pax_global_header00006660000000000000000000000064122776625460014533gustar00rootroot0000000000000052 comment=04dfb4c66c854a0627a5c3b940695b5fd6553b8b ngx_http_substitutions_filter_module-0.6.4/000077500000000000000000000000001227766254600213265ustar00rootroot00000000000000ngx_http_substitutions_filter_module-0.6.4/CHANGES000066400000000000000000000027021227766254600223220ustar00rootroot00000000000000 Changes with nginx_substitutions_filter 0.6.4 2014-02-15 *) Now non-200 response will work *) added the subs_filter_bypass directive Changes with nginx_substitutions_filter 0.6.2 2012-08-26 *) fixed a bug of buffer overlap *) fixed a bug with last zero buffer Changes with nginx_substitutions_filter 0.6.0 2012-06-30 *) refactor this module Changes with nginx_substitutions_filter 0.5.2 2010-08-11 *) do many optimizing for this module *) fix a bug of buffer overlap *) fix a segment fault bug when output chain return NGX_AGAIN. *) fix a bug about last buffer with no linefeed. This may cause segment fault. Thanks for Josef Fröhle Changes with nginx_substitutions_filter 0.5 2010-04-15 *) refactor the source structure, create branches of dev *) fix a bug of small chunk of buffers causing lose content *) fix the bug of last_buf and the nginx's compatibility above 0.8.25 *) fix a bug with unwanted capture config error in fix string substitution *) add feature of regex captures Changes with nginx_substitutions_filter 0.4 2009-12-23 *) fix many bugs Changes with nginx_substitutions_filter 0.3 2009-02-04 *) Initial public release ngx_http_substitutions_filter_module-0.6.4/README000066400000000000000000000100511227766254600222030ustar00rootroot00000000000000nginx_substitutions_filter *Note: this module is not distributed with the Nginx source. Installation instructions can be found below.* Description nginx_substitutions_filter is a filter module which can do both regular expression and fixed string substitutions on response bodies. This module is quite different from the Nginx's native Substitution Module. It scans the output chains buffer and matches string line by line, just like Apache's mod_substitute (). Example location / { subs_filter_types text/html text/css text/xml; subs_filter st(\d*).example.com $1.example.com ir; subs_filter a.example.com s.example.com; } Directives * subs_filter_types * subs_filter subs_filter_types syntax: *subs_filter_types mime-type [mime-types] * default: *subs_filter_types text/html* context: *http, server, location* *subs_filter_types* is used to specify which content types should be checked for *subs_filter*. The default is only *text/html*. This module just works with plain text. If the response is compressed, it can't uncompress the response and will ignore this response. This module can be compatible with gzip filter module. But it will not work with proxy compressed response. You can disable the compressed response like this: proxy_set_header Accept-Encoding ""; subs_filter syntax: *subs_filter source_str destination_str [gior] * default: *none* context: *http, server, location* *subs_filter* allows replacing source string(regular expression or fixed) in the nginx response with destination string. Substitution text may contain variables. More than one substitution rules per location is supported. The meaning of the third flags are: * *g*(default): Replace all the match strings. * *i*: Perform a case-insensitive match. * *o*: Just replace the first one. * *r*: The pattern is treated as a regular expression, default is fixed string. subs_filter_bypass syntax: *subs_filter_bypass $variable1 ...* default: *none* context: *http, server, location* You can sepcify several variables with this directive. If at least one of the variable is not empty and is not equal to '0', this substitution filter will be disabled. Installation To install, get the source with subversion: git clone git://github.com/yaoweibin/ngx_http_substitutions_filter_module.git and then compile nginx with the following option: ./configure --add-module=/path/to/module Known issue * Can't substitute the response header. CHANGES Changes with nginx_substitutions_filter 0.6.4 2014-02-15 * Now non-200 response will work * added the subs_filter_bypass directive Changes with nginx_substitutions_filter 0.6.2 2012-08-26 * fixed a bug of buffer overlap * fixed a bug with last zero buffer Changes with nginx_substitutions_filter 0.6.0 2012-06-30 * refactor this module Changes with nginx_substitutions_filter 0.5.2 2010-08-11 * do many optimizing for this module * fix a bug of buffer overlap * fix a segment fault bug when output chain return NGX_AGAIN. * fix a bug about last buffer with no linefeed. This may cause segment fault. Thanks for Josef Fröhle Changes with nginx_substitutions_filter 0.5 2010-04-15 * refactor the source structure, create branches of dev * fix a bug of small chunk of buffers causing lose content * fix the bug of last_buf and the nginx's compatibility above 0.8.25 * fix a bug with unwanted capture config error in fix string substitution * add feature of regex captures Changes with nginx_substitutions_filter 0.4 2009-12-23 * fix many bugs Changes with nginx_substitutions_filter 0.3 2009-02-04 * Initial public release Reporting a bug Questions/patches may be directed to Weibin Yao, yaoweibin@gmail.com. ngx_http_substitutions_filter_module-0.6.4/config000066400000000000000000000003101227766254600225100ustar00rootroot00000000000000ngx_addon_name=ngx_http_subs_filter_module HTTP_AUX_FILTER_MODULES="$HTTP_AUX_FILTER_MODULES ngx_http_subs_filter_module" NGX_ADDON_SRCS="$NGX_ADDON_SRCS $ngx_addon_dir/ngx_http_subs_filter_module.c" ngx_http_substitutions_filter_module-0.6.4/doc/000077500000000000000000000000001227766254600220735ustar00rootroot00000000000000ngx_http_substitutions_filter_module-0.6.4/doc/README.google_code_home_page.wiki000066400000000000000000000101511227766254600301640ustar00rootroot00000000000000= nginx_substitutions_filter = _Note: this module is not distributed with the Nginx source. Installation instructions can be found [#Installation below]._ == Description == `nginx_substitutions_filter` is a filter module which can do both regular expression and fixed string substitutions on response bodies. This module is quite different from the Nginx's native Substitution Module. It scans the output chains buffer and matches string line by line, just like Apache's [http://httpd.apache.org/docs/trunk/mod/mod_substitute.html mod_substitute]. == Example == {{{ location / { subs_filter_types text/html text/css text/xml; subs_filter st(\d*).example.com $1.example.com ir; subs_filter a.example.com s.example.com; } }}} == Directives == * [#subs_filter_types subs_filter_types] * [#subs_filter subs_filter] === subs_filter_types === `syntax:` _subs_filter_types mime-type `[`mime-types`]` _ `default:` _subs_filter_types text/html_ `context:` _http, server, location_ _subs_filter_types_ is used to specify which content types should be checked for _subs_filter_. The default is only _text/html_. This module just works with plain text. If the response is compressed, it can't uncompress the response and will ignore this response. This module can be compatible with gzip filter module. But it will not work with proxy compressed response. You can disable the compressed response like this: proxy_set_header Accept-Encoding ""; === subs_filter === `syntax:` _subs_filter source_str destination_str `[`gior`]` _ `default:` _none_ `context:` _http, server, location_ _subs_filter_ allows replacing source string(regular expression or fixed) in the nginx response with destination string. Substitution text may contain variables. More than one substitution rules per location is supported. The meaning of the third flags are: * _g_(default): Replace all the match strings. * _i_: Perform a case-insensitive match. * _o_: Just replace the first one. * _r_: The pattern is treated as a regular expression, default is fixed string. === subs_filter_bypass === `syntax:` _subs_filter_bypass $variable1 ..._ `default:` _none_ `context:` _http, server, location_ You can sepcify several variables with this directive. If at least one of the variable is not empty and is not equal to '0', this substitution filter will be disabled. == Installation == To install, get the source with subversion: {{{ git clone git://github.com/yaoweibin/ngx_http_substitutions_filter_module.git }}} and then compile nginx with the following option: {{{ ./configure --add-module=/path/to/module }}} == Known issue == * Can't substitute the response header. == CHANGES == Changes with nginx_substitutions_filter 0.6.4 2014-02-15 * Now non-200 response will work * added the subs_filter_bypass directive Changes with nginx_substitutions_filter 0.6.2 2012-08-26 * fixed a bug of buffer overlap * fixed a bug with last zero buffer Changes with nginx_substitutions_filter 0.6.0 2012-06-30 * refactor this module Changes with nginx_substitutions_filter 0.5.2 2010-08-11 * do many optimizing for this module * fix a bug of buffer overlap * fix a segment fault bug when output chain return NGX_AGAIN. * fix a bug about last buffer with no linefeed. This may cause segment fault. Thanks for Josef Fröhle Changes with nginx_substitutions_filter 0.5 2010-04-15 * refactor the source structure, create branches of dev * fix a bug of small chunk of buffers causing lose content * fix the bug of last_buf and the nginx's compatibility above 0.8.25 * fix a bug with unwanted capture config error in fix string substitution * add feature of regex captures Changes with nginx_substitutions_filter 0.4 2009-12-23 * fix many bugs Changes with nginx_substitutions_filter 0.3 2009-02-04 * Initial public release == Reporting a bug == Questions/patches may be directed to Weibin Yao, yaoweibin@gmail.com. ngx_http_substitutions_filter_module-0.6.4/doc/README.html000066400000000000000000000153471227766254600237300ustar00rootroot00000000000000 nginx_substitutions_filter

nginx_substitutions_filter

Note: this module is not distributed with the Nginx source. Installation instructions can be found below. >

Description

nginx_substitutions_filter is a filter module which can do both regular expression and fixed string substitutions on response bodies. This module is quite different from the Nginx's native Substitution Module. It scans the output chains buffer and matches string line by line, just like Apache's mod_substitute (http://httpd.apache.org/docs/trunk/mod/mod_substitute.html).

Example

location / {

    subs_filter_types text/html text/css text/xml;
    subs_filter st(\d*).example.com $1.example.com ir;
    subs_filter a.example.com s.example.com;

}

Directives

subs_filter_types

syntax: subs_filter_types mime-type [mime-types]

default: subs_filter_types text/html

context: http, server, location

subs_filter_types is used to specify which content types should be checked for subs_filter. The default is only text/html.

This module just works with plain text. If the response is compressed, it can't uncompress the response and will ignore this response. This module can be compatible with gzip filter module. But it will not work with proxy compressed response. You can disable the compressed response like this:

proxy_set_header Accept-Encoding ``'';

subs_filter

syntax: subs_filter source_str destination_str [gior]

default: none

context: http, server, location

subs_filter allows replacing source string(regular expression or fixed) in the nginx response with destination string. Substitution text may contain variables. More than one substitution rules per location is supported. The meaning of the third flags are:

subs_filter_bypass

syntax: subs_filter_bypass $variable1 ...

default: none

context: http, server, location

You can sepcify several variables with this directive. If at least one of the variable is not empty and is not equal to '0', this substitution filter will be disabled.

Installation

To install, get the source with subversion:

git clone git://github.com/yaoweibin/ngx_http_substitutions_filter_module.git

and then compile nginx with the following option:

./configure --add-module=/path/to/module

Known issue

CHANGES

Changes with nginx_substitutions_filter 0.6.4 2014-02-15

Changes with nginx_substitutions_filter 0.6.2 2012-08-26

Changes with nginx_substitutions_filter 0.6.0 2012-06-30

Changes with nginx_substitutions_filter 0.5.2 2010-08-11

Changes with nginx_substitutions_filter 0.5 2010-04-15

Changes with nginx_substitutions_filter 0.4 2009-12-23

Changes with nginx_substitutions_filter 0.3 2009-02-04

Reporting a bug

Questions/patches may be directed to Weibin Yao, yaoweibin@gmail.com.

ngx_http_substitutions_filter_module-0.6.4/doc/README.wiki000066400000000000000000000103031227766254600237120ustar00rootroot00000000000000= nginx_substitutions_filter = ''Note: this module is not distributed with the Nginx source. Installation instructions can be found [[#Installation|below]].'' == Description == '''nginx_substitutions_filter''' is a filter module which can do both regular expression and fixed string substitutions on response bodies. This module is quite different from the Nginx's native Substitution Module. It scans the output chains buffer and matches string line by line, just like Apache's [http://httpd.apache.org/docs/trunk/mod/mod_substitute.html mod_substitute]. == Example == location / { subs_filter_types text/html text/css text/xml; subs_filter st(\d*).example.com $1.example.com ir; subs_filter a.example.com s.example.com; } == Directives == * [[#subs_filter_types|subs_filter_types]] * [[#subs_filter|subs_filter]] === subs_filter_types === '''syntax:''' ''subs_filter_types mime-type [mime-types] '' '''default:''' ''subs_filter_types text/html'' '''context:''' ''http, server, location'' ''subs_filter_types'' is used to specify which content types should be checked for ''subs_filter''. The default is only ''text/html''. This module just works with plain text. If the response is compressed, it can't uncompress the response and will ignore this response. This module can be compatible with gzip filter module. But it will not work with proxy compressed response. You can disable the compressed response like this: proxy_set_header Accept-Encoding ""; === subs_filter === '''syntax:''' ''subs_filter source_str destination_str [gior] '' '''default:''' ''none'' '''context:''' ''http, server, location'' ''subs_filter'' allows replacing source string(regular expression or fixed) in the nginx response with destination string. Substitution text may contain variables. More than one substitution rules per location is supported. The meaning of the third flags are: * ''g''(default): Replace all the match strings. * ''i'': Perform a case-insensitive match. * ''o'': Just replace the first one. * ''r'': The pattern is treated as a regular expression, default is fixed string. === subs_filter_bypass === '''syntax:''' ''subs_filter_bypass $variable1 ...'' '''default:''' ''none'' '''context:''' ''http, server, location'' You can sepcify several variables with this directive. If at least one of the variable is not empty and is not equal to '0', this substitution filter will be disabled. == Installation == To install, get the source with subversion: git clone git://github.com/yaoweibin/ngx_http_substitutions_filter_module.git and then compile nginx with the following option: ./configure --add-module=/path/to/module == Known issue == * Can't substitute the response header. == CHANGES == Changes with nginx_substitutions_filter 0.6.4 2014-02-15 * Now non-200 response will work * added the subs_filter_bypass directive Changes with nginx_substitutions_filter 0.6.2 2012-08-26 * fixed a bug of buffer overlap * fixed a bug with last zero buffer Changes with nginx_substitutions_filter 0.6.0 2012-06-30 * refactor this module Changes with nginx_substitutions_filter 0.5.2 2010-08-11 * do many optimizing for this module * fix a bug of buffer overlap * fix a segment fault bug when output chain return NGX_AGAIN. * fix a bug about last buffer with no linefeed. This may cause segment fault. Thanks for Josef Fröhle Changes with nginx_substitutions_filter 0.5 2010-04-15 * refactor the source structure, create branches of dev * fix a bug of small chunk of buffers causing lose content * fix the bug of last_buf and the nginx's compatibility above 0.8.25 * fix a bug with unwanted capture config error in fix string substitution * add feature of regex captures Changes with nginx_substitutions_filter 0.4 2009-12-23 * fix many bugs Changes with nginx_substitutions_filter 0.3 2009-02-04 * Initial public release == Reporting a bug == Questions/patches may be directed to Weibin Yao, yaoweibin@gmail.com. ngx_http_substitutions_filter_module-0.6.4/ngx_http_subs_filter_module.c000066400000000000000000001016611227766254600273000ustar00rootroot00000000000000/* * Author: Weibin Yao(yaoweibin@gmail.com) * * Licence: This module could be distributed under the * same terms as Nginx itself. */ #include #include #include #include #if (NGX_DEBUG) #define SUBS_DEBUG 1 #else #define SUBS_DEBUG 0 #endif #ifndef NGX_HTTP_MAX_CAPTURES #define NGX_HTTP_MAX_CAPTURES 9 #endif #define ngx_buffer_init(b) b->pos = b->last = b->start; typedef struct { ngx_flag_t once; ngx_flag_t regex; ngx_flag_t insensitive; /* If it has captured variables? */ ngx_flag_t has_captured; ngx_str_t match; #if (NGX_PCRE) ngx_regex_t *match_regex; int *captures; ngx_int_t ncaptures; #endif ngx_str_t sub; ngx_array_t *sub_lengths; ngx_array_t *sub_values; unsigned matched; } sub_pair_t; typedef struct { ngx_hash_t types; ngx_array_t *sub_pairs; /* array of sub_pair_t */ ngx_array_t *types_keys; /* array of ngx_hash_key_t */ ngx_array_t *bypass; /* array of ngx_http_complex_value_t */ size_t line_buffer_size; ngx_bufs_t bufs; } ngx_http_subs_loc_conf_t; typedef struct { ngx_array_t *sub_pairs; /* array of sub_pair_t */ ngx_chain_t *in; /* the line input buffer before substitution */ ngx_buf_t *line_in; /* the line destination buffer after substitution */ ngx_buf_t *line_dst; /* the last output buffer */ ngx_buf_t *out_buf; /* point to the last output chain's next chain */ ngx_chain_t **last_out; ngx_chain_t *out; ngx_chain_t *busy; /* the freed chain buffers. */ ngx_chain_t *free; ngx_int_t bufs; unsigned last; } ngx_http_subs_ctx_t; static ngx_int_t ngx_http_subs_header_filter(ngx_http_request_t *r); static ngx_int_t ngx_http_subs_init_context(ngx_http_request_t *r); static ngx_int_t ngx_http_subs_body_filter(ngx_http_request_t *r, ngx_chain_t *in); static ngx_int_t ngx_http_subs_body_filter_init_context(ngx_http_request_t *r, ngx_chain_t *in); static ngx_int_t ngx_http_subs_body_filter_process_buffer(ngx_http_request_t *r, ngx_buf_t *b); static ngx_int_t ngx_http_subs_match(ngx_http_request_t *r, ngx_http_subs_ctx_t *ctx); #if (NGX_PCRE) static ngx_int_t ngx_http_subs_match_regex_substituion(ngx_http_request_t *r, sub_pair_t *pair, ngx_buf_t *b, ngx_buf_t *dst); #endif static ngx_int_t ngx_http_subs_match_fix_substituion(ngx_http_request_t *r, sub_pair_t *pair, ngx_buf_t *b, ngx_buf_t *dst); static ngx_buf_t * buffer_append_string(ngx_buf_t *b, u_char *s, size_t len, ngx_pool_t *pool); static ngx_int_t ngx_http_subs_out_chain_append(ngx_http_request_t *r, ngx_http_subs_ctx_t *ctx, ngx_buf_t *b); static ngx_int_t ngx_http_subs_get_chain_buf(ngx_http_request_t *r, ngx_http_subs_ctx_t *ctx); static ngx_int_t ngx_http_subs_output(ngx_http_request_t *r, ngx_http_subs_ctx_t *ctx, ngx_chain_t *in); static char * ngx_http_subs_filter(ngx_conf_t *cf, ngx_command_t *cmd, void *conf); static ngx_int_t ngx_http_subs_filter_regex_compile(sub_pair_t *pair, ngx_http_script_compile_t *sc, ngx_conf_t *cf); static void *ngx_http_subs_create_conf(ngx_conf_t *cf); static char *ngx_http_subs_merge_conf(ngx_conf_t *cf, void *parent, void *child); static ngx_int_t ngx_http_subs_filter_init(ngx_conf_t *cf); #if (NGX_PCRE) static ngx_int_t ngx_http_subs_regex_capture_count(ngx_regex_t *re); #endif static ngx_command_t ngx_http_subs_filter_commands[] = { { ngx_string("subs_filter"), NGX_HTTP_MAIN_CONF|NGX_HTTP_SRV_CONF|NGX_HTTP_LOC_CONF|NGX_CONF_2MORE, ngx_http_subs_filter, NGX_HTTP_LOC_CONF_OFFSET, 0, NULL }, { ngx_string("subs_filter_bypass"), NGX_HTTP_MAIN_CONF|NGX_HTTP_SRV_CONF|NGX_HTTP_LOC_CONF|NGX_CONF_1MORE, ngx_http_set_predicate_slot, NGX_HTTP_LOC_CONF_OFFSET, offsetof(ngx_http_subs_loc_conf_t, bypass), NULL }, { ngx_string("subs_filter_types"), NGX_HTTP_MAIN_CONF|NGX_HTTP_SRV_CONF|NGX_HTTP_LOC_CONF|NGX_CONF_1MORE, ngx_http_types_slot, NGX_HTTP_LOC_CONF_OFFSET, offsetof(ngx_http_subs_loc_conf_t, types_keys), &ngx_http_html_default_types[0] }, { ngx_string("subs_line_buffer_size"), NGX_HTTP_MAIN_CONF|NGX_HTTP_SRV_CONF|NGX_HTTP_LOC_CONF|NGX_CONF_TAKE2, ngx_conf_set_size_slot, NGX_HTTP_LOC_CONF_OFFSET, offsetof(ngx_http_subs_loc_conf_t, line_buffer_size), NULL }, { ngx_string("subs_buffers"), NGX_HTTP_MAIN_CONF|NGX_HTTP_SRV_CONF|NGX_HTTP_LOC_CONF|NGX_CONF_TAKE2, ngx_conf_set_bufs_slot, NGX_HTTP_LOC_CONF_OFFSET, offsetof(ngx_http_subs_loc_conf_t, bufs), NULL }, ngx_null_command }; static ngx_http_module_t ngx_http_subs_filter_module_ctx = { NULL, /* preconfiguration */ ngx_http_subs_filter_init, /* postconfiguration */ NULL, /* create main configuration */ NULL, /* init main configuration */ NULL, /* create server configuration */ NULL, /* merge server configuration */ ngx_http_subs_create_conf, /* create location configuration */ ngx_http_subs_merge_conf /* merge location configuration */ }; ngx_module_t ngx_http_subs_filter_module = { NGX_MODULE_V1, &ngx_http_subs_filter_module_ctx, /* module context */ ngx_http_subs_filter_commands, /* module directives */ NGX_HTTP_MODULE, /* module type */ NULL, /* init master */ NULL, /* init module */ NULL, /* init process */ NULL, /* init thread */ NULL, /* exit thread */ NULL, /* exit process */ NULL, /* exit master */ NGX_MODULE_V1_PADDING }; static ngx_http_output_header_filter_pt ngx_http_next_header_filter; static ngx_http_output_body_filter_pt ngx_http_next_body_filter; extern volatile ngx_cycle_t *ngx_cycle; static ngx_int_t ngx_http_subs_header_filter(ngx_http_request_t *r) { ngx_http_subs_loc_conf_t *slcf; slcf = ngx_http_get_module_loc_conf(r, ngx_http_subs_filter_module); if (slcf->sub_pairs->nelts == 0 || r->header_only || r->headers_out.content_type.len == 0 || r->headers_out.content_length_n == 0) { return ngx_http_next_header_filter(r); } if (ngx_http_test_content_type(r, &slcf->types) == NULL) { return ngx_http_next_header_filter(r); } switch (ngx_http_test_predicates(r, slcf->bypass)) { case NGX_ERROR: /*pass through*/ case NGX_DECLINED: return ngx_http_next_header_filter(r); default: /* NGX_OK */ break; } /* Don't do substitution with the compressed content */ if (r->headers_out.content_encoding && r->headers_out.content_encoding->value.len) { ngx_log_error(NGX_LOG_WARN, r->connection->log, 0, "http subs filter header ignored, this may be a " "compressed response."); return ngx_http_next_header_filter(r); } ngx_log_debug1(NGX_LOG_DEBUG_HTTP, r->connection->log, 0, "http subs filter header \"%V\"", &r->uri); if (ngx_http_subs_init_context(r) == NGX_ERROR) { return NGX_ERROR; } r->filter_need_in_memory = 1; if (r == r->main) { ngx_http_clear_content_length(r); ngx_http_clear_last_modified(r); } return ngx_http_next_header_filter(r); } static ngx_int_t ngx_http_subs_init_context(ngx_http_request_t *r) { ngx_uint_t i; sub_pair_t *src_pair, *dst_pair; ngx_http_subs_ctx_t *ctx; ngx_http_subs_loc_conf_t *slcf; slcf = ngx_http_get_module_loc_conf(r, ngx_http_subs_filter_module); /* Everything in ctx is NULL or 0. */ ctx = ngx_pcalloc(r->pool, sizeof(ngx_http_subs_ctx_t)); if (ctx == NULL) { return NGX_ERROR; } ngx_http_set_ctx(r, ctx, ngx_http_subs_filter_module); ctx->sub_pairs = ngx_array_create(r->pool, slcf->sub_pairs->nelts, sizeof(sub_pair_t)); if (slcf->sub_pairs == NULL) { return NGX_ERROR; } /* Deep copy sub_pairs from slcf to ctx, matched and captures need it */ src_pair = (sub_pair_t *) slcf->sub_pairs->elts; for (i = 0; i < slcf->sub_pairs->nelts; i++) { dst_pair = ngx_array_push(ctx->sub_pairs); if (dst_pair == NULL) { return NGX_ERROR; } ngx_memcpy(dst_pair, src_pair + i, sizeof(sub_pair_t)); } if (ctx->line_in == NULL) { ctx->line_in = ngx_create_temp_buf(r->pool, slcf->line_buffer_size); if (ctx->line_in == NULL) { return NGX_ERROR; } } if (ctx->line_dst == NULL) { ctx->line_dst = ngx_create_temp_buf(r->pool, slcf->line_buffer_size); if (ctx->line_dst == NULL) { return NGX_ERROR; } } return NGX_OK; } static ngx_int_t ngx_http_subs_body_filter(ngx_http_request_t *r, ngx_chain_t *in) { ngx_int_t rc; ngx_log_t *log; ngx_chain_t *cl, *temp; ngx_http_subs_ctx_t *ctx; ngx_http_subs_loc_conf_t *slcf; log = r->connection->log; slcf = ngx_http_get_module_loc_conf(r, ngx_http_subs_filter_module); if (slcf == NULL) { return ngx_http_next_body_filter(r, in); } ctx = ngx_http_get_module_ctx(r, ngx_http_subs_filter_module); if (ctx == NULL) { return ngx_http_next_body_filter(r, in); } ngx_log_debug1(NGX_LOG_DEBUG_HTTP, log, 0, "http subs filter \"%V\"", &r->uri); if (in == NULL && ctx->busy == NULL) { return ngx_http_next_body_filter(r, in); } if (ngx_http_subs_body_filter_init_context(r, in) != NGX_OK){ goto failed; } for (cl = ctx->in; cl; cl = cl->next) { if (cl->buf->last_buf || cl->buf->last_in_chain){ ctx->last = 1; } /* TODO: check the flush flag */ rc = ngx_http_subs_body_filter_process_buffer(r, cl->buf); if (rc == NGX_DECLINED) { continue; } else if (rc == NGX_ERROR) { goto failed; } if (cl->next != NULL) { continue; } if (ctx->last) { /* copy line_in to ctx->out. */ if (ngx_buf_size(ctx->line_in) > 0) { ngx_log_debug0(NGX_LOG_DEBUG_HTTP, log, 0, "[subs_filter] Lost last linefeed, output anyway."); if (ngx_http_subs_out_chain_append(r, ctx, ctx->line_in) != NGX_OK) { goto failed; } } if (ctx->out_buf == NULL) { ngx_log_debug0(NGX_LOG_DEBUG_HTTP, log, 0, "[subs_filter] The last buffer is zero size."); /* * This is a zero buffer, it should not be set the temporary * or memory flag * */ ctx->out_buf = ngx_calloc_buf(r->pool); if (ctx->out_buf == NULL) { goto failed; } ctx->out_buf->sync = 1; temp = ngx_alloc_chain_link(r->pool); if (temp == NULL) { goto failed; } temp->buf = ctx->out_buf; temp->next = NULL; *ctx->last_out = temp; ctx->last_out = &temp->next; } ctx->out_buf->last_buf = (r == r->main) ? 1 : 0; ctx->out_buf->last_in_chain = cl->buf->last_in_chain; break; } } /* It doesn't output anything, return */ if ((ctx->out == NULL) && (ctx->busy == NULL)) { return NGX_OK; } return ngx_http_subs_output(r, ctx, in); failed: ngx_log_error(NGX_LOG_ERR, log, 0, "[subs_filter] ngx_http_subs_body_filter error."); return NGX_ERROR; } static ngx_int_t ngx_http_subs_body_filter_init_context(ngx_http_request_t *r, ngx_chain_t *in) { ngx_http_subs_ctx_t *ctx; ctx = ngx_http_get_module_ctx(r, ngx_http_subs_filter_module); r->connection->buffered |= NGX_HTTP_SUB_BUFFERED; ctx->in = NULL; if (in) { if (ngx_chain_add_copy(r->pool, &ctx->in, in) != NGX_OK) { return NGX_ERROR; } } #if SUBS_DEBUG if (ngx_buf_size(ctx->line_in) > 0) { ngx_log_debug2(NGX_LOG_DEBUG_HTTP, r->connection->log, 0, "subs line in buffer: %p, size:%uz", ctx->line_in, ngx_buf_size(ctx->line_in)); } #endif #if SUBS_DEBUG ngx_chain_t *cl; for (cl = ctx->in; cl; cl = cl->next) { if (cl->buf) { ngx_log_debug4(NGX_LOG_DEBUG_HTTP, r->connection->log, 0, "subs in buffer:%p, size:%uz, " "flush:%d, last_buf:%d", cl->buf, ngx_buf_size(cl->buf), cl->buf->flush, cl->buf->last_buf); } } #endif ctx->last_out = &ctx->out; ctx->out_buf = NULL; return NGX_OK; } static ngx_int_t ngx_http_subs_body_filter_process_buffer(ngx_http_request_t *r, ngx_buf_t *b) { u_char *p, *last, *linefeed; ngx_int_t len, rc; ngx_http_subs_ctx_t *ctx; ctx = ngx_http_get_module_ctx(r, ngx_http_subs_filter_module); if (b == NULL) { return NGX_DECLINED; } p = b->pos; last = b->last; b->pos = b->last; ngx_log_debug4(NGX_LOG_DEBUG_HTTP, r->connection->log, 0, "subs process in buffer: %p %uz, line_in buffer: %p %uz", b, last - p, ctx->line_in, ngx_buf_size(ctx->line_in)); if ((last - p) == 0 && ngx_buf_size(ctx->line_in) == 0){ return NGX_OK; } if ((last - p) == 0 && ngx_buf_size(ctx->line_in) && ctx->last) { ngx_log_debug0(NGX_LOG_DEBUG_HTTP, r->connection->log, 0, "the last zero buffer, try to do substitution"); rc = ngx_http_subs_match(r, ctx); if (rc < 0) { return NGX_ERROR; } return NGX_OK; } while (p < last) { linefeed = memchr(p, LF, last - p); ngx_log_debug1(NGX_LOG_DEBUG_HTTP, r->connection->log, 0, "find linefeed: %p", linefeed); if (linefeed == NULL) { if (ctx->last) { linefeed = last - 1; ngx_log_debug0(NGX_LOG_DEBUG_HTTP, r->connection->log, 0, "the last buffer, not find linefeed"); } } if (linefeed) { len = linefeed - p + 1; if (buffer_append_string(ctx->line_in, p, len, r->pool) == NULL) { return NGX_ERROR; } p += len; rc = ngx_http_subs_match(r, ctx); if (rc < 0) { return NGX_ERROR; } } else { /* Not find linefeed in this chain, save the left data to line_in */ if (buffer_append_string(ctx->line_in, p, last - p, r->pool) == NULL) { return NGX_ERROR; } break; } } return NGX_OK; } /* * Do the substitutions from ctx->line_in * and output the chain buffers to ctx->out * */ static ngx_int_t ngx_http_subs_match(ngx_http_request_t *r, ngx_http_subs_ctx_t *ctx) { ngx_buf_t *src, *dst, *temp; ngx_log_t *log; ngx_int_t count, match_count; sub_pair_t *pairs, *pair; ngx_uint_t i; count = 0; match_count = 0; log = r->connection->log; src = ctx->line_in; dst = ctx->line_dst; pairs = (sub_pair_t *) ctx->sub_pairs->elts; for (i = 0; i < ctx->sub_pairs->nelts; i++) { pair = &pairs[i]; if (!pair->has_captured) { if (pair->sub.data == NULL) { if (ngx_http_script_run(r, &pair->sub, pair->sub_lengths->elts, 0, pair->sub_values->elts) == NULL) { goto failed; } } } else { pair->sub.data = NULL; pair->sub.len = 0; } /* exchange the src and dst buffer */ if (dst->pos != dst->last) { temp = src; src = dst; dst = temp; ngx_buffer_init(dst); } if ((!pair->regex) && ((ngx_uint_t)(src->last - src->pos) < pair->match.len)) { continue; } if (pair->once && pair->matched) { continue; } if (pair->sub.data == NULL && !pair->has_captured) { if (ngx_http_script_run(r, &pair->sub, pair->sub_lengths->elts, 0, pair->sub_values->elts) == NULL) { goto failed; } } /* regex substitution */ if (pair->regex || pair->insensitive) { #if (NGX_PCRE) count = ngx_http_subs_match_regex_substituion(r, pair, src, dst); if (count == NGX_ERROR) { goto failed; } #endif } else { /* fixed string substituion */ count = ngx_http_subs_match_fix_substituion(r, pair, src, dst); if (count == NGX_ERROR) { goto failed; } } /* no match. */ if (count == 0){ continue; } if (src->pos < src->last) { if (buffer_append_string(dst, src->pos, src->last - src->pos, r->pool) == NULL) { goto failed; } src->pos = src->last; } /* match */ match_count += count; } /* no match last time */ if (dst->pos == dst->last){ dst = src; } if (ngx_http_subs_out_chain_append(r, ctx, dst) != NGX_OK) { goto failed; } ngx_buffer_init(ctx->line_in); ngx_buffer_init(ctx->line_dst); ngx_log_debug1(NGX_LOG_DEBUG_HTTP, log, 0, "match counts: %i", match_count); return match_count; failed: ngx_log_error(NGX_LOG_ERR, log, 0, "[subs_filter] ngx_http_subs_match error."); return -1; } #if (NGX_PCRE) static ngx_int_t ngx_http_subs_match_regex_substituion(ngx_http_request_t *r, sub_pair_t *pair, ngx_buf_t *b, ngx_buf_t *dst) { ngx_str_t line; ngx_log_t *log; ngx_int_t rc, count = 0; log = r->connection->log; if (pair->captures == NULL || pair->ncaptures == 0) { pair->ncaptures = (NGX_HTTP_MAX_CAPTURES + 1) * 3; pair->captures = ngx_palloc(r->pool, pair->ncaptures * sizeof(int)); if (pair->captures == NULL) { return NGX_ERROR; } } while (b->pos < b->last) { if (pair->once && pair->matched) { break; } line.data = b->pos; line.len = b->last - b->pos; rc = ngx_regex_exec(pair->match_regex, &line, (int *) pair->captures, pair->ncaptures); if (rc == NGX_REGEX_NO_MATCHED) { break; } else if(rc < 0) { ngx_log_error(NGX_LOG_ERR, log, 0, ngx_regex_exec_n " failed: %i on \"%V\" using \"%V\"", rc, &line, &pair->match); return NGX_ERROR; } pair->matched++; count++; ngx_log_debug3(NGX_LOG_DEBUG_HTTP, log, 0, "regex match:%i, start:%d, end:%d ", rc, pair->captures[0], pair->captures[1]); if (pair->has_captured) { r->captures = pair->captures; r->ncaptures = pair->ncaptures; r->captures_data = line.data; if (ngx_http_script_run(r, &pair->sub, pair->sub_lengths->elts, 0, pair->sub_values->elts) == NULL) { ngx_log_error(NGX_LOG_ALERT, log, 0, "[subs_filter] ngx_http_script_run error."); return NGX_ERROR; } } if (buffer_append_string(dst, b->pos, pair->captures[0], r->pool) == NULL) { return NGX_ERROR; } if (buffer_append_string(dst, pair->sub.data, pair->sub.len, r->pool) == NULL) { return NGX_ERROR; } b->pos = b->pos + pair->captures[1]; } return count; } #endif /* * Thanks to Laurent Ghigonis * Taken from FreeBSD * Find the first occurrence of the byte string s in byte string l. */ static void * subs_memmem(const void *l, size_t l_len, const void *s, size_t s_len) { register char *cur, *last; const char *cl = (const char *)l; const char *cs = (const char *)s; /* we need something to compare */ if (l_len == 0 || s_len == 0) { return NULL; } /* "s" must be smaller or equal to "l" */ if (l_len < s_len) { return NULL; } /* special case where s_len == 1 */ if (s_len == 1) { return memchr(l, (int)*cs, l_len); } /* the last position where its possible to find "s" in "l" */ last = (char *)cl + l_len - s_len; for (cur = (char *)cl; cur <= last; cur++) { if (cur[0] == cs[0] && memcmp(cur, cs, s_len) == 0) { return cur; } } return NULL; } static ngx_int_t ngx_http_subs_match_fix_substituion(ngx_http_request_t *r, sub_pair_t *pair, ngx_buf_t *b, ngx_buf_t *dst) { u_char *sub_start; ngx_int_t count = 0; while(b->pos < b->last) { if (pair->once && pair->matched) { break; } sub_start = subs_memmem(b->pos, b->last - b->pos, pair->match.data, pair->match.len); if (sub_start == NULL) { break; } pair->matched++; count++; if (buffer_append_string(dst, b->pos, sub_start - b->pos, r->pool) == NULL) { return NGX_ERROR; } if (buffer_append_string(dst, pair->sub.data, pair->sub.len, r->pool) == NULL) { return NGX_ERROR; } ngx_log_debug1(NGX_LOG_DEBUG_HTTP, r->connection->log, 0, "fixed string match: %p", sub_start); b->pos = sub_start + pair->match.len; if ((ngx_uint_t)(b->last - b->pos) < pair->match.len) break; } return count; } static ngx_buf_t * buffer_append_string(ngx_buf_t *b, u_char *s, size_t len, ngx_pool_t *pool) { u_char *p; ngx_uint_t capacity, size; if (len > (size_t) (b->end - b->last)) { size = b->last - b->pos; capacity = b->end - b->start; capacity <<= 1; if (capacity < (size + len)) { capacity = size + len; } p = ngx_palloc(pool, capacity); if (p == NULL) { return NULL; } b->last = ngx_copy(p, b->pos, size); b->start = b->pos = p; b->end = p + capacity; } b->last = ngx_copy(b->last, s, len); return b; } static ngx_int_t ngx_http_subs_out_chain_append(ngx_http_request_t *r, ngx_http_subs_ctx_t *ctx, ngx_buf_t *b) { size_t len, capcity; if (b == NULL || ngx_buf_size(b) == 0) { return NGX_OK; } if (ctx->out_buf == NULL) { if (ngx_http_subs_get_chain_buf(r, ctx) != NGX_OK) { return NGX_ERROR; } } while (1) { len = (size_t) ngx_buf_size(b); if (len == 0) { break; } capcity = ctx->out_buf->end - ctx->out_buf->last; if (len <= capcity) { ctx->out_buf->last = ngx_copy(ctx->out_buf->last, b->pos, len); b->pos += len; break; } else { ctx->out_buf->last = ngx_copy(ctx->out_buf->last, b->pos, capcity); } b->pos += capcity; /* get more buffers */ if (ngx_http_subs_get_chain_buf(r, ctx) != NGX_OK) { return NGX_ERROR; } } return NGX_OK; } static ngx_int_t ngx_http_subs_get_chain_buf(ngx_http_request_t *r, ngx_http_subs_ctx_t *ctx) { ngx_chain_t *temp; ngx_http_subs_loc_conf_t *slcf; slcf = ngx_http_get_module_loc_conf(r, ngx_http_subs_filter_module); if (ctx->free) { temp = ctx->free; ctx->free = ctx->free->next; } else { temp = ngx_alloc_chain_link(r->pool); if (temp == NULL) { return NGX_ERROR; } temp->buf = ngx_create_temp_buf(r->pool, slcf->bufs.size); if (temp->buf == NULL) { return NGX_ERROR; } temp->buf->tag = (ngx_buf_tag_t) &ngx_http_subs_filter_module; temp->buf->recycled = 1; /* TODO: limit the buffer number */ ctx->bufs++; } temp->next = NULL; ctx->out_buf = temp->buf; *ctx->last_out = temp; ctx->last_out = &temp->next; return NGX_OK; } static ngx_int_t ngx_http_subs_output(ngx_http_request_t *r, ngx_http_subs_ctx_t *ctx, ngx_chain_t *in) { ngx_int_t rc; #if SUBS_DEBUG ngx_buf_t *b; ngx_chain_t *cl; for (cl = ctx->out; cl; cl = cl->next) { b = cl->buf; ngx_log_debug4(NGX_LOG_DEBUG_HTTP, r->connection->log, 0, "subs out buffer:%p, size:%uz, t:%d, l:%d", b, ngx_buf_size(b), b->temporary, b->last_buf); } #endif /* ctx->out may not output all the data */ rc = ngx_http_next_body_filter(r, ctx->out); if (rc == NGX_ERROR) { return NGX_ERROR; } #if SUBS_DEBUG for (cl = ctx->out; cl; cl = cl->next) { ngx_log_debug2(NGX_LOG_DEBUG_HTTP, r->connection->log, 0, "subs out end: %p %uz", cl->buf, ngx_buf_size(cl->buf)); } #endif #if defined(nginx_version) && (nginx_version >= 1001004) ngx_chain_update_chains(r->pool, &ctx->free, &ctx->busy, &ctx->out, (ngx_buf_tag_t) &ngx_http_subs_filter_module); #else ngx_chain_update_chains(&ctx->free, &ctx->busy, &ctx->out, (ngx_buf_tag_t) &ngx_http_subs_filter_module); #endif if (ctx->last) { r->connection->buffered &= ~NGX_HTTP_SUB_BUFFERED; } return rc; } static char * ngx_http_subs_filter( ngx_conf_t *cf, ngx_command_t *cmd, void *conf) { ngx_int_t n; ngx_uint_t i; ngx_str_t *value; ngx_str_t *option; sub_pair_t *pair; ngx_http_subs_loc_conf_t *slcf = conf; ngx_http_script_compile_t sc; value = cf->args->elts; if (slcf->sub_pairs == NULL) { slcf->sub_pairs = ngx_array_create(cf->pool, 4, sizeof(sub_pair_t)); if (slcf->sub_pairs == NULL) { return NGX_CONF_ERROR; } } pair = ngx_array_push(slcf->sub_pairs); if (pair == NULL) { return NGX_CONF_ERROR; } ngx_memzero(pair, sizeof(sub_pair_t)); pair->match = value[1]; n = ngx_http_script_variables_count(&value[2]); if (n != 0) { ngx_memzero(&sc, sizeof(ngx_http_script_compile_t)); sc.cf = cf; sc.source = &value[2]; sc.lengths = &pair->sub_lengths; sc.values = &pair->sub_values; sc.variables = n; sc.complete_lengths = 1; sc.complete_values = 1; if (ngx_http_script_compile(&sc) != NGX_OK) { return NGX_CONF_ERROR; } /* Dirty hack, if it has captured variables */ if (sc.captures_mask) { pair->has_captured = 1; } } else { pair->sub = value[2]; } if (cf->args->nelts > 3) { option = &value[3]; for(i = 0; i < option->len; i++) { switch (option->data[i]){ case 'i': pair->insensitive = 1; break; case 'o': pair->once = 1; break; case 'r': pair->regex = 1; break; case 'g': default: continue; } } } if (pair->regex || pair->insensitive) { if (ngx_http_subs_filter_regex_compile(pair, &sc, cf) == NGX_ERROR) { return NGX_CONF_ERROR; } } return NGX_CONF_OK; } static ngx_int_t ngx_http_subs_filter_regex_compile(sub_pair_t *pair, ngx_http_script_compile_t *sc, ngx_conf_t *cf) { /* Caseless match can only be implemented in regex. */ #if (NGX_PCRE) u_char errstr[NGX_MAX_CONF_ERRSTR]; ngx_int_t n, options; ngx_str_t err, *value; ngx_uint_t mask; value = cf->args->elts; err.len = NGX_MAX_CONF_ERRSTR; err.data = errstr; options = (pair->insensitive ? NGX_REGEX_CASELESS : 0); /* make nginx-0.8.25+ happy */ #if defined(nginx_version) && nginx_version >= 8025 ngx_regex_compile_t rc; rc.pattern = pair->match; rc.pool = cf->pool; rc.err = err; rc.options = options; if (ngx_regex_compile(&rc) != NGX_OK) { ngx_conf_log_error(NGX_LOG_EMERG, cf, 0, "%V", &rc.err); return NGX_ERROR; } pair->match_regex = rc.regex; #else pair->match_regex = ngx_regex_compile(&pair->match, options, cf->pool, &err); #endif if (pair->match_regex == NULL) { ngx_conf_log_error(NGX_LOG_EMERG, cf, 0, "%V", &err); return NGX_ERROR; } n = ngx_http_subs_regex_capture_count(pair->match_regex); if (pair->has_captured) { mask = ((1 << (n + 1)) - 1); if ( mask < sc->captures_mask ) { ngx_conf_log_error(NGX_LOG_EMERG, cf, 0, "You want to capture too many regex substrings, " "more than %i in \"%V\"", n, &value[2]); return NGX_ERROR; } } #else ngx_conf_log_error(NGX_LOG_EMERG, cf, 0, "the using of the regex \"%V\" requires PCRE library", &pair->match); return NGX_ERROR; #endif return NGX_OK; } #if (NGX_PCRE) static ngx_int_t ngx_http_subs_regex_capture_count(ngx_regex_t *re) { int rc, n; n = 0; #if defined(nginx_version) && nginx_version >= 1002002 rc = pcre_fullinfo(re->code, NULL, PCRE_INFO_CAPTURECOUNT, &n); #elif defined(nginx_version) && nginx_version >= 1001012 rc = pcre_fullinfo(re->pcre, NULL, PCRE_INFO_CAPTURECOUNT, &n); #else rc = pcre_fullinfo(re, NULL, PCRE_INFO_CAPTURECOUNT, &n); #endif if (rc < 0) { return (ngx_int_t) rc; } return (ngx_int_t) n; } #endif static void * ngx_http_subs_create_conf(ngx_conf_t *cf) { ngx_http_subs_loc_conf_t *conf; conf = ngx_pcalloc(cf->pool, sizeof(ngx_http_subs_loc_conf_t)); if (conf == NULL) { return NGX_CONF_ERROR; } /* * set by ngx_pcalloc(): * * conf->sub_pairs = NULL; * conf->types = {NULL, 0}; * conf->types_keys = NULL; * conf->bufs.num = 0; */ conf->line_buffer_size = NGX_CONF_UNSET_SIZE; conf->bypass = NGX_CONF_UNSET_PTR; return conf; } static char * ngx_http_subs_merge_conf(ngx_conf_t *cf, void *parent, void *child) { ngx_http_subs_loc_conf_t *prev = parent; ngx_http_subs_loc_conf_t *conf = child; if (conf->sub_pairs == NULL) { if (prev->sub_pairs == NULL) { conf->sub_pairs = ngx_array_create(cf->pool, 4, sizeof(sub_pair_t)); if (conf->sub_pairs == NULL) { return NGX_CONF_ERROR; } } else { conf->sub_pairs = prev->sub_pairs; } } ngx_conf_merge_ptr_value(conf->bypass, prev->bypass, NULL); if (ngx_http_merge_types(cf, &conf->types_keys, &conf->types, &prev->types_keys, &prev->types, ngx_http_html_default_types) != NGX_OK) { return NGX_CONF_ERROR; } ngx_conf_merge_size_value(conf->line_buffer_size, prev->line_buffer_size, 8 * ngx_pagesize); /* Default total buffer size is 128k */ ngx_conf_merge_bufs_value(conf->bufs, prev->bufs, (128 * 1024) / ngx_pagesize, ngx_pagesize); return NGX_CONF_OK; } static ngx_int_t ngx_http_subs_filter_init(ngx_conf_t *cf) { ngx_http_next_header_filter = ngx_http_top_header_filter; ngx_http_top_header_filter = ngx_http_subs_header_filter; ngx_http_next_body_filter = ngx_http_top_body_filter; ngx_http_top_body_filter = ngx_http_subs_body_filter; return NGX_OK; } ngx_http_substitutions_filter_module-0.6.4/test/000077500000000000000000000000001227766254600223055ustar00rootroot00000000000000ngx_http_substitutions_filter_module-0.6.4/test/README000066400000000000000000000231731227766254600231730ustar00rootroot00000000000000NAME Test::Nginx - Testing modules for Nginx C module development DESCRIPTION This distribution provides two testing modules for Nginx C module development: * Test::Nginx::LWP * Test::Nginx::Socket All of them are based on Test::Base. Usually, Test::Nginx::Socket is preferred because it works on a much lower level and not that fault tolerant like Test::Nginx::LWP. 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 because Perl's LWP::UserAgent 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 etcproxy integration The default settings in etcproxy (https://github.com/chaoslawful/etcproxy) makes this small TCP proxy split the TCP packets into bytes and introduce 1 ms latency among them. There's usually various TCP chains that we can put etcproxy into, for example Test::Nginx <=> nginx $ ./etcproxy 1234 1984 Here we tell etcproxy to listen on port 1234 and to delegate all the TCP traffic to the port 1984, the default port that Test::Nginx makes nginx listen to. And then we tell Test::Nginx to test against the port 1234, where etcproxy listens on, rather than the port 1984 that nginx directly listens on: $ TEST_NGINX_CLIENT_PORT=1234 prove -r t/ Then the TCP chain now looks like this: Test::Nginx <=> etcproxy (1234) <=> nginx (1984) So etcproxy can effectively emulate extreme network conditions and exercise "unusual" code paths in your nginx server by your tests. In practice, *tons* of weird bugs can be captured by this setting. Even ourselves didn't expect that this simple approach is so effective. nginx <=> memcached We first start the memcached server daemon on port 11211: memcached -p 11211 -vv and then we another etcproxy instance to listen on port 11984 like this $ ./etcproxy 11984 11211 Then we tell our t/foo.t test script to connect to 11984 rather than 11211: # foo.t use Test::Nginx::Socket; repeat_each(1); plan tests => 2 * repeat_each() * blocks(); $ENV{TEST_NGINX_MEMCACHED_PORT} ||= 11211; # make this env take a default value run_tests(); __DATA__ === TEST 1: sanity --- config location /foo { set $memc_cmd set; set $memc_key foo; set $memc_value bar; memc_pass 127.0.0.1:$TEST_NGINX_MEMCACHED_PORT; } --- request GET /foo --- response_body_like: STORED The Test::Nginx library will automatically expand the special macro $TEST_NGINX_MEMCACHED_PORT to the environment with the same name. You can define your own $TEST_NGINX_BLAH_BLAH_PORT macros as long as its prefix is "TEST_NGINX_" and all in upper case letters. And now we can run your test script against the etcproxy port 11984: TEST_NGINX_MEMCACHED_PORT=11984 prove t/foo.t Then the TCP chains look like this: Test::Nginx <=> nginx (1984) <=> etcproxy (11984) <=> memcached (11211) If "TEST_NGINX_MEMCACHED_PORT" is not set, then it will take the default value 11211, which is what we want when there's no etcproxy configured: Test::Nginx <=> nginx (1984) <=> memcached (11211) This approach also works for proxied mysql and postgres traffic. Please see the live test suite of ngx_drizzle and ngx_postgres for more details. Usually we set both "TEST_NGINX_CLIENT_PORT" and "TEST_NGINX_MEMCACHED_PORT" (and etc) at the same time, effectively yielding the following chain: Test::Nginx <=> etcproxy (1234) <=> nginx (1984) <=> etcproxy (11984) <=> memcached (11211) as long as you run two separate etcproxy instances in two separate terminals. It's easy to verify if the traffic actually goes through your etcproxy server. Just check if the terminal running etcproxy emits outputs. By default, etcproxy always dump out the incoming and outgoing data to stdout/stderr. valgrind integration Test::Nginx has integrated support for valgrind () even though by default it does not bother running it with the tests because valgrind will significantly slow down the test sutie. First ensure that your valgrind executable visible in your PATH env. And then run your test suite with the "TEST_NGINX_USE_VALGRIND" env set to true: TEST_NGINX_USE_VALGRIND=1 prove -r t If you see false alarms, you do have a chance to skip them by defining a ./valgrind.suppress file at the root of your module source tree, as in This is the suppression file for ngx_drizzle. Test::Nginx will automatically use it to start nginx with valgrind memcheck if this file does exist at the expected location. If you do see a lot of "Connection refused" errors while running the tests this way, then you probably have a slow machine (or a very busy one) that the default waiting time is not sufficient for valgrind to start. You can define the sleep time to a larger value by setting the "TEST_NGINX_SLEEP" env: TEST_NGINX_SLEEP=1 prove -r t The time unit used here is "second". The default sleep setting just fits my ThinkPad ("Core2Duo T9600"). Applying the no-pool patch to your nginx core is recommended while running nginx with valgrind: The nginx memory pool can prevent valgrind from spotting lots of invalid memory reads/writes as well as certain double-free errors. We did find a lot more memory issues in many of our modules when we first introduced the no-pool patch in practice ;) There's also more advanced features in Test::Nginx that have never documented. I'd like to write more about them in the near future ;) Nginx C modules that use Test::Nginx to drive their test suites ngx_echo ngx_headers_more ngx_chunkin ngx_memc ngx_drizzle ngx_rds_json ngx_xss ngx_srcache ngx_lua ngx_set_misc ngx_array_var ngx_form_input ngx_iconv ngx_set_cconv ngx_postgres ngx_coolkit 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. AUTHORS agentzh (章亦春) "" Antoine BONAVITA "" COPYRIGHT & LICENSE Copyright (c) 2009-2011, Taobao Inc., Alibaba Group (). Copyright (c) 2009-2011, agentzh "". Copyright (c) 2011, 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 Taobao Inc. 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. SEE ALSO Test::Nginx::LWP, Test::Nginx::Socket, Test::Base. ngx_http_substitutions_filter_module-0.6.4/test/inc/000077500000000000000000000000001227766254600230565ustar00rootroot00000000000000ngx_http_substitutions_filter_module-0.6.4/test/inc/Module/000077500000000000000000000000001227766254600243035ustar00rootroot00000000000000ngx_http_substitutions_filter_module-0.6.4/test/inc/Module/AutoInstall.pm000066400000000000000000000542311227766254600271050ustar00rootroot00000000000000#line 1 package Module::AutoInstall; use strict; use Cwd (); use ExtUtils::MakeMaker (); use vars qw{$VERSION}; BEGIN { $VERSION = '1.03'; } # special map on pre-defined feature sets my %FeatureMap = ( '' => 'Core Features', # XXX: deprecated '-core' => 'Core Features', ); # various lexical flags my ( @Missing, @Existing, %DisabledTests, $UnderCPAN, $HasCPANPLUS ); my ( $Config, $CheckOnly, $SkipInstall, $AcceptDefault, $TestOnly, $AllDeps ); my ( $PostambleActions, $PostambleUsed ); # 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 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 =~ /^--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::cwd(); $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; 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 combatability 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 = _load($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 _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; print "*** Dependencies will be installed the next time you type '$Config::Config{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 @_; 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 ); while ( my ( $pkg, $ver ) = splice( @_, 0, 2 ) ) { # grep out those already installed if ( _version_cmp( _load($pkg), $ver ) >= 0 ) { push @installed, $pkg; } else { push @modules, $pkg, $ver; } } 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( _load($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"; } } 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$/; # pseudo-option $CPAN::Config->{$opt} = $arg; } 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 = $args{force} ? CPAN::Shell->force( install => $pkg ) : 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::cwd() ); 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( _load($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; # class/instance doesn't matter my $file = $mod; $file =~ s|::|/|g; $file .= '.pm'; local $@; return eval { require $file; $mod->VERSION } || ( $@ ? undef: 0 ); } # 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)" ); 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; return <<"END_MAKE"; config :: installdeps \t\$(NOECHO) \$(NOOP) checkdeps :: \t\$(PERL) $0 --checkdeps installdeps :: \t$PostambleActions END_MAKE } 1; __END__ #line 1071 ngx_http_substitutions_filter_module-0.6.4/test/inc/Module/Install.pm000066400000000000000000000301351227766254600262510ustar00rootroot00000000000000#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.005; 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.01'; # 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::cwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::cwd(); 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::cwd()) eq $base_path ) { delete $args{prefix}; } return $args{_self} if $args{_self}; $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( 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($subpath . '.pm'); my $in_pod = 0; foreach ( split //, $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; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _read { local *FH; open( FH, '<', $_[0] ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_NEW sub _read { local *FH; open( FH, "< $_[0]" ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_OLD 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; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _write { local *FH; open( FH, '>', $_[0] ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_NEW sub _write { local *FH; open( FH, "> $_[0]" ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_OLD # _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($_[0]) <=> _version($_[1]); } # 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 - 2011 Adam Kennedy. ngx_http_substitutions_filter_module-0.6.4/test/inc/Module/Install/000077500000000000000000000000001227766254600257115ustar00rootroot00000000000000ngx_http_substitutions_filter_module-0.6.4/test/inc/Module/Install/AutoInstall.pm000066400000000000000000000036321227766254600305120ustar00rootroot00000000000000#line 1 package Module::Install::AutoInstall; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.01'; @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 auto_install_now { my $self = shift; $self->auto_install(@_); Module::AutoInstall::do_install(); } 1; ngx_http_substitutions_filter_module-0.6.4/test/inc/Module/Install/Base.pm000066400000000000000000000021471227766254600271250ustar00rootroot00000000000000#line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '1.01'; } # 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 ngx_http_substitutions_filter_module-0.6.4/test/inc/Module/Install/Can.pm000066400000000000000000000033331227766254600267520ustar00rootroot00000000000000#line 1 package Module::Install::Can; use strict; use Config (); use File::Spec (); use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.01'; @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 ''; my $abs = File::Spec->catfile($dir, $_[1]); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } # can we locate a (the) C compiler sub can_cc { my $self = shift; 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 156 ngx_http_substitutions_filter_module-0.6.4/test/inc/Module/Install/Fetch.pm000066400000000000000000000046271227766254600273110ustar00rootroot00000000000000#line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.01'; @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; ngx_http_substitutions_filter_module-0.6.4/test/inc/Module/Install/Include.pm000066400000000000000000000010151227766254600276270ustar00rootroot00000000000000#line 1 package Module::Install::Include; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.01'; @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; ngx_http_substitutions_filter_module-0.6.4/test/inc/Module/Install/Makefile.pm000066400000000000000000000270321227766254600277700ustar00rootroot00000000000000#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.01'; @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-seperated 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 ) { # MakeMaker can complain about module versions that include # an underscore, even though its own version may contain one! # Hence the funny regexp to get rid of it. See RT #35800 # for details. my $v = $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/; $self->build_requires( 'ExtUtils::MakeMaker' => $v ); $self->configure_requires( 'ExtUtils::MakeMaker' => $v ); } 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.42 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.42 ); } # 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 $DB::single = 1; 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 541 ngx_http_substitutions_filter_module-0.6.4/test/inc/Module/Install/Metadata.pm000066400000000000000000000431231227766254600277720ustar00rootroot00000000000000#line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.01'; @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; unless ( @_ ) { warn "You MUST provide an explicit true/false value to dynamic_config\n"; return $self; } $self->{values}->{dynamic_config} = $_[0] ? 1 : 0; return 1; } 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 reall 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', apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1', artistic => 'http://opensource.org/licenses/artistic-license.php', artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php', lgpl => 'http://opensource.org/licenses/lgpl-license.php', lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php', lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html', 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, ); 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+([\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 hashs 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; ngx_http_substitutions_filter_module-0.6.4/test/inc/Module/Install/TestBase.pm000066400000000000000000000010331227766254600277560ustar00rootroot00000000000000#line 1 package Module::Install::TestBase; use strict; use warnings; use Module::Install::Base; use vars qw($VERSION @ISA); BEGIN { $VERSION = '0.60'; @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; =encoding utf8 #line 70 ngx_http_substitutions_filter_module-0.6.4/test/inc/Module/Install/Win32.pm000066400000000000000000000034031227766254600271510ustar00rootroot00000000000000#line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.01'; @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; ngx_http_substitutions_filter_module-0.6.4/test/inc/Module/Install/WriteAll.pm000066400000000000000000000023761227766254600300020ustar00rootroot00000000000000#line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.01'; @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; ngx_http_substitutions_filter_module-0.6.4/test/inc/Spiffy.pm000066400000000000000000000362311227766254600246610ustar00rootroot00000000000000#line 1 package Spiffy; use strict; use 5.006001; use warnings; use Carp; require Exporter; our $VERSION = '0.30'; 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}; $code .= sprintf $fragment, $field, $args->{-init}, ($field) x 4; } $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; __END__ #line 1066 ngx_http_substitutions_filter_module-0.6.4/test/inc/Test/000077500000000000000000000000001227766254600237755ustar00rootroot00000000000000ngx_http_substitutions_filter_module-0.6.4/test/inc/Test/Base.pm000066400000000000000000000430631227766254600252130ustar00rootroot00000000000000#line 1 package Test::Base; use 5.006001; use Spiffy 0.30 -Base; use Spiffy ':XXX'; our $VERSION = '0.60'; 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; } sub is($$;$) { (my ($self), @_) = find_my_self(@_); my ($actual, $expected, $name) = @_; local $Test::Builder::Level = $Test::Builder::Level + 1; 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 . "\n" . 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 @_ 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(@_); $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 $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; $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 { $spec = do { package main; no warnings 'once'; ; }; } 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 ); } __DATA__ =encoding utf8 #line 1374 ngx_http_substitutions_filter_module-0.6.4/test/inc/Test/Base/000077500000000000000000000000001227766254600246475ustar00rootroot00000000000000ngx_http_substitutions_filter_module-0.6.4/test/inc/Test/Base/Filter.pm000066400000000000000000000157661227766254600264510ustar00rootroot00000000000000#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"; } __DATA__ #line 636 ngx_http_substitutions_filter_module-0.6.4/test/inc/Test/Builder.pm000066400000000000000000000737651227766254600257430ustar00rootroot00000000000000#line 1 package Test::Builder; use 5.006; use strict; use warnings; our $VERSION = '0.92'; $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) BEGIN { if( $] < 5.008 ) { require Test::Builder::IO::Scalar; } } # Make Test::Builder thread-safe for ithreads. BEGIN { use Config; # Load threads::shared when threads are turned on. # 5.8.0's threads are so busted we no longer support them. if( $] >= 5.008001 && $Config{useithreads} && $INC{'threads.pm'} ) { require threads::shared; # Hack around YET ANOTHER threads::shared bug. It would # occassionally forget the contents of the variable when sharing it. # So we first copy the data, then share, then put our copy back. *share = sub (\[$@%]) { my $type = ref $_[0]; my $data; if( $type eq 'HASH' ) { %$data = %{ $_[0] }; } elsif( $type eq 'ARRAY' ) { @$data = @{ $_[0] }; } elsif( $type eq 'SCALAR' ) { $$data = ${ $_[0] }; } else { die( "Unknown type: " . $type ); } $_[0] = &threads::shared::share( $_[0] ); if( $type eq 'HASH' ) { %{ $_[0] } = %$data; } elsif( $type eq 'ARRAY' ) { @{ $_[0] } = @$data; } elsif( $type eq 'SCALAR' ) { ${ $_[0] } = $$data; } else { die( "Unknown type: " . $type ); } return $_[0]; }; } # 5.8.0's threads::shared is busted when threads are off # and earlier Perls just don't have that module at all. else { *share = sub { return $_[0] }; *lock = sub { 0 }; } } #line 117 my $Test = Test::Builder->new; sub new { my($class) = shift; $Test ||= $class->create; return $Test; } #line 139 sub create { my $class = shift; my $self = bless {}, $class; $self->reset; return $self; } #line 158 our $Level; sub reset { ## no critic (Subroutines::ProhibitBuiltinHomonyms) my($self) = @_; # 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->{Have_Plan} = 0; $self->{No_Plan} = 0; $self->{Have_Output_Plan} = 0; $self->{Original_Pid} = $$; share( $self->{Curr_Test} ); $self->{Curr_Test} = 0; $self->{Test_Results} = &share( [] ); $self->{Exported_To} = undef; $self->{Expected_Tests} = 0; $self->{Skip_All} = 0; $self->{Use_Nums} = 1; $self->{No_Header} = 0; $self->{No_Ending} = 0; $self->{Todo} = undef; $self->{Todo_Stack} = []; $self->{Start_Todo} = 0; $self->{Opened_Testhandles} = 0; $self->_dup_stdhandles; return; } #line 219 my %plan_cmds = ( no_plan => \&no_plan, skip_all => \&skip_all, tests => \&_plan_tests, ); sub plan { my( $self, $cmd, $arg ) = @_; return unless $cmd; local $Level = $Level + 1; $self->croak("You tried to plan twice") if $self->{Have_Plan}; if( my $method = $plan_cmds{$cmd} ) { local $Level = $Level + 1; $self->$method($arg); } else { my @args = grep { defined } ( $cmd, $arg ); $self->croak("plan() doesn't understand @args"); } return 1; } sub _plan_tests { my($self, $arg) = @_; if($arg) { local $Level = $Level + 1; return $self->expected_tests($arg); } elsif( !defined $arg ) { $self->croak("Got an undefined number of tests"); } else { $self->croak("You said to run 0 tests"); } return; } #line 275 sub expected_tests { my $self = shift; my($max) = @_; if(@_) { $self->croak("Number of tests must be a positive integer. You gave it '$max'") unless $max =~ /^\+?\d+$/; $self->{Expected_Tests} = $max; $self->{Have_Plan} = 1; $self->_output_plan($max) unless $self->no_header; } return $self->{Expected_Tests}; } #line 299 sub no_plan { my($self, $arg) = @_; $self->carp("no_plan takes no arguments") if $arg; $self->{No_Plan} = 1; $self->{Have_Plan} = 1; return 1; } #line 333 sub _output_plan { my($self, $max, $directive, $reason) = @_; $self->carp("The plan was already output") if $self->{Have_Output_Plan}; my $plan = "1..$max"; $plan .= " # $directive" if defined $directive; $plan .= " $reason" if defined $reason; $self->_print("$plan\n"); $self->{Have_Output_Plan} = 1; return; } #line 384 sub done_testing { my($self, $num_tests) = @_; # If done_testing() specified the number of tests, shut off no_plan. if( defined $num_tests ) { $self->{No_Plan} = 0; } else { $num_tests = $self->current_test; } if( $self->{Done_Testing} ) { my($file, $line) = @{$self->{Done_Testing}}[1,2]; $self->ok(0, "done_testing() was already called at $file line $line"); return; } $self->{Done_Testing} = [caller]; if( $self->expected_tests && $num_tests != $self->expected_tests ) { $self->ok(0, "planned to run @{[ $self->expected_tests ]} ". "but done_testing() expects $num_tests"); } else { $self->{Expected_Tests} = $num_tests; } $self->_output_plan($num_tests) unless $self->{Have_Output_Plan}; $self->{Have_Plan} = 1; return 1; } #line 429 sub has_plan { my $self = shift; return( $self->{Expected_Tests} ) if $self->{Expected_Tests}; return('no_plan') if $self->{No_Plan}; return(undef); } #line 446 sub skip_all { my( $self, $reason ) = @_; $self->{Skip_All} = 1; $self->_output_plan(0, "SKIP", $reason) unless $self->no_header; exit(0); } #line 468 sub exported_to { my( $self, $pack ) = @_; if( defined $pack ) { $self->{Exported_To} = $pack; } return $self->{Exported_To}; } #line 498 sub ok { my( $self, $test, $name ) = @_; # $test might contain an object which we don't want to accidentally # store, so we turn it into a boolean. $test = $test ? 1 : 0; lock $self->{Curr_Test}; $self->{Curr_Test}++; # In case $name is a string overloaded object, force it to stringify. $self->_unoverload_str( \$name ); $self->diag(<<"ERR") if defined $name and $name =~ /^[\d\s]+$/; You named your test '$name'. You shouldn't use numbers for your test names. Very confusing. ERR # Capture the value of $TODO for the rest of this ok() call # so it can more easily be found by other routines. my $todo = $self->todo(); my $in_todo = $self->in_todo; local $self->{Todo} = $todo if $in_todo; $self->_unoverload_str( \$todo ); my $out; my $result = &share( {} ); unless($test) { $out .= "not "; @$result{ 'ok', 'actual_ok' } = ( ( $self->in_todo ? 1 : 0 ), 0 ); } else { @$result{ 'ok', 'actual_ok' } = ( 1, $test ); } $out .= "ok"; $out .= " $self->{Curr_Test}" if $self->use_numbers; if( defined $name ) { $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness. $out .= " - $name"; $result->{name} = $name; } else { $result->{name} = ''; } if( $self->in_todo ) { $out .= " # TODO $todo"; $result->{reason} = $todo; $result->{type} = 'todo'; } else { $result->{reason} = ''; $result->{type} = ''; } $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = $result; $out .= "\n"; $self->_print($out); unless($test) { my $msg = $self->in_todo ? "Failed (TODO)" : "Failed"; $self->_print_to_fh( $self->_diag_fh, "\n" ) if $ENV{HARNESS_ACTIVE}; my( undef, $file, $line ) = $self->caller; if( defined $name ) { $self->diag(qq[ $msg test '$name'\n]); $self->diag(qq[ at $file line $line.\n]); } else { $self->diag(qq[ $msg test at $file line $line.\n]); } } return $test ? 1 : 0; } sub _unoverload { my $self = shift; my $type = shift; $self->_try(sub { require overload; }, die_on_fail => 1); foreach my $thing (@_) { if( $self->_is_object($$thing) ) { if( my $string_meth = overload::Method( $$thing, $type ) ) { $$thing = $$thing->$string_meth(); } } } return; } sub _is_object { my( $self, $thing ) = @_; return $self->_try( sub { ref $thing && $thing->isa('UNIVERSAL') } ) ? 1 : 0; } sub _unoverload_str { my $self = shift; return $self->_unoverload( q[""], @_ ); } sub _unoverload_num { my $self = shift; $self->_unoverload( '0+', @_ ); for my $val (@_) { next unless $self->_is_dualvar($$val); $$val = $$val + 0; } return; } # 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; } #line 649 sub is_eq { my( $self, $got, $expect, $name ) = @_; local $Level = $Level + 1; $self->_unoverload_str( \$got, \$expect ); 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; return $test; } return $self->cmp_ok( $got, 'eq', $expect, $name ); } sub is_num { my( $self, $got, $expect, $name ) = @_; local $Level = $Level + 1; $self->_unoverload_num( \$got, \$expect ); 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; return $test; } return $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 } #line 746 sub isnt_eq { my( $self, $got, $dont_expect, $name ) = @_; 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; return $test; } return $self->cmp_ok( $got, 'ne', $dont_expect, $name ); } sub isnt_num { my( $self, $got, $dont_expect, $name ) = @_; 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; return $test; } return $self->cmp_ok( $got, '!=', $dont_expect, $name ); } #line 797 sub like { my( $self, $this, $regex, $name ) = @_; local $Level = $Level + 1; return $self->_regex_ok( $this, $regex, '=~', $name ); } sub unlike { my( $self, $this, $regex, $name ) = @_; local $Level = $Level + 1; return $self->_regex_ok( $this, $regex, '!~', $name ); } #line 821 my %numeric_cmps = map { ( $_, 1 ) } ( "<", "<=", ">", ">=", "==", "!=", "<=>" ); sub cmp_ok { my( $self, $got, $type, $expect, $name ) = @_; my $test; my $error; { ## no critic (BuiltinFunctions::ProhibitStringyEval) local( $@, $!, $SIG{__DIE__} ); # isolate eval my($pack, $file, $line) = $self->caller(); $test = eval qq[ #line 1 "cmp_ok [from $file line $line]" \$got $type \$expect; ]; $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") if $error; 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|!=)$/ ) { $self->_isnt_diag( $got, $type ); } else { $self->_cmp_diag( $got, $type, $expect ); } } return $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; } #line 920 sub BAIL_OUT { my( $self, $reason ) = @_; $self->{Bailed_Out} = 1; $self->_print("Bail out! $reason"); exit 255; } #line 933 *BAILOUT = \&BAIL_OUT; #line 944 sub skip { my( $self, $why ) = @_; $why ||= ''; $self->_unoverload_str( \$why ); lock( $self->{Curr_Test} ); $self->{Curr_Test}++; $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share( { 'ok' => 1, actual_ok => 1, name => '', type => 'skip', reason => $why, } ); my $out = "ok"; $out .= " $self->{Curr_Test}" if $self->use_numbers; $out .= " # skip"; $out .= " $why" if length $why; $out .= "\n"; $self->_print($out); return 1; } #line 985 sub todo_skip { my( $self, $why ) = @_; $why ||= ''; lock( $self->{Curr_Test} ); $self->{Curr_Test}++; $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share( { 'ok' => 1, actual_ok => 0, name => '', type => 'todo_skip', reason => $why, } ); my $out = "not ok"; $out .= " $self->{Curr_Test}" if $self->use_numbers; $out .= " # TODO & SKIP $why\n"; $self->_print($out); return 1; } #line 1062 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, $this, $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; } { ## no critic (BuiltinFunctions::ProhibitStringyEval) my $test; my $code = $self->_caller_context; local( $@, $!, $SIG{__DIE__} ); # isolate eval # Yes, it has to look like this or 5.4.5 won't see the #line # directive. # Don't ask me, man, I just work here. $test = eval " $code" . q{$test = $this =~ /$usable_regex/ ? 1 : 0}; $test = !$test if $cmp eq '!~'; local $Level = $Level + 1; $ok = $self->ok( $test, $name ); } unless($ok) { $this = defined $this ? "'$this'" : 'undef'; my $match = $cmp eq '=~' ? "doesn't match" : "matches"; local $Level = $Level + 1; $self->diag( sprintf <<'DIAGNOSTIC', $this, $match, $regex ); %s %13s '%s' DIAGNOSTIC } return $ok; } # I'm not ready to publish this. It doesn't deal with array return # values from the code or context. #line 1162 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; } #line 1191 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") } || # 5.5.4's tied() and can() doesn't like getting undef eval { ( tied($maybe_fh) || '' )->can('TIEHANDLE') }; } #line 1235 sub level { my( $self, $level ) = @_; if( defined $level ) { $Level = $level; } return $Level; } #line 1267 sub use_numbers { my( $self, $use_nums ) = @_; if( defined $use_nums ) { $self->{Use_Nums} = $use_nums; } return $self->{Use_Nums}; } #line 1300 foreach my $attribute (qw(No_Header No_Ending No_Diag)) { my $method = lc $attribute; my $code = sub { my( $self, $no ) = @_; if( defined $no ) { $self->{$attribute} = $no; } return $self->{$attribute}; }; no strict 'refs'; ## no critic *{ __PACKAGE__ . '::' . $method } = $code; } #line 1353 sub diag { my $self = shift; $self->_print_comment( $self->_diag_fh, @_ ); } #line 1368 sub note { my $self = shift; $self->_print_comment( $self->output, @_ ); } sub _diag_fh { my $self = shift; local $Level = $Level + 1; return $self->in_todo ? $self->todo_output : $self->failure_output; } 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 $Level = $Level + 1; $self->_print_to_fh( $fh, $msg ); return 0; } #line 1418 sub explain { my $self = shift; return map { ref $_ ? do { $self->_try(sub { require Data::Dumper }, die_on_fail => 1); my $dumper = Data::Dumper->new( [$_] ); $dumper->Indent(1)->Terse(1); $dumper->Sortkeys(1) if $dumper->can("Sortkeys"); $dumper->Dump; } : $_ } @_; } #line 1447 sub _print { my $self = shift; return $self->_print_to_fh( $self->output, @_ ); } sub _print_to_fh { my( $self, $fh, @msgs ) = @_; # Prevent printing headers when only compiling. Mostly for when # tests are deparsed with B::Deparse return if $^C; my $msg = join '', @msgs; local( $\, $", $, ) = ( undef, ' ', '' ); # Escape each line after the first with a # so we don't # confuse Test::Harness. $msg =~ s{\n(?!\z)}{\n# }sg; # Stick a newline on the end if it needs it. $msg .= "\n" unless $msg =~ /\n\z/; return print $fh $msg; } #line 1506 sub output { my( $self, $fh ) = @_; if( defined $fh ) { $self->{Out_FH} = $self->_new_fh($fh); } return $self->{Out_FH}; } sub failure_output { my( $self, $fh ) = @_; if( defined $fh ) { $self->{Fail_FH} = $self->_new_fh($fh); } return $self->{Fail_FH}; } sub todo_output { my( $self, $fh ) = @_; if( defined $fh ) { $self->{Todo_FH} = $self->_new_fh($fh); } return $self->{Todo_FH}; } 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; } my( $Testout, $Testerr ); sub _dup_stdhandles { my $self = shift; $self->_open_testhandles; # Set everything to unbuffered else plain prints to STDOUT will # come out in the wrong order from our own prints. _autoflush($Testout); _autoflush( \*STDOUT ); _autoflush($Testerr); _autoflush( \*STDERR ); $self->reset_outputs; return; } sub _open_testhandles { my $self = shift; return if $self->{Opened_Testhandles}; # We dup STDOUT and STDERR so people can change them in their # test suites while still getting normal test output. open( $Testout, ">&STDOUT" ) or die "Can't dup STDOUT: $!"; open( $Testerr, ">&STDERR" ) or die "Can't dup STDERR: $!"; # $self->_copy_io_layers( \*STDOUT, $Testout ); # $self->_copy_io_layers( \*STDERR, $Testerr ); $self->{Opened_Testhandles} = 1; return; } sub _copy_io_layers { my( $self, $src, $dst ) = @_; $self->_try( sub { require PerlIO; my @src_layers = PerlIO::get_layers($src); binmode $dst, join " ", map ":$_", @src_layers if @src_layers; } ); return; } #line 1631 sub reset_outputs { my $self = shift; $self->output ($Testout); $self->failure_output($Testerr); $self->todo_output ($Testout); return; } #line 1657 sub _message_at_caller { my $self = shift; local $Level = $Level + 1; my( $pack, $file, $line ) = $self->caller; return join( "", @_ ) . " at $file line $line.\n"; } sub carp { my $self = shift; return warn $self->_message_at_caller(@_); } sub croak { my $self = shift; return die $self->_message_at_caller(@_); } #line 1697 sub current_test { my( $self, $num ) = @_; lock( $self->{Curr_Test} ); if( defined $num ) { $self->{Curr_Test} = $num; # If the test counter is being pushed forward fill in the details. my $test_results = $self->{Test_Results}; if( $num > @$test_results ) { my $start = @$test_results ? @$test_results : 0; for( $start .. $num - 1 ) { $test_results->[$_] = &share( { '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 $self->{Curr_Test}; } #line 1739 sub summary { my($self) = shift; return map { $_->{'ok'} } @{ $self->{Test_Results} }; } #line 1794 sub details { my $self = shift; return @{ $self->{Test_Results} }; } #line 1823 sub todo { my( $self, $pack ) = @_; return $self->{Todo} if defined $self->{Todo}; local $Level = $Level + 1; my $todo = $self->find_TODO($pack); return $todo if defined $todo; return ''; } #line 1845 sub find_TODO { my( $self, $pack ) = @_; $pack = $pack || $self->caller(1) || $self->exported_to; return unless $pack; no strict 'refs'; ## no critic return ${ $pack . '::TODO' }; } #line 1863 sub in_todo { my $self = shift; local $Level = $Level + 1; return( defined $self->{Todo} || $self->find_TODO ) ? 1 : 0; } #line 1913 sub todo_start { my $self = shift; my $message = @_ ? shift : ''; $self->{Start_Todo}++; if( $self->in_todo ) { push @{ $self->{Todo_Stack} } => $self->todo; } $self->{Todo} = $message; return; } #line 1935 sub todo_end { my $self = shift; if( !$self->{Start_Todo} ) { $self->croak('todo_end() called without todo_start()'); } $self->{Start_Todo}--; if( $self->{Start_Todo} && @{ $self->{Todo_Stack} } ) { $self->{Todo} = pop @{ $self->{Todo_Stack} }; } else { delete $self->{Todo}; } return; } #line 1968 sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms) my( $self, $height ) = @_; $height ||= 0; my $level = $self->level + $height + 1; my @caller; do { @caller = CORE::caller( $level ); $level--; } until @caller; return wantarray ? @caller : $caller[0]; } #line 1985 #line 1999 #'# sub _sanity_check { my $self = shift; $self->_whoa( $self->{Curr_Test} < 0, 'Says here you ran a negative number of tests!' ); $self->_whoa( $self->{Curr_Test} != @{ $self->{Test_Results} }, 'Somehow you got a different number of results than tests ran!' ); return; } #line 2020 sub _whoa { my( $self, $check, $desc ) = @_; if($check) { local $Level = $Level + 1; $self->croak(<<"WHOA"); WHOA! $desc This should never happen! Please contact the author immediately! WHOA } return; } #line 2044 sub _my_exit { $? = $_[0]; ## no critic (Variables::RequireLocalizedPunctuationVars) return 1; } #line 2056 sub _ending { my $self = shift; my $real_exit_code = $?; # Don't bother with an ending if this is a forked copy. Only the parent # should do the ending. if( $self->{Original_Pid} != $$ ) { return; } # Ran tests but never declared a plan or hit done_testing if( !$self->{Have_Plan} and $self->{Curr_Test} ) { $self->diag("Tests were run but no plan was declared and done_testing() was not seen."); } # Exit if plan() was never called. This is so "require Test::Simple" # doesn't puke. if( !$self->{Have_Plan} ) { return; } # Don't do an ending if we bailed out. if( $self->{Bailed_Out} ) { return; } # Figure out if we passed or failed and print helpful messages. my $test_results = $self->{Test_Results}; if(@$test_results) { # The plan? We have no plan. if( $self->{No_Plan} ) { $self->_output_plan($self->{Curr_Test}) unless $self->no_header; $self->{Expected_Tests} = $self->{Curr_Test}; } # Auto-extended arrays and elements which aren't explicitly # filled in with a shared reference will puke under 5.8.0 # ithreads. So we have to fill them in by hand. :( my $empty_result = &share( {} ); for my $idx ( 0 .. $self->{Expected_Tests} - 1 ) { $test_results->[$idx] = $empty_result unless defined $test_results->[$idx]; } my $num_failed = grep !$_->{'ok'}, @{$test_results}[ 0 .. $self->{Curr_Test} - 1 ]; my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests}; if( $num_extra != 0 ) { my $s = $self->{Expected_Tests} == 1 ? '' : 's'; $self->diag(<<"FAIL"); Looks like you planned $self->{Expected_Tests} test$s but ran $self->{Curr_Test}. FAIL } if($num_failed) { my $num_tests = $self->{Curr_Test}; my $s = $num_failed == 1 ? '' : 's'; my $qualifier = $num_extra == 0 ? '' : ' run'; $self->diag(<<"FAIL"); Looks like you failed $num_failed test$s of $num_tests$qualifier. FAIL } if($real_exit_code) { $self->diag(<<"FAIL"); Looks like your test exited with $real_exit_code just after $self->{Curr_Test}. FAIL _my_exit($real_exit_code) && return; } my $exit_code; if($num_failed) { $exit_code = $num_failed <= 254 ? $num_failed : 254; } elsif( $num_extra != 0 ) { $exit_code = 255; } else { $exit_code = 0; } _my_exit($exit_code) && return; } elsif( $self->{Skip_All} ) { _my_exit(0) && return; } elsif($real_exit_code) { $self->diag(<<"FAIL"); Looks like your test exited with $real_exit_code before it could output anything. FAIL _my_exit($real_exit_code) && return; } else { $self->diag("No tests run!\n"); _my_exit(255) && return; } $self->_whoa( 1, "We fell off the end of _ending()" ); } END { $Test->_ending if defined $Test and !$Test->no_ending; } #line 2236 1; ngx_http_substitutions_filter_module-0.6.4/test/inc/Test/Builder/000077500000000000000000000000001227766254600253635ustar00rootroot00000000000000ngx_http_substitutions_filter_module-0.6.4/test/inc/Test/Builder/Module.pm000066400000000000000000000026161227766254600271530ustar00rootroot00000000000000#line 1 package Test::Builder::Module; use strict; use Test::Builder; require Exporter; our @ISA = qw(Exporter); our $VERSION = '0.92'; $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) # 5.004's Exporter doesn't have export_to_level. my $_export_to_level = sub { my $pkg = shift; my $level = shift; (undef) = shift; # redundant arg my $callpkg = caller($level); $pkg->export( $callpkg, @_ ); }; #line 82 sub import { my($class) = shift; # 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(@_); $class->$_export_to_level( 1, $class, @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 145 sub import_extra { } #line 175 sub builder { return Test::Builder->new; } 1; ngx_http_substitutions_filter_module-0.6.4/test/inc/Test/More.pm000066400000000000000000000405451227766254600252450ustar00rootroot00000000000000#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 use_ok() 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 = '0.92'; $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) 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 BAIL_OUT ); #line 163 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; while( $idx <= $#{$list} ) { my $item = $list->[$idx]; if( defined $item and $item eq 'no_diag' ) { $class->builder->no_diag(1); } else { push @other, $item; } $idx++; } @$list = @other; return; } #line 216 sub done_testing { my $tb = Test::More->builder; $tb->done_testing(@_); } #line 289 sub ok ($;$) { my( $test, $name ) = @_; my $tb = Test::More->builder; return $tb->ok( $test, $name ); } #line 367 sub is ($$;$) { my $tb = Test::More->builder; return $tb->is_eq(@_); } sub isnt ($$;$) { my $tb = Test::More->builder; return $tb->isnt_eq(@_); } *isn't = \&isnt; #line 411 sub like ($$;$) { my $tb = Test::More->builder; return $tb->like(@_); } #line 426 sub unlike ($$;$) { my $tb = Test::More->builder; return $tb->unlike(@_); } #line 471 sub cmp_ok($$$;$) { my $tb = Test::More->builder; return $tb->cmp_ok(@_); } #line 506 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 572 sub isa_ok ($$;$) { my( $object, $class, $obj_name ) = @_; my $tb = Test::More->builder; my $diag; if( !defined $object ) { $obj_name = 'The thing' unless defined $obj_name; $diag = "$obj_name isn't defined"; } else { my $whatami = ref $object ? 'object' : 'class'; # We can't use UNIVERSAL::isa because we want to honor isa() overrides my( $rslt, $error ) = $tb->_try( sub { $object->isa($class) } ); if($error) { if( $error =~ /^Can't call method "isa" on unblessed reference/ ) { # Its an unblessed reference $obj_name = 'The reference' unless defined $obj_name; if( !UNIVERSAL::isa( $object, $class ) ) { my $ref = ref $object; $diag = "$obj_name isn't a '$class' it's a '$ref'"; } } elsif( $error =~ /Can't call method "isa" without a package/ ) { # It's something that can't even be a class $diag = "$obj_name isn't a class or reference"; } else { die <isa on your $whatami and got some weird error. Here's the error. $error WHOA } } else { $obj_name = "The $whatami" unless defined $obj_name; if( !$rslt ) { my $ref = ref $object; $diag = "$obj_name isn't a '$class' it's a '$ref'"; } } } my $name = "$obj_name isa $class"; my $ok; if($diag) { $ok = $tb->ok( 0, $name ); $tb->diag(" $diag\n"); } else { $ok = $tb->ok( 1, $name ); } return $ok; } #line 650 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 ||= []; $object_name = "The object" unless defined $object_name; 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 { $tb->ok( 0, "new() died" ); $tb->diag(" Error was: $error"); } return $obj; } #line 690 sub pass (;$) { my $tb = Test::More->builder; return $tb->ok( 1, @_ ); } sub fail (;$) { my $tb = Test::More->builder; return $tb->ok( 0, @_ ); } #line 753 sub use_ok ($;@) { my( $module, @imports ) = @_; @imports = () unless @imports; my $tb = Test::More->builder; my( $pack, $filename, $line ) = caller; 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; my $pack = caller; # Try to deterine 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; 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(ARRAY HASH REF SCALAR GLOB CODE Regexp)) { return $type if UNIVERSAL::isa( $thing, $type ); } return ''; } #line 1059 sub diag { return Test::More->builder->diag(@_); } sub note { return Test::More->builder->note(@_); } #line 1085 sub explain { return Test::More->builder->explain(@_); } #line 1151 ## no critic (Subroutines::RequireFinalReturn) sub 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 "skip() needs to know \$how_many tests are in the block" unless $tb->has_plan eq 'no_plan'; $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 1238 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 1293 sub BAIL_OUT { my $reason = shift; my $tb = Test::More->builder; $tb->BAIL_OUT($reason); } #line 1332 #'# 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->[$_]; 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 _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; { # Quiet uninitialized value warnings when comparing undefs. no warnings 'uninitialized'; $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 defined. $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 1465 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; 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 1522 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 1735 1; ngx_http_substitutions_filter_module-0.6.4/test/lib/000077500000000000000000000000001227766254600230535ustar00rootroot00000000000000ngx_http_substitutions_filter_module-0.6.4/test/lib/Test/000077500000000000000000000000001227766254600237725ustar00rootroot00000000000000ngx_http_substitutions_filter_module-0.6.4/test/lib/Test/Nginx.pm000066400000000000000000000224261227766254600254210ustar00rootroot00000000000000package Test::Nginx; use strict; use warnings; our $VERSION = '0.17'; __END__ =encoding utf-8 =head1 NAME Test::Nginx - Testing modules for Nginx C module development =head1 DESCRIPTION This distribution provides two testing modules for Nginx C module development: =over =item * L =item * L =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 =head2 etcproxy integration The default settings in etcproxy (https://github.com/chaoslawful/etcproxy) makes this small TCP proxy split the TCP packets into bytes and introduce 1 ms latency among them. There's usually various TCP chains that we can put etcproxy into, for example =head3 Test::Nginx <=> nginx $ ./etcproxy 1234 1984 Here we tell etcproxy to listen on port 1234 and to delegate all the TCP traffic to the port 1984, the default port that Test::Nginx makes nginx listen to. And then we tell Test::Nginx to test against the port 1234, where etcproxy listens on, rather than the port 1984 that nginx directly listens on: $ TEST_NGINX_CLIENT_PORT=1234 prove -r t/ Then the TCP chain now looks like this: Test::Nginx <=> etcproxy (1234) <=> nginx (1984) So etcproxy can effectively emulate extreme network conditions and exercise "unusual" code paths in your nginx server by your tests. In practice, *tons* of weird bugs can be captured by this setting. Even ourselves didn't expect that this simple approach is so effective. =head3 nginx <=> memcached We first start the memcached server daemon on port 11211: memcached -p 11211 -vv and then we another etcproxy instance to listen on port 11984 like this $ ./etcproxy 11984 11211 Then we tell our t/foo.t test script to connect to 11984 rather than 11211: # foo.t use Test::Nginx::Socket; repeat_each(1); plan tests => 2 * repeat_each() * blocks(); $ENV{TEST_NGINX_MEMCACHED_PORT} ||= 11211; # make this env take a default value run_tests(); __DATA__ === TEST 1: sanity --- config location /foo { set $memc_cmd set; set $memc_key foo; set $memc_value bar; memc_pass 127.0.0.1:$TEST_NGINX_MEMCACHED_PORT; } --- request GET /foo --- response_body_like: STORED The Test::Nginx library will automatically expand the special macro C<$TEST_NGINX_MEMCACHED_PORT> to the environment with the same name. You can define your own C<$TEST_NGINX_BLAH_BLAH_PORT> macros as long as its prefix is C and all in upper case letters. And now we can run your test script against the etcproxy port 11984: TEST_NGINX_MEMCACHED_PORT=11984 prove t/foo.t Then the TCP chains look like this: Test::Nginx <=> nginx (1984) <=> etcproxy (11984) <=> memcached (11211) If C is not set, then it will take the default value 11211, which is what we want when there's no etcproxy configured: Test::Nginx <=> nginx (1984) <=> memcached (11211) This approach also works for proxied mysql and postgres traffic. Please see the live test suite of ngx_drizzle and ngx_postgres for more details. Usually we set both C and C (and etc) at the same time, effectively yielding the following chain: Test::Nginx <=> etcproxy (1234) <=> nginx (1984) <=> etcproxy (11984) <=> memcached (11211) as long as you run two separate etcproxy instances in two separate terminals. It's easy to verify if the traffic actually goes through your etcproxy server. Just check if the terminal running etcproxy emits outputs. By default, etcproxy always dump out the incoming and outgoing data to stdout/stderr. =head2 valgrind integration Test::Nginx has integrated support for valgrind (L) even though by default it does not bother running it with the tests because valgrind will significantly slow down the test sutie. First ensure that your valgrind executable visible in your PATH env. And then run your test suite with the C env set to true: TEST_NGINX_USE_VALGRIND=1 prove -r t If you see false alarms, you do have a chance to skip them by defining a ./valgrind.suppress file at the root of your module source tree, as in L This is the suppression file for ngx_drizzle. Test::Nginx will automatically use it to start nginx with valgrind memcheck if this file does exist at the expected location. If you do see a lot of "Connection refused" errors while running the tests this way, then you probably have a slow machine (or a very busy one) that the default waiting time is not sufficient for valgrind to start. You can define the sleep time to a larger value by setting the C env: TEST_NGINX_SLEEP=1 prove -r t The time unit used here is "second". The default sleep setting just fits my ThinkPad (C). Applying the no-pool patch to your nginx core is recommended while running nginx with valgrind: L The nginx memory pool can prevent valgrind from spotting lots of invalid memory reads/writes as well as certain double-free errors. We did find a lot more memory issues in many of our modules when we first introduced the no-pool patch in practice ;) There's also more advanced features in Test::Nginx that have never documented. I'd like to write more about them in the near future ;) =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_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 =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 AUTHORS agentzh (章亦春) C<< >> Antoine BONAVITA C<< >> =head1 COPYRIGHT & LICENSE Copyright (c) 2009-2011, Taobao Inc., Alibaba Group (L). Copyright (c) 2009-2011, agentzh C<< >>. Copyright (c) 2011, 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 Taobao Inc. 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. ngx_http_substitutions_filter_module-0.6.4/test/lib/Test/Nginx/000077500000000000000000000000001227766254600250555ustar00rootroot00000000000000ngx_http_substitutions_filter_module-0.6.4/test/lib/Test/Nginx/LWP.pm000066400000000000000000000336661227766254600260730ustar00rootroot00000000000000package Test::Nginx::LWP; use lib 'lib'; use lib 'inc'; use Test::Base -Base; our $VERSION = '0.17'; 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 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 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 the lack of directive $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 the lack of directive $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 the lack of directive $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 the lack of directive $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 the lack of directive $dry_run", 1); } } else { like($content, qr/$expected_pat/s, "$name - response_body_like - response is expected ($summary)"); } } elsif (defined $block->response_body_unlike) { 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_unlike; $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 the lack of directive $dry_run", 1); } } else { unlike($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-2011, Taobao Inc., Alibaba Group (L). Copyright (c) 2009-2011, 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 Taobao Inc. 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. ngx_http_substitutions_filter_module-0.6.4/test/lib/Test/Nginx/Socket.pm000066400000000000000000001541621227766254600266540ustar00rootroot00000000000000package Test::Nginx::Socket; use lib 'lib'; use lib 'inc'; use Test::Base -Base; our $VERSION = '0.17'; use Encode; use Data::Dumper; use Time::HiRes qw(sleep time); use Test::LongString; use List::MoreUtils qw( any ); use IO::Select (); our $ServerAddr = 'localhost'; our $Timeout = $ENV{TEST_NGINX_TIMEOUT} || 2; 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 $ServerPort $PidFile $ServRoot $ConfFile $RunTestHelper $RepeatEach worker_connections master_process_enabled config_preamble repeat_each workers master_on log_level no_shuffle no_root_location server_root html_dir server_port no_nginx_manager ); #use Smart::Comments::JSON '###'; use Fcntl qw(F_GETFL F_SETFL O_NONBLOCK); use POSIX qw(EAGAIN); use IO::Socket; #our ($PrevRequest, $PrevConfig); our $NoLongString = undef; our @EXPORT = qw( plan run_tests run_test repeat_each config_preamble worker_connections master_process_enabled no_long_string workers master_on log_level no_shuffle no_root_location server_addr server_root html_dir server_port timeout no_nginx_manager ); sub send_request ($$$$@); sub run_test_helper ($$); sub error_event_handler ($); sub read_event_handler ($); sub write_event_handler ($); sub no_long_string () { $NoLongString = 1; } sub server_addr (@) { if (@_) { #warn "setting server addr to $_[0]\n"; $ServerAddr = shift; } else { return $ServerAddr; } } sub timeout (@) { if (@_) { $Timeout = shift; } else { $Timeout; } } $RunTestHelper = \&run_test_helper; # 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 ) { Test::More::BAIL_OUT("$name - Request line should be non-empty"); die; } #$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 { Test::More::BAIL_OUT("$name - Request line is not valid. Should be 'meth [url [version]]'"); die; } 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 !~ /\bContent-Length:/ ) { $parsed_req->{content} =~ s/^\s+|\s+$//gs; $len_header .= "Content-Length: " . length( $parsed_req->{content} ) . "\r\n"; } $parsed_req->{method} .= ' '; $parsed_req->{url} .= ' '; $parsed_req->{http_ver} .= "\r\n"; $parsed_req->{headers} = "Host: localhost\r\nConnection: $conn_header\r\n$more_headers$len_header\r\n"; # Get the moves from parsing my @elements_moves = get_moves($parsed_req); # Apply them to the packets. return apply_moves($request_packets, \@elements_moves); } # 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; } my $is_chunked = 0; my $more_headers = ''; 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; if ( lc($key) eq 'transfer-encoding' and $val eq 'chunked' ) { $is_chunked = 1; } #warn "[$key, $val]\n"; $more_headers .= "$key: $val\r\n"; } } if ( $block->pipelined_requests ) { my $reqs = $block->pipelined_requests; if ( !ref $reqs || ref $reqs ne 'ARRAY' ) { Test::More::BAIL_OUT( "$name - invalid entries in --- pipelined_requests"); } my $i = 0; my $prq = ""; for my $request (@$reqs) { my $conn_type; if ( $i++ == @$reqs - 1 ) { $conn_type = 'close'; } else { $conn_type = 'keep-alive'; } my $r_br = build_request_from_packets($name, $more_headers, $is_chunked, $conn_type, [$request] ); $prq .= $$r_br[0]; } push @req_list, [{value =>$prq}]; } else { # request section. if (!ref $request) { # One request and it is a good old string. my $r_br = build_request_from_packets($name, $more_headers, $is_chunked, 'Close', [$request] ); push @req_list, [{value => $$r_br[0]}]; } elsif (ref $request eq 'ARRAY') { # A bunch of requests... for my $one_req (@$request) { if (!ref $one_req) { # This request is a good old string. my $r_br = build_request_from_packets($name, $more_headers, $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 { Test::More::BAIL_OUT "$name - Invalid syntax. $one_packet should be a string or hash with value."; } } my $transformed_packet_array = build_request_from_packets($name, $more_headers, $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 { Test::More::BAIL_OUT "$name - Invalid syntax. $one_req should be a string or an array of packets."; } } } else { Test::More::BAIL_OUT( "$name - invalid ---request : MUST be string or array of requests"); } } } return \@req_list; } sub run_test_helper ($$) { my ( $block, $dry_run ) = @_; my $name = $block->name; my $r_req_list = get_req_from_block($block); if ( $#$r_req_list < 0 ) { Test::More::BAIL_OUT("$name - request empty"); } #warn "request: $req\n"; my $timeout = $block->timeout; if ( !defined $timeout ) { $timeout = $Timeout; } my $req_idx = 0; for my $one_req (@$r_req_list) { my $raw_resp; if ($dry_run) { $raw_resp = "200 OK HTTP/1.0\r\nContent-Length: 0\r\n\r\n"; } else { $raw_resp = send_request( $one_req, $block->raw_request_middle_delay, $timeout, $block->name ); } #warn "raw resonse: [$raw_resp]\n"; my ($n, $need_array); if ($block->pipelined_requests) { $n = @{ $block->pipelined_requests }; $need_array = 1; } else { $need_array = $#$r_req_list > 0; } again: #warn "!!! resp: [$raw_resp]"; if (!defined $raw_resp) { $raw_resp = ''; } my ( $res, $raw_headers, $left ) = parse_response( $name, $raw_resp ); 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--; } 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); check_response_body($block, $res, $dry_run, $req_idx, $need_array); $req_idx++; if ($n) { goto again; } } } # 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]; } else { Test::More::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) { Test::More::BAIL_OUT("$name - SHOULD NOT HAPPEN: idx != 0 and don't need array."); } else { return $$value[0]; } } else { 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 the lack of directive $dry_run", 1 if $dry_run; if ( defined $block->error_code ) { is( $res->code || '', get_indexed_value($name, $block->error_code, $req_idx, $need_array), "$name - status code ok" ); } else { is( $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 - tests skipped due to the lack of directive $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"; } } } 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 - tests skipped due to the lack of directive $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; } my $actual_val = $res->header($key); if ( !defined $actual_val ) { $actual_val = ''; } SKIP: { skip "$name - tests skipped due to the lack of directive $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 - tests skipped due to the lack of directive $dry_run", 1 if $dry_run; like $expected_val, qr/^$val$/, "$name - header $key like ok"; } } } } sub check_response_body() { my ($block, $res, $dry_run, $req_idx, $need_array) = @_; my $name = $block->name; if ( defined $block->response_body || defined $block->response_body_eval ) { 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; 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 (ref $expected) { $expected =~ s/\$ServerPort\b/$ServerPort/g; $expected =~ s/\$ServerPortForClient\b/$ServerPortForClient/g; } #warn show_all_chars($content); #warn "no long string: $NoLongString"; SKIP: { skip "$name - tests skipped due to the lack of directive $dry_run", 1 if $dry_run; if (ref $expected) { like $content, $expected, "$name - response_body - like"; } else { if ($NoLongString) { is( $content, $expected, "$name - response_body - response is expected" ); } else { is_string( $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 = get_indexed_value($name, $block->response_body_like, $req_idx, $need_array); $expected_pat =~ s/\$ServerPort\b/$ServerPort/g; $expected_pat =~ s/\$ServerPortForClient\b/$ServerPortForClient/g; my $summary = trim($content); SKIP: { skip "$name - tests skipped due to the lack of directive $dry_run", 1 if $dry_run; like( $content, qr/$expected_pat/s, "$name - response_body_like - response is expected ($summary)" ); } } elsif ( defined $block->response_body_unlike ) { 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 = get_indexed_value($name, $block->response_body_unlike, $req_idx, $need_array); $expected_pat =~ s/\$ServerPort\b/$ServerPort/g; $expected_pat =~ s/\$ServerPortForClient\b/$ServerPortForClient/g; my $summary = trim($content); SKIP: { skip "$name - tests skipped due to the lack of directive $dry_run", 1 if $dry_run; unlike( $content, qr/$expected_pat/s, "$name - response_body_like - response is expected ($summary)" ); } } sub parse_response($$) { my ( $name, $raw_resp ) = @_; 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 $enc = $res->header('Transfer-Encoding'); my $len = $res->header('Content-Length'); if ( defined $enc && $enc eq 'chunked' ) { #warn "Found chunked!"; my $raw = $res->content; if ( !defined $raw ) { $raw = ''; } my $decoded = ''; while (1) { if ( $raw =~ /\G 0 [\ \t]* \r\n \r\n /gcsx ) { 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 { fail( "$name - invalid chunked data received (not enought octets for the data section)" ); return; } $rest -= $bit; } if ( $raw !~ /\G\r\n/gcs ) { fail( "$name - invalid chunked data received (expected CRLF)." ); return; } } elsif ( $raw =~ /\G.+/gcs ) { fail "$name - invalid chunked body received: $&"; return; } else { 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) { 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_request ($$$$@) { my ( $req, $middle_delay, $timeout, $name, $tries ) = @_; my $sock = IO::Socket::INET->new( PeerAddr => $ServerAddr, PeerPort => $ServerPortForClient, Proto => 'tcp' ); if (! defined $sock) { $tries ||= 0; if ($tries < 3) { warn "Can't connect to $ServerAddr:$ServerPortForClient: $!\n"; sleep 1; return send_request($req, $middle_delay, $timeout, $name, $tries + 1); } else { die "Can't connect to $ServerAddr:$ServerPortForClient: $!\n"; } } my @req_bits = ref $req ? @$req : ($req); 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, }; 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; } 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 ) { if ( $writable_hdls->exists($hdl) ) { $writable_hdls->remove($hdl); } } } } return $ctx->{resp}; } sub timeout_event_handler ($) { my $ctx = shift; warn "ERROR: socket client: timed out - $ctx->{name}\n"; } 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 { my $next_send = shift @{ $ctx->{req_bits} } or 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; } $ctx->{resp} = "500 read failed: $!"; 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; } 1; __END__ =encoding utf-8 =head1 NAME Test::Nginx::Socket - Socket-backed test scaffold for the Nginx C modules =head1 SYNOPSIS use Test::Nginx::Socket; plan tests => $Test::Nginx::Socket::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 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 ;) =head1 Sections supported The following sections are supported: =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 of the generated config file. This is very rarely used, except if you are testing nginx core itself. This section goes through environment variable expansion (variables have to start with TEST_NGINX). =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 Close 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 nto 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"] =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 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_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 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 raw_request The exact request to send to nginx. This is useful when you want to test soem 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 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". =head2 skip_nginx =head2 skip_nginx2 Both string scalar and string arrays are supported as values. =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. =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_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_NO_SHUFFLE Dafaults 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 to 1, will start nginx with valgrind. nginx is actually started with C, the suppressions option being used only if there is actually a valgrind.suppress file. =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 diirect 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. =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