pax_global_header00006660000000000000000000000064152251153420014512gustar00rootroot0000000000000052 comment=0bb16a1fa07c9ac8b35d89211e60b03d27d5199e libtest-nginx-perl-0.32/000077500000000000000000000000001522511534200151655ustar00rootroot00000000000000libtest-nginx-perl-0.32/Changes000066400000000000000000001154631522511534200164720ustar00rootroot00000000000000Changes for Test::Nginx 0.32 - 2026-03-03 * bugfix: address incorrect HTTP/2 configuration. * bugfix: dynamically set the proxy_temp_path. * bugfix: fixed warning introduced by commit c3e96f. * bugfix: put load_module directives before the stream block. * doc: update copyright. * docs: Add the missing version number. * feature: add --- no_mockeagain. * feature: add --- tcp_query_auto_timeout for unknow input length. * feature: add TEST_NGINX_LD_PRELOAD. * feature: add stream listen option like reuseport or proxy_protocol. * optimize: throw warning message if enable the mockeagain without poll event type. 0.31 - 2025-04-03 * bugfix: check the rand port with bind(). thanks lijunlong for the patch. * bugfix: Add the default config base on the nginx -V. This is a commit after 3f15aea4. thanks lijunlong for the patch. * bugfix: should not include cgi related configs by default. The cgi related features may not build into the nginx binary. thanks lijunlong for the patch. * feature: allow to perform unprivileged tests. thanks BalkanMadman for the patch. * optimize: use 'http2 on for nginx>1.25.3.' thanks lijunlong for the patch. * change: get pcre version from 'Nginx -V'. thanks lijunlong for the patch. * change: get pcre version from the linking library of nginx. thanks lijunlong for the patch. * fix: enable ngx.location.capture API test in http2. thanks Jun Ouyang for the patch. * bugfix: use rename to ensure atomicity of write operations in TCP/UDP server. thanks Johnny Wang for the patch. * bugfix: failed to validate no_shutdown_error_log. thanks lijunlong for the patch. * bugfix: should allow the underscore in the test filename. thanks lijunlong for the patch. * feature: add test case name to asan log_path. thanks lijunlong for the patch. * feature: add new enviroment variable TEST_NGINX_VALGRIND_EXIT_ON_FIRST_ERR. thanks lijunlong for the patch. * doc: typo wo -> we. thanks Johnny Wang for the patch. * feature: added new section --- post_setup_server_root. thanks leslie for the patch. * fixed a use of undef value introduced in the previous commit. thanks Yichun Zhang (agentzh) for the patch. * feature: added new section --- write_resp_body_file. thanks Yichun Zhang (agentzh) for the patch. * feature: make the valgrind exit on the first error. thanks lijunlong for the patch. * feature: expand env vars in udp_listen, error_log_file, pipelined_requests. thanks Johnny Wang for the patch. * feature: add --- suppress_stderr to silent error messages on nginx startup. Useful with must_die block. thanks Jiří Setnička for the patch. * change: adjust http3 test for the latest change in nginx 1.25. thanks lijunlong for the patch. * feature: support pcre2. thanks swananan for the patch. * bugfix: handle openresty+ server name as well. thanks Yichun Zhang (agentzh) for the patch. * bugfix: ensure cache dir is removed before cleanup. thanks leslie for the patch. * feature: now we expand env vars in --- grep_error_log_out texts as well. thanks lijunlong for the patch. * feature: now we expand env vars in --- response_body texts as well. thanks Yichun Zhang (agentzh) for the patch. * feature: add a builtin filter for json response. thanks lijunlong for the patch. * feat(Valgrind): show full backtrace for lib loaded by Lua C API. thanks 罗泽轩 for the patch. * feature: export new API add_test_cleanup_handler. thanks lijunlong for the patch. * CPAN: fixed the forgotten version number update in Socket/Lua/Stream.pm. thanks Johnny Wang for the patch. 0.30 - 2022-05-13 * bugfix: reserved ports for stream_server_config. * feature: expanded environment values in --- tcp_listen section. * bugfix: user name with dash was not allowed, eg like 'www-data'. thanks lijunlong for the patch. * bugfix: there can be trailing spaces in HTTP 0.9. * feature: add TEST_NGINX_FAST_SHUTDOWN to stop Nginx without graceful. thanks spacewander for the patch. * bugfix: supported to parse http trailer in response body. thanks Yuansheng for the patch. * change: quic use keepalive_timeout instead of quic_max_idle_timeout now. thanks lijunlong for the patch. * bugfix: did not skip test cases that proxy_pass or directly connect to request server port. thanks lijunlong for the patch. * bugfix: should not change config line number for old test cases. thanks lijunlong for the patch. * bugfix: curl request was sent before nginx startup when running in valgrind mode. thanks lijunlong for the patch. * bugifx: waitpid failed when the process is not subprocess of perl. thanks lijunlong for the patch. * bugfix: nginx reload hangs when http3 is enabled. thanks lijunlong for the patch. * feature: support HTTP/3 testing. thanks lijunlong for the patch. * feature: added new section "--- no_access_log" which could be used to specify patterns of lines that do not appear in access.log at all. thanks levy001 for the patch. * bugfix: allow capture OpenSSL version without letter. thanks Wangchong Zhou for the patch. * feature: check if grep_error_log is defined when grep_error_log_out exists. thanks spacewander for the patch. * feature: add '--- curl_options' and '--- curl_protocol' section. thanks woodgear for the patch. * feature: added file name to name of the test case. thanks lijunlong for the patch. * feature: support FIRST to mark the beginning of test. thanks spacewander for the patch. * bugfix: perl did not exit when kill process with SIGKILL. thanks lijunlong for the patch. 0.29 - 2020-11-06 * bugfix: check leak mode: use much larger number of requests for ab/weighttp to make sure we always have the load even for large TEST_NGINX_CHECK_LEAK_COUNT values. * feature: added TEST_NGINX_RAND_PORT_XXX variable to provide random ports during environment variable expansion. thanks Johnny for the patch. * bugfix: log correct server address when server_addr_for_client section is used. thanks Patrick Thiel for the patch. 0.28 - 2020-07-13 * bugfix: we downgraded the bundled version of Test::Builder to avoid the extra dependency Test2::Util. 0.27 - 2020-07-02 * feature: added the --- reload_fails new section to skip checking config_version after HUP reload in the HUp reload testing mode. * feature: added a "--- gen_dgram_request" section. * feature: relaxed the Server response header parsing pattern for extracting the nginx core verison number. * bugfix: when --- reload_fails is specified, we did not assume --- no_chck_leak since it would always fail in the check leak testing mode. * feature: implemented the `--- shutdown_error_log` section for checking the error logs generated during nginx exit. * feature: added new test mode enabled by the env TEST_NGINX_USE_HTTP2=1 and new section "--- http2", for enabling the HTTP/2 protocol to send the test request. * bugfix: when TEST_NGINX_USE_STAP=1 env was specified, the master process would be turned off when for test blocks without actually using --- stap. * feature: be more patient to wait for the nginx to start up in profiling and "check leak" test mode. * optimize: use perl's own remove_tree() instead of the shell command 'rm -rf' since the latter may use too much memory. * feature: added support for the env TEST_NGINX_CHECK_LEAK_COUNT to control how many data points to sample in the "check leak" test mode. * feature: now we pass through the MOCKNOEAGAIN_VERBOSE and MOCKNOEAGAIN env to the nginx worker processes by default as well. * feature: added support for TEST_NGINX_WORKER_USER env for setting the user account (and user group) for nginx worker processes; defaults to root when the master is run by root. * bugfix: the value of env TEST_NGINX_WORKER_USER did not accept a single user name (without a user group name). * feature: added support for the --- access_log section for checking access log file content. * bugfix: valgrind test mode: we no longer disable nginx master process in this mode. * bugfix: we did not clean up nginx's *_cache directories under the server root directory. * feature: added support for environment variable TEST_NGINX_REUSE_PORT for enabling the reuseport parameter in the listen directive automatically generated in nginx.conf. * feature: we now check for the new "write guard" warning message to detect misuses of lua globals. * feature: added the use_hup() Perl utility function. * feature: when --- no_error_log fails, we output up to 9 lines of subsequent error log messages for better debuggability (for example, wen can have complete lua backtraces). * feature: expanded environment values in --- user_files section. * bugfix: when setting TEST_NGINX_USE_HUP=1, some directories could not be cleaned up correctly. * feature: implemented the TEST_NGINX_USE_RR=1 env for enabling Mozilla rr to record the nginx server execution. * bugfix: increased resiliency in HUP reload mode. * feature: added the '--- skip_openssl' section to skip tests depending on the OpenSSL version NGINX was built with. * bugfix: ensured we do not remove some files when using HUP mode. * bugfix: properly use a concat operator instead of a range. * bugfix: ensure servroot is cleaned up when starting NGINX for the first time. 0.26 - 2017-04-09 * feature: added new Test::Nginx::Socket::Lua::Dgram module for testing UDP/datagram nginx servers. * feature: added new section, `--- response_body_filters`, to allow custom value filters applied upon the *actual* response body data before matching against the expected values. thanks detailyang for the patch. * feature: added support for env TEST_NGINX_RANDOMIZE, which when set allows parallel testing. * feature: added support for the `$TEST_NGINX_SERVER_ROOT` special macro variable in test block specs. * feature: allows extracting nginx version numbers from more forked versions of nginx. * feature: support the "SKIP" section dynamically defined by subclasses of the test scaffold calsses. * feature: `--- tcp_reply` section: allows perl subroutines as section values. thanks Robert Paprocki for the patch. * bugfix: fixed the TEST_NGINX_BINARY environment for specifying nginx binary path. thanks Thibault Charbonnier for the patch. * bugfix: ensure that kill_process() still kills the process with force if the process is still running after sending SIGQUIT. * improve: improved the nginx shut down logic. thanks Dejiang Zhu for the suggestion. * improve: improved the test message for ARRAY-typed "response_body" section values. * improve: improved the dry run skip message for no_error_log. * doc: typo fixes from Juntong Fu. 0.25 - 2016-02-24 * feature: added the new test mdoule, Test::Nginx::Socket::Lua::Stream, for testing stream-typed NGINX C modules like ngx_stream_echo_module and ngx_stream_lua_module. * feature: added new section "--- server_addr_for_client" to control the value of server_addr for client. thanks Guanlan Dai for the patch. * feature: added support for the TEST_NGINX_LOAD_MODULES environment for loading dynamic NGINX modules in nginx.conf globally. * feature: added support for ASAN by passing ASAN_OPTIONS environment variable. thanks Markus Linnala for the patch. * feature: Test::Nginx::Socket::Lua: added support for the init_by_lua_block {} directive of ngx_http_lua_module. * feature: avoided variations in the absolute line numbers of user configurations so that the test cases can check nginx configuration file line numbers deterministically. * feature: implemented the env_to_nginx() Perl utility function as per Rollin Crittendon's request. for example: env_to_nginx('foo', 'bar=hello world') * feature: now we pass the environment DYLD_FORCE_FLAT_NAMESPACE to the nginx by default as well. * feature: implemented the "--- todo" section for TODOing test blocks. thanks Markus Linnala for the patch. * feature: repeat_each() also returns the value even when it is used as a setter. * bugfix: testing could not continue properly when the "--- must_die" subtest failed. * bugfix: ARRAY-typed "--- more_headers" now work with ARRAY-typed "--- request". thanks Kipras Mancevičius for the report. * bugfix: fixed the perl warning "Use of uninitialized value $val in concatenation" when "--- more_headers" has headers without values. * bugfix: use SIGTERM to kill non-responsive nginx/valgrind processes instead of SIGQUIT; otherwise the perl test process may hang forever in valgrind testing mode. * bugfix: only complain about failures of removing the nginx pid file when it still exists. * bugfix: we should bail out when `nginx -V` returns anything that we cannot understand. * bugfix: builtin udp server: fixed recv() call's error handling. * bugfix: we did not expand environments TEST_NGINX_XXX in the "--- main_config" and "--- post_main_config" data sections. * bugfix: better error handling in the mocked UDP server. * change: changed the default value of TEST_NGINX_SLEEP to 0.015 (sec). thanks Dejiang Zhu for the patch. * improvement: output the system error message when failing to remove the nginx pid file. * improvement: made the error_log test failure message clearer. thanks Nick Muerdter for the patch. * doc: fixed the module description of Test::Nginx and Test::Nginx::Socket to reflect recent changes. * doc: now we highly recommend Test::Nginx::Socket and its subclasses. * doc: documentged the default timeout value used by the client. thanks Nick Muerdter for the patch. * doc: added a link to the official user guide in the book "Programming OpenResty". 0.24 - 2014-12-07 * feature: added support for the "benchmark" testing mode enabled by the TEST_NGINX_BENCHMARK environment variable. * feature: added support for the TEST_NGINX_BENCHMARK_WARMUP environment to specify the number of warm-up requests before the actual benchmark testing. * feature: added support for the "--- curl" section that generates a "curl" command line for the corresponding test request. * feature: added new section "--- server_name" to control the value of the server_name nginx config directive used for the default server {}. * feature: added new section "--- error_log_file". * feature: automatically print out warnings for [emerg] messages in nginx's error.log to stderr if it is not mentioned in "--- error_log" nor "--- no_error_log". * feature: Test::Nginx::Socket: "--- request" now supports leading comment lines prefixed by "#". * feature: the "--- user_files" section supports raw Perl data structures for specifying the user files. * feature: the "--- more_headers" section now supports perl array-ref typed values for pipelined requests. * feature: exported the "add_response_body_check" and "is_str" utility functions. * feature: the "--- udp_reply" section now accepts a Perl subroutine as its value which can be used to generate dynamic replies based on the actual query. thanks blablacio for the original patch. * feature: Test::Nginx::Socket: exported new Perl utility functions "add_cleanup_handler", "add_block_preprocessor", and "bail_out". * feature: made the special $LIBxxx_PATH variable more general in the "--- stap" section. * feature: the "--- no_error_log" section now tries to find all the matched lines in error logs instead of stopping on the first hit. * feature: added new section "--- tcp_shutdown" for shutting down read, write, or both parts of the connection in the embedded TCP server immedately after the connection is established. * feature: the value of "--- tcp_query_len" now defaults to the lenghth of the value of "--- tcp_query" (if any). * feature: added new section "--- must_die" for testing the cases that nginx fail to start (like invalid nginx configurations and etc). thanks Markus Linnala for the patch. * bugfix: when user specifies "Host" and "Connection" in "--- more_headers", then we should not add our own Host request headers. * bugfix: made the default value of the "Connection" request header to be "close" instead of "Close". * bugfix: the "check leak" testing mode might send a bogus request header via ab or weighttp. * bugfix: we should also wait for the time specified by the "--- abort" section before checking error logs for the repeated requests that are not the last one. * optimize disabled accept_mutex by default in the auto-generated nginx.conf. * bugfix: "--- skip_nginx" and "--- skip_nginx2" did not skip tests related to the mocked TCP and UDP servers. * bugfix: we did not automatically remove the .stp and .stp-out temp files created by the "--- stap" sections in the systemtap testing mode. * bugfix: "--- request" did not provide the guilty request line that it failed to parse. * bugfix: Test::Nginx::Socket: "--- error_code" might take bad values. * bugfix: we incorrectly discarded all the query data read in the mocked TCP server when timeout errors happen (due to the actual query is shorter than the expected data specified "--- tcp_query", for example). * bugfix: the "check leak" testing mode could not parse raw HTTP requests using LF instead of CRLF for line terminators. * doc: documented the section "--- init". * doc: added info for the openresty and openresty-en mailing lists for discussions. * doc: spelling fixes from Markus Linnala. 0.23 - 2014-04-05 * feature: added new section --- response_body_unlike. thanks Rickey Visinski for the patch. * feature: allow use of the $ServerPort and $ServerPortForClient variables in "--- response_headers". * feature: now we automatically kill the process listening on the mocked TCP port when we have tried for more than 20 times. * feature: added new section "--- http09" to Test::Nginx::Socket to indicate use of HTTP 0.9 requests. * feature: added support for the $LIBLUA_PATH variable in "--- stap", which evaluates to the absolute path of the liblua*.so DSO loaded by the nginx server. * feature: we skipped reading the response body for 101 responses. * feature: added new section "--- post_main_config" to add custom top-level configuration snippets right after the http {} block generated by Test::Nginx. * feature: added unix domain socket support for tcp_listen. thanks Jiale Zhi for the patch. * feature: added new sections "--- grep_error_log" and "--- grep_error_log_out". * feature: added utility function check_accum_error_log for checking the accumulated error logs in "--- error_log" and "--- no_error_log". * feature: added utility Perl function server_port_for_client. thanks doujiang for the patch. * feature: added configuration Perl function server_name(). thanks doujiang for the original patch. * feature: added new module Test::Nginx::Socket::Lua. * feature: automatically test if there is any assertion failures in the nginx error logs. * feature: when nginx process is gone unexpectedly, we automatically tail the nginx error log file. * feature: added the "--- no_check_leak" section to skip test blocks in the "check leak" testing mode. * feature: "--- no_error_log" accepts a single Perl Regexp object now, just like "--- error_log". * bugfix: Test::Nginx::Socket tried to read response bodies for 304 responses. * bugfix: we did not try hard enough before killing the nginx process by force. * bugfix: improved the error handling when recv() fails on the HTTP connection. * bugfix: subtests for "--- tcp_query", "--- tcp_query_len", and "--- udp_query" disabled test plan checks. * bugfix: we did not pass the LD_LIBRARY_PATH environment to nginx when systemtap is used. * bugfix: "--- error_log" should work on each test request's own logs only. * bugfix: server address should default to 127.0.0.1 instead of "localhost". * bugfix: made the test skip messages better. * change: removed "env LUA_PATH" and "env LUA_CPATH" from the default nginx configuration generated. * change: set --num-callers=100 to valgrind by default. * doc: Test::Nginx::Socket: documented the various exported Perl functions like "run_tests", "repeat_each", and "no_shuffle". 0.22 - 2013-06-10 * feature: added new sections --- abort and --- shutdown to test premature client abortions. * feature: implemented new section "--- raw_response_headers_unlike". * feature: added support for custom http_config filters for subclasses. * feature: now we automatically check [alert] and [crit] messages in the nginx error logs and print them as warnings if they do not appear in either --- error_log or --- no_error_log. * feature: added new section "--- stap_out_unlike" for testing patterns which should not appear in the output systemtap. * feature: added support for the special notation "$LIBPCRE_PATH" within --- stap, which is always substituted by the absolute path to libpcre used by the current nginx. * feature: now we check if the nginx process is gone in the "check leak" testing mode (i.e., when TEST_NGINX_CHECK_LEAK=1). * feature: added new section "--- skip_eval: " for skipping tests according to the running result of a piece of Perl code. * feature: now we allow a (unix domain) socket file path specified in the "--- udp_listen" directive value. * feature: in --- stap values, now we support the notation "F(func@file)". * feature: made the environment TEST_NGINX_SERVER_PORT always take the value so that the test cases can always reference it. * feature: added new section "--- wait" to always wait a specified amount of time before checking the systemtap outputs and/or error logs (if any). * bugfix: no longer retry connecting to the nginx server when the child process running nginx is already gone. * bugfix: no longer bail out the up to 3 test cases fail all their connecting attempts. * bugfix: TEST_NGINX_USE_HUP=1 could not work with TEST_NGINX_NO_CLEAN=1. * bugfix: the output of systemtap took the value undef when it was in fact empty. * bugfix: protect against division by zero in the "check leak" testing mode. * bugfix: disabled the test report ending when failing to parse chunked response body because the test count is surely out of sync. * bugfix: the code that searches executables in the PATH environment would always look up the current working directory first and might pick up an executable directory with the same name. * bugfix: conflicting testing modes may conflict together. * bugfix: added File::Path 2.06_05 as a minimum requirement. thanks Andreas J. König for reporting this issue. * bugfix: pass --show-possibly-lost=no to valgrind by default because nginx makes clever use of pointers almost everywhere. * bugfix: when --- abort was not specified, http client timeout was not treated as a subtest failure as specified. * bugfix: the child process running ab or weighttp might not be reaped in extreme conditions. * bugfix: we did not close STDOUT and STDERR in the child processes forked, which could confuse the "prove" harness and lead to hang. * optimize: disabled the access log altogether in the "check leak" testing mode. * docs: documented the TEST_NGINX_NO_CLEAN environment. * docs: fixed a small issue in the code sample. thanks smallfish. 0.21 - 2012-09-27 * feature: added support for SystemTap: the SystemTap white-box testing mode is enabled by setting TEST_NGINX_USE_STAP=1 and by using new test sections "--- stap", "--- stap_out", and "--- stap_out_like". * feature: added support for new sections "--- udp_listen" and "--- udp_reply" for mocking an internal UDP server. * feature: added new section "--- udp_reply_delay" and also make "--- udp_reply_delay" and "--- timeout" sections accept time values with a time unit which can be either "s" or "ms". * feature: added new section "--- udp_query" to test if the UDP query sent to the embeded UDP server is expected. * feature: added new section "--- tcp_query_len" to work with mockeagain testing modes. * feature: added support for embedded TCP server by introducing new sections "--- tcp_listen", "--- tcp_query", "--- tcp_reply", and "--- tcp_reply_delay". * feature: added new section "--- tcp_no_close" to tell the embedded TCP server (if any) never close the connection actively. this is feature is mainly for mocking upstream reply read time out in the middle. * feature: added new section "--- log_level" to specify the error log level on a test-by-test basis. * bugfix: we might lose logs at config-time when TEST_NGINX_USE_HUP=1 because we sent HUP before USR1. * bugfix: be more tolarent when removing the nginx pid file while the nginx process is not running. * optimize: now we can automatically check the version of the current nginx configuration and retry dozens of times when TEST_NGINX_USE_HUP=1. this speed up the test suite in this mode a lot and also avoid accidental failures due to slow nginx reloads. * bugfix: try harder when failing to connect to the Nginx server. * refactor: now we use the standard "return" directive instead of "echo" for detecting nginx config reload completion for the "HUP reload" testing mode. * refactor: use waitpid() wherever possible. * bugfix: Parallel::ForkManager does not allow the user calling waitpid directly, or inifinite looping might happen when calling its start() method. now we no longer use this module any more and use the fork() builtin function exclusively. * bugfix: disabled the ending output "Looks like you ..." when the client socket timed out. * refactor: now we disabled the access log by default. * updated the bundled versions of Test::Builder and Test::More modules. * docs: documented the "--- skip_nginx" and "--- skip_nginx2" sections. thanks Weibin Yao for requesting it. 0.20 - 2012-06-25 * feature: now "--- error_log" allows a single regexp object as its value. * feature: made client socket timeout as a test failure. * feature: added support for the environment TEST_NGINX_CHECK_LEAK=1 that enables the most general memory leak check by calling ab/weighttp + ps (for the nginx process's RSS). * feature: when the TEST_NGINX_USE_HUP environment is set to true, then HUP signal will be used to update the nginx config between different test blocks and there will be no HUP reload between every two successive test cases within the same test block when "repeat_each" is set to a number more than 1. * bugfix: fixed the TEST_NGINX_SLEEP environment support. * bugfix: we should always restore user files before each "repeat_each" iteration because some test case may modify the user files. * bugfix: setting environment TEST_NGINX_USE_HUP could not work with TEST_NGINX_USE_VALGRIND=1 properly. * bugfix: print out every test block's name when TEST_NGINX_USE_HUP=1 and TEST_NGINX_USE_VALGRIND=1. * bugfix: the "response body truncated" warning was a false alarm for HEAD requests. thanks Piotr Sikora for reporting this in github issue #1. * bugfix: do not add --gen-suppressions and --suppressions options to the valgrind command line when custom non-number TEST_NGINX_USE_VALGRIND env value is specified. * docs: documented the "--- timeout" section. * docs: added a link to António P. P. Almeida's debian package for this module. 0.19 - 2012-04-29 * feature: added new section "--- error_code_like". * bugfix: tests could hang on slow machines after maximal number of connecting attempts (as well as other exceptions). Now we eliminate dying directly from within the test scaffold. Instead, we always use Test::More::BAIL_OUT. Also, we always politely clean up all the forked child processes before we quit. Finally, we add timeout protection to the connect operation. * bugfix: prevented blocking indefinitely on ForkManager's wait_all_children call. also made timeout an API provided by Test::Nginx::Util. * feature: now we preserve environment "MOCKEAGAIN" as well. * bugfix: the timestamps for the "--- user_files" directive should be GMT rather than localtime. * feature: now section "no_error_log" also supports multi-line values to mean multiple literal patterns (per line). * feature: the "--- user_files" sections now support absolute file paths and creating arbitrarily nested directories in the file path. thanks @penjin2012 for suggesting it. * feature: the "--- error_log" section now supports multiple lines to mean multiple literal patterns. * bugfix: fixed places that crash for bad responses. * bugfix: fixed another crash when no response object is constructed. 0.18 - 2012-02-03 * feature: added new section "--- no_error_log" which could be used to specify patterns of lines that do not appear in error.log at all. * feature: added MOCKEAGAIN_VERBOSE, DYLD_INSERT_LIBRARIES, MOCKEAGAIN_WRITE_TIMEOUT_PATTERN, and LD_PRELOAD to the environments that should be kept through nginx reload and restart. * doc: added Naxsi and ngx_rds_csv to the user module list in the POD documentation. * feature: now we can use the environment TEST_NGINX_USE_VALGRIND to specify the valgrind command-line options, when set to 1 or other non-zero numbers, it is effectively equivalent to the value "--tool=memcheck --leak-check=full". To use Valgrind SGCheck to run the tests, just specify the environment TEST_NGINX_USE_VALGRIND="--tool=exp-sgcheck" first. * feature: added support for environment TEST_NGINX_VERBOSE. * feature: added support for environment TEST_NGINX_USE_HUP. * feature: added support for the TEST_NGINX_POSTPONE_OUTPUT environment. * feature: now we'll retry sending the QUIT signal for at most 5 times when the nginx process is refusing to quit. after 5 trials, KILL signal will be sent. * feature: exposes the "master_off" API which turns off the nginx master process. * feature: added new section "--- ignore_response" to test bad responses. * bugfix: Test::Nginx::Socket will retry 10 times if fail to connect because nginx with valgrind can be very slow to start in some systems. * feature: added new section name "--- error_log" to test error lines. requested by Piotr Sikora in the last year or so. * feature: added the TEST_NGINX_EVENT_TYPE environment to specify an event API type (like "epoll" or "select") when running the test suite. 0.17 - 2011-11-04 * bugfix: do not strip trailing CRCF for response headers in Test::Nginx::Socket's response parser. * bugfix: fixed issues in Content-Length response header handling in case of pipelined reqeusts. * bugfix: fixed the pipelined_requests section support. * feature: added support for user file timestamp. 0.16 - 2011-07-07 * fixed a bug that length(undef) produced lots of warnings on perl 5.10.x. thanks Guo Ying (shrimp). * now we automatically retry connecting for 3 times (1 sec delay) in Test::Nginx::Socket::send_request. this will help automatically recovering from random slow valgrind loading problems. * when the directories specified in --- user_files do not exist, Test::Nginx will create it automatically. * now we'll issue warning when there is extra bytes after the last chunk in the chunked response parser. 0.15 - 2011-05-23 * fixed a bug when using arrays in the "response_body" (and other similar) section when there was only one request. * fixed presentation problems in the HTML generated from the POD. * added documentation for the TEST_NGINX_* variables. * added "local $?" in Test::Nginx::Util::END to avoid confusing Test::Builder::_ending() * removed "use Test::More" from Test::Nginx::Socket because Test::Base already loads it. 0.14 - 2011-05-12 * now we require Parallel::ForkManager, Text::Diff, and Test::Base. * the --- request section now supports multiple requests and even "packeting" (see documentation for details). And it should be backward compatible. Of course, the "expected" sections have been upgraded to expect (and even require) arrays in this situation. * updated quite a bit the documentation. * deprecated request_eval and response_body_eval. If you use them, the test will pass but you will be issued a "diag" statement telling you to move to "request eval" and "response_body eval" respectively. * added new implementation for pipelined requests and raw requests. Rewrote SKIP statement to be less verbose and more in line with what is recommended on Test::Nginx. * added support for environment variable TEST_NGINX_FORCE_RESTART_ON_TEST. Defaults to 1. Must be explicitly set to 0 to avoid restarting the nginx server when the config does not change between two tests. This also brings support for allowing config not to be set. This way, using TEST_NGINX_FORCE_RESTART_ON_TEST=1 with TEST_NGINX_NO_SHUFFLE=1 and having a config section only on the first test, you can have all tests use the same config. * added support for environment variable TEST_NGINX_NO_NGINX_MANAGER (defaults to 0) which will disable the nginx management code (stop/config/start). Very useful when you want to run tests on an already running NGINX (set TEST_NGINX_NO_NGINX_MANAGER to 1 and TEST_NGINX_CLIENT_PORT to the port your running nginx is listening on). 0.13 - 2011-03-08 * documented the TEST_NGINX_PORT environment. 0.12 - 2011-03-08 * documented the etcproxy and valgrind integration support. * implemented the no_nginx_manager utility function * documented the difference between Test::Nginx::Socket and Test::Nginx::LWP. * allow numbers in TEST_NGINX_BLAH_BLAH_BLAH env names. * added support for --- raw_response_headers_like. * fixed a bug in the can_run sub. 0.11 - 2010-10-09 * add TEST_NGINX_BUILDSLAVE and --- skip_slave. * implemented the TEST_NGINX_IGNORE_MISSING_DIRECTIVES which can force test cases to skip when the directive is not found in the current nginx. * added support for env TEST_NGINX_TIMEOUT. * implemented TEST_NGINX_XXX env expansion in --- config and --- http_config sections. 0.10 - 2010-08-19 * we use our own can_run function rather than Module::Install::Can's. * added TEST_NGINX_MASTER_PROCESS, rename TEST_NGINX_ROOT to less confusing TEST_NGINX_SERVROOT and reorder priority of TEST_NGINX_{CLIENT_,SERVER_,}PORT environment options. (Piotr Sikora) * added support for TEST_NGINX_NO_SHUFFLE env as requested by Piotr Sikora :) * added support for TEST_NGINX_LOG_LEVEL env but it can be overriden on the script level by calling the log_level function. * added support for TEST_NGINX_ERROR_LOG: if this env is specified to some file path, then all the error log by all the test cases will be accumulated to that file. * Now the test script driven by Test::Nginx will tell nginx to quit by default. The TEST_NGINX_NO_CLEAN=1 env setting will give back the old behavior :) Thanks Piotr Sikora for requesting this. * added support for --- main_config. * Make Test::Nginx more friendly to the environment (Piotr Sikora) Added environment variables: TEST_NGINX_BINARY - full path to the nginx binary, TEST_NGINX_ROOT - path where server root should be created, TEST_NGINX_PORT - port number that should be used by client and server (takes precedence over _CLIENT_PORT and _SERVER_PORT), TEST_NGINX_SERVER_PORT - port number that should be used by the server. * add environment variable TEST_NGINX_SLEEP * added support for ngx_openresty in nginx version parser. 0.09 - Wed 07 Jul 2010 02:57:13 PM CST * added new section --- user_files which will create user files under html/. * applied the patch from Piotr Sikora to add the --- skip_nginx2 directive. * use the latest nginx version as the default if the version number can not be parsed from "nginx -V". * added support for ! HEADER syntax to --- response_headers such that we can test if a response header exists. * fixed some bugs in --- response_headers. * now TEST_NGINX_USE_VALGRIND=1 works out of the box. one can ualso use test/valgrind.suppress file to serve as a default suppression file. * better diagnostics for socket timeout outputs. * added support for the --- charset section. * use localhost as the server_name in the test nginx.conf. * added support for the server_addr sub as well as the TEST_NGINX_CLIENT_PORT environment. * always use Time::HiRes's sleep. this issue was reported by leicheng++. * added new config function no_root_location as well as the new section --- init. 0.08 - Tue 26 Jan 2010 12:20:03 PM CST * fixed a bug in the chunked parser in Test::Nginx::Socket: now we immediately stop reading more data chunks when seeing the last chunk. * added func no_long_string to Test::Nginx::Socket and Test::Nginx::LWP so that we can disable Test::LongString in the test scaffold. * added utility config functions "workers", "log_level", and "master_on" to Test::Nginx::Socket. * added ngx_rds_json and ngx_xss modules to the module list that uses Test::Nginx::Socket. 0.07 - Tue 05 Jan 2010 10:06:56 AM CST * we now use IO::Select in Test::Nginx::Socket to save CPU resources while polling the non-blocking socket. * POD: added ngx_drizzle to the module list that use Test::Nginx::Socket. * added utility config functions "worker_connections" and "master_process_enabled". 0.06 - Thu 24 Dec 2009 10:59:29 AM CST * we now disable the nginx daemon mode in the config file by default. * we now generate a default index.html page under the root /. * added support for the new --- http_config section so that you can put upstream foo { ... } in it. 0.05 - Tue 22 Dec 2009 10:17:44 AM CST * added support for gcc profiling via the $Nginx::Util::Profiling variable. * fixed the chunked decoder for large chunks. 0.04 - Fri 18 Dec 2009 04:09:02 PM CST * added new sections --- raw_request and --- raw_request_middle_delay to Test::Nginx::Socket. * added new functions config_preamble and repeat which are exported by default. 0.03 - Tue 15 Dec 2009 11:35:07 AM CST - refactored a lot of duplicate code between Test::Nginx::LWP and Test::Nginx::Socket to a separate module named Test::Nginx::Util. - now Test::Nginx::Socket also restart the nginx server at every test case run. - added support for --- request_eval and --- response_eval to Test::Nginx::Socket. 0.02 - Wed 09 Dec 2009 09:50:11 AM CST - skipped the POD coverage tests for now. 0.01 - Tue 08 Dec 2009 11:07:51 AM CST - initial release. libtest-nginx-perl-0.32/MANIFEST000066400000000000000000000015521522511534200163210ustar00rootroot00000000000000lib/Test/Nginx.pm lib/Test/Nginx/LWP.pm lib/Test/Nginx/Socket.pm lib/Test/Nginx/Util.pm Makefile.PL MANIFEST This list of files MANIFEST.SKIP README.md t/syntax.t Changes inc/Module/AutoInstall.pm inc/Module/Install.pm inc/Module/Install/AutoInstall.pm inc/Module/Install/Base.pm inc/Module/Install/Can.pm inc/Module/Install/Fetch.pm inc/Module/Install/Include.pm inc/Module/Install/Makefile.pm inc/Module/Install/Metadata.pm inc/Module/Install/TestBase.pm inc/Module/Install/Win32.pm inc/Module/Install/WriteAll.pm inc/Spiffy.pm inc/Test/Base.pm inc/Test/Base/Filter.pm inc/Test/Builder.pm inc/Test/Builder/Module.pm inc/Test/More.pm META.yml t/pod-coverage.t t/pod.t t/apply_moves.t t/get_req_from_block.t t/parse_request.t t/check_response_body.t t/resp_body_filters.t lib/Test/Nginx/Socket/Lua.pm lib/Test/Nginx/Socket/Lua/Stream.pm lib/Test/Nginx/Socket/Lua/Dgram.pm libtest-nginx-perl-0.32/MANIFEST.SKIP000066400000000000000000000006661522511534200170730ustar00rootroot00000000000000[^/]+\.png$ [^/]+\.dot$ [^/]+\.tmp$ fast.*\.yml$ ^a\.yml$ ^baz\.yml$ ^t/me\.dot$ ^t/ppi\.png$ ^Makefile$ ^t/slow\.pl$ ^bin/\. ~$ \.old$ \.bak$ ^cover_db .git .gitignore ^backup bin/.*\.dat ^t/cover- \.tar\.gz$ preload\.yml \.swp$ diffall submitall testall update ^\.rsync$ genmobi\.sh$ \.mobi$ .*\.tar$ ^MYMETA\.\w+$ ^tags$ ^html_out \.diff$ \.patch$ \.tags$ \.sh$ \.pdf$ ^\.travis\.yml$ ^go$ \.t_$ \.ps$ t/servroot/ ^valgrind\.suppress$ libtest-nginx-perl-0.32/META.yml000066400000000000000000000020161522511534200164350ustar00rootroot00000000000000--- abstract: 'Data-driven test scaffold for Nginx C module and Nginx/OpenResty-based libraries and applications' author: - 'Yichun Zhang (agentzh) C<< >>, OpenResty Inc.' build_requires: ExtUtils::MakeMaker: 6.59 configure_requires: ExtUtils::MakeMaker: 6.59 distribution_type: module dynamic_config: 1 generated_by: 'Module::Install version 1.21' license: bsd meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Test-Nginx no_index: directory: - inc - t requires: Encode: 0 Fcntl: 0 File::Find: 0 File::Path: 0 File::Temp: 0 Filter::Util::Call: 0 HTTP::Response: 0 IO::Select: 0 IO::Socket: 0 IO::Socket::INET: 0 IPC::Run: 0 LWP::UserAgent: 0 List::MoreUtils: 0 List::Util: 0 POSIX: 0 Test::Base: 0 Test::LongString: 0 Text::Diff: 0 Time::HiRes: 0 URI::Escape: 0 perl: 5.10.1 resources: license: http://opensource.org/licenses/bsd-license.php repository: https://github.com/openresty/test-nginx version: '0.32' libtest-nginx-perl-0.32/Makefile.PL000066400000000000000000000016451522511534200171450ustar00rootroot00000000000000use strict; use lib '.'; use inc::Module::Install; name ('Test-Nginx'); license ('bsd'); perl_version ('5.010001'); repository ('https://github.com/openresty/test-nginx'); all_from ('lib/Test/Nginx.pm'); requires ('Test::Base'); requires ('Text::Diff'); requires ('Test::LongString'); requires ('IO::Socket'); requires ('Time::HiRes'); requires ('LWP::UserAgent'); requires ('HTTP::Response'); requires ('Fcntl'); requires ('POSIX'); requires ('IPC::Run'); requires ('URI::Escape'); requires ('IO::Select'); requires ('File::Path'); requires ('File::Temp'); requires ('List::MoreUtils'); requires ('List::Util'); requires ('Encode'); requires ('File::Find'); requires ('IO::Socket::INET'); use_test_base(); auto_install(); #tests('t/*.t t/*/*.t'); WriteAll(); libtest-nginx-perl-0.32/README.md000066400000000000000000000204621522511534200164500ustar00rootroot00000000000000# NAME Test::Nginx - Data-driven test scaffold for Nginx C module and Nginx/OpenResty-based libraries and applications # Table of Contents * [NAME](#name) * [DESCRIPTION](#description) * [User Guide](#user-guide) * [Nginx C modules that use Test::Nginx to drive their test suites](#nginx-c-modules-that-use-testnginx-to-drive-their-test-suites) * [INSTALLATION](#installation) * [SOURCE REPOSITORY](#source-repository) * [DEBIAN PACKAGES](#debian-packages) * [Community](#community) * [English Mailing List](#english-mailing-list) * [Chinese Mailing List](#chinese-mailing-list) * [AUTHORS](#authors) * [COPYRIGHT & LICENSE](#copyright--license) * [SEE ALSO](#see-also) # DESCRIPTION This distribution provides two testing modules for Nginx C module development: - [Test::Nginx::Socket](https://metacpan.org/pod/Test%3A%3ANginx%3A%3ASocket) (This is highly recommended.) This library also has the following subclasses: - [Test::Nginx::Socket::Lua](https://metacpan.org/pod/Test%3A%3ANginx%3A%3ASocket%3A%3ALua) - [Test::Nginx::Socket::Lua::Stream](https://metacpan.org/pod/Test%3A%3ANginx%3A%3ASocket%3A%3ALua%3A%3AStream) - [Test::Nginx::Socket::Lua::Dgram](https://metacpan.org/pod/Test%3A%3ANginx%3A%3ASocket%3A%3ALua%3A%3ADgram) - [Test::Nginx::LWP](https://metacpan.org/pod/Test%3A%3ANginx%3A%3ALWP) (This is obsolete.) All of them are based on [Test::Base](https://metacpan.org/pod/Test%3A%3ABase). Usually, [Test::Nginx::Socket](https://metacpan.org/pod/Test%3A%3ANginx%3A%3ASocket) is preferred because it works on a much lower level and not that fault tolerant like [Test::Nginx::LWP](https://metacpan.org/pod/Test%3A%3ANginx%3A%3ALWP). Also, a lot of connection hang issues (like wrong `r->main->count` value in nginx 0.8.x) can only be captured by [Test::Nginx::Socket](https://metacpan.org/pod/Test%3A%3ANginx%3A%3ASocket) because Perl's [LWP::UserAgent](https://metacpan.org/pod/LWP%3A%3AUserAgent) client will close the connection itself which will conceal such issues from the testers. Test::Nginx automatically starts an nginx instance (from the `PATH` env) rooted at t/servroot/ and the default config template makes this nginx instance listen on the port `1984` by default. One can specify a different port number by setting his port number to the `TEST_NGINX_PORT` environment, as in export TEST_NGINX_PORT=1989 # User Guide You can find a comprehensive user guide on this test framework in my upcoming book "Programming OpenResty": [https://openresty.gitbooks.io/programming-openresty/content/testing/index.html](https://openresty.gitbooks.io/programming-openresty/content/testing/index.html) # Nginx C modules that use Test::Nginx to drive their test suites - ngx\_echo [https://github.com/openresty/echo-nginx-module](https://github.com/openresty/echo-nginx-module) - ngx\_headers\_more [https://github.com/openresty/headers-more-nginx-module](https://github.com/openresty/headers-more-nginx-module) - ngx\_chunkin [http://wiki.nginx.org/NginxHttpChunkinModule](http://wiki.nginx.org/NginxHttpChunkinModule) - ngx\_memc [http://wiki.nginx.org/NginxHttpMemcModule](http://wiki.nginx.org/NginxHttpMemcModule) - ngx\_drizzle [https://github.com/openresty/drizzle-nginx-module](https://github.com/openresty/drizzle-nginx-module) - ngx\_rds\_json [https://github.com/openresty/rds-json-nginx-module](https://github.com/openresty/rds-json-nginx-module) - ngx\_rds\_csv [https://github.com/openresty/rds-csv-nginx-module](https://github.com/openresty/rds-csv-nginx-module) - ngx\_xss [https://github.com/openresty/xss-nginx-module](https://github.com/openresty/xss-nginx-module) - ngx\_srcache [https://github.com/openresty/srcache-nginx-module](https://github.com/openresty/srcache-nginx-module) - ngx\_lua [https://github.com/openresty/lua-nginx-module](https://github.com/openresty/lua-nginx-module) - ngx\_set\_misc [https://github.com/openresty/set-misc-nginx-module](https://github.com/openresty/set-misc-nginx-module) - ngx\_array\_var [https://github.com/openresty/array-var-nginx-module](https://github.com/openresty/array-var-nginx-module) - ngx\_form\_input [https://github.com/calio/form-input-nginx-module](https://github.com/calio/form-input-nginx-module) - ngx\_iconv [https://github.com/calio/iconv-nginx-module](https://github.com/calio/iconv-nginx-module) - ngx\_set\_cconv [https://github.com/liseen/set-cconv-nginx-module](https://github.com/liseen/set-cconv-nginx-module) - ngx\_postgres [https://github.com/FRiCKLE/ngx\_postgres](https://github.com/FRiCKLE/ngx_postgres) - ngx\_coolkit [https://github.com/FRiCKLE/ngx\_coolkit](https://github.com/FRiCKLE/ngx_coolkit) - Naxsi [https://github.com/nbs-system/naxsi](https://github.com/nbs-system/naxsi) - ngx\_shibboleth [https://github.com/nginx-shib/nginx-http-shibboleth](https://github.com/nginx-shib/nginx-http-shibboleth) [Back to TOC](#table-of-contents) # INSTALLATION If you have \`cpan\` installed, you can simply run the command to install this module: sudo cpan Test::Nginx If you want to install from the source code directory directly, you can run sudo cpan . If you prefer `cpanm` to `cpan` (like I do!), you can replace `cpan` in the commands above with `cpanm`. Otherwise you can install this module in the good old way below: perl Makefile.PL make sudo make install [Back to TOC](#table-of-contents) # SOURCE REPOSITORY This module has a Git repository on Github, which has access for all. [https://github.com/openresty/test-nginx](https://github.com/openresty/test-nginx) If you want a commit bit, feel free to drop me a line. [Back to TOC](#table-of-contents) # DEBIAN PACKAGES António P. P. Almeida is maintaining a Debian package for this module in his Debian repository: [http://debian.perusio.net](http://debian.perusio.net) [Back to TOC](#table-of-contents) # Community ## English Mailing List The `openresty-en` mailing list is for English speakers: [https://groups.google.com/group/openresty-en](https://groups.google.com/group/openresty-en) [Back to TOC](#table-of-contents) ## Chinese Mailing List The `openresty` mailing list is for Chinese speakers: [https://groups.google.com/group/openresty](https://groups.google.com/group/openresty) [Back to TOC](#table-of-contents) # AUTHORS Yichun Zhang (agentzh) ``, OpenResty Inc. Antoine BONAVITA `` [Back to TOC](#table-of-contents) # COPYRIGHT & LICENSE Copyright (c) 2009-2025, Yichun Zhang (agentzh) ``, OpenResty Inc. Copyright (c) 2011-2012, Antoine Bonavita ``. This module is licensed under the terms of the BSD license. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - Neither the name of the authors nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. [Back to TOC](#table-of-contents) # SEE ALSO [Test::Nginx::LWP](https://metacpan.org/pod/Test%3A%3ANginx%3A%3ALWP), [Test::Nginx::Socket](https://metacpan.org/pod/Test%3A%3ANginx%3A%3ASocket), [Test::Base](https://metacpan.org/pod/Test%3A%3ABase). [Back to TOC](#table-of-contents) libtest-nginx-perl-0.32/inc/000077500000000000000000000000001522511534200157365ustar00rootroot00000000000000libtest-nginx-perl-0.32/inc/Module/000077500000000000000000000000001522511534200171635ustar00rootroot00000000000000libtest-nginx-perl-0.32/inc/Module/AutoInstall.pm000066400000000000000000000623111522511534200217630ustar00rootroot00000000000000#line 1 package Module::AutoInstall; use strict; use Cwd (); use File::Spec (); use ExtUtils::MakeMaker (); use vars qw{$VERSION}; BEGIN { $VERSION = '1.21'; } # special map on pre-defined feature sets my %FeatureMap = ( '' => 'Core Features', # XXX: deprecated '-core' => 'Core Features', ); # various lexical flags my ( @Missing, @Existing, %DisabledTests, $UnderCPAN, $InstallDepsTarget, $HasCPANPLUS ); my ( $Config, $CheckOnly, $SkipInstall, $AcceptDefault, $TestOnly, $AllDeps, $UpgradeDeps ); my ( $PostambleActions, $PostambleActionsNoTest, $PostambleActionsUpgradeDeps, $PostambleActionsUpgradeDepsNoTest, $PostambleActionsListDeps, $PostambleActionsListAllDeps, $PostambleUsed, $NoTest); # See if it's a testing or non-interactive session _accept_default( $ENV{AUTOMATED_TESTING} or ! -t STDIN ); _init(); sub _accept_default { $AcceptDefault = shift; } sub _installdeps_target { $InstallDepsTarget = shift; } sub missing_modules { return @Missing; } sub do_install { __PACKAGE__->install( [ $Config ? ( UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} ) : () ], @Missing, ); } # initialize various flags, and/or perform install sub _init { foreach my $arg ( @ARGV, split( /[\s\t]+/, $ENV{PERL_AUTOINSTALL} || $ENV{PERL_EXTUTILS_AUTOINSTALL} || '' ) ) { if ( $arg =~ /^--config=(.*)$/ ) { $Config = [ split( ',', $1 ) ]; } elsif ( $arg =~ /^--installdeps=(.*)$/ ) { __PACKAGE__->install( $Config, @Missing = split( /,/, $1 ) ); exit 0; } elsif ( $arg =~ /^--upgradedeps=(.*)$/ ) { $UpgradeDeps = 1; __PACKAGE__->install( $Config, @Missing = split( /,/, $1 ) ); exit 0; } elsif ( $arg =~ /^--default(?:deps)?$/ ) { $AcceptDefault = 1; } elsif ( $arg =~ /^--check(?:deps)?$/ ) { $CheckOnly = 1; } elsif ( $arg =~ /^--skip(?:deps)?$/ ) { $SkipInstall = 1; } elsif ( $arg =~ /^--test(?:only)?$/ ) { $TestOnly = 1; } elsif ( $arg =~ /^--all(?:deps)?$/ ) { $AllDeps = 1; } } } # overrides MakeMaker's prompt() to automatically accept the default choice sub _prompt { goto &ExtUtils::MakeMaker::prompt unless $AcceptDefault; my ( $prompt, $default ) = @_; my $y = ( $default =~ /^[Yy]/ ); print $prompt, ' [', ( $y ? 'Y' : 'y' ), '/', ( $y ? 'n' : 'N' ), '] '; print "$default\n"; return $default; } # the workhorse sub import { my $class = shift; my @args = @_ or return; my $core_all; print "*** $class version " . $class->VERSION . "\n"; print "*** Checking for Perl dependencies...\n"; my $cwd = Cwd::getcwd(); $Config = []; my $maxlen = length( ( sort { length($b) <=> length($a) } grep { /^[^\-]/ } map { ref($_) ? ( ( ref($_) eq 'HASH' ) ? keys(%$_) : @{$_} ) : '' } map { +{@args}->{$_} } grep { /^[^\-]/ or /^-core$/i } keys %{ +{@args} } )[0] ); # We want to know if we're under CPAN early to avoid prompting, but # if we aren't going to try and install anything anyway then skip the # check entirely since we don't want to have to load (and configure) # an old CPAN just for a cosmetic message $UnderCPAN = _check_lock(1) unless $SkipInstall || $InstallDepsTarget; while ( my ( $feature, $modules ) = splice( @args, 0, 2 ) ) { my ( @required, @tests, @skiptests ); my $default = 1; my $conflict = 0; if ( $feature =~ m/^-(\w+)$/ ) { my $option = lc($1); # check for a newer version of myself _update_to( $modules, @_ ) and return if $option eq 'version'; # sets CPAN configuration options $Config = $modules if $option eq 'config'; # promote every features to core status $core_all = ( $modules =~ /^all$/i ) and next if $option eq 'core'; next unless $option eq 'core'; } print "[" . ( $FeatureMap{ lc($feature) } || $feature ) . "]\n"; $modules = [ %{$modules} ] if UNIVERSAL::isa( $modules, 'HASH' ); unshift @$modules, -default => &{ shift(@$modules) } if ( ref( $modules->[0] ) eq 'CODE' ); # XXX: bugward compatibility while ( my ( $mod, $arg ) = splice( @$modules, 0, 2 ) ) { if ( $mod =~ m/^-(\w+)$/ ) { my $option = lc($1); $default = $arg if ( $option eq 'default' ); $conflict = $arg if ( $option eq 'conflict' ); @tests = @{$arg} if ( $option eq 'tests' ); @skiptests = @{$arg} if ( $option eq 'skiptests' ); next; } printf( "- %-${maxlen}s ...", $mod ); if ( $arg and $arg =~ /^\D/ ) { unshift @$modules, $arg; $arg = 0; } # XXX: check for conflicts and uninstalls(!) them. my $cur = _version_of($mod); if (_version_cmp ($cur, $arg) >= 0) { print "loaded. ($cur" . ( $arg ? " >= $arg" : '' ) . ")\n"; push @Existing, $mod => $arg; $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; } else { if (not defined $cur) # indeed missing { print "missing." . ( $arg ? " (would need $arg)" : '' ) . "\n"; } else { # no need to check $arg as _version_cmp ($cur, undef) would satisfy >= above print "too old. ($cur < $arg)\n"; } push @required, $mod => $arg; } } next unless @required; my $mandatory = ( $feature eq '-core' or $core_all ); if ( !$SkipInstall and ( $CheckOnly or ($mandatory and $UnderCPAN) or $AllDeps or $InstallDepsTarget or _prompt( qq{==> Auto-install the } . ( @required / 2 ) . ( $mandatory ? ' mandatory' : ' optional' ) . qq{ module(s) from CPAN?}, $default ? 'y' : 'n', ) =~ /^[Yy]/ ) ) { push( @Missing, @required ); $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; } elsif ( !$SkipInstall and $default and $mandatory and _prompt( qq{==> The module(s) are mandatory! Really skip?}, 'n', ) =~ /^[Nn]/ ) { push( @Missing, @required ); $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; } else { $DisabledTests{$_} = 1 for map { glob($_) } @tests; } } if ( @Missing and not( $CheckOnly or $UnderCPAN) ) { require Config; my $make = $Config::Config{make}; if ($InstallDepsTarget) { print "*** To install dependencies type '$make installdeps' or '$make installdeps_notest'.\n"; } else { print "*** Dependencies will be installed the next time you type '$make'.\n"; } # make an educated guess of whether we'll need root permission. print " (You may need to do that as the 'root' user.)\n" if eval '$>'; } print "*** $class configuration finished.\n"; chdir $cwd; # import to main:: no strict 'refs'; *{'main::WriteMakefile'} = \&Write if caller(0) eq 'main'; return (@Existing, @Missing); } sub _running_under { my $thing = shift; print <<"END_MESSAGE"; *** Since we're running under ${thing}, I'll just let it take care of the dependency's installation later. END_MESSAGE return 1; } # Check to see if we are currently running under CPAN.pm and/or CPANPLUS; # if we are, then we simply let it taking care of our dependencies sub _check_lock { return unless @Missing or @_; if ($ENV{PERL5_CPANM_IS_RUNNING}) { return _running_under('cpanminus'); } my $cpan_env = $ENV{PERL5_CPAN_IS_RUNNING}; if ($ENV{PERL5_CPANPLUS_IS_RUNNING}) { return _running_under($cpan_env ? 'CPAN' : 'CPANPLUS'); } require CPAN; if ($CPAN::VERSION > '1.89') { if ($cpan_env) { return _running_under('CPAN'); } return; # CPAN.pm new enough, don't need to check further } # last ditch attempt, this -will- configure CPAN, very sorry _load_cpan(1); # force initialize even though it's already loaded # Find the CPAN lock-file my $lock = MM->catfile( $CPAN::Config->{cpan_home}, ".lock" ); return unless -f $lock; # Check the lock local *LOCK; return unless open(LOCK, $lock); if ( ( $^O eq 'MSWin32' ? _under_cpan() : == getppid() ) and ( $CPAN::Config->{prerequisites_policy} || '' ) ne 'ignore' ) { print <<'END_MESSAGE'; *** Since we're running under CPAN, I'll just let it take care of the dependency's installation later. END_MESSAGE return 1; } close LOCK; return; } sub install { my $class = shift; my $i; # used below to strip leading '-' from config keys my @config = ( map { s/^-// if ++$i; $_ } @{ +shift } ); my ( @modules, @installed, @modules_to_upgrade ); while (my ($pkg, $ver) = splice(@_, 0, 2)) { # grep out those already installed if (_version_cmp(_version_of($pkg), $ver) >= 0) { push @installed, $pkg; if ($UpgradeDeps) { push @modules_to_upgrade, $pkg, $ver; } } else { push @modules, $pkg, $ver; } } if ($UpgradeDeps) { push @modules, @modules_to_upgrade; @installed = (); @modules_to_upgrade = (); } return @installed unless @modules; # nothing to do return @installed if _check_lock(); # defer to the CPAN shell print "*** Installing dependencies...\n"; return unless _connected_to('cpan.org'); my %args = @config; my %failed; local *FAILED; if ( $args{do_once} and open( FAILED, '.#autoinstall.failed' ) ) { while () { chomp; $failed{$_}++ } close FAILED; my @newmod; while ( my ( $k, $v ) = splice( @modules, 0, 2 ) ) { push @newmod, ( $k => $v ) unless $failed{$k}; } @modules = @newmod; } if ( _has_cpanplus() and not $ENV{PERL_AUTOINSTALL_PREFER_CPAN} ) { _install_cpanplus( \@modules, \@config ); } else { _install_cpan( \@modules, \@config ); } print "*** $class installation finished.\n"; # see if we have successfully installed them while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { if ( _version_cmp( _version_of($pkg), $ver ) >= 0 ) { push @installed, $pkg; } elsif ( $args{do_once} and open( FAILED, '>> .#autoinstall.failed' ) ) { print FAILED "$pkg\n"; } } close FAILED if $args{do_once}; return @installed; } sub _install_cpanplus { my @modules = @{ +shift }; my @config = _cpanplus_config( @{ +shift } ); my $installed = 0; require CPANPLUS::Backend; my $cp = CPANPLUS::Backend->new; my $conf = $cp->configure_object; return unless $conf->can('conf') # 0.05x+ with "sudo" support or _can_write($conf->_get_build('base')); # 0.04x # if we're root, set UNINST=1 to avoid trouble unless user asked for it. my $makeflags = $conf->get_conf('makeflags') || ''; if ( UNIVERSAL::isa( $makeflags, 'HASH' ) ) { # 0.03+ uses a hashref here $makeflags->{UNINST} = 1 unless exists $makeflags->{UNINST}; } else { # 0.02 and below uses a scalar $makeflags = join( ' ', split( ' ', $makeflags ), 'UNINST=1' ) if ( $makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' } ); } $conf->set_conf( makeflags => $makeflags ); $conf->set_conf( prereqs => 1 ); while ( my ( $key, $val ) = splice( @config, 0, 2 ) ) { $conf->set_conf( $key, $val ); } my $modtree = $cp->module_tree; while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { print "*** Installing $pkg...\n"; MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall; my $success; my $obj = $modtree->{$pkg}; if ( $obj and _version_cmp( $obj->{version}, $ver ) >= 0 ) { my $pathname = $pkg; $pathname =~ s/::/\\W/; foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) { delete $INC{$inc}; } my $rv = $cp->install( modules => [ $obj->{module} ] ); if ( $rv and ( $rv->{ $obj->{module} } or $rv->{ok} ) ) { print "*** $pkg successfully installed.\n"; $success = 1; } else { print "*** $pkg installation cancelled.\n"; $success = 0; } $installed += $success; } else { print << "."; *** Could not find a version $ver or above for $pkg; skipping. . } MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall; } return $installed; } sub _cpanplus_config { my @config = (); while ( @_ ) { my ($key, $value) = (shift(), shift()); if ( $key eq 'prerequisites_policy' ) { if ( $value eq 'follow' ) { $value = CPANPLUS::Internals::Constants::PREREQ_INSTALL(); } elsif ( $value eq 'ask' ) { $value = CPANPLUS::Internals::Constants::PREREQ_ASK(); } elsif ( $value eq 'ignore' ) { $value = CPANPLUS::Internals::Constants::PREREQ_IGNORE(); } else { die "*** Cannot convert option $key = '$value' to CPANPLUS version.\n"; } push @config, 'prereqs', $value; } elsif ( $key eq 'force' ) { push @config, $key, $value; } elsif ( $key eq 'notest' ) { push @config, 'skiptest', $value; } else { die "*** Cannot convert option $key to CPANPLUS version.\n"; } } return @config; } sub _install_cpan { my @modules = @{ +shift }; my @config = @{ +shift }; my $installed = 0; my %args; _load_cpan(); require Config; if (CPAN->VERSION < 1.80) { # no "sudo" support, probe for writableness return unless _can_write( MM->catfile( $CPAN::Config->{cpan_home}, 'sources' ) ) and _can_write( $Config::Config{sitelib} ); } # if we're root, set UNINST=1 to avoid trouble unless user asked for it. my $makeflags = $CPAN::Config->{make_install_arg} || ''; $CPAN::Config->{make_install_arg} = join( ' ', split( ' ', $makeflags ), 'UNINST=1' ) if ( $makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' } ); # don't show start-up info $CPAN::Config->{inhibit_startup_message} = 1; # set additional options while ( my ( $opt, $arg ) = splice( @config, 0, 2 ) ) { ( $args{$opt} = $arg, next ) if $opt =~ /^(?:force|notest)$/; # pseudo-option $CPAN::Config->{$opt} = $opt eq 'urllist' ? [$arg] : $arg; } if ($args{notest} && (not CPAN::Shell->can('notest'))) { die "Your version of CPAN is too old to support the 'notest' pragma"; } local $CPAN::Config->{prerequisites_policy} = 'follow'; while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall; print "*** Installing $pkg...\n"; my $obj = CPAN::Shell->expand( Module => $pkg ); my $success = 0; if ( $obj and _version_cmp( $obj->cpan_version, $ver ) >= 0 ) { my $pathname = $pkg; $pathname =~ s/::/\\W/; foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) { delete $INC{$inc}; } my $rv = do { if ($args{force}) { CPAN::Shell->force( install => $pkg ) } elsif ($args{notest}) { CPAN::Shell->notest( install => $pkg ) } else { CPAN::Shell->install($pkg) } }; $rv ||= eval { $CPAN::META->instance( 'CPAN::Distribution', $obj->cpan_file, ) ->{install} if $CPAN::META; }; if ( $rv eq 'YES' ) { print "*** $pkg successfully installed.\n"; $success = 1; } else { print "*** $pkg installation failed.\n"; $success = 0; } $installed += $success; } else { print << "."; *** Could not find a version $ver or above for $pkg; skipping. . } MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall; } return $installed; } sub _has_cpanplus { return ( $HasCPANPLUS = ( $INC{'CPANPLUS/Config.pm'} or _load('CPANPLUS::Shell::Default') ) ); } # make guesses on whether we're under the CPAN installation directory sub _under_cpan { require Cwd; require File::Spec; my $cwd = File::Spec->canonpath( Cwd::getcwd() ); my $cpan = File::Spec->canonpath( $CPAN::Config->{cpan_home} ); return ( index( $cwd, $cpan ) > -1 ); } sub _update_to { my $class = __PACKAGE__; my $ver = shift; return if _version_cmp( _version_of($class), $ver ) >= 0; # no need to upgrade if ( _prompt( "==> A newer version of $class ($ver) is required. Install?", 'y' ) =~ /^[Nn]/ ) { die "*** Please install $class $ver manually.\n"; } print << "."; *** Trying to fetch it from CPAN... . # install ourselves _load($class) and return $class->import(@_) if $class->install( [], $class, $ver ); print << '.'; exit 1; *** Cannot bootstrap myself. :-( Installation terminated. . } # check if we're connected to some host, using inet_aton sub _connected_to { my $site = shift; return ( ( _load('Socket') and Socket::inet_aton($site) ) or _prompt( qq( *** Your host cannot resolve the domain name '$site', which probably means the Internet connections are unavailable. ==> Should we try to install the required module(s) anyway?), 'n' ) =~ /^[Yy]/ ); } # check if a directory is writable; may create it on demand sub _can_write { my $path = shift; mkdir( $path, 0755 ) unless -e $path; return 1 if -w $path; print << "."; *** You are not allowed to write to the directory '$path'; the installation may fail due to insufficient permissions. . if ( eval '$>' and lc(`sudo -V`) =~ /version/ and _prompt( qq( ==> Should we try to re-execute the autoinstall process with 'sudo'?), ((-t STDIN) ? 'y' : 'n') ) =~ /^[Yy]/ ) { # try to bootstrap ourselves from sudo print << "."; *** Trying to re-execute the autoinstall process with 'sudo'... . my $missing = join( ',', @Missing ); my $config = join( ',', UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} ) if $Config; return unless system( 'sudo', $^X, $0, "--config=$config", "--installdeps=$missing" ); print << "."; *** The 'sudo' command exited with error! Resuming... . } return _prompt( qq( ==> Should we try to install the required module(s) anyway?), 'n' ) =~ /^[Yy]/; } # load a module and return the version it reports sub _load { my $mod = pop; # method/function doesn't matter my $file = $mod; $file =~ s|::|/|g; $file .= '.pm'; local $@; return eval { require $file; $mod->VERSION } || ( $@ ? undef: 0 ); } # report version without loading a module sub _version_of { my $mod = pop; # method/function doesn't matter my $file = $mod; $file =~ s|::|/|g; $file .= '.pm'; foreach my $dir ( @INC ) { next if ref $dir; my $path = File::Spec->catfile($dir, $file); next unless -e $path; require ExtUtils::MM_Unix; return ExtUtils::MM_Unix->parse_version($path); } return undef; } # Load CPAN.pm and it's configuration sub _load_cpan { return if $CPAN::VERSION and $CPAN::Config and not @_; require CPAN; # CPAN-1.82+ adds CPAN::Config::AUTOLOAD to redirect to # CPAN::HandleConfig->load. CPAN reports that the redirection # is deprecated in a warning printed at the user. # CPAN-1.81 expects CPAN::HandleConfig->load, does not have # $CPAN::HandleConfig::VERSION but cannot handle # CPAN::Config->load # Which "versions expect CPAN::Config->load? if ( $CPAN::HandleConfig::VERSION || CPAN::HandleConfig->can('load') ) { # Newer versions of CPAN have a HandleConfig module CPAN::HandleConfig->load; } else { # Older versions had the load method in Config directly CPAN::Config->load; } } # compare two versions, either use Sort::Versions or plain comparison # return values same as <=> sub _version_cmp { my ( $cur, $min ) = @_; return -1 unless defined $cur; # if 0 keep comparing return 1 unless $min; $cur =~ s/\s+$//; # check for version numbers that are not in decimal format if ( ref($cur) or ref($min) or $cur =~ /v|\..*\./ or $min =~ /v|\..*\./ ) { if ( ( $version::VERSION or defined( _load('version') )) and version->can('new') ) { # use version.pm if it is installed. return version->new($cur) <=> version->new($min); } elsif ( $Sort::Versions::VERSION or defined( _load('Sort::Versions') ) ) { # use Sort::Versions as the sorting algorithm for a.b.c versions return Sort::Versions::versioncmp( $cur, $min ); } warn "Cannot reliably compare non-decimal formatted versions.\n" . "Please install version.pm or Sort::Versions.\n"; } # plain comparison local $^W = 0; # shuts off 'not numeric' bugs return $cur <=> $min; } # nothing; this usage is deprecated. sub main::PREREQ_PM { return {}; } sub _make_args { my %args = @_; $args{PREREQ_PM} = { %{ $args{PREREQ_PM} || {} }, @Existing, @Missing } if $UnderCPAN or $TestOnly; if ( $args{EXE_FILES} and -e 'MANIFEST' ) { require ExtUtils::Manifest; my $manifest = ExtUtils::Manifest::maniread('MANIFEST'); $args{EXE_FILES} = [ grep { exists $manifest->{$_} } @{ $args{EXE_FILES} } ]; } $args{test}{TESTS} ||= 't/*.t'; $args{test}{TESTS} = join( ' ', grep { !exists( $DisabledTests{$_} ) } map { glob($_) } split( /\s+/, $args{test}{TESTS} ) ); my $missing = join( ',', @Missing ); my $config = join( ',', UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} ) if $Config; $PostambleActions = ( ($missing and not $UnderCPAN) ? "\$(PERL) $0 --config=$config --installdeps=$missing" : "\$(NOECHO) \$(NOOP)" ); my $deps_list = join( ',', @Missing, @Existing ); $PostambleActionsUpgradeDeps = "\$(PERL) $0 --config=$config --upgradedeps=$deps_list"; my $config_notest = join( ',', (UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config}), 'notest', 1 ) if $Config; $PostambleActionsNoTest = ( ($missing and not $UnderCPAN) ? "\$(PERL) $0 --config=$config_notest --installdeps=$missing" : "\$(NOECHO) \$(NOOP)" ); $PostambleActionsUpgradeDepsNoTest = "\$(PERL) $0 --config=$config_notest --upgradedeps=$deps_list"; $PostambleActionsListDeps = '@$(PERL) -le "print for @ARGV" ' . join(' ', map $Missing[$_], grep $_ % 2 == 0, 0..$#Missing); my @all = (@Missing, @Existing); $PostambleActionsListAllDeps = '@$(PERL) -le "print for @ARGV" ' . join(' ', map $all[$_], grep $_ % 2 == 0, 0..$#all); return %args; } # a wrapper to ExtUtils::MakeMaker::WriteMakefile sub Write { require Carp; Carp::croak "WriteMakefile: Need even number of args" if @_ % 2; if ($CheckOnly) { print << "."; *** Makefile not written in check-only mode. . return; } my %args = _make_args(@_); no strict 'refs'; $PostambleUsed = 0; local *MY::postamble = \&postamble unless defined &MY::postamble; ExtUtils::MakeMaker::WriteMakefile(%args); print << "." unless $PostambleUsed; *** WARNING: Makefile written with customized MY::postamble() without including contents from Module::AutoInstall::postamble() -- auto installation features disabled. Please contact the author. . return 1; } sub postamble { $PostambleUsed = 1; my $fragment; $fragment .= <<"AUTO_INSTALL" if !$InstallDepsTarget; config :: installdeps \t\$(NOECHO) \$(NOOP) AUTO_INSTALL $fragment .= <<"END_MAKE"; checkdeps :: \t\$(PERL) $0 --checkdeps installdeps :: \t$PostambleActions installdeps_notest :: \t$PostambleActionsNoTest upgradedeps :: \t$PostambleActionsUpgradeDeps upgradedeps_notest :: \t$PostambleActionsUpgradeDepsNoTest listdeps :: \t$PostambleActionsListDeps listalldeps :: \t$PostambleActionsListAllDeps END_MAKE return $fragment; } 1; __END__ #line 1197 libtest-nginx-perl-0.32/inc/Module/Install.pm000066400000000000000000000271451522511534200211400ustar00rootroot00000000000000#line 1 package Module::Install; # For any maintainers: # The load order for Module::Install is a bit magic. # It goes something like this... # # IF ( host has Module::Install installed, creating author mode ) { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install # 3. The installed version of inc::Module::Install loads # 4. inc::Module::Install calls "require Module::Install" # 5. The ./inc/ version of Module::Install loads # } ELSE { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install # 3. The ./inc/ version of Module::Install loads # } use 5.006; use strict 'vars'; use Cwd (); use File::Find (); use File::Path (); use vars qw{$VERSION $MAIN}; BEGIN { # All Module::Install core packages now require synchronised versions. # This will be used to ensure we don't accidentally load old or # different versions of modules. # This is not enforced yet, but will be some time in the next few # releases once we can make sure it won't clash with custom # Module::Install extensions. $VERSION = '1.21'; # Storage for the pseudo-singleton $MAIN = undef; *inc::Module::Install::VERSION = *VERSION; @inc::Module::Install::ISA = __PACKAGE__; } sub import { my $class = shift; my $self = $class->new(@_); my $who = $self->_caller; #------------------------------------------------------------- # all of the following checks should be included in import(), # to allow "eval 'require Module::Install; 1' to test # installation of Module::Install. (RT #51267) #------------------------------------------------------------- # Whether or not inc::Module::Install is actually loaded, the # $INC{inc/Module/Install.pm} is what will still get set as long as # the caller loaded module this in the documented manner. # If not set, the caller may NOT have loaded the bundled version, and thus # they may not have a MI version that works with the Makefile.PL. This would # result in false errors or unexpected behaviour. And we don't want that. my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; unless ( $INC{$file} ) { die <<"END_DIE" } Please invoke ${\__PACKAGE__} with: use inc::${\__PACKAGE__}; not: use ${\__PACKAGE__}; END_DIE # This reportedly fixes a rare Win32 UTC file time issue, but # as this is a non-cross-platform XS module not in the core, # we shouldn't really depend on it. See RT #24194 for detail. # (Also, this module only supports Perl 5.6 and above). eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006; # If the script that is loading Module::Install is from the future, # then make will detect this and cause it to re-run over and over # again. This is bad. Rather than taking action to touch it (which # is unreliable on some platforms and requires write permissions) # for now we should catch this and refuse to run. if ( -f $0 ) { my $s = (stat($0))[9]; # If the modification time is only slightly in the future, # sleep briefly to remove the problem. my $a = $s - time; if ( $a > 0 and $a < 5 ) { sleep 5 } # Too far in the future, throw an error. my $t = time; if ( $s > $t ) { die <<"END_DIE" } Your installer $0 has a modification time in the future ($s > $t). This is known to create infinite loops in make. Please correct this, then run $0 again. END_DIE } # Build.PL was formerly supported, but no longer is due to excessive # difficulty in implementing every single feature twice. if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } Module::Install no longer supports Build.PL. It was impossible to maintain duel backends, and has been deprecated. Please remove all Build.PL files and only use the Makefile.PL installer. END_DIE #------------------------------------------------------------- # To save some more typing in Module::Install installers, every... # use inc::Module::Install # ...also acts as an implicit use strict. $^H |= strict::bits(qw(refs subs vars)); #------------------------------------------------------------- unless ( -f $self->{file} ) { foreach my $key (keys %INC) { delete $INC{$key} if $key =~ /Module\/Install/; } local $^W; require "$self->{path}/$self->{dispatch}.pm"; File::Path::mkpath("$self->{prefix}/$self->{author}"); $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); $self->{admin}->init; @_ = ($class, _self => $self); goto &{"$self->{name}::import"}; } local $^W; *{"${who}::AUTOLOAD"} = $self->autoload; $self->preload; # Unregister loader and worker packages so subdirs can use them again delete $INC{'inc/Module/Install.pm'}; delete $INC{'Module/Install.pm'}; # Save to the singleton $MAIN = $self; return 1; } sub autoload { my $self = shift; my $who = $self->_caller; my $cwd = Cwd::getcwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::getcwd(); if ( my $code = $sym->{$pwd} ) { # Delegate back to parent dirs goto &$code unless $cwd eq $pwd; } unless ($$sym =~ s/([^:]+)$//) { # XXX: it looks like we can't retrieve the missing function # via $$sym (usually $main::AUTOLOAD) in this case. # I'm still wondering if we should slurp Makefile.PL to # get some context or not ... my ($package, $file, $line) = caller; die <<"EOT"; Unknown function is found at $file line $line. Execution of $file aborted due to runtime errors. If you're a contributor to a project, you may need to install some Module::Install extensions from CPAN (or other repository). If you're a user of a module, please contact the author. EOT } my $method = $1; if ( uc($method) eq $method ) { # Do nothing return; } elsif ( $method =~ /^_/ and $self->can($method) ) { # Dispatch to the root M:I class return $self->$method(@_); } # Dispatch to the appropriate plugin unshift @_, ( $self, $1 ); goto &{$self->can('call')}; }; } sub preload { my $self = shift; unless ( $self->{extensions} ) { $self->load_extensions( "$self->{prefix}/$self->{path}", $self ); } my @exts = @{$self->{extensions}}; unless ( @exts ) { @exts = $self->{admin}->load_all_extensions; } my %seen; foreach my $obj ( @exts ) { while (my ($method, $glob) = each %{ref($obj) . '::'}) { next unless $obj->can($method); next if $method =~ /^_/; next if $method eq uc($method); $seen{$method}++; } } my $who = $self->_caller; foreach my $name ( sort keys %seen ) { local $^W; *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; delete $INC{'FindBin.pm'}; { # to suppress the redefine warning local $SIG{__WARN__} = sub {}; require FindBin; } # ignore the prefix on extension modules built from top level. my $base_path = Cwd::abs_path($FindBin::Bin); unless ( Cwd::abs_path(Cwd::getcwd()) eq $base_path ) { delete $args{prefix}; } return $args{_self} if $args{_self}; $base_path = VMS::Filespec::unixify($base_path) if $^O eq 'VMS'; $args{dispatch} ||= 'Admin'; $args{prefix} ||= 'inc'; $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); $args{bundle} ||= 'inc/BUNDLES'; $args{base} ||= $base_path; $class =~ s/^\Q$args{prefix}\E:://; $args{name} ||= $class; $args{version} ||= $class->VERSION; unless ( $args{path} ) { $args{path} = $args{name}; $args{path} =~ s!::!/!g; } $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; $args{wrote} = 0; bless( \%args, $class ); } sub call { my ($self, $method) = @_; my $obj = $self->load($method) or return; splice(@_, 0, 2, $obj); goto &{$obj->can($method)}; } sub load { my ($self, $method) = @_; $self->load_extensions( "$self->{prefix}/$self->{path}", $self ) unless $self->{extensions}; foreach my $obj (@{$self->{extensions}}) { return $obj if $obj->can($method); } my $admin = $self->{admin} or die <<"END_DIE"; The '$method' method does not exist in the '$self->{prefix}' path! Please remove the '$self->{prefix}' directory and run $0 again to load it. END_DIE my $obj = $admin->load($method, 1); push @{$self->{extensions}}, $obj; $obj; } sub load_extensions { my ($self, $path, $top) = @_; my $should_reload = 0; unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { unshift @INC, $self->{prefix}; $should_reload = 1; } foreach my $rv ( $self->find_extensions($path) ) { my ($file, $pkg) = @{$rv}; next if $self->{pathnames}{$pkg}; local $@; my $new = eval { local $^W; require $file; $pkg->can('new') }; unless ( $new ) { warn $@ if $@; next; } $self->{pathnames}{$pkg} = $should_reload ? delete $INC{$file} : $INC{$file}; push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); } $self->{extensions} ||= []; } sub find_extensions { my ($self, $path) = @_; my @found; File::Find::find( {no_chdir => 1, wanted => sub { my $file = $File::Find::name; return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; my $subpath = $1; return if lc($subpath) eq lc($self->{dispatch}); $file = "$self->{path}/$subpath.pm"; my $pkg = "$self->{name}::$subpath"; $pkg =~ s!/!::!g; # If we have a mixed-case package name, assume case has been preserved # correctly. Otherwise, root through the file to locate the case-preserved # version of the package name. if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { my $content = Module::Install::_read($File::Find::name); my $in_pod = 0; foreach ( split /\n/, $content ) { $in_pod = 1 if /^=\w/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); # skip pod text next if /^\s*#/; # and comments if ( m/^\s*package\s+($pkg)\s*;/i ) { $pkg = $1; last; } } } push @found, [ $file, $pkg ]; }}, $path ) if -d $path; @found; } ##################################################################### # Common Utility Functions sub _caller { my $depth = 0; my $call = caller($depth); while ( $call eq __PACKAGE__ ) { $depth++; $call = caller($depth); } return $call; } sub _read { local *FH; open( FH, '<', $_[0] ) or die "open($_[0]): $!"; binmode FH; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } sub _readperl { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s; $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg; return $string; } sub _readpod { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; return $string if $_[0] =~ /\.pod\z/; $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg; $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg; $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg; $string =~ s/^\n+//s; return $string; } sub _write { local *FH; open( FH, '>', $_[0] ) or die "open($_[0]): $!"; binmode FH; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } # _version is for processing module versions (eg, 1.03_05) not # Perl versions (eg, 5.8.1). sub _version { my $s = shift || 0; my $d =()= $s =~ /(\.)/g; if ( $d >= 2 ) { # Normalise multipart versions $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg; } $s =~ s/^(\d+)\.?//; my $l = $1 || 0; my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g; $l = $l . '.' . join '', @v if @v; return $l + 0; } sub _cmp { _version($_[1]) <=> _version($_[2]); } # Cloned from Params::Util::_CLASS sub _CLASS { ( defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s ) ? $_[0] : undef; } 1; # Copyright 2008 - 2012 Adam Kennedy. libtest-nginx-perl-0.32/inc/Module/Install/000077500000000000000000000000001522511534200205715ustar00rootroot00000000000000libtest-nginx-perl-0.32/inc/Module/Install/AutoInstall.pm000066400000000000000000000041621522511534200233710ustar00rootroot00000000000000#line 1 package Module::Install::AutoInstall; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.21'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub AutoInstall { $_[0] } sub run { my $self = shift; $self->auto_install_now(@_); } sub write { my $self = shift; $self->auto_install(@_); } sub auto_install { my $self = shift; return if $self->{done}++; # Flatten array of arrays into a single array my @core = map @$_, map @$_, grep ref, $self->build_requires, $self->requires; my @config = @_; # We'll need Module::AutoInstall $self->include('Module::AutoInstall'); require Module::AutoInstall; my @features_require = Module::AutoInstall->import( (@config ? (-config => \@config) : ()), (@core ? (-core => \@core) : ()), $self->features, ); my %seen; my @requires = map @$_, map @$_, grep ref, $self->requires; while (my ($mod, $ver) = splice(@requires, 0, 2)) { $seen{$mod}{$ver}++; } my @build_requires = map @$_, map @$_, grep ref, $self->build_requires; while (my ($mod, $ver) = splice(@build_requires, 0, 2)) { $seen{$mod}{$ver}++; } my @configure_requires = map @$_, map @$_, grep ref, $self->configure_requires; while (my ($mod, $ver) = splice(@configure_requires, 0, 2)) { $seen{$mod}{$ver}++; } my @deduped; while (my ($mod, $ver) = splice(@features_require, 0, 2)) { push @deduped, $mod => $ver unless $seen{$mod}{$ver}++; } $self->requires(@deduped); $self->makemaker_args( Module::AutoInstall::_make_args() ); my $class = ref($self); $self->postamble( "# --- $class section:\n" . Module::AutoInstall::postamble() ); } sub installdeps_target { my ($self, @args) = @_; $self->include('Module::AutoInstall'); require Module::AutoInstall; Module::AutoInstall::_installdeps_target(1); $self->auto_install(@args); } sub auto_install_now { my $self = shift; $self->auto_install(@_); Module::AutoInstall::do_install(); } 1; libtest-nginx-perl-0.32/inc/Module/Install/Base.pm000066400000000000000000000021471522511534200220050ustar00rootroot00000000000000#line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '1.21'; } # Suspend handler for "redefined" warnings BEGIN { my $w = $SIG{__WARN__}; $SIG{__WARN__} = sub { $w }; } #line 42 sub new { my $class = shift; unless ( defined &{"${class}::call"} ) { *{"${class}::call"} = sub { shift->_top->call(@_) }; } unless ( defined &{"${class}::load"} ) { *{"${class}::load"} = sub { shift->_top->load(@_) }; } bless { @_ }, $class; } #line 61 sub AUTOLOAD { local $@; my $func = eval { shift->_top->autoload } or return; goto &$func; } #line 75 sub _top { $_[0]->{_top}; } #line 90 sub admin { $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new; } #line 106 sub is_admin { ! $_[0]->admin->isa('Module::Install::Base::FakeAdmin'); } sub DESTROY {} package Module::Install::Base::FakeAdmin; use vars qw{$VERSION}; BEGIN { $VERSION = $Module::Install::Base::VERSION; } my $fake; sub new { $fake ||= bless(\@_, $_[0]); } sub AUTOLOAD {} sub DESTROY {} # Restore warning handler BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->(); } 1; #line 159 libtest-nginx-perl-0.32/inc/Module/Install/Can.pm000066400000000000000000000064051522511534200216350ustar00rootroot00000000000000#line 1 package Module::Install::Can; use strict; use Config (); use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.21'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # check if we can load some module ### Upgrade this to not have to load the module if possible sub can_use { my ($self, $mod, $ver) = @_; $mod =~ s{::|\\}{/}g; $mod .= '.pm' unless $mod =~ /\.pm$/i; my $pkg = $mod; $pkg =~ s{/}{::}g; $pkg =~ s{\.pm$}{}i; local $@; eval { require $mod; $pkg->VERSION($ver || 0); 1 }; } # Check if we can run some command sub can_run { my ($self, $cmd) = @_; my $_cmd = $cmd; return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { next if $dir eq ''; require File::Spec; my $abs = File::Spec->catfile($dir, $cmd); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } # Can our C compiler environment build XS files sub can_xs { my $self = shift; # Ensure we have the CBuilder module $self->configure_requires( 'ExtUtils::CBuilder' => 0.27 ); # Do we have the configure_requires checker? local $@; eval "require ExtUtils::CBuilder;"; if ( $@ ) { # They don't obey configure_requires, so it is # someone old and delicate. Try to avoid hurting # them by falling back to an older simpler test. return $self->can_cc(); } # Do we have a working C compiler my $builder = ExtUtils::CBuilder->new( quiet => 1, ); unless ( $builder->have_compiler ) { # No working C compiler return 0; } # Write a C file representative of what XS becomes require File::Temp; my ( $FH, $tmpfile ) = File::Temp::tempfile( "compilexs-XXXXX", SUFFIX => '.c', ); binmode $FH; print $FH <<'END_C'; #include "EXTERN.h" #include "perl.h" #include "XSUB.h" int main(int argc, char **argv) { return 0; } int boot_sanexs() { return 1; } END_C close $FH; # Can the C compiler access the same headers XS does my @libs = (); my $object = undef; eval { local $^W = 0; $object = $builder->compile( source => $tmpfile, ); @libs = $builder->link( objects => $object, module_name => 'sanexs', ); }; my $result = $@ ? 0 : 1; # Clean up all the build files foreach ( $tmpfile, $object, @libs ) { next unless defined $_; 1 while unlink; } return $result; } # Can we locate a (the) C compiler sub can_cc { my $self = shift; if ($^O eq 'VMS') { require ExtUtils::CBuilder; my $builder = ExtUtils::CBuilder->new( quiet => 1, ); return $builder->have_compiler; } my @chunks = split(/ /, $Config::Config{cc}) or return; # $Config{cc} may contain args; try to find out the program part while (@chunks) { return $self->can_run("@chunks") || (pop(@chunks), next); } return; } # Fix Cygwin bug on maybe_command(); if ( $^O eq 'cygwin' ) { require ExtUtils::MM_Cygwin; require ExtUtils::MM_Win32; if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { *ExtUtils::MM_Cygwin::maybe_command = sub { my ($self, $file) = @_; if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { ExtUtils::MM_Win32->maybe_command($file); } else { ExtUtils::MM_Unix->maybe_command($file); } } } } 1; __END__ #line 245 libtest-nginx-perl-0.32/inc/Module/Install/Fetch.pm000066400000000000000000000046271522511534200221710ustar00rootroot00000000000000#line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.21'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub get_file { my ($self, %args) = @_; my ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) { $args{url} = $args{ftp_url} or (warn("LWP support unavailable!\n"), return); ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; } $|++; print "Fetching '$file' from $host... "; unless (eval { require Socket; Socket::inet_aton($host) }) { warn "'$host' resolve failed!\n"; return; } return unless $scheme eq 'ftp' or $scheme eq 'http'; require Cwd; my $dir = Cwd::getcwd(); chdir $args{local_dir} or return if exists $args{local_dir}; if (eval { require LWP::Simple; 1 }) { LWP::Simple::mirror($args{url}, $file); } elsif (eval { require Net::FTP; 1 }) { eval { # use Net::FTP to get past firewall my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600); $ftp->login("anonymous", 'anonymous@example.com'); $ftp->cwd($path); $ftp->binary; $ftp->get($file) or (warn("$!\n"), return); $ftp->quit; } } elsif (my $ftp = $self->can_run('ftp')) { eval { # no Net::FTP, fallback to ftp.exe require FileHandle; my $fh = FileHandle->new; local $SIG{CHLD} = 'IGNORE'; unless ($fh->open("|$ftp -n")) { warn "Couldn't open ftp: $!\n"; chdir $dir; return; } my @dialog = split(/\n/, <<"END_FTP"); open $host user anonymous anonymous\@example.com cd $path binary get $file $file quit END_FTP foreach (@dialog) { $fh->print("$_\n") } $fh->close; } } else { warn "No working 'ftp' program available!\n"; chdir $dir; return; } unless (-f $file) { warn "Fetching failed: $@\n"; chdir $dir; return; } return if exists $args{size} and -s $file != $args{size}; system($args{run}) if exists $args{run}; unlink($file) if $args{remove}; print(((!exists $args{check_for} or -e $args{check_for}) ? "done!" : "failed! ($!)"), "\n"); chdir $dir; return !$?; } 1; libtest-nginx-perl-0.32/inc/Module/Install/Include.pm000066400000000000000000000010151522511534200225070ustar00rootroot00000000000000#line 1 package Module::Install::Include; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.21'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub include { shift()->admin->include(@_); } sub include_deps { shift()->admin->include_deps(@_); } sub auto_include { shift()->admin->auto_include(@_); } sub auto_include_deps { shift()->admin->auto_include_deps(@_); } sub auto_include_dependent_dists { shift()->admin->auto_include_dependent_dists(@_); } 1; libtest-nginx-perl-0.32/inc/Module/Install/Makefile.pm000066400000000000000000000274371522511534200226610ustar00rootroot00000000000000#line 1 package Module::Install::Makefile; use strict 'vars'; use ExtUtils::MakeMaker (); use Module::Install::Base (); use Fcntl qw/:flock :seek/; use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.21'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub Makefile { $_[0] } my %seen = (); sub prompt { shift; # Infinite loop protection my @c = caller(); if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; } # In automated testing or non-interactive session, always use defaults if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { goto &ExtUtils::MakeMaker::prompt; } } # Store a cleaned up version of the MakeMaker version, # since we need to behave differently in a variety of # ways based on the MM version. my $makemaker = eval $ExtUtils::MakeMaker::VERSION; # If we are passed a param, do a "newer than" comparison. # Otherwise, just return the MakeMaker version. sub makemaker { ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0 } # Ripped from ExtUtils::MakeMaker 6.56, and slightly modified # as we only need to know here whether the attribute is an array # or a hash or something else (which may or may not be appendable). my %makemaker_argtype = ( C => 'ARRAY', CONFIG => 'ARRAY', # CONFIGURE => 'CODE', # ignore DIR => 'ARRAY', DL_FUNCS => 'HASH', DL_VARS => 'ARRAY', EXCLUDE_EXT => 'ARRAY', EXE_FILES => 'ARRAY', FUNCLIST => 'ARRAY', H => 'ARRAY', IMPORTS => 'HASH', INCLUDE_EXT => 'ARRAY', LIBS => 'ARRAY', # ignore '' MAN1PODS => 'HASH', MAN3PODS => 'HASH', META_ADD => 'HASH', META_MERGE => 'HASH', PL_FILES => 'HASH', PM => 'HASH', PMLIBDIRS => 'ARRAY', PMLIBPARENTDIRS => 'ARRAY', PREREQ_PM => 'HASH', CONFIGURE_REQUIRES => 'HASH', SKIP => 'ARRAY', TYPEMAPS => 'ARRAY', XS => 'HASH', # VERSION => ['version',''], # ignore # _KEEP_AFTER_FLUSH => '', clean => 'HASH', depend => 'HASH', dist => 'HASH', dynamic_lib=> 'HASH', linkext => 'HASH', macro => 'HASH', postamble => 'HASH', realclean => 'HASH', test => 'HASH', tool_autosplit => 'HASH', # special cases where you can use makemaker_append CCFLAGS => 'APPENDABLE', DEFINE => 'APPENDABLE', INC => 'APPENDABLE', LDDLFLAGS => 'APPENDABLE', LDFROM => 'APPENDABLE', ); sub makemaker_args { my ($self, %new_args) = @_; my $args = ( $self->{makemaker_args} ||= {} ); foreach my $key (keys %new_args) { if ($makemaker_argtype{$key}) { if ($makemaker_argtype{$key} eq 'ARRAY') { $args->{$key} = [] unless defined $args->{$key}; unless (ref $args->{$key} eq 'ARRAY') { $args->{$key} = [$args->{$key}] } push @{$args->{$key}}, ref $new_args{$key} eq 'ARRAY' ? @{$new_args{$key}} : $new_args{$key}; } elsif ($makemaker_argtype{$key} eq 'HASH') { $args->{$key} = {} unless defined $args->{$key}; foreach my $skey (keys %{ $new_args{$key} }) { $args->{$key}{$skey} = $new_args{$key}{$skey}; } } elsif ($makemaker_argtype{$key} eq 'APPENDABLE') { $self->makemaker_append($key => $new_args{$key}); } } else { if (defined $args->{$key}) { warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n}; } $args->{$key} = $new_args{$key}; } } return $args; } # For mm args that take multiple space-separated args, # append an argument to the current list. sub makemaker_append { my $self = shift; my $name = shift; my $args = $self->makemaker_args; $args->{$name} = defined $args->{$name} ? join( ' ', $args->{$name}, @_ ) : join( ' ', @_ ); } sub build_subdirs { my $self = shift; my $subdirs = $self->makemaker_args->{DIR} ||= []; for my $subdir (@_) { push @$subdirs, $subdir; } } sub clean_files { my $self = shift; my $clean = $self->makemaker_args->{clean} ||= {}; %$clean = ( %$clean, FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_), ); } sub realclean_files { my $self = shift; my $realclean = $self->makemaker_args->{realclean} ||= {}; %$realclean = ( %$realclean, FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_), ); } sub libs { my $self = shift; my $libs = ref $_[0] ? shift : [ shift ]; $self->makemaker_args( LIBS => $libs ); } sub inc { my $self = shift; $self->makemaker_args( INC => shift ); } sub _wanted_t { } sub tests_recursive { my $self = shift; my $dir = shift || 't'; unless ( -d $dir ) { die "tests_recursive dir '$dir' does not exist"; } my %tests = map { $_ => 1 } split / /, ($self->tests || ''); require File::Find; File::Find::find( sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 }, $dir ); $self->tests( join ' ', sort keys %tests ); } sub write { my $self = shift; die "&Makefile->write() takes no arguments\n" if @_; # Check the current Perl version my $perl_version = $self->perl_version; if ( $perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } # Make sure we have a new enough MakeMaker require ExtUtils::MakeMaker; if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) { # This previous attempted to inherit the version of # ExtUtils::MakeMaker in use by the module author, but this # was found to be untenable as some authors build releases # using future dev versions of EU:MM that nobody else has. # Instead, #toolchain suggests we use 6.59 which is the most # stable version on CPAN at time of writing and is, to quote # ribasushi, "not terminally fucked, > and tested enough". # TODO: We will now need to maintain this over time to push # the version up as new versions are released. $self->build_requires( 'ExtUtils::MakeMaker' => 6.59 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.59 ); } else { # Allow legacy-compatibility with 5.005 by depending on the # most recent EU:MM that supported 5.005. $self->build_requires( 'ExtUtils::MakeMaker' => 6.36 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.36 ); } # Generate the MakeMaker params my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name || $self->name; $args->{NAME} =~ s/-/::/g; $args->{VERSION} = $self->version or die <<'EOT'; ERROR: Can't determine distribution version. Please specify it explicitly via 'version' in Makefile.PL, or set a valid $VERSION in a module, and provide its file path via 'version_from' (or 'all_from' if you prefer) in Makefile.PL. EOT if ( $self->tests ) { my @tests = split ' ', $self->tests; my %seen; $args->{test} = { TESTS => (join ' ', grep {!$seen{$_}++} @tests), }; } elsif ( $Module::Install::ExtraTests::use_extratests ) { # Module::Install::ExtraTests doesn't set $self->tests and does its own tests via harness. # So, just ignore our xt tests here. } elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) { $args->{test} = { TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ), }; } if ( $] >= 5.005 ) { $args->{ABSTRACT} = $self->abstract; $args->{AUTHOR} = join ', ', @{$self->author || []}; } if ( $self->makemaker(6.10) ) { $args->{NO_META} = 1; #$args->{NO_MYMETA} = 1; } if ( $self->makemaker(6.17) and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } if ( $self->makemaker(6.31) and $self->license ) { $args->{LICENSE} = $self->license; } my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->requires) ); # Remove any reference to perl, PREREQ_PM doesn't support it delete $args->{PREREQ_PM}->{perl}; # Merge both kinds of requires into BUILD_REQUIRES my $build_prereq = ($args->{BUILD_REQUIRES} ||= {}); %$build_prereq = ( %$build_prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->configure_requires, $self->build_requires) ); # Remove any reference to perl, BUILD_REQUIRES doesn't support it delete $args->{BUILD_REQUIRES}->{perl}; # Delete bundled dists from prereq_pm, add it to Makefile DIR my $subdirs = ($args->{DIR} || []); if ($self->bundles) { my %processed; foreach my $bundle (@{ $self->bundles }) { my ($mod_name, $dist_dir) = @$bundle; delete $prereq->{$mod_name}; $dist_dir = File::Basename::basename($dist_dir); # dir for building this module if (not exists $processed{$dist_dir}) { if (-d $dist_dir) { # List as sub-directory to be processed by make push @$subdirs, $dist_dir; } # Else do nothing: the module is already present on the system $processed{$dist_dir} = undef; } } } unless ( $self->makemaker('6.55_03') ) { %$prereq = (%$prereq,%$build_prereq); delete $args->{BUILD_REQUIRES}; } if ( my $perl_version = $self->perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; if ( $self->makemaker(6.48) ) { $args->{MIN_PERL_VERSION} = $perl_version; } } if ($self->installdirs) { warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS}; $args->{INSTALLDIRS} = $self->installdirs; } my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_} ) } keys %$args; my $user_preop = delete $args{dist}->{PREOP}; if ( my $preop = $self->admin->preop($user_preop) ) { foreach my $key ( keys %$preop ) { $args{dist}->{$key} = $preop->{$key}; } } my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); } sub fix_up_makefile { my $self = shift; my $makefile_name = shift; my $top_class = ref($self->_top) || ''; my $top_version = $self->_top->VERSION || ''; my $preamble = $self->preamble ? "# Preamble by $top_class $top_version\n" . $self->preamble : ''; my $postamble = "# Postamble by $top_class $top_version\n" . ($self->postamble || ''); local *MAKEFILE; open MAKEFILE, "+< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; eval { flock MAKEFILE, LOCK_EX }; my $makefile = do { local $/; }; $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; # Module::Install will never be used to build the Core Perl # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well. $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g; # XXX - This is currently unused; not sure if it breaks other MM-users # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; seek MAKEFILE, 0, SEEK_SET; truncate MAKEFILE, 0; print MAKEFILE "$preamble$makefile$postamble" or die $!; close MAKEFILE or die $!; 1; } sub preamble { my ($self, $text) = @_; $self->{preamble} = $text . $self->{preamble} if defined $text; $self->{preamble}; } sub postamble { my ($self, $text) = @_; $self->{postamble} ||= $self->admin->postamble; $self->{postamble} .= $text if defined $text; $self->{postamble} } 1; __END__ #line 544 libtest-nginx-perl-0.32/inc/Module/Install/Metadata.pm000066400000000000000000000434371522511534200226620ustar00rootroot00000000000000#line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.21'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } my @boolean_keys = qw{ sign }; my @scalar_keys = qw{ name module_name abstract version distribution_type tests installdirs }; my @tuple_keys = qw{ configure_requires build_requires requires recommends bundles resources }; my @resource_keys = qw{ homepage bugtracker repository }; my @array_keys = qw{ keywords author }; *authors = \&author; sub Meta { shift } sub Meta_BooleanKeys { @boolean_keys } sub Meta_ScalarKeys { @scalar_keys } sub Meta_TupleKeys { @tuple_keys } sub Meta_ResourceKeys { @resource_keys } sub Meta_ArrayKeys { @array_keys } foreach my $key ( @boolean_keys ) { *$key = sub { my $self = shift; if ( defined wantarray and not @_ ) { return $self->{values}->{$key}; } $self->{values}->{$key} = ( @_ ? $_[0] : 1 ); return $self; }; } foreach my $key ( @scalar_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} = shift; return $self; }; } foreach my $key ( @array_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} ||= []; push @{$self->{values}->{$key}}, @_; return $self; }; } foreach my $key ( @resource_keys ) { *$key = sub { my $self = shift; unless ( @_ ) { return () unless $self->{values}->{resources}; return map { $_->[1] } grep { $_->[0] eq $key } @{ $self->{values}->{resources} }; } return $self->{values}->{resources}->{$key} unless @_; my $uri = shift or die( "Did not provide a value to $key()" ); $self->resources( $key => $uri ); return 1; }; } foreach my $key ( grep { $_ ne "resources" } @tuple_keys) { *$key = sub { my $self = shift; return $self->{values}->{$key} unless @_; my @added; while ( @_ ) { my $module = shift or last; my $version = shift || 0; push @added, [ $module, $version ]; } push @{ $self->{values}->{$key} }, @added; return map {@$_} @added; }; } # Resource handling my %lc_resource = map { $_ => 1 } qw{ homepage license bugtracker repository }; sub resources { my $self = shift; while ( @_ ) { my $name = shift or last; my $value = shift or next; if ( $name eq lc $name and ! $lc_resource{$name} ) { die("Unsupported reserved lowercase resource '$name'"); } $self->{values}->{resources} ||= []; push @{ $self->{values}->{resources} }, [ $name, $value ]; } $self->{values}->{resources}; } # Aliases for build_requires that will have alternative # meanings in some future version of META.yml. sub test_requires { shift->build_requires(@_) } sub install_requires { shift->build_requires(@_) } # Aliases for installdirs options sub install_as_core { $_[0]->installdirs('perl') } sub install_as_cpan { $_[0]->installdirs('site') } sub install_as_site { $_[0]->installdirs('site') } sub install_as_vendor { $_[0]->installdirs('vendor') } sub dynamic_config { my $self = shift; my $value = @_ ? shift : 1; if ( $self->{values}->{dynamic_config} ) { # Once dynamic we never change to static, for safety return 0; } $self->{values}->{dynamic_config} = $value ? 1 : 0; return 1; } # Convenience command sub static_config { shift->dynamic_config(0); } sub perl_version { my $self = shift; return $self->{values}->{perl_version} unless @_; my $version = shift or die( "Did not provide a value to perl_version()" ); # Normalize the version $version = $self->_perl_version($version); # We don't support the really old versions unless ( $version >= 5.005 ) { die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n"; } $self->{values}->{perl_version} = $version; } sub all_from { my ( $self, $file ) = @_; unless ( defined($file) ) { my $name = $self->name or die( "all_from called with no args without setting name() first" ); $file = join('/', 'lib', split(/-/, $name)) . '.pm'; $file =~ s{.*/}{} unless -e $file; unless ( -e $file ) { die("all_from cannot find $file from $name"); } } unless ( -f $file ) { die("The path '$file' does not exist, or is not a file"); } $self->{values}{all_from} = $file; # Some methods pull from POD instead of code. # If there is a matching .pod, use that instead my $pod = $file; $pod =~ s/\.pm$/.pod/i; $pod = $file unless -e $pod; # Pull the different values $self->name_from($file) unless $self->name; $self->version_from($file) unless $self->version; $self->perl_version_from($file) unless $self->perl_version; $self->author_from($pod) unless @{$self->author || []}; $self->license_from($pod) unless $self->license; $self->abstract_from($pod) unless $self->abstract; return 1; } sub provides { my $self = shift; my $provides = ( $self->{values}->{provides} ||= {} ); %$provides = (%$provides, @_) if @_; return $provides; } sub auto_provides { my $self = shift; return $self unless $self->is_admin; unless (-e 'MANIFEST') { warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; return $self; } # Avoid spurious warnings as we are not checking manifest here. local $SIG{__WARN__} = sub {1}; require ExtUtils::Manifest; local *ExtUtils::Manifest::manicheck = sub { return }; require Module::Build; my $build = Module::Build->new( dist_name => $self->name, dist_version => $self->version, license => $self->license, ); $self->provides( %{ $build->find_dist_packages || {} } ); } sub feature { my $self = shift; my $name = shift; my $features = ( $self->{values}->{features} ||= [] ); my $mods; if ( @_ == 1 and ref( $_[0] ) ) { # The user used ->feature like ->features by passing in the second # argument as a reference. Accomodate for that. $mods = $_[0]; } else { $mods = \@_; } my $count = 0; push @$features, ( $name => [ map { ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ } @$mods ] ); return @$features; } sub features { my $self = shift; while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { $self->feature( $name, @$mods ); } return $self->{values}->{features} ? @{ $self->{values}->{features} } : (); } sub no_index { my $self = shift; my $type = shift; push @{ $self->{values}->{no_index}->{$type} }, @_ if $type; return $self->{values}->{no_index}; } sub read { my $self = shift; $self->include_deps( 'YAML::Tiny', 0 ); require YAML::Tiny; my $data = YAML::Tiny::LoadFile('META.yml'); # Call methods explicitly in case user has already set some values. while ( my ( $key, $value ) = each %$data ) { next unless $self->can($key); if ( ref $value eq 'HASH' ) { while ( my ( $module, $version ) = each %$value ) { $self->can($key)->($self, $module => $version ); } } else { $self->can($key)->($self, $value); } } return $self; } sub write { my $self = shift; return $self unless $self->is_admin; $self->admin->write_meta; return $self; } sub version_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->version( ExtUtils::MM_Unix->parse_version($file) ); # for version integrity check $self->makemaker_args( VERSION_FROM => $file ); } sub abstract_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->abstract( bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix' )->parse_abstract($file) ); } # Add both distribution and module name sub name_from { my ($self, $file) = @_; if ( Module::Install::_read($file) =~ m/ ^ \s* package \s* ([\w:]+) [\s|;]* /ixms ) { my ($name, $module_name) = ($1, $1); $name =~ s{::}{-}g; $self->name($name); unless ( $self->module_name ) { $self->module_name($module_name); } } else { die("Cannot determine name from $file\n"); } } sub _extract_perl_version { if ( $_[0] =~ m/ ^\s* (?:use|require) \s* v? ([\d_\.]+) \s* ; /ixms ) { my $perl_version = $1; $perl_version =~ s{_}{}g; return $perl_version; } else { return; } } sub perl_version_from { my $self = shift; my $perl_version=_extract_perl_version(Module::Install::_read($_[0])); if ($perl_version) { $self->perl_version($perl_version); } else { warn "Cannot determine perl version info from $_[0]\n"; return; } } sub author_from { my $self = shift; my $content = Module::Install::_read($_[0]); if ($content =~ m/ =head \d \s+ (?:authors?)\b \s* ([^\n]*) | =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* ([^\n]*) /ixms) { my $author = $1 || $2; # XXX: ugly but should work anyway... if (eval "require Pod::Escapes; 1") { # Pod::Escapes has a mapping table. # It's in core of perl >= 5.9.3, and should be installed # as one of the Pod::Simple's prereqs, which is a prereq # of Pod::Text 3.x (see also below). $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $Pod::Escapes::Name2character_number{$1} ? chr($Pod::Escapes::Name2character_number{$1}) : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) { # Pod::Text < 3.0 has yet another mapping table, # though the table name of 2.x and 1.x are different. # (1.x is in core of Perl < 5.6, 2.x is in core of # Perl < 5.9.3) my $mapping = ($Pod::Text::VERSION < 2) ? \%Pod::Text::HTML_Escapes : \%Pod::Text::ESCAPES; $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $mapping->{$1} ? $mapping->{$1} : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } else { $author =~ s{E}{<}g; $author =~ s{E}{>}g; } $self->author($author); } else { warn "Cannot determine author info from $_[0]\n"; } } #Stolen from M::B my %license_urls = ( perl => 'http://dev.perl.org/licenses/', apache => 'http://apache.org/licenses/LICENSE-2.0', artistic => 'http://opensource.org/licenses/artistic-license.php', lgpl => 'http://opensource.org/licenses/lgpl-license.php', bsd => 'http://opensource.org/licenses/bsd-license.php', gpl => 'http://opensource.org/licenses/gpl-license.php', gpl2 => 'http://opensource.org/licenses/gpl-2.0.php', gpl3 => 'http://opensource.org/licenses/gpl-3.0.html', mit => 'http://opensource.org/licenses/mit-license.php', mozilla => 'http://opensource.org/licenses/mozilla1.1.php', open_source => undef, unrestricted => undef, restrictive => undef, unknown => undef, # these are not actually allowed in meta-spec v1.4 but are left here for compatibility: apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1', artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php', lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php', lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html', ); sub license { my $self = shift; return $self->{values}->{license} unless @_; my $license = shift or die( 'Did not provide a value to license()' ); $license = __extract_license($license) || lc $license; $self->{values}->{license} = $license; # Automatically fill in license URLs if ( $license_urls{$license} ) { $self->resources( license => $license_urls{$license} ); } return 1; } sub _extract_license { my $pod = shift; my $matched; return __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ L(?i:ICEN[CS]E|ICENSING)\b.*?) (=head \d.*|=cut.*|)\z /xms ) || __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ (?:C(?i:OPYRIGHTS?)|L(?i:EGAL))\b.*?) (=head \d.*|=cut.*|)\z /xms ); } sub __extract_license { my $license_text = shift or return; my @phrases = ( '(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1, '(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1, 'Artistic and GPL' => 'perl', 1, 'GNU general public license' => 'gpl', 1, 'GNU public license' => 'gpl', 1, 'GNU lesser general public license' => 'lgpl', 1, 'GNU lesser public license' => 'lgpl', 1, 'GNU library general public license' => 'lgpl', 1, 'GNU library public license' => 'lgpl', 1, 'GNU Free Documentation license' => 'unrestricted', 1, 'GNU Affero General Public License' => 'open_source', 1, '(?:Free)?BSD license' => 'bsd', 1, 'Artistic license 2\.0' => 'artistic_2', 1, 'Artistic license' => 'artistic', 1, 'Apache (?:Software )?license' => 'apache', 1, 'GPL' => 'gpl', 1, 'LGPL' => 'lgpl', 1, 'BSD' => 'bsd', 1, 'Artistic' => 'artistic', 1, 'MIT' => 'mit', 1, 'Mozilla Public License' => 'mozilla', 1, 'Q Public License' => 'open_source', 1, 'OpenSSL License' => 'unrestricted', 1, 'SSLeay License' => 'unrestricted', 1, 'zlib License' => 'open_source', 1, 'proprietary' => 'proprietary', 0, ); while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { $pattern =~ s#\s+#\\s+#gs; if ( $license_text =~ /\b$pattern\b/i ) { return $license; } } return ''; } sub license_from { my $self = shift; if (my $license=_extract_license(Module::Install::_read($_[0]))) { $self->license($license); } else { warn "Cannot determine license info from $_[0]\n"; return 'unknown'; } } sub _extract_bugtracker { my @links = $_[0] =~ m#L<( https?\Q://rt.cpan.org/\E[^>]+| https?\Q://github.com/\E[\w_]+/[\w_]+/issues| https?\Q://code.google.com/p/\E[\w_\-]+/issues/list )>#gx; my %links; @links{@links}=(); @links=keys %links; return @links; } sub bugtracker_from { my $self = shift; my $content = Module::Install::_read($_[0]); my @links = _extract_bugtracker($content); unless ( @links ) { warn "Cannot determine bugtracker info from $_[0]\n"; return 0; } if ( @links > 1 ) { warn "Found more than one bugtracker link in $_[0]\n"; return 0; } # Set the bugtracker bugtracker( $links[0] ); return 1; } sub requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+(v?[\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->requires( $module => $version ); } } sub test_requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->test_requires( $module => $version ); } } # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to # numbers (eg, 5.006001 or 5.008009). # Also, convert double-part versions (eg, 5.8) sub _perl_version { my $v = $_[-1]; $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e; $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e; $v =~ s/(\.\d\d\d)000$/$1/; $v =~ s/_.+$//; if ( ref($v) ) { # Numify $v = $v + 0; } return $v; } sub add_metadata { my $self = shift; my %hash = @_; for my $key (keys %hash) { warn "add_metadata: $key is not prefixed with 'x_'.\n" . "Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/; $self->{values}->{$key} = $hash{$key}; } } ###################################################################### # MYMETA Support sub WriteMyMeta { die "WriteMyMeta has been deprecated"; } sub write_mymeta_yaml { my $self = shift; # We need YAML::Tiny to write the MYMETA.yml file unless ( eval { require YAML::Tiny; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.yml\n"; YAML::Tiny::DumpFile('MYMETA.yml', $meta); } sub write_mymeta_json { my $self = shift; # We need JSON to write the MYMETA.json file unless ( eval { require JSON; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.json\n"; Module::Install::_write( 'MYMETA.json', JSON->new->pretty(1)->canonical->encode($meta), ); } sub _write_mymeta_data { my $self = shift; # If there's no existing META.yml there is nothing we can do return undef unless -f 'META.yml'; # We need Parse::CPAN::Meta to load the file unless ( eval { require Parse::CPAN::Meta; 1; } ) { return undef; } # Merge the perl version into the dependencies my $val = $self->Meta->{values}; my $perl = delete $val->{perl_version}; if ( $perl ) { $val->{requires} ||= []; my $requires = $val->{requires}; # Canonize to three-dot version after Perl 5.6 if ( $perl >= 5.006 ) { $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e } unshift @$requires, [ perl => $perl ]; } # Load the advisory META.yml file my @yaml = Parse::CPAN::Meta::LoadFile('META.yml'); my $meta = $yaml[0]; # Overwrite the non-configure dependency hashes delete $meta->{requires}; delete $meta->{build_requires}; delete $meta->{recommends}; if ( exists $val->{requires} ) { $meta->{requires} = { map { @$_ } @{ $val->{requires} } }; } if ( exists $val->{build_requires} ) { $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } }; } return $meta; } 1; libtest-nginx-perl-0.32/inc/Module/Install/TestBase.pm000066400000000000000000000010011522511534200226310ustar00rootroot00000000000000#line 1 package Module::Install::TestBase; use strict; use warnings; use Module::Install::Base; use vars qw($VERSION @ISA); BEGIN { $VERSION = '0.86'; @ISA = 'Module::Install::Base'; } sub use_test_base { my $self = shift; $self->include('Test::Base'); $self->include('Test::Base::Filter'); $self->include('Spiffy'); $self->include('Test::More'); $self->include('Test::Builder'); $self->include('Test::Builder::Module'); $self->requires('Filter::Util::Call'); } 1; libtest-nginx-perl-0.32/inc/Module/Install/Win32.pm000066400000000000000000000034031522511534200220310ustar00rootroot00000000000000#line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.21'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # determine if the user needs nmake, and download it if needed sub check_nmake { my $self = shift; $self->load('can_run'); $self->load('get_file'); require Config; return unless ( $^O eq 'MSWin32' and $Config::Config{make} and $Config::Config{make} =~ /^nmake\b/i and ! $self->can_run('nmake') ); print "The required 'nmake' executable not found, fetching it...\n"; require File::Basename; my $rv = $self->get_file( url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe', ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe', local_dir => File::Basename::dirname($^X), size => 51928, run => 'Nmake15.exe /o > nul', check_for => 'Nmake.exe', remove => 1, ); die <<'END_MESSAGE' unless $rv; ------------------------------------------------------------------------------- Since you are using Microsoft Windows, you will need the 'nmake' utility before installation. It's available at: http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe or ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe Please download the file manually, save it to a directory in %PATH% (e.g. C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to that directory, and run "Nmake15.exe" from there; that will create the 'nmake.exe' file needed by this module. You may then resume the installation process described in README. ------------------------------------------------------------------------------- END_MESSAGE } 1; libtest-nginx-perl-0.32/inc/Module/Install/WriteAll.pm000066400000000000000000000023761522511534200226620ustar00rootroot00000000000000#line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.21'; @ISA = qw{Module::Install::Base}; $ISCORE = 1; } sub WriteAll { my $self = shift; my %args = ( meta => 1, sign => 0, inline => 0, check_nmake => 1, @_, ); $self->sign(1) if $args{sign}; $self->admin->WriteAll(%args) if $self->is_admin; $self->check_nmake if $args{check_nmake}; unless ( $self->makemaker_args->{PL_FILES} ) { # XXX: This still may be a bit over-defensive... unless ($self->makemaker(6.25)) { $self->makemaker_args( PL_FILES => {} ) if -f 'Build.PL'; } } # Until ExtUtils::MakeMaker support MYMETA.yml, make sure # we clean it up properly ourself. $self->realclean_files('MYMETA.yml'); if ( $args{inline} ) { $self->Inline->write; } else { $self->Makefile->write; } # The Makefile write process adds a couple of dependencies, # so write the META.yml files after the Makefile. if ( $args{meta} ) { $self->Meta->write; } # Experimental support for MYMETA if ( $ENV{X_MYMETA} ) { if ( $ENV{X_MYMETA} eq 'JSON' ) { $self->Meta->write_mymeta_json; } else { $self->Meta->write_mymeta_yaml; } } return 1; } 1; libtest-nginx-perl-0.32/inc/Spiffy.pm000066400000000000000000000362051522511534200175420ustar00rootroot00000000000000#line 1 use strict; use warnings; package Spiffy; our $VERSION = '0.46'; use Carp; require Exporter; our @EXPORT = (); our @EXPORT_BASE = qw(field const stub super); our @EXPORT_OK = (@EXPORT_BASE, qw(id WWW XXX YYY ZZZ)); our %EXPORT_TAGS = (XXX => [qw(WWW XXX YYY ZZZ)]); my $stack_frame = 0; my $dump = 'yaml'; my $bases_map = {}; sub WWW; sub XXX; sub YYY; sub ZZZ; # This line is here to convince "autouse" into believing we are autousable. sub can { ($_[1] eq 'import' and caller()->isa('autouse')) ? \&Exporter::import # pacify autouse's equality test : $_[0]->SUPER::can($_[1]) # normal case } # TODO # # Exported functions like field and super should be hidden so as not to # be confused with methods that can be inherited. # sub new { my $class = shift; $class = ref($class) || $class; my $self = bless {}, $class; while (@_) { my $method = shift; $self->$method(shift); } return $self; } my $filtered_files = {}; my $filter_dump = 0; my $filter_save = 0; our $filter_result = ''; sub import { no strict 'refs'; no warnings; my $self_package = shift; # XXX Using parse_arguments here might cause confusion, because the # subclass's boolean_arguments and paired_arguments can conflict, causing # difficult debugging. Consider using something truly local. my ($args, @export_list) = do { local *boolean_arguments = sub { qw( -base -Base -mixin -selfless -XXX -dumper -yaml -filter_dump -filter_save ) }; local *paired_arguments = sub { qw(-package) }; $self_package->parse_arguments(@_); }; return spiffy_mixin_import(scalar(caller(0)), $self_package, @export_list) if $args->{-mixin}; $filter_dump = 1 if $args->{-filter_dump}; $filter_save = 1 if $args->{-filter_save}; $dump = 'yaml' if $args->{-yaml}; $dump = 'dumper' if $args->{-dumper}; local @EXPORT_BASE = @EXPORT_BASE; if ($args->{-XXX}) { push @EXPORT_BASE, @{$EXPORT_TAGS{XXX}} unless grep /^XXX$/, @EXPORT_BASE; } spiffy_filter() if ($args->{-selfless} or $args->{-Base}) and not $filtered_files->{(caller($stack_frame))[1]}++; my $caller_package = $args->{-package} || caller($stack_frame); push @{"$caller_package\::ISA"}, $self_package if $args->{-Base} or $args->{-base}; for my $class (@{all_my_bases($self_package)}) { next unless $class->isa('Spiffy'); my @export = grep { not defined &{"$caller_package\::$_"}; } ( @{"$class\::EXPORT"}, ($args->{-Base} or $args->{-base}) ? @{"$class\::EXPORT_BASE"} : (), ); my @export_ok = grep { not defined &{"$caller_package\::$_"}; } @{"$class\::EXPORT_OK"}; # Avoid calling the expensive Exporter::export # if there is nothing to do (optimization) my %exportable = map { ($_, 1) } @export, @export_ok; next unless keys %exportable; my @export_save = @{"$class\::EXPORT"}; my @export_ok_save = @{"$class\::EXPORT_OK"}; @{"$class\::EXPORT"} = @export; @{"$class\::EXPORT_OK"} = @export_ok; my @list = grep { (my $v = $_) =~ s/^[\!\:]//; $exportable{$v} or ${"$class\::EXPORT_TAGS"}{$v}; } @export_list; Exporter::export($class, $caller_package, @list); @{"$class\::EXPORT"} = @export_save; @{"$class\::EXPORT_OK"} = @export_ok_save; } } sub spiffy_filter { require Filter::Util::Call; my $done = 0; Filter::Util::Call::filter_add( sub { return 0 if $done; my ($data, $end) = ('', ''); while (my $status = Filter::Util::Call::filter_read()) { return $status if $status < 0; if (/^__(?:END|DATA)__\r?$/) { $end = $_; last; } $data .= $_; $_ = ''; } $_ = $data; my @my_subs; s[^(sub\s+\w+\s+\{)(.*\n)] [${1}my \$self = shift;$2]gm; s[^(sub\s+\w+)\s*\(\s*\)(\s+\{.*\n)] [${1}${2}]gm; s[^my\s+sub\s+(\w+)(\s+\{)(.*)((?s:.*?\n))\}\n] [push @my_subs, $1; "\$$1 = sub$2my \$self = shift;$3$4\};\n"]gem; my $preclare = ''; if (@my_subs) { $preclare = join ',', map "\$$_", @my_subs; $preclare = "my($preclare);"; } $_ = "use strict;use warnings;$preclare${_};1;\n$end"; if ($filter_dump) { print; exit } if ($filter_save) { $filter_result = $_; $_ = $filter_result; } $done = 1; } ); } sub base { push @_, -base; goto &import; } sub all_my_bases { my $class = shift; return $bases_map->{$class} if defined $bases_map->{$class}; my @bases = ($class); no strict 'refs'; for my $base_class (@{"${class}::ISA"}) { push @bases, @{all_my_bases($base_class)}; } my $used = {}; $bases_map->{$class} = [grep {not $used->{$_}++} @bases]; } my %code = ( sub_start => "sub {\n", set_default => " \$_[0]->{%s} = %s\n unless exists \$_[0]->{%s};\n", init => " return \$_[0]->{%s} = do { my \$self = \$_[0]; %s }\n" . " unless \$#_ > 0 or defined \$_[0]->{%s};\n", weak_init => " return do {\n" . " \$_[0]->{%s} = do { my \$self = \$_[0]; %s };\n" . " Scalar::Util::weaken(\$_[0]->{%s}) if ref \$_[0]->{%s};\n" . " \$_[0]->{%s};\n" . " } unless \$#_ > 0 or defined \$_[0]->{%s};\n", return_if_get => " return \$_[0]->{%s} unless \$#_ > 0;\n", set => " \$_[0]->{%s} = \$_[1];\n", weaken => " Scalar::Util::weaken(\$_[0]->{%s}) if ref \$_[0]->{%s};\n", sub_end => " return \$_[0]->{%s};\n}\n", ); sub field { my $package = caller; my ($args, @values) = do { no warnings; local *boolean_arguments = sub { (qw(-weak)) }; local *paired_arguments = sub { (qw(-package -init)) }; Spiffy->parse_arguments(@_); }; my ($field, $default) = @values; $package = $args->{-package} if defined $args->{-package}; die "Cannot have a default for a weakened field ($field)" if defined $default && $args->{-weak}; return if defined &{"${package}::$field"}; require Scalar::Util if $args->{-weak}; my $default_string = ( ref($default) eq 'ARRAY' and not @$default ) ? '[]' : (ref($default) eq 'HASH' and not keys %$default ) ? '{}' : default_as_code($default); my $code = $code{sub_start}; if ($args->{-init}) { my $fragment = $args->{-weak} ? $code{weak_init} : $code{init}; my @count = ($fragment =~ /(%s)/g); $code .= sprintf $fragment, $field, $args->{-init}, ($field) x (@count - 2); } $code .= sprintf $code{set_default}, $field, $default_string, $field if defined $default; $code .= sprintf $code{return_if_get}, $field; $code .= sprintf $code{set}, $field; $code .= sprintf $code{weaken}, $field, $field if $args->{-weak}; $code .= sprintf $code{sub_end}, $field; my $sub = eval $code; die $@ if $@; no strict 'refs'; *{"${package}::$field"} = $sub; return $code if defined wantarray; } sub default_as_code { require Data::Dumper; local $Data::Dumper::Sortkeys = 1; my $code = Data::Dumper::Dumper(shift); $code =~ s/^\$VAR1 = //; $code =~ s/;$//; return $code; } sub const { my $package = caller; my ($args, @values) = do { no warnings; local *paired_arguments = sub { (qw(-package)) }; Spiffy->parse_arguments(@_); }; my ($field, $default) = @values; $package = $args->{-package} if defined $args->{-package}; no strict 'refs'; return if defined &{"${package}::$field"}; *{"${package}::$field"} = sub { $default } } sub stub { my $package = caller; my ($args, @values) = do { no warnings; local *paired_arguments = sub { (qw(-package)) }; Spiffy->parse_arguments(@_); }; my ($field, $default) = @values; $package = $args->{-package} if defined $args->{-package}; no strict 'refs'; return if defined &{"${package}::$field"}; *{"${package}::$field"} = sub { require Carp; Carp::confess "Method $field in package $package must be subclassed"; } } sub parse_arguments { my $class = shift; my ($args, @values) = ({}, ()); my %booleans = map { ($_, 1) } $class->boolean_arguments; my %pairs = map { ($_, 1) } $class->paired_arguments; while (@_) { my $elem = shift; if (defined $elem and defined $booleans{$elem}) { $args->{$elem} = (@_ and $_[0] =~ /^[01]$/) ? shift : 1; } elsif (defined $elem and defined $pairs{$elem} and @_) { $args->{$elem} = shift; } else { push @values, $elem; } } return wantarray ? ($args, @values) : $args; } sub boolean_arguments { () } sub paired_arguments { () } # get a unique id for any node sub id { if (not ref $_[0]) { return 'undef' if not defined $_[0]; \$_[0] =~ /\((\w+)\)$/o or die; return "$1-S"; } require overload; overload::StrVal($_[0]) =~ /\((\w+)\)$/o or die; return $1; } #=============================================================================== # It's super, man. #=============================================================================== package DB; { no warnings 'redefine'; sub super_args { my @dummy = caller(@_ ? $_[0] : 2); return @DB::args; } } package Spiffy; sub super { my $method; my $frame = 1; while ($method = (caller($frame++))[3]) { $method =~ s/.*::// and last; } my @args = DB::super_args($frame); @_ = @_ ? ($args[0], @_) : @args; my $class = ref $_[0] ? ref $_[0] : $_[0]; my $caller_class = caller; my $seen = 0; my @super_classes = reverse grep { ($seen or $seen = ($_ eq $caller_class)) ? 0 : 1; } reverse @{all_my_bases($class)}; for my $super_class (@super_classes) { no strict 'refs'; next if $super_class eq $class; if (defined &{"${super_class}::$method"}) { ${"$super_class\::AUTOLOAD"} = ${"$class\::AUTOLOAD"} if $method eq 'AUTOLOAD'; return &{"${super_class}::$method"}; } } return; } #=============================================================================== # This code deserves a spanking, because it is being very naughty. # It is exchanging base.pm's import() for its own, so that people # can use base.pm with Spiffy modules, without being the wiser. #=============================================================================== my $real_base_import; my $real_mixin_import; BEGIN { require base unless defined $INC{'base.pm'}; $INC{'mixin.pm'} ||= 'Spiffy/mixin.pm'; $real_base_import = \&base::import; $real_mixin_import = \&mixin::import; no warnings; *base::import = \&spiffy_base_import; *mixin::import = \&spiffy_mixin_import; } # my $i = 0; # while (my $caller = caller($i++)) { # next unless $caller eq 'base' or $caller eq 'mixin'; # croak <isa('Spiffy'); } @base_classes; my $inheritor = caller(0); for my $base_class (@base_classes) { next if $inheritor->isa($base_class); croak "Can't mix Spiffy and non-Spiffy classes in 'use base'.\n", "See the documentation of Spiffy.pm for details\n " unless $base_class->isa('Spiffy'); $stack_frame = 1; # tell import to use different caller import($base_class, '-base'); $stack_frame = 0; } } sub mixin { my $self = shift; my $target_class = ref($self); spiffy_mixin_import($target_class, @_) } sub spiffy_mixin_import { my $target_class = shift; $target_class = caller(0) if $target_class eq 'mixin'; my $mixin_class = shift or die "Nothing to mixin"; eval "require $mixin_class"; my @roles = @_; my $pseudo_class = join '-', $target_class, $mixin_class, @roles; my %methods = spiffy_mixin_methods($mixin_class, @roles); no strict 'refs'; no warnings; @{"$pseudo_class\::ISA"} = @{"$target_class\::ISA"}; @{"$target_class\::ISA"} = ($pseudo_class); for (keys %methods) { *{"$pseudo_class\::$_"} = $methods{$_}; } } sub spiffy_mixin_methods { my $mixin_class = shift; no strict 'refs'; my %methods = spiffy_all_methods($mixin_class); map { $methods{$_} ? ($_, \ &{"$methods{$_}\::$_"}) : ($_, \ &{"$mixin_class\::$_"}) } @_ ? (get_roles($mixin_class, @_)) : (keys %methods); } sub get_roles { my $mixin_class = shift; my @roles = @_; while (grep /^!*:/, @roles) { @roles = map { s/!!//g; /^!:(.*)/ ? do { my $m = "_role_$1"; map("!$_", $mixin_class->$m); } : /^:(.*)/ ? do { my $m = "_role_$1"; ($mixin_class->$m); } : ($_) } @roles; } if (@roles and $roles[0] =~ /^!/) { my %methods = spiffy_all_methods($mixin_class); unshift @roles, keys(%methods); } my %roles; for (@roles) { s/!!//g; delete $roles{$1}, next if /^!(.*)/; $roles{$_} = 1; } keys %roles; } sub spiffy_all_methods { no strict 'refs'; my $class = shift; return if $class eq 'Spiffy'; my %methods = map { ($_, $class) } grep { defined &{"$class\::$_"} and not /^_/ } keys %{"$class\::"}; my %super_methods; %super_methods = spiffy_all_methods(${"$class\::ISA"}[0]) if @{"$class\::ISA"}; %{{%super_methods, %methods}}; } # END of naughty code. #=============================================================================== # Debugging support #=============================================================================== sub spiffy_dump { no warnings; if ($dump eq 'dumper') { require Data::Dumper; $Data::Dumper::Sortkeys = 1; $Data::Dumper::Indent = 1; return Data::Dumper::Dumper(@_); } require YAML; $YAML::UseVersion = 0; return YAML::Dump(@_) . "...\n"; } sub at_line_number { my ($file_path, $line_number) = (caller(1))[1,2]; " at $file_path line $line_number\n"; } sub WWW { warn spiffy_dump(@_) . at_line_number; return wantarray ? @_ : $_[0]; } sub XXX { die spiffy_dump(@_) . at_line_number; } sub YYY { print spiffy_dump(@_) . at_line_number; return wantarray ? @_ : $_[0]; } sub ZZZ { require Carp; Carp::confess spiffy_dump(@_); } 1; libtest-nginx-perl-0.32/inc/Test/000077500000000000000000000000001522511534200166555ustar00rootroot00000000000000libtest-nginx-perl-0.32/inc/Test/Base.pm000066400000000000000000000436341522511534200200770ustar00rootroot00000000000000#line 1 package Test::Base; our $VERSION = '0.89'; use Spiffy -Base; use Spiffy ':XXX'; my $HAS_PROVIDER; BEGIN { $HAS_PROVIDER = eval "require Test::Builder::Provider; 1"; if ($HAS_PROVIDER) { Test::Builder::Provider->import('provides'); } else { *provides = sub { 1 }; } } my @test_more_exports; BEGIN { @test_more_exports = qw( ok isnt like unlike is_deeply cmp_ok skip todo_skip pass fail eq_array eq_hash eq_set plan can_ok isa_ok diag use_ok $TODO ); } use Test::More import => \@test_more_exports; use Carp; our @EXPORT = (@test_more_exports, qw( is no_diff blocks next_block first_block delimiters spec_file spec_string filters filters_delay filter_arguments run run_compare run_is run_is_deeply run_like run_unlike skip_all_unless_require is_deep run_is_deep WWW XXX YYY ZZZ tie_output no_diag_on_only find_my_self default_object croak carp cluck confess )); field '_spec_file'; field '_spec_string'; field _filters => [qw(norm trim)]; field _filters_map => {}; field spec => -init => '$self->_spec_init'; field block_list => -init => '$self->_block_list_init'; field _next_list => []; field block_delim => -init => '$self->block_delim_default'; field data_delim => -init => '$self->data_delim_default'; field _filters_delay => 0; field _no_diag_on_only => 0; field block_delim_default => '==='; field data_delim_default => '---'; my $default_class; my $default_object; my $reserved_section_names = {}; sub default_object { $default_object ||= $default_class->new; return $default_object; } my $import_called = 0; sub import() { $import_called = 1; my $class = (grep /^-base$/i, @_) ? scalar(caller) : $_[0]; if (not defined $default_class) { $default_class = $class; } # else { # croak "Can't use $class after using $default_class" # unless $default_class->isa($class); # } unless (grep /^-base$/i, @_) { my @args; for (my $ii = 1; $ii <= $#_; ++$ii) { if ($_[$ii] eq '-package') { ++$ii; } else { push @args, $_[$ii]; } } Test::More->import(import => \@test_more_exports, @args) if @args; } _strict_warnings(); goto &Spiffy::import; } # Wrap Test::Builder::plan my $plan_code = \&Test::Builder::plan; my $Have_Plan = 0; { no warnings 'redefine'; *Test::Builder::plan = sub { $Have_Plan = 1; goto &$plan_code; }; } my $DIED = 0; $SIG{__DIE__} = sub { $DIED = 1; die @_ }; sub block_class { $self->find_class('Block') } sub filter_class { $self->find_class('Filter') } sub find_class { my $suffix = shift; my $class = ref($self) . "::$suffix"; return $class if $class->can('new'); $class = __PACKAGE__ . "::$suffix"; return $class if $class->can('new'); eval "require $class"; return $class if $class->can('new'); die "Can't find a class for $suffix"; } sub check_late { if ($self->{block_list}) { my $caller = (caller(1))[3]; $caller =~ s/.*:://; croak "Too late to call $caller()" } } sub find_my_self() { my $self = ref($_[0]) eq $default_class ? splice(@_, 0, 1) : default_object(); return $self, @_; } sub blocks() { (my ($self), @_) = find_my_self(@_); croak "Invalid arguments passed to 'blocks'" if @_ > 1; croak sprintf("'%s' is invalid argument to blocks()", shift(@_)) if @_ && $_[0] !~ /^[a-zA-Z]\w*$/; my $blocks = $self->block_list; my $section_name = shift || ''; my @blocks = $section_name ? (grep { exists $_->{$section_name} } @$blocks) : (@$blocks); return scalar(@blocks) unless wantarray; return (@blocks) if $self->_filters_delay; for my $block (@blocks) { $block->run_filters unless $block->is_filtered; } return (@blocks); } sub next_block() { (my ($self), @_) = find_my_self(@_); my $list = $self->_next_list; if (@$list == 0) { $list = [@{$self->block_list}, undef]; $self->_next_list($list); } my $block = shift @$list; if (defined $block and not $block->is_filtered) { $block->run_filters; } return $block; } sub first_block() { (my ($self), @_) = find_my_self(@_); $self->_next_list([]); $self->next_block; } sub filters_delay() { (my ($self), @_) = find_my_self(@_); $self->_filters_delay(defined $_[0] ? shift : 1); } sub no_diag_on_only() { (my ($self), @_) = find_my_self(@_); $self->_no_diag_on_only(defined $_[0] ? shift : 1); } sub delimiters() { (my ($self), @_) = find_my_self(@_); $self->check_late; my ($block_delimiter, $data_delimiter) = @_; $block_delimiter ||= $self->block_delim_default; $data_delimiter ||= $self->data_delim_default; $self->block_delim($block_delimiter); $self->data_delim($data_delimiter); return $self; } sub spec_file() { (my ($self), @_) = find_my_self(@_); $self->check_late; $self->_spec_file(shift); return $self; } sub spec_string() { (my ($self), @_) = find_my_self(@_); $self->check_late; $self->_spec_string(shift); return $self; } sub filters() { (my ($self), @_) = find_my_self(@_); if (ref($_[0]) eq 'HASH') { $self->_filters_map(shift); } else { my $filters = $self->_filters; push @$filters, @_; } return $self; } sub filter_arguments() { $Test::Base::Filter::arguments; } sub have_text_diff { eval { require Text::Diff; 1 } && $Text::Diff::VERSION >= 0.35 && $Algorithm::Diff::VERSION >= 1.15; } provides 'is'; sub is($$;$) { (my ($self), @_) = find_my_self(@_); my ($actual, $expected, $name) = @_; local $Test::Builder::Level = $Test::Builder::Level + 1 unless $HAS_PROVIDER; if ($ENV{TEST_SHOW_NO_DIFFS} or not defined $actual or not defined $expected or $actual eq $expected or not($self->have_text_diff) or $expected !~ /\n./s ) { Test::More::is($actual, $expected, $name); } else { $name = '' unless defined $name; ok $actual eq $expected, $name; diag Text::Diff::diff(\$expected, \$actual); } } sub run(&;$) { (my ($self), @_) = find_my_self(@_); my $callback = shift; for my $block (@{$self->block_list}) { $block->run_filters unless $block->is_filtered; &{$callback}($block); } } my $name_error = "Can't determine section names"; sub _section_names { return unless defined $self->spec; return @_ if @_ == 2; my $block = $self->first_block or croak $name_error; my @names = grep { $_ !~ /^(ONLY|LAST|SKIP)$/; } @{$block->{_section_order}[0] || []}; croak "$name_error. Need two sections in first block" unless @names == 2; return @names; } sub _assert_plan { plan('no_plan') unless $Have_Plan; } sub END { run_compare() unless $Have_Plan or $DIED or not $import_called; } sub run_compare() { (my ($self), @_) = find_my_self(@_); return unless defined $self->spec; $self->_assert_plan; my ($x, $y) = $self->_section_names(@_); local $Test::Builder::Level = $Test::Builder::Level + 1; for my $block (@{$self->block_list}) { next unless exists($block->{$x}) and exists($block->{$y}); $block->run_filters unless $block->is_filtered; if (ref $block->$x) { is_deeply($block->$x, $block->$y, $block->name ? $block->name : ()); } elsif (ref $block->$y eq 'Regexp') { my $regexp = ref $y ? $y : $block->$y; like($block->$x, $regexp, $block->name ? $block->name : ()); } else { is($block->$x, $block->$y, $block->name ? $block->name : ()); } } } sub run_is() { (my ($self), @_) = find_my_self(@_); $self->_assert_plan; my ($x, $y) = $self->_section_names(@_); local $Test::Builder::Level = $Test::Builder::Level + 1; for my $block (@{$self->block_list}) { next unless exists($block->{$x}) and exists($block->{$y}); $block->run_filters unless $block->is_filtered; is($block->$x, $block->$y, $block->name ? $block->name : () ); } } sub run_is_deeply() { (my ($self), @_) = find_my_self(@_); $self->_assert_plan; my ($x, $y) = $self->_section_names(@_); for my $block (@{$self->block_list}) { next unless exists($block->{$x}) and exists($block->{$y}); $block->run_filters unless $block->is_filtered; is_deeply($block->$x, $block->$y, $block->name ? $block->name : () ); } } sub run_like() { (my ($self), @_) = find_my_self(@_); $self->_assert_plan; my ($x, $y) = $self->_section_names(@_); for my $block (@{$self->block_list}) { next unless exists($block->{$x}) and defined($y); $block->run_filters unless $block->is_filtered; my $regexp = ref $y ? $y : $block->$y; like($block->$x, $regexp, $block->name ? $block->name : () ); } } sub run_unlike() { (my ($self), @_) = find_my_self(@_); $self->_assert_plan; my ($x, $y) = $self->_section_names(@_); for my $block (@{$self->block_list}) { next unless exists($block->{$x}) and defined($y); $block->run_filters unless $block->is_filtered; my $regexp = ref $y ? $y : $block->$y; unlike($block->$x, $regexp, $block->name ? $block->name : () ); } } sub skip_all_unless_require() { (my ($self), @_) = find_my_self(@_); my $module = shift; eval "require $module; 1" or Test::More::plan( skip_all => "$module failed to load" ); } sub is_deep() { (my ($self), @_) = find_my_self(@_); require Test::Deep; Test::Deep::cmp_deeply(@_); } sub run_is_deep() { (my ($self), @_) = find_my_self(@_); $self->_assert_plan; my ($x, $y) = $self->_section_names(@_); for my $block (@{$self->block_list}) { next unless exists($block->{$x}) and exists($block->{$y}); $block->run_filters unless $block->is_filtered; is_deep($block->$x, $block->$y, $block->name ? $block->name : () ); } } sub _pre_eval { my $spec = shift; return unless defined $spec; return $spec unless $spec =~ s/\A\s*<<<(.*?)>>>\s*$//sm; my $eval_code = $1; eval "package main; $eval_code"; croak $@ if $@; return $spec; } sub _block_list_init { my $spec = $self->spec; return [] unless defined $spec; $spec = $self->_pre_eval($spec); my $cd = $self->block_delim; my @hunks = ($spec =~ /^(\Q${cd}\E.*?(?=^\Q${cd}\E|\z))/msg); my $blocks = $self->_choose_blocks(@hunks); $self->block_list($blocks); # Need to set early for possible filter use my $seq = 1; for my $block (@$blocks) { $block->blocks_object($self); $block->seq_num($seq++); } return $blocks; } sub _choose_blocks { my $blocks = []; for my $hunk (@_) { my $block = $self->_make_block($hunk); if (exists $block->{ONLY}) { diag "I found ONLY: maybe you're debugging?" unless $self->_no_diag_on_only; return [$block]; } next if exists $block->{SKIP}; push @$blocks, $block; if (exists $block->{LAST}) { return $blocks; } } return $blocks; } sub _check_reserved { my $id = shift; croak "'$id' is a reserved name. Use something else.\n" if $reserved_section_names->{$id} or $id =~ /^_/; } sub _make_block { my $hunk = shift; my $cd = $self->block_delim; my $dd = $self->data_delim; my $block = $self->block_class->new; $hunk =~ s/\A\Q${cd}\E[ \t]*(.*)\s+// or die; my $name = $1; my @parts = split /^\Q${dd}\E +\(?(\w+)\)? *(.*)?\n/m, $hunk; my $description = shift @parts; $description ||= ''; unless ($description =~ /\S/) { $description = $name; } $description =~ s/\s*\z//; $block->set_value(description => $description); my $section_map = {}; my $section_order = []; while (@parts) { my ($type, $filters, $value) = splice(@parts, 0, 3); $self->_check_reserved($type); $value = '' unless defined $value; $filters = '' unless defined $filters; if ($filters =~ /:(\s|\z)/) { croak "Extra lines not allowed in '$type' section" if $value =~ /\S/; ($filters, $value) = split /\s*:(?:\s+|\z)/, $filters, 2; $value = '' unless defined $value; $value =~ s/^\s*(.*?)\s*$/$1/; } $section_map->{$type} = { filters => $filters, }; push @$section_order, $type; $block->set_value($type, $value); } $block->set_value(name => $name); $block->set_value(_section_map => $section_map); $block->set_value(_section_order => $section_order); return $block; } sub _spec_init { return $self->_spec_string if $self->_spec_string; local $/; my $spec; if (my $spec_file = $self->_spec_file) { open FILE, $spec_file or die $!; $spec = ; close FILE; } else { require Scalar::Util; my $handle = Scalar::Util::openhandle( \*main::DATA ); if ($handle) { $spec = <$handle>; } } return $spec; } sub _strict_warnings() { require Filter::Util::Call; my $done = 0; Filter::Util::Call::filter_add( sub { return 0 if $done; my ($data, $end) = ('', ''); while (my $status = Filter::Util::Call::filter_read()) { return $status if $status < 0; if (/^__(?:END|DATA)__\r?$/) { $end = $_; last; } $data .= $_; $_ = ''; } $_ = "use strict;use warnings;$data$end"; $done = 1; } ); } sub tie_output() { my $handle = shift; die "No buffer to tie" unless @_; tie *$handle, 'Test::Base::Handle', $_[0]; } sub no_diff { $ENV{TEST_SHOW_NO_DIFFS} = 1; } package Test::Base::Handle; sub TIEHANDLE() { my $class = shift; bless \ $_[0], $class; } sub PRINT { $$self .= $_ for @_; } #=============================================================================== # Test::Base::Block # # This is the default class for accessing a Test::Base block object. #=============================================================================== package Test::Base::Block; our @ISA = qw(Spiffy); our @EXPORT = qw(block_accessor); sub AUTOLOAD { return; } sub block_accessor() { my $accessor = shift; no strict 'refs'; return if defined &$accessor; *$accessor = sub { my $self = shift; if (@_) { Carp::croak "Not allowed to set values for '$accessor'"; } my @list = @{$self->{$accessor} || []}; return wantarray ? (@list) : $list[0]; }; } block_accessor 'name'; block_accessor 'description'; Spiffy::field 'seq_num'; Spiffy::field 'is_filtered'; Spiffy::field 'blocks_object'; Spiffy::field 'original_values' => {}; sub set_value { no strict 'refs'; my $accessor = shift; block_accessor $accessor unless defined &$accessor; $self->{$accessor} = [@_]; } sub run_filters { my $map = $self->_section_map; my $order = $self->_section_order; Carp::croak "Attempt to filter a block twice" if $self->is_filtered; for my $type (@$order) { my $filters = $map->{$type}{filters}; my @value = $self->$type; $self->original_values->{$type} = $value[0]; for my $filter ($self->_get_filters($type, $filters)) { $Test::Base::Filter::arguments = $filter =~ s/=(.*)$// ? $1 : undef; my $function = "main::$filter"; no strict 'refs'; if (defined &$function) { local $_ = (@value == 1 and not defined($value[0])) ? undef : join '', @value; my $old = $_; @value = &$function(@value); if (not(@value) or @value == 1 and defined($value[0]) and $value[0] =~ /\A(\d+|)\z/ ) { if ($value[0] && $_ eq $old) { Test::Base::diag("Filters returning numbers are supposed to do munging \$_: your filter '$function' apparently doesn't."); } @value = ($_); } } else { my $filter_object = $self->blocks_object->filter_class->new; die "Can't find a function or method for '$filter' filter\n" unless $filter_object->can($filter); $filter_object->current_block($self); @value = $filter_object->$filter(@value); } # Set the value after each filter since other filters may be # introspecting. $self->set_value($type, @value); } } $self->is_filtered(1); } sub _get_filters { my $type = shift; my $string = shift || ''; $string =~ s/\s*(.*?)\s*/$1/; my @filters = (); my $map_filters = $self->blocks_object->_filters_map->{$type} || []; $map_filters = [ $map_filters ] unless ref $map_filters; my @append = (); for ( @{$self->blocks_object->_filters}, @$map_filters, split(/\s+/, $string), ) { my $filter = $_; last unless length $filter; if ($filter =~ s/^-//) { @filters = grep { $_ ne $filter } @filters; } elsif ($filter =~ s/^\+//) { push @append, $filter; } else { push @filters, $filter; } } return @filters, @append; } { %$reserved_section_names = map { ($_, 1); } keys(%Test::Base::Block::), qw( new DESTROY ); } 1; libtest-nginx-perl-0.32/inc/Test/Base/000077500000000000000000000000001522511534200175275ustar00rootroot00000000000000libtest-nginx-perl-0.32/inc/Test/Base/Filter.pm000066400000000000000000000157451522511534200213260ustar00rootroot00000000000000#line 1 #=============================================================================== # This is the default class for handling Test::Base data filtering. #=============================================================================== package Test::Base::Filter; use Spiffy -Base; use Spiffy ':XXX'; field 'current_block'; our $arguments; sub current_arguments { return undef unless defined $arguments; my $args = $arguments; $args =~ s/(\\s)/ /g; $args =~ s/(\\[a-z])/'"' . $1 . '"'/gee; return $args; } sub assert_scalar { return if @_ == 1; require Carp; my $filter = (caller(1))[3]; $filter =~ s/.*:://; Carp::croak "Input to the '$filter' filter must be a scalar, not a list"; } sub _apply_deepest { my $method = shift; return () unless @_; if (ref $_[0] eq 'ARRAY') { for my $aref (@_) { @$aref = $self->_apply_deepest($method, @$aref); } return @_; } $self->$method(@_); } sub _split_array { map { [$self->split($_)]; } @_; } sub _peel_deepest { return () unless @_; if (ref $_[0] eq 'ARRAY') { if (ref $_[0]->[0] eq 'ARRAY') { for my $aref (@_) { @$aref = $self->_peel_deepest(@$aref); } return @_; } return map { $_->[0] } @_; } return @_; } #=============================================================================== # these filters work on the leaves of nested arrays #=============================================================================== sub Join { $self->_peel_deepest($self->_apply_deepest(join => @_)) } sub Reverse { $self->_apply_deepest(reverse => @_) } sub Split { $self->_apply_deepest(_split_array => @_) } sub Sort { $self->_apply_deepest(sort => @_) } sub append { my $suffix = $self->current_arguments; map { $_ . $suffix } @_; } sub array { return [@_]; } sub base64_decode { $self->assert_scalar(@_); require MIME::Base64; MIME::Base64::decode_base64(shift); } sub base64_encode { $self->assert_scalar(@_); require MIME::Base64; MIME::Base64::encode_base64(shift); } sub chomp { map { CORE::chomp; $_ } @_; } sub chop { map { CORE::chop; $_ } @_; } sub dumper { no warnings 'once'; require Data::Dumper; local $Data::Dumper::Sortkeys = 1; local $Data::Dumper::Indent = 1; local $Data::Dumper::Terse = 1; Data::Dumper::Dumper(@_); } sub escape { $self->assert_scalar(@_); my $text = shift; $text =~ s/(\\.)/eval "qq{$1}"/ge; return $text; } sub eval { $self->assert_scalar(@_); my @return = CORE::eval(shift); return $@ if $@; return @return; } sub eval_all { $self->assert_scalar(@_); my $out = ''; my $err = ''; Test::Base::tie_output(*STDOUT, $out); Test::Base::tie_output(*STDERR, $err); my $return = CORE::eval(shift); no warnings; untie *STDOUT; untie *STDERR; return $return, $@, $out, $err; } sub eval_stderr { $self->assert_scalar(@_); my $output = ''; Test::Base::tie_output(*STDERR, $output); CORE::eval(shift); no warnings; untie *STDERR; return $output; } sub eval_stdout { $self->assert_scalar(@_); my $output = ''; Test::Base::tie_output(*STDOUT, $output); CORE::eval(shift); no warnings; untie *STDOUT; return $output; } sub exec_perl_stdout { my $tmpfile = "/tmp/test-blocks-$$"; $self->_write_to($tmpfile, @_); open my $execution, "$^X $tmpfile 2>&1 |" or die "Couldn't open subprocess: $!\n"; local $/; my $output = <$execution>; close $execution; unlink($tmpfile) or die "Couldn't unlink $tmpfile: $!\n"; return $output; } sub flatten { $self->assert_scalar(@_); my $ref = shift; if (ref($ref) eq 'HASH') { return map { ($_, $ref->{$_}); } sort keys %$ref; } if (ref($ref) eq 'ARRAY') { return @$ref; } die "Can only flatten a hash or array ref"; } sub get_url { $self->assert_scalar(@_); my $url = shift; CORE::chomp($url); require LWP::Simple; LWP::Simple::get($url); } sub hash { return +{ @_ }; } sub head { my $size = $self->current_arguments || 1; return splice(@_, 0, $size); } sub join { my $string = $self->current_arguments; $string = '' unless defined $string; CORE::join $string, @_; } sub lines { $self->assert_scalar(@_); my $text = shift; return () unless length $text; my @lines = ($text =~ /^(.*\n?)/gm); return @lines; } sub norm { $self->assert_scalar(@_); my $text = shift; $text = '' unless defined $text; $text =~ s/\015\012/\n/g; $text =~ s/\r/\n/g; return $text; } sub prepend { my $prefix = $self->current_arguments; map { $prefix . $_ } @_; } sub read_file { $self->assert_scalar(@_); my $file = shift; CORE::chomp $file; open my $fh, $file or die "Can't open '$file' for input:\n$!"; CORE::join '', <$fh>; } sub regexp { $self->assert_scalar(@_); my $text = shift; my $flags = $self->current_arguments; if ($text =~ /\n.*?\n/s) { $flags = 'xism' unless defined $flags; } else { CORE::chomp($text); } $flags ||= ''; my $regexp = eval "qr{$text}$flags"; die $@ if $@; return $regexp; } sub reverse { CORE::reverse(@_); } sub slice { die "Invalid args for slice" unless $self->current_arguments =~ /^(\d+)(?:,(\d))?$/; my ($x, $y) = ($1, $2); $y = $x if not defined $y; die "Invalid args for slice" if $x > $y; return splice(@_, $x, 1 + $y - $x); } sub sort { CORE::sort(@_); } sub split { $self->assert_scalar(@_); my $separator = $self->current_arguments; if (defined $separator and $separator =~ s{^/(.*)/$}{$1}) { my $regexp = $1; $separator = qr{$regexp}; } $separator = qr/\s+/ unless $separator; CORE::split $separator, shift; } sub strict { $self->assert_scalar(@_); <<'...' . shift; use strict; use warnings; ... } sub tail { my $size = $self->current_arguments || 1; return splice(@_, @_ - $size, $size); } sub trim { map { s/\A([ \t]*\n)+//; s/(?<=\n)\s*\z//g; $_; } @_; } sub unchomp { map { $_ . "\n" } @_; } sub write_file { my $file = $self->current_arguments or die "No file specified for write_file filter"; if ($file =~ /(.*)[\\\/]/) { my $dir = $1; if (not -e $dir) { require File::Path; File::Path::mkpath($dir) or die "Can't create $dir"; } } open my $fh, ">$file" or die "Can't open '$file' for output\n:$!"; print $fh @_; close $fh; return $file; } sub yaml { $self->assert_scalar(@_); require YAML; return YAML::Load(shift); } sub _write_to { my $filename = shift; open my $script, ">$filename" or die "Couldn't open $filename: $!\n"; print $script @_; close $script or die "Couldn't close $filename: $!\n"; } 1; libtest-nginx-perl-0.32/inc/Test/Builder.pm000066400000000000000000001255621522511534200206140ustar00rootroot00000000000000#line 1 package Test::Builder; use 5.006; use strict; use warnings; our $VERSION = '1.302191'; BEGIN { if( $] < 5.008 ) { require Test::Builder::IO::Scalar; } } use Scalar::Util qw/blessed reftype weaken/; use Test2::Util qw/USE_THREADS try get_tid/; use Test2::API qw/context release/; # Make Test::Builder thread-safe for ithreads. BEGIN { warn "Test::Builder was loaded after Test2 initialization, this is not recommended." if Test2::API::test2_init_done() || Test2::API::test2_load_done(); if (USE_THREADS && ! Test2::API::test2_ipc_disabled()) { require Test2::IPC; require Test2::IPC::Driver::Files; Test2::IPC::Driver::Files->import; Test2::API::test2_ipc_enable_polling(); Test2::API::test2_no_wait(1); } } use Test2::Event::Subtest; use Test2::Hub::Subtest; use Test::Builder::Formatter; use Test::Builder::TodoDiag; our $Level = 1; our $Test = $ENV{TB_NO_EARLY_INIT} ? undef : Test::Builder->new; sub _add_ts_hooks { my $self = shift; my $hub = $self->{Stack}->top; # Take a reference to the hash key, we do this to avoid closing over $self # which is the singleton. We use a reference because the value could change # in rare cases. my $epkgr = \$self->{Exported_To}; #$hub->add_context_aquire(sub {$_[0]->{level} += $Level - 1}); $hub->pre_filter( sub { my ($active_hub, $e) = @_; my $epkg = $$epkgr; my $cpkg = $e->{trace} ? $e->{trace}->{frame}->[0] : undef; no strict 'refs'; no warnings 'once'; my $todo; $todo = ${"$cpkg\::TODO"} if $cpkg; $todo = ${"$epkg\::TODO"} if $epkg && !$todo; return $e unless defined($todo); return $e unless length($todo); # Turn a diag into a todo diag return Test::Builder::TodoDiag->new(%$e) if ref($e) eq 'Test2::Event::Diag'; $e->set_todo($todo) if $e->can('set_todo'); $e->add_amnesty({tag => 'TODO', details => $todo}); # Set todo on ok's if ($e->isa('Test2::Event::Ok')) { $e->set_effective_pass(1); if (my $result = $e->get_meta(__PACKAGE__)) { $result->{reason} ||= $todo; $result->{type} ||= 'todo'; $result->{ok} = 1; } } return $e; }, inherit => 1, intercept_inherit => { clean => sub { my %params = @_; my $state = $params{state}; my $trace = $params{trace}; my $epkg = $$epkgr; my $cpkg = $trace->{frame}->[0]; no strict 'refs'; no warnings 'once'; $state->{+__PACKAGE__} = {}; $state->{+__PACKAGE__}->{"$cpkg\::TODO"} = ${"$cpkg\::TODO"} if $cpkg; $state->{+__PACKAGE__}->{"$epkg\::TODO"} = ${"$epkg\::TODO"} if $epkg; ${"$cpkg\::TODO"} = undef if $cpkg; ${"$epkg\::TODO"} = undef if $epkg; }, restore => sub { my %params = @_; my $state = $params{state}; no strict 'refs'; no warnings 'once'; for my $item (keys %{$state->{+__PACKAGE__}}) { no strict 'refs'; no warnings 'once'; ${"$item"} = $state->{+__PACKAGE__}->{$item}; } }, }, ); } { no warnings; INIT { use warnings; Test2::API::test2_load() unless Test2::API::test2_in_preload(); } } sub new { my($class) = shift; unless($Test) { $Test = $class->create(singleton => 1); Test2::API::test2_add_callback_post_load( sub { $Test->{Original_Pid} = $$ if !$Test->{Original_Pid} || $Test->{Original_Pid} == 0; $Test->reset(singleton => 1); $Test->_add_ts_hooks; } ); # Non-TB tools normally expect 0 added to the level. $Level is normally 1. So # we only want the level to change if $Level != 1. # TB->ctx compensates for this later. Test2::API::test2_add_callback_context_aquire(sub { $_[0]->{level} += $Level - 1 }); Test2::API::test2_add_callback_exit(sub { $Test->_ending(@_) }); Test2::API::test2_ipc()->set_no_fatal(1) if Test2::API::test2_has_ipc(); } return $Test; } sub create { my $class = shift; my %params = @_; my $self = bless {}, $class; if ($params{singleton}) { $self->{Stack} = Test2::API::test2_stack(); } else { $self->{Stack} = Test2::API::Stack->new; $self->{Stack}->new_hub( formatter => Test::Builder::Formatter->new, ipc => Test2::API::test2_ipc(), ); $self->reset(%params); $self->_add_ts_hooks; } return $self; } sub ctx { my $self = shift; context( # 1 for our frame, another for the -1 off of $Level in our hook at the top. level => 2, fudge => 1, stack => $self->{Stack}, hub => $self->{Hub}, wrapped => 1, @_ ); } sub parent { my $self = shift; my $ctx = $self->ctx; my $chub = $self->{Hub} || $ctx->hub; $ctx->release; my $meta = $chub->meta(__PACKAGE__, {}); my $parent = $meta->{parent}; return undef unless $parent; return bless { Original_Pid => $$, Stack => $self->{Stack}, Hub => $parent, }, blessed($self); } sub child { my( $self, $name ) = @_; $name ||= "Child of " . $self->name; my $ctx = $self->ctx; my $parent = $ctx->hub; my $pmeta = $parent->meta(__PACKAGE__, {}); $self->croak("You already have a child named ($pmeta->{child}) running") if $pmeta->{child}; $pmeta->{child} = $name; # Clear $TODO for the child. my $orig_TODO = $self->find_TODO(undef, 1, undef); my $subevents = []; my $hub = $ctx->stack->new_hub( class => 'Test2::Hub::Subtest', ); $hub->pre_filter(sub { my ($active_hub, $e) = @_; # Turn a diag into a todo diag return Test::Builder::TodoDiag->new(%$e) if ref($e) eq 'Test2::Event::Diag'; return $e; }, inherit => 1) if $orig_TODO; $hub->listen(sub { push @$subevents => $_[1] }); $hub->set_nested( $parent->nested + 1 ); my $meta = $hub->meta(__PACKAGE__, {}); $meta->{Name} = $name; $meta->{TODO} = $orig_TODO; $meta->{TODO_PKG} = $ctx->trace->package; $meta->{parent} = $parent; $meta->{Test_Results} = []; $meta->{subevents} = $subevents; $meta->{subtest_id} = $hub->id; $meta->{subtest_uuid} = $hub->uuid; $meta->{subtest_buffered} = $parent->format ? 0 : 1; $self->_add_ts_hooks; $ctx->release; return bless { Original_Pid => $$, Stack => $self->{Stack}, Hub => $hub, no_log_results => $self->{no_log_results} }, blessed($self); } sub finalize { my $self = shift; my $ok = 1; ($ok) = @_ if @_; my $st_ctx = $self->ctx; my $chub = $self->{Hub} || return $st_ctx->release; my $meta = $chub->meta(__PACKAGE__, {}); if ($meta->{child}) { $self->croak("Can't call finalize() with child ($meta->{child}) active"); } local $? = 0; # don't fail if $subtests happened to set $? nonzero $self->{Stack}->pop($chub); $self->find_TODO($meta->{TODO_PKG}, 1, $meta->{TODO}); my $parent = $self->parent; my $ctx = $parent->ctx; my $trace = $ctx->trace; delete $ctx->hub->meta(__PACKAGE__, {})->{child}; $chub->finalize($trace->snapshot(hid => $chub->hid, nested => $chub->nested), 1) if $ok && $chub->count && !$chub->no_ending && !$chub->ended; my $plan = $chub->plan || 0; my $count = $chub->count; my $failed = $chub->failed; my $passed = $chub->is_passing; my $num_extra = $plan =~ m/\D/ ? 0 : $count - $plan; if ($count && $num_extra != 0) { my $s = $plan == 1 ? '' : 's'; $st_ctx->diag(<<"FAIL"); Looks like you planned $plan test$s but ran $count. FAIL } if ($failed) { my $s = $failed == 1 ? '' : 's'; my $qualifier = $num_extra == 0 ? '' : ' run'; $st_ctx->diag(<<"FAIL"); Looks like you failed $failed test$s of $count$qualifier. FAIL } if (!$passed && !$failed && $count && !$num_extra) { $st_ctx->diag(<<"FAIL"); All assertions inside the subtest passed, but errors were encountered. FAIL } $st_ctx->release; unless ($chub->bailed_out) { my $plan = $chub->plan; if ( $plan && $plan eq 'SKIP' ) { $parent->skip($chub->skip_reason, $meta->{Name}); } elsif ( !$chub->count ) { $parent->ok( 0, sprintf q[No tests run for subtest "%s"], $meta->{Name} ); } else { $parent->{subevents} = $meta->{subevents}; $parent->{subtest_id} = $meta->{subtest_id}; $parent->{subtest_uuid} = $meta->{subtest_uuid}; $parent->{subtest_buffered} = $meta->{subtest_buffered}; $parent->ok( $chub->is_passing, $meta->{Name} ); } } $ctx->release; return $chub->is_passing; } sub subtest { my $self = shift; my ($name, $code, @args) = @_; my $ctx = $self->ctx; $ctx->throw("subtest()'s second argument must be a code ref") unless $code && reftype($code) eq 'CODE'; $name ||= "Child of " . $self->name; $_->($name,$code,@args) for Test2::API::test2_list_pre_subtest_callbacks(); $ctx->note("Subtest: $name"); my $child = $self->child($name); my $start_pid = $$; my $st_ctx; my ($ok, $err, $finished, $child_error); T2_SUBTEST_WRAPPER: { my $ctx = $self->ctx; $st_ctx = $ctx->snapshot; $ctx->release; $ok = eval { local $Level = 1; $code->(@args); 1 }; ($err, $child_error) = ($@, $?); # They might have done 'BEGIN { skip_all => "whatever" }' if (!$ok && $err =~ m/Label not found for "last T2_SUBTEST_WRAPPER"/ || (blessed($err) && blessed($err) eq 'Test::Builder::Exception')) { $ok = undef; $err = undef; } else { $finished = 1; } } if ($start_pid != $$ && !$INC{'Test2/IPC.pm'}) { warn $ok ? "Forked inside subtest, but subtest never finished!\n" : $err; exit 255; } my $trace = $ctx->trace; if (!$finished) { if(my $bailed = $st_ctx->hub->bailed_out) { my $chub = $child->{Hub}; $self->{Stack}->pop($chub); $ctx->bail($bailed->reason); } my $code = $st_ctx->hub->exit_code; $ok = !$code; $err = "Subtest ended with exit code $code" if $code; } my $st_hub = $st_ctx->hub; my $plan = $st_hub->plan; my $count = $st_hub->count; if (!$count && (!defined($plan) || "$plan" ne 'SKIP')) { $st_ctx->plan(0) unless defined $plan; $st_ctx->diag('No tests run!'); } $child->finalize($st_ctx->trace); $ctx->release; die $err unless $ok; $? = $child_error if defined $child_error; return $st_hub->is_passing; } sub name { my $self = shift; my $ctx = $self->ctx; release $ctx, $ctx->hub->meta(__PACKAGE__, {})->{Name}; } sub reset { ## no critic (Subroutines::ProhibitBuiltinHomonyms) my ($self, %params) = @_; Test2::API::test2_unset_is_end(); # We leave this a global because it has to be localized and localizing # hash keys is just asking for pain. Also, it was documented. $Level = 1; $self->{no_log_results} = $ENV{TEST_NO_LOG_RESULTS} ? 1 : 0 unless $params{singleton}; $self->{Original_Pid} = Test2::API::test2_in_preload() ? -1 : $$; my $ctx = $self->ctx; my $hub = $ctx->hub; $ctx->release; unless ($params{singleton}) { $hub->reset_state(); $hub->_tb_reset(); } $ctx = $self->ctx; my $meta = $ctx->hub->meta(__PACKAGE__, {}); %$meta = ( Name => $0, Ending => 0, Done_Testing => undef, Skip_All => 0, Test_Results => [], parent => $meta->{parent}, ); $self->{Exported_To} = undef unless $params{singleton}; $self->{Orig_Handles} ||= do { my $format = $ctx->hub->format; my $out; if ($format && $format->isa('Test2::Formatter::TAP')) { $out = $format->handles; } $out ? [@$out] : []; }; $self->use_numbers(1); $self->no_header(0) unless $params{singleton}; $self->no_ending(0) unless $params{singleton}; $self->reset_outputs; $ctx->release; return; } my %plan_cmds = ( no_plan => \&no_plan, skip_all => \&skip_all, tests => \&_plan_tests, ); sub plan { my( $self, $cmd, $arg ) = @_; return unless $cmd; my $ctx = $self->ctx; my $hub = $ctx->hub; $ctx->throw("You tried to plan twice") if $hub->plan; local $Level = $Level + 1; if( my $method = $plan_cmds{$cmd} ) { local $Level = $Level + 1; $self->$method($arg); } else { my @args = grep { defined } ( $cmd, $arg ); $ctx->throw("plan() doesn't understand @args"); } release $ctx, 1; } sub _plan_tests { my($self, $arg) = @_; my $ctx = $self->ctx; if($arg) { local $Level = $Level + 1; $self->expected_tests($arg); } elsif( !defined $arg ) { $ctx->throw("Got an undefined number of tests"); } else { $ctx->throw("You said to run 0 tests"); } $ctx->release; } sub expected_tests { my $self = shift; my($max) = @_; my $ctx = $self->ctx; if(@_) { $self->croak("Number of tests must be a positive integer. You gave it '$max'") unless $max =~ /^\+?\d+$/; $ctx->plan($max); } my $hub = $ctx->hub; $ctx->release; my $plan = $hub->plan; return 0 unless $plan; return 0 if $plan =~ m/\D/; return $plan; } sub no_plan { my($self, $arg) = @_; my $ctx = $self->ctx; if (defined $ctx->hub->plan) { warn "Plan already set, no_plan() is a no-op, this will change to a hard failure in the future."; $ctx->release; return; } $ctx->alert("no_plan takes no arguments") if $arg; $ctx->hub->plan('NO PLAN'); release $ctx, 1; } sub done_testing { my($self, $num_tests) = @_; my $ctx = $self->ctx; my $meta = $ctx->hub->meta(__PACKAGE__, {}); if ($meta->{Done_Testing}) { my ($file, $line) = @{$meta->{Done_Testing}}[1,2]; local $ctx->hub->{ended}; # OMG This is awful. $self->ok(0, "done_testing() was already called at $file line $line"); $ctx->release; return; } $meta->{Done_Testing} = [$ctx->trace->call]; my $plan = $ctx->hub->plan; my $count = $ctx->hub->count; # If done_testing() specified the number of tests, shut off no_plan if( defined $num_tests ) { $ctx->plan($num_tests) if !$plan || $plan eq 'NO PLAN'; } elsif ($count && defined $num_tests && $count != $num_tests) { $self->ok(0, "planned to run @{[ $self->expected_tests ]} but done_testing() expects $num_tests"); } else { $num_tests = $self->current_test; } if( $self->expected_tests && $num_tests != $self->expected_tests ) { $self->ok(0, "planned to run @{[ $self->expected_tests ]} ". "but done_testing() expects $num_tests"); } $ctx->plan($num_tests) if $ctx->hub->plan && $ctx->hub->plan eq 'NO PLAN'; $ctx->hub->finalize($ctx->trace, 1); release $ctx, 1; } sub has_plan { my $self = shift; my $ctx = $self->ctx; my $plan = $ctx->hub->plan; $ctx->release; return( $plan ) if $plan && $plan !~ m/\D/; return('no_plan') if $plan && $plan eq 'NO PLAN'; return(undef); } sub skip_all { my( $self, $reason ) = @_; my $ctx = $self->ctx; $ctx->hub->meta(__PACKAGE__, {})->{Skip_All} = $reason || 1; # Work around old perl bug if ($] < 5.020000) { my $begin = 0; my $level = 0; while (my @call = caller($level++)) { last unless @call && $call[0]; next unless $call[3] =~ m/::BEGIN$/; $begin++; last; } # HACK! die 'Label not found for "last T2_SUBTEST_WRAPPER"' if $begin && $ctx->hub->meta(__PACKAGE__, {})->{parent}; } $reason = "$reason" if defined $reason; $ctx->plan(0, SKIP => $reason); } sub exported_to { my( $self, $pack ) = @_; if( defined $pack ) { $self->{Exported_To} = $pack; } return $self->{Exported_To}; } sub ok { my( $self, $test, $name ) = @_; my $ctx = $self->ctx; # $test might contain an object which we don't want to accidentally # store, so we turn it into a boolean. $test = $test ? 1 : 0; # In case $name is a string overloaded object, force it to stringify. no warnings qw/uninitialized numeric/; $name = "$name" if defined $name; # Profiling showed that the regex here was a huge time waster, doing the # numeric addition first cuts our profile time from ~300ms to ~50ms $self->diag(<<" ERR") if 0 + $name && $name =~ /^[\d\s]+$/; You named your test '$name'. You shouldn't use numbers for your test names. Very confusing. ERR use warnings qw/uninitialized numeric/; my $trace = $ctx->{trace}; my $hub = $ctx->{hub}; my $result = { ok => $test, actual_ok => $test, reason => '', type => '', (name => defined($name) ? $name : ''), }; $hub->{_meta}->{+__PACKAGE__}->{Test_Results}[ $hub->{count} ] = $result unless $self->{no_log_results}; my $orig_name = $name; my @attrs; my $subevents = delete $self->{subevents}; my $subtest_id = delete $self->{subtest_id}; my $subtest_uuid = delete $self->{subtest_uuid}; my $subtest_buffered = delete $self->{subtest_buffered}; my $epkg = 'Test2::Event::Ok'; if ($subevents) { $epkg = 'Test2::Event::Subtest'; push @attrs => (subevents => $subevents, subtest_id => $subtest_id, subtest_uuid => $subtest_uuid, buffered => $subtest_buffered); } my $e = bless { trace => bless( {%$trace}, 'Test2::EventFacet::Trace'), pass => $test, name => $name, _meta => {'Test::Builder' => $result}, effective_pass => $test, @attrs, }, $epkg; $hub->send($e); $self->_ok_debug($trace, $orig_name) unless($test); $ctx->release; return $test; } sub _ok_debug { my $self = shift; my ($trace, $orig_name) = @_; my $is_todo = $self->in_todo; my $msg = $is_todo ? "Failed (TODO)" : "Failed"; my (undef, $file, $line) = $trace->call; if (defined $orig_name) { $self->diag(qq[ $msg test '$orig_name'\n at $file line $line.\n]); } else { $self->diag(qq[ $msg test at $file line $line.\n]); } } sub _diag_fh { my $self = shift; local $Level = $Level + 1; return $self->in_todo ? $self->todo_output : $self->failure_output; } sub _unoverload { my ($self, $type, $thing) = @_; return unless ref $$thing; return unless blessed($$thing) || scalar $self->_try(sub{ $$thing->isa('UNIVERSAL') }); { local ($!, $@); require overload; } my $string_meth = overload::Method( $$thing, $type ) || return; $$thing = $$thing->$string_meth(undef, 0); } sub _unoverload_str { my $self = shift; $self->_unoverload( q[""], $_ ) for @_; } sub _unoverload_num { my $self = shift; $self->_unoverload( '0+', $_ ) for @_; for my $val (@_) { next unless $self->_is_dualvar($$val); $$val = $$val + 0; } } # This is a hack to detect a dualvar such as $! sub _is_dualvar { my( $self, $val ) = @_; # Objects are not dualvars. return 0 if ref $val; no warnings 'numeric'; my $numval = $val + 0; return ($numval != 0 and $numval ne $val ? 1 : 0); } sub is_eq { my( $self, $got, $expect, $name ) = @_; my $ctx = $self->ctx; local $Level = $Level + 1; if( !defined $got || !defined $expect ) { # undef only matches undef and nothing else my $test = !defined $got && !defined $expect; $self->ok( $test, $name ); $self->_is_diag( $got, 'eq', $expect ) unless $test; $ctx->release; return $test; } release $ctx, $self->cmp_ok( $got, 'eq', $expect, $name ); } sub is_num { my( $self, $got, $expect, $name ) = @_; my $ctx = $self->ctx; local $Level = $Level + 1; if( !defined $got || !defined $expect ) { # undef only matches undef and nothing else my $test = !defined $got && !defined $expect; $self->ok( $test, $name ); $self->_is_diag( $got, '==', $expect ) unless $test; $ctx->release; return $test; } release $ctx, $self->cmp_ok( $got, '==', $expect, $name ); } sub _diag_fmt { my( $self, $type, $val ) = @_; if( defined $$val ) { if( $type eq 'eq' or $type eq 'ne' ) { # quote and force string context $$val = "'$$val'"; } else { # force numeric context $self->_unoverload_num($val); } } else { $$val = 'undef'; } return; } sub _is_diag { my( $self, $got, $type, $expect ) = @_; $self->_diag_fmt( $type, $_ ) for \$got, \$expect; local $Level = $Level + 1; return $self->diag(<<"DIAGNOSTIC"); got: $got expected: $expect DIAGNOSTIC } sub _isnt_diag { my( $self, $got, $type ) = @_; $self->_diag_fmt( $type, \$got ); local $Level = $Level + 1; return $self->diag(<<"DIAGNOSTIC"); got: $got expected: anything else DIAGNOSTIC } sub isnt_eq { my( $self, $got, $dont_expect, $name ) = @_; my $ctx = $self->ctx; local $Level = $Level + 1; if( !defined $got || !defined $dont_expect ) { # undef only matches undef and nothing else my $test = defined $got || defined $dont_expect; $self->ok( $test, $name ); $self->_isnt_diag( $got, 'ne' ) unless $test; $ctx->release; return $test; } release $ctx, $self->cmp_ok( $got, 'ne', $dont_expect, $name ); } sub isnt_num { my( $self, $got, $dont_expect, $name ) = @_; my $ctx = $self->ctx; local $Level = $Level + 1; if( !defined $got || !defined $dont_expect ) { # undef only matches undef and nothing else my $test = defined $got || defined $dont_expect; $self->ok( $test, $name ); $self->_isnt_diag( $got, '!=' ) unless $test; $ctx->release; return $test; } release $ctx, $self->cmp_ok( $got, '!=', $dont_expect, $name ); } sub like { my( $self, $thing, $regex, $name ) = @_; my $ctx = $self->ctx; local $Level = $Level + 1; release $ctx, $self->_regex_ok( $thing, $regex, '=~', $name ); } sub unlike { my( $self, $thing, $regex, $name ) = @_; my $ctx = $self->ctx; local $Level = $Level + 1; release $ctx, $self->_regex_ok( $thing, $regex, '!~', $name ); } my %numeric_cmps = map { ( $_, 1 ) } ( "<", "<=", ">", ">=", "==", "!=", "<=>" ); # Bad, these are not comparison operators. Should we include more? my %cmp_ok_bl = map { ( $_, 1 ) } ( "=", "+=", ".=", "x=", "^=", "|=", "||=", "&&=", "..."); sub cmp_ok { my( $self, $got, $type, $expect, $name ) = @_; my $ctx = $self->ctx; if ($cmp_ok_bl{$type}) { $ctx->throw("$type is not a valid comparison operator in cmp_ok()"); } my ($test, $succ); my $error; { ## no critic (BuiltinFunctions::ProhibitStringyEval) local( $@, $!, $SIG{__DIE__} ); # isolate eval my($pack, $file, $line) = $ctx->trace->call(); my $warning_bits = $ctx->trace->warning_bits; # convert this to a code string so the BEGIN doesn't have to close # over it, which can lead to issues with Devel::Cover my $bits_code = defined $warning_bits ? qq["\Q$warning_bits\E"] : 'undef'; # This is so that warnings come out at the caller's level $succ = eval qq[ BEGIN {\${^WARNING_BITS} = $bits_code}; #line $line "(eval in cmp_ok) $file" \$test = (\$got $type \$expect); 1; ]; $error = $@; } local $Level = $Level + 1; my $ok = $self->ok( $test, $name ); # Treat overloaded objects as numbers if we're asked to do a # numeric comparison. my $unoverload = $numeric_cmps{$type} ? '_unoverload_num' : '_unoverload_str'; $self->diag(<<"END") unless $succ; An error occurred while using $type: ------------------------------------ $error ------------------------------------ END unless($ok) { $self->$unoverload( \$got, \$expect ); if( $type =~ /^(eq|==)$/ ) { $self->_is_diag( $got, $type, $expect ); } elsif( $type =~ /^(ne|!=)$/ ) { if (defined($got) xor defined($expect)) { $self->_cmp_diag( $got, $type, $expect ); } else { $self->_isnt_diag( $got, $type ); } } else { $self->_cmp_diag( $got, $type, $expect ); } } return release $ctx, $ok; } sub _cmp_diag { my( $self, $got, $type, $expect ) = @_; $got = defined $got ? "'$got'" : 'undef'; $expect = defined $expect ? "'$expect'" : 'undef'; local $Level = $Level + 1; return $self->diag(<<"DIAGNOSTIC"); $got $type $expect DIAGNOSTIC } sub _caller_context { my $self = shift; my( $pack, $file, $line ) = $self->caller(1); my $code = ''; $code .= "#line $line $file\n" if defined $file and defined $line; return $code; } sub BAIL_OUT { my( $self, $reason ) = @_; my $ctx = $self->ctx; $self->{Bailed_Out} = 1; $ctx->bail($reason); } { no warnings 'once'; *BAILOUT = \&BAIL_OUT; } sub skip { my( $self, $why, $name ) = @_; $why ||= ''; $name = '' unless defined $name; $self->_unoverload_str( \$why ); my $ctx = $self->ctx; $name = "$name"; $why = "$why"; $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness. $name =~ s{\n}{\n# }sg; $why =~ s{\n}{\n# }sg; $ctx->hub->meta(__PACKAGE__, {})->{Test_Results}[ $ctx->hub->count ] = { 'ok' => 1, actual_ok => 1, name => $name, type => 'skip', reason => $why, } unless $self->{no_log_results}; my $tctx = $ctx->snapshot; $tctx->skip('', $why); return release $ctx, 1; } sub todo_skip { my( $self, $why ) = @_; $why ||= ''; my $ctx = $self->ctx; $ctx->hub->meta(__PACKAGE__, {})->{Test_Results}[ $ctx->hub->count ] = { 'ok' => 1, actual_ok => 0, name => '', type => 'todo_skip', reason => $why, } unless $self->{no_log_results}; $why =~ s{\n}{\n# }sg; my $tctx = $ctx->snapshot; $tctx->send_event( 'Skip', todo => $why, todo_diag => 1, reason => $why, pass => 0); return release $ctx, 1; } sub maybe_regex { my( $self, $regex ) = @_; my $usable_regex = undef; return $usable_regex unless defined $regex; my( $re, $opts ); # Check for qr/foo/ if( _is_qr($regex) ) { $usable_regex = $regex; } # Check for '/foo/' or 'm,foo,' elsif(( $re, $opts ) = $regex =~ m{^ /(.*)/ (\w*) $ }sx or ( undef, $re, $opts ) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx ) { $usable_regex = length $opts ? "(?$opts)$re" : $re; } return $usable_regex; } sub _is_qr { my $regex = shift; # is_regexp() checks for regexes in a robust manner, say if they're # blessed. return re::is_regexp($regex) if defined &re::is_regexp; return ref $regex eq 'Regexp'; } sub _regex_ok { my( $self, $thing, $regex, $cmp, $name ) = @_; my $ok = 0; my $usable_regex = $self->maybe_regex($regex); unless( defined $usable_regex ) { local $Level = $Level + 1; $ok = $self->ok( 0, $name ); $self->diag(" '$regex' doesn't look much like a regex to me."); return $ok; } { my $test; my $context = $self->_caller_context; { ## no critic (BuiltinFunctions::ProhibitStringyEval) local( $@, $!, $SIG{__DIE__} ); # isolate eval # No point in issuing an uninit warning, they'll see it in the diagnostics no warnings 'uninitialized'; $test = eval $context . q{$test = $thing =~ /$usable_regex/ ? 1 : 0}; } $test = !$test if $cmp eq '!~'; local $Level = $Level + 1; $ok = $self->ok( $test, $name ); } unless($ok) { $thing = defined $thing ? "'$thing'" : 'undef'; my $match = $cmp eq '=~' ? "doesn't match" : "matches"; local $Level = $Level + 1; $self->diag( sprintf <<'DIAGNOSTIC', $thing, $match, $regex ); %s %13s '%s' DIAGNOSTIC } return $ok; } sub is_fh { my $self = shift; my $maybe_fh = shift; return 0 unless defined $maybe_fh; return 1 if ref $maybe_fh eq 'GLOB'; # its a glob ref return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob return eval { $maybe_fh->isa("IO::Handle") } || eval { tied($maybe_fh)->can('TIEHANDLE') }; } sub level { my( $self, $level ) = @_; if( defined $level ) { $Level = $level; } return $Level; } sub use_numbers { my( $self, $use_nums ) = @_; my $ctx = $self->ctx; my $format = $ctx->hub->format; unless ($format && $format->can('no_numbers') && $format->can('set_no_numbers')) { warn "The current formatter does not support 'use_numbers'" if $format; return release $ctx, 0; } $format->set_no_numbers(!$use_nums) if defined $use_nums; return release $ctx, $format->no_numbers ? 0 : 1; } BEGIN { for my $method (qw(no_header no_diag)) { my $set = "set_$method"; my $code = sub { my( $self, $no ) = @_; my $ctx = $self->ctx; my $format = $ctx->hub->format; unless ($format && $format->can($set)) { warn "The current formatter does not support '$method'" if $format; $ctx->release; return } $format->$set($no) if defined $no; return release $ctx, $format->$method ? 1 : 0; }; no strict 'refs'; ## no critic *$method = $code; } } sub no_ending { my( $self, $no ) = @_; my $ctx = $self->ctx; $ctx->hub->set_no_ending($no) if defined $no; return release $ctx, $ctx->hub->no_ending; } sub diag { my $self = shift; return unless @_; my $text = join '' => map {defined($_) ? $_ : 'undef'} @_; if (Test2::API::test2_in_preload()) { chomp($text); $text =~ s/^/# /msg; print STDERR $text, "\n"; return 0; } my $ctx = $self->ctx; $ctx->diag($text); $ctx->release; return 0; } sub note { my $self = shift; return unless @_; my $text = join '' => map {defined($_) ? $_ : 'undef'} @_; if (Test2::API::test2_in_preload()) { chomp($text); $text =~ s/^/# /msg; print STDOUT $text, "\n"; return 0; } my $ctx = $self->ctx; $ctx->note($text); $ctx->release; return 0; } sub explain { my $self = shift; local ($@, $!); require Data::Dumper; return map { ref $_ ? do { my $dumper = Data::Dumper->new( [$_] ); $dumper->Indent(1)->Terse(1); $dumper->Sortkeys(1) if $dumper->can("Sortkeys"); $dumper->Dump; } : $_ } @_; } sub output { my( $self, $fh ) = @_; my $ctx = $self->ctx; my $format = $ctx->hub->format; $ctx->release; return unless $format && $format->isa('Test2::Formatter::TAP'); $format->handles->[Test2::Formatter::TAP::OUT_STD()] = $self->_new_fh($fh) if defined $fh; return $format->handles->[Test2::Formatter::TAP::OUT_STD()]; } sub failure_output { my( $self, $fh ) = @_; my $ctx = $self->ctx; my $format = $ctx->hub->format; $ctx->release; return unless $format && $format->isa('Test2::Formatter::TAP'); $format->handles->[Test2::Formatter::TAP::OUT_ERR()] = $self->_new_fh($fh) if defined $fh; return $format->handles->[Test2::Formatter::TAP::OUT_ERR()]; } sub todo_output { my( $self, $fh ) = @_; my $ctx = $self->ctx; my $format = $ctx->hub->format; $ctx->release; return unless $format && $format->isa('Test::Builder::Formatter'); $format->handles->[Test::Builder::Formatter::OUT_TODO()] = $self->_new_fh($fh) if defined $fh; return $format->handles->[Test::Builder::Formatter::OUT_TODO()]; } sub _new_fh { my $self = shift; my($file_or_fh) = shift; my $fh; if( $self->is_fh($file_or_fh) ) { $fh = $file_or_fh; } elsif( ref $file_or_fh eq 'SCALAR' ) { # Scalar refs as filehandles was added in 5.8. if( $] >= 5.008 ) { open $fh, ">>", $file_or_fh or $self->croak("Can't open scalar ref $file_or_fh: $!"); } # Emulate scalar ref filehandles with a tie. else { $fh = Test::Builder::IO::Scalar->new($file_or_fh) or $self->croak("Can't tie scalar ref $file_or_fh"); } } else { open $fh, ">", $file_or_fh or $self->croak("Can't open test output log $file_or_fh: $!"); _autoflush($fh); } return $fh; } sub _autoflush { my($fh) = shift; my $old_fh = select $fh; $| = 1; select $old_fh; return; } sub reset_outputs { my $self = shift; my $ctx = $self->ctx; my $format = $ctx->hub->format; $ctx->release; return unless $format && $format->isa('Test2::Formatter::TAP'); $format->set_handles([@{$self->{Orig_Handles}}]) if $self->{Orig_Handles}; return; } sub carp { my $self = shift; my $ctx = $self->ctx; $ctx->alert(join "", @_); $ctx->release; } sub croak { my $self = shift; my $ctx = $self->ctx; $ctx->throw(join "", @_); $ctx->release; } sub current_test { my( $self, $num ) = @_; my $ctx = $self->ctx; my $hub = $ctx->hub; if( defined $num ) { $hub->set_count($num); unless ($self->{no_log_results}) { # If the test counter is being pushed forward fill in the details. my $test_results = $ctx->hub->meta(__PACKAGE__, {})->{Test_Results}; if ($num > @$test_results) { my $start = @$test_results ? @$test_results : 0; for ($start .. $num - 1) { $test_results->[$_] = { 'ok' => 1, actual_ok => undef, reason => 'incrementing test number', type => 'unknown', name => undef }; } } # If backward, wipe history. Its their funeral. elsif ($num < @$test_results) { $#{$test_results} = $num - 1; } } } return release $ctx, $hub->count; } sub is_passing { my $self = shift; my $ctx = $self->ctx; my $hub = $ctx->hub; if( @_ ) { my ($bool) = @_; $hub->set_failed(0) if $bool; $hub->is_passing($bool); } return release $ctx, $hub->is_passing; } sub summary { my($self) = shift; return if $self->{no_log_results}; my $ctx = $self->ctx; my $data = $ctx->hub->meta(__PACKAGE__, {})->{Test_Results}; $ctx->release; return map { $_ ? $_->{'ok'} : () } @$data; } sub details { my $self = shift; return if $self->{no_log_results}; my $ctx = $self->ctx; my $data = $ctx->hub->meta(__PACKAGE__, {})->{Test_Results}; $ctx->release; return @$data; } sub find_TODO { my( $self, $pack, $set, $new_value ) = @_; my $ctx = $self->ctx; $pack ||= $ctx->trace->package || $self->exported_to; $ctx->release; return unless $pack; no strict 'refs'; ## no critic no warnings 'once'; my $old_value = ${ $pack . '::TODO' }; $set and ${ $pack . '::TODO' } = $new_value; return $old_value; } sub todo { my( $self, $pack ) = @_; local $Level = $Level + 1; my $ctx = $self->ctx; $ctx->release; my $meta = $ctx->hub->meta(__PACKAGE__, {todo => []})->{todo}; return $meta->[-1]->[1] if $meta && @$meta; $pack ||= $ctx->trace->package; return unless $pack; no strict 'refs'; ## no critic no warnings 'once'; return ${ $pack . '::TODO' }; } sub in_todo { my $self = shift; local $Level = $Level + 1; my $ctx = $self->ctx; $ctx->release; my $meta = $ctx->hub->meta(__PACKAGE__, {todo => []})->{todo}; return 1 if $meta && @$meta; my $pack = $ctx->trace->package || return 0; no strict 'refs'; ## no critic no warnings 'once'; my $todo = ${ $pack . '::TODO' }; return 0 unless defined $todo; return 0 if "$todo" eq ''; return 1; } sub todo_start { my $self = shift; my $message = @_ ? shift : ''; my $ctx = $self->ctx; my $hub = $ctx->hub; my $filter = $hub->pre_filter(sub { my ($active_hub, $e) = @_; # Turn a diag into a todo diag return Test::Builder::TodoDiag->new(%$e) if ref($e) eq 'Test2::Event::Diag'; # Set todo on ok's if ($hub == $active_hub && $e->isa('Test2::Event::Ok')) { $e->set_todo($message); $e->set_effective_pass(1); if (my $result = $e->get_meta(__PACKAGE__)) { $result->{reason} ||= $message; $result->{type} ||= 'todo'; $result->{ok} = 1; } } return $e; }, inherit => 1); push @{$ctx->hub->meta(__PACKAGE__, {todo => []})->{todo}} => [$filter, $message]; $ctx->release; return; } sub todo_end { my $self = shift; my $ctx = $self->ctx; my $set = pop @{$ctx->hub->meta(__PACKAGE__, {todo => []})->{todo}}; $ctx->throw('todo_end() called without todo_start()') unless $set; $ctx->hub->pre_unfilter($set->[0]); $ctx->release; return; } sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms) my( $self ) = @_; my $ctx = $self->ctx; my $trace = $ctx->trace; $ctx->release; return wantarray ? $trace->call : $trace->package; } sub _try { my( $self, $code, %opts ) = @_; my $error; my $return; { local $!; # eval can mess up $! local $@; # don't set $@ in the test local $SIG{__DIE__}; # don't trip an outside DIE handler. $return = eval { $code->() }; $error = $@; } die $error if $error and $opts{die_on_fail}; return wantarray ? ( $return, $error ) : $return; } sub _ending { my $self = shift; my ($ctx, $real_exit_code, $new) = @_; unless ($ctx) { my $octx = $self->ctx; $ctx = $octx->snapshot; $octx->release; } return if $ctx->hub->no_ending; return if $ctx->hub->meta(__PACKAGE__, {})->{Ending}++; # Don't bother with an ending if this is a forked copy. Only the parent # should do the ending. return unless $self->{Original_Pid} == $$; my $hub = $ctx->hub; return if $hub->bailed_out; my $plan = $hub->plan; my $count = $hub->count; my $failed = $hub->failed; my $passed = $hub->is_passing; return unless $plan || $count || $failed; # Ran tests but never declared a plan or hit done_testing if( !$hub->plan and $hub->count ) { $self->diag("Tests were run but no plan was declared and done_testing() was not seen."); if($real_exit_code) { $self->diag(<<"FAIL"); Looks like your test exited with $real_exit_code just after $count. FAIL $$new ||= $real_exit_code; return; } # But if the tests ran, handle exit code. if($failed > 0) { my $exit_code = $failed <= 254 ? $failed : 254; $$new ||= $exit_code; return; } $$new ||= 254; return; } if ($real_exit_code && !$count) { $self->diag("Looks like your test exited with $real_exit_code before it could output anything."); $$new ||= $real_exit_code; return; } return if $plan && "$plan" eq 'SKIP'; if (!$count) { $self->diag('No tests run!'); $$new ||= 255; return; } if ($real_exit_code) { $self->diag(<<"FAIL"); Looks like your test exited with $real_exit_code just after $count. FAIL $$new ||= $real_exit_code; return; } if ($plan eq 'NO PLAN') { $ctx->plan( $count ); $plan = $hub->plan; } # Figure out if we passed or failed and print helpful messages. my $num_extra = $count - $plan; if ($num_extra != 0) { my $s = $plan == 1 ? '' : 's'; $self->diag(<<"FAIL"); Looks like you planned $plan test$s but ran $count. FAIL } if ($failed) { my $s = $failed == 1 ? '' : 's'; my $qualifier = $num_extra == 0 ? '' : ' run'; $self->diag(<<"FAIL"); Looks like you failed $failed test$s of $count$qualifier. FAIL } if (!$passed && !$failed && $count && !$num_extra) { $ctx->diag(<<"FAIL"); All assertions passed, but errors were encountered. FAIL } my $exit_code = 0; if ($failed) { $exit_code = $failed <= 254 ? $failed : 254; } elsif ($num_extra != 0) { $exit_code = 255; } elsif (!$passed) { $exit_code = 255; } $$new ||= $exit_code; return; } # Some things used this even though it was private... I am looking at you # Test::Builder::Prefix... sub _print_comment { my( $self, $fh, @msgs ) = @_; return if $self->no_diag; return unless @msgs; # Prevent printing headers when compiling (i.e. -c) return if $^C; # Smash args together like print does. # Convert undef to 'undef' so its readable. my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs; # Escape the beginning, _print will take care of the rest. $msg =~ s/^/# /; local( $\, $", $, ) = ( undef, ' ', '' ); print $fh $msg; return 0; } # This is used by Test::SharedFork to turn on IPC after the fact. Not # documenting because I do not want it used. The method name is borrowed from # Test::Builder 2 # Once Test2 stuff goes stable this method will be removed and Test::SharedFork # will be made smarter. sub coordinate_forks { my $self = shift; { local ($@, $!); require Test2::IPC; } Test2::IPC->import; Test2::API::test2_ipc_enable_polling(); Test2::API::test2_load(); my $ipc = Test2::IPC::apply_ipc($self->{Stack}); $ipc->set_no_fatal(1); Test2::API::test2_no_wait(1); } sub no_log_results { $_[0]->{no_log_results} = 1 } 1; __END__ #line 2163 libtest-nginx-perl-0.32/inc/Test/Builder/000077500000000000000000000000001522511534200202435ustar00rootroot00000000000000libtest-nginx-perl-0.32/inc/Test/Builder/Module.pm000066400000000000000000000023241522511534200220270ustar00rootroot00000000000000#line 1 package Test::Builder::Module; use strict; use Test::Builder; require Exporter; our @ISA = qw(Exporter); our $VERSION = '1.302191'; #line 73 sub import { my($class) = shift; Test2::API::test2_load() unless Test2::API::test2_in_preload(); # Don't run all this when loading ourself. return 1 if $class eq 'Test::Builder::Module'; my $test = $class->builder; my $caller = caller; $test->exported_to($caller); $class->import_extra( \@_ ); my(@imports) = $class->_strip_imports( \@_ ); $test->plan(@_); local $Exporter::ExportLevel = $Exporter::ExportLevel + 1; $class->Exporter::import(@imports); } sub _strip_imports { my $class = shift; my $list = shift; my @imports = (); my @other = (); my $idx = 0; while( $idx <= $#{$list} ) { my $item = $list->[$idx]; if( defined $item and $item eq 'import' ) { push @imports, @{ $list->[ $idx + 1 ] }; $idx++; } else { push @other, $item; } $idx++; } @$list = @other; return @imports; } #line 139 sub import_extra { } #line 169 sub builder { return Test::Builder->new; } #line 180 1; libtest-nginx-perl-0.32/inc/Test/More.pm000066400000000000000000000443361522511534200201270ustar00rootroot00000000000000#line 1 package Test::More; use 5.006; use strict; use warnings; #---- perlcritic exemptions. ----# # We use a lot of subroutine prototypes ## no critic (Subroutines::ProhibitSubroutinePrototypes) # Can't use Carp because it might cause C to accidentally succeed # even though the module being used forgot to use Carp. Yes, this # actually happened. sub _carp { my( $file, $line ) = ( caller(1) )[ 1, 2 ]; return warn @_, " at $file line $line\n"; } our $VERSION = '1.302191'; use Test::Builder::Module; our @ISA = qw(Test::Builder::Module); our @EXPORT = qw(ok use_ok require_ok is isnt like unlike is_deeply cmp_ok skip todo todo_skip pass fail eq_array eq_hash eq_set $TODO plan done_testing can_ok isa_ok new_ok diag note explain subtest BAIL_OUT ); #line 166 sub plan { my $tb = Test::More->builder; return $tb->plan(@_); } # This implements "use Test::More 'no_diag'" but the behavior is # deprecated. sub import_extra { my $class = shift; my $list = shift; my @other = (); my $idx = 0; my $import; while( $idx <= $#{$list} ) { my $item = $list->[$idx]; if( defined $item and $item eq 'no_diag' ) { $class->builder->no_diag(1); } elsif( defined $item and $item eq 'import' ) { if ($import) { push @$import, @{$list->[ ++$idx ]}; } else { $import = $list->[ ++$idx ]; push @other, $item, $import; } } else { push @other, $item; } $idx++; } @$list = @other; if ($class eq __PACKAGE__ && (!$import || grep $_ eq '$TODO', @$import)) { my $to = $class->builder->exported_to; no strict 'refs'; *{"$to\::TODO"} = \our $TODO; if ($import) { @$import = grep $_ ne '$TODO', @$import; } else { push @$list, import => [grep $_ ne '$TODO', @EXPORT]; } } return; } #line 245 sub done_testing { my $tb = Test::More->builder; $tb->done_testing(@_); } #line 317 sub ok ($;$) { my( $test, $name ) = @_; my $tb = Test::More->builder; return $tb->ok( $test, $name ); } #line 400 sub is ($$;$) { my $tb = Test::More->builder; return $tb->is_eq(@_); } sub isnt ($$;$) { my $tb = Test::More->builder; return $tb->isnt_eq(@_); } # make this available as isn't() *isn::t = \&isnt; #line 445 sub like ($$;$) { my $tb = Test::More->builder; return $tb->like(@_); } #line 460 sub unlike ($$;$) { my $tb = Test::More->builder; return $tb->unlike(@_); } #line 506 sub cmp_ok($$$;$) { my $tb = Test::More->builder; return $tb->cmp_ok(@_); } #line 541 sub can_ok ($@) { my( $proto, @methods ) = @_; my $class = ref $proto || $proto; my $tb = Test::More->builder; unless($class) { my $ok = $tb->ok( 0, "->can(...)" ); $tb->diag(' can_ok() called with empty class or reference'); return $ok; } unless(@methods) { my $ok = $tb->ok( 0, "$class->can(...)" ); $tb->diag(' can_ok() called with no methods'); return $ok; } my @nok = (); foreach my $method (@methods) { $tb->_try( sub { $proto->can($method) } ) or push @nok, $method; } my $name = (@methods == 1) ? "$class->can('$methods[0]')" : "$class->can(...)" ; my $ok = $tb->ok( !@nok, $name ); $tb->diag( map " $class->can('$_') failed\n", @nok ); return $ok; } #line 607 sub isa_ok ($$;$) { my( $thing, $class, $thing_name ) = @_; my $tb = Test::More->builder; my $whatami; if( !defined $thing ) { $whatami = 'undef'; } elsif( ref $thing ) { $whatami = 'reference'; local($@,$!); require Scalar::Util; if( Scalar::Util::blessed($thing) ) { $whatami = 'object'; } } else { $whatami = 'class'; } # We can't use UNIVERSAL::isa because we want to honor isa() overrides my( $rslt, $error ) = $tb->_try( sub { $thing->isa($class) } ); if($error) { die <isa on your $whatami and got some weird error. Here's the error. $error WHOA } # Special case for isa_ok( [], "ARRAY" ) and like if( $whatami eq 'reference' ) { $rslt = UNIVERSAL::isa($thing, $class); } my($diag, $name); if( defined $thing_name ) { $name = "'$thing_name' isa '$class'"; $diag = defined $thing ? "'$thing_name' isn't a '$class'" : "'$thing_name' isn't defined"; } elsif( $whatami eq 'object' ) { my $my_class = ref $thing; $thing_name = qq[An object of class '$my_class']; $name = "$thing_name isa '$class'"; $diag = "The object of class '$my_class' isn't a '$class'"; } elsif( $whatami eq 'reference' ) { my $type = ref $thing; $thing_name = qq[A reference of type '$type']; $name = "$thing_name isa '$class'"; $diag = "The reference of type '$type' isn't a '$class'"; } elsif( $whatami eq 'undef' ) { $thing_name = 'undef'; $name = "$thing_name isa '$class'"; $diag = "$thing_name isn't defined"; } elsif( $whatami eq 'class' ) { $thing_name = qq[The class (or class-like) '$thing']; $name = "$thing_name isa '$class'"; $diag = "$thing_name isn't a '$class'"; } else { die; } my $ok; if($rslt) { $ok = $tb->ok( 1, $name ); } else { $ok = $tb->ok( 0, $name ); $tb->diag(" $diag\n"); } return $ok; } #line 708 sub new_ok { my $tb = Test::More->builder; $tb->croak("new_ok() must be given at least a class") unless @_; my( $class, $args, $object_name ) = @_; $args ||= []; my $obj; my( $success, $error ) = $tb->_try( sub { $obj = $class->new(@$args); 1 } ); if($success) { local $Test::Builder::Level = $Test::Builder::Level + 1; isa_ok $obj, $class, $object_name; } else { $class = 'undef' if !defined $class; $tb->ok( 0, "$class->new() died" ); $tb->diag(" Error was: $error"); } return $obj; } #line 805 sub subtest { my $tb = Test::More->builder; return $tb->subtest(@_); } #line 827 sub pass (;$) { my $tb = Test::More->builder; return $tb->ok( 1, @_ ); } sub fail (;$) { my $tb = Test::More->builder; return $tb->ok( 0, @_ ); } #line 880 sub require_ok ($) { my($module) = shift; my $tb = Test::More->builder; my $pack = caller; # Try to determine if we've been given a module name or file. # Module names must be barewords, files not. $module = qq['$module'] unless _is_module_name($module); my $code = <ok( $eval_result, "require $module;" ); unless($ok) { chomp $eval_error; $tb->diag(<builder; my %caller; @caller{qw/pack file line sub args want eval req strict warn/} = caller(0); my ($pack, $filename, $line, $warn) = @caller{qw/pack file line warn/}; $filename =~ y/\n\r/_/; # so it doesn't run off the "#line $line $f" line my $code; if( @imports == 1 and $imports[0] =~ /^\d+(?:\.\d+)?$/ ) { # probably a version check. Perl needs to see the bare number # for it to work with non-Exporter based modules. $code = <ok( $eval_result, "use $module;" ); unless($ok) { chomp $eval_error; $@ =~ s{^BEGIN failed--compilation aborted at .*$} {BEGIN failed--compilation aborted at $filename line $line.}m; $tb->diag(<builder; unless( @_ == 2 or @_ == 3 ) { my $msg = <<'WARNING'; is_deeply() takes two or three args, you gave %d. This usually means you passed an array or hash instead of a reference to it WARNING chop $msg; # clip off newline so carp() will put in line/file _carp sprintf $msg, scalar @_; return $tb->ok(0); } my( $got, $expected, $name ) = @_; $tb->_unoverload_str( \$expected, \$got ); my $ok; if( !ref $got and !ref $expected ) { # neither is a reference $ok = $tb->is_eq( $got, $expected, $name ); } elsif( !ref $got xor !ref $expected ) { # one's a reference, one isn't $ok = $tb->ok( 0, $name ); $tb->diag( _format_stack({ vals => [ $got, $expected ] }) ); } else { # both references local @Data_Stack = (); if( _deep_check( $got, $expected ) ) { $ok = $tb->ok( 1, $name ); } else { $ok = $tb->ok( 0, $name ); $tb->diag( _format_stack(@Data_Stack) ); } } return $ok; } sub _format_stack { my(@Stack) = @_; my $var = '$FOO'; my $did_arrow = 0; foreach my $entry (@Stack) { my $type = $entry->{type} || ''; my $idx = $entry->{'idx'}; if( $type eq 'HASH' ) { $var .= "->" unless $did_arrow++; $var .= "{$idx}"; } elsif( $type eq 'ARRAY' ) { $var .= "->" unless $did_arrow++; $var .= "[$idx]"; } elsif( $type eq 'REF' ) { $var = "\${$var}"; } } my @vals = @{ $Stack[-1]{vals} }[ 0, 1 ]; my @vars = (); ( $vars[0] = $var ) =~ s/\$FOO/ \$got/; ( $vars[1] = $var ) =~ s/\$FOO/\$expected/; my $out = "Structures begin differing at:\n"; foreach my $idx ( 0 .. $#vals ) { my $val = $vals[$idx]; $vals[$idx] = !defined $val ? 'undef' : _dne($val) ? "Does not exist" : ref $val ? "$val" : "'$val'"; } $out .= "$vars[0] = $vals[0]\n"; $out .= "$vars[1] = $vals[1]\n"; $out =~ s/^/ /msg; return $out; } sub _type { my $thing = shift; return '' if !ref $thing; for my $type (qw(Regexp ARRAY HASH REF SCALAR GLOB CODE VSTRING)) { return $type if UNIVERSAL::isa( $thing, $type ); } return ''; } #line 1252 sub diag { return Test::More->builder->diag(@_); } sub note { return Test::More->builder->note(@_); } #line 1278 sub explain { return Test::More->builder->explain(@_); } #line 1344 ## no critic (Subroutines::RequireFinalReturn) sub skip { my( $why, $how_many ) = @_; my $tb = Test::More->builder; # If the plan is set, and is static, then skip needs a count. If the plan # is 'no_plan' we are fine. As well if plan is undefined then we are # waiting for done_testing. unless (defined $how_many) { my $plan = $tb->has_plan; _carp "skip() needs to know \$how_many tests are in the block" if $plan && $plan =~ m/^\d+$/; $how_many = 1; } if( defined $how_many and $how_many =~ /\D/ ) { _carp "skip() was passed a non-numeric number of tests. Did you get the arguments backwards?"; $how_many = 1; } for( 1 .. $how_many ) { $tb->skip($why); } no warnings 'exiting'; last SKIP; } #line 1440 sub todo_skip { my( $why, $how_many ) = @_; my $tb = Test::More->builder; unless( defined $how_many ) { # $how_many can only be avoided when no_plan is in use. _carp "todo_skip() needs to know \$how_many tests are in the block" unless $tb->has_plan eq 'no_plan'; $how_many = 1; } for( 1 .. $how_many ) { $tb->todo_skip($why); } no warnings 'exiting'; last TODO; } #line 1495 sub BAIL_OUT { my $reason = shift; my $tb = Test::More->builder; $tb->BAIL_OUT($reason); } #line 1534 #'# sub eq_array { local @Data_Stack = (); _deep_check(@_); } sub _eq_array { my( $a1, $a2 ) = @_; if( grep _type($_) ne 'ARRAY', $a1, $a2 ) { warn "eq_array passed a non-array ref"; return 0; } return 1 if $a1 eq $a2; my $ok = 1; my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2; for( 0 .. $max ) { my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_]; my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_]; next if _equal_nonrefs($e1, $e2); push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [ $e1, $e2 ] }; $ok = _deep_check( $e1, $e2 ); pop @Data_Stack if $ok; last unless $ok; } return $ok; } sub _equal_nonrefs { my( $e1, $e2 ) = @_; return if ref $e1 or ref $e2; if ( defined $e1 ) { return 1 if defined $e2 and $e1 eq $e2; } else { return 1 if !defined $e2; } return; } sub _deep_check { my( $e1, $e2 ) = @_; my $tb = Test::More->builder; my $ok = 0; # Effectively turn %Refs_Seen into a stack. This avoids picking up # the same referenced used twice (such as [\$a, \$a]) to be considered # circular. local %Refs_Seen = %Refs_Seen; { $tb->_unoverload_str( \$e1, \$e2 ); # Either they're both references or both not. my $same_ref = !( !ref $e1 xor !ref $e2 ); my $not_ref = ( !ref $e1 and !ref $e2 ); if( defined $e1 xor defined $e2 ) { $ok = 0; } elsif( !defined $e1 and !defined $e2 ) { # Shortcut if they're both undefined. $ok = 1; } elsif( _dne($e1) xor _dne($e2) ) { $ok = 0; } elsif( $same_ref and( $e1 eq $e2 ) ) { $ok = 1; } elsif($not_ref) { push @Data_Stack, { type => '', vals => [ $e1, $e2 ] }; $ok = 0; } else { if( $Refs_Seen{$e1} ) { return $Refs_Seen{$e1} eq $e2; } else { $Refs_Seen{$e1} = "$e2"; } my $type = _type($e1); $type = 'DIFFERENT' unless _type($e2) eq $type; if( $type eq 'DIFFERENT' ) { push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] }; $ok = 0; } elsif( $type eq 'ARRAY' ) { $ok = _eq_array( $e1, $e2 ); } elsif( $type eq 'HASH' ) { $ok = _eq_hash( $e1, $e2 ); } elsif( $type eq 'REF' ) { push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] }; $ok = _deep_check( $$e1, $$e2 ); pop @Data_Stack if $ok; } elsif( $type eq 'SCALAR' ) { push @Data_Stack, { type => 'REF', vals => [ $e1, $e2 ] }; $ok = _deep_check( $$e1, $$e2 ); pop @Data_Stack if $ok; } elsif($type) { push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] }; $ok = 0; } else { _whoa( 1, "No type in _deep_check" ); } } } return $ok; } sub _whoa { my( $check, $desc ) = @_; if($check) { die <<"WHOA"; WHOA! $desc This should never happen! Please contact the author immediately! WHOA } } #line 1681 sub eq_hash { local @Data_Stack = (); return _deep_check(@_); } sub _eq_hash { my( $a1, $a2 ) = @_; if( grep _type($_) ne 'HASH', $a1, $a2 ) { warn "eq_hash passed a non-hash ref"; return 0; } return 1 if $a1 eq $a2; my $ok = 1; my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2; foreach my $k ( keys %$bigger ) { my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE; my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE; next if _equal_nonrefs($e1, $e2); push @Data_Stack, { type => 'HASH', idx => $k, vals => [ $e1, $e2 ] }; $ok = _deep_check( $e1, $e2 ); pop @Data_Stack if $ok; last unless $ok; } return $ok; } #line 1740 sub eq_set { my( $a1, $a2 ) = @_; return 0 unless @$a1 == @$a2; no warnings 'uninitialized'; # It really doesn't matter how we sort them, as long as both arrays are # sorted with the same algorithm. # # Ensure that references are not accidentally treated the same as a # string containing the reference. # # Have to inline the sort routine due to a threading/sort bug. # See [rt.cpan.org 6782] # # I don't know how references would be sorted so we just don't sort # them. This means eq_set doesn't really work with refs. return eq_array( [ grep( ref, @$a1 ), sort( grep( !ref, @$a1 ) ) ], [ grep( ref, @$a2 ), sort( grep( !ref, @$a2 ) ) ], ); } #line 2004 1; libtest-nginx-perl-0.32/lib/000077500000000000000000000000001522511534200157335ustar00rootroot00000000000000libtest-nginx-perl-0.32/lib/Test/000077500000000000000000000000001522511534200166525ustar00rootroot00000000000000libtest-nginx-perl-0.32/lib/Test/Nginx.pm000066400000000000000000000136641522511534200203050ustar00rootroot00000000000000package Test::Nginx; use strict; use warnings; our $VERSION = '0.32'; __END__ =encoding utf-8 =head1 NAME Test::Nginx - Data-driven test scaffold for Nginx C module and Nginx/OpenResty-based libraries and applications =head1 DESCRIPTION This distribution provides two testing modules for Nginx C module development: =over =item * L (This is highly recommended.) This library also has the following subclasses: =over =item * L =item * L =item * L =back =item * L (This is obsolete.) =back All of them are based on L. Usually, L is preferred because it works on a much lower level and not that fault tolerant like L. Also, a lot of connection hang issues (like wrong C<< r->main->count >> value in nginx 0.8.x) can only be captured by L because Perl's L client will close the connection itself which will conceal such issues from the testers. Test::Nginx automatically starts an nginx instance (from the C env) rooted at t/servroot/ and the default config template makes this nginx instance listen on the port C<1984> by default. One can specify a different port number by setting his port number to the C environment, as in export TEST_NGINX_PORT=1989 =head1 User Guide You can find a comprehensive user guide on this test framework in my upcoming book "Programming OpenResty": L =head1 Nginx C modules that use Test::Nginx to drive their test suites =over =item ngx_echo L =item ngx_headers_more L =item ngx_chunkin L =item ngx_memc L =item ngx_drizzle L =item ngx_rds_json L =item ngx_rds_csv L =item ngx_xss L =item ngx_srcache L =item ngx_lua L =item ngx_set_misc L =item ngx_array_var L =item ngx_form_input L =item ngx_iconv L =item ngx_set_cconv L =item ngx_postgres L =item ngx_coolkit L =item Naxsi L =item ngx_shibboleth L =back =head1 INSTALLATION If you have `cpan` installed, you can simply run the command to install this module: sudo cpan Test::Nginx If you want to install from the source code directory directly, you can run sudo cpan . If you prefer F to F (like I do!), you can replace C in the commands above with C. Otherwise you can install this module in the good old way below: perl Makefile.PL make sudo make install =head1 SOURCE REPOSITORY This module has a Git repository on Github, which has access for all. L If you want a commit bit, feel free to drop me a line. =head1 DEBIAN PACKAGES António P. P. Almeida is maintaining a Debian package for this module in his Debian repository: L =head1 Community =head2 English Mailing List The C mailing list is for English speakers: L =head2 Chinese Mailing List The C mailing list is for Chinese speakers: L =head1 AUTHORS Yichun Zhang (agentzh) C<< >>, OpenResty Inc. Antoine BONAVITA C<< >> =head1 COPYRIGHT & LICENSE Copyright (c) 2009-2025, Yichun Zhang (agentzh) C<< >>, OpenResty Inc. Copyright (c) 2011-2012, Antoine Bonavita C<< >>. This module is licensed under the terms of the BSD license. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: =over =item * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. =item * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. =item * Neither the name of the authors nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. =back THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. =head1 SEE ALSO L, L, L. libtest-nginx-perl-0.32/lib/Test/Nginx/000077500000000000000000000000001522511534200177355ustar00rootroot00000000000000libtest-nginx-perl-0.32/lib/Test/Nginx/LWP.pm000066400000000000000000000320361522511534200207410ustar00rootroot00000000000000package Test::Nginx::LWP; use lib 'lib'; use lib 'inc'; use Test::Base -Base; our $VERSION = '0.32'; our $NoLongString; use LWP::UserAgent; use Time::HiRes qw(sleep); use Test::LongString; use Test::Nginx::Util qw( setup_server_root write_config_file get_canon_version get_nginx_version trim show_all_chars parse_headers run_tests $ServerPortForClient $PidFile $ServRoot $ConfFile $ServerPort $RunTestHelper $NoNginxManager $RepeatEach worker_connections master_process_enabled master_on master_off config_preamble repeat_each no_shuffle no_root_location ); our $UserAgent = LWP::UserAgent->new; $UserAgent->agent(__PACKAGE__); #$UserAgent->default_headers(HTTP::Headers->new); #use Smart::Comments::JSON '##'; our @EXPORT = qw( plan run_tests run_test repeat_each config_preamble worker_connections master_process_enabled master_on master_off no_long_string no_shuffle no_root_location); sub no_long_string () { $NoLongString = 1; } sub run_test_helper ($$); $RunTestHelper = \&run_test_helper; sub parse_request ($$) { my ($name, $rrequest) = @_; open my $in, '<', $rrequest; my $first = <$in>; if (!$first) { Test::More::BAIL_OUT("$name - Request line should be non-empty"); die; } $first =~ s/^\s+|\s+$//g; my ($meth, $rel_url) = split /\s+/, $first, 2; my $url = "http://localhost:$ServerPortForClient" . $rel_url; my $content = do { local $/; <$in> }; if ($content) { $content =~ s/^\s+|\s+$//s; } close $in; return { method => $meth, url => $url, content => $content, }; } sub chunk_it ($$$) { my ($chunks, $start_delay, $middle_delay) = @_; my $i = 0; return sub { if ($i == 0) { if ($start_delay) { sleep($start_delay); } } elsif ($middle_delay) { sleep($middle_delay); } return $chunks->[$i++]; } } sub run_test_helper ($$) { my ($block, $dry_run) = @_; my $request = $block->request; my $name = $block->name; #if (defined $TODO) { #$name .= "# $TODO"; #} my $req_spec = parse_request($name, \$request); ## $req_spec my $method = $req_spec->{method}; my $req = HTTP::Request->new($method); my $content = $req_spec->{content}; if (defined ($block->request_headers)) { my $headers = parse_headers($block->request_headers); while (my ($key, $val) = each %$headers) { $req->header($key => $val); } } #$req->header('Accept', '*/*'); $req->url($req_spec->{url}); if ($content) { if ($method eq 'GET' or $method eq 'HEAD') { croak "HTTP 1.0/1.1 $method request should not have content: $content"; } $req->content($content); } elsif ($method eq 'POST' or $method eq 'PUT') { my $chunks = $block->chunked_body; if (defined $chunks) { if (!ref $chunks or ref $chunks ne 'ARRAY') { Test::More::BAIL_OUT("$name - --- chunked_body should takes a Perl array ref as its value"); } my $start_delay = $block->start_chunk_delay || 0; my $middle_delay = $block->middle_chunk_delay || 0; $req->content(chunk_it($chunks, $start_delay, $middle_delay)); if (!defined $req->header('Content-Type')) { $req->header('Content-Type' => 'text/plain'); } } else { if (!defined $req->header('Content-Type')) { $req->header('Content-Type' => 'text/plain'); } $req->header('Content-Length' => 0); } } if ($block->more_headers) { my @headers = split /\n+/, $block->more_headers; for my $header (@headers) { next if $header =~ /^\s*\#/; my ($key, $val) = split /:\s*/, $header, 2; #warn "[$key, $val]\n"; $req->header($key => $val); } } #warn "req: ", $req->as_string, "\n"; #warn "DONE!!!!!!!!!!!!!!!!!!!!"; my $res = HTTP::Response->new; unless ($dry_run) { $res = $UserAgent->request($req); } #warn "res returned!!!"; if ($dry_run) { SKIP: { Test::More::skip("$name - tests skipped due to $dry_run", 1); } } else { if (defined $block->error_code) { is($res->code, $block->error_code, "$name - status code ok"); } else { is($res->code, 200, "$name - status code ok"); } } if (defined $block->response_headers) { my $headers = parse_headers($block->response_headers); while (my ($key, $val) = each %$headers) { my $expected_val = $res->header($key); if (!defined $expected_val) { $expected_val = ''; } if ($dry_run) { SKIP: { Test::More::skip("$name - tests skipped due to $dry_run", 1); } } else { is $expected_val, $val, "$name - header $key ok"; } } } elsif (defined $block->response_headers_like) { my $headers = parse_headers($block->response_headers_like); while (my ($key, $val) = each %$headers) { my $expected_val = $res->header($key); if (!defined $expected_val) { $expected_val = ''; } if ($dry_run) { SKIP: { Test::More::skip("$name - tests skipped due to $dry_run", 1); } } else { like $expected_val, qr/^$val$/, "$name - header $key like ok"; } } } if (defined $block->response_body) { my $content = $res->content; if (defined $content) { $content =~ s/^TE: deflate,gzip;q=0\.3\r\n//gms; } $content =~ s/^Connection: TE, close\r\n//gms; my $expected = $block->response_body; $expected =~ s/\$ServerPort\b/$ServerPort/g; $expected =~ s/\$ServerPortForClient\b/$ServerPortForClient/g; #warn show_all_chars($content); if ($dry_run) { SKIP: { Test::More::skip("$name - tests skipped due to $dry_run", 1); } } else { if ($NoLongString) { is($content, $expected, "$name - response_body - response is expected"); } else { is_string($content, $expected, "$name - response_body - response is expected"); } #is($content, $expected, "$name - response_body - response is expected"); } } elsif (defined $block->response_body_like) { my $content = $res->content; if (defined $content) { $content =~ s/^TE: deflate,gzip;q=0\.3\r\n//gms; } $content =~ s/^Connection: TE, close\r\n//gms; my $expected_pat = $block->response_body_like; $expected_pat =~ s/\$ServerPort\b/$ServerPort/g; $expected_pat =~ s/\$ServerPortForClient\b/$ServerPortForClient/g; my $summary = trim($content); if ($dry_run) { SKIP: { Test::More::skip("$name - tests skipped due to $dry_run", 1); } } else { like($content, qr/$expected_pat/s, "$name - response_body_like - response is expected ($summary)"); } } } 1; __END__ =encoding utf-8 =head1 NAME Test::Nginx::LWP - LWP-backed test scaffold for the Nginx C modules =head1 SYNOPSIS use Test::Nginx::LWP; plan tests => $Test::Nginx::LWP::RepeatEach * 2 * blocks(); run_tests(); __DATA__ === TEST 1: sanity --- config location /echo { echo_before_body hello; echo world; } --- request GET /echo --- response_body hello world --- error_code: 200 === TEST 2: set Server --- config location /foo { echo hi; more_set_headers 'Server: Foo'; } --- request GET /foo --- response_headers Server: Foo --- response_body hi === TEST 3: clear Server --- config location /foo { echo hi; more_clear_headers 'Server: '; } --- request GET /foo --- response_headers_like Server: nginx.* --- response_body hi === TEST 4: set request header at client side and rewrite it --- config location /foo { more_set_input_headers 'X-Foo: howdy'; echo $http_x_foo; } --- request GET /foo --- request_headers X-Foo: blah --- response_headers X-Foo: --- response_body howdy === TEST 3: rewrite content length --- config location /bar { more_set_input_headers 'Content-Length: 2048'; echo_read_request_body; echo_request_body; } --- request eval "POST /bar\n" . "a" x 4096 --- response_body eval "a" x 2048 === TEST 4: timer without explicit reset --- config location /timer { echo_sleep 0.03; echo "elapsed $echo_timer_elapsed sec."; } --- request GET /timer --- response_body_like ^elapsed 0\.0(2[6-9]|3[0-6]) sec\.$ === TEST 5: small buf (using 2-byte buf) --- config chunkin on; location /main { client_body_buffer_size 2; echo "body:"; echo $echo_request_body; echo_request_body; } --- request POST /main --- start_chunk_delay: 0.01 --- middle_chunk_delay: 0.01 --- chunked_body eval ["hello", "world"] --- error_code: 200 --- response_body eval "body: helloworld" =head1 DESCRIPTION This module provides a test scaffold based on L for automated testing in Nginx C module development. This class inherits from L, thus bringing all its declarative power to the Nginx C module testing practices. You need to terminate or kill any Nginx processes before running the test suite if you have changed the Nginx server binary. Normally it's as simple as killall nginx PATH=/path/to/your/nginx-with-memc-module:$PATH prove -r t This module will create a temporary server root under t/servroot/ of the current working directory and starts and uses the nginx executable in the PATH environment. You will often want to look into F when things go wrong ;) =head1 Sections supported The following sections are supported: =over =item config =item http_config =item request =item request_headers =item more_headers =item response_body =item response_body_like =item response_headers =item response_headers_like =item error_code =item chunked_body =item middle_chunk_delay =item start_chunk_delay =back =head1 Samples You'll find live samples in the following Nginx 3rd-party modules: =over =item ngx_echo L =item ngx_headers_more L =item ngx_chunkin L =item ngx_memc L =back =head1 SOURCE REPOSITORY This module has a Git repository on Github, which has access for all. http://github.com/agentzh/test-nginx If you want a commit bit, feel free to drop me a line. =head1 AUTHOR agentzh (章亦春) C<< >> =head1 COPYRIGHT & LICENSE Copyright (c) 2009-2025, agentzh C<< >>. This module is licensed under the terms of the BSD license. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: =over =item * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. =item * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. =item * Neither the name of the authors nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. =back THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. =head1 SEE ALSO L, L. libtest-nginx-perl-0.32/lib/Test/Nginx/Socket.pm000066400000000000000000004534671522511534200215460ustar00rootroot00000000000000package Test::Nginx::Socket; use lib 'lib'; use lib 'inc'; use v5.10.1; use Test::Base -Base; our $VERSION = '0.32'; use POSIX qw( SIGQUIT SIGKILL SIGTERM SIGHUP ); use Encode; #use Data::Dumper; use Time::HiRes qw(sleep time); use Test::LongString; use List::MoreUtils qw( any ); use List::Util qw( sum min ); use IO::Select (); use File::Temp qw( tempfile ); use Digest::MD5 (); use Digest::SHA (); use POSIX ":sys_wait_h"; use Test::Nginx::Util; use JSON::PP; #use Smart::Comments::JSON '###'; use Fcntl qw(F_GETFL F_SETFL O_NONBLOCK); use POSIX qw(EAGAIN); use IO::Socket; #our ($PrevRequest, $PrevConfig); our @EXPORT = qw( env_to_nginx is_str plan run_tests run_test repeat_each config_preamble worker_connections master_process_enabled no_long_string workers master_on master_off log_level no_shuffle no_root_location use_hup server_name server_addr server_root html_dir server_port server_port_for_client timeout no_nginx_manager check_accum_error_log add_block_preprocessor bail_out add_test_cleanup_handler add_cleanup_handler add_response_body_check ); our $CheckLeakCount = $ENV{TEST_NGINX_CHECK_LEAK_COUNT} // 100; our $UseHttp2 = $Test::Nginx::Util::UseHttp2; our $TotalConnectingTimeouts = 0; our $PrevNginxPid; our $UseValgrind = $ENV{TEST_NGINX_USE_VALGRIND}; sub send_request ($$$$@); sub send_http_req_by_curl ($$$); sub run_filter_helper($$$); sub run_test_helper ($$); sub test_stap ($$); sub error_event_handler ($); sub read_event_handler ($); sub write_event_handler ($); sub transform_response_body ($$$); sub check_response_body ($$$$$$); sub fmt_str ($); sub gen_ab_cmd_from_req ($$@); sub gen_curl_cmd_from_req ($$); sub get_linear_regression_slope ($); sub value_contains ($$); $RunTestHelper = \&run_test_helper; $CheckErrorLog = \&check_error_log; $CheckShutdownErrorLog = \&check_shutdown_error_log; sub set_http_config_filter ($) { $FilterHttpConfig = shift; } our @ResponseBodyChecks; sub add_response_body_check ($) { push @ResponseBodyChecks, shift; } # This will parse a "request"" string. The expected format is: # - One line for the HTTP verb (POST, GET, etc.) plus optional relative URL # (default is /) plus optional HTTP version (default is HTTP/1.1). # - More lines considered as the body of the request. # Most people don't care about headers and this is enough. # # This function will return a reference to a hash with the parsed elements # plus information on the parsing itself like "how many white spaces were # skipped before the VERB" (skipped_before_method), "was the version provided" # (http_ver_size = 0). sub parse_request ($$) { my ( $name, $rrequest ) = @_; open my $in, '<', $rrequest; my $first = <$in>; if ( !$first ) { bail_out("$name - Request line should be non-empty"); } #$first =~ s/^\s+|\s+$//gs; my ($before_meth, $meth, $after_meth); my ($rel_url, $rel_url_size, $after_rel_url); my ($http_ver, $http_ver_size, $after_http_ver); my $end_line_size; if ($first =~ /^(\s*)(\S+)( *)((\S+)( *))?((\S+)( *))?(\s*)$/) { $before_meth = defined $1 ? length($1) : undef; $meth = $2; $after_meth = defined $3 ? length($3) : undef; $rel_url = $5; $rel_url_size = defined $5 ? length($5) : undef; $after_rel_url = defined $6 ? length($6) : undef; $http_ver = $8; if (!defined $8) { $http_ver_size = undef; } else { $http_ver_size = defined $8 ? length($8) : undef; } if (!defined $9) { $after_http_ver = undef; } else { $after_http_ver = defined $9 ? length($9) : undef; } $end_line_size = defined $10 ? length($10) : undef; } else { bail_out("$name - Request line is not valid. Should be 'meth [url [version]]' but got \"$first\"."); } if ( !defined $rel_url ) { $rel_url = '/'; $rel_url_size = 0; $after_rel_url = 0; } if ( !defined $http_ver ) { $http_ver = 'HTTP/1.1'; $http_ver_size = 0; $after_http_ver = 0; } #my $url = "http://localhost:$ServerPortForClient" . $rel_url; my $content = do { local $/; <$in> }; my $content_size; if ( !defined $content ) { $content = ""; $content_size = 0; } else { $content_size = length($content); } #warn Dumper($content); close $in; return { method => $meth, url => $rel_url, content => $content, http_ver => $http_ver, skipped_before_method => $before_meth, method_size => length($meth), skipped_after_method => $after_meth, url_size => $rel_url_size, skipped_after_url => $after_rel_url, http_ver_size => $http_ver_size, skipped_after_http_ver => $after_http_ver + $end_line_size, content_size => $content_size, }; } # From a parsed request, builds the "moves" to apply to the original request # to transform it (e.g. add missing version). Elements of the returned array # are of 2 types: # - d : number of characters to remove. # - s_* : number of characters (s_s) to replace by value (s_v). sub get_moves($) { my ($parsed_req) = @_; return ({d => $parsed_req->{skipped_before_method}}, {s_s => $parsed_req->{method_size}, s_v => $parsed_req->{method}}, {d => $parsed_req->{skipped_after_method}}, {s_s => $parsed_req->{url_size}, s_v => $parsed_req->{url}}, {d => $parsed_req->{skipped_after_url}}, {s_s => $parsed_req->{http_ver_size}, s_v => $parsed_req->{http_ver}}, {d => $parsed_req->{skipped_after_http_ver}}, {s_s => 0, s_v => $parsed_req->{headers}}, {s_s => $parsed_req->{content_size}, s_v => $parsed_req->{content}} ); } # Apply moves (see above) to an array of packets that correspond to a request. # The use of this function is explained in the build_request_from_packets # function. sub apply_moves($$) { my ($r_packet, $r_move) = @_; my $current_packet = shift @$r_packet; my $current_move = shift @$r_move; my $in_packet_cursor = 0; my @result = (); while (defined $current_packet) { if (!defined $current_move) { push @result, $current_packet; $current_packet = shift @$r_packet; $in_packet_cursor = 0; } elsif (defined $current_move->{d}) { # Remove stuff from packet if ($current_move->{d} > length($current_packet) - $in_packet_cursor) { # Eat up what is left of packet. $current_move->{d} -= length($current_packet) - $in_packet_cursor; if ($in_packet_cursor > 0) { # Something in packet from previous iteration. push @result, $current_packet; } $current_packet = shift @$r_packet; $in_packet_cursor = 0; } else { # Remove from current point in current packet substr($current_packet, $in_packet_cursor, $current_move->{d}) = ''; $current_move = shift @$r_move; } } else { # Substitute stuff if ($current_move->{s_s} > length($current_packet) - $in_packet_cursor) { # {s_s=>3, s_v=>GET} on ['GE', 'T /foo'] $current_move->{s_s} -= length($current_packet) - $in_packet_cursor; substr($current_packet, $in_packet_cursor) = substr($current_move->{s_v}, 0, length($current_packet) - $in_packet_cursor); push @result, $current_packet; $current_move->{s_v} = substr($current_move->{s_v}, length($current_packet) - $in_packet_cursor); $current_packet = shift @$r_packet; $in_packet_cursor = 0; } else { substr($current_packet, $in_packet_cursor, $current_move->{s_s}) = $current_move->{s_v}; $in_packet_cursor += length($current_move->{s_v}); $current_move = shift @$r_move; } } } return \@result; } # Given a request as an array of packets, will parse it, append the appropriate # headers and return another array of packets. # The function implemented here can be high-level summarized as: # 1 - Concatenate all packets to obtain a string representation of request. # 2 - Parse the string representation # 3 - Get the "moves" from the parsing # 4 - Apply the "moves" to the packets. sub build_request_from_packets($$$$$) { my ( $name, $more_headers, $is_chunked, $conn_header, $request_packets ) = @_; # Concatenate packets as a string my $parsable_request = ''; my @packet_length; for my $one_packet (@$request_packets) { $parsable_request .= $one_packet; push @packet_length, length($one_packet); } # Parse the string representation. my $parsed_req = parse_request( $name, \$parsable_request ); # Append headers my $len_header = ''; if ( !$is_chunked && defined $parsed_req->{content} && $parsed_req->{content} ne '' && $more_headers !~ /(?:^|\n)Content-Length:/ ) { $parsed_req->{content} =~ s/^\s+|\s+$//gs; $len_header .= "Content-Length: " . length( $parsed_req->{content} ) . "\r\n"; } $more_headers =~ s/(?{method} .= ' '; $parsed_req->{url} .= ' '; $parsed_req->{http_ver} .= "\r\n"; $parsed_req->{headers} = $headers; # Get the moves from parsing my @elements_moves = get_moves($parsed_req); # Apply them to the packets. return apply_moves($request_packets, \@elements_moves); } sub parse_more_headers ($) { my ($in) = @_; my @headers = split /\n+/, $in; my $is_chunked; my $out = ''; for my $header (@headers) { next if $header =~ /^\s*\#/; #warn "HEADER: $header"; my ($key, $val) = split /:\s*/, $header, 2; if (!defined $val) { $val = ''; } if (lc($key) eq 'transfer-encoding' and $val eq 'chunked') { $is_chunked = 1; } #warn "[$key, $val]\n"; $out .= "$key: $val\r\n"; } return $out, $is_chunked; } # Returns an array of array of hashes from the block. Each element of # the first-level array is a request. # Each request is an array of the "packets" to be sent. Each packet is a # string to send, with an (optionnal) delay before sending it. # This function parses (and therefore defines the syntax) of "request*" # sections. See documentation for supported syntax. sub get_req_from_block ($) { my ($block) = @_; my $name = $block->name; my @req_list = (); if (defined $block->raw_request) { # Should be deprecated. if (ref $block->raw_request && ref $block->raw_request eq 'ARRAY') { # User already provided an array. So, he/she specified where the # data should be split. This allows for backward compatibility but # should use request with arrays as it provides the same functionnality. my @rr_list = (); for my $elt (@{ $block->raw_request }) { push @rr_list, {value => $elt}; } push @req_list, \@rr_list; } else { push @req_list, [{value => $block->raw_request}]; } } else { my $request; if (defined $block->request_eval) { diag "$name - request_eval DEPRECATED. Use request eval instead."; $request = eval $block->request_eval; if ($@) { warn $@; } } else { $request = $block->request; if (defined $request) { while ($request =~ s/^\s*\#[^\n]+\s+|^\s+//gs) { # do nothing } } #warn "my req: $request"; } my $more_headers = $block->more_headers || ''; if ( $block->pipelined_requests ) { my $reqs = $block->pipelined_requests; if (!ref $reqs || ref $reqs ne 'ARRAY') { bail_out( "$name - invalid entries in --- pipelined_requests"); } my $i = 0; my $prq = ""; for my $request (@$reqs) { $request = expand_env_in_text $request, $name, $Test::Nginx::Util::RandPorts; my $conn_type; if ($i == @$reqs - 1) { $conn_type = 'close'; } else { $conn_type = 'keep-alive'; } my ($hdr, $is_chunked); if (ref $more_headers eq 'ARRAY') { #warn "Found ", scalar @$more_headers, " entries in --- more_headers."; $hdr = $more_headers->[$i]; if (!defined $hdr) { bail_out("--- more_headers lacks data for the $i pipelined request"); } ($hdr, $is_chunked) = parse_more_headers($hdr); #warn "more headers: $hdr"; } else { ($hdr, $is_chunked) = parse_more_headers($more_headers); } my $r_br = build_request_from_packets($name, $hdr, $is_chunked, $conn_type, [$request] ); $prq .= $$r_br[0]; $i++; } push @req_list, [{value =>$prq}]; } else { my ($is_chunked, $hdr); # request section. if (!ref $request) { if (ref $more_headers eq 'ARRAY') { #warn "Found ", scalar @$more_headers, " entries in --- more_headers."; $hdr = $more_headers->[0]; if (!defined $hdr) { bail_out("--- more_headers lacks data for the request"); } ($hdr, $is_chunked) = parse_more_headers($hdr); #warn "more headers: $hdr"; } else { ($hdr, $is_chunked) = parse_more_headers($more_headers); } # One request and it is a good old string. my $r_br = build_request_from_packets($name, $hdr, $is_chunked, 'close', [$request] ); push @req_list, [{value => $$r_br[0]}]; } elsif (ref $request eq 'ARRAY') { # A bunch of requests... my $i = 0; for my $one_req (@$request) { if (ref $more_headers eq 'ARRAY') { #warn "Found ", scalar @$more_headers, " entries in --- more_headers."; $hdr = $more_headers->[$i]; if (!defined $hdr) { bail_out("--- more_headers lacks data for the " . "${i}th request"); } ($hdr, $is_chunked) = parse_more_headers($hdr); #warn "more headers: $hdr"; } else { ($hdr, $is_chunked) = parse_more_headers($more_headers); } if (!ref $one_req) { # This request is a good old string. my $r_br = build_request_from_packets($name, $hdr, $is_chunked, 'close', [$one_req] ); push @req_list, [{value => $$r_br[0]}]; } elsif (ref $one_req eq 'ARRAY') { # Request expressed as a serie of packets my @packet_array = (); for my $one_packet (@$one_req) { if (!ref $one_packet) { # Packet is a string. push @packet_array, $one_packet; } elsif (ref $one_packet eq 'HASH'){ # Packet is a hash with a value... push @packet_array, $one_packet->{value}; } else { bail_out "$name - Invalid syntax. $one_packet should be a string or hash with value."; } } my $transformed_packet_array = build_request_from_packets($name, $hdr, $is_chunked, 'close', \@packet_array); my @transformed_req = (); my $idx = 0; for my $one_transformed_packet (@$transformed_packet_array) { if (!ref $$one_req[$idx]) { push @transformed_req, {value => $one_transformed_packet}; } else { # Is a HASH (checked above as $one_packet) $$one_req[$idx]->{value} = $one_transformed_packet; push @transformed_req, $$one_req[$idx]; } $idx++; } push @req_list, \@transformed_req; } else { bail_out "$name - Invalid syntax. $one_req should be a string or an array of packets."; } $i++; } } else { bail_out( "$name - invalid ---request : MUST be string or array of requests"); } } } return \@req_list; } sub quote_sh_args ($) { my ($args) = @_; for my $arg (@$args) { if ($arg =~ m{^[- "&%;,|?*.+=\w:/()]*$}) { if ($arg =~ /[ "&%;,|?*()]/) { $arg = "'$arg'"; } next; } $arg =~ s/\\/\\\\/g; $arg =~ s/'/\\'/g; $arg =~ s/\n/\\n/g; $arg =~ s/\r/\\r/g; $arg =~ s/\t/\\t/g; $arg = "\$'$arg'"; } return "@$args"; } sub run_filter_helper($$$) { my ($block, $filter, $content) = @_; my $name = $block->name; if (ref $filter && ref $filter eq 'CODE') { $content = $filter->($content); } elsif (!ref $filter) { for ($filter) { if ($_ eq 'md5_hex') { $content = Digest::MD5::md5_hex($content); } elsif ($_ eq 'sha1_hex') { $content = Digest::SHA::sha1_hex($content); } elsif ($_ eq 'uc') { $content = uc($content); } elsif ($_ eq 'lc') { $content = lc($content); } elsif ($_ eq 'ucfirst') { $content = ucfirst($content); } elsif ($_ eq 'lcfirst') { $content = lcfirst($content); } elsif ($_ eq 'length') { $content = length($content); } else { bail_out("$name - unknown filter, \"$filter\", " . "specified in the --- response_body_filters section"); } } } else { bail_out("$name - the --- response_body_filters section " . "only supports subroutine reference values and string values"); } return $content; } sub run_test_helper ($$) { my ($block, $dry_run, $repeated_req_idx) = @_; #warn "repeated req idx: $repeated_req_idx"; my $name = $block->name; my $r_req_list = get_req_from_block($block); if ( $#$r_req_list < 0 ) { bail_out("$name - request empty"); } if (defined $block->curl) { my $req = $r_req_list->[0]; my $cmd = gen_curl_cmd_from_req($block, $req); warn "# ", quote_sh_args($cmd), "\n"; } if ($CheckLeak) { $dry_run = "the \"check leak\" testing mode"; } if ($Benchmark) { $dry_run = "the \"benchmark\" testing mode"; } if ($Benchmark && !defined $block->no_check_leak) { warn "$name\n"; my $req = $r_req_list->[0]; my ($nreqs, $concur); if ($Benchmark =~ /^\s*(\d+)(?:\s+(\d+))?\s*$/) { ($nreqs, $concur) = ($1, $2); } if ($BenchmarkWarmup) { my $cmd = gen_ab_cmd_from_req($block, $req, $BenchmarkWarmup, $concur); warn "Warming up with $BenchmarkWarmup requests...\n"; system @$cmd; } my $cmd = gen_ab_cmd_from_req($block, $req, $nreqs, $concur); $cmd = quote_sh_args($cmd); warn "$cmd\n"; system "unbuffer $cmd > /dev/stderr"; } if ($CheckLeak && !defined $block->no_check_leak) { warn "$name\n"; my $req = $r_req_list->[0]; my $cmd = gen_ab_cmd_from_req($block, $req); # start a sub-process to run ab or weighttp my $pid = fork(); if (!defined $pid) { bail_out("$name - fork() failed: $!"); } elsif ($pid == 0) { # child process exec @$cmd; } else { # main process $Test::Nginx::Util::ChildPid = $pid; sleep(1); my $ngx_pid = get_pid_from_pidfile($name); if ($PrevNginxPid && $ngx_pid) { my $i = 0; while ($ngx_pid == $PrevNginxPid) { sleep 0.01; $ngx_pid = get_pid_from_pidfile($name); if (++$i > 1000) { bail_out("nginx cannot be started"); } } } $PrevNginxPid = $ngx_pid; my @rss_list; for (my $i = 0; $i < $CheckLeakCount; $i++) { sleep 0.02; my $out = `ps -eo pid,rss|grep $ngx_pid`; if ($? != 0 && !is_running($ngx_pid)) { if (is_running($pid)) { kill(SIGKILL, $pid); waitpid($pid, 0); } my $tb = Test::More->builder; $tb->no_ending(1); Test::More::fail("$name - the nginx process $ngx_pid is gone"); last; } my @lines = grep { $_->[0] eq $ngx_pid } map { s/^\s+|\s+$//g; [ split /\s+/, $_ ] } split /\n/, $out; if (@lines == 0) { last; } if (@lines > 1) { warn "Bad ps output: \"$out\"\n"; next; } my $ln = shift @lines; push @rss_list, $ln->[1]; } #if ($Test::Nginx::Util::Verbose) { warn "LeakTest: [@rss_list]\n"; #} if (@rss_list == 0) { warn "LeakTest: k=N/A\n"; } else { my $k = get_linear_regression_slope(\@rss_list); warn "LeakTest: k=$k\n"; #$k = get_linear_regression_slope([1 .. 100]); #warn "K = $k (1 expected)\n"; #$k = get_linear_regression_slope([map { $_ * 2 } 1 .. 100]); #warn "K = $k (2 expected)\n"; } if (is_running($pid)) { kill(SIGKILL, $pid); waitpid($pid, 0); } } } #warn "request: $req\n"; my $timeout = parse_time($block->timeout); if ( !defined $timeout ) { $timeout = timeout(); } my $res; my $req_idx = 0; my ($n, $need_array); for my $one_req (@$r_req_list) { my ($raw_resp, $head_req); if ($dry_run) { $raw_resp = "200 OK HTTP/1.0\r\nContent-Length: 0\r\n\r\n"; } else { ($raw_resp, $head_req) = send_request( $one_req, $block->raw_request_middle_delay, $timeout, $block ); } #warn "raw resonse: [$raw_resp]\n"; if ($block->pipelined_requests) { $n = @{ $block->pipelined_requests }; $need_array = 1; } else { $need_array = $#$r_req_list > 0; } again: if ($Test::Nginx::Util::Verbose) { warn "!!! resp: [$raw_resp]"; } if (!defined $raw_resp) { $raw_resp = ''; } my ( $raw_headers, $left ); if (!defined $block->ignore_response) { if ($Test::Nginx::Util::Verbose) { warn "parse response\n"; } if (defined $block->http09) { $res = HTTP::Response->new(200, "OK", [], $raw_resp); $raw_headers = ''; } else { ( $res, $raw_headers, $left ) = parse_response( $name, $raw_resp, $head_req ); } } if (!$n) { if ($left) { my $name = $block->name; $left =~ s/([\0-\037\200-\377])/sprintf('\x{%02x}',ord $1)/eg; warn "WARNING: $name - unexpected extra bytes after last chunk in ", "response: \"$left\"\n"; } } else { $raw_resp = $left; $n--; } if (!defined $block->ignore_response) { check_error_code($block, $res, $dry_run, $req_idx, $need_array); check_raw_response_headers($block, $raw_headers, $dry_run, $req_idx, $need_array); check_response_headers($block, $res, $raw_headers, $dry_run, $req_idx, $need_array); transform_response_body($block, $res, $req_idx); check_response_body($block, $res, $dry_run, $req_idx, $repeated_req_idx, $need_array); } if ($n || $req_idx < @$r_req_list - 1) { if ($block->wait) { sleep($block->wait); } check_error_log($block, $res, $dry_run, $repeated_req_idx, $need_array); if (!defined $block->ignore_response) { check_access_log($block, $dry_run, $repeated_req_idx); } } $req_idx++; if ($n) { goto again; } } if ($block->wait) { sleep($block->wait); } if ($Test::Nginx::Util::Verbose) { warn "Testing stap...\n"; } test_stap($block, $dry_run); check_error_log($block, $res, $dry_run, $repeated_req_idx, $need_array); if (!defined $block->ignore_response) { check_access_log($block, $dry_run, $repeated_req_idx); } } sub test_stap ($$) { my ($block, $dry_run) = @_; return if !$block->{stap}; my $name = $block->name; my $reason; if ($dry_run) { $reason = "the lack of directive $dry_run"; } if (!$UseStap) { $dry_run = 1; $reason ||= "env TEST_NGINX_USE_STAP is not set"; } my $fname = stap_out_fname(); if ($fname && ($fname eq '/dev/stdout' || $fname eq '/dev/stderr')) { $dry_run = 1; $reason ||= "TEST_NGINX_TAP_OUT is set to $fname"; } my $stap_out = $block->stap_out; my $stap_out_like = $block->stap_out_like; my $stap_out_unlike = $block->stap_out_unlike; SKIP: { skip "$name - stap_out - tests skipped due to $reason", 1 if $dry_run; my $fh = stap_out_fh(); if (!$fh) { bail_out("no stap output file handle found"); } my $out = ''; for (1..2) { if (sleep_time() < 0.2) { sleep 0.2; } else { sleep sleep_time(); } while (<$fh>) { $out .= $_; } if ($out) { last; } } if ($Test::Nginx::Util::Verbose) { warn "stap out: $out\n"; } if (defined $stap_out) { if ($NoLongString) { is($out, $block->stap_out, "$name - stap output expected"); } else { is_string($out, $block->stap_out, "$name - stap output expected"); } } if (defined $stap_out_like) { like($out || '', qr/$stap_out_like/sm, "$name - stap output should match the pattern"); } if (defined $stap_out_unlike) { unlike($out || '', qr/$stap_out_unlike/sm, "$name - stap output should not match the pattern"); } } } # Helper function to retrieve a "check" (e.g. error_code) section. This also # checks that tests with arrays of requests are arrays themselves. sub get_indexed_value($$$$) { my ($name, $value, $req_idx, $need_array) = @_; if ($need_array) { if (ref $value && ref $value eq 'ARRAY') { return $$value[$req_idx]; } bail_out("$name - You asked for many requests, the expected results should be arrays as well."); } else { # One element but still provided as an array. if (ref $value && ref $value eq 'ARRAY') { if ($req_idx != 0) { bail_out("$name - SHOULD NOT HAPPEN: idx != 0 and don't need array."); } return $$value[0]; } return $value; } } sub check_error_code ($$$$$) { my ($block, $res, $dry_run, $req_idx, $need_array) = @_; my $name = $block->name; SKIP: { skip "$name - tests skipped due to $dry_run", 1 if $dry_run; if ( defined $block->error_code_like ) { my $val = get_indexed_value($name, $block->error_code_like, $req_idx, $need_array); like( ($res && $res->code) || '', qr/$val/sm, "$name - status code ok" ); } elsif ( defined $block->error_code ) { is( ($res && $res->code) || '', get_indexed_value($name, $block->error_code, $req_idx, $need_array), "$name - status code ok" ); } else { is( ($res && $res->code) || '', 200, "$name - status code ok" ); } } } sub check_raw_response_headers($$$$$) { my ($block, $raw_headers, $dry_run, $req_idx, $need_array) = @_; my $name = $block->name; if (defined $block->raw_response_headers_like) { SKIP: { skip "$name - raw_response_headers_like - tests skipped due to $dry_run", 1 if $dry_run; my $expected = get_indexed_value($name, $block->raw_response_headers_like, $req_idx, $need_array); like $raw_headers, qr/$expected/s, "$name - raw resp headers like"; } } if (defined $block->raw_response_headers_unlike) { SKIP: { skip "$name - raw_response_headers_unlike - tests skipped due to $dry_run", 1 if $dry_run; my $expected = get_indexed_value($name, $block->raw_response_headers_unlike, $req_idx, $need_array); unlike $raw_headers, qr/$expected/s, "$name - raw resp headers unlike"; } } } sub check_response_headers($$$$$) { my ($block, $res, $raw_headers, $dry_run, $req_idx, $need_array) = @_; my $name = $block->name; if ( defined $block->response_headers ) { my $headers = parse_headers( get_indexed_value($name, $block->response_headers, $req_idx, $need_array)); while ( my ( $key, $val ) = each %$headers ) { if ( !defined $val ) { #warn "HIT"; SKIP: { skip "$name - response_headers - tests skipped due to $dry_run", 1 if $dry_run; unlike $raw_headers, qr/^\s*\Q$key\E\s*:/ms, "$name - header $key not present in the raw headers"; } next; } $val =~ s/\$ServerPort\b/$ServerPort/g; $val =~ s/\$ServerPortForClient\b/$ServerPortForClient/g; my $actual_val = $res ? $res->header($key) : undef; if ( !defined $actual_val ) { $actual_val = ''; } SKIP: { skip "$name - response_headers - tests skipped due to $dry_run", 1 if $dry_run; is $actual_val, $val, "$name - header $key ok"; } } } elsif ( defined $block->response_headers_like ) { my $headers = parse_headers( get_indexed_value($name, $block->response_headers_like, $req_idx, $need_array) ); while ( my ( $key, $val ) = each %$headers ) { my $expected_val = $res->header($key); if ( !defined $expected_val ) { $expected_val = ''; } SKIP: { skip "$name - response_headers_like - tests skipped due to $dry_run", 1 if $dry_run; like $expected_val, qr/^$val$/, "$name - header $key like ok"; } } } } sub value_contains ($$) { my ($val, $pat) = @_; if (!ref $val || ref $val eq 'Regexp') { return $val =~ /\Q$pat\E/; } if (ref $val eq 'ARRAY') { for my $v (@$val) { if (value_contains($v, $pat)) { return 1; } } } return undef; } sub check_access_log ($$$) { my ($block, $dry_run, $repeated_req_idx) = @_; my $name = $block->name; my $lines; if (defined $block->access_log) { my $pats = $block->access_log; if (!ref $pats) { chomp $pats; my @lines = split /\n+/, $pats; $pats = \@lines; } elsif (ref $pats eq 'Regexp') { $pats = [$pats]; } else { my @clone = @$pats; $pats = \@clone; } $lines ||= access_log_data(); for my $line (@$lines) { for my $pat (@$pats) { next if !defined $pat; if (ref $pat && $line =~ /$pat/ || $line =~ /\Q$pat\E/) { SKIP: { skip "$name - access_log - tests skipped due to $dry_run", 1 if $dry_run; pass("$name - pattern \"$pat\" matches a line in access.log (req $repeated_req_idx)"); } undef $pat; } } } for my $pat (@$pats) { if (defined $pat) { SKIP: { skip "$name - access_log - tests skipped due to $dry_run", 1 if $dry_run; fail("$name - pattern \"$pat\" should match a line in access.log (req $repeated_req_idx)"); #die join("", @$lines); } } } } if (defined $block->no_access_log) { #warn "HERE"; my $pats = $block->no_access_log; if (!ref $pats) { chomp $pats; my @lines = split /\n+/, $pats; $pats = \@lines; } elsif (ref $pats eq 'Regexp') { $pats = [$pats]; } else { my @clone = @$pats; $pats = \@clone; } my %found; $lines ||= access_log_data(); my $i = 0; for my $line (@$lines) { for my $pat (@$pats) { next if !defined $pat; #warn "test $pat\n"; if ((ref $pat && $line =~ /$pat/) || $line =~ /\Q$pat\E/) { if ($found{$pat}) { my $tb = Test::More->builder; $tb->no_ending(1); } else { $found{$pat} = 1; } SKIP: { skip "$name - no_access_log - tests skipped due to $dry_run ($line)", 1 if $dry_run; my $ln = fmt_str($line); my $p = fmt_str($pat); my @more_lines; for (my $j = $i + 1; $j < min($i + 10, @$lines - 1); $j++) { push @more_lines, $lines->[$j]; } fail("$name - pattern \"$p\" should not match any line in access.log but matches line \"$ln\" (req $repeated_req_idx)\n" . join "", @more_lines); } } } } continue { $i++; } for my $pat (@$pats) { next if $found{$pat}; if (defined $pat) { SKIP: { skip "$name - no_access_log - tests skipped due to $dry_run", 1 if $dry_run; my $p = fmt_str($pat); pass("$name - pattern \"$p\" does not match a line in access.log (req $repeated_req_idx)"); } } } } } sub check_error_log ($$$$) { my ($block, $res, $dry_run, $repeated_req_idx, $need_array) = @_; my $name = $block->name; my $lines; my $check_write_guard_message = 1; my $check_alert_message = 1; my $check_crit_message = 1; my $check_emerg_message = 1; my $grep_pat; my $grep_pats = $block->grep_error_log; if (defined $grep_pats) { if (ref $grep_pats && ref $grep_pats eq 'ARRAY') { $grep_pat = $grep_pats->[$repeated_req_idx]; } else { $grep_pat = $grep_pats; } } else { my $grep_error_log_out = $block->grep_error_log_out; if (defined $grep_error_log_out) { bail_out("$name - No --- grep_error_log defined but --- grep_error_log_out is defined"); } } if (defined $grep_pat) { my $expected = $block->grep_error_log_out; if (!defined $expected) { bail_out("$name - No --- grep_error_log_out defined but --- grep_error_log is defined"); } $expected = expand_env_in_text $expected, $name, $Test::Nginx::Util::RandPorts; #warn "ref grep error log: ", ref $expected; if (ref $expected && ref $expected eq 'ARRAY') { #warn "grep error log out is an ARRAY"; $expected = $expected->[$repeated_req_idx]; } SKIP: { skip "$name - error_log - tests skipped due to $dry_run", 1 if $dry_run; $lines ||= error_log_data(); my $matched_lines = ''; for my $line (@$lines) { if (ref $grep_pat && $line =~ /$grep_pat/ || $line =~ /\Q$grep_pat\E/) { my $matched = $&; if ($matched !~ /\n/) { $matched_lines .= $matched . "\n"; } } } if (ref $expected eq 'Regexp') { like($matched_lines, $expected, "$name - grep_error_log_out (req $repeated_req_idx)"); } else { if ($NoLongString) { is($matched_lines, $expected, "$name - grep_error_log_out (req $repeated_req_idx)" ); } else { is_string($matched_lines, $expected, "$name - grep_error_log_out (req $repeated_req_idx)"); } } } } if (defined $block->error_log) { my $pats = $block->error_log; if (value_contains($pats, "writing a global lua variable")) { undef $check_write_guard_message; } if (value_contains($pats, "[alert")) { undef $check_alert_message; } if (value_contains($pats, "[crit")) { undef $check_crit_message; } if (value_contains($pats, "[emerg")) { undef $check_emerg_message; } if (!ref $pats) { chomp $pats; my @lines = split /\n+/, $pats; $pats = \@lines; } elsif (ref $pats eq 'Regexp') { $pats = [$pats]; } else { my @clone = @$pats; $pats = \@clone; } $lines ||= error_log_data(); #warn "error log data: ", join "\n", @$lines; for my $line (@$lines) { for my $pat (@$pats) { next if !defined $pat; if (ref $pat && $line =~ /$pat/ || $line =~ /\Q$pat\E/) { SKIP: { skip "$name - error_log - tests skipped due to $dry_run", 1 if $dry_run; pass("$name - pattern \"$pat\" matches a line in error.log (req $repeated_req_idx)"); } undef $pat; } } } for my $pat (@$pats) { if (defined $pat) { SKIP: { skip "$name - error_log - tests skipped due to $dry_run", 1 if $dry_run; fail("$name - pattern \"$pat\" should match a line in error.log (req $repeated_req_idx)"); #die join("", @$lines); } } } } if (defined $block->no_error_log) { #warn "HERE"; my $pats = $block->no_error_log; if (value_contains($pats, "writing a global lua variable")) { undef $check_write_guard_message; } if (value_contains($pats, "[alert")) { undef $check_alert_message; } if (value_contains($pats, "[crit")) { undef $check_crit_message; } if (value_contains($pats, "[emerg")) { undef $check_emerg_message; } if (!ref $pats) { chomp $pats; my @lines = split /\n+/, $pats; $pats = \@lines; } elsif (ref $pats eq 'Regexp') { $pats = [$pats]; } else { my @clone = @$pats; $pats = \@clone; } my %found; $lines ||= error_log_data(); my $i = 0; for my $line (@$lines) { for my $pat (@$pats) { next if !defined $pat; #warn "test $pat\n"; if ((ref $pat && $line =~ /$pat/) || $line =~ /\Q$pat\E/) { if ($found{$pat}) { my $tb = Test::More->builder; $tb->no_ending(1); } else { $found{$pat} = 1; } SKIP: { skip "$name - no_error_log - tests skipped due to $dry_run ($line)", 1 if $dry_run; my $ln = fmt_str($line); my $p = fmt_str($pat); my @more_lines; for (my $j = $i + 1; $j < min($i + 10, @$lines - 1); $j++) { push @more_lines, $lines->[$j]; } fail("$name - pattern \"$p\" should not match any line in error.log but matches line \"$ln\" (req $repeated_req_idx)\n" . join "", @more_lines); } } } } continue { $i++; } for my $pat (@$pats) { next if $found{$pat}; if (defined $pat) { SKIP: { skip "$name - no_error_log - tests skipped due to $dry_run", 1 if $dry_run; my $p = fmt_str($pat); pass("$name - pattern \"$p\" does not match a line in error.log (req $repeated_req_idx)"); } } } } if ($check_write_guard_message && !$dry_run) { $lines ||= error_log_data(); for my $line (@$lines) { #warn "test $pat\n"; if ($line =~ /writing a global lua variable/) { my $ln = fmt_str($line); warn("WARNING: $name - $ln\n"); } } } if ($check_alert_message && !$dry_run) { $lines ||= error_log_data(); for my $line (@$lines) { #warn "test $pat\n"; if ($line =~ /\[alert\]/) { my $ln = fmt_str($line); warn("WARNING: $name - $ln\n"); } } } if ($check_crit_message && !$dry_run) { $lines ||= error_log_data(); for my $line (@$lines) { #warn "test $pat\n"; if ($line =~ /\[crit\]/) { my $ln = fmt_str($line); warn("WARNING: $name - $ln\n"); } } } if ($check_emerg_message && !$dry_run) { $lines ||= error_log_data(); for my $line (@$lines) { #warn "test $pat\n"; if ($line =~ /\[emerg\]/) { my $ln = fmt_str($line); warn("WARNING: $name - $ln"); } } } for my $line (@$lines) { #warn "test $pat\n"; if ($line =~ /\bAssertion .*?failed\b/) { my $tb = Test::More->builder; $tb->no_ending(1); chomp $line; fail("$name - $line\n"); } } } sub check_shutdown_error_log ($$) { my ($block, $dry_run) = @_; my $name = $block->name; my $lines; my $pats = $block->shutdown_error_log; if (defined $pats) { if (!ref $pats) { chomp $pats; my @lines = split /\n+/, $pats; $pats = \@lines; } elsif (ref $pats eq 'Regexp') { $pats = [$pats]; } else { my @clone = @$pats; $pats = \@clone; } $lines ||= error_log_data(); #warn "error log data: ", join "\n", @$lines; for my $line (@$lines) { for my $pat (@$pats) { next if !defined $pat; if (ref $pat && $line =~ /$pat/ || $line =~ /\Q$pat\E/) { SKIP: { skip "$name - shutdown_error_log - tests skipped due to dry_run", 1 if $dry_run; pass("$name - pattern \"$pat\" matches a line in error.log"); } undef $pat; } } } for my $pat (@$pats) { if (defined $pat) { SKIP: { skip "$name - shutdown_error_log - tests skipped due to dry_run", 1 if $dry_run; fail("$name - pattern \"$pat\" should match a line in error.log"); #die join("", @$lines); } } } for my $line (@$lines) { #warn "test $line\n"; if ($line =~ /\bAssertion .*? failed\.$/) { my $tb = Test::More->builder; $tb->no_ending(1); chomp $line; fail("$name - $line"); } } } if (defined $block->no_shutdown_error_log) { # warn "HERE"; my $pats = $block->no_shutdown_error_log; if (!ref $pats) { chomp $pats; my @lines = split /\n+/, $pats; $pats = \@lines; } elsif (ref $pats eq 'Regexp') { $pats = [$pats]; } else { my @clone = @$pats; $pats = \@clone; } my %found; $lines ||= error_log_data(); # warn "error log data: ", join "\n", @$lines; for my $line (@$lines) { for my $pat (@$pats) { next if !defined $pat; #warn "test $pat\n"; if ((ref $pat && $line =~ /$pat/) || $line =~ /\Q$pat\E/) { if ($found{$pat}) { my $tb = Test::More->builder; $tb->no_ending(1); } else { $found{$pat} = 1; } SKIP: { skip "$name - no_shutdown_error_log - tests skipped due to $dry_run ($line)", 1 if $dry_run; my $ln = fmt_str($line); my $p = fmt_str($pat); fail("$name - pattern \"$p\" should not match any line in error.log but matches line \"$ln\""); } } } } for my $pat (@$pats) { next if $found{$pat}; if (defined $pat) { SKIP: { skip "$name - no_shutdown_error_log - tests skipped due to $dry_run", 1 if $dry_run; my $p = fmt_str($pat); pass("$name - pattern \"$p\" does not match a line in error.log"); } } } } } sub fmt_str ($) { my $str = shift; chomp $str; $str =~ s/"/\\"/g; $str =~ s/\r/\\r/g; $str =~ s/\n/\\n/g; $str; } sub transform_response_body ($$$) { my ($block, $res, $req_idx) = @_; return unless defined $res; my $content = $res->content; return unless defined $content; my $is_2d_array = 0; my $name = $block->name; my $response_body_filters = $block->response_body_filters; if (defined $response_body_filters) { if (!ref $response_body_filters) { $response_body_filters =~ s/^\s+|\s+$//gs; $response_body_filters = [split /\s+/, $response_body_filters]; } elsif (ref $response_body_filters ne 'ARRAY') { $response_body_filters = [$response_body_filters]; } if (ref $response_body_filters eq 'ARRAY') { if (ref $response_body_filters->[0] eq 'ARRAY') { $is_2d_array = 1; for my $elem (@$response_body_filters) { if (ref $elem ne "ARRAY") { bail_out("$name - the --- response_body_filters two-dimensional array " . "only be like [[uc], [lc]] not [[uc], lc]"); } } } } my $new = $content; my $filter = $response_body_filters; if ($is_2d_array) { $filter = $response_body_filters->[$req_idx]; bail_out("$name - the ---response_body_filters two-dimensional array " . "unmatch the specified request($req_idx)") unless defined $filter; } if (ref $filter && ref $filter eq 'ARRAY') { for my $f (@$filter) { $new = run_filter_helper($block, $f, $new); } } else { $new = run_filter_helper($block, $filter, $new); } $res->content($new); } } sub check_response_body ($$$$$$) { my ($block, $res, $dry_run, $req_idx, $repeated_req_idx, $need_array) = @_; my $name = $block->name; my $write_resp_body_file = $block->write_resp_body_file; if (defined $write_resp_body_file && defined $res) { my $got_body = $res->content // ''; open my $out, ">$write_resp_body_file" or bail_out "$name - failed to write to file '$write_resp_body_file': $!"; print $out $got_body; close $out; } if ( defined $block->response_body || defined $block->response_body_eval ) { my $content = $res ? $res->content : undef; if ( defined $content ) { $content =~ s/^TE: deflate,gzip;q=0\.3\r\n//gms; $content =~ s/^Connection: TE, close\r\n//gms; } if ( defined $block->response_body_json_sort ) { my $js = JSON::PP->new; $js->canonical(1); my $obj; my $rc = eval { $obj = $js->loose(1)->decode($content); 1; }; if ($rc) { $content = $js->encode($obj) . "\n"; } } my $expected; if ( $block->response_body_eval ) { diag "$name - response_body_eval is DEPRECATED. Use response_body eval instead."; $expected = eval get_indexed_value($name, $block->response_body_eval, $req_idx, $need_array); if ($@) { warn $@; } } else { $expected = get_indexed_value($name, $block->response_body, $req_idx, $need_array); } if ( $block->charset ) { Encode::from_to( $expected, 'UTF-8', $block->charset ); } unless (!defined $expected || ref $expected) { $expected =~ s/\$ServerPort\b/$ServerPort/g; $expected =~ s/\$ServerPortForClient\b/$ServerPortForClient/g; $expected = expand_env_in_text $expected, $name, $Test::Nginx::Util::RandPorts; } #warn show_all_chars($content); #warn "no long string: $NoLongString"; SKIP: { skip "$name - response_body - tests skipped due to $dry_run", 1 if $dry_run; if (ref $expected) { like $content, $expected, "$name - response_body - like (repeated req $repeated_req_idx, req $req_idx)"; } else { if ($NoLongString) { is( $content, $expected, "$name - response_body - response is expected (repeated req $repeated_req_idx, req $req_idx)" ); } else { is_string( $content, $expected, "$name - response_body - response is expected (repeated req $repeated_req_idx, req $req_idx)" ); } } } } elsif (defined $block->response_body_like || defined $block->response_body_unlike) { my $patterns; my $type; my $cmp; if (defined $block->response_body_like) { $patterns = $block->response_body_like; $type = "like"; $cmp = \&like; } else { $patterns = $block->response_body_unlike; $type = "unlike"; $cmp = \&unlike; } my $content = $res ? $res->content : undef; if ( defined $content ) { $content =~ s/^TE: deflate,gzip;q=0\.3\r\n//gms; $content =~ s/^Connection: TE, close\r\n//gms; } my $expected_pat = get_indexed_value($name, $patterns, $req_idx, $need_array); $expected_pat =~ s/\$ServerPort\b/$ServerPort/g; $expected_pat =~ s/\$ServerPortForClient\b/$ServerPortForClient/g; my $summary = trim($content); if (!defined $summary) { $summary = ""; } SKIP: { skip "$name - response_body_$type - tests skipped due to $dry_run", 1 if $dry_run; $cmp->( $content, qr/$expected_pat/s, "$name - response_body_$type - response is expected ($summary)" ); } } for my $check (@ResponseBodyChecks) { $check->($block, $res->content, $req_idx, $repeated_req_idx, $dry_run); } } sub parse_response($$$) { my ( $name, $raw_resp, $head_req ) = @_; my $left; my $raw_headers = ''; if ( $raw_resp =~ /(.*?\r\n)\r\n/s ) { #warn "\$1: $1"; $raw_headers = $1; } #warn "raw headers: $raw_headers\n"; my $res = HTTP::Response->parse($raw_resp); my $code = $res->code; my $enc = $res->header('Transfer-Encoding'); my $len = $res->header('Content-Length'); my @trailers = $res->header('Trailer'); # warn "trailers: @trailers"; if ($code && $code !~ /^\d+$/) { undef $code; $res->code(undef); } if ($code && ($code == 304 || $code == 101)) { return $res, $raw_headers } if ( defined $enc && $enc eq 'chunked' ) { #warn "Found chunked!"; my $raw = $res->content; if ( !defined $raw ) { $raw = ''; } my $decoded = ''; while (1) { if (@trailers == 0 && $raw =~ /\G 0 [\ \t]* \r\n \r\n /gcsx ) { if ( $raw =~ /\G (.+) /gcsx ) { $left = $1; } last; } elsif (@trailers > 0 && $raw =~ /\G 0 [\ \t]* \r\n /gcsx) { # skip HTTP Trailer for my $trailer (@trailers) { if ( $raw !~ /\G($trailer:\ [^\n]*\r\n)/gcs ) { my $tb = Test::More->builder; $tb->no_ending(1); fail( "$name - invalid trailer data received (expected $trailer)." ); return; } } if ($raw !~ /\G\r\n/gcs ) { my $tb = Test::More->builder; $tb->no_ending(1); fail( "$name - invalid chunked data received (expected CRLF)." ); return; } if ( $raw =~ /\G (.+) /gcsx ) { $left = $1; } last; } if ( $raw =~ m{ \G [\ \t]* ( [A-Fa-f0-9]+ ) [\ \t]* \r\n }gcsx ) { my $rest = hex($1); #warn "chunk size: $rest\n"; my $bit_sz = 32765; while ( $rest > 0 ) { my $bit = $rest < $bit_sz ? $rest : $bit_sz; #warn "bit: $bit\n"; if ( $raw =~ /\G(.{$bit})/gcs ) { $decoded .= $1; #warn "decoded: [$1]\n"; } else { my $tb = Test::More->builder; $tb->no_ending(1); fail("$name - invalid chunked data received " ."(not enought octets for the data section)" ); return; } $rest -= $bit; } if ( $raw !~ /\G\r\n/gcs ) { my $tb = Test::More->builder; $tb->no_ending(1); fail( "$name - invalid chunked data received (expected CRLF)." ); return; } } elsif ( $raw =~ /\G.+/gcs ) { my $tb = Test::More->builder; $tb->no_ending(1); fail "$name - invalid chunked body received: $&"; return; } else { my $tb = Test::More->builder; $tb->no_ending(1); fail "$name - no last chunk found - $raw"; return; } } #warn "decoded: $decoded\n"; $res->content($decoded); } elsif (defined $len && $len ne '' && $len >= 0) { my $raw = $res->content; if (length $raw < $len) { if (!$head_req) { warn "WARNING: $name - response body truncated: ", "$len expected, but got ", length $raw, "\n"; } } elsif (length $raw > $len) { my $content = substr $raw, 0, $len; $left = substr $raw, $len; $res->content($content); #warn "parsed body: [", $res->content, "]\n"; } } return ( $res, $raw_headers, $left ); } sub send_http_req_by_curl ($$$) { my ($block, $req, $timeout) = @_; my $name = $block->name; my $cmd = gen_curl_cmd_from_req($block, $req); if ($Test::Nginx::Util::Verbose) { warn "running cmd @$cmd"; } if (use_http2($block)) { my $total_tries = $TotalConnectingTimeouts ? 20 : 50; while ($total_tries-- > 0) { if (is_tcp_port_used($ServerPortForClient)) { last; } warn "$name - waiting for nginx to listen on port " . "$ServerPortForClient, Retry connecting after 1 sec\n"; sleep 1; } } if (use_http3($block)) { my $total_tries = $TotalConnectingTimeouts ? 20 : 50; while ($total_tries-- > 0) { if (is_udp_port_used($ServerPortForClient)) { last; } warn "$name - waiting for nginx to listen on port " . "$ServerPortForClient, Retry connecting after 1 sec\n"; sleep 1; } } my $ok = IPC::Run::run($cmd, \(my $in), \(my $out), \(my $err), IPC::Run::timeout($timeout)); #my @cmd_copy = @$cmd; #warn "running cmd ", quote_sh_args(\@cmd_copy); if (!defined $ok) { fail "failed to run curl: $?: " . ($err // ''); return; } if (!$out) { if ($err) { my $curl_err = $block->curl_error; if (defined $curl_err) { if (ref $curl_err && $err =~ /$curl_err/) { return; } elsif ($err =~ /\Q$curl_err\E/) { return; } fail "$name - command \"@$cmd\" generates stderr output: $err"; return; } fail "$name - command \"@$cmd\" generates stderr output: $err"; return; } fail "$name - curl command \"@$cmd\" generates no stdout output"; return; } if ($err) { warn "WARNING: $name - command \"@$cmd\" generates stderr output: $err"; } return $out; } sub send_request ($$$$@) { my ( $req, $middle_delay, $timeout, $block, $tries ) = @_; my $name = $block->name; my @req_bits = ref $req ? @$req : ($req); my $head_req = 0; { my $req = join '', map { $_->{value} } @req_bits; #warn "Request: $req\n"; if ($req =~ /^\s*HEAD\s+/) { #warn "Found HEAD request!\n"; $head_req = 1; } } if (use_http2($block) || use_http3($block)) { return send_http_req_by_curl($block, $req, $timeout), $head_req; } my $server_addr = $block->server_addr_for_client; if (!defined $server_addr) { $server_addr = $ServerAddr; } my $sock = IO::Socket::INET->new( PeerAddr => $server_addr, PeerPort => $ServerPortForClient, Proto => 'tcp', #ReuseAddr => 1, #ReusePort => 1, Blocking => 0, Timeout => $timeout, ); #warn "connecting...\n"; if (!defined $sock) { $tries ||= 1; my $total_tries = $TotalConnectingTimeouts ? 20 : 50; if ($tries <= $total_tries) { my $wait = (sleep_time() + sleep_time() * $tries) * $tries / 2; if ($wait >= 1) { $wait = 1; } if (defined $Test::Nginx::Util::ChildPid) { my $errcode = $!; if (waitpid($Test::Nginx::Util::ChildPid, WNOHANG) == -1) { warn "WARNING: Child process $Test::Nginx::Util::ChildPid is already gone.\n"; warn `tail -n20 $Test::Nginx::Util::ErrLogFile`; my $tb = Test::More->builder; $tb->no_ending(1); fail("$name - Can't connect to $server_addr:$ServerPortForClient: $errcode (aborted)\n"); return; } } if ($wait >= 0.6) { warn "$name - Can't connect to $server_addr:$ServerPortForClient: $!\n"; if ($tries + 1 <= $total_tries) { warn "\tRetry connecting after $wait sec\n"; } } sleep $wait; #warn "sending request"; return send_request($req, $middle_delay, $timeout, $block, $tries + 1); } my $msg = "$name - Can't connect to $server_addr:$ServerPortForClient: $! (aborted)\n"; if (++$TotalConnectingTimeouts < 3) { my $tb = Test::More->builder; $tb->no_ending(1); fail($msg); } else { bail_out($msg); } return; } #warn "connected"; #my $flags = fcntl $sock, F_GETFL, 0 #or die "Failed to get flags: $!\n"; #fcntl $sock, F_SETFL, $flags | O_NONBLOCK #or die "Failed to set flags: $!\n"; my $ctx = { resp => '', write_offset => 0, buf_size => 1024, req_bits => \@req_bits, write_buf => (shift @req_bits)->{"value"}, middle_delay => $middle_delay, sock => $sock, name => $name, block => $block, }; my $readable_hdls = IO::Select->new($sock); my $writable_hdls = IO::Select->new($sock); my $err_hdls = IO::Select->new($sock); while (1) { if ( $readable_hdls->count == 0 && $writable_hdls->count == 0 && $err_hdls->count == 0 ) { last; } #warn "doing select...\n"; my ($new_readable, $new_writable, $new_err) = IO::Select->select($readable_hdls, $writable_hdls, $err_hdls, $timeout); if (!defined $new_err && !defined $new_readable && !defined $new_writable) { # timed out timeout_event_handler($ctx); last; } for my $hdl (@$new_err) { next if !defined $hdl; error_event_handler($ctx); if ( $err_hdls->exists($hdl) ) { $err_hdls->remove($hdl); } if ( $readable_hdls->exists($hdl) ) { $readable_hdls->remove($hdl); } if ( $writable_hdls->exists($hdl) ) { $writable_hdls->remove($hdl); } for my $h (@$readable_hdls) { next if !defined $h; if ( $h eq $hdl ) { undef $h; last; } } for my $h (@$writable_hdls) { next if !defined $h; if ( $h eq $hdl ) { undef $h; last; } } close $hdl; } for my $hdl (@$new_readable) { next if !defined $hdl; my $res = read_event_handler($ctx); if ( !$res ) { # error occured if ( $err_hdls->exists($hdl) ) { $err_hdls->remove($hdl); } if ( $readable_hdls->exists($hdl) ) { $readable_hdls->remove($hdl); } if ( $writable_hdls->exists($hdl) ) { $writable_hdls->remove($hdl); } for my $h (@$writable_hdls) { next if !defined $h; if ( $h eq $hdl ) { undef $h; last; } } close $hdl; } } for my $hdl (@$new_writable) { next if !defined $hdl; my $res = write_event_handler($ctx); if ( !$res ) { # error occured if ( $err_hdls->exists($hdl) ) { $err_hdls->remove($hdl); } if ( $readable_hdls->exists($hdl) ) { $readable_hdls->remove($hdl); } if ( $writable_hdls->exists($hdl) ) { $writable_hdls->remove($hdl); } close $hdl; } elsif ( $res == 2 ) { # all data has been written my $shutdown = $block->shutdown; if (defined $shutdown) { if ($shutdown =~ /^$/s) { $shutdown = 1; } #warn "shutting down with $shutdown"; shutdown($sock, $shutdown); } if ( $writable_hdls->exists($hdl) ) { $writable_hdls->remove($hdl); } } } } return ($ctx->{resp}, $head_req); } sub timeout_event_handler ($) { my $ctx = shift; close($ctx->{sock}); if (!defined $ctx->{block}->abort) { my $tb = Test::More->builder; $tb->no_ending(1); fail("ERROR: client socket timed out - $ctx->{name}\n"); } else { sleep 0.005; } } sub error_event_handler ($) { warn "exception occurs on the socket: $!\n"; } sub write_event_handler ($) { my ($ctx) = @_; while (1) { return undef if !defined $ctx->{write_buf}; my $rest = length( $ctx->{write_buf} ) - $ctx->{write_offset}; #warn "offset: $write_offset, rest: $rest, length ", length($write_buf), "\n"; #die; if ( $rest > 0 ) { my $bytes; eval { $bytes = syswrite( $ctx->{sock}, $ctx->{write_buf}, $rest, $ctx->{write_offset} ); }; if ($@) { my $errmsg = "write failed: $@"; warn "$errmsg\n"; $ctx->{resp} = $errmsg; return undef; } if ( !defined $bytes ) { if ( $! == EAGAIN ) { #warn "write again..."; #sleep 0.002; return 1; } my $errmsg = "write failed: $!"; warn "$errmsg\n"; if ( !$ctx->{resp} ) { $ctx->{resp} = "$errmsg"; } return undef; } #warn "wrote $bytes bytes.\n"; $ctx->{write_offset} += $bytes; } else { # $rest == 0 my $next_send = shift @{ $ctx->{req_bits} }; if (!defined $next_send) { return 2; } $ctx->{write_buf} = $next_send->{'value'}; $ctx->{write_offset} = 0; my $wait_time; if (!defined $next_send->{'delay_before'}) { if (defined $ctx->{middle_delay}) { $wait_time = $ctx->{middle_delay}; } } else { $wait_time = $next_send->{'delay_before'}; } if ($wait_time) { #warn "sleeping.."; sleep $wait_time; } } } # impossible to reach here... return undef; } sub read_event_handler ($) { my ($ctx) = @_; while (1) { my $read_buf; my $bytes = sysread( $ctx->{sock}, $read_buf, $ctx->{buf_size} ); if ( !defined $bytes ) { if ( $! == EAGAIN ) { #warn "read again..."; #sleep 0.002; return 1; } warn "WARNING: $ctx->{name} - HTTP response read failure: $!"; return undef; } if ( $bytes == 0 ) { return undef; # connection closed } $ctx->{resp} .= $read_buf; #warn "read $bytes ($read_buf) bytes.\n"; } # impossible to reach here... return undef; } sub gen_curl_cmd_from_req ($$) { my ($block, $req) = @_; my $name = $block->name; $req = join '', map { $_->{value} } @$req; #use JSON::XS; #warn "Req: ", JSON::XS->new->encode([$req]), "\n"; my ($meth, $uri, $http_ver); if ($req =~ m{^\s*(\w+)\s+(\S+)\s+HTTP/(\S+)\r?\n}smig) { ($meth, $uri, $http_ver) = ($1, $2, $3); } elsif ($req =~ m{^\s*(\w+)\s+(.*\S)\s*\r?\n}smig) { # NB: there can be trailing spaces in the HTTP 0.9, # but it will be ignored by the server ($meth, $uri) = ($1, $2); $http_ver = '0.9'; } else { bail_out "$name - cannot parse the status line in the request: $req"; } # remove 'user-agent' and 'accept' request headers from curl # because test-nginx does not send these header by default my @args = ('curl', '-i', '-H', 'User-Agent:', '-H', 'Accept:', '-H', 'Host:'); my $curl_protocol = $block->curl_protocol; if (!defined $curl_protocol) { $curl_protocol = "http"; } if ($Test::Nginx::Util::Verbose) { push @args, "-vv"; } else { push @args, '-sS'; } if (use_http3($block)) { push @args, '--http3-only'; push @args, '-k'; $curl_protocol = "https"; } elsif (use_http2($block)) { push @args, '--http2-prior-knowledge'; } if ($meth eq 'HEAD') { push @args, '-I'; } else { if ($meth ne 'GET') { push @args, "-X", $meth; } } if ($http_ver ne '1.1') { # HTTP 1.0 or HTTP 0.9 push @args, '-0'; } my @headers; if ($http_ver ge '1.0') { if ($req =~ m{\G(.*?)\r?\n\r?\n}gcs) { my $headers = $1; #warn "raw headers: $headers\n"; @headers = grep { !/^Connection\s*:/i } split /\r\n/, $headers; } else { bail_out "cannot parse the header entries in the request: $req"; } } #warn "headers: @headers ", scalar(@headers), "\n"; my $found_content_type; for my $h (@headers) { #warn "h: $h\n"; if ($h =~ /^\s*Content-Type\s*:/i) { $found_content_type = 1; } push @args, '-H', $h; } if ($req =~ m{\G(.+)}gcsm) { #warn "!! POST body data len: ", length($1); if (!$found_content_type) { push @args, "-H", 'Content-Type: '; } my $body = $1; my $filename = html_dir() . "/curl.data.bin"; push @args, '--data-binary', '@' . $filename; open my $fh, ">", $filename or die "Could not open file. $!"; print $fh $body; close $fh; } my $timeout = $block->timeout; if (!$timeout) { $timeout = timeout(); } push @args, '--connect-timeout', $timeout; # http3 use udp, the connect-timeout does not take effect # so use the max-time instead. push @args, '--max-time', $timeout; my $link; my $server_addr = $block->server_addr_for_client; if (!defined $server_addr) { $server_addr = $ServerAddr; } { my $server = $server_addr; my $port = $ServerPortForClient; $link = "$curl_protocol://$server:$port$uri"; } my $curl_options = $block->curl_options; if (defined $curl_options) { push @args, $curl_options; } push @args, $link; return \@args; } sub gen_ab_cmd_from_req ($$@) { my ($block, $req, $nreqs, $concur) = @_; $nreqs ||= 100000000; $concur ||= 2; if ($nreqs < $concur) { $concur = $nreqs; } my $name = $block->name; $req = join '', map { $_->{value} } @$req; #use JSON::XS; #warn "Req: ", JSON::XS->new->encode([$req]), "\n"; my ($meth, $uri, $http_ver); if ($req =~ m{^\s*(\w+)\s+(\S+)\s+HTTP/(\S+)\r?\n}smig) { ($meth, $uri, $http_ver) = ($1, $2, $3); } elsif ($req =~ m{^\s*(\w+)\s+(.*\S)\s*\r?\n}smig) { # NB: there can be trailing spaces in the HTTP 0.9, # but it will be ignored by the server ($meth, $uri) = ($1, $2); $http_ver = '0.9'; } else { bail_out "$name - cannot parse the status line in the request: $req"; } #warn "HTTP version: $http_ver\n"; my @opts = ("-c$concur", '-k', "-n$nreqs"); my $prog; if ($http_ver eq '1.1' && $meth eq 'GET') { $prog = 'weighttp'; } else { # HTTP 1.0 or HTTP 0.9 $prog = 'ab'; unshift @opts, '-r', '-d', '-S'; } my @headers; if ($http_ver ge '1.0') { if ($req =~ m{\G(.*?)\r?\n\r?\n}gcs) { my $headers = $1; #warn "raw headers: $headers\n"; @headers = grep { !/^Connection\s*:/i && !/^Host: \Q$ServerName\E$/i && !/^Content-Length\s*:/i } split /\r\n/, $headers; } else { bail_out "cannot parse the header entries in the request: $req"; } } #warn "headers: @headers ", scalar(@headers), "\n"; for my $h (@headers) { #warn "h: $h\n"; if ($prog eq 'ab' && $h =~ /^\s*Content-Type\s*:\s*(.*\S)/i) { my $type = $1; push @opts, '-T', $type; } else { push @opts, '-H', $h; } } my $bodyfile; if ($req =~ m{\G.+}gcs || $meth eq 'POST' || $meth eq 'PUT') { my $body = $&; if (!defined $body) { $body = ''; } my ($out, $bodyfile) = tempfile("bodyXXXXXXX", UNLINK => 1, SUFFIX => '.temp', TMPDIR => 1); print $out $body; close $out; if ($meth eq 'PUT') { push @opts, '-u', $bodyfile; } elsif ($meth eq 'POST') { push @opts, '-p', $bodyfile; } elsif ($meth eq 'GET') { warn "WARNING: method $meth not supported for ab when taking a request body\n"; } else { warn "WARNING: method $meth not supported for ab when taking a request body\n"; $meth = 'PUT'; push @opts, '-p', $bodyfile; } } if ($meth eq 'HEAD') { unshift @opts, '-i'; } my $link; my $server_addr = $block->server_addr_for_client; if (!defined $server_addr) { $server_addr = $ServerAddr; } { my $server = $server_addr; my $port = $ServerPortForClient; $link = "http://$server:$port$uri"; } my @cmd = ($prog, @opts, $link); if ($Test::Nginx::Util::Verbose) { warn "command: @cmd\n"; } return \@cmd; } sub get_linear_regression_slope ($) { my $list = shift; my $n = @$list; my $avg_x = ($n + 1) / 2; my $avg_y = sum(@$list) / $n; my $x = 0; my $avg_xy = sum(map { $x++; $x * $_ } @$list) / $n; my $avg_x2 = sum(map { $_ * $_ } 1 .. $n) / $n; my $denom = $avg_x2 - $avg_x * $avg_x; if ($denom == 0) { return 'Inf'; } my $k = ($avg_xy - $avg_x * $avg_y) / $denom; return sprintf("%.01f", $k); } 1; __END__ =encoding utf-8 =head1 NAME Test::Nginx::Socket - Socket-backed test scaffold for the Nginx C modules and Nginx/OpenResty-based libraries and applications =head1 SYNOPSIS use Test::Nginx::Socket; repeat_each(2); plan tests => repeat_each() * 3 * blocks(); no_shuffle(); run_tests(); __DATA__ === TEST 1: sanity --- config location /echo { echo_before_body hello; echo world; } --- request GET /echo --- response_body hello world --- error_code: 200 === TEST 2: set Server --- config location /foo { echo hi; more_set_headers 'Server: Foo'; } --- request GET /foo --- response_headers Server: Foo --- response_body hi === TEST 3: clear Server --- config location /foo { echo hi; more_clear_headers 'Server: '; } --- request GET /foo --- response_headers_like Server: nginx.* --- response_body hi === TEST 3: chunk size too small --- config chunkin on; location /main { echo_request_body; } --- more_headers Transfer-Encoding: chunked --- request eval "POST /main 4\r hello\r 0\r \r " --- error_code: 400 --- response_body_like: 400 Bad Request =head1 DESCRIPTION This module provides a test scaffold based on non-blocking L for automated testing in Nginx C module development. This class inherits from L, thus bringing all its declarative power to the Nginx C module testing practices. You need to terminate or kill any Nginx processes before running the test suite if you have changed the Nginx server binary. Normally it's as simple as killall nginx PATH=/path/to/your/nginx-with-memc-module:$PATH prove -r t This module will create a temporary server root under t/servroot/ of the current working directory and starts and uses the nginx executable in the PATH environment. You will often want to look into F when things go wrong ;) =head2 User Guide You can find a comprehensive user guide on this test framework in my upcoming book "Programming OpenResty": L =head2 Features inherited from L All the features of L are inherited since it is an ancestor class of this module anyway. Still we would highlight some of the inherited features here for those unfamiliar with L. =head3 Meta sections =over =item C<--- ONLY> Runs the surrounding test block only. You need to remember removing C<--- ONLY> before committing your changes though. Don't worry, the test scaffold would warn you loudly on the console when you left a C<--- ONLY> in some test file. It is also very intuitive for the developer's workflow. One does not have to specify a (unique) test name on the command-line; just find the block in the editor, insert a C<--- ONLY> line right away, and run the current test file immediately (for Vim users, the final step is as simple as entering C<:!prove %> where C<:!> is the Vim way of running an external shell command and C<%> would get substituted with the current file being edited in Vim's buffer). This is definitely one of the most useful and frequently used features. =item C<--- SKIP> Skips the surrounding test block unconditionally. You can use C<--- skip_nginx> and C<--- skip_nginx2> providied by this module (see their documentation below) to conditionally skip tests according to the current NGINX server versions. You can also use C<--- skip_openssl> (see its documentation below) to conditionally skip tests according to the current OpenSSL version. =back =head3 Filters We can use filters to preprocess the values of our blocks, which can make specifying special values much easier. For example, we could chop off the last new-line character (if any) of the current section value by specifying the C filter, like this: --- response_body chomp Hello world! Without the C filter, the value of the C section would take a trailing new line. We list some of the common filters below (please keep in mind that one can define custom filters!) =over =item C Remove the last character if it is a newline. =item C Remove the last character no matter what it is. =item C Treat the section value as a Perl source code snippet, evaluate it right away, and use the returned value of the Perl code snippet (usually being the value of the last expression). This is very useful for specifying non-printable characters in section values, as in --- response_body eval "I don't know what \0 is.\n" =back =head1 Exported Perl Functions The following Perl functions are exported by default: =head2 run_tests This is the main entry point of the test scaffold. Calling this Perl function before C<__DATA__> makes all the tests run. Other configuration Perl functions I be called before calling this C function. =head2 no_shuffle By default, the test scaffold always shuffles the order of the test blocks automatically. Calling this function before calling C will disable the shuffling. =head2 use_hup Calling this function before calling C will make the current test scaffold behave as if C was set to 1. =head2 no_long_string By default, failed string equality test will use the L module to generate the error message. Calling this function before calling C will turn this off. =head2 no_diff When the C function is called, the C module will be used to generate a diff for failed string equality test. Calling this C function before calling C will turn this diff output format off and just generate the raw "got" text and "expected" text. =head2 worker_connections Call this function before calling C to set the Nginx's C configuration value. For example, worker_connections(1024); run_tests(); Default to 64. =head2 repeat_each Call this function with an integer argument before C to ask the test scaffold to run the specified number of duplicate requests for each test block. When it is called without argument, it returns the current setting. Default to 1. =head2 shutdown_error_log You can use this section to check the error log generated during nginx exit. For example, --- shutdown_error_log cleanup resolver or an example for using an array value, --- shutdown_error_log eval ["cleanup", "resolver"] B skip the shutdown_error_log tests under the HUP reload mode. =head2 no_shutdown_error_log Very much like the C<--- shutdown_error_log> section, but does the opposite test, i.e., pass only when the specified patterns of lines do not appear in the F file at all. Here is an example: --- no_shutdown_error_log [error] This test will fail when any of the line in the F file contains the string C<"[error]">. =head2 env_to_nginx Specify additional system environmnt variables to be passed into the nginx server. For example, env_to_nginx("foo", "bar=123", "baz=hello world"); run_tests(); will result in the following lines to be inserted into the resulting F file generated by the test scaffold: env foo; env bar=123; env 'baz=hello world'; The latter two are examples of setting values directly to the environments. You can also set values directly on the Perl land, before calling this C function, for instance, $ENV{baz} = 'hello world'; env_to_nginx("baz"); If you just want to pass certain environments to a particular test case (or test block), you can just use the C<--- main_config> secion directly. For example, --- main_config env foo; env bar=123; You can check out nginx's official document on its C directive below: L By default, only the following environments are passed: =over =item * MOCKEAGAIN_VERBOSE =item * MOCKEAGAIN =item * MOCKEAGAIN_WRITE_TIMEOUT_PATTERN =item * LD_PRELOAD =item * LD_LIBRARY_PATH =item * DYLD_INSERT_LIBRARIES =item * DYLD_FORCE_FLAT_NAMESPACE =item * ASAN_OPTIONS =item * MOCKNOEAGAIN_VERBOSE =item * MOCKNOEAGAIN =back =head2 workers Call this function before C to configure Nginx's C directive's value. For example, workers(2); Default to 1. =head2 master_on Call this function before C to turn on the Nginx master process. By default, the master process is not enabled unless in the "HUP reload" testing mode. =head2 log_level Call this function before C to set the default error log filtering level in Nginx. This global setting can be overridden by the per-test-block C<--- log_level> sections. Default to C. =head2 check_accum_error_log Make C<--- error_log> and C<--- no_error_log> check accumulated error log across duplicate requests controlled by C. By default, only the error logs belonging to the individual C request is tested. =head2 no_root_location By default, the Nginx configuration file generated by the test scaffold automatically emits a C. Calling this function before C disables this behavior such that the test blocks can have their own root locations. =head2 bail_out Aborting the whole test session (not just the current test file) with a specified message. This function will also do all the necessary cleanup work. So always use this function instead of calling C directly. For example, bail_out("something bad happened!"); =head2 add_test_cleanup_handler Register custom cleanup handler for the current perl/prove process by specifying a Perl subroutine object as the argument. For example, add_test_cleanup_handler(sub ($block) { print $block->name, " finish"; }); =head2 add_cleanup_handler Register custom cleanup handler for the current perl/prove process by specifying a Perl subroutine object as the argument. For example, add_cleanup_handler(sub { kill INT => $my_own_child_pid; $my_own_socket->close() }); =head2 add_block_preprocessor Add a custom Perl preprocessor to each test block by specifying a Perl subroutine object as the argument. The processor subroutine is always run right before processing the test block. This mechanism can be used to add custom sections or modify existing ones. For example, add_block_preprocessor(sub { my $block = shift; # use "--- req_headers" for "--- more_Headers": $block->set_value("more_headers", $block->req_headers); # initialize external dependencies like memcached services here... }); We can leverage this feature to specify a default value for one or more sections in a single test file. For instance, use Test::Nginx::Socket 'no_plan'; add_block_preprocessor(sub { my $block = shift; if (!defined $block->config) { $block->set_value("config", <<'_END_'); location = /t { echo $arg_a; } _END_ } }); run_tests(); __DATA__ === TEST 1: --- request GET /t?a=3 --- response_body 3 === TEST 2: --- request GET /t?a=blah --- response_body blah === TEST 3: --- config location = /t { echo ok; } --- request GET /t?a=blah --- response_body ok Here all the test blocks in this file have a default C<--- config> section configured. Some of the test blocks can still specify its own C<--- config> section to override the default, as in the `TEST 3` test block above. You can also make the defaults applicable to all the test files. Just create a subclass of L (or one of its subclasses like L, as in, package t::MyTester; use Test::Nginx::Socket -Base; add_block_preprocessor(sub { my $block = shift; if (!defined $block->config) { $block->set_value("config", <<'_END_'); location = /t { echo $arg_a; } _END_ } }); 1; Save this as file F. And then in one of your test file: use t::MyTester 'no_plan'; run_tests(); __DATA__ === TEST 1: --- request GET /t?a=3 --- response_body 3 === TEST 2: --- request GET /t?a=blah --- response_body blah You can do the same with the C<--- http_config> section, or even inventing your own new sections. This is very powerful. =head2 add_response_body_check Add custom checks for testing response bodies by specifying a Perl subroutine object as the argument. Below is an example for doing HTML title checks: add_response_body_check(sub { my ($block, $body, $req_idx, $repeated_req_idx, $dry_run) = @_; my $name = $block->name; my $expected_title = $block->resp_title; if ($expected_title && !ref $expected_title) { $expected_title =~ s/^\s*|\s*$//gs; } if (defined $expected_title) { SKIP: { skip "$name - resp_title - tests skipped due to $dry_run", 1 if $dry_run; my $title; if ($body =~ m{<\s*title\s*>\s*(.*?)<\s*/\s*title\s*>}) { $title = $1; $title =~ s/\s*$//s; } is_str($title, $expected_title, "$name - resp_title (req $repeated_req_idx)" ); } } }); =head2 is_str Performs intelligent string comparison subtests which honors both C and regular expression references in the "expected" argument. =head1 Sections supported The following sections are supported: =head2 http2 Enforces the test scaffold to use the HTTP/2 wire protocol to send the test request. Under the hood, the test scaffold uses the `curl` command-line utility to do the wire communication with the NGINX server. The `curl` utility must be recent enough to support C<--http2-prior-knowledge> command-line options. B not all the sections and features are supported when this C<--- http2> section is specified. For example, this section cannot be used with C<--- pipelined_requests> or C<--- raw_request>. See also the L system environment for the "http2" test mode. =head2 curl_protocol Set protocol (such as http/https) when sending request using 'curl'. =head2 curl_options Add extra command line options when using 'curl' to send request. Below is an example for sending an insecure https request using 'curl': --- http2 --- curl_options: -k --- curl_protocol: https --- request GET /ping =head2 curl_error The expected curl error. --- curl_error =head2 config Content of this section will be included in the "server" part of the generated config file. This is the place where you want to put the "location" directive enabling the module you want to test. Example: location /echo { echo_before_body hello; echo world; } Sometimes you simply don't want to bother copying ten times the same configuration for the ten tests you want to run against your module. One way to do this is to write a config section only for the first test in your C<.t> file. All subsequent tests will re-use the same config. Please note that this depends on the order of test, so you should run C with variable C (see below for more on this variable). Please note that config section goes through environment variable expansion provided the variables to expand start with TEST_NGINX. So, the following is a perfectly legal (provided C is set correctly): location /main { echo_subrequest POST /sub -f $TEST_NGINX_HTML_DIR/blah.txt; } =head2 http_config Content of this section will be included in the "http" part of the generated config file. This is the place where you want to put the "upstream" directive you might want to test. Example: upstream database { postgres_server 127.0.0.1:$TEST_NGINX_POSTGRESQL_PORT dbname=ngx_test user=ngx_test password=wrong_pass; } As you guessed from the example above, this section goes through environment variable expansion (variables have to start with TEST_NGINX). =head2 main_config Content of this section will be included in the "main" part (or toplevel) of the generated config file. This is very rarely used, except if you are testing nginx core itself. Everything in C<--- main_config> will be put before the C block generated automatically by the test scaffold. This section goes through environment variable expansion (variables have to start with TEST_NGINX). =head2 post_main_config Similar to C, but the content will be put I the C block generated by this module. =head2 server_name Specify a custom server name (via the "server_name" nginx config directive) for the current test block. Default to "localhost". =head2 init Run a piece of Perl code specified as the content of this C<--- init> section before running the tests for the blocks. Note that it is only run once before *all* the repeated requests for this test block. =head2 post_setup_server_root Run a piece of Perl code specified as the content of this C<--- post_setup_server_root> section to customization the test nginx instance for testing. Unlike C<--- init> section, C<--- post_setup_server_root> will preserve the changes in C. In its most basic form, this section looks like that: --- post_setup_server_root use Cwd qw(cwd); my $root_dir = cwd(); `ln -sf ${root_dir}/t/data/mime.types ${root_dir}/t/servroot/conf/mime.types`; This will create a symbolic link for file C, allow nginx to loading it by C =head2 request This is probably the most important section. It defines the request(s) you are going to send to the nginx server. It offers a pretty powerful grammar which we are going to walk through one example at a time. In its most basic form, this section looks like that: --- request GET This will just do a GET request on the root (i.e. /) of the server using HTTP/1.1. Of course, you might want to test something else than the root of your web server and even use a different version of HTTP. This is possible: --- request GET /foo HTTP/1.0 Please note that specifying HTTP/1.0 will not prevent Test::Nginx from sending the C header. Actually Test::Nginx always sends 2 headers: C (with value localhost) and C (with value C for simple requests and keep-alive for all but the last pipelined_requests). You can also add a content to your request: --- request POST /foo Hello world Test::Nginx will automatically calculate the content length and add the corresponding header for you. This being said, as soon as you want to POST real data, you will be interested in using the more_headers section and using the power of Test::Base filters to urlencode the content you are sending. Which gives us a slightly more realistic example: --- more_headers Content-type: application/x-www-form-urlencoded --- request eval use URI::Escape; "POST /rrd/foo value=".uri_escape("N:12345") Sometimes a test is more than one request. Typically you want to POST some data and make sure the data has been taken into account with a GET. You can do it using arrays: --- request eval ["POST /users name=foo", "GET /users/foo"] This way, REST-like interfaces are pretty easy to test. When you develop nifty nginx modules you will eventually want to test things with buffers and "weird" network conditions. This is where you split your request into network packets: --- request eval [["POST /users\nna", "me=foo"]] Here, Test::Nginx will first send the request line, the headers it automatically added for you and the first two letters of the body ("na" in our example) in ONE network packet. Then, it will send the next packet (here it's "me=foo"). When we talk about packets here, this is not exactly correct as there is no way to guarantee the behavior of the TCP/IP stack. What Test::Nginx can guarantee is that this will result in two calls to C. A good way to make I sure the two calls result in two packets is to introduce a delay (let's say 2 seconds)before sending the second packet: --- request eval [["POST /users\nna", {value => "me=foo", delay_before => 2}]] Of course, everything can be combined till your brain starts boiling ;) : --- request eval use URI::Escape; my $val="value=".uri_escape("N:12346"); [["POST /rrd/foo ".substr($val, 0, 6), {value => substr($val, 6, 5), delay_before=>5}, substr($val, 11)], "GET /rrd/foo"] Adding comments before the actual request spec is also supported, for example, --- request # this request contains the URI args # "foo" and "bar": GET /api?foo=1&bar=2 =head2 request_eval Use of this section is deprecated and tests using it should replace it with a C section with an C filter. More explicitly: --- request_eval "POST /echo_body hello\x00\x01\x02 world\x03\x04\xff" should be replaced by: --- request eval "POST /echo_body hello\x00\x01\x02 world\x03\x04\xff" =head2 pipelined_requests Specify pipelined requests that use a single keep-alive connection to the server. Here is an example from ngx_lua's test suite: === TEST 7: discard body --- config location = /foo { content_by_lua ' ngx.req.discard_body() ngx.say("body: ", ngx.var.request_body) '; } location = /bar { content_by_lua ' ngx.req.read_body() ngx.say("body: ", ngx.var.request_body) '; } --- pipelined_requests eval ["POST /foo hello, world", "POST /bar hiya, world"] --- response_body eval ["body: nil\n", "body: hiya, world\n"] =head2 more_headers Adds the content of this section as headers to the request being sent. Example: --- more_headers X-Foo: blah This will add C to the request (on top of the automatically generated headers like C, C and potentially C). =head2 curl When this section is specified, the test scaffold will try generating a C command line for the (first) test request. For example, --- request GET /foo/bar?baz=3 --- more_headers X-Foo: 3 User-Agent: openresty --- curl will produce the following line (to C) while running this test block: # curl -i -sS -H 'X-Foo: 3' -A openresty 'http://127.0.0.1:1984/foo/bar?baz=3' You need to remember to set the C environment to 1 to prevent the nginx and other processes from quitting automatically upon test exits. =head2 response_body_filters Transforms the value of the I response body data through a series of filters, before being matched against the expected response body data specified by the C or C sections. The filters can be specified either as names (for builtin filters) or as arbitrary Perl subroutine references. The following builtin filter names are supported: =over =item md5_hex =item sha1_hex =item length =item uc =item lc =item ucfirst =item lcfirst =back Their meanings are self-explanatory. Here is an example: === TEST 1: --- config location = /t { echo hello; } --- request GET /t --- response_body_filters uc --- response_body HELLO Here the actual response body data, C, will go through the fitler, C, to become all-upper-case, before getting matched against the expected pattern specified by the C section, C. The example above can be rewritten by using raw Perl subroutine reference values: === TEST 1: --- config location = /t { echo hello; } --- request GET /t --- response_body_filters eval \&CORE::uc --- response_body HELLO To reference builtin Perl functions like C<\&CORE::uc> and C<\&CORE::lc>, you need at least perl 5.16. Multiple builtin filter names can be specified at the same time and they will be applied in order. For example, === TEST 2: --- config location = /t { echo hello; } --- request GET /hello --- response_body_filters uc lc --- response_body hello If the response_body_filters value can also be an array reference, mostly useful for specifying multiple Perl subroutine references as the filters: === TEST 3: --- config location = /t { echo hello; } --- request GET /hello --- response_body_filters eval [\&CORE::uc, \&CORE::lc] --- response_body hello If the response_body_filters value can also be an two-dimensional array reference, it means the actual response body data will be C applied by the indexed array's filters: === TEST 4: --- config location = /t { echo hello; } --- request eval ['GET /t', 'GET /t'] --- response_body_filters eval [[\&CORE::uc, \&CORE::lc], [\&CORE::uc]] --- response_body eval ['hello', 'HELLO'] =head2 response_body_json_sort Because the order of the json string output by the lua-cjson is uncertain. In order to compare the output result, we need to sort the response body. --- response_body_json_sort --- response_body {"a": 1, "b": 2} =head2 response_body The expected value for the body of the submitted request. --- response_body hello If the test is made of multiple requests, then the response_body B be an array and each request B return the corresponding expected body: --- request eval ["GET /hello", "GET /world"] --- response_body eval ["hello", "world"] =head2 response_body_eval Use of this section is deprecated and tests using it should replace it with a C section with an C filter. Therefore: --- response_body_eval "hello\x00\x01\x02 world\x03\x04\xff" should be replaced by: --- response_body eval "hello\x00\x01\x02 world\x03\x04\xff" =head2 response_body_like The body returned by the request MUST match the pattern provided by this section. Example: --- response_body_like ^elapsed 0\.00[0-5] sec\.$ If the test is made of multiple requests, then response_body_like B be an array and each request B match the corresponding pattern. =head2 response_body_unlike Just like C but this test only pass when the specified pattern does I match the actual response body data. =head2 response_headers The headers specified in this section are in the response sent by nginx. --- response_headers Content-Type: application/x-resty-dbd-stream Of course, you can specify many headers in this section: --- response_headers X-Resty-DBD-Module: Content-Type: application/x-resty-dbd-stream The test will be successful only if all headers are found in the response with the appropriate values. If the test is made of multiple requests, then response_headers B be an array and each element of the array is checked against the response to the corresponding request. =head2 response_headers_like The value of the headers returned by nginx match the patterns. --- response_headers_like X-Resty-DBD-Module: ngx_drizzle \d+\.\d+\.\d+ Content-Type: application/x-resty-dbd-stream This will check that the response's C is application/x-resty-dbd-stream and that the C matches C. The test will be successful only if all headers are found in the response and if the values match the patterns. If the test is made of multiple requests, then response_headers_like B be an array and each element of the array is checked against the response to the corresponding request. =head2 raw_response_headers_like Checks the headers part of the response against this pattern. This is particularly useful when you want to write tests of redirect functions that are not bound to the value of the port your nginx server (under test) is listening to: --- raw_response_headers_like: Location: http://localhost(?::\d+)?/foo\r\n As usual, if the test is made of multiple requests, then raw_response_headers_like B be an array. =head2 raw_response_headers_unlike Just like C but the subtest only passes when the regex does I match the raw response headers string. =head2 error_code The expected value of the HTTP response code. If not set, this is assumed to be 200. But you can expect other things such as a redirect: --- error_code: 302 If the test is made of multiple requests, then error_code B be an array with the expected value for the response status of each request in the test. =head2 error_code_like Just like C, but accepts a Perl regex as the value, for example: --- error_code_like: ^(?:500)?$ If the test is made of multiple requests, then error_code_like B be an array with the expected value for the response status of each request in the test. =head2 timeout Specify the timeout value (in seconds) for the HTTP client embedded into the test scaffold. This has nothing to do with the server side configuration. When the timeout expires, the test scaffold will immediately close the socket for connecting to the Nginx server being tested. Note that, just as almost all the timeout settings in the Nginx world, this timeout also specifies the maximum waiting time between two successive I/O events on the same socket handle, rather than the total waiting time for the current socket operation. When the timeout setting expires, a test failure will be triggered with the message "ERROR: client socket timed out - TEST NAME", unless you have specified C<--- abort> at the same time. Here is an example: === TEST 1: test timeout --- location location = /t { echo_sleep 1; echo ok; } --- request GET /t --- response_body ok --- timeout: 1.5 An optional time unit can be specified, for example, --- timeout: 50ms Acceptable time units are C (seconds) and C (milliseconds). If no time unit is specified, then default to seconds. Default to 3s. =head2 error_log_file Specify the global error log file for the current test block only. Right now, it will not affect the C<--- error_log> section and etc accordingly. =head2 error_log Checks if the pattern or multiple patterns all appear in lines of the F file. For example, === TEST 1: matched with j --- config location /re { content_by_lua ' m = ngx.re.match("hello, 1234", "([0-9]+)", "j") if m then ngx.say(m[0]) else ngx.say("not matched!") end '; } --- request GET /re --- response_body 1234 --- error_log: pcre JIT compiling result: 1 Then the substring "pcre JIT compiling result: 1" must appear literally in a line of F. Multiple patterns are also supported, for example: --- error_log eval ["abc", qr/blah/] then the substring "abc" must appear literally in a line of F, and the regex C must also match a line in F. By default, only the part of the error logs corresponding to the current request is checked. You can make it check accumulated error logs by calling the C Perl function before calling C in the boilerplate Perl code above the C<__DATA__> line. =head2 access_log Similar to the L section, but for asserting appearance of patterns in the nginx access log file. Below is an example: === TEST 1: check access log --- config location /t { content_by_lua_block { ngx.say("hello") } } --- request GET /t --- response_body hello --- access_log GET /t =head2 no_access_log Similar to the L section, but for asserting appearance of patterns in the nginx access log file. Below is an example: === TEST 1: check access log --- config location /t { content_by_lua_block { ngx.say("hello") } } --- request GET /t --- response_body hello --- no_access_log GET /p =head2 abort Makes the test scaffold not to treat C<--- timeout> expiration as a test failure. =head2 shutdown Perform a C() operation on the client socket connecting to Nginx as soon as sending out all the request data. This section takes an (optional) integer value for the argument to the C function call. For example, --- shutdown: 1 will make the connection stop sending data, which is the default. =head2 no_error_log Very much like the C<--- error_log> section, but does the opposite test, i.e., pass only when the specified patterns of lines do not appear in the F file at all. Here is an example: --- no_error_log [error] This test will fail when any of the line in the F file contains the string C<"[error]">. Just like the C<--- error_log> section, one can also specify multiple patterns: --- no_error_log eval ["abc", qr/blah/] Then if any line in F contains the string C<"abc"> or match the Perl regex C, then the test will fail. =head2 grep_error_log This section specifies the Perl regex pattern for filtering out the Nginx error logs. You can specify a verbatim substring being matched in the error log messages, as in --- grep_error_log chop some thing we want to see or specify a Perl regex object to match against the error log message lines, as in --- grep_error_log eval qr/something should be: \d+/ All the matched substrings in the error log messages will be concatenated by a newline character as a whole to be compared with the value of the C<--- grep_error_log_out> section. =head2 grep_error_log_out This section contains the expected output for the filtering operations specified by the C<--- grep_error_log> section. If the filtered output varies among the repeated requests (specified by the C function, then you can specify a Perl array as the value, as in --- grep_error_log_out eval ["output for req 0", "output for req 1"] =head2 log_level Overrides the default error log level for the current test block. For example: --- log_level: debug The default error log level can be specified in the Perl code by calling the C function, as in use Test::Nginx::Socket; repeat_each(2); plan tests => repeat_each() * (3 * blocks()); log_level('warn'); run_tests(); __DATA__ ... =head2 raw_request The exact request to send to nginx. This is useful when you want to test some behaviors that are not available with "request" such as an erroneous C header or splitting packets right in the middle of headers: --- raw_request eval ["POST /rrd/taratata HTTP/1.1\r Host: localhost\r Connection: close\r Content-Type: application/", "x-www-form-urlencoded\r Content-Length:15\r\n\r\nvalue=N%3A12345"] This can also be useful to tests "invalid" request lines: --- raw_request GET /foo HTTP/2.0 THE_FUTURE_IS_NOW =head2 http09 Specifies that the HTTP 0.9 protocol is used. This affects how C parses the response. Below is an example from ngx_headers_more module's test suite: === TEST 38: HTTP 0.9 (set) --- config location /foo { more_set_input_headers 'X-Foo: howdy'; echo "x-foo: $http_x_foo"; } --- raw_request eval "GET /foo\r\n" --- response_headers ! X-Foo --- response_body x-foo: --- http09 =head2 ignore_response Do not attempt to parse the response or run the response related subtests. =head2 reload_fails Allows the NGINX HUP reload fails, which means that the server will still use the previous test block's nginx configuration. This only makes sense in the HUP reload testing mode. =head2 user_files With this section you can create a file that will be copied in the html directory of the nginx server under test. For example: --- user_files >>> blah.txt Hello, world will create a file named C in the html directory of the nginx server tested. The file will contain the text "Hello, world". Multiple files are supported, for example, --- user_files >>> foo.txt Hello, world! >>> bar.txt Hello, heaven! An optional last modified timestamp (in elpased seconds since Epoch) is supported, for example, --- user_files >>> blah.txt 199801171935.33 Hello, world It's also possible to specify a Perl data structure for the user files to be created, for example, --- user_files eval [ [ "foo.txt" => "Hello, world!", 199801171935.33 ], [ "bar.txt" => "Hello, heaven!" ], ] =head2 skip_eval Skip the specified number of subtests (in the current test block) if the result of running a piece of Perl code is true. The format for this section is --- skip_eval : For example, to skip 3 subtests when the current operating system is not Linux: --- skip_eval 3: $^O ne 'linux' or equivalently, --- skip_eval: 3: $^O ne 'linux' =head2 skip_nginx Skip the specified number of subtests (in the current test block) for the specified version range of nginx. The format for this section is --- skip_nginx : The value must be a positive integer. The value could be either C<< > >>, C<< >= >>, C<< < >>, or C<< <= >>. the part is a valid nginx version number, like C<1.0.2>. An example is === TEST 1: sample --- config location /t { echo hello; } --- request GET /t --- response_body --- skip_nginx 2: < 0.8.54 That is, skipping 2 subtests in this test block for nginx versions older than 0.8.54. This C section only allows you to specify one boolean expression as the skip condition. If you want to use two boolean expressions, you should use the C section instead. =head2 skip_nginx2 This section is similar to C, but the skip condition consists of two boolean expressions joined by the operator C or C. The format for this section is --- skip_nginx2 : and|or For example: === TEST 1: sample --- config location /t { echo hello; } --- request GET /t --- response_body --- skip_nginx2 2: < 0.8.53 and >= 0.8.41 =head2 skip_openssl Skip the specified number of subtests (in the current test block) for the specified version range of OpenSSL. The format for this section is --- skip_openssl : The value must be a positive integer. The value could be either C<< > >>, C<< >= >>, C<< < >>, or C<< <= >>. The part is a valid OpenSSL version number, like C<1.1.1> or C<1.1.0h>. An example is === TEST 1: sample --- config location /t { echo hello; } --- request GET /t --- response_body --- skip_openssl 2: < 1.1.1 That is, skipping 2 subtests in this test block for OpenSSL versions older than 1.1.1. This C section only allows you to specify one boolean expression as the skip condition. =head2 todo Mark tests as todo. Currently they are not used but they should be. The format for this section is --- todo : The value must be a positive integer. is logged when you run tests with --directives. =head2 stap This section is used to specify user systemtap script file (.stp file) Here's an example: === TEST 1: stap sample --- config location /t { echo hello; } --- stap probe process("nginx").function("ngx_http_finalize_request") { printf("finalize %s?%s\n", ngx_http_req_uri($r), ngx_http_req_args($r)) } --- stap_out finalize /test?a=3&b=4 --- request GET /test?a=3&b=4 --- response_body hello There's some macros that can be used in the "--- stap" section value. These macros will be expanded by the test scaffold automatically. =over =item C This expands to C. For example, the sample above can be rewritten as === TEST 1: stap sample --- config location /t { echo hello; } --- stap F(ngx_http_finalize_request) { printf("finalize %s?%s\n", ngx_http_req_uri($r), ngx_http_req_args($r)) } --- stap_out finalize /test?a=3&b=4 --- request GET /test?a=3&b=4 --- response_body hello =item C This macro will be expanded to C. =item C This macro will be expanded to C. For example, M(http-subrequest-start) { ... } will be expanded to probe process("nginx").mark("http-subrequest-start") { ... } =back =head2 stap_out This section specifies the expected literal output of the systemtap script specified by C. =head2 stap_out_like Just like C, but specify a Perl regex pattern instead. =head2 stap_out_unlike Just like C, but the subtest only passes when the specified pattern does I match the output of the systemtap script. =head2 wait Takes an integer value for the seconds of time to wait right after processing the Nginx response and before performing the error log and/or systemtap output checks. =head2 udp_listen Instantiates a UDP server listening on the port specified in the background for the test case to access. The server will be started and shut down at each iteration of the test case (if repeat_each is set to 3, then there are 3 iterations). The UDP server will first read and discard a datagram and then send back a datagram with the content specified by the C section value. Here is an example: === TEST 1: udp access --- config location = /t { content_by_lua ' local udp = ngx.socket.udp() udp:setpeername("127.0.0.1", 19232) udp:send("blah") local data, err = udp:receive() ngx.say("received: ", data) '; } --- udp_listen: 19232 --- udp_reply: hello world --- request GET /t --- response_body received: hello world Datagram UNIX domain socket is also supported if a path name ending with ".sock" is given to this directive. For instance, === TEST 2: datagram unix domain socket access --- config location = /t { content_by_lua ' local udp = ngx.socket.udp() udp:setpeername("unix:a.sock") udp:send("blah") local data, err = udp:receive() ngx.say("received: ", data) '; } --- udp_listen: a.sock --- udp_reply: hello world --- request GET /t --- response_body received: hello world =head2 udp_reply This section specifies the datagram reply content for the UDP server created by the C section. You can also specify a delay time before sending out the reply via the C section. By default, there is no delay. An array value can be specified to make the embedded UDP server to send multiple replies as specified, for example: --- udp_reply eval [ "hello", "world" ] This section also accepts a Perl subroutine value that can be used to generate dynamic response packet or packets based on the actual query, for example: --- udp_reply eval sub { my $req = shift; return "hello, $req"; } The custom Perl subroutine can also return an array reference, for example, --- udp_reply eval sub { my $req = shift; return ["hello, $req", "hiya, $req"]; } See the C section for more details. =head2 udp_reply_delay This section specifies the delay time before sending out the reply specified by the C section. It is C<0> delay by default. An optional time unit can be specified, for example, --- udp_reply_delay: 50ms Acceptable time units are C (seconds) and C (milliseconds). If no time unit is specified, then default to seconds. =head2 udp_query Tests whether the UDP query sent to the embedded UDP server is equal to what is specified by this directive. For example, === TEST 1: udp access --- config location = /t { content_by_lua ' local udp = ngx.socket.udp() udp:setpeername("127.0.0.1", 19232) udp:send("blah") local data, err = udp:receive() ngx.say("received: ", data) '; } --- udp_listen: 19232 --- udp_reply: hello world --- request GET /t --- udp_query: hello world --- response_body received: hello world =head2 tcp_listen Just like C, but starts an embedded TCP server listening on the port specified. For example, --- tcp_listen: 12345 Stream-typed unix domain socket is also supported. Just specify the path to the socket file, as in --- tcp_listen: /tmp/my-socket.sock =head2 tcp_no_close When this section is present, the embedded TCP server (if any) will not close the current TCP connection. =head2 tcp_reply_delay Just like C, but for the embedded TCP server. =head2 tcp_reply Just like C, but for the embedded TCP server. Like the C section, this section also accepts a Perl subroutine value that can be used to generate dynamic response packet or packets based on the actual query, for example: --- tcp_reply eval sub { my $req = shift; return "hello, $req"; } The custom Perl subroutine can also return an array reference, for example, --- tcp_reply eval sub { my $req = shift; return ["hello, $req", "hiya, $req"]; } =head2 tcp_query Just like C, but for the embedded TCP server. =head2 tcp_query_len Specifies the expected TCP query received by the embedded TCP server. If C is specified, C defaults to the length of the value of C. =head2 tcp_query_auto_timeout If you don't know the query data length in advance, you can specify this option with an timeout argument. The default timeout for reading from peer is 0.1 sec. =head2 tcp_shutdown Shuts down the reading part, writing part, or both in the embedded TCP server as soon as a new connection is established. Its value specifies which part to shut down: 0 for read part only, 1 for write part only, and 2 for both directions. =head2 raw_request_middle_delay Delay in sec between sending successive packets in the "raw_request" array value. Also used when a request is split in packets. =head2 no_check_leak Skip the tests in the current test block in the "check leak" testing mode (i.e, with C=1). =head2 must_die Test the cases that Nginx must die right after starting. If a value is specified, the exit code must match the specified value. Normal request and response cycle is not done. But you can still use the C section to check if there is an error message to be seen. This is meant to test bogus configuration is noticed and given proper error message. It is normal to see stderr error message when running these tests (you can use L to suppress these messages). Below is an example: === TEST 1: bad "return" directive --- config location = /t { return a b c; } --- request GET /t --- must_die --- error_log invalid number of arguments in "return" directive --- no_error_log [error] This configuration ignores C C or C since there is no point to check other things when the nginx is expected to die right away. This directive is handled before checking C. =head2 suppress_stderr Send stderr of the nginx to the /dev/null. Useful with L. =head2 server_addr_for_client This section specifies the server address Test::Nginx will connect to. If server_addr_for_client is not set, then 127.0.0.1 is used. =head1 Environment variables All environment variables starting with C are expanded in the sections used to build the configuration of the server that tests automatically starts. The following environment variables are supported by this module: =head2 TEST_NGINX_REUSE_PORT When this environment is set to a true value, the test scaffold would add the "resuseport" parameter to the "listen" directive automatically generated in F. =head2 TEST_NGINX_USE_HTTP2 Enables the "http2" test mode by enforcing using the (plain text) HTTP/2 protocol to send the test request. Under the hood, the test scaffold uses the `curl` command-line utility to do the wire communication with the NGINX server. The `curl` utility must be recent enough to support C<--http2-prior-knowledge> command-line options. B not all the sections and features are supported in the "http2" test mode. For example, the L and L will still use the HTTP/1 protocols even in the "http2" test mode. Similarly, test blocks explicitly require the HTTP 1.0 protocol will still use HTTP 1.0. One can enable HTTP/2 mode for an individual test block by specifying the L section, as in --- http2 One can disable HTTP/2 mode for an individual test block by specifying the L section, as in --- no_http2 =head2 TEST_NGINX_USE_HTTP3 Enables the "http3" test mode by enforcing using the HTTP/3 protocol to send the test request. Under the hood, the test scaffold uses the `curl` command-line utility to do the wire communication with the NGINX server. The `curl` utility must be recent enough to support both the C<--http3> command-line options. B not all the sections and features are supported in the "http3" test mode. For example, the L and L will still use the HTTP/1 protocols even in the "http3" test mode. Similarly, test blocks explicitly require the HTTP 1.0 protocol will still use HTTP 1.0. One can enable HTTP/3 mode for an individual test block by specifying the L section, as in --- http3 One can disable HTTP/3 mode for an individual test block by specifying the L section, as in --- no_http3 =head2 TEST_NGINX_HTTP3_CRT When running in http3 mode, you need to specify the default certificate. =head2 TEST_NGINX_HTTP3_KEY When running in http3 mode, you need to specify the default key. =head2 TEST_NGINX_QUIC_IDLE_TIMEOUT HTTP3 connections are not closed when the requests finished. When reload nginx, the older nginx will not exit unitl the older connections idle timeout reach. The default idle timeout is 60 seconds which is too long for the test scaffold. Change the idle timeout value by environment var TEST_NGINX_QUIC_IDLE_TIMEOUT. Default idle timeout value is 0.6s if not set. export TEST_NGINX_QUIC_IDLE_TIMEOUT=0.1 =head2 TEST_NGINX_VERBOSE Controls whether to output verbose debugging messages in Test::Nginx. Default to empty. =head2 TEST_NGINX_BENCHMARK When set to an non-empty and non-zero value, then the test scaffold enters the benchmarking testing mode by invoking C (for HTTP 1.1 requests) and C (for HTTP 1.0 requests) to run each test case with the test request repeatedly. When specifying a positive number as the value, then this number is used for the total number of repeated requests. For example, export TEST_NGINX_BENCHMARK=1000 will result in 1000 repeated requests for each test block. Default to C<100000>. When a second number is specified (separated from the first number by spaces), then this second number is used for the concurrency level for the benchmark. For example, export TEST_NGINX_BENCHMARK='1000 10' will result in 1000 repeated requests over 10 concurrent connections for each test block. The default concurrency level is 2 (or 1 if the number of requests is 1). The "benchmark" testing mode will also output to stderr the actual "ab" or "weighttp" command line used by the test scaffold. For example, weighttp -c2 -k -n2000 -H 'Host: foo.com' http://127.0.0.1:1984/t See also the C environment. This testing mode requires the C command-line utility from the C package. =head2 TEST_NGINX_BENCHMARK_WARMUP Specify the number of "warm-up" requests performed before the actual benchmark requests for each test block. The latencies of the warm-up requests never get included in the final benchmark results. Only meaningful in the "benchmark" testing mode. See also the C environment. =head2 TEST_NGINX_CHECK_LEAK When set to 1, the test scaffold performs the most general memory leak test by means of calling C/C and C. Specifically, it starts C (for HTTP 1.1 C requests) or C (for HTTP 1.0 requests) to repeatedly hitting Nginx for seconds in a sub-process, and then after about 1 second, it will start sampling the RSS value of the Nginx process by calling the C utility every 20 ms. Finally, it will output all the sample point data and the line slope of the linear regression result on the 100 sample points. One typical output for non-leaking test cases: t/075-logby.t .. 3/17 TEST 2: log_by_lua_file LeakTest: [2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176 2176] LeakTest: k=0.0 and here is an example of leaking: TEST 5: ngx.ctx available in log_by_lua (not defined yet) LeakTest: [4396 4440 4476 4564 4620 4708 4752 4788 4884 4944 4996 5032 5080 5132 5188 5236 5348 5404 5464 5524 5596 5652 5700 5776 5828 5912 5964 6040 6108 6108 6316 6316 6584 6672 6672 6752 6820 6912 6912 6980 7064 7152 7152 7240 7340 7340 7432 7508 7508 7600 7700 7700 7792 7896 7896 7992 7992 8100 8100 8204 8296 8296 8416 8416 8512 8512 8624 8624 8744 8744 8848 8848 8968 8968 9084 9084 9204 9204 9324 9324 9444 9444 9584 9584 9704 9704 9832 9832 9864 9964 9964 10096 10096 10488 10488 10488 10488 10488 11052 11052] LeakTest: k=64.1 Even very small leaks can be amplified and caught easily by this testing mode because their slopes will usually be far above C<1.0>. One can configure the number of sample points via the L system environment, for example, to sample 1000 data points, we can set the following environment I running the test: export TEST_NGINX_CHECK_LEAK_COUNT=1000 For now, only C, C, C, and C requests are supported (due to the limited HTTP support in both C and C). Other methods specified in the test cases will turn to C with force. The tests in this mode will always succeed because this mode also enforces the "dry-run" mode. Test blocks carrying the "--- no_check_leak" directive will be skipped in this testing mode. =head2 TEST_NGINX_CHECK_LEAK_COUNT Takes a number value which controls how many data points to be sampled in the "check leak" test mode. See L for more details. Defaults to 100. =head2 TEST_NGINX_USE_HUP When set to 1, the test scaffold will try to send C signal to the Nginx master process to reload the config file between successive test blocks (but not successive C sub-tests within the same test block). When this environment is set to 1, it will also enforce the "master_process on" config line in the F file, because Nginx is buggy in processing HUP signal when the master process is off. =head2 TEST_NGINX_LOAD_MODULES This environment takes a list of dynamic NGINX module files' paths. The test scaffold generates a series of C directives in the top-level scope of F. For example, when this environment takes the value C<../../work/nginx/modules/ngx_http_headers_more_filter_module.so ../../work/nginx/modules/ngx_http_lua_module.so >, then the following snippet will be generated in F: load_module ../../work/nginx/modules/ngx_http_headers_more_filter_module.so; load_module ../../work/nginx/modules/ngx_http_lua_module.so; This requires at least NGINX 1.9.11 to work. =head2 TEST_NGINX_POSTPONE_OUTPUT Defaults to empty. This environment takes positive integer numbers as its value and it will cause the auto-generated nginx.conf file to have a "postpone_output" setting in the http {} block. For example, setting TEST_NGINX_POSTPONE_OUTPUT to 1 will have the following line in nginx.conf's http {} block: postpone_output 1; and it will effectively disable the write buffering in nginx's ngx_http_write_module. =head2 TEST_NGINX_NO_CLEAN When this environment is set to 1, it will prevent the test scaffold from quitting the Nginx server at the end of the run. This is very useful when you want to use other tools like gdb or curl inspect the Nginx server manually afterwards. =head2 TEST_NGINX_NO_NGINX_MANAGER Defaults to 0. If set to 1, Test::Nginx module will not manage (configure/start/stop) the C process. Can be useful to run tests against an already configured (and running) nginx server. =head2 TEST_NGINX_FAST_SHUTDOWN Defaults to 0. If set to 1, Test::Nginx module will stop C process with SIGTERM. =head2 TEST_NGINX_NO_SHUFFLE Defaults to 0. If set to 1, will make sure the tests are run in the order they appear in the test file (and not in random order). =head2 TEST_NGINX_USE_VALGRIND If set, Test::Nginx will start nginx with valgrind with the the value of this environment as the options. Nginx is actually started with C, the suppressions option being used only if there is actually a valgrind.suppress file. If this environment is set to the number C<1> or any other non-zero numbers, then it is equivalent to taking the value C<--tool=memcheck --leak-check=full>. =head2 TEST_NGINX_VALGRIND_EXIT_ON_FIRST_ERR If set, Test::Nginx will add C<--exit-on-first-error=yes --error-exitcode=1> options for the valgrind. Nginx is actually started with C, the suppressions option being used only if there is actually a valgrind.suppress file. If this environment is set to the number C<1> or any other non-zero numbers, then it is equivalent to taking the value C<--exit-on-first-error=yes --error-exitcode=1>. You would prefer to turn on this option when multiple invalid memory accesses exist. =head2 TEST_NGINX_USE_RR Uses Mozilla rr to record the execution of the nginx server run by the test scaffold. This feature is experimental. =head2 TEST_NGINX_USE_STAP When set to true values (like 1), the test scaffold will use systemtap to instrument the nginx process. You can specify the stap script in the C section. Note that you need to use the C script from the C project. =head2 TEST_NGINX_STAP_OUT You can specify the output file for the systemtap tool. By default, a random file name under the system temporary directory is generated. It's common to specify C when debugging. =head2 TEST_NGINX_BINARY The command to start nginx. Defaults to C. Can be used as an alternative to setting C to run a specific nginx instance. =head2 TEST_NGINX_LOG_LEVEL Value of the last argument of the C configuration directive. Defaults to C. =head2 TEST_NGINX_MASTER_PROCESS Value of the C configuration directive. Defaults to C. =head2 TEST_NGINX_SERVER_PORT Value of the port the server started by Test::Nginx will listen to. If not set, C is used. If C is not set, then C<1984> is used. See below for typical use. =head2 TEST_NGINX_CLIENT_PORT Value of the port Test::Nginx will direct requests to. If not set, C is used. If C is not set, then C<1984> is used. A typical use of this feature is to test extreme network conditions by adding a "proxy" between Test::Nginx and nginx itself. This is described in the C section of this module README. =head2 TEST_NGINX_PORT A shortcut for setting both C and C. =head2 TEST_NGINX_SLEEP How much time (in seconds) should Test::Nginx sleep between two calls to C when sending request data. Defaults to 0.015 (seconds). =head2 TEST_NGINX_FORCE_RESTART_ON_TEST Defaults to 1. If set to 0, Test::Nginx will not restart the nginx server when the config does not change between two tests. =head2 TEST_NGINX_SERVROOT The root of the nginx "hierarchy" (where you find the conf, *_tmp and logs directories). This value will be used with the C<-p> option of C. Defaults to appending C to the current directory. =head2 TEST_NGINX_IGNORE_MISSING_DIRECTIVES If set to 1 will SKIP all tests which C sections resulted in a C when trying to start C. Useful when you want to run tests on a build of nginx that does not include all modules it should. By default, these tests will FAIL. =head2 TEST_NGINX_EVENT_TYPE This environment can be used to specify a event API type to be used by Nginx. Possible values are C, C, C