├── .gitignore ├── ngx_http_upstream_keepalive ├── config ├── CHANGES ├── LICENSE ├── README ├── t │ ├── stale.t │ ├── fastcgi-keepalive.t │ └── memcached-keepalive.t └── ngx_http_upstream_keepalive_module.c ├── config ├── test ├── inc │ ├── Module │ │ ├── Install │ │ │ ├── TestBase.pm │ │ │ ├── Include.pm │ │ │ ├── Base.pm │ │ │ ├── WriteAll.pm │ │ │ ├── AutoInstall.pm │ │ │ ├── Win32.pm │ │ │ ├── Can.pm │ │ │ ├── Fetch.pm │ │ │ ├── Makefile.pm │ │ │ └── Metadata.pm │ │ └── Install.pm │ ├── Test │ │ ├── Builder │ │ │ └── Module.pm │ │ ├── Base │ │ │ └── Filter.pm │ │ ├── More.pm │ │ └── Base.pm │ └── Spiffy.pm ├── t │ ├── http_head.t │ ├── http_buffering_off.t │ ├── http_put.t │ ├── http_get.t │ ├── http_store.t │ └── http_cache.t ├── README └── lib │ └── Test │ ├── Nginx.pm │ └── Nginx │ ├── Util.pm │ └── LWP.pm ├── README └── upstream_keepalive_1.0.5.patch /.gitignore: -------------------------------------------------------------------------------- 1 | *.swp 2 | *.sh 3 | *.[oa] 4 | Makefile 5 | cscope* 6 | objs 7 | .hg* 8 | -------------------------------------------------------------------------------- /ngx_http_upstream_keepalive/config: -------------------------------------------------------------------------------- 1 | ngx_addon_name="ngx_http_upstream_keepalive_module" 2 | 3 | HTTP_MODULES="$HTTP_MODULES \ 4 | ngx_http_upstream_keepalive_module" 5 | 6 | NGX_ADDON_SRCS="$NGX_ADDON_SRCS \ 7 | $ngx_addon_dir/ngx_http_upstream_keepalive_module.c" 8 | -------------------------------------------------------------------------------- /config: -------------------------------------------------------------------------------- 1 | ngx_addon_name="ngx_http_upstream_keepalive_patch" 2 | 3 | have=NGX_ENABLE_UPSTREAM_KEEPALIVE . auto/have 4 | 5 | HTTP_MODULES="$HTTP_MODULES \ 6 | ngx_http_upstream_keepalive_module" 7 | 8 | NGX_ADDON_SRCS="$NGX_ADDON_SRCS \ 9 | $ngx_addon_dir/ngx_http_upstream_keepalive/ngx_http_upstream_keepalive_module.c" 10 | -------------------------------------------------------------------------------- /test/inc/Module/Install/TestBase.pm: -------------------------------------------------------------------------------- 1 | #line 1 2 | package Module::Install::TestBase; 3 | use strict; 4 | use warnings; 5 | 6 | use Module::Install::Base; 7 | 8 | use vars qw($VERSION @ISA); 9 | BEGIN { 10 | $VERSION = '0.11'; 11 | @ISA = 'Module::Install::Base'; 12 | } 13 | 14 | sub use_test_base { 15 | my $self = shift; 16 | $self->include('Test::Base'); 17 | $self->include('Test::Base::Filter'); 18 | $self->include('Spiffy'); 19 | $self->include('Test::More'); 20 | $self->include('Test::Builder'); 21 | $self->include('Test::Builder::Module'); 22 | $self->requires('Filter::Util::Call'); 23 | } 24 | 25 | 1; 26 | 27 | =encoding utf8 28 | 29 | #line 70 30 | -------------------------------------------------------------------------------- /test/inc/Module/Install/Include.pm: -------------------------------------------------------------------------------- 1 | #line 1 2 | package Module::Install::Include; 3 | 4 | use strict; 5 | use Module::Install::Base (); 6 | 7 | use vars qw{$VERSION @ISA $ISCORE}; 8 | BEGIN { 9 | $VERSION = '0.91'; 10 | @ISA = 'Module::Install::Base'; 11 | $ISCORE = 1; 12 | } 13 | 14 | sub include { 15 | shift()->admin->include(@_); 16 | } 17 | 18 | sub include_deps { 19 | shift()->admin->include_deps(@_); 20 | } 21 | 22 | sub auto_include { 23 | shift()->admin->auto_include(@_); 24 | } 25 | 26 | sub auto_include_deps { 27 | shift()->admin->auto_include_deps(@_); 28 | } 29 | 30 | sub auto_include_dependent_dists { 31 | shift()->admin->auto_include_dependent_dists(@_); 32 | } 33 | 34 | 1; 35 | -------------------------------------------------------------------------------- /ngx_http_upstream_keepalive/CHANGES: -------------------------------------------------------------------------------- 1 | 2 | Changes with upstream keepalive module 0.4 (2010-12-15): 3 | 4 | *) Bugfix: the "[alert] ... open socket ... left in connection ..." 5 | messages were logged on nginx worker process gracefull exit for 6 | each cached connection; the bug had appeared in 0.3. 7 | 8 | 9 | Changes with upstream keepalive module 0.3 (2010-09-14): 10 | 11 | *) Bugfix: cached connections might be closed needlessly. 12 | Thanks to Martin Fjordvald. 13 | 14 | *) Bugfix: in memory allocation error handling on config creation. 15 | 16 | 17 | Changes with upstream keepalive module 0.2 (2009-05-15): 18 | 19 | *) Feature: expiremental support for FastCGI (requires patches). 20 | 21 | *) Bugfix: invalid connections might be cached. 22 | 23 | 24 | Changes with upstream keepalive module 0.1 (2008-10-24): 25 | 26 | *) The first public version. 27 | -------------------------------------------------------------------------------- /test/t/http_head.t: -------------------------------------------------------------------------------- 1 | # 2 | #=============================================================================== 3 | # 4 | # FILE: sample.t 5 | # 6 | # DESCRIPTION: test 7 | # 8 | # FILES: --- 9 | # BUGS: --- 10 | # NOTES: --- 11 | # AUTHOR: Weibin Yao (http://yaoweibin.cn/), yaoweibin@gmail.com 12 | # COMPANY: 13 | # VERSION: 1.0 14 | # CREATED: 03/02/2010 03:18:28 PM 15 | # REVISION: --- 16 | #=============================================================================== 17 | 18 | 19 | # vi:filetype=perl 20 | 21 | use lib 'lib'; 22 | use Test::Nginx::LWP; 23 | 24 | plan tests => repeat_each() * 2 * blocks(); 25 | 26 | #no_diff; 27 | 28 | run_tests(); 29 | 30 | __DATA__ 31 | 32 | === TEST 1: the HEAD of HTTP 33 | --- http_config 34 | upstream backend{ 35 | server blog.163.com; 36 | keepalive 64; 37 | } 38 | --- config 39 | location / { 40 | proxy_set_header Host blog.163.com; 41 | proxy_set_header Connection "keep-alive"; 42 | proxy_pass http://backend; 43 | } 44 | --- request 45 | HEAD / 46 | --- response_body_like: ^(.*)$ 47 | -------------------------------------------------------------------------------- /test/t/http_buffering_off.t: -------------------------------------------------------------------------------- 1 | # 2 | #=============================================================================== 3 | # 4 | # FILE: sample.t 5 | # 6 | # DESCRIPTION: test 7 | # 8 | # FILES: --- 9 | # BUGS: --- 10 | # NOTES: --- 11 | # AUTHOR: Weibin Yao (http://yaoweibin.cn/), yaoweibin@gmail.com 12 | # COMPANY: 13 | # VERSION: 1.0 14 | # CREATED: 03/02/2010 03:18:28 PM 15 | # REVISION: --- 16 | #=============================================================================== 17 | 18 | 19 | # vi:filetype=perl 20 | 21 | use lib 'lib'; 22 | use Test::Nginx::LWP; 23 | 24 | plan tests => repeat_each() * 2 * blocks(); 25 | 26 | #no_diff; 27 | 28 | run_tests(); 29 | 30 | __DATA__ 31 | 32 | === TEST 1: set proxy_buffering off 33 | --- http_config 34 | upstream backend{ 35 | server blog.163.com; 36 | keepalive 64; 37 | } 38 | --- config 39 | location / { 40 | proxy_buffering off; 41 | proxy_set_header Host blog.163.com; 42 | proxy_set_header Connection "keep-alive"; 43 | proxy_pass http://backend; 44 | } 45 | --- request 46 | GET / 47 | --- response_body_like: ^(.*)$ 48 | -------------------------------------------------------------------------------- /test/t/http_put.t: -------------------------------------------------------------------------------- 1 | # 2 | #=============================================================================== 3 | # 4 | # FILE: sample.t 5 | # 6 | # DESCRIPTION: test 7 | # 8 | # FILES: --- 9 | # BUGS: --- 10 | # NOTES: --- 11 | # AUTHOR: Weibin Yao (http://yaoweibin.cn/), yaoweibin@gmail.com 12 | # COMPANY: 13 | # VERSION: 1.0 14 | # CREATED: 03/02/2010 03:18:28 PM 15 | # REVISION: --- 16 | #=============================================================================== 17 | 18 | 19 | # vi:filetype=perl 20 | 21 | use lib 'lib'; 22 | use Test::Nginx::LWP; 23 | 24 | plan tests => repeat_each() * 2 * blocks(); 25 | 26 | #no_diff; 27 | 28 | run_tests(); 29 | 30 | __DATA__ 31 | 32 | === TEST 1: the POST of HTTP 33 | --- http_config 34 | upstream backend{ 35 | server www.javasonics.com; 36 | keepalive 64; 37 | } 38 | --- config 39 | location / { 40 | proxy_set_header Host www.javasonics.com; 41 | proxy_set_header Connection "keep-alive"; 42 | proxy_pass http://backend; 43 | } 44 | --- request 45 | PUT /listenup/php_test/handle_file_upload.php 46 | username=yaoweibin 47 | --- request_headers 48 | Content-Type: multipart/form-data 49 | --- response_body_like: ^(.*)$ 50 | -------------------------------------------------------------------------------- /test/inc/Module/Install/Base.pm: -------------------------------------------------------------------------------- 1 | #line 1 2 | package Module::Install::Base; 3 | 4 | use strict 'vars'; 5 | use vars qw{$VERSION}; 6 | BEGIN { 7 | $VERSION = '0.91'; 8 | } 9 | 10 | # Suspend handler for "redefined" warnings 11 | BEGIN { 12 | my $w = $SIG{__WARN__}; 13 | $SIG{__WARN__} = sub { $w }; 14 | } 15 | 16 | #line 42 17 | 18 | sub new { 19 | my $class = shift; 20 | unless ( defined &{"${class}::call"} ) { 21 | *{"${class}::call"} = sub { shift->_top->call(@_) }; 22 | } 23 | unless ( defined &{"${class}::load"} ) { 24 | *{"${class}::load"} = sub { shift->_top->load(@_) }; 25 | } 26 | bless { @_ }, $class; 27 | } 28 | 29 | #line 61 30 | 31 | sub AUTOLOAD { 32 | local $@; 33 | my $func = eval { shift->_top->autoload } or return; 34 | goto &$func; 35 | } 36 | 37 | #line 75 38 | 39 | sub _top { 40 | $_[0]->{_top}; 41 | } 42 | 43 | #line 90 44 | 45 | sub admin { 46 | $_[0]->_top->{admin} 47 | or 48 | Module::Install::Base::FakeAdmin->new; 49 | } 50 | 51 | #line 106 52 | 53 | sub is_admin { 54 | $_[0]->admin->VERSION; 55 | } 56 | 57 | sub DESTROY {} 58 | 59 | package Module::Install::Base::FakeAdmin; 60 | 61 | my $fake; 62 | 63 | sub new { 64 | $fake ||= bless(\@_, $_[0]); 65 | } 66 | 67 | sub AUTOLOAD {} 68 | 69 | sub DESTROY {} 70 | 71 | # Restore warning handler 72 | BEGIN { 73 | $SIG{__WARN__} = $SIG{__WARN__}->(); 74 | } 75 | 76 | 1; 77 | 78 | #line 154 79 | -------------------------------------------------------------------------------- /ngx_http_upstream_keepalive/LICENSE: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright (C) 2008-2010 Maxim Dounin 3 | * 4 | * Redistribution and use in source and binary forms, with or without 5 | * modification, are permitted provided that the following conditions 6 | * are met: 7 | * 1. Redistributions of source code must retain the above copyright 8 | * notice, this list of conditions and the following disclaimer. 9 | * 2. Redistributions in binary form must reproduce the above copyright 10 | * notice, this list of conditions and the following disclaimer in the 11 | * documentation and/or other materials provided with the distribution. 12 | * 13 | * THIS SOFTWARE IS PROVIDED BY AUTHOR AND CONTRIBUTORS ``AS IS'' AND 14 | * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 15 | * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 16 | * ARE DISCLAIMED. IN NO EVENT SHALL AUTHOR OR CONTRIBUTORS BE LIABLE 17 | * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 18 | * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 19 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 20 | * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 21 | * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 22 | * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 23 | * SUCH DAMAGE. 24 | */ 25 | -------------------------------------------------------------------------------- /test/inc/Module/Install/WriteAll.pm: -------------------------------------------------------------------------------- 1 | #line 1 2 | package Module::Install::WriteAll; 3 | 4 | use strict; 5 | use Module::Install::Base (); 6 | 7 | use vars qw{$VERSION @ISA $ISCORE}; 8 | BEGIN { 9 | $VERSION = '0.91';; 10 | @ISA = qw{Module::Install::Base}; 11 | $ISCORE = 1; 12 | } 13 | 14 | sub WriteAll { 15 | my $self = shift; 16 | my %args = ( 17 | meta => 1, 18 | sign => 0, 19 | inline => 0, 20 | check_nmake => 1, 21 | @_, 22 | ); 23 | 24 | $self->sign(1) if $args{sign}; 25 | $self->admin->WriteAll(%args) if $self->is_admin; 26 | 27 | $self->check_nmake if $args{check_nmake}; 28 | unless ( $self->makemaker_args->{PL_FILES} ) { 29 | $self->makemaker_args( PL_FILES => {} ); 30 | } 31 | 32 | # Until ExtUtils::MakeMaker support MYMETA.yml, make sure 33 | # we clean it up properly ourself. 34 | $self->realclean_files('MYMETA.yml'); 35 | 36 | if ( $args{inline} ) { 37 | $self->Inline->write; 38 | } else { 39 | $self->Makefile->write; 40 | } 41 | 42 | # The Makefile write process adds a couple of dependencies, 43 | # so write the META.yml files after the Makefile. 44 | if ( $args{meta} ) { 45 | $self->Meta->write; 46 | } 47 | 48 | # Experimental support for MYMETA 49 | if ( $ENV{X_MYMETA} ) { 50 | if ( $ENV{X_MYMETA} eq 'JSON' ) { 51 | $self->Meta->write_mymeta_json; 52 | } else { 53 | $self->Meta->write_mymeta_yaml; 54 | } 55 | } 56 | 57 | return 1; 58 | } 59 | 60 | 1; 61 | -------------------------------------------------------------------------------- /test/inc/Module/Install/AutoInstall.pm: -------------------------------------------------------------------------------- 1 | #line 1 2 | package Module::Install::AutoInstall; 3 | 4 | use strict; 5 | use Module::Install::Base (); 6 | 7 | use vars qw{$VERSION @ISA $ISCORE}; 8 | BEGIN { 9 | $VERSION = '0.91'; 10 | @ISA = 'Module::Install::Base'; 11 | $ISCORE = 1; 12 | } 13 | 14 | sub AutoInstall { $_[0] } 15 | 16 | sub run { 17 | my $self = shift; 18 | $self->auto_install_now(@_); 19 | } 20 | 21 | sub write { 22 | my $self = shift; 23 | $self->auto_install(@_); 24 | } 25 | 26 | sub auto_install { 27 | my $self = shift; 28 | return if $self->{done}++; 29 | 30 | # Flatten array of arrays into a single array 31 | my @core = map @$_, map @$_, grep ref, 32 | $self->build_requires, $self->requires; 33 | 34 | my @config = @_; 35 | 36 | # We'll need Module::AutoInstall 37 | $self->include('Module::AutoInstall'); 38 | require Module::AutoInstall; 39 | 40 | Module::AutoInstall->import( 41 | (@config ? (-config => \@config) : ()), 42 | (@core ? (-core => \@core) : ()), 43 | $self->features, 44 | ); 45 | 46 | $self->makemaker_args( Module::AutoInstall::_make_args() ); 47 | 48 | my $class = ref($self); 49 | $self->postamble( 50 | "# --- $class section:\n" . 51 | Module::AutoInstall::postamble() 52 | ); 53 | } 54 | 55 | sub auto_install_now { 56 | my $self = shift; 57 | $self->auto_install(@_); 58 | Module::AutoInstall::do_install(); 59 | } 60 | 61 | 1; 62 | -------------------------------------------------------------------------------- /test/inc/Test/Builder/Module.pm: -------------------------------------------------------------------------------- 1 | #line 1 2 | package Test::Builder::Module; 3 | 4 | use strict; 5 | 6 | use Test::Builder; 7 | 8 | require Exporter; 9 | our @ISA = qw(Exporter); 10 | 11 | our $VERSION = '0.94'; 12 | $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) 13 | 14 | 15 | #line 74 16 | 17 | sub import { 18 | my($class) = shift; 19 | 20 | # Don't run all this when loading ourself. 21 | return 1 if $class eq 'Test::Builder::Module'; 22 | 23 | my $test = $class->builder; 24 | 25 | my $caller = caller; 26 | 27 | $test->exported_to($caller); 28 | 29 | $class->import_extra( \@_ ); 30 | my(@imports) = $class->_strip_imports( \@_ ); 31 | 32 | $test->plan(@_); 33 | 34 | $class->export_to_level( 1, $class, @imports ); 35 | } 36 | 37 | sub _strip_imports { 38 | my $class = shift; 39 | my $list = shift; 40 | 41 | my @imports = (); 42 | my @other = (); 43 | my $idx = 0; 44 | while( $idx <= $#{$list} ) { 45 | my $item = $list->[$idx]; 46 | 47 | if( defined $item and $item eq 'import' ) { 48 | push @imports, @{ $list->[ $idx + 1 ] }; 49 | $idx++; 50 | } 51 | else { 52 | push @other, $item; 53 | } 54 | 55 | $idx++; 56 | } 57 | 58 | @$list = @other; 59 | 60 | return @imports; 61 | } 62 | 63 | #line 137 64 | 65 | sub import_extra { } 66 | 67 | #line 167 68 | 69 | sub builder { 70 | return Test::Builder->new; 71 | } 72 | 73 | 1; 74 | -------------------------------------------------------------------------------- /ngx_http_upstream_keepalive/README: -------------------------------------------------------------------------------- 1 | Keepalive balancer module for nginx. 2 | 3 | This module implements cache for backend connections. As of now, it may 4 | be used with memcached upstreams. 5 | 6 | Note: don't even try it with http backends. It won't work. 7 | 8 | Note: it's for nginx 0.7.* and up, won't work with nginx 0.6.*. 9 | 10 | Configuration directives: 11 | 12 | keepalive [single] 13 | 14 | Scope: upstream 15 | 16 | Switches on keepalive module for the upstream in question. 17 | 18 | Parameters: 19 | 20 | - 21 | Maximum number of connections to cache. If there isn't enough 22 | room to cache new connections - last recently used connections 23 | will be kicked off the cache. 24 | 25 | - single 26 | Treat everything as single host. With this flag connections 27 | to different backends are treated as equal. 28 | 29 | Sample configuration: 30 | 31 | upstream memd { 32 | server 127.0.0.1:11211; 33 | server 10.0.0.2:11211; 34 | keepalive 10; 35 | } 36 | 37 | This module was tested to work with standard round-robin balancing, but 38 | it's believed to be compatible with more sophisticated balancers. The only 39 | requirement is to activate them *before* this module, e.g.: 40 | 41 | upstream memd { 42 | server 127.0.0.1:11211; 43 | server 10.0.0.2:11211; 44 | ip_hash; 45 | keepalive 10; 46 | } 47 | 48 | To compile nginx with keepalive module, use "--add-module " option to 49 | nginx configure. 50 | -------------------------------------------------------------------------------- /test/inc/Module/Install/Win32.pm: -------------------------------------------------------------------------------- 1 | #line 1 2 | package Module::Install::Win32; 3 | 4 | use strict; 5 | use Module::Install::Base (); 6 | 7 | use vars qw{$VERSION @ISA $ISCORE}; 8 | BEGIN { 9 | $VERSION = '0.91'; 10 | @ISA = 'Module::Install::Base'; 11 | $ISCORE = 1; 12 | } 13 | 14 | # determine if the user needs nmake, and download it if needed 15 | sub check_nmake { 16 | my $self = shift; 17 | $self->load('can_run'); 18 | $self->load('get_file'); 19 | 20 | require Config; 21 | return unless ( 22 | $^O eq 'MSWin32' and 23 | $Config::Config{make} and 24 | $Config::Config{make} =~ /^nmake\b/i and 25 | ! $self->can_run('nmake') 26 | ); 27 | 28 | print "The required 'nmake' executable not found, fetching it...\n"; 29 | 30 | require File::Basename; 31 | my $rv = $self->get_file( 32 | url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe', 33 | ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe', 34 | local_dir => File::Basename::dirname($^X), 35 | size => 51928, 36 | run => 'Nmake15.exe /o > nul', 37 | check_for => 'Nmake.exe', 38 | remove => 1, 39 | ); 40 | 41 | die <<'END_MESSAGE' unless $rv; 42 | 43 | ------------------------------------------------------------------------------- 44 | 45 | Since you are using Microsoft Windows, you will need the 'nmake' utility 46 | before installation. It's available at: 47 | 48 | http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe 49 | or 50 | ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe 51 | 52 | Please download the file manually, save it to a directory in %PATH% (e.g. 53 | C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to 54 | that directory, and run "Nmake15.exe" from there; that will create the 55 | 'nmake.exe' file needed by this module. 56 | 57 | You may then resume the installation process described in README. 58 | 59 | ------------------------------------------------------------------------------- 60 | END_MESSAGE 61 | 62 | } 63 | 64 | 1; 65 | -------------------------------------------------------------------------------- /test/inc/Module/Install/Can.pm: -------------------------------------------------------------------------------- 1 | #line 1 2 | package Module::Install::Can; 3 | 4 | use strict; 5 | use Config (); 6 | use File::Spec (); 7 | use ExtUtils::MakeMaker (); 8 | use Module::Install::Base (); 9 | 10 | use vars qw{$VERSION @ISA $ISCORE}; 11 | BEGIN { 12 | $VERSION = '0.91'; 13 | @ISA = 'Module::Install::Base'; 14 | $ISCORE = 1; 15 | } 16 | 17 | # check if we can load some module 18 | ### Upgrade this to not have to load the module if possible 19 | sub can_use { 20 | my ($self, $mod, $ver) = @_; 21 | $mod =~ s{::|\\}{/}g; 22 | $mod .= '.pm' unless $mod =~ /\.pm$/i; 23 | 24 | my $pkg = $mod; 25 | $pkg =~ s{/}{::}g; 26 | $pkg =~ s{\.pm$}{}i; 27 | 28 | local $@; 29 | eval { require $mod; $pkg->VERSION($ver || 0); 1 }; 30 | } 31 | 32 | # check if we can run some command 33 | sub can_run { 34 | my ($self, $cmd) = @_; 35 | 36 | my $_cmd = $cmd; 37 | return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); 38 | 39 | for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { 40 | next if $dir eq ''; 41 | my $abs = File::Spec->catfile($dir, $_[1]); 42 | return $abs if (-x $abs or $abs = MM->maybe_command($abs)); 43 | } 44 | 45 | return; 46 | } 47 | 48 | # can we locate a (the) C compiler 49 | sub can_cc { 50 | my $self = shift; 51 | my @chunks = split(/ /, $Config::Config{cc}) or return; 52 | 53 | # $Config{cc} may contain args; try to find out the program part 54 | while (@chunks) { 55 | return $self->can_run("@chunks") || (pop(@chunks), next); 56 | } 57 | 58 | return; 59 | } 60 | 61 | # Fix Cygwin bug on maybe_command(); 62 | if ( $^O eq 'cygwin' ) { 63 | require ExtUtils::MM_Cygwin; 64 | require ExtUtils::MM_Win32; 65 | if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { 66 | *ExtUtils::MM_Cygwin::maybe_command = sub { 67 | my ($self, $file) = @_; 68 | if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { 69 | ExtUtils::MM_Win32->maybe_command($file); 70 | } else { 71 | ExtUtils::MM_Unix->maybe_command($file); 72 | } 73 | } 74 | } 75 | } 76 | 77 | 1; 78 | 79 | __END__ 80 | 81 | #line 156 82 | -------------------------------------------------------------------------------- /test/README: -------------------------------------------------------------------------------- 1 | NAME 2 | Test::Nginx - Testing modules for Nginx C module development 3 | 4 | DESCRIPTION 5 | This distribution provides two testing modules for Nginx C module 6 | development: 7 | 8 | * Test::Nginx::LWP 9 | 10 | * Test::Nginx::Socket 11 | 12 | All of them are based on Test::Base. 13 | 14 | SOURCE REPOSITORY 15 | This module has a Git repository on Github, which has access for all. 16 | 17 | http://github.com/agentzh/test-nginx 18 | 19 | If you want a commit bit, feel free to drop me a line. 20 | 21 | AUTHOR 22 | agentzh (章亦春) "" 23 | 24 | COPYRIGHT & LICENSE 25 | Copyright (c) 2009, Taobao Inc., Alibaba Group 26 | (). 27 | 28 | Copyright (c) 2009, agentzh "". 29 | 30 | This module is licensed under the terms of the BSD license. 31 | 32 | Redistribution and use in source and binary forms, with or without 33 | modification, are permitted provided that the following conditions are 34 | met: 35 | 36 | * Redistributions of source code must retain the above copyright 37 | notice, this list of conditions and the following disclaimer. 38 | 39 | * Redistributions in binary form must reproduce the above copyright 40 | notice, this list of conditions and the following disclaimer in the 41 | documentation and/or other materials provided with the distribution. 42 | 43 | * Neither the name of the Taobao Inc. nor the names of its 44 | contributors may be used to endorse or promote products derived from 45 | this software without specific prior written permission. 46 | 47 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS 48 | IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED 49 | TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A 50 | PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 51 | HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 52 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 53 | TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 54 | PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 55 | LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 56 | NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 57 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 58 | 59 | SEE ALSO 60 | Test::Nginx::LWP, Test::Nginx::Socket, Test::Base. 61 | 62 | -------------------------------------------------------------------------------- /test/lib/Test/Nginx.pm: -------------------------------------------------------------------------------- 1 | package Test::Nginx; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | our $VERSION = '0.08'; 7 | 8 | __END__ 9 | 10 | =encoding utf-8 11 | 12 | =head1 NAME 13 | 14 | Test::Nginx - Testing modules for Nginx C module development 15 | 16 | =head1 DESCRIPTION 17 | 18 | This distribution provides two testing modules for Nginx C module development: 19 | 20 | =over 21 | 22 | =item * 23 | 24 | L 25 | 26 | =item * 27 | 28 | L 29 | 30 | =back 31 | 32 | All of them are based on L. 33 | 34 | =head1 SOURCE REPOSITORY 35 | 36 | This module has a Git repository on Github, which has access for all. 37 | 38 | http://github.com/agentzh/test-nginx 39 | 40 | If you want a commit bit, feel free to drop me a line. 41 | 42 | =head1 AUTHOR 43 | 44 | agentzh (章亦春) C<< >> 45 | 46 | =head1 COPYRIGHT & LICENSE 47 | 48 | Copyright (c) 2009, Taobao Inc., Alibaba Group (L). 49 | 50 | Copyright (c) 2009, agentzh C<< >>. 51 | 52 | This module is licensed under the terms of the BSD license. 53 | 54 | Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 55 | 56 | =over 57 | 58 | =item * 59 | 60 | Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 61 | 62 | =item * 63 | 64 | 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. 65 | 66 | =item * 67 | 68 | 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. 69 | 70 | =back 71 | 72 | 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. 73 | 74 | =head1 SEE ALSO 75 | 76 | L, L, L. 77 | 78 | -------------------------------------------------------------------------------- /test/inc/Module/Install/Fetch.pm: -------------------------------------------------------------------------------- 1 | #line 1 2 | package Module::Install::Fetch; 3 | 4 | use strict; 5 | use Module::Install::Base (); 6 | 7 | use vars qw{$VERSION @ISA $ISCORE}; 8 | BEGIN { 9 | $VERSION = '0.91'; 10 | @ISA = 'Module::Install::Base'; 11 | $ISCORE = 1; 12 | } 13 | 14 | sub get_file { 15 | my ($self, %args) = @_; 16 | my ($scheme, $host, $path, $file) = 17 | $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; 18 | 19 | if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) { 20 | $args{url} = $args{ftp_url} 21 | or (warn("LWP support unavailable!\n"), return); 22 | ($scheme, $host, $path, $file) = 23 | $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; 24 | } 25 | 26 | $|++; 27 | print "Fetching '$file' from $host... "; 28 | 29 | unless (eval { require Socket; Socket::inet_aton($host) }) { 30 | warn "'$host' resolve failed!\n"; 31 | return; 32 | } 33 | 34 | return unless $scheme eq 'ftp' or $scheme eq 'http'; 35 | 36 | require Cwd; 37 | my $dir = Cwd::getcwd(); 38 | chdir $args{local_dir} or return if exists $args{local_dir}; 39 | 40 | if (eval { require LWP::Simple; 1 }) { 41 | LWP::Simple::mirror($args{url}, $file); 42 | } 43 | elsif (eval { require Net::FTP; 1 }) { eval { 44 | # use Net::FTP to get past firewall 45 | my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600); 46 | $ftp->login("anonymous", 'anonymous@example.com'); 47 | $ftp->cwd($path); 48 | $ftp->binary; 49 | $ftp->get($file) or (warn("$!\n"), return); 50 | $ftp->quit; 51 | } } 52 | elsif (my $ftp = $self->can_run('ftp')) { eval { 53 | # no Net::FTP, fallback to ftp.exe 54 | require FileHandle; 55 | my $fh = FileHandle->new; 56 | 57 | local $SIG{CHLD} = 'IGNORE'; 58 | unless ($fh->open("|$ftp -n")) { 59 | warn "Couldn't open ftp: $!\n"; 60 | chdir $dir; return; 61 | } 62 | 63 | my @dialog = split(/\n/, <<"END_FTP"); 64 | open $host 65 | user anonymous anonymous\@example.com 66 | cd $path 67 | binary 68 | get $file $file 69 | quit 70 | END_FTP 71 | foreach (@dialog) { $fh->print("$_\n") } 72 | $fh->close; 73 | } } 74 | else { 75 | warn "No working 'ftp' program available!\n"; 76 | chdir $dir; return; 77 | } 78 | 79 | unless (-f $file) { 80 | warn "Fetching failed: $@\n"; 81 | chdir $dir; return; 82 | } 83 | 84 | return if exists $args{size} and -s $file != $args{size}; 85 | system($args{run}) if exists $args{run}; 86 | unlink($file) if $args{remove}; 87 | 88 | print(((!exists $args{check_for} or -e $args{check_for}) 89 | ? "done!" : "failed! ($!)"), "\n"); 90 | chdir $dir; return !$?; 91 | } 92 | 93 | 1; 94 | -------------------------------------------------------------------------------- /test/t/http_get.t: -------------------------------------------------------------------------------- 1 | # 2 | #=============================================================================== 3 | # 4 | # FILE: sample.t 5 | # 6 | # DESCRIPTION: test 7 | # 8 | # FILES: --- 9 | # BUGS: --- 10 | # NOTES: --- 11 | # AUTHOR: Weibin Yao (http://yaoweibin.cn/), yaoweibin@gmail.com 12 | # COMPANY: 13 | # VERSION: 1.0 14 | # CREATED: 03/02/2010 03:18:28 PM 15 | # REVISION: --- 16 | #=============================================================================== 17 | 18 | 19 | # vi:filetype=perl 20 | 21 | use lib 'lib'; 22 | use Test::Nginx::LWP; 23 | 24 | plan tests => repeat_each() * 2 * blocks(); 25 | 26 | #no_diff; 27 | 28 | run_tests(); 29 | 30 | __DATA__ 31 | 32 | === TEST 1: the GET of HTTP 33 | --- http_config 34 | upstream backend{ 35 | server blog.163.com; 36 | keepalive 64; 37 | } 38 | --- config 39 | location / { 40 | proxy_set_header Host blog.163.com; 41 | proxy_set_header Connection "keep-alive"; 42 | proxy_pass http://backend; 43 | } 44 | --- request 45 | GET / 46 | --- response_body_like: ^(.*)$ 47 | 48 | === TEST 2: the GET of HTTP again 49 | --- http_config 50 | upstream backend{ 51 | server blog.163.com; 52 | keepalive 64; 53 | } 54 | --- config 55 | location / { 56 | proxy_set_header Host blog.163.com; 57 | proxy_set_header Connection "keep-alive"; 58 | proxy_pass http://backend; 59 | } 60 | --- request 61 | GET / 62 | --- response_body_like: ^(.*)$ 63 | 64 | === TEST 3: the GET of HTTP with variable length response 65 | --- http_config 66 | upstream backend{ 67 | server www.163.com; 68 | keepalive 64; 69 | } 70 | --- config 71 | location / { 72 | proxy_set_header Host www.163.com; 73 | proxy_set_header Connection "keep-alive"; 74 | proxy_pass http://backend; 75 | } 76 | --- request 77 | GET / 78 | --- response_body_like: ^(.*)$ 79 | 80 | === TEST 4: the GET of HTTP with variable length response again 81 | --- http_config 82 | upstream backend{ 83 | server www.163.com; 84 | keepalive 64; 85 | } 86 | --- config 87 | location / { 88 | proxy_set_header Host www.163.com; 89 | proxy_set_header Connection "keep-alive"; 90 | proxy_pass http://backend; 91 | } 92 | --- request 93 | GET / 94 | --- response_body_like: ^(.*)$ 95 | 96 | === TEST 5: the GET of HTTP without keepalive 97 | --- http_config 98 | upstream backend{ 99 | server www.163.com; 100 | } 101 | --- config 102 | location / { 103 | proxy_set_header Host www.163.com; 104 | proxy_set_header Connection "keep-alive"; 105 | proxy_pass http://backend; 106 | } 107 | --- request 108 | GET / 109 | --- response_body_like: ^(.*)$ 110 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | ==NOTICE= 2 | This patch may be just usable under the version of Nginx_1.0.5. It just adds the 3 | support for the upstream keepalive connection and it isn't a completed HTTP/1.1 4 | patch. 5 | 6 | The core Nginx developer Maxim Dounin has released a completed patch for Nginx 7 | HTTP/1.1 proxying (http://forum.nginx.org/read.php?2,213207). It will be merged 8 | into the 1.1.x branch of Nginx(http://mailman.nginx.org/pipermail/nginx-devel/2011-July/001083.html). 9 | 10 | This patch has merged into the Nginx-1.1.4 branch. 11 | 12 | I suggest you should use this patch. Good luck. 13 | 14 | ==INSTALLATION== 15 | 16 | cd nginx-1.0.5 17 | patch -p1 < /path/to/this/directory/upstream_keepalive_1.0.5.patch 18 | 19 | #add the module 20 | ./configure --add-module=/path/to/this/directory 21 | 22 | 23 | ==EXAMPLE== 24 | 25 | upstream backends { 26 | server 10.0.0.1; 27 | server 10.0.0.2; 28 | 29 | keepalive 128; 30 | } 31 | 32 | Append the header of "Connection: keep-alive" with the proxy packet: 33 | 34 | location /foo { 35 | proxy_set_header Connection "keep-alive"; 36 | proxy_pass http://backends; 37 | } 38 | 39 | The ngx_http_upstream_keepalive_module's document is here: 40 | https://github.com/yaoweibin/nginx_upstream_keepalive_patch/raw/master/ngx_http_upstream_keepalive/README 41 | 42 | Notice that, this module keep connections in a pool. All the backend connections 43 | will not be timeout or closed actively by this module, unless the backend 44 | server close the connection. 45 | 46 | ==COPYRIGHT & LICENSE== 47 | 48 | This original patch and ngx_http_upstream_keepalive_module is written by 49 | Maxim Dounin and published under the BSD license. 50 | 51 | This patch is also published under the BSD license. 52 | 53 | Copyright (C) 2011 by Weibin Yao . 54 | 55 | Thanks to Simpli.fi to sponsor this patch. 56 | 57 | Redistribution and use in source and binary forms, with or without 58 | modification, are permitted provided that the following conditions are 59 | met: 60 | 61 | * Redistributions of source code must retain the above copyright 62 | notice, this list of conditions and the following disclaimer. 63 | 64 | * Redistributions in binary form must reproduce the above copyright 65 | notice, this list of conditions and the following disclaimer in the 66 | documentation and/or other materials provided with the distribution. 67 | 68 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS 69 | IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED 70 | TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A 71 | PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 72 | HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 73 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 74 | TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 75 | PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 76 | LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 77 | NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 78 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 79 | -------------------------------------------------------------------------------- /ngx_http_upstream_keepalive/t/stale.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # (C) Maxim Dounin 4 | 5 | # Test for stale events handling in upstream keepalive. 6 | 7 | ############################################################################### 8 | 9 | use warnings; 10 | use strict; 11 | 12 | use Test::More; 13 | use Test::Nginx; 14 | 15 | ############################################################################### 16 | 17 | select STDERR; $| = 1; 18 | select STDOUT; $| = 1; 19 | 20 | eval { require Cache::Memcached; }; 21 | plan(skip_all => 'Cache::Memcached not installed') if $@; 22 | 23 | my $t = Test::Nginx->new()->has('rewrite')->has_daemon('memcached')->plan(2) 24 | ->write_file_expand('nginx.conf', <<'EOF'); 25 | 26 | %%TEST_GLOBALS%% 27 | 28 | daemon off; 29 | 30 | worker_processes 2; 31 | 32 | events { 33 | } 34 | 35 | http { 36 | %%TEST_GLOBALS_HTTP%% 37 | 38 | upstream memd { 39 | server 127.0.0.1:8081; 40 | keepalive 1; 41 | } 42 | 43 | server { 44 | listen 127.0.0.1:8080 sndbuf=32k; 45 | server_name localhost; 46 | 47 | location / { 48 | set $memcached_key $uri; 49 | memcached_pass memd; 50 | } 51 | } 52 | } 53 | 54 | EOF 55 | 56 | my $memhelp = `memcached -h`; 57 | my @memopts1 = (); 58 | 59 | if ($memhelp =~ /repcached/) { 60 | # repcached patches adds additional listen socket memcached 61 | # that should be different too 62 | 63 | push @memopts1, '-X', '8091'; 64 | } 65 | if ($memhelp =~ /-U/) { 66 | # UDP ports no longer off by default in memcached 1.2.7+ 67 | 68 | push @memopts1, '-U', '0'; 69 | } 70 | 71 | $t->run_daemon('memcached', '-l', '127.0.0.1', '-p', '8081', @memopts1); 72 | 73 | $t->run(); 74 | 75 | $t->waitforsocket('127.0.0.1:8081') 76 | or die "Unable to start memcached"; 77 | 78 | ############################################################################### 79 | 80 | my $memd1 = Cache::Memcached->new(servers => [ '127.0.0.1:8081' ]); 81 | 82 | # It's possible that stale events occur, i.e. read event handler called 83 | # for just saved upstream connection without any data available for 84 | # read. We shouldn't close upstream connection in such situation. 85 | # 86 | # This happens due to reading from upstream connection on downstream write 87 | # events. More likely to happen with multiple workers due to use of posted 88 | # events. 89 | # 90 | # Stale event may only happen if reading response from upstream requires 91 | # entering event loop, i.e. response should be big enough. On the other 92 | # hand, it is less likely to occur with full client's connection output 93 | # buffer. 94 | # 95 | # We use here 2 workers, 20k response and set output buffer on clients 96 | # connection to 32k. This allows more or less reliably reproduce stale 97 | # events at least on FreeBSD testbed here. 98 | 99 | $memd1->set('/big', 'X' x 20480); 100 | 101 | my $total = $memd1->stats()->{total}->{total_connections}; 102 | 103 | for (1 .. 100) { 104 | http_get('/big'); 105 | } 106 | 107 | cmp_ok($memd1->stats()->{total}->{total_connections}, '<=', $total + 2, 108 | 'only one connection per worker used'); 109 | 110 | $t->stop(); 111 | 112 | like(`grep -F '[alert]' ${\($t->testdir())}/error.log`, qr/^$/s, 'no alerts'); 113 | 114 | ############################################################################### 115 | -------------------------------------------------------------------------------- /test/t/http_store.t: -------------------------------------------------------------------------------- 1 | # 2 | #=============================================================================== 3 | # 4 | # FILE: sample.t 5 | # 6 | # DESCRIPTION: test 7 | # 8 | # FILES: --- 9 | # BUGS: --- 10 | # NOTES: --- 11 | # AUTHOR: Weibin Yao (http://yaoweibin.cn/), yaoweibin@gmail.com 12 | # COMPANY: 13 | # VERSION: 1.0 14 | # CREATED: 03/02/2010 03:18:28 PM 15 | # REVISION: --- 16 | #=============================================================================== 17 | 18 | 19 | # vi:filetype=perl 20 | 21 | use lib 'lib'; 22 | use Test::Nginx::LWP; 23 | 24 | plan tests => repeat_each() * 2 * blocks(); 25 | 26 | #no_diff; 27 | 28 | run_tests(); 29 | 30 | __DATA__ 31 | 32 | === TEST 1: GET file MISS at first time 33 | --- http_config 34 | upstream backend{ 35 | server www.163.com; 36 | keepalive 64; 37 | } 38 | 39 | --- config 40 | location / { 41 | root /tmp/proxy_store_test; 42 | error_page 404 = /fetch$uri; 43 | } 44 | 45 | location /fetch { 46 | internal; 47 | 48 | proxy_store on; 49 | proxy_store_access user:rw group:rw all:r; 50 | proxy_temp_path /tmp/proxy_store_test; 51 | alias /tmp/proxy_store_test; 52 | 53 | proxy_set_header Host www.163.com; 54 | proxy_set_header Connection "keep-alive"; 55 | proxy_pass http://backend; 56 | } 57 | --- request 58 | GET /index.html 59 | --- response_body_like: ^(.*)$ 60 | 61 | === TEST 2: GET file HIT at second time 62 | --- http_config 63 | upstream backend{ 64 | server www.163.com; 65 | keepalive 64; 66 | } 67 | 68 | --- config 69 | location / { 70 | root /tmp/proxy_store_test; 71 | error_page 404 = /fetch$uri; 72 | } 73 | 74 | location /fetch { 75 | internal; 76 | 77 | proxy_store on; 78 | proxy_store_access user:rw group:rw all:r; 79 | proxy_temp_path /tmp/proxy_store_test; 80 | alias /tmp/proxy_store_test; 81 | 82 | proxy_set_header Host www.163.com; 83 | proxy_set_header Connection "keep-alive"; 84 | proxy_pass http://backend; 85 | } 86 | --- request 87 | GET /index.html 88 | --- response_body_like: ^(.*)$ 89 | 90 | === TEST 3: GET file MISS at first time 91 | --- http_config 92 | upstream backend{ 93 | server blog.163.com; 94 | keepalive 64; 95 | } 96 | 97 | --- config 98 | location / { 99 | root /tmp/proxy_store_test; 100 | error_page 404 = /fetch$uri; 101 | } 102 | 103 | location /fetch { 104 | internal; 105 | 106 | proxy_store on; 107 | proxy_store_access user:rw group:rw all:r; 108 | proxy_temp_path /tmp/proxy_store_test; 109 | alias /tmp/proxy_store_test; 110 | 111 | proxy_set_header Host blog.163.com; 112 | proxy_set_header Connection "keep-alive"; 113 | proxy_pass http://backend; 114 | } 115 | --- request 116 | GET /classify/index.do 117 | --- response_body_like: ^(.*)$ 118 | 119 | === TEST 4: GET file MISS again, because the blog.163.com disable cache 120 | --- http_config 121 | upstream backend{ 122 | server blog.163.com; 123 | keepalive 64; 124 | } 125 | 126 | --- config 127 | location / { 128 | root /tmp/proxy_store_test; 129 | error_page 404 = /fetch$uri; 130 | } 131 | 132 | location /fetch { 133 | internal; 134 | 135 | proxy_store on; 136 | proxy_store_access user:rw group:rw all:r; 137 | proxy_temp_path /tmp/proxy_store_test; 138 | alias /tmp/proxy_store_test; 139 | 140 | proxy_set_header Host blog.163.com; 141 | proxy_set_header Connection "keep-alive"; 142 | proxy_pass http://backend; 143 | } 144 | --- request 145 | GET /classify/index.do 146 | --- response_body_like: ^(.*)$ 147 | -------------------------------------------------------------------------------- /test/t/http_cache.t: -------------------------------------------------------------------------------- 1 | # 2 | #=============================================================================== 3 | # 4 | # FILE: sample.t 5 | # 6 | # DESCRIPTION: test 7 | # 8 | # FILES: --- 9 | # BUGS: --- 10 | # NOTES: --- 11 | # AUTHOR: Weibin Yao (http://yaoweibin.cn/), yaoweibin@gmail.com 12 | # COMPANY: 13 | # VERSION: 1.0 14 | # CREATED: 03/02/2010 03:18:28 PM 15 | # REVISION: --- 16 | #=============================================================================== 17 | 18 | 19 | # vi:filetype=perl 20 | 21 | use lib 'lib'; 22 | use Test::Nginx::LWP; 23 | 24 | plan tests => repeat_each() * 2 * blocks(); 25 | 26 | #no_diff; 27 | 28 | run_tests(); 29 | 30 | __DATA__ 31 | 32 | === TEST 1: GET file MISS at first time 33 | --- http_config 34 | upstream backend{ 35 | server www.163.com; 36 | keepalive 64; 37 | } 38 | 39 | proxy_cache_path /tmp/http_cache_test levels=1:2 keys_zone=http_cache_zone:10m inactive=24h max_size=1g; 40 | 41 | --- config 42 | location / { 43 | proxy_cache "http_cache_zone"; 44 | proxy_cache_key "$host$request_uri$cookie_user"; 45 | proxy_cache_valid 200 1d; 46 | proxy_cache_use_stale error timeout invalid_header updating http_500; 47 | add_header X-Cache $upstream_cache_status; 48 | 49 | proxy_set_header Host www.163.com; 50 | proxy_set_header Connection "keep-alive"; 51 | 52 | proxy_pass http://backend; 53 | } 54 | --- request 55 | GET / 56 | --- response_headers 57 | X-Cache: MISS 58 | 59 | === TEST 2: GET file HIT at second time 60 | --- http_config 61 | upstream backend{ 62 | server www.163.com; 63 | keepalive 64; 64 | } 65 | 66 | proxy_cache_path /tmp/http_cache_test levels=1:2 keys_zone=http_cache_zone:10m inactive=24h max_size=1g; 67 | 68 | --- config 69 | location / { 70 | proxy_cache "http_cache_zone"; 71 | proxy_cache_key "$host$request_uri$cookie_user"; 72 | proxy_cache_valid 200 1d; 73 | proxy_cache_use_stale error timeout invalid_header updating http_500; 74 | add_header X-Cache $upstream_cache_status; 75 | 76 | proxy_set_header Host www.163.com; 77 | proxy_set_header Connection "keep-alive"; 78 | proxy_pass http://backend; 79 | } 80 | --- request 81 | GET / 82 | --- response_headers 83 | X-Cache: HIT 84 | 85 | === TEST 3: GET file MISS at first time 86 | --- http_config 87 | upstream backend{ 88 | server blog.163.com; 89 | keepalive 64; 90 | } 91 | 92 | proxy_cache_path /tmp/http_cache_test levels=1:2 keys_zone=http_cache_zone:10m inactive=24h max_size=1g; 93 | 94 | --- config 95 | location / { 96 | proxy_cache "http_cache_zone"; 97 | proxy_cache_key "blog.163.com$request_uri$cookie_user"; 98 | proxy_cache_valid 200 1d; 99 | proxy_cache_use_stale error timeout invalid_header updating http_500; 100 | add_header X-Cache $upstream_cache_status; 101 | 102 | proxy_set_header Host blog.163.com; 103 | proxy_set_header Connection "keep-alive"; 104 | proxy_pass http://backend; 105 | } 106 | --- request 107 | GET / 108 | --- response_headers 109 | X-Cache: MISS 110 | 111 | === TEST 4: GET file MISS again, because the blog.163.com disable cache 112 | --- http_config 113 | upstream backend{ 114 | server blog.163.com; 115 | keepalive 64; 116 | } 117 | 118 | proxy_cache_path /tmp/http_cache_test levels=1:2 keys_zone=http_cache_zone:10m inactive=24h max_size=1g; 119 | 120 | --- config 121 | location / { 122 | proxy_cache "http_cache_zone"; 123 | proxy_cache_key "blog.163.com$request_uri$cookie_user"; 124 | proxy_cache_valid 200 1d; 125 | proxy_cache_use_stale error timeout invalid_header updating http_500; 126 | add_header X-Cache $upstream_cache_status; 127 | 128 | proxy_set_header Host blog.163.com; 129 | proxy_set_header Connection "keep-alive"; 130 | proxy_pass http://backend; 131 | } 132 | --- request 133 | GET / 134 | --- response_headers 135 | X-Cache: MISS 136 | -------------------------------------------------------------------------------- /ngx_http_upstream_keepalive/t/fastcgi-keepalive.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # (C) Maxim Dounin 4 | 5 | # Test for fastcgi backend with keepalive. 6 | 7 | ############################################################################### 8 | 9 | use warnings; 10 | use strict; 11 | 12 | use Test::More; 13 | use Test::Nginx; 14 | 15 | ############################################################################### 16 | 17 | select STDERR; $| = 1; 18 | select STDOUT; $| = 1; 19 | 20 | my $t = Test::Nginx->new()->plan(6) 21 | ->write_file_expand('nginx.conf', <<'EOF'); 22 | 23 | %%TEST_GLOBALS%% 24 | 25 | master_process off; 26 | daemon off; 27 | 28 | events { 29 | } 30 | 31 | http { 32 | %%TEST_GLOBALS_HTTP%% 33 | 34 | upstream backend { 35 | server 127.0.0.1:8081; 36 | keepalive 1; 37 | } 38 | 39 | server { 40 | listen 127.0.0.1:8080; 41 | server_name localhost; 42 | 43 | location / { 44 | fastcgi_pass backend; 45 | } 46 | } 47 | } 48 | 49 | EOF 50 | 51 | $t->run_daemon(\&fastcgi_test_daemon); 52 | $t->run(); 53 | 54 | ############################################################################### 55 | 56 | { 57 | local $TODO = 'needs experimental patches'; 58 | local $SIG{__WARN__} = sub {}; 59 | 60 | like(http_get('/'), qr/SEE-THIS/, 'fastcgi request'); 61 | like(http_get('/redir'), qr/302/, 'fastcgi redirect'); 62 | like(http_get('/'), qr/^request: 3$/m, 'fastcgi third request'); 63 | 64 | like(http_get('/single'), qr/^connection: 1$/m, 'single connection used'); 65 | 66 | } 67 | 68 | # New connection to fastcgi application should be established after HEAD 69 | # requests since nginx doesn't read whole response (as it doesn't need 70 | # body). 71 | 72 | unlike(http_head('/head'), qr/SEE-THIS/, 'no data in HEAD'); 73 | 74 | { 75 | local $TODO = 'needs experimental patches'; 76 | local $SIG{__WARN__} = sub {}; 77 | 78 | like(http_get('/after'), qr/^connection: 2$/m, 'new connection after HEAD'); 79 | 80 | } 81 | 82 | ############################################################################### 83 | 84 | # Simple FastCGI responder implementation. Unlike FCGI and FCGI::Async it's 85 | # able to count connections. 86 | 87 | # http://www.fastcgi.com/devkit/doc/fcgi-spec.html 88 | 89 | sub fastcgi_read_record($) { 90 | my ($socket) = @_; 91 | 92 | my ($n, $h, $header); 93 | 94 | $n = $socket->read($header, 8); 95 | return undef if !defined $n or $n != 8; 96 | 97 | @{$h}{qw/ version type id clen plen /} = unpack("CCnnC", $header); 98 | 99 | $n = $socket->read($h->{content}, $h->{clen}); 100 | return undef if $n != $h->{clen}; 101 | 102 | $n = $socket->read($h->{padding}, $h->{plen}); 103 | return undef if $n != $h->{plen}; 104 | 105 | $h->{socket} = $socket; 106 | return $h; 107 | } 108 | 109 | sub fastcgi_respond($$) { 110 | my ($h, $body) = @_; 111 | 112 | # stdout 113 | $h->{socket}->write(pack("CCnnCx", $h->{version}, 6, $h->{id}, 114 | length($body), 0)); 115 | $h->{socket}->write($body); 116 | 117 | # write some text to stdout and stderr splitted over multiple network 118 | # packets to test if we correctly set pipe length in various places 119 | 120 | my $tt = "test text, just for test"; 121 | 122 | $h->{socket}->write(pack("CCnnCx", $h->{version}, 6, $h->{id}, 123 | length($tt . $tt), 0) . $tt); 124 | select(undef, undef, undef, 0.1); 125 | $h->{socket}->write($tt . pack("CC", $h->{version}, 7)); 126 | select(undef, undef, undef, 0.1); 127 | $h->{socket}->write(pack("nnCx", $h->{id}, length($tt), 0)); 128 | $h->{socket}->write($tt); 129 | 130 | # close stdout 131 | $h->{socket}->write(pack("CCnnCx", $h->{version}, 6, $h->{id}, 0, 0)); 132 | 133 | select(undef, undef, undef, 0.1); 134 | 135 | # end request 136 | $h->{socket}->write(pack("CCnnCx", $h->{version}, 3, $h->{id}, 8, 0)); 137 | $h->{socket}->write(pack("NCxxx", 0, 0)); 138 | } 139 | 140 | sub fastcgi_test_daemon { 141 | my $server = IO::Socket::INET->new( 142 | Proto => 'tcp', 143 | LocalAddr => '127.0.0.1:8081', 144 | Listen => 5, 145 | Reuse => 1 146 | ) 147 | or die "Can't create listening socket: $!\n"; 148 | 149 | local $SIG{PIPE} = 'IGNORE'; 150 | 151 | my $ccount = 0; 152 | my $rcount = 0; 153 | 154 | while (my $client = $server->accept()) { 155 | $client->autoflush(1); 156 | Test::Nginx::log_core('||', "fastcgi connection"); 157 | 158 | $ccount++; 159 | 160 | while (my $h = fastcgi_read_record($client)) { 161 | Test::Nginx::log_core('||', "fastcgi record: " 162 | . " $h->{version}, $h->{type}, $h->{id}, " 163 | . "'$h->{content}'"); 164 | 165 | # skip everything unless stdin, then respond 166 | next if $h->{type} != 5; 167 | 168 | $rcount++; 169 | 170 | # respond 171 | fastcgi_respond($h, < 'Cache::Memcached not installed') if $@; 22 | 23 | my $t = Test::Nginx->new()->has('rewrite')->has_daemon('memcached')->plan(17) 24 | ->write_file_expand('nginx.conf', <<'EOF'); 25 | 26 | %%TEST_GLOBALS%% 27 | 28 | daemon off; 29 | 30 | events { 31 | } 32 | 33 | http { 34 | %%TEST_GLOBALS_HTTP%% 35 | 36 | upstream memd { 37 | server 127.0.0.1:8081; 38 | keepalive 1; 39 | } 40 | 41 | upstream memd2 { 42 | server 127.0.0.1:8081; 43 | server 127.0.0.1:8082; 44 | keepalive 1 single; 45 | } 46 | 47 | upstream memd3 { 48 | server 127.0.0.1:8081; 49 | server 127.0.0.1:8082; 50 | keepalive 1; 51 | } 52 | 53 | upstream memd4 { 54 | server 127.0.0.1:8081; 55 | server 127.0.0.1:8082; 56 | keepalive 10; 57 | } 58 | 59 | server { 60 | listen 127.0.0.1:8080; 61 | server_name localhost; 62 | 63 | location / { 64 | set $memcached_key $uri; 65 | memcached_pass memd; 66 | } 67 | 68 | location /next { 69 | set $memcached_key $uri; 70 | memcached_next_upstream not_found; 71 | memcached_pass memd; 72 | } 73 | 74 | location /memd2 { 75 | set $memcached_key "/"; 76 | memcached_pass memd2; 77 | } 78 | 79 | location /memd3 { 80 | set $memcached_key "/"; 81 | memcached_pass memd3; 82 | } 83 | 84 | location /memd4 { 85 | set $memcached_key "/"; 86 | memcached_pass memd4; 87 | } 88 | } 89 | } 90 | 91 | EOF 92 | 93 | my $memhelp = `memcached -h`; 94 | my @memopts1 = (); 95 | my @memopts2 = (); 96 | 97 | if ($memhelp =~ /repcached/) { 98 | # repcached patches adds additional listen socket memcached 99 | # that should be different too 100 | 101 | push @memopts1, '-X', '8091'; 102 | push @memopts2, '-X', '8092'; 103 | } 104 | if ($memhelp =~ /-U/) { 105 | # UDP ports no longer off by default in memcached 1.2.7+ 106 | 107 | push @memopts1, '-U', '0'; 108 | push @memopts2, '-U', '0'; 109 | } 110 | 111 | $t->run_daemon('memcached', '-l', '127.0.0.1', '-p', '8081', @memopts1); 112 | $t->run_daemon('memcached', '-l', '127.0.0.1', '-p', '8082', @memopts2); 113 | 114 | $t->run(); 115 | 116 | $t->waitforsocket('127.0.0.1:8081') 117 | or die "Unable to start memcached"; 118 | $t->waitforsocket('127.0.0.1:8082') 119 | or die "Unable to start second memcached"; 120 | 121 | ############################################################################### 122 | 123 | my $memd1 = Cache::Memcached->new(servers => [ '127.0.0.1:8081' ]); 124 | my $memd2 = Cache::Memcached->new(servers => [ '127.0.0.1:8082' ]); 125 | 126 | $memd1->set('/', 'SEE-THIS'); 127 | $memd2->set('/', 'SEE-THIS'); 128 | $memd1->set('/big', 'X' x 1000000); 129 | 130 | my $total = $memd1->stats()->{total}->{total_connections}; 131 | 132 | like(http_get('/'), qr/SEE-THIS/, 'keepalive memcached request'); 133 | like(http_get('/notfound'), qr/404/, 'keepalive memcached not found'); 134 | like(http_get('/next'), qr/404/, 135 | 'keepalive not found with memcached_next_upstream'); 136 | like(http_get('/'), qr/SEE-THIS/, 'keepalive memcached request again'); 137 | like(http_get('/'), qr/SEE-THIS/, 'keepalive memcached request again'); 138 | like(http_get('/'), qr/SEE-THIS/, 'keepalive memcached request again'); 139 | 140 | is($memd1->stats()->{total}->{total_connections}, $total + 1, 141 | 'only one connection used'); 142 | 143 | # Since nginx doesn't read all data from connection in some situations (head 144 | # requests, post_action, errors writing to client) we have to close such 145 | # connections. Check if we really do close them. 146 | 147 | $total = $memd1->stats()->{total}->{total_connections}; 148 | 149 | unlike(http_head('/'), qr/SEE-THIS/, 'head request'); 150 | like(http_get('/'), qr/SEE-THIS/, 'get after head'); 151 | 152 | is($memd1->stats()->{total}->{total_connections}, $total + 1, 153 | 'head request closes connection'); 154 | 155 | $total = $memd1->stats()->{total}->{total_connections}; 156 | 157 | unlike(http_head('/big'), qr/XXX/, 'big head'); 158 | like(http_get('/'), qr/SEE-THIS/, 'get after big head'); 159 | 160 | is($memd1->stats()->{total}->{total_connections}, $total + 1, 161 | 'big head request closes connection'); 162 | 163 | # two backends with 'single' option - should establish only one connection 164 | 165 | $total = $memd1->stats()->{total}->{total_connections} + 166 | $memd2->stats()->{total}->{total_connections}; 167 | 168 | http_get('/memd2'); 169 | http_get('/memd2'); 170 | http_get('/memd2'); 171 | 172 | is($memd1->stats()->{total}->{total_connections} + 173 | $memd2->stats()->{total}->{total_connections}, $total + 1, 174 | 'only one connection with two backends and single'); 175 | 176 | $total = $memd1->stats()->{total}->{total_connections} + 177 | $memd2->stats()->{total}->{total_connections}; 178 | 179 | # two backends without 'single' option and maximum number of cached 180 | # connections set to 1 - should establish new connection on each request 181 | 182 | http_get('/memd3'); 183 | http_get('/memd3'); 184 | http_get('/memd3'); 185 | 186 | is($memd1->stats()->{total}->{total_connections} + 187 | $memd2->stats()->{total}->{total_connections}, $total + 3, 188 | '3 connections should be established'); 189 | 190 | # two backends without 'single' option and maximum number of cached 191 | # connections set to 10 - should establish only two connections (1 per backend) 192 | 193 | $total = $memd1->stats()->{total}->{total_connections} + 194 | $memd2->stats()->{total}->{total_connections}; 195 | 196 | http_get('/memd4'); 197 | http_get('/memd4'); 198 | http_get('/memd4'); 199 | 200 | is($memd1->stats()->{total}->{total_connections} + 201 | $memd2->stats()->{total}->{total_connections}, $total + 2, 202 | 'connection per backend'); 203 | 204 | $t->stop(); 205 | 206 | like(`grep -F '[alert]' ${\($t->testdir())}/error.log`, qr/^$/s, 'no alerts'); 207 | 208 | ############################################################################### 209 | -------------------------------------------------------------------------------- /upstream_keepalive_1.0.5.patch: -------------------------------------------------------------------------------- 1 | diff --git a/src/event/ngx_event_pipe.c b/src/event/ngx_event_pipe.c 2 | index d01b204..02325b2 100644 3 | --- a/src/event/ngx_event_pipe.c 4 | +++ b/src/event/ngx_event_pipe.c 5 | @@ -10,7 +10,12 @@ 6 | #include 7 | 8 | 9 | +#if (NGX_ENABLE_UPSTREAM_KEEPALIVE) 10 | +static ngx_int_t ngx_event_pipe_read_upstream(ngx_event_pipe_t *p, 11 | + ngx_int_t do_flush); 12 | +#else 13 | static ngx_int_t ngx_event_pipe_read_upstream(ngx_event_pipe_t *p); 14 | +#endif 15 | static ngx_int_t ngx_event_pipe_write_to_downstream(ngx_event_pipe_t *p); 16 | 17 | static ngx_int_t ngx_event_pipe_write_chain_to_temp_file(ngx_event_pipe_t *p); 18 | @@ -47,7 +52,11 @@ ngx_event_pipe(ngx_event_pipe_t *p, ngx_int_t do_write) 19 | 20 | p->log->action = "reading upstream"; 21 | 22 | +#if (NGX_ENABLE_UPSTREAM_KEEPALIVE) 23 | + if (ngx_event_pipe_read_upstream(p, 0) == NGX_ABORT) { 24 | +#else 25 | if (ngx_event_pipe_read_upstream(p) == NGX_ABORT) { 26 | +#endif 27 | return NGX_ABORT; 28 | } 29 | 30 | @@ -95,8 +104,33 @@ ngx_event_pipe(ngx_event_pipe_t *p, ngx_int_t do_write) 31 | } 32 | 33 | 34 | +#if (NGX_ENABLE_UPSTREAM_KEEPALIVE) 35 | +ngx_int_t 36 | +ngx_event_pipe_flush(ngx_event_pipe_t *p) 37 | +{ 38 | + p->log->action = "reading upstream"; 39 | + 40 | + if (ngx_event_pipe_read_upstream(p, 1) == NGX_ABORT) { 41 | + return NGX_ABORT; 42 | + } 43 | + 44 | + p->log->action = "sending to client"; 45 | + 46 | + if (ngx_event_pipe_write_to_downstream(p) == NGX_ABORT) { 47 | + return NGX_ABORT; 48 | + } 49 | + 50 | + return NGX_OK; 51 | +} 52 | +#endif 53 | + 54 | + 55 | static ngx_int_t 56 | +#if (NGX_ENABLE_UPSTREAM_KEEPALIVE) 57 | +ngx_event_pipe_read_upstream(ngx_event_pipe_t *p, ngx_int_t do_flush) 58 | +#else 59 | ngx_event_pipe_read_upstream(ngx_event_pipe_t *p) 60 | +#endif 61 | { 62 | ssize_t n, size; 63 | ngx_int_t rc; 64 | @@ -104,6 +138,11 @@ ngx_event_pipe_read_upstream(ngx_event_pipe_t *p) 65 | ngx_chain_t *chain, *cl, *ln; 66 | 67 | if (p->upstream_eof || p->upstream_error || p->upstream_done) { 68 | +#if (NGX_ENABLE_UPSTREAM_KEEPALIVE) 69 | + if (do_flush) { 70 | + goto flush; 71 | + } 72 | +#endif 73 | return NGX_OK; 74 | } 75 | 76 | @@ -313,6 +352,9 @@ ngx_event_pipe_read_upstream(ngx_event_pipe_t *p) 77 | if (n >= size) { 78 | cl->buf->last = cl->buf->end; 79 | 80 | +#if (NGX_ENABLE_UPSTREAM_KEEPALIVE) 81 | + n -= size; 82 | +#else 83 | /* STUB */ cl->buf->num = p->num++; 84 | 85 | if (p->input_filter(p, cl->buf) == NGX_ERROR) { 86 | @@ -323,11 +365,29 @@ ngx_event_pipe_read_upstream(ngx_event_pipe_t *p) 87 | ln = cl; 88 | cl = cl->next; 89 | ngx_free_chain(p->pool, ln); 90 | +#endif 91 | 92 | } else { 93 | cl->buf->last += n; 94 | n = 0; 95 | +#if (NGX_ENABLE_UPSTREAM_KEEPALIVE) 96 | + if (cl->buf->last - cl->buf->pos < p->length) { 97 | + continue; 98 | + } 99 | +#endif 100 | } 101 | + 102 | +#if (NGX_ENABLE_UPSTREAM_KEEPALIVE) 103 | + /* STUB */ cl->buf->num = p->num++; 104 | + 105 | + if (p->input_filter(p, cl->buf) == NGX_ERROR) { 106 | + return NGX_ABORT; 107 | + } 108 | + 109 | + ln = cl; 110 | + cl = cl->next; 111 | + ngx_free_chain(p->pool, ln); 112 | +#endif 113 | } 114 | 115 | if (cl) { 116 | @@ -337,6 +397,9 @@ ngx_event_pipe_read_upstream(ngx_event_pipe_t *p) 117 | p->free_raw_bufs = cl; 118 | } 119 | } 120 | +#if (NGX_ENABLE_UPSTREAM_KEEPALIVE) 121 | +flush: 122 | +#endif 123 | 124 | #if (NGX_DEBUG) 125 | 126 | @@ -392,6 +455,11 @@ ngx_event_pipe_read_upstream(ngx_event_pipe_t *p) 127 | cl->buf->file_last - cl->buf->file_pos); 128 | } 129 | 130 | +#if (NGX_ENABLE_UPSTREAM_KEEPALIVE) 131 | + ngx_log_debug1(NGX_LOG_DEBUG_EVENT, p->log, 0, 132 | + "pipe length: %O", p->length); 133 | +#endif 134 | + 135 | #endif 136 | 137 | if ((p->upstream_eof || p->upstream_error) && p->free_raw_bufs) { 138 | @@ -848,6 +916,18 @@ ngx_event_pipe_copy_input_filter(ngx_event_pipe_t *p, ngx_buf_t *buf) 139 | } 140 | p->last_in = &cl->next; 141 | 142 | +#if (NGX_ENABLE_UPSTREAM_KEEPALIVE) 143 | + if (p->length == NGX_MAX_OFF_T_VALUE) { 144 | + return NGX_OK; 145 | + } 146 | + 147 | + p->length -= b->last - b->pos; 148 | + 149 | + if (p->length <= 0) { 150 | + p->upstream_done = 1; 151 | + } 152 | +#endif 153 | + 154 | return NGX_OK; 155 | } 156 | 157 | diff --git a/src/event/ngx_event_pipe.h b/src/event/ngx_event_pipe.h 158 | index 00b8acf..7fd921e 100644 159 | --- a/src/event/ngx_event_pipe.h 160 | +++ b/src/event/ngx_event_pipe.h 161 | @@ -65,6 +65,9 @@ struct ngx_event_pipe_s { 162 | ssize_t busy_size; 163 | 164 | off_t read_length; 165 | +#if (NGX_ENABLE_UPSTREAM_KEEPALIVE) 166 | + off_t length; 167 | +#endif 168 | 169 | off_t max_temp_file_size; 170 | ssize_t temp_file_write_size; 171 | @@ -87,6 +90,9 @@ struct ngx_event_pipe_s { 172 | 173 | 174 | ngx_int_t ngx_event_pipe(ngx_event_pipe_t *p, ngx_int_t do_write); 175 | +#if (NGX_ENABLE_UPSTREAM_KEEPALIVE) 176 | +ngx_int_t ngx_event_pipe_flush(ngx_event_pipe_t *p); 177 | +#endif 178 | ngx_int_t ngx_event_pipe_copy_input_filter(ngx_event_pipe_t *p, ngx_buf_t *buf); 179 | ngx_int_t ngx_event_pipe_add_free_buf(ngx_event_pipe_t *p, ngx_buf_t *b); 180 | 181 | diff --git a/src/http/modules/ngx_http_proxy_module.c b/src/http/modules/ngx_http_proxy_module.c 182 | index 214fe6a..00c1a0c 100644 183 | --- a/src/http/modules/ngx_http_proxy_module.c 184 | +++ b/src/http/modules/ngx_http_proxy_module.c 185 | @@ -611,6 +611,9 @@ ngx_http_proxy_handler(ngx_http_request_t *r) 186 | } 187 | 188 | u->pipe->input_filter = ngx_event_pipe_copy_input_filter; 189 | +#if (NGX_ENABLE_UPSTREAM_KEEPALIVE) 190 | + u->keepalive = 1; 191 | +#endif 192 | 193 | u->accel = 1; 194 | 195 | diff --git a/src/http/ngx_http_upstream.c b/src/http/ngx_http_upstream.c 196 | index ad5b449..77f0806 100644 197 | --- a/src/http/ngx_http_upstream.c 198 | +++ b/src/http/ngx_http_upstream.c 199 | @@ -2208,6 +2208,17 @@ ngx_http_upstream_send_response(ngx_http_request_t *r, ngx_http_upstream_t *u) 200 | p->pool = r->pool; 201 | p->log = c->log; 202 | 203 | +#if (NGX_ENABLE_UPSTREAM_KEEPALIVE) 204 | + if (r->headers_out.content_length_n != -1) { 205 | + 206 | + p->length = r->headers_out.content_length_n; 207 | + 208 | + } else { 209 | + p->length = NGX_MAX_OFF_T_VALUE; 210 | + } 211 | + 212 | +#endif 213 | + 214 | p->cacheable = u->cacheable || u->store; 215 | 216 | p->temp_file = ngx_pcalloc(r->pool, sizeof(ngx_temp_file_t)); 217 | @@ -2598,6 +2609,17 @@ ngx_http_upstream_process_upstream(ngx_http_request_t *r, 218 | u->pipe->upstream_error = 1; 219 | ngx_connection_error(c, NGX_ETIMEDOUT, "upstream timed out"); 220 | 221 | +#if (NGX_ENABLE_UPSTREAM_KEEPALIVE) 222 | + if (ngx_event_pipe_flush(u->pipe) == NGX_ABORT) { 223 | + 224 | + if (r->connection->destroyed) { 225 | + return; 226 | + } 227 | + 228 | + ngx_http_upstream_finalize_request(r, u, 0); 229 | + return; 230 | + } 231 | +#endif 232 | } else { 233 | if (ngx_event_pipe(u->pipe, 0) == NGX_ABORT) { 234 | ngx_http_upstream_finalize_request(r, u, 0); 235 | diff --git a/src/http/ngx_http_upstream.h b/src/http/ngx_http_upstream.h 236 | index 01e2e1e..21ecc52 100644 237 | --- a/src/http/ngx_http_upstream.h 238 | +++ b/src/http/ngx_http_upstream.h 239 | @@ -310,6 +310,9 @@ struct ngx_http_upstream_s { 240 | 241 | unsigned request_sent:1; 242 | unsigned header_sent:1; 243 | +#if (NGX_ENABLE_UPSTREAM_KEEPALIVE) 244 | + unsigned keepalive:1; 245 | +#endif 246 | }; 247 | 248 | 249 | -------------------------------------------------------------------------------- /test/inc/Module/Install/Makefile.pm: -------------------------------------------------------------------------------- 1 | #line 1 2 | package Module::Install::Makefile; 3 | 4 | use strict 'vars'; 5 | use ExtUtils::MakeMaker (); 6 | use Module::Install::Base (); 7 | 8 | use vars qw{$VERSION @ISA $ISCORE}; 9 | BEGIN { 10 | $VERSION = '0.91'; 11 | @ISA = 'Module::Install::Base'; 12 | $ISCORE = 1; 13 | } 14 | 15 | sub Makefile { $_[0] } 16 | 17 | my %seen = (); 18 | 19 | sub prompt { 20 | shift; 21 | 22 | # Infinite loop protection 23 | my @c = caller(); 24 | if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { 25 | die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; 26 | } 27 | 28 | # In automated testing, always use defaults 29 | if ( $ENV{AUTOMATED_TESTING} and ! $ENV{PERL_MM_USE_DEFAULT} ) { 30 | local $ENV{PERL_MM_USE_DEFAULT} = 1; 31 | goto &ExtUtils::MakeMaker::prompt; 32 | } else { 33 | goto &ExtUtils::MakeMaker::prompt; 34 | } 35 | } 36 | 37 | sub makemaker_args { 38 | my $self = shift; 39 | my $args = ( $self->{makemaker_args} ||= {} ); 40 | %$args = ( %$args, @_ ); 41 | return $args; 42 | } 43 | 44 | # For mm args that take multiple space-seperated args, 45 | # append an argument to the current list. 46 | sub makemaker_append { 47 | my $self = sShift; 48 | my $name = shift; 49 | my $args = $self->makemaker_args; 50 | $args->{name} = defined $args->{$name} 51 | ? join( ' ', $args->{name}, @_ ) 52 | : join( ' ', @_ ); 53 | } 54 | 55 | sub build_subdirs { 56 | my $self = shift; 57 | my $subdirs = $self->makemaker_args->{DIR} ||= []; 58 | for my $subdir (@_) { 59 | push @$subdirs, $subdir; 60 | } 61 | } 62 | 63 | sub clean_files { 64 | my $self = shift; 65 | my $clean = $self->makemaker_args->{clean} ||= {}; 66 | %$clean = ( 67 | %$clean, 68 | FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_), 69 | ); 70 | } 71 | 72 | sub realclean_files { 73 | my $self = shift; 74 | my $realclean = $self->makemaker_args->{realclean} ||= {}; 75 | %$realclean = ( 76 | %$realclean, 77 | FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_), 78 | ); 79 | } 80 | 81 | sub libs { 82 | my $self = shift; 83 | my $libs = ref $_[0] ? shift : [ shift ]; 84 | $self->makemaker_args( LIBS => $libs ); 85 | } 86 | 87 | sub inc { 88 | my $self = shift; 89 | $self->makemaker_args( INC => shift ); 90 | } 91 | 92 | my %test_dir = (); 93 | 94 | sub _wanted_t { 95 | /\.t$/ and -f $_ and $test_dir{$File::Find::dir} = 1; 96 | } 97 | 98 | sub tests_recursive { 99 | my $self = shift; 100 | if ( $self->tests ) { 101 | die "tests_recursive will not work if tests are already defined"; 102 | } 103 | my $dir = shift || 't'; 104 | unless ( -d $dir ) { 105 | die "tests_recursive dir '$dir' does not exist"; 106 | } 107 | %test_dir = (); 108 | require File::Find; 109 | File::Find::find( \&_wanted_t, $dir ); 110 | $self->tests( join ' ', map { "$_/*.t" } sort keys %test_dir ); 111 | } 112 | 113 | sub write { 114 | my $self = shift; 115 | die "&Makefile->write() takes no arguments\n" if @_; 116 | 117 | # Check the current Perl version 118 | my $perl_version = $self->perl_version; 119 | if ( $perl_version ) { 120 | eval "use $perl_version; 1" 121 | or die "ERROR: perl: Version $] is installed, " 122 | . "but we need version >= $perl_version"; 123 | } 124 | 125 | # Make sure we have a new enough MakeMaker 126 | require ExtUtils::MakeMaker; 127 | 128 | if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) { 129 | # MakeMaker can complain about module versions that include 130 | # an underscore, even though its own version may contain one! 131 | # Hence the funny regexp to get rid of it. See RT #35800 132 | # for details. 133 | $self->build_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/ ); 134 | $self->configure_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/ ); 135 | } else { 136 | # Allow legacy-compatibility with 5.005 by depending on the 137 | # most recent EU:MM that supported 5.005. 138 | $self->build_requires( 'ExtUtils::MakeMaker' => 6.42 ); 139 | $self->configure_requires( 'ExtUtils::MakeMaker' => 6.42 ); 140 | } 141 | 142 | # Generate the MakeMaker params 143 | my $args = $self->makemaker_args; 144 | $args->{DISTNAME} = $self->name; 145 | $args->{NAME} = $self->module_name || $self->name; 146 | $args->{VERSION} = $self->version; 147 | $args->{NAME} =~ s/-/::/g; 148 | if ( $self->tests ) { 149 | $args->{test} = { TESTS => $self->tests }; 150 | } 151 | if ( $] >= 5.005 ) { 152 | $args->{ABSTRACT} = $self->abstract; 153 | $args->{AUTHOR} = $self->author; 154 | } 155 | if ( eval($ExtUtils::MakeMaker::VERSION) >= 6.10 ) { 156 | $args->{NO_META} = 1; 157 | } 158 | if ( eval($ExtUtils::MakeMaker::VERSION) > 6.17 and $self->sign ) { 159 | $args->{SIGN} = 1; 160 | } 161 | unless ( $self->is_admin ) { 162 | delete $args->{SIGN}; 163 | } 164 | 165 | # Merge both kinds of requires into prereq_pm 166 | my $prereq = ($args->{PREREQ_PM} ||= {}); 167 | %$prereq = ( %$prereq, 168 | map { @$_ } 169 | map { @$_ } 170 | grep $_, 171 | ($self->configure_requires, $self->build_requires, $self->requires) 172 | ); 173 | 174 | # Remove any reference to perl, PREREQ_PM doesn't support it 175 | delete $args->{PREREQ_PM}->{perl}; 176 | 177 | # merge both kinds of requires into prereq_pm 178 | my $subdirs = ($args->{DIR} ||= []); 179 | if ($self->bundles) { 180 | foreach my $bundle (@{ $self->bundles }) { 181 | my ($file, $dir) = @$bundle; 182 | push @$subdirs, $dir if -d $dir; 183 | delete $prereq->{$file}; 184 | } 185 | } 186 | 187 | if ( my $perl_version = $self->perl_version ) { 188 | eval "use $perl_version; 1" 189 | or die "ERROR: perl: Version $] is installed, " 190 | . "but we need version >= $perl_version"; 191 | } 192 | 193 | $args->{INSTALLDIRS} = $self->installdirs; 194 | 195 | my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_})} keys %$args; 196 | 197 | my $user_preop = delete $args{dist}->{PREOP}; 198 | if (my $preop = $self->admin->preop($user_preop)) { 199 | foreach my $key ( keys %$preop ) { 200 | $args{dist}->{$key} = $preop->{$key}; 201 | } 202 | } 203 | 204 | my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); 205 | $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); 206 | } 207 | 208 | sub fix_up_makefile { 209 | my $self = shift; 210 | my $makefile_name = shift; 211 | my $top_class = ref($self->_top) || ''; 212 | my $top_version = $self->_top->VERSION || ''; 213 | 214 | my $preamble = $self->preamble 215 | ? "# Preamble by $top_class $top_version\n" 216 | . $self->preamble 217 | : ''; 218 | my $postamble = "# Postamble by $top_class $top_version\n" 219 | . ($self->postamble || ''); 220 | 221 | local *MAKEFILE; 222 | open MAKEFILE, "< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; 223 | my $makefile = do { local $/; }; 224 | close MAKEFILE or die $!; 225 | 226 | $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; 227 | $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; 228 | $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; 229 | $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; 230 | $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; 231 | 232 | # Module::Install will never be used to build the Core Perl 233 | # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks 234 | # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist 235 | $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; 236 | #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; 237 | 238 | # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well. 239 | $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g; 240 | 241 | # XXX - This is currently unused; not sure if it breaks other MM-users 242 | # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; 243 | 244 | open MAKEFILE, "> $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; 245 | print MAKEFILE "$preamble$makefile$postamble" or die $!; 246 | close MAKEFILE or die $!; 247 | 248 | 1; 249 | } 250 | 251 | sub preamble { 252 | my ($self, $text) = @_; 253 | $self->{preamble} = $text . $self->{preamble} if defined $text; 254 | $self->{preamble}; 255 | } 256 | 257 | sub postamble { 258 | my ($self, $text) = @_; 259 | $self->{postamble} ||= $self->admin->postamble; 260 | $self->{postamble} .= $text if defined $text; 261 | $self->{postamble} 262 | } 263 | 264 | 1; 265 | 266 | __END__ 267 | 268 | #line 394 269 | -------------------------------------------------------------------------------- /test/inc/Test/Base/Filter.pm: -------------------------------------------------------------------------------- 1 | #line 1 2 | #. TODO: 3 | #. 4 | 5 | #=============================================================================== 6 | # This is the default class for handling Test::Base data filtering. 7 | #=============================================================================== 8 | package Test::Base::Filter; 9 | use Spiffy -Base; 10 | use Spiffy ':XXX'; 11 | 12 | field 'current_block'; 13 | 14 | our $arguments; 15 | sub current_arguments { 16 | return undef unless defined $arguments; 17 | my $args = $arguments; 18 | $args =~ s/(\\s)/ /g; 19 | $args =~ s/(\\[a-z])/'"' . $1 . '"'/gee; 20 | return $args; 21 | } 22 | 23 | sub assert_scalar { 24 | return if @_ == 1; 25 | require Carp; 26 | my $filter = (caller(1))[3]; 27 | $filter =~ s/.*:://; 28 | Carp::croak "Input to the '$filter' filter must be a scalar, not a list"; 29 | } 30 | 31 | sub _apply_deepest { 32 | my $method = shift; 33 | return () unless @_; 34 | if (ref $_[0] eq 'ARRAY') { 35 | for my $aref (@_) { 36 | @$aref = $self->_apply_deepest($method, @$aref); 37 | } 38 | return @_; 39 | } 40 | $self->$method(@_); 41 | } 42 | 43 | sub _split_array { 44 | map { 45 | [$self->split($_)]; 46 | } @_; 47 | } 48 | 49 | sub _peel_deepest { 50 | return () unless @_; 51 | if (ref $_[0] eq 'ARRAY') { 52 | if (ref $_[0]->[0] eq 'ARRAY') { 53 | for my $aref (@_) { 54 | @$aref = $self->_peel_deepest(@$aref); 55 | } 56 | return @_; 57 | } 58 | return map { $_->[0] } @_; 59 | } 60 | return @_; 61 | } 62 | 63 | #=============================================================================== 64 | # these filters work on the leaves of nested arrays 65 | #=============================================================================== 66 | sub Join { $self->_peel_deepest($self->_apply_deepest(join => @_)) } 67 | sub Reverse { $self->_apply_deepest(reverse => @_) } 68 | sub Split { $self->_apply_deepest(_split_array => @_) } 69 | sub Sort { $self->_apply_deepest(sort => @_) } 70 | 71 | 72 | sub append { 73 | my $suffix = $self->current_arguments; 74 | map { $_ . $suffix } @_; 75 | } 76 | 77 | sub array { 78 | return [@_]; 79 | } 80 | 81 | sub base64_decode { 82 | $self->assert_scalar(@_); 83 | require MIME::Base64; 84 | MIME::Base64::decode_base64(shift); 85 | } 86 | 87 | sub base64_encode { 88 | $self->assert_scalar(@_); 89 | require MIME::Base64; 90 | MIME::Base64::encode_base64(shift); 91 | } 92 | 93 | sub chomp { 94 | map { CORE::chomp; $_ } @_; 95 | } 96 | 97 | sub chop { 98 | map { CORE::chop; $_ } @_; 99 | } 100 | 101 | sub dumper { 102 | no warnings 'once'; 103 | require Data::Dumper; 104 | local $Data::Dumper::Sortkeys = 1; 105 | local $Data::Dumper::Indent = 1; 106 | local $Data::Dumper::Terse = 1; 107 | Data::Dumper::Dumper(@_); 108 | } 109 | 110 | sub escape { 111 | $self->assert_scalar(@_); 112 | my $text = shift; 113 | $text =~ s/(\\.)/eval "qq{$1}"/ge; 114 | return $text; 115 | } 116 | 117 | sub eval { 118 | $self->assert_scalar(@_); 119 | my @return = CORE::eval(shift); 120 | return $@ if $@; 121 | return @return; 122 | } 123 | 124 | sub eval_all { 125 | $self->assert_scalar(@_); 126 | my $out = ''; 127 | my $err = ''; 128 | Test::Base::tie_output(*STDOUT, $out); 129 | Test::Base::tie_output(*STDERR, $err); 130 | my $return = CORE::eval(shift); 131 | no warnings; 132 | untie *STDOUT; 133 | untie *STDERR; 134 | return $return, $@, $out, $err; 135 | } 136 | 137 | sub eval_stderr { 138 | $self->assert_scalar(@_); 139 | my $output = ''; 140 | Test::Base::tie_output(*STDERR, $output); 141 | CORE::eval(shift); 142 | no warnings; 143 | untie *STDERR; 144 | return $output; 145 | } 146 | 147 | sub eval_stdout { 148 | $self->assert_scalar(@_); 149 | my $output = ''; 150 | Test::Base::tie_output(*STDOUT, $output); 151 | CORE::eval(shift); 152 | no warnings; 153 | untie *STDOUT; 154 | return $output; 155 | } 156 | 157 | sub exec_perl_stdout { 158 | my $tmpfile = "/tmp/test-blocks-$$"; 159 | $self->_write_to($tmpfile, @_); 160 | open my $execution, "$^X $tmpfile 2>&1 |" 161 | or die "Couldn't open subprocess: $!\n"; 162 | local $/; 163 | my $output = <$execution>; 164 | close $execution; 165 | unlink($tmpfile) 166 | or die "Couldn't unlink $tmpfile: $!\n"; 167 | return $output; 168 | } 169 | 170 | sub flatten { 171 | $self->assert_scalar(@_); 172 | my $ref = shift; 173 | if (ref($ref) eq 'HASH') { 174 | return map { 175 | ($_, $ref->{$_}); 176 | } sort keys %$ref; 177 | } 178 | if (ref($ref) eq 'ARRAY') { 179 | return @$ref; 180 | } 181 | die "Can only flatten a hash or array ref"; 182 | } 183 | 184 | sub get_url { 185 | $self->assert_scalar(@_); 186 | my $url = shift; 187 | CORE::chomp($url); 188 | require LWP::Simple; 189 | LWP::Simple::get($url); 190 | } 191 | 192 | sub hash { 193 | return +{ @_ }; 194 | } 195 | 196 | sub head { 197 | my $size = $self->current_arguments || 1; 198 | return splice(@_, 0, $size); 199 | } 200 | 201 | sub join { 202 | my $string = $self->current_arguments; 203 | $string = '' unless defined $string; 204 | CORE::join $string, @_; 205 | } 206 | 207 | sub lines { 208 | $self->assert_scalar(@_); 209 | my $text = shift; 210 | return () unless length $text; 211 | my @lines = ($text =~ /^(.*\n?)/gm); 212 | return @lines; 213 | } 214 | 215 | sub norm { 216 | $self->assert_scalar(@_); 217 | my $text = shift; 218 | $text = '' unless defined $text; 219 | $text =~ s/\015\012/\n/g; 220 | $text =~ s/\r/\n/g; 221 | return $text; 222 | } 223 | 224 | sub prepend { 225 | my $prefix = $self->current_arguments; 226 | map { $prefix . $_ } @_; 227 | } 228 | 229 | sub read_file { 230 | $self->assert_scalar(@_); 231 | my $file = shift; 232 | CORE::chomp $file; 233 | open my $fh, $file 234 | or die "Can't open '$file' for input:\n$!"; 235 | CORE::join '', <$fh>; 236 | } 237 | 238 | sub regexp { 239 | $self->assert_scalar(@_); 240 | my $text = shift; 241 | my $flags = $self->current_arguments; 242 | if ($text =~ /\n.*?\n/s) { 243 | $flags = 'xism' 244 | unless defined $flags; 245 | } 246 | else { 247 | CORE::chomp($text); 248 | } 249 | $flags ||= ''; 250 | my $regexp = eval "qr{$text}$flags"; 251 | die $@ if $@; 252 | return $regexp; 253 | } 254 | 255 | sub reverse { 256 | CORE::reverse(@_); 257 | } 258 | 259 | sub slice { 260 | die "Invalid args for slice" 261 | unless $self->current_arguments =~ /^(\d+)(?:,(\d))?$/; 262 | my ($x, $y) = ($1, $2); 263 | $y = $x if not defined $y; 264 | die "Invalid args for slice" 265 | if $x > $y; 266 | return splice(@_, $x, 1 + $y - $x); 267 | } 268 | 269 | sub sort { 270 | CORE::sort(@_); 271 | } 272 | 273 | sub split { 274 | $self->assert_scalar(@_); 275 | my $separator = $self->current_arguments; 276 | if (defined $separator and $separator =~ s{^/(.*)/$}{$1}) { 277 | my $regexp = $1; 278 | $separator = qr{$regexp}; 279 | } 280 | $separator = qr/\s+/ unless $separator; 281 | CORE::split $separator, shift; 282 | } 283 | 284 | sub strict { 285 | $self->assert_scalar(@_); 286 | <<'...' . shift; 287 | use strict; 288 | use warnings; 289 | ... 290 | } 291 | 292 | sub tail { 293 | my $size = $self->current_arguments || 1; 294 | return splice(@_, @_ - $size, $size); 295 | } 296 | 297 | sub trim { 298 | map { 299 | s/\A([ \t]*\n)+//; 300 | s/(?<=\n)\s*\z//g; 301 | $_; 302 | } @_; 303 | } 304 | 305 | sub unchomp { 306 | map { $_ . "\n" } @_; 307 | } 308 | 309 | sub write_file { 310 | my $file = $self->current_arguments 311 | or die "No file specified for write_file filter"; 312 | if ($file =~ /(.*)[\\\/]/) { 313 | my $dir = $1; 314 | if (not -e $dir) { 315 | require File::Path; 316 | File::Path::mkpath($dir) 317 | or die "Can't create $dir"; 318 | } 319 | } 320 | open my $fh, ">$file" 321 | or die "Can't open '$file' for output\n:$!"; 322 | print $fh @_; 323 | close $fh; 324 | return $file; 325 | } 326 | 327 | sub yaml { 328 | $self->assert_scalar(@_); 329 | require YAML; 330 | return YAML::Load(shift); 331 | } 332 | 333 | sub _write_to { 334 | my $filename = shift; 335 | open my $script, ">$filename" 336 | or die "Couldn't open $filename: $!\n"; 337 | print $script @_; 338 | close $script 339 | or die "Couldn't close $filename: $!\n"; 340 | } 341 | 342 | __DATA__ 343 | 344 | #line 639 345 | -------------------------------------------------------------------------------- /test/inc/Module/Install.pm: -------------------------------------------------------------------------------- 1 | #line 1 2 | package Module::Install; 3 | 4 | # For any maintainers: 5 | # The load order for Module::Install is a bit magic. 6 | # It goes something like this... 7 | # 8 | # IF ( host has Module::Install installed, creating author mode ) { 9 | # 1. Makefile.PL calls "use inc::Module::Install" 10 | # 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install 11 | # 3. The installed version of inc::Module::Install loads 12 | # 4. inc::Module::Install calls "require Module::Install" 13 | # 5. The ./inc/ version of Module::Install loads 14 | # } ELSE { 15 | # 1. Makefile.PL calls "use inc::Module::Install" 16 | # 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install 17 | # 3. The ./inc/ version of Module::Install loads 18 | # } 19 | 20 | use 5.005; 21 | use strict 'vars'; 22 | 23 | use vars qw{$VERSION $MAIN}; 24 | BEGIN { 25 | # All Module::Install core packages now require synchronised versions. 26 | # This will be used to ensure we don't accidentally load old or 27 | # different versions of modules. 28 | # This is not enforced yet, but will be some time in the next few 29 | # releases once we can make sure it won't clash with custom 30 | # Module::Install extensions. 31 | $VERSION = '0.91'; 32 | 33 | # Storage for the pseudo-singleton 34 | $MAIN = undef; 35 | 36 | *inc::Module::Install::VERSION = *VERSION; 37 | @inc::Module::Install::ISA = __PACKAGE__; 38 | 39 | } 40 | 41 | 42 | 43 | 44 | 45 | # Whether or not inc::Module::Install is actually loaded, the 46 | # $INC{inc/Module/Install.pm} is what will still get set as long as 47 | # the caller loaded module this in the documented manner. 48 | # If not set, the caller may NOT have loaded the bundled version, and thus 49 | # they may not have a MI version that works with the Makefile.PL. This would 50 | # result in false errors or unexpected behaviour. And we don't want that. 51 | my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; 52 | unless ( $INC{$file} ) { die <<"END_DIE" } 53 | 54 | Please invoke ${\__PACKAGE__} with: 55 | 56 | use inc::${\__PACKAGE__}; 57 | 58 | not: 59 | 60 | use ${\__PACKAGE__}; 61 | 62 | END_DIE 63 | 64 | 65 | 66 | 67 | 68 | # If the script that is loading Module::Install is from the future, 69 | # then make will detect this and cause it to re-run over and over 70 | # again. This is bad. Rather than taking action to touch it (which 71 | # is unreliable on some platforms and requires write permissions) 72 | # for now we should catch this and refuse to run. 73 | if ( -f $0 ) { 74 | my $s = (stat($0))[9]; 75 | 76 | # If the modification time is only slightly in the future, 77 | # sleep briefly to remove the problem. 78 | my $a = $s - time; 79 | if ( $a > 0 and $a < 5 ) { sleep 5 } 80 | 81 | # Too far in the future, throw an error. 82 | my $t = time; 83 | if ( $s > $t ) { die <<"END_DIE" } 84 | 85 | Your installer $0 has a modification time in the future ($s > $t). 86 | 87 | This is known to create infinite loops in make. 88 | 89 | Please correct this, then run $0 again. 90 | 91 | END_DIE 92 | } 93 | 94 | 95 | 96 | 97 | 98 | # Build.PL was formerly supported, but no longer is due to excessive 99 | # difficulty in implementing every single feature twice. 100 | if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } 101 | 102 | Module::Install no longer supports Build.PL. 103 | 104 | It was impossible to maintain duel backends, and has been deprecated. 105 | 106 | Please remove all Build.PL files and only use the Makefile.PL installer. 107 | 108 | END_DIE 109 | 110 | 111 | 112 | 113 | 114 | # To save some more typing in Module::Install installers, every... 115 | # use inc::Module::Install 116 | # ...also acts as an implicit use strict. 117 | $^H |= strict::bits(qw(refs subs vars)); 118 | 119 | 120 | 121 | 122 | 123 | use Cwd (); 124 | use File::Find (); 125 | use File::Path (); 126 | use FindBin; 127 | 128 | sub autoload { 129 | my $self = shift; 130 | my $who = $self->_caller; 131 | my $cwd = Cwd::cwd(); 132 | my $sym = "${who}::AUTOLOAD"; 133 | $sym->{$cwd} = sub { 134 | my $pwd = Cwd::cwd(); 135 | if ( my $code = $sym->{$pwd} ) { 136 | # Delegate back to parent dirs 137 | goto &$code unless $cwd eq $pwd; 138 | } 139 | $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym"; 140 | my $method = $1; 141 | if ( uc($method) eq $method ) { 142 | # Do nothing 143 | return; 144 | } elsif ( $method =~ /^_/ and $self->can($method) ) { 145 | # Dispatch to the root M:I class 146 | return $self->$method(@_); 147 | } 148 | 149 | # Dispatch to the appropriate plugin 150 | unshift @_, ( $self, $1 ); 151 | goto &{$self->can('call')}; 152 | }; 153 | } 154 | 155 | sub import { 156 | my $class = shift; 157 | my $self = $class->new(@_); 158 | my $who = $self->_caller; 159 | 160 | unless ( -f $self->{file} ) { 161 | require "$self->{path}/$self->{dispatch}.pm"; 162 | File::Path::mkpath("$self->{prefix}/$self->{author}"); 163 | $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); 164 | $self->{admin}->init; 165 | @_ = ($class, _self => $self); 166 | goto &{"$self->{name}::import"}; 167 | } 168 | 169 | *{"${who}::AUTOLOAD"} = $self->autoload; 170 | $self->preload; 171 | 172 | # Unregister loader and worker packages so subdirs can use them again 173 | delete $INC{"$self->{file}"}; 174 | delete $INC{"$self->{path}.pm"}; 175 | 176 | # Save to the singleton 177 | $MAIN = $self; 178 | 179 | return 1; 180 | } 181 | 182 | sub preload { 183 | my $self = shift; 184 | unless ( $self->{extensions} ) { 185 | $self->load_extensions( 186 | "$self->{prefix}/$self->{path}", $self 187 | ); 188 | } 189 | 190 | my @exts = @{$self->{extensions}}; 191 | unless ( @exts ) { 192 | @exts = $self->{admin}->load_all_extensions; 193 | } 194 | 195 | my %seen; 196 | foreach my $obj ( @exts ) { 197 | while (my ($method, $glob) = each %{ref($obj) . '::'}) { 198 | next unless $obj->can($method); 199 | next if $method =~ /^_/; 200 | next if $method eq uc($method); 201 | $seen{$method}++; 202 | } 203 | } 204 | 205 | my $who = $self->_caller; 206 | foreach my $name ( sort keys %seen ) { 207 | *{"${who}::$name"} = sub { 208 | ${"${who}::AUTOLOAD"} = "${who}::$name"; 209 | goto &{"${who}::AUTOLOAD"}; 210 | }; 211 | } 212 | } 213 | 214 | sub new { 215 | my ($class, %args) = @_; 216 | 217 | # ignore the prefix on extension modules built from top level. 218 | my $base_path = Cwd::abs_path($FindBin::Bin); 219 | unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) { 220 | delete $args{prefix}; 221 | } 222 | 223 | return $args{_self} if $args{_self}; 224 | 225 | $args{dispatch} ||= 'Admin'; 226 | $args{prefix} ||= 'inc'; 227 | $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); 228 | $args{bundle} ||= 'inc/BUNDLES'; 229 | $args{base} ||= $base_path; 230 | $class =~ s/^\Q$args{prefix}\E:://; 231 | $args{name} ||= $class; 232 | $args{version} ||= $class->VERSION; 233 | unless ( $args{path} ) { 234 | $args{path} = $args{name}; 235 | $args{path} =~ s!::!/!g; 236 | } 237 | $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; 238 | $args{wrote} = 0; 239 | 240 | bless( \%args, $class ); 241 | } 242 | 243 | sub call { 244 | my ($self, $method) = @_; 245 | my $obj = $self->load($method) or return; 246 | splice(@_, 0, 2, $obj); 247 | goto &{$obj->can($method)}; 248 | } 249 | 250 | sub load { 251 | my ($self, $method) = @_; 252 | 253 | $self->load_extensions( 254 | "$self->{prefix}/$self->{path}", $self 255 | ) unless $self->{extensions}; 256 | 257 | foreach my $obj (@{$self->{extensions}}) { 258 | return $obj if $obj->can($method); 259 | } 260 | 261 | my $admin = $self->{admin} or die <<"END_DIE"; 262 | The '$method' method does not exist in the '$self->{prefix}' path! 263 | Please remove the '$self->{prefix}' directory and run $0 again to load it. 264 | END_DIE 265 | 266 | my $obj = $admin->load($method, 1); 267 | push @{$self->{extensions}}, $obj; 268 | 269 | $obj; 270 | } 271 | 272 | sub load_extensions { 273 | my ($self, $path, $top) = @_; 274 | 275 | unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { 276 | unshift @INC, $self->{prefix}; 277 | } 278 | 279 | foreach my $rv ( $self->find_extensions($path) ) { 280 | my ($file, $pkg) = @{$rv}; 281 | next if $self->{pathnames}{$pkg}; 282 | 283 | local $@; 284 | my $new = eval { require $file; $pkg->can('new') }; 285 | unless ( $new ) { 286 | warn $@ if $@; 287 | next; 288 | } 289 | $self->{pathnames}{$pkg} = delete $INC{$file}; 290 | push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); 291 | } 292 | 293 | $self->{extensions} ||= []; 294 | } 295 | 296 | sub find_extensions { 297 | my ($self, $path) = @_; 298 | 299 | my @found; 300 | File::Find::find( sub { 301 | my $file = $File::Find::name; 302 | return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; 303 | my $subpath = $1; 304 | return if lc($subpath) eq lc($self->{dispatch}); 305 | 306 | $file = "$self->{path}/$subpath.pm"; 307 | my $pkg = "$self->{name}::$subpath"; 308 | $pkg =~ s!/!::!g; 309 | 310 | # If we have a mixed-case package name, assume case has been preserved 311 | # correctly. Otherwise, root through the file to locate the case-preserved 312 | # version of the package name. 313 | if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { 314 | my $content = Module::Install::_read($subpath . '.pm'); 315 | my $in_pod = 0; 316 | foreach ( split //, $content ) { 317 | $in_pod = 1 if /^=\w/; 318 | $in_pod = 0 if /^=cut/; 319 | next if ($in_pod || /^=cut/); # skip pod text 320 | next if /^\s*#/; # and comments 321 | if ( m/^\s*package\s+($pkg)\s*;/i ) { 322 | $pkg = $1; 323 | last; 324 | } 325 | } 326 | } 327 | 328 | push @found, [ $file, $pkg ]; 329 | }, $path ) if -d $path; 330 | 331 | @found; 332 | } 333 | 334 | 335 | 336 | 337 | 338 | ##################################################################### 339 | # Common Utility Functions 340 | 341 | sub _caller { 342 | my $depth = 0; 343 | my $call = caller($depth); 344 | while ( $call eq __PACKAGE__ ) { 345 | $depth++; 346 | $call = caller($depth); 347 | } 348 | return $call; 349 | } 350 | 351 | sub _read { 352 | local *FH; 353 | if ( $] >= 5.006 ) { 354 | open( FH, '<', $_[0] ) or die "open($_[0]): $!"; 355 | } else { 356 | open( FH, "< $_[0]" ) or die "open($_[0]): $!"; 357 | } 358 | my $string = do { local $/; }; 359 | close FH or die "close($_[0]): $!"; 360 | return $string; 361 | } 362 | 363 | sub _readperl { 364 | my $string = Module::Install::_read($_[0]); 365 | $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; 366 | $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s; 367 | $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg; 368 | return $string; 369 | } 370 | 371 | sub _readpod { 372 | my $string = Module::Install::_read($_[0]); 373 | $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; 374 | return $string if $_[0] =~ /\.pod\z/; 375 | $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg; 376 | $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg; 377 | $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg; 378 | $string =~ s/^\n+//s; 379 | return $string; 380 | } 381 | 382 | sub _write { 383 | local *FH; 384 | if ( $] >= 5.006 ) { 385 | open( FH, '>', $_[0] ) or die "open($_[0]): $!"; 386 | } else { 387 | open( FH, "> $_[0]" ) or die "open($_[0]): $!"; 388 | } 389 | foreach ( 1 .. $#_ ) { 390 | print FH $_[$_] or die "print($_[0]): $!"; 391 | } 392 | close FH or die "close($_[0]): $!"; 393 | } 394 | 395 | # _version is for processing module versions (eg, 1.03_05) not 396 | # Perl versions (eg, 5.8.1). 397 | sub _version ($) { 398 | my $s = shift || 0; 399 | my $d =()= $s =~ /(\.)/g; 400 | if ( $d >= 2 ) { 401 | # Normalise multipart versions 402 | $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg; 403 | } 404 | $s =~ s/^(\d+)\.?//; 405 | my $l = $1 || 0; 406 | my @v = map { 407 | $_ . '0' x (3 - length $_) 408 | } $s =~ /(\d{1,3})\D?/g; 409 | $l = $l . '.' . join '', @v if @v; 410 | return $l + 0; 411 | } 412 | 413 | sub _cmp ($$) { 414 | _version($_[0]) <=> _version($_[1]); 415 | } 416 | 417 | # Cloned from Params::Util::_CLASS 418 | sub _CLASS ($) { 419 | ( 420 | defined $_[0] 421 | and 422 | ! ref $_[0] 423 | and 424 | $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s 425 | ) ? $_[0] : undef; 426 | } 427 | 428 | 1; 429 | 430 | # Copyright 2008 - 2009 Adam Kennedy. 431 | -------------------------------------------------------------------------------- /test/lib/Test/Nginx/Util.pm: -------------------------------------------------------------------------------- 1 | package Test::Nginx::Util; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | our $VERSION = '0.08'; 7 | 8 | use base 'Exporter'; 9 | 10 | use POSIX qw( SIGQUIT SIGKILL SIGTERM ); 11 | use File::Spec (); 12 | use HTTP::Response; 13 | use Module::Install::Can; 14 | use Cwd qw( cwd ); 15 | use List::Util qw( shuffle ); 16 | use Time::HiRes qw( sleep ); 17 | 18 | our $NoNginxManager = 0; 19 | our $Profiling = 0; 20 | 21 | our $RepeatEach = 1; 22 | our $MAX_PROCESSES = 10; 23 | 24 | our $NoShuffle = 1; 25 | 26 | sub no_shuffle () { 27 | $NoShuffle = 1; 28 | } 29 | 30 | our $ForkManager; 31 | 32 | if ($Profiling) { 33 | eval "use Parallel::ForkManager"; 34 | if ($@) { 35 | die "Failed to load Parallel::ForkManager: $@\n"; 36 | } 37 | $ForkManager = new Parallel::ForkManager($MAX_PROCESSES); 38 | } 39 | 40 | our $Workers = 1; 41 | our $WorkerConnections = 64; 42 | our $LogLevel = 'debug'; 43 | our $MasterProcessEnabled = 'on'; 44 | our $DaemonEnabled = 'on'; 45 | our $ServerPort = 1984; 46 | our $ServerPortForClient = 1984; 47 | our $NoRootLocation = 1; 48 | 49 | 50 | sub repeat_each (@) { 51 | if (@_) { 52 | $RepeatEach = shift; 53 | } else { 54 | return $RepeatEach; 55 | } 56 | } 57 | 58 | sub worker_connections (@) { 59 | if (@_) { 60 | $WorkerConnections = shift; 61 | } else { 62 | return $WorkerConnections; 63 | } 64 | } 65 | 66 | sub no_root_location () { 67 | $NoRootLocation = 1; 68 | } 69 | 70 | sub workers (@) { 71 | if (@_) { 72 | #warn "setting workers to $_[0]"; 73 | $Workers = shift; 74 | } else { 75 | return $Workers; 76 | } 77 | } 78 | 79 | sub log_level (@) { 80 | if (@_) { 81 | $LogLevel = shift; 82 | } else { 83 | return $LogLevel; 84 | } 85 | } 86 | 87 | sub master_on () { 88 | $MasterProcessEnabled = 'on'; 89 | } 90 | 91 | sub master_process_enabled (@) { 92 | if (@_) { 93 | $MasterProcessEnabled = shift() ? 'on' : 'off'; 94 | } else { 95 | return $MasterProcessEnabled; 96 | } 97 | } 98 | 99 | our @EXPORT_OK = qw( 100 | setup_server_root 101 | write_config_file 102 | get_canon_version 103 | get_nginx_version 104 | trim 105 | show_all_chars 106 | parse_headers 107 | run_tests 108 | $ServerPortForClient 109 | $ServerPort 110 | $NginxVersion 111 | $PidFile 112 | $ServRoot 113 | $ConfFile 114 | $RunTestHelper 115 | $NoNginxManager 116 | $RepeatEach 117 | worker_connections 118 | workers 119 | master_on 120 | config_preamble 121 | repeat_each 122 | master_process_enabled 123 | log_level 124 | no_shuffle 125 | no_root_location 126 | ); 127 | 128 | 129 | if ($Profiling) { 130 | $DaemonEnabled = 'off'; 131 | $MasterProcessEnabled = 'off'; 132 | } 133 | 134 | our $ConfigPreamble = ''; 135 | 136 | sub config_preamble ($) { 137 | $ConfigPreamble = shift; 138 | } 139 | 140 | our $RunTestHelper; 141 | 142 | our $NginxVersion; 143 | our $NginxRawVersion; 144 | our $TODO; 145 | 146 | #our ($PrevRequest, $PrevConfig); 147 | 148 | our $ServRoot = File::Spec->catfile(cwd(), 't/servroot'); 149 | our $LogDir = File::Spec->catfile($ServRoot, 'logs'); 150 | our $ErrLogFile = File::Spec->catfile($LogDir, 'error.log'); 151 | our $AccLogFile = File::Spec->catfile($LogDir, 'access.log'); 152 | our $HtmlDir = File::Spec->catfile($ServRoot, 'html'); 153 | our $ConfDir = File::Spec->catfile($ServRoot, 'conf'); 154 | our $ConfFile = File::Spec->catfile($ConfDir, 'nginx.conf'); 155 | our $PidFile = File::Spec->catfile($LogDir, 'nginx.pid'); 156 | 157 | sub run_tests () { 158 | $NginxVersion = get_nginx_version(); 159 | 160 | if (defined $NginxVersion) { 161 | #warn "[INFO] Using nginx version $NginxVersion ($NginxRawVersion)\n"; 162 | } 163 | 164 | for my $block ($NoShuffle ? Test::Base::blocks() : shuffle Test::Base::blocks()) { 165 | #for (1..3) { 166 | run_test($block); 167 | #} 168 | } 169 | 170 | if ($Profiling) { 171 | $ForkManager->wait_all_children; 172 | } 173 | } 174 | 175 | sub setup_server_root () { 176 | if (-d $ServRoot) { 177 | #sleep 0.5; 178 | #die ".pid file $PidFile exists.\n"; 179 | system("rm -rf t/servroot > /dev/null") == 0 or 180 | die "Can't remove t/servroot"; 181 | #sleep 0.5; 182 | } 183 | mkdir $ServRoot or 184 | die "Failed to do mkdir $ServRoot\n"; 185 | mkdir $LogDir or 186 | die "Failed to do mkdir $LogDir\n"; 187 | mkdir $HtmlDir or 188 | die "Failed to do mkdir $HtmlDir\n"; 189 | 190 | my $index_file = "$HtmlDir/index.html"; 191 | 192 | open my $out, ">$index_file" or 193 | die "Can't open $index_file for writing: $!\n"; 194 | 195 | print $out 'It works!It works!'; 196 | 197 | close $out; 198 | 199 | mkdir $ConfDir or 200 | die "Failed to do mkdir $ConfDir\n"; 201 | } 202 | 203 | sub write_config_file ($$) { 204 | my ($config, $http_config) = @_; 205 | 206 | if (!defined $config) { 207 | $config = ''; 208 | } 209 | 210 | if (!defined $http_config) { 211 | $http_config = ''; 212 | } 213 | 214 | open my $out, ">$ConfFile" or 215 | die "Can't open $ConfFile for writing: $!\n"; 216 | print $out <<_EOC_; 217 | worker_processes $Workers; 218 | daemon $DaemonEnabled; 219 | master_process $MasterProcessEnabled; 220 | error_log $ErrLogFile $LogLevel; 221 | pid $PidFile; 222 | 223 | http { 224 | access_log $AccLogFile; 225 | 226 | default_type text/plain; 227 | keepalive_timeout 68; 228 | 229 | $http_config 230 | 231 | server { 232 | listen $ServerPort; 233 | #server_name "_"; 234 | 235 | client_max_body_size 30M; 236 | #client_body_buffer_size 4k; 237 | 238 | # Begin preamble config... 239 | $ConfigPreamble 240 | # End preamble config... 241 | 242 | # Begin test case config... 243 | $config 244 | # End test case config. 245 | 246 | _EOC_ 247 | 248 | if (! $NoRootLocation) { 249 | print $out <<_EOC_; 250 | location / { 251 | root $HtmlDir; 252 | index index.html index.htm; 253 | } 254 | _EOC_ 255 | } 256 | 257 | print $out <<_EOC_; 258 | } 259 | } 260 | 261 | events { 262 | worker_connections $WorkerConnections; 263 | } 264 | 265 | _EOC_ 266 | close $out; 267 | } 268 | 269 | sub get_canon_version (@) { 270 | sprintf "%d.%03d%03d", $_[0], $_[1], $_[2]; 271 | } 272 | 273 | sub get_nginx_version () { 274 | my $out = `nginx -V 2>&1`; 275 | if (!defined $out || $? != 0) { 276 | warn "Failed to get the version of the Nginx in PATH.\n"; 277 | } 278 | if ($out =~ m{nginx/(\d+)\.(\d+)\.(\d+)}s) { 279 | $NginxRawVersion = "$1.$2.$3"; 280 | return get_canon_version($1, $2, $3); 281 | } 282 | warn "Failed to parse the output of \"nginx -V\": $out\n"; 283 | return undef; 284 | } 285 | 286 | sub get_pid_from_pidfile ($) { 287 | my ($name) = @_; 288 | open my $in, $PidFile or 289 | Test::More::BAIL_OUT("$name - Failed to open the pid file $PidFile for reading: $!"); 290 | my $pid = do { local $/; <$in> }; 291 | #warn "Pid: $pid\n"; 292 | close $in; 293 | $pid; 294 | } 295 | 296 | sub trim ($) { 297 | (my $s = shift) =~ s/^\s+|\s+$//g; 298 | $s =~ s/\n/ /gs; 299 | $s =~ s/\s{2,}/ /gs; 300 | $s; 301 | } 302 | 303 | sub show_all_chars ($) { 304 | my $s = shift; 305 | $s =~ s/\n/\\n/gs; 306 | $s =~ s/\r/\\r/gs; 307 | $s =~ s/\t/\\t/gs; 308 | $s; 309 | } 310 | 311 | sub parse_headers ($) { 312 | my $s = shift; 313 | my %headers; 314 | open my $in, '<', \$s; 315 | while (<$in>) { 316 | s/^\s+|\s+$//g; 317 | my ($key, $val) = split /\s*:\s*/, $_, 2; 318 | $headers{$key} = $val; 319 | } 320 | close $in; 321 | return \%headers; 322 | } 323 | 324 | sub run_test ($) { 325 | my $block = shift; 326 | my $name = $block->name; 327 | 328 | my $config = $block->config; 329 | if (!defined $config) { 330 | Test::More::BAIL_OUT("$name - No '--- config' section specified"); 331 | #$config = $PrevConfig; 332 | die; 333 | } 334 | 335 | my $skip_nginx = $block->skip_nginx; 336 | my ($tests_to_skip, $should_skip, $skip_reason); 337 | if (defined $skip_nginx) { 338 | if ($skip_nginx =~ m{ 339 | ^ \s* (\d+) \s* : \s* 340 | ([<>]=?) \s* (\d+)\.(\d+)\.(\d+) 341 | (?: \s* : \s* (.*) )? 342 | \s*$}x) { 343 | $tests_to_skip = $1; 344 | my ($op, $ver1, $ver2, $ver3) = ($2, $3, $4, $5); 345 | $skip_reason = $6; 346 | #warn "$ver1 $ver2 $ver3"; 347 | my $ver = get_canon_version($ver1, $ver2, $ver3); 348 | if ((!defined $NginxVersion and $op =~ /^todo_nginx; 364 | my ($should_todo, $todo_reason); 365 | if (defined $todo_nginx) { 366 | if ($todo_nginx =~ m{ 367 | ^ \s* 368 | ([<>]=?) \s* (\d+)\.(\d+)\.(\d+) 369 | (?: \s* : \s* (.*) )? 370 | \s*$}x) { 371 | my ($op, $ver1, $ver2, $ver3) = ($1, $2, $3, $4); 372 | $todo_reason = $5; 373 | my $ver = get_canon_version($ver1, $ver2, $ver3); 374 | if ((!defined $NginxVersion and $op =~ /^ /dev/null") == 0) { 400 | #warn "found running nginx..."; 401 | write_config_file($config, $block->http_config); 402 | if (kill(SIGQUIT, $pid) == 0) { # send quit signal 403 | #warn("$name - Failed to send quit signal to the nginx process with PID $pid"); 404 | } 405 | sleep 0.02; 406 | if (system("ps $pid > /dev/null") == 0) { 407 | #warn "killing with force...\n"; 408 | kill(SIGKILL, $pid); 409 | sleep 0.02; 410 | } 411 | undef $nginx_is_running; 412 | } else { 413 | unlink $PidFile or 414 | die "Failed to remove pid file $PidFile\n"; 415 | undef $nginx_is_running; 416 | } 417 | } else { 418 | undef $nginx_is_running; 419 | } 420 | 421 | start_nginx: 422 | 423 | unless ($nginx_is_running) { 424 | #system("killall -9 nginx"); 425 | 426 | #warn "*** Restarting the nginx server...\n"; 427 | setup_server_root(); 428 | write_config_file($config, $block->http_config); 429 | if ( ! Module::Install::Can->can_run('nginx') ) { 430 | Test::More::BAIL_OUT("$name - Cannot find the nginx executable in the PATH environment"); 431 | die; 432 | } 433 | #if (system("nginx -p $ServRoot -c $ConfFile -t") != 0) { 434 | #Test::More::BAIL_OUT("$name - Invalid config file"); 435 | #} 436 | #my $cmd = "nginx -p $ServRoot -c $ConfFile > /dev/null"; 437 | my $cmd; 438 | if ($NginxVersion >= 0.007053) { 439 | $cmd = "nginx -p $ServRoot/ -c $ConfFile > /dev/null"; 440 | } else { 441 | $cmd = "nginx -c $ConfFile > /dev/null"; 442 | } 443 | 444 | if ($Profiling) { 445 | my $pid = $ForkManager->start; 446 | if (!$pid) { 447 | # child process 448 | if (system($cmd) != 0) { 449 | Test::More::BAIL_OUT("$name - Cannot start nginx using command \"$cmd\"."); 450 | } 451 | 452 | $ForkManager->finish; # terminate the child process 453 | } 454 | } else { 455 | if (system($cmd) != 0) { 456 | Test::More::BAIL_OUT("$name - Cannot start nginx using command \"$cmd\"."); 457 | } 458 | } 459 | 460 | sleep 0.1; 461 | } 462 | } 463 | 464 | if ($block->init) { 465 | eval $block->init; 466 | if ($@) { 467 | Test::More::BAIL_OUT("$name - init failed: $@"); 468 | } 469 | } 470 | 471 | my $i = 0; 472 | while ($i++ < $RepeatEach) { 473 | if ($should_skip) { 474 | SKIP: { 475 | Test::More::skip("$name - $skip_reason", $tests_to_skip); 476 | 477 | $RunTestHelper->($block); 478 | } 479 | } elsif ($should_todo) { 480 | TODO: { 481 | local $TODO = "$name - $todo_reason"; 482 | 483 | $RunTestHelper->($block); 484 | } 485 | } else { 486 | $RunTestHelper->($block); 487 | } 488 | } 489 | 490 | if (defined $block->quit && $Profiling) { 491 | warn "Found quit..."; 492 | if (-f $PidFile) { 493 | my $pid = get_pid_from_pidfile($name); 494 | if (system("ps $pid > /dev/null") == 0) { 495 | write_config_file($config, $block->http_config); 496 | if (kill(SIGQUIT, $pid) == 0) { # send quit signal 497 | #warn("$name - Failed to send quit signal to the nginx process with PID $pid"); 498 | } 499 | sleep 0.02; 500 | if (system("ps $pid > /dev/null") == 0) { 501 | #warn "killing with force...\n"; 502 | kill(SIGKILL, $pid); 503 | sleep 0.02; 504 | } 505 | } else { 506 | unlink $PidFile or 507 | die "Failed to remove pid file $PidFile\n"; 508 | } 509 | } 510 | } 511 | } 512 | 513 | 1; 514 | -------------------------------------------------------------------------------- /test/lib/Test/Nginx/LWP.pm: -------------------------------------------------------------------------------- 1 | package Test::Nginx::LWP; 2 | 3 | use lib 'lib'; 4 | use lib 'inc'; 5 | use Test::Base -Base; 6 | 7 | our $VERSION = '0.08'; 8 | 9 | our $NoLongString; 10 | 11 | use LWP::UserAgent; 12 | use Time::HiRes qw(sleep); 13 | use Test::LongString; 14 | use Test::Nginx::Util qw( 15 | setup_server_root 16 | write_config_file 17 | get_canon_version 18 | get_nginx_version 19 | trim 20 | show_all_chars 21 | parse_headers 22 | run_tests 23 | $ServerPortForClient 24 | $PidFile 25 | $ServRoot 26 | $ConfFile 27 | $ServerPort 28 | $RunTestHelper 29 | $NoNginxManager 30 | $RepeatEach 31 | worker_connections 32 | master_process_enabled 33 | config_preamble 34 | repeat_each 35 | no_shuffle 36 | no_root_location 37 | ); 38 | 39 | our $UserAgent = LWP::UserAgent->new; 40 | $UserAgent->agent(__PACKAGE__); 41 | #$UserAgent->default_headers(HTTP::Headers->new); 42 | 43 | #use Smart::Comments::JSON '##'; 44 | 45 | our @EXPORT = qw( plan run_tests run_test 46 | repeat_each config_preamble worker_connections 47 | master_process_enabled 48 | no_long_string no_shuffle no_root_location); 49 | 50 | sub no_long_string () { 51 | $NoLongString = 1; 52 | } 53 | 54 | sub run_test_helper ($); 55 | 56 | $RunTestHelper = \&run_test_helper; 57 | 58 | sub parse_request ($$) { 59 | my ($name, $rrequest) = @_; 60 | open my $in, '<', $rrequest; 61 | my $first = <$in>; 62 | if (!$first) { 63 | Test::More::BAIL_OUT("$name - Request line should be non-empty"); 64 | die; 65 | } 66 | $first =~ s/^\s+|\s+$//g; 67 | my ($meth, $rel_url) = split /\s+/, $first, 2; 68 | my $url = "http://localhost:$ServerPortForClient" . $rel_url; 69 | 70 | my $content = do { local $/; <$in> }; 71 | if ($content) { 72 | $content =~ s/^\s+|\s+$//s; 73 | chomp($content); 74 | } 75 | 76 | close $in; 77 | 78 | return { 79 | method => $meth, 80 | url => $url, 81 | content => $content, 82 | }; 83 | } 84 | 85 | sub chunk_it ($$$) { 86 | my ($chunks, $start_delay, $middle_delay) = @_; 87 | my $i = 0; 88 | return sub { 89 | if ($i == 0) { 90 | if ($start_delay) { 91 | sleep($start_delay); 92 | } 93 | } elsif ($middle_delay) { 94 | sleep($middle_delay); 95 | } 96 | return $chunks->[$i++]; 97 | } 98 | } 99 | 100 | sub run_test_helper ($) { 101 | my ($block) = @_; 102 | 103 | my $request = $block->request; 104 | 105 | my $name = $block->name; 106 | #if (defined $TODO) { 107 | #$name .= "# $TODO"; 108 | #} 109 | 110 | my $req_spec = parse_request($name, \$request); 111 | ## $req_spec 112 | my $method = $req_spec->{method}; 113 | my $req = HTTP::Request->new($method); 114 | my $content = $req_spec->{content}; 115 | 116 | if (defined ($block->request_headers)) { 117 | my $headers = parse_headers($block->request_headers); 118 | while (my ($key, $val) = each %$headers) { 119 | $req->header($key => $val); 120 | } 121 | } 122 | 123 | #$req->header('Accept', '*/*'); 124 | $req->url($req_spec->{url}); 125 | if ($content) { 126 | if ($method eq 'GET' or $method eq 'HEAD') { 127 | croak "HTTP 1.0/1.1 $method request should not have content: $content"; 128 | } 129 | $req->content($content); 130 | } elsif ($method eq 'POST' or $method eq 'PUT') { 131 | my $chunks = $block->chunked_body; 132 | if (defined $chunks) { 133 | if (!ref $chunks or ref $chunks ne 'ARRAY') { 134 | 135 | Test::More::BAIL_OUT("$name - --- chunked_body should takes a Perl array ref as its value"); 136 | } 137 | 138 | my $start_delay = $block->start_chunk_delay || 0; 139 | my $middle_delay = $block->middle_chunk_delay || 0; 140 | $req->content(chunk_it($chunks, $start_delay, $middle_delay)); 141 | if (!defined $req->header('Content-Type')) { 142 | $req->header('Content-Type' => 'text/plain'); 143 | } 144 | } else { 145 | if (!defined $req->header('Content-Type')) { 146 | $req->header('Content-Type' => 'text/plain'); 147 | } 148 | 149 | $req->header('Content-Length' => 0); 150 | } 151 | } 152 | 153 | if ($block->more_headers) { 154 | my @headers = split /\n+/, $block->more_headers; 155 | for my $header (@headers) { 156 | next if $header =~ /^\s*\#/; 157 | my ($key, $val) = split /:\s*/, $header, 2; 158 | #warn "[$key, $val]\n"; 159 | $req->header($key => $val); 160 | } 161 | } 162 | 163 | #warn "req: ", $req->as_string, "\n"; 164 | #warn "DONE!!!!!!!!!!!!!!!!!!!!"; 165 | 166 | my $res = $UserAgent->request($req); 167 | 168 | #warn "res returned!!!"; 169 | 170 | if (defined $block->error_code) { 171 | is($res->code, $block->error_code, "$name - status code ok"); 172 | } else { 173 | is($res->code, 200, "$name - status code ok"); 174 | } 175 | 176 | if (defined $block->response_headers) { 177 | my $headers = parse_headers($block->response_headers); 178 | while (my ($key, $val) = each %$headers) { 179 | my $expected_val = $res->header($key); 180 | if (!defined $expected_val) { 181 | $expected_val = ''; 182 | } 183 | is $expected_val, $val, 184 | "$name - header $key ok"; 185 | } 186 | } elsif (defined $block->response_headers_like) { 187 | my $headers = parse_headers($block->response_headers_like); 188 | while (my ($key, $val) = each %$headers) { 189 | my $expected_val = $res->header($key); 190 | if (!defined $expected_val) { 191 | $expected_val = ''; 192 | } 193 | like $expected_val, qr/^$val$/, 194 | "$name - header $key like ok"; 195 | } 196 | } 197 | 198 | if (defined $block->response_body) { 199 | my $content = $res->content; 200 | if (defined $content) { 201 | $content =~ s/^TE: deflate,gzip;q=0\.3\r\n//gms; 202 | } 203 | 204 | $content =~ s/^Connection: TE, close\r\n//gms; 205 | my $expected = $block->response_body; 206 | $expected =~ s/\$ServerPort\b/$ServerPort/g; 207 | $expected =~ s/\$ServerPortForClient\b/$ServerPortForClient/g; 208 | #warn show_all_chars($content); 209 | 210 | if ($NoLongString) { 211 | is($content, $expected, "$name - response_body - response is expected"); 212 | } else { 213 | is_string($content, $expected, "$name - response_body - response is expected"); 214 | } 215 | #is($content, $expected, "$name - response_body - response is expected"); 216 | 217 | } elsif (defined $block->response_body_like) { 218 | my $content = $res->content; 219 | if (defined $content) { 220 | $content =~ s/^TE: deflate,gzip;q=0\.3\r\n//gms; 221 | } 222 | $content =~ s/^Connection: TE, close\r\n//gms; 223 | my $expected_pat = $block->response_body_like; 224 | $expected_pat =~ s/\$ServerPort\b/$ServerPort/g; 225 | $expected_pat =~ s/\$ServerPortForClient\b/$ServerPortForClient/g; 226 | my $summary = trim($content); 227 | like($content, qr/$expected_pat/s, "$name - response_body_like - response is expected ($summary)"); 228 | } elsif (defined $block->response_body_unlike) { 229 | my $content = $res->content; 230 | if (defined $content) { 231 | $content =~ s/^TE: deflate,gzip;q=0\.3\r\n//gms; 232 | } 233 | $content =~ s/^Connection: TE, close\r\n//gms; 234 | my $expected_pat = $block->response_body_unlike; 235 | $expected_pat =~ s/\$ServerPort\b/$ServerPort/g; 236 | $expected_pat =~ s/\$ServerPortForClient\b/$ServerPortForClient/g; 237 | my $summary = trim($content); 238 | unlike($content, qr/$expected_pat/s, "$name - response_body_like - response is expected ($summary)"); 239 | } 240 | } 241 | 242 | 1; 243 | __END__ 244 | 245 | =encoding utf-8 246 | 247 | =head1 NAME 248 | 249 | Test::Nginx::LWP - LWP-backed test scaffold for the Nginx C modules 250 | 251 | =head1 SYNOPSIS 252 | 253 | use Test::Nginx::LWP; 254 | 255 | plan tests => $Test::Nginx::LWP::RepeatEach * 2 * blocks(); 256 | 257 | run_tests(); 258 | 259 | __DATA__ 260 | 261 | === TEST 1: sanity 262 | --- config 263 | location /echo { 264 | echo_before_body hello; 265 | echo world; 266 | } 267 | --- request 268 | GET /echo 269 | --- response_body 270 | hello 271 | world 272 | --- error_code: 200 273 | 274 | 275 | === TEST 2: set Server 276 | --- config 277 | location /foo { 278 | echo hi; 279 | more_set_headers 'Server: Foo'; 280 | } 281 | --- request 282 | GET /foo 283 | --- response_headers 284 | Server: Foo 285 | --- response_body 286 | hi 287 | 288 | 289 | === TEST 3: clear Server 290 | --- config 291 | location /foo { 292 | echo hi; 293 | more_clear_headers 'Server: '; 294 | } 295 | --- request 296 | GET /foo 297 | --- response_headers_like 298 | Server: nginx.* 299 | --- response_body 300 | hi 301 | 302 | 303 | === TEST 4: set request header at client side and rewrite it 304 | --- config 305 | location /foo { 306 | more_set_input_headers 'X-Foo: howdy'; 307 | echo $http_x_foo; 308 | } 309 | --- request 310 | GET /foo 311 | --- request_headers 312 | X-Foo: blah 313 | --- response_headers 314 | X-Foo: 315 | --- response_body 316 | howdy 317 | 318 | 319 | === TEST 3: rewrite content length 320 | --- config 321 | location /bar { 322 | more_set_input_headers 'Content-Length: 2048'; 323 | echo_read_request_body; 324 | echo_request_body; 325 | } 326 | --- request eval 327 | "POST /bar\n" . 328 | "a" x 4096 329 | --- response_body eval 330 | "a" x 2048 331 | 332 | 333 | === TEST 4: timer without explicit reset 334 | --- config 335 | location /timer { 336 | echo_sleep 0.03; 337 | echo "elapsed $echo_timer_elapsed sec."; 338 | } 339 | --- request 340 | GET /timer 341 | --- response_body_like 342 | ^elapsed 0\.0(2[6-9]|3[0-6]) sec\.$ 343 | 344 | 345 | === TEST 5: small buf (using 2-byte buf) 346 | --- config 347 | chunkin on; 348 | location /main { 349 | client_body_buffer_size 2; 350 | echo "body:"; 351 | echo $echo_request_body; 352 | echo_request_body; 353 | } 354 | --- request 355 | POST /main 356 | --- start_chunk_delay: 0.01 357 | --- middle_chunk_delay: 0.01 358 | --- chunked_body eval 359 | ["hello", "world"] 360 | --- error_code: 200 361 | --- response_body eval 362 | "body: 363 | 364 | helloworld" 365 | 366 | =head1 DESCRIPTION 367 | 368 | This module provides a test scaffold based on L for automated testing in Nginx C module development. 369 | 370 | This class inherits from L, thus bringing all its 371 | declarative power to the Nginx C module testing practices. 372 | 373 | 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 374 | 375 | killall nginx 376 | PATH=/path/to/your/nginx-with-memc-module:$PATH prove -r t 377 | 378 | 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. 379 | 380 | You will often want to look into F 381 | when things go wrong ;) 382 | 383 | =head1 Sections supported 384 | 385 | The following sections are supported: 386 | 387 | =over 388 | 389 | =item config 390 | 391 | =item http_config 392 | 393 | =item request 394 | 395 | =item request_headers 396 | 397 | =item more_headers 398 | 399 | =item response_body 400 | 401 | =item response_body_like 402 | 403 | =item response_headers 404 | 405 | =item response_headers_like 406 | 407 | =item error_code 408 | 409 | =item chunked_body 410 | 411 | =item middle_chunk_delay 412 | 413 | =item start_chunk_delay 414 | 415 | =back 416 | 417 | =head1 Samples 418 | 419 | You'll find live samples in the following Nginx 3rd-party modules: 420 | 421 | =over 422 | 423 | =item ngx_echo 424 | 425 | L 426 | 427 | =item ngx_headers_more 428 | 429 | L 430 | 431 | =item ngx_chunkin 432 | 433 | L 434 | 435 | =item ngx_memc 436 | 437 | L 438 | 439 | =back 440 | 441 | =head1 SOURCE REPOSITORY 442 | 443 | This module has a Git repository on Github, which has access for all. 444 | 445 | http://github.com/agentzh/test-nginx 446 | 447 | If you want a commit bit, feel free to drop me a line. 448 | 449 | =head1 AUTHOR 450 | 451 | agentzh (章亦春) C<< >> 452 | 453 | =head1 COPYRIGHT & LICENSE 454 | 455 | Copyright (c) 2009, Taobao Inc., Alibaba Group (L). 456 | 457 | Copyright (c) 2009, agentzh C<< >>. 458 | 459 | This module is licensed under the terms of the BSD license. 460 | 461 | Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 462 | 463 | =over 464 | 465 | =item * 466 | 467 | Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 468 | 469 | =item * 470 | 471 | 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. 472 | 473 | =item * 474 | 475 | 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. 476 | 477 | =back 478 | 479 | 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. 480 | 481 | =head1 SEE ALSO 482 | 483 | L, L. 484 | 485 | -------------------------------------------------------------------------------- /ngx_http_upstream_keepalive/ngx_http_upstream_keepalive_module.c: -------------------------------------------------------------------------------- 1 | 2 | /* 3 | * Copyright (C) Maxim Dounin 4 | */ 5 | 6 | 7 | #include 8 | #include 9 | #include 10 | 11 | 12 | typedef struct { 13 | ngx_uint_t max_cached; 14 | ngx_uint_t single; /* unsigned:1 */ 15 | 16 | ngx_queue_t cache; 17 | ngx_queue_t free; 18 | 19 | ngx_http_upstream_init_pt original_init_upstream; 20 | ngx_http_upstream_init_peer_pt original_init_peer; 21 | 22 | } ngx_http_upstream_keepalive_srv_conf_t; 23 | 24 | 25 | typedef struct { 26 | ngx_http_upstream_keepalive_srv_conf_t *conf; 27 | 28 | ngx_http_upstream_t *upstream; 29 | 30 | void *data; 31 | 32 | ngx_event_get_peer_pt original_get_peer; 33 | ngx_event_free_peer_pt original_free_peer; 34 | 35 | ngx_uint_t failed; /* unsigned:1 */ 36 | 37 | } ngx_http_upstream_keepalive_peer_data_t; 38 | 39 | 40 | typedef struct { 41 | ngx_http_upstream_keepalive_srv_conf_t *conf; 42 | 43 | ngx_queue_t queue; 44 | ngx_connection_t *connection; 45 | 46 | socklen_t socklen; 47 | struct sockaddr_storage sockaddr; 48 | 49 | } ngx_http_upstream_keepalive_cache_t; 50 | 51 | 52 | static ngx_int_t ngx_http_upstream_init_keepalive_peer(ngx_http_request_t *r, 53 | ngx_http_upstream_srv_conf_t *us); 54 | static ngx_int_t ngx_http_upstream_get_keepalive_peer(ngx_peer_connection_t *pc, 55 | void *data); 56 | static void ngx_http_upstream_free_keepalive_peer(ngx_peer_connection_t *pc, 57 | void *data, ngx_uint_t state); 58 | 59 | static void ngx_http_upstream_keepalive_dummy_handler(ngx_event_t *ev); 60 | static void ngx_http_upstream_keepalive_close_handler(ngx_event_t *ev); 61 | 62 | static void *ngx_http_upstream_keepalive_create_conf(ngx_conf_t *cf); 63 | static char *ngx_http_upstream_keepalive(ngx_conf_t *cf, ngx_command_t *cmd, 64 | void *conf); 65 | 66 | 67 | static ngx_command_t ngx_http_upstream_keepalive_commands[] = { 68 | 69 | { ngx_string("keepalive"), 70 | NGX_HTTP_UPS_CONF|NGX_CONF_TAKE12, 71 | ngx_http_upstream_keepalive, 72 | 0, 73 | 0, 74 | NULL }, 75 | 76 | ngx_null_command 77 | }; 78 | 79 | 80 | static ngx_http_module_t ngx_http_upstream_keepalive_module_ctx = { 81 | NULL, /* preconfiguration */ 82 | NULL, /* postconfiguration */ 83 | 84 | NULL, /* create main configuration */ 85 | NULL, /* init main configuration */ 86 | 87 | ngx_http_upstream_keepalive_create_conf, /* create server configuration */ 88 | NULL, /* merge server configuration */ 89 | 90 | NULL, /* create location configuration */ 91 | NULL /* merge location configuration */ 92 | }; 93 | 94 | 95 | ngx_module_t ngx_http_upstream_keepalive_module = { 96 | NGX_MODULE_V1, 97 | &ngx_http_upstream_keepalive_module_ctx, /* module context */ 98 | ngx_http_upstream_keepalive_commands, /* module directives */ 99 | NGX_HTTP_MODULE, /* module type */ 100 | NULL, /* init master */ 101 | NULL, /* init module */ 102 | NULL, /* init process */ 103 | NULL, /* init thread */ 104 | NULL, /* exit thread */ 105 | NULL, /* exit process */ 106 | NULL, /* exit master */ 107 | NGX_MODULE_V1_PADDING 108 | }; 109 | 110 | 111 | ngx_int_t 112 | ngx_http_upstream_init_keepalive(ngx_conf_t *cf, 113 | ngx_http_upstream_srv_conf_t *us) 114 | { 115 | ngx_uint_t i; 116 | ngx_http_upstream_keepalive_srv_conf_t *kcf; 117 | ngx_http_upstream_keepalive_cache_t *cached; 118 | 119 | ngx_log_debug0(NGX_LOG_DEBUG_HTTP, cf->log, 0, 120 | "init keepalive"); 121 | 122 | kcf = ngx_http_conf_upstream_srv_conf(us, 123 | ngx_http_upstream_keepalive_module); 124 | 125 | if (kcf->original_init_upstream(cf, us) != NGX_OK) { 126 | return NGX_ERROR; 127 | } 128 | 129 | kcf->original_init_peer = us->peer.init; 130 | 131 | us->peer.init = ngx_http_upstream_init_keepalive_peer; 132 | 133 | /* allocate cache items and add to free queue */ 134 | 135 | cached = ngx_pcalloc(cf->pool, 136 | sizeof(ngx_http_upstream_keepalive_cache_t) * kcf->max_cached); 137 | if (cached == NULL) { 138 | return NGX_ERROR; 139 | } 140 | 141 | ngx_queue_init(&kcf->cache); 142 | ngx_queue_init(&kcf->free); 143 | 144 | for (i = 0; i < kcf->max_cached; i++) { 145 | ngx_queue_insert_head(&kcf->free, &cached[i].queue); 146 | cached[i].conf = kcf; 147 | } 148 | 149 | return NGX_OK; 150 | } 151 | 152 | 153 | static ngx_int_t 154 | ngx_http_upstream_init_keepalive_peer(ngx_http_request_t *r, 155 | ngx_http_upstream_srv_conf_t *us) 156 | { 157 | ngx_http_upstream_keepalive_peer_data_t *kp; 158 | ngx_http_upstream_keepalive_srv_conf_t *kcf; 159 | 160 | ngx_log_debug0(NGX_LOG_DEBUG_HTTP, r->connection->log, 0, 161 | "init keepalive peer"); 162 | 163 | kcf = ngx_http_conf_upstream_srv_conf(us, 164 | ngx_http_upstream_keepalive_module); 165 | 166 | kp = ngx_palloc(r->pool, sizeof(ngx_http_upstream_keepalive_peer_data_t)); 167 | if (kp == NULL) { 168 | return NGX_ERROR; 169 | } 170 | 171 | if (kcf->original_init_peer(r, us) != NGX_OK) { 172 | return NGX_ERROR; 173 | } 174 | 175 | kp->conf = kcf; 176 | kp->upstream = r->upstream; 177 | kp->data = r->upstream->peer.data; 178 | kp->original_get_peer = r->upstream->peer.get; 179 | kp->original_free_peer = r->upstream->peer.free; 180 | 181 | r->upstream->peer.data = kp; 182 | r->upstream->peer.get = ngx_http_upstream_get_keepalive_peer; 183 | r->upstream->peer.free = ngx_http_upstream_free_keepalive_peer; 184 | 185 | return NGX_OK; 186 | } 187 | 188 | 189 | static ngx_int_t 190 | ngx_http_upstream_get_keepalive_peer(ngx_peer_connection_t *pc, void *data) 191 | { 192 | ngx_http_upstream_keepalive_peer_data_t *kp = data; 193 | ngx_http_upstream_keepalive_cache_t *item; 194 | 195 | ngx_int_t rc; 196 | ngx_queue_t *q, *cache; 197 | ngx_connection_t *c; 198 | 199 | ngx_log_debug0(NGX_LOG_DEBUG_HTTP, pc->log, 0, 200 | "get keepalive peer"); 201 | 202 | kp->failed = 0; 203 | 204 | /* single pool of cached connections */ 205 | 206 | if (kp->conf->single && !ngx_queue_empty(&kp->conf->cache)) { 207 | 208 | q = ngx_queue_head(&kp->conf->cache); 209 | ngx_queue_remove(q); 210 | 211 | item = ngx_queue_data(q, ngx_http_upstream_keepalive_cache_t, queue); 212 | c = item->connection; 213 | 214 | ngx_queue_insert_head(&kp->conf->free, q); 215 | 216 | c->idle = 0; 217 | c->log = pc->log; 218 | c->read->log = pc->log; 219 | c->write->log = pc->log; 220 | 221 | pc->connection = c; 222 | pc->cached = 1; 223 | 224 | return NGX_DONE; 225 | } 226 | 227 | rc = kp->original_get_peer(pc, kp->data); 228 | 229 | if (kp->conf->single || rc != NGX_OK) { 230 | return rc; 231 | } 232 | 233 | /* search cache for suitable connection */ 234 | 235 | cache = &kp->conf->cache; 236 | 237 | for (q = ngx_queue_head(cache); 238 | q != ngx_queue_sentinel(cache); 239 | q = ngx_queue_next(q)) 240 | { 241 | item = ngx_queue_data(q, ngx_http_upstream_keepalive_cache_t, queue); 242 | c = item->connection; 243 | 244 | if (ngx_memn2cmp((u_char *) &item->sockaddr, (u_char *) pc->sockaddr, 245 | item->socklen, pc->socklen) 246 | == 0) 247 | { 248 | ngx_queue_remove(q); 249 | ngx_queue_insert_head(&kp->conf->free, q); 250 | 251 | c->idle = 0; 252 | c->log = pc->log; 253 | c->read->log = pc->log; 254 | c->write->log = pc->log; 255 | 256 | pc->connection = c; 257 | pc->cached = 1; 258 | 259 | return NGX_DONE; 260 | } 261 | } 262 | 263 | return NGX_OK; 264 | } 265 | 266 | 267 | static void 268 | ngx_http_upstream_free_keepalive_peer(ngx_peer_connection_t *pc, void *data, 269 | ngx_uint_t state) 270 | { 271 | ngx_http_upstream_keepalive_peer_data_t *kp = data; 272 | ngx_http_upstream_keepalive_cache_t *item; 273 | 274 | ngx_queue_t *q; 275 | ngx_connection_t *c; 276 | ngx_http_upstream_t *u; 277 | 278 | ngx_log_debug0(NGX_LOG_DEBUG_HTTP, pc->log, 0, 279 | "free keepalive peer"); 280 | 281 | /* remember failed state - peer.free() may be called more than once */ 282 | 283 | if (state & NGX_PEER_FAILED) { 284 | kp->failed = 1; 285 | } 286 | 287 | /* 288 | * cache valid connections 289 | * 290 | * For memcached this means status either 404 or 200. For status 200 we 291 | * should also check if all response body was read (u->length == 0) and 292 | * make sure that u->length is valid (we use u->header_sent flag to test 293 | * this). Memcached is the only supported protocol for now. 294 | * 295 | * Some notes on other possibilities (incomplete): 296 | * 297 | * fastcgi: u->pipe->upstream_done should be sufficient 298 | * 299 | * proxy buffered: u->pipe->upstream_done, 304 replies, replies to head 300 | * requests (see RFC 2616, 4.4 Message Length) 301 | * 302 | * proxy unbuffered: 200 as for memcached (with u->length == 0 and 303 | * header_sent), 304, replies to head requests 304 | * 305 | * subrequest_in_memory: won't work as of now 306 | * 307 | * TODO: move this logic to protocol modules (NGX_PEER_KEEPALIVE?) 308 | */ 309 | 310 | u = kp->upstream; 311 | 312 | #if !(NGX_ENABLE_UPSTREAM_KEEPALIVE) 313 | ngx_uint_t status; 314 | status = u->headers_in.status_n; 315 | #endif 316 | 317 | if (!kp->failed 318 | && pc->connection != NULL 319 | #if (NGX_ENABLE_UPSTREAM_KEEPALIVE) 320 | && u->keepalive && !u->pipe->upstream_eof && !u->pipe->upstream_error) 321 | #else 322 | && (status == NGX_HTTP_NOT_FOUND 323 | || (status == NGX_HTTP_OK && u->header_sent && u->length == 0))) 324 | #endif 325 | { 326 | c = pc->connection; 327 | 328 | ngx_log_debug1(NGX_LOG_DEBUG_HTTP, pc->log, 0, 329 | "free keepalive peer: saving connection %p", c); 330 | 331 | if (ngx_queue_empty(&kp->conf->free)) { 332 | 333 | q = ngx_queue_last(&kp->conf->cache); 334 | ngx_queue_remove(q); 335 | 336 | item = ngx_queue_data(q, ngx_http_upstream_keepalive_cache_t, 337 | queue); 338 | 339 | ngx_close_connection(item->connection); 340 | 341 | } else { 342 | q = ngx_queue_head(&kp->conf->free); 343 | ngx_queue_remove(q); 344 | 345 | item = ngx_queue_data(q, ngx_http_upstream_keepalive_cache_t, 346 | queue); 347 | } 348 | 349 | item->connection = c; 350 | ngx_queue_insert_head(&kp->conf->cache, q); 351 | 352 | pc->connection = NULL; 353 | 354 | if (c->read->timer_set) { 355 | ngx_del_timer(c->read); 356 | } 357 | if (c->write->timer_set) { 358 | ngx_del_timer(c->write); 359 | } 360 | 361 | c->write->handler = ngx_http_upstream_keepalive_dummy_handler; 362 | c->read->handler = ngx_http_upstream_keepalive_close_handler; 363 | 364 | c->data = item; 365 | c->idle = 1; 366 | c->log = ngx_cycle->log; 367 | c->read->log = ngx_cycle->log; 368 | c->write->log = ngx_cycle->log; 369 | 370 | item->socklen = pc->socklen; 371 | ngx_memcpy(&item->sockaddr, pc->sockaddr, pc->socklen); 372 | } 373 | 374 | return kp->original_free_peer(pc, kp->data, state); 375 | } 376 | 377 | 378 | static void 379 | ngx_http_upstream_keepalive_dummy_handler(ngx_event_t *ev) 380 | { 381 | ngx_log_debug0(NGX_LOG_DEBUG_HTTP, ev->log, 0, 382 | "keepalive dummy handler"); 383 | } 384 | 385 | 386 | static void 387 | ngx_http_upstream_keepalive_close_handler(ngx_event_t *ev) 388 | { 389 | ngx_http_upstream_keepalive_srv_conf_t *conf; 390 | ngx_http_upstream_keepalive_cache_t *item; 391 | 392 | int n; 393 | char buf[1]; 394 | ngx_connection_t *c; 395 | 396 | ngx_log_debug0(NGX_LOG_DEBUG_HTTP, ev->log, 0, 397 | "keepalive close handler"); 398 | 399 | c = ev->data; 400 | 401 | if (c->close) { 402 | goto close; 403 | } 404 | 405 | n = recv(c->fd, buf, 1, MSG_PEEK); 406 | 407 | if (n == -1 && ngx_socket_errno == NGX_EAGAIN) { 408 | /* stale event */ 409 | 410 | if (ngx_handle_read_event(c->read, 0) != NGX_OK) { 411 | goto close; 412 | } 413 | 414 | return; 415 | } 416 | 417 | close: 418 | 419 | item = c->data; 420 | conf = item->conf; 421 | 422 | ngx_queue_remove(&item->queue); 423 | ngx_close_connection(item->connection); 424 | ngx_queue_insert_head(&conf->free, &item->queue); 425 | } 426 | 427 | 428 | static void * 429 | ngx_http_upstream_keepalive_create_conf(ngx_conf_t *cf) 430 | { 431 | ngx_http_upstream_keepalive_srv_conf_t *conf; 432 | 433 | conf = ngx_pcalloc(cf->pool, 434 | sizeof(ngx_http_upstream_keepalive_srv_conf_t)); 435 | if (conf == NULL) { 436 | return NULL; 437 | } 438 | 439 | /* 440 | * set by ngx_pcalloc(): 441 | * 442 | * conf->original_init_upstream = NULL; 443 | * conf->original_init_peer = NULL; 444 | */ 445 | 446 | conf->max_cached = 1; 447 | 448 | return conf; 449 | } 450 | 451 | 452 | static char * 453 | ngx_http_upstream_keepalive(ngx_conf_t *cf, ngx_command_t *cmd, void *conf) 454 | { 455 | ngx_http_upstream_srv_conf_t *uscf; 456 | ngx_http_upstream_keepalive_srv_conf_t *kcf; 457 | 458 | ngx_int_t n; 459 | ngx_str_t *value; 460 | ngx_uint_t i; 461 | 462 | uscf = ngx_http_conf_get_module_srv_conf(cf, ngx_http_upstream_module); 463 | 464 | kcf = ngx_http_conf_upstream_srv_conf(uscf, 465 | ngx_http_upstream_keepalive_module); 466 | 467 | kcf->original_init_upstream = uscf->peer.init_upstream 468 | ? uscf->peer.init_upstream 469 | : ngx_http_upstream_init_round_robin; 470 | 471 | uscf->peer.init_upstream = ngx_http_upstream_init_keepalive; 472 | 473 | /* read options */ 474 | 475 | value = cf->args->elts; 476 | 477 | n = ngx_atoi(value[1].data, value[1].len); 478 | 479 | if (n == NGX_ERROR || n == 0) { 480 | ngx_conf_log_error(NGX_LOG_EMERG, cf, 0, 481 | "invalid value \"%V\" in \"%V\" directive", 482 | &value[1], &cmd->name); 483 | return NGX_CONF_ERROR; 484 | } 485 | 486 | kcf->max_cached = n; 487 | 488 | for (i = 2; i < cf->args->nelts; i++) { 489 | 490 | if (ngx_strcmp(value[i].data, "single") == 0) { 491 | 492 | kcf->single = 1; 493 | 494 | continue; 495 | } 496 | 497 | goto invalid; 498 | } 499 | 500 | return NGX_CONF_OK; 501 | 502 | invalid: 503 | 504 | ngx_conf_log_error(NGX_LOG_EMERG, cf, 0, 505 | "invalid parameter \"%V\"", &value[i]); 506 | 507 | return NGX_CONF_ERROR; 508 | } 509 | -------------------------------------------------------------------------------- /test/inc/Spiffy.pm: -------------------------------------------------------------------------------- 1 | #line 1 2 | package Spiffy; 3 | use strict; 4 | use 5.006001; 5 | use warnings; 6 | use Carp; 7 | require Exporter; 8 | our $VERSION = '0.30'; 9 | our @EXPORT = (); 10 | our @EXPORT_BASE = qw(field const stub super); 11 | our @EXPORT_OK = (@EXPORT_BASE, qw(id WWW XXX YYY ZZZ)); 12 | our %EXPORT_TAGS = (XXX => [qw(WWW XXX YYY ZZZ)]); 13 | 14 | my $stack_frame = 0; 15 | my $dump = 'yaml'; 16 | my $bases_map = {}; 17 | 18 | sub WWW; sub XXX; sub YYY; sub ZZZ; 19 | 20 | # This line is here to convince "autouse" into believing we are autousable. 21 | sub can { 22 | ($_[1] eq 'import' and caller()->isa('autouse')) 23 | ? \&Exporter::import # pacify autouse's equality test 24 | : $_[0]->SUPER::can($_[1]) # normal case 25 | } 26 | 27 | # TODO 28 | # 29 | # Exported functions like field and super should be hidden so as not to 30 | # be confused with methods that can be inherited. 31 | # 32 | 33 | sub new { 34 | my $class = shift; 35 | $class = ref($class) || $class; 36 | my $self = bless {}, $class; 37 | while (@_) { 38 | my $method = shift; 39 | $self->$method(shift); 40 | } 41 | return $self; 42 | } 43 | 44 | my $filtered_files = {}; 45 | my $filter_dump = 0; 46 | my $filter_save = 0; 47 | our $filter_result = ''; 48 | sub import { 49 | no strict 'refs'; 50 | no warnings; 51 | my $self_package = shift; 52 | 53 | # XXX Using parse_arguments here might cause confusion, because the 54 | # subclass's boolean_arguments and paired_arguments can conflict, causing 55 | # difficult debugging. Consider using something truly local. 56 | my ($args, @export_list) = do { 57 | local *boolean_arguments = sub { 58 | qw( 59 | -base -Base -mixin -selfless 60 | -XXX -dumper -yaml 61 | -filter_dump -filter_save 62 | ) 63 | }; 64 | local *paired_arguments = sub { qw(-package) }; 65 | $self_package->parse_arguments(@_); 66 | }; 67 | return spiffy_mixin_import(scalar(caller(0)), $self_package, @export_list) 68 | if $args->{-mixin}; 69 | 70 | $filter_dump = 1 if $args->{-filter_dump}; 71 | $filter_save = 1 if $args->{-filter_save}; 72 | $dump = 'yaml' if $args->{-yaml}; 73 | $dump = 'dumper' if $args->{-dumper}; 74 | 75 | local @EXPORT_BASE = @EXPORT_BASE; 76 | 77 | if ($args->{-XXX}) { 78 | push @EXPORT_BASE, @{$EXPORT_TAGS{XXX}} 79 | unless grep /^XXX$/, @EXPORT_BASE; 80 | } 81 | 82 | spiffy_filter() 83 | if ($args->{-selfless} or $args->{-Base}) and 84 | not $filtered_files->{(caller($stack_frame))[1]}++; 85 | 86 | my $caller_package = $args->{-package} || caller($stack_frame); 87 | push @{"$caller_package\::ISA"}, $self_package 88 | if $args->{-Base} or $args->{-base}; 89 | 90 | for my $class (@{all_my_bases($self_package)}) { 91 | next unless $class->isa('Spiffy'); 92 | my @export = grep { 93 | not defined &{"$caller_package\::$_"}; 94 | } ( @{"$class\::EXPORT"}, 95 | ($args->{-Base} or $args->{-base}) 96 | ? @{"$class\::EXPORT_BASE"} : (), 97 | ); 98 | my @export_ok = grep { 99 | not defined &{"$caller_package\::$_"}; 100 | } @{"$class\::EXPORT_OK"}; 101 | 102 | # Avoid calling the expensive Exporter::export 103 | # if there is nothing to do (optimization) 104 | my %exportable = map { ($_, 1) } @export, @export_ok; 105 | next unless keys %exportable; 106 | 107 | my @export_save = @{"$class\::EXPORT"}; 108 | my @export_ok_save = @{"$class\::EXPORT_OK"}; 109 | @{"$class\::EXPORT"} = @export; 110 | @{"$class\::EXPORT_OK"} = @export_ok; 111 | my @list = grep { 112 | (my $v = $_) =~ s/^[\!\:]//; 113 | $exportable{$v} or ${"$class\::EXPORT_TAGS"}{$v}; 114 | } @export_list; 115 | Exporter::export($class, $caller_package, @list); 116 | @{"$class\::EXPORT"} = @export_save; 117 | @{"$class\::EXPORT_OK"} = @export_ok_save; 118 | } 119 | } 120 | 121 | sub spiffy_filter { 122 | require Filter::Util::Call; 123 | my $done = 0; 124 | Filter::Util::Call::filter_add( 125 | sub { 126 | return 0 if $done; 127 | my ($data, $end) = ('', ''); 128 | while (my $status = Filter::Util::Call::filter_read()) { 129 | return $status if $status < 0; 130 | if (/^__(?:END|DATA)__\r?$/) { 131 | $end = $_; 132 | last; 133 | } 134 | $data .= $_; 135 | $_ = ''; 136 | } 137 | $_ = $data; 138 | my @my_subs; 139 | s[^(sub\s+\w+\s+\{)(.*\n)] 140 | [${1}my \$self = shift;$2]gm; 141 | s[^(sub\s+\w+)\s*\(\s*\)(\s+\{.*\n)] 142 | [${1}${2}]gm; 143 | s[^my\s+sub\s+(\w+)(\s+\{)(.*)((?s:.*?\n))\}\n] 144 | [push @my_subs, $1; "\$$1 = sub$2my \$self = shift;$3$4\};\n"]gem; 145 | my $preclare = ''; 146 | if (@my_subs) { 147 | $preclare = join ',', map "\$$_", @my_subs; 148 | $preclare = "my($preclare);"; 149 | } 150 | $_ = "use strict;use warnings;$preclare${_};1;\n$end"; 151 | if ($filter_dump) { print; exit } 152 | if ($filter_save) { $filter_result = $_; $_ = $filter_result; } 153 | $done = 1; 154 | } 155 | ); 156 | } 157 | 158 | sub base { 159 | push @_, -base; 160 | goto &import; 161 | } 162 | 163 | sub all_my_bases { 164 | my $class = shift; 165 | 166 | return $bases_map->{$class} 167 | if defined $bases_map->{$class}; 168 | 169 | my @bases = ($class); 170 | no strict 'refs'; 171 | for my $base_class (@{"${class}::ISA"}) { 172 | push @bases, @{all_my_bases($base_class)}; 173 | } 174 | my $used = {}; 175 | $bases_map->{$class} = [grep {not $used->{$_}++} @bases]; 176 | } 177 | 178 | my %code = ( 179 | sub_start => 180 | "sub {\n", 181 | set_default => 182 | " \$_[0]->{%s} = %s\n unless exists \$_[0]->{%s};\n", 183 | init => 184 | " return \$_[0]->{%s} = do { my \$self = \$_[0]; %s }\n" . 185 | " unless \$#_ > 0 or defined \$_[0]->{%s};\n", 186 | weak_init => 187 | " return do {\n" . 188 | " \$_[0]->{%s} = do { my \$self = \$_[0]; %s };\n" . 189 | " Scalar::Util::weaken(\$_[0]->{%s}) if ref \$_[0]->{%s};\n" . 190 | " \$_[0]->{%s};\n" . 191 | " } unless \$#_ > 0 or defined \$_[0]->{%s};\n", 192 | return_if_get => 193 | " return \$_[0]->{%s} unless \$#_ > 0;\n", 194 | set => 195 | " \$_[0]->{%s} = \$_[1];\n", 196 | weaken => 197 | " Scalar::Util::weaken(\$_[0]->{%s}) if ref \$_[0]->{%s};\n", 198 | sub_end => 199 | " return \$_[0]->{%s};\n}\n", 200 | ); 201 | 202 | sub field { 203 | my $package = caller; 204 | my ($args, @values) = do { 205 | no warnings; 206 | local *boolean_arguments = sub { (qw(-weak)) }; 207 | local *paired_arguments = sub { (qw(-package -init)) }; 208 | Spiffy->parse_arguments(@_); 209 | }; 210 | my ($field, $default) = @values; 211 | $package = $args->{-package} if defined $args->{-package}; 212 | die "Cannot have a default for a weakened field ($field)" 213 | if defined $default && $args->{-weak}; 214 | return if defined &{"${package}::$field"}; 215 | require Scalar::Util if $args->{-weak}; 216 | my $default_string = 217 | ( ref($default) eq 'ARRAY' and not @$default ) 218 | ? '[]' 219 | : (ref($default) eq 'HASH' and not keys %$default ) 220 | ? '{}' 221 | : default_as_code($default); 222 | 223 | my $code = $code{sub_start}; 224 | if ($args->{-init}) { 225 | my $fragment = $args->{-weak} ? $code{weak_init} : $code{init}; 226 | $code .= sprintf $fragment, $field, $args->{-init}, ($field) x 4; 227 | } 228 | $code .= sprintf $code{set_default}, $field, $default_string, $field 229 | if defined $default; 230 | $code .= sprintf $code{return_if_get}, $field; 231 | $code .= sprintf $code{set}, $field; 232 | $code .= sprintf $code{weaken}, $field, $field 233 | if $args->{-weak}; 234 | $code .= sprintf $code{sub_end}, $field; 235 | 236 | my $sub = eval $code; 237 | die $@ if $@; 238 | no strict 'refs'; 239 | *{"${package}::$field"} = $sub; 240 | return $code if defined wantarray; 241 | } 242 | 243 | sub default_as_code { 244 | require Data::Dumper; 245 | local $Data::Dumper::Sortkeys = 1; 246 | my $code = Data::Dumper::Dumper(shift); 247 | $code =~ s/^\$VAR1 = //; 248 | $code =~ s/;$//; 249 | return $code; 250 | } 251 | 252 | sub const { 253 | my $package = caller; 254 | my ($args, @values) = do { 255 | no warnings; 256 | local *paired_arguments = sub { (qw(-package)) }; 257 | Spiffy->parse_arguments(@_); 258 | }; 259 | my ($field, $default) = @values; 260 | $package = $args->{-package} if defined $args->{-package}; 261 | no strict 'refs'; 262 | return if defined &{"${package}::$field"}; 263 | *{"${package}::$field"} = sub { $default } 264 | } 265 | 266 | sub stub { 267 | my $package = caller; 268 | my ($args, @values) = do { 269 | no warnings; 270 | local *paired_arguments = sub { (qw(-package)) }; 271 | Spiffy->parse_arguments(@_); 272 | }; 273 | my ($field, $default) = @values; 274 | $package = $args->{-package} if defined $args->{-package}; 275 | no strict 'refs'; 276 | return if defined &{"${package}::$field"}; 277 | *{"${package}::$field"} = 278 | sub { 279 | require Carp; 280 | Carp::confess 281 | "Method $field in package $package must be subclassed"; 282 | } 283 | } 284 | 285 | sub parse_arguments { 286 | my $class = shift; 287 | my ($args, @values) = ({}, ()); 288 | my %booleans = map { ($_, 1) } $class->boolean_arguments; 289 | my %pairs = map { ($_, 1) } $class->paired_arguments; 290 | while (@_) { 291 | my $elem = shift; 292 | if (defined $elem and defined $booleans{$elem}) { 293 | $args->{$elem} = (@_ and $_[0] =~ /^[01]$/) 294 | ? shift 295 | : 1; 296 | } 297 | elsif (defined $elem and defined $pairs{$elem} and @_) { 298 | $args->{$elem} = shift; 299 | } 300 | else { 301 | push @values, $elem; 302 | } 303 | } 304 | return wantarray ? ($args, @values) : $args; 305 | } 306 | 307 | sub boolean_arguments { () } 308 | sub paired_arguments { () } 309 | 310 | # get a unique id for any node 311 | sub id { 312 | if (not ref $_[0]) { 313 | return 'undef' if not defined $_[0]; 314 | \$_[0] =~ /\((\w+)\)$/o or die; 315 | return "$1-S"; 316 | } 317 | require overload; 318 | overload::StrVal($_[0]) =~ /\((\w+)\)$/o or die; 319 | return $1; 320 | } 321 | 322 | #=============================================================================== 323 | # It's super, man. 324 | #=============================================================================== 325 | package DB; 326 | { 327 | no warnings 'redefine'; 328 | sub super_args { 329 | my @dummy = caller(@_ ? $_[0] : 2); 330 | return @DB::args; 331 | } 332 | } 333 | 334 | package Spiffy; 335 | sub super { 336 | my $method; 337 | my $frame = 1; 338 | while ($method = (caller($frame++))[3]) { 339 | $method =~ s/.*::// and last; 340 | } 341 | my @args = DB::super_args($frame); 342 | @_ = @_ ? ($args[0], @_) : @args; 343 | my $class = ref $_[0] ? ref $_[0] : $_[0]; 344 | my $caller_class = caller; 345 | my $seen = 0; 346 | my @super_classes = reverse grep { 347 | ($seen or $seen = ($_ eq $caller_class)) ? 0 : 1; 348 | } reverse @{all_my_bases($class)}; 349 | for my $super_class (@super_classes) { 350 | no strict 'refs'; 351 | next if $super_class eq $class; 352 | if (defined &{"${super_class}::$method"}) { 353 | ${"$super_class\::AUTOLOAD"} = ${"$class\::AUTOLOAD"} 354 | if $method eq 'AUTOLOAD'; 355 | return &{"${super_class}::$method"}; 356 | } 357 | } 358 | return; 359 | } 360 | 361 | #=============================================================================== 362 | # This code deserves a spanking, because it is being very naughty. 363 | # It is exchanging base.pm's import() for its own, so that people 364 | # can use base.pm with Spiffy modules, without being the wiser. 365 | #=============================================================================== 366 | my $real_base_import; 367 | my $real_mixin_import; 368 | 369 | BEGIN { 370 | require base unless defined $INC{'base.pm'}; 371 | $INC{'mixin.pm'} ||= 'Spiffy/mixin.pm'; 372 | $real_base_import = \&base::import; 373 | $real_mixin_import = \&mixin::import; 374 | no warnings; 375 | *base::import = \&spiffy_base_import; 376 | *mixin::import = \&spiffy_mixin_import; 377 | } 378 | 379 | # my $i = 0; 380 | # while (my $caller = caller($i++)) { 381 | # next unless $caller eq 'base' or $caller eq 'mixin'; 382 | # croak <isa('Spiffy'); 396 | } @base_classes; 397 | my $inheritor = caller(0); 398 | for my $base_class (@base_classes) { 399 | next if $inheritor->isa($base_class); 400 | croak "Can't mix Spiffy and non-Spiffy classes in 'use base'.\n", 401 | "See the documentation of Spiffy.pm for details\n " 402 | unless $base_class->isa('Spiffy'); 403 | $stack_frame = 1; # tell import to use different caller 404 | import($base_class, '-base'); 405 | $stack_frame = 0; 406 | } 407 | } 408 | 409 | sub mixin { 410 | my $self = shift; 411 | my $target_class = ref($self); 412 | spiffy_mixin_import($target_class, @_) 413 | } 414 | 415 | sub spiffy_mixin_import { 416 | my $target_class = shift; 417 | $target_class = caller(0) 418 | if $target_class eq 'mixin'; 419 | my $mixin_class = shift 420 | or die "Nothing to mixin"; 421 | eval "require $mixin_class"; 422 | my @roles = @_; 423 | my $pseudo_class = join '-', $target_class, $mixin_class, @roles; 424 | my %methods = spiffy_mixin_methods($mixin_class, @roles); 425 | no strict 'refs'; 426 | no warnings; 427 | @{"$pseudo_class\::ISA"} = @{"$target_class\::ISA"}; 428 | @{"$target_class\::ISA"} = ($pseudo_class); 429 | for (keys %methods) { 430 | *{"$pseudo_class\::$_"} = $methods{$_}; 431 | } 432 | } 433 | 434 | sub spiffy_mixin_methods { 435 | my $mixin_class = shift; 436 | no strict 'refs'; 437 | my %methods = spiffy_all_methods($mixin_class); 438 | map { 439 | $methods{$_} 440 | ? ($_, \ &{"$methods{$_}\::$_"}) 441 | : ($_, \ &{"$mixin_class\::$_"}) 442 | } @_ 443 | ? (get_roles($mixin_class, @_)) 444 | : (keys %methods); 445 | } 446 | 447 | sub get_roles { 448 | my $mixin_class = shift; 449 | my @roles = @_; 450 | while (grep /^!*:/, @roles) { 451 | @roles = map { 452 | s/!!//g; 453 | /^!:(.*)/ ? do { 454 | my $m = "_role_$1"; 455 | map("!$_", $mixin_class->$m); 456 | } : 457 | /^:(.*)/ ? do { 458 | my $m = "_role_$1"; 459 | ($mixin_class->$m); 460 | } : 461 | ($_) 462 | } @roles; 463 | } 464 | if (@roles and $roles[0] =~ /^!/) { 465 | my %methods = spiffy_all_methods($mixin_class); 466 | unshift @roles, keys(%methods); 467 | } 468 | my %roles; 469 | for (@roles) { 470 | s/!!//g; 471 | delete $roles{$1}, next 472 | if /^!(.*)/; 473 | $roles{$_} = 1; 474 | } 475 | keys %roles; 476 | } 477 | 478 | sub spiffy_all_methods { 479 | no strict 'refs'; 480 | my $class = shift; 481 | return if $class eq 'Spiffy'; 482 | my %methods = map { 483 | ($_, $class) 484 | } grep { 485 | defined &{"$class\::$_"} and not /^_/ 486 | } keys %{"$class\::"}; 487 | my %super_methods; 488 | %super_methods = spiffy_all_methods(${"$class\::ISA"}[0]) 489 | if @{"$class\::ISA"}; 490 | %{{%super_methods, %methods}}; 491 | } 492 | 493 | 494 | # END of naughty code. 495 | #=============================================================================== 496 | # Debugging support 497 | #=============================================================================== 498 | sub spiffy_dump { 499 | no warnings; 500 | if ($dump eq 'dumper') { 501 | require Data::Dumper; 502 | $Data::Dumper::Sortkeys = 1; 503 | $Data::Dumper::Indent = 1; 504 | return Data::Dumper::Dumper(@_); 505 | } 506 | require YAML; 507 | $YAML::UseVersion = 0; 508 | return YAML::Dump(@_) . "...\n"; 509 | } 510 | 511 | sub at_line_number { 512 | my ($file_path, $line_number) = (caller(1))[1,2]; 513 | " at $file_path line $line_number\n"; 514 | } 515 | 516 | sub WWW { 517 | warn spiffy_dump(@_) . at_line_number; 518 | return wantarray ? @_ : $_[0]; 519 | } 520 | 521 | sub XXX { 522 | die spiffy_dump(@_) . at_line_number; 523 | } 524 | 525 | sub YYY { 526 | print spiffy_dump(@_) . at_line_number; 527 | return wantarray ? @_ : $_[0]; 528 | } 529 | 530 | sub ZZZ { 531 | require Carp; 532 | Carp::confess spiffy_dump(@_); 533 | } 534 | 535 | 1; 536 | 537 | __END__ 538 | 539 | #line 1066 540 | -------------------------------------------------------------------------------- /test/inc/Module/Install/Metadata.pm: -------------------------------------------------------------------------------- 1 | #line 1 2 | package Module::Install::Metadata; 3 | 4 | use strict 'vars'; 5 | use Module::Install::Base (); 6 | 7 | use vars qw{$VERSION @ISA $ISCORE}; 8 | BEGIN { 9 | $VERSION = '0.91'; 10 | @ISA = 'Module::Install::Base'; 11 | $ISCORE = 1; 12 | } 13 | 14 | my @boolean_keys = qw{ 15 | sign 16 | }; 17 | 18 | my @scalar_keys = qw{ 19 | name 20 | module_name 21 | abstract 22 | author 23 | version 24 | distribution_type 25 | tests 26 | installdirs 27 | }; 28 | 29 | my @tuple_keys = qw{ 30 | configure_requires 31 | build_requires 32 | requires 33 | recommends 34 | bundles 35 | resources 36 | }; 37 | 38 | my @resource_keys = qw{ 39 | homepage 40 | bugtracker 41 | repository 42 | }; 43 | 44 | my @array_keys = qw{ 45 | keywords 46 | }; 47 | 48 | sub Meta { shift } 49 | sub Meta_BooleanKeys { @boolean_keys } 50 | sub Meta_ScalarKeys { @scalar_keys } 51 | sub Meta_TupleKeys { @tuple_keys } 52 | sub Meta_ResourceKeys { @resource_keys } 53 | sub Meta_ArrayKeys { @array_keys } 54 | 55 | foreach my $key ( @boolean_keys ) { 56 | *$key = sub { 57 | my $self = shift; 58 | if ( defined wantarray and not @_ ) { 59 | return $self->{values}->{$key}; 60 | } 61 | $self->{values}->{$key} = ( @_ ? $_[0] : 1 ); 62 | return $self; 63 | }; 64 | } 65 | 66 | foreach my $key ( @scalar_keys ) { 67 | *$key = sub { 68 | my $self = shift; 69 | return $self->{values}->{$key} if defined wantarray and !@_; 70 | $self->{values}->{$key} = shift; 71 | return $self; 72 | }; 73 | } 74 | 75 | foreach my $key ( @array_keys ) { 76 | *$key = sub { 77 | my $self = shift; 78 | return $self->{values}->{$key} if defined wantarray and !@_; 79 | $self->{values}->{$key} ||= []; 80 | push @{$self->{values}->{$key}}, @_; 81 | return $self; 82 | }; 83 | } 84 | 85 | foreach my $key ( @resource_keys ) { 86 | *$key = sub { 87 | my $self = shift; 88 | unless ( @_ ) { 89 | return () unless $self->{values}->{resources}; 90 | return map { $_->[1] } 91 | grep { $_->[0] eq $key } 92 | @{ $self->{values}->{resources} }; 93 | } 94 | return $self->{values}->{resources}->{$key} unless @_; 95 | my $uri = shift or die( 96 | "Did not provide a value to $key()" 97 | ); 98 | $self->resources( $key => $uri ); 99 | return 1; 100 | }; 101 | } 102 | 103 | foreach my $key ( grep { $_ ne "resources" } @tuple_keys) { 104 | *$key = sub { 105 | my $self = shift; 106 | return $self->{values}->{$key} unless @_; 107 | my @added; 108 | while ( @_ ) { 109 | my $module = shift or last; 110 | my $version = shift || 0; 111 | push @added, [ $module, $version ]; 112 | } 113 | push @{ $self->{values}->{$key} }, @added; 114 | return map {@$_} @added; 115 | }; 116 | } 117 | 118 | # Resource handling 119 | my %lc_resource = map { $_ => 1 } qw{ 120 | homepage 121 | license 122 | bugtracker 123 | repository 124 | }; 125 | 126 | sub resources { 127 | my $self = shift; 128 | while ( @_ ) { 129 | my $name = shift or last; 130 | my $value = shift or next; 131 | if ( $name eq lc $name and ! $lc_resource{$name} ) { 132 | die("Unsupported reserved lowercase resource '$name'"); 133 | } 134 | $self->{values}->{resources} ||= []; 135 | push @{ $self->{values}->{resources} }, [ $name, $value ]; 136 | } 137 | $self->{values}->{resources}; 138 | } 139 | 140 | # Aliases for build_requires that will have alternative 141 | # meanings in some future version of META.yml. 142 | sub test_requires { shift->build_requires(@_) } 143 | sub install_requires { shift->build_requires(@_) } 144 | 145 | # Aliases for installdirs options 146 | sub install_as_core { $_[0]->installdirs('perl') } 147 | sub install_as_cpan { $_[0]->installdirs('site') } 148 | sub install_as_site { $_[0]->installdirs('site') } 149 | sub install_as_vendor { $_[0]->installdirs('vendor') } 150 | 151 | sub dynamic_config { 152 | my $self = shift; 153 | unless ( @_ ) { 154 | warn "You MUST provide an explicit true/false value to dynamic_config\n"; 155 | return $self; 156 | } 157 | $self->{values}->{dynamic_config} = $_[0] ? 1 : 0; 158 | return 1; 159 | } 160 | 161 | sub perl_version { 162 | my $self = shift; 163 | return $self->{values}->{perl_version} unless @_; 164 | my $version = shift or die( 165 | "Did not provide a value to perl_version()" 166 | ); 167 | 168 | # Normalize the version 169 | $version = $self->_perl_version($version); 170 | 171 | # We don't support the reall old versions 172 | unless ( $version >= 5.005 ) { 173 | die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n"; 174 | } 175 | 176 | $self->{values}->{perl_version} = $version; 177 | } 178 | 179 | #Stolen from M::B 180 | my %license_urls = ( 181 | perl => 'http://dev.perl.org/licenses/', 182 | apache => 'http://apache.org/licenses/LICENSE-2.0', 183 | artistic => 'http://opensource.org/licenses/artistic-license.php', 184 | artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php', 185 | lgpl => 'http://opensource.org/licenses/lgpl-license.php', 186 | lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php', 187 | lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html', 188 | bsd => 'http://opensource.org/licenses/bsd-license.php', 189 | gpl => 'http://opensource.org/licenses/gpl-license.php', 190 | gpl2 => 'http://opensource.org/licenses/gpl-2.0.php', 191 | gpl3 => 'http://opensource.org/licenses/gpl-3.0.html', 192 | mit => 'http://opensource.org/licenses/mit-license.php', 193 | mozilla => 'http://opensource.org/licenses/mozilla1.1.php', 194 | open_source => undef, 195 | unrestricted => undef, 196 | restrictive => undef, 197 | unknown => undef, 198 | ); 199 | 200 | sub license { 201 | my $self = shift; 202 | return $self->{values}->{license} unless @_; 203 | my $license = shift or die( 204 | 'Did not provide a value to license()' 205 | ); 206 | $self->{values}->{license} = $license; 207 | 208 | # Automatically fill in license URLs 209 | if ( $license_urls{$license} ) { 210 | $self->resources( license => $license_urls{$license} ); 211 | } 212 | 213 | return 1; 214 | } 215 | 216 | sub all_from { 217 | my ( $self, $file ) = @_; 218 | 219 | unless ( defined($file) ) { 220 | my $name = $self->name or die( 221 | "all_from called with no args without setting name() first" 222 | ); 223 | $file = join('/', 'lib', split(/-/, $name)) . '.pm'; 224 | $file =~ s{.*/}{} unless -e $file; 225 | unless ( -e $file ) { 226 | die("all_from cannot find $file from $name"); 227 | } 228 | } 229 | unless ( -f $file ) { 230 | die("The path '$file' does not exist, or is not a file"); 231 | } 232 | 233 | # Some methods pull from POD instead of code. 234 | # If there is a matching .pod, use that instead 235 | my $pod = $file; 236 | $pod =~ s/\.pm$/.pod/i; 237 | $pod = $file unless -e $pod; 238 | 239 | # Pull the different values 240 | $self->name_from($file) unless $self->name; 241 | $self->version_from($file) unless $self->version; 242 | $self->perl_version_from($file) unless $self->perl_version; 243 | $self->author_from($pod) unless $self->author; 244 | $self->license_from($pod) unless $self->license; 245 | $self->abstract_from($pod) unless $self->abstract; 246 | 247 | return 1; 248 | } 249 | 250 | sub provides { 251 | my $self = shift; 252 | my $provides = ( $self->{values}->{provides} ||= {} ); 253 | %$provides = (%$provides, @_) if @_; 254 | return $provides; 255 | } 256 | 257 | sub auto_provides { 258 | my $self = shift; 259 | return $self unless $self->is_admin; 260 | unless (-e 'MANIFEST') { 261 | warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; 262 | return $self; 263 | } 264 | # Avoid spurious warnings as we are not checking manifest here. 265 | local $SIG{__WARN__} = sub {1}; 266 | require ExtUtils::Manifest; 267 | local *ExtUtils::Manifest::manicheck = sub { return }; 268 | 269 | require Module::Build; 270 | my $build = Module::Build->new( 271 | dist_name => $self->name, 272 | dist_version => $self->version, 273 | license => $self->license, 274 | ); 275 | $self->provides( %{ $build->find_dist_packages || {} } ); 276 | } 277 | 278 | sub feature { 279 | my $self = shift; 280 | my $name = shift; 281 | my $features = ( $self->{values}->{features} ||= [] ); 282 | my $mods; 283 | 284 | if ( @_ == 1 and ref( $_[0] ) ) { 285 | # The user used ->feature like ->features by passing in the second 286 | # argument as a reference. Accomodate for that. 287 | $mods = $_[0]; 288 | } else { 289 | $mods = \@_; 290 | } 291 | 292 | my $count = 0; 293 | push @$features, ( 294 | $name => [ 295 | map { 296 | ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ 297 | } @$mods 298 | ] 299 | ); 300 | 301 | return @$features; 302 | } 303 | 304 | sub features { 305 | my $self = shift; 306 | while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { 307 | $self->feature( $name, @$mods ); 308 | } 309 | return $self->{values}->{features} 310 | ? @{ $self->{values}->{features} } 311 | : (); 312 | } 313 | 314 | sub no_index { 315 | my $self = shift; 316 | my $type = shift; 317 | push @{ $self->{values}->{no_index}->{$type} }, @_ if $type; 318 | return $self->{values}->{no_index}; 319 | } 320 | 321 | sub read { 322 | my $self = shift; 323 | $self->include_deps( 'YAML::Tiny', 0 ); 324 | 325 | require YAML::Tiny; 326 | my $data = YAML::Tiny::LoadFile('META.yml'); 327 | 328 | # Call methods explicitly in case user has already set some values. 329 | while ( my ( $key, $value ) = each %$data ) { 330 | next unless $self->can($key); 331 | if ( ref $value eq 'HASH' ) { 332 | while ( my ( $module, $version ) = each %$value ) { 333 | $self->can($key)->($self, $module => $version ); 334 | } 335 | } else { 336 | $self->can($key)->($self, $value); 337 | } 338 | } 339 | return $self; 340 | } 341 | 342 | sub write { 343 | my $self = shift; 344 | return $self unless $self->is_admin; 345 | $self->admin->write_meta; 346 | return $self; 347 | } 348 | 349 | sub version_from { 350 | require ExtUtils::MM_Unix; 351 | my ( $self, $file ) = @_; 352 | $self->version( ExtUtils::MM_Unix->parse_version($file) ); 353 | } 354 | 355 | sub abstract_from { 356 | require ExtUtils::MM_Unix; 357 | my ( $self, $file ) = @_; 358 | $self->abstract( 359 | bless( 360 | { DISTNAME => $self->name }, 361 | 'ExtUtils::MM_Unix' 362 | )->parse_abstract($file) 363 | ); 364 | } 365 | 366 | # Add both distribution and module name 367 | sub name_from { 368 | my ($self, $file) = @_; 369 | if ( 370 | Module::Install::_read($file) =~ m/ 371 | ^ \s* 372 | package \s* 373 | ([\w:]+) 374 | \s* ; 375 | /ixms 376 | ) { 377 | my ($name, $module_name) = ($1, $1); 378 | $name =~ s{::}{-}g; 379 | $self->name($name); 380 | unless ( $self->module_name ) { 381 | $self->module_name($module_name); 382 | } 383 | } else { 384 | die("Cannot determine name from $file\n"); 385 | } 386 | } 387 | 388 | sub perl_version_from { 389 | my $self = shift; 390 | if ( 391 | Module::Install::_read($_[0]) =~ m/ 392 | ^ 393 | (?:use|require) \s* 394 | v? 395 | ([\d_\.]+) 396 | \s* ; 397 | /ixms 398 | ) { 399 | my $perl_version = $1; 400 | $perl_version =~ s{_}{}g; 401 | $self->perl_version($perl_version); 402 | } else { 403 | warn "Cannot determine perl version info from $_[0]\n"; 404 | return; 405 | } 406 | } 407 | 408 | sub author_from { 409 | my $self = shift; 410 | my $content = Module::Install::_read($_[0]); 411 | if ($content =~ m/ 412 | =head \d \s+ (?:authors?)\b \s* 413 | ([^\n]*) 414 | | 415 | =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* 416 | .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* 417 | ([^\n]*) 418 | /ixms) { 419 | my $author = $1 || $2; 420 | $author =~ s{E}{<}g; 421 | $author =~ s{E}{>}g; 422 | $self->author($author); 423 | } else { 424 | warn "Cannot determine author info from $_[0]\n"; 425 | } 426 | } 427 | 428 | sub license_from { 429 | my $self = shift; 430 | if ( 431 | Module::Install::_read($_[0]) =~ m/ 432 | ( 433 | =head \d \s+ 434 | (?:licen[cs]e|licensing|copyright|legal)\b 435 | .*? 436 | ) 437 | (=head\\d.*|=cut.*|) 438 | \z 439 | /ixms ) { 440 | my $license_text = $1; 441 | my @phrases = ( 442 | 'under the same (?:terms|license) as (?:perl|the perl programming language) itself' => 'perl', 1, 443 | 'GNU general public license' => 'gpl', 1, 444 | 'GNU public license' => 'gpl', 1, 445 | 'GNU lesser general public license' => 'lgpl', 1, 446 | 'GNU lesser public license' => 'lgpl', 1, 447 | 'GNU library general public license' => 'lgpl', 1, 448 | 'GNU library public license' => 'lgpl', 1, 449 | 'BSD license' => 'bsd', 1, 450 | 'Artistic license' => 'artistic', 1, 451 | 'GPL' => 'gpl', 1, 452 | 'LGPL' => 'lgpl', 1, 453 | 'BSD' => 'bsd', 1, 454 | 'Artistic' => 'artistic', 1, 455 | 'MIT' => 'mit', 1, 456 | 'proprietary' => 'proprietary', 0, 457 | ); 458 | while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { 459 | $pattern =~ s{\s+}{\\s+}g; 460 | if ( $license_text =~ /\b$pattern\b/i ) { 461 | $self->license($license); 462 | return 1; 463 | } 464 | } 465 | } 466 | 467 | warn "Cannot determine license info from $_[0]\n"; 468 | return 'unknown'; 469 | } 470 | 471 | sub _extract_bugtracker { 472 | my @links = $_[0] =~ m#L<(\Qhttp://rt.cpan.org/\E[^>]+)>#g; 473 | my %links; 474 | @links{@links}=(); 475 | @links=keys %links; 476 | return @links; 477 | } 478 | 479 | sub bugtracker_from { 480 | my $self = shift; 481 | my $content = Module::Install::_read($_[0]); 482 | my @links = _extract_bugtracker($content); 483 | unless ( @links ) { 484 | warn "Cannot determine bugtracker info from $_[0]\n"; 485 | return 0; 486 | } 487 | if ( @links > 1 ) { 488 | warn "Found more than on rt.cpan.org link in $_[0]\n"; 489 | return 0; 490 | } 491 | 492 | # Set the bugtracker 493 | bugtracker( $links[0] ); 494 | return 1; 495 | } 496 | 497 | sub requires_from { 498 | my $self = shift; 499 | my $content = Module::Install::_readperl($_[0]); 500 | my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; 501 | while ( @requires ) { 502 | my $module = shift @requires; 503 | my $version = shift @requires; 504 | $self->requires( $module => $version ); 505 | } 506 | } 507 | 508 | sub test_requires_from { 509 | my $self = shift; 510 | my $content = Module::Install::_readperl($_[0]); 511 | my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; 512 | while ( @requires ) { 513 | my $module = shift @requires; 514 | my $version = shift @requires; 515 | $self->test_requires( $module => $version ); 516 | } 517 | } 518 | 519 | # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to 520 | # numbers (eg, 5.006001 or 5.008009). 521 | # Also, convert double-part versions (eg, 5.8) 522 | sub _perl_version { 523 | my $v = $_[-1]; 524 | $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e; 525 | $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e; 526 | $v =~ s/(\.\d\d\d)000$/$1/; 527 | $v =~ s/_.+$//; 528 | if ( ref($v) ) { 529 | # Numify 530 | $v = $v + 0; 531 | } 532 | return $v; 533 | } 534 | 535 | 536 | 537 | 538 | 539 | ###################################################################### 540 | # MYMETA Support 541 | 542 | sub WriteMyMeta { 543 | die "WriteMyMeta has been deprecated"; 544 | } 545 | 546 | sub write_mymeta_yaml { 547 | my $self = shift; 548 | 549 | # We need YAML::Tiny to write the MYMETA.yml file 550 | unless ( eval { require YAML::Tiny; 1; } ) { 551 | return 1; 552 | } 553 | 554 | # Generate the data 555 | my $meta = $self->_write_mymeta_data or return 1; 556 | 557 | # Save as the MYMETA.yml file 558 | print "Writing MYMETA.yml\n"; 559 | YAML::Tiny::DumpFile('MYMETA.yml', $meta); 560 | } 561 | 562 | sub write_mymeta_json { 563 | my $self = shift; 564 | 565 | # We need JSON to write the MYMETA.json file 566 | unless ( eval { require JSON; 1; } ) { 567 | return 1; 568 | } 569 | 570 | # Generate the data 571 | my $meta = $self->_write_mymeta_data or return 1; 572 | 573 | # Save as the MYMETA.yml file 574 | print "Writing MYMETA.json\n"; 575 | Module::Install::_write( 576 | 'MYMETA.json', 577 | JSON->new->pretty(1)->canonical->encode($meta), 578 | ); 579 | } 580 | 581 | sub _write_mymeta_data { 582 | my $self = shift; 583 | 584 | # If there's no existing META.yml there is nothing we can do 585 | return undef unless -f 'META.yml'; 586 | 587 | # We need Parse::CPAN::Meta to load the file 588 | unless ( eval { require Parse::CPAN::Meta; 1; } ) { 589 | return undef; 590 | } 591 | 592 | # Merge the perl version into the dependencies 593 | my $val = $self->Meta->{values}; 594 | my $perl = delete $val->{perl_version}; 595 | if ( $perl ) { 596 | $val->{requires} ||= []; 597 | my $requires = $val->{requires}; 598 | 599 | # Canonize to three-dot version after Perl 5.6 600 | if ( $perl >= 5.006 ) { 601 | $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e 602 | } 603 | unshift @$requires, [ perl => $perl ]; 604 | } 605 | 606 | # Load the advisory META.yml file 607 | my @yaml = Parse::CPAN::Meta::LoadFile('META.yml'); 608 | my $meta = $yaml[0]; 609 | 610 | # Overwrite the non-configure dependency hashs 611 | delete $meta->{requires}; 612 | delete $meta->{build_requires}; 613 | delete $meta->{recommends}; 614 | if ( exists $val->{requires} ) { 615 | $meta->{requires} = { map { @$_ } @{ $val->{requires} } }; 616 | } 617 | if ( exists $val->{build_requires} ) { 618 | $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } }; 619 | } 620 | 621 | return $meta; 622 | } 623 | 624 | 1; 625 | -------------------------------------------------------------------------------- /test/inc/Test/More.pm: -------------------------------------------------------------------------------- 1 | #line 1 2 | package Test::More; 3 | 4 | use 5.006; 5 | use strict; 6 | use warnings; 7 | 8 | #---- perlcritic exemptions. ----# 9 | 10 | # We use a lot of subroutine prototypes 11 | ## no critic (Subroutines::ProhibitSubroutinePrototypes) 12 | 13 | # Can't use Carp because it might cause use_ok() to accidentally succeed 14 | # even though the module being used forgot to use Carp. Yes, this 15 | # actually happened. 16 | sub _carp { 17 | my( $file, $line ) = ( caller(1) )[ 1, 2 ]; 18 | return warn @_, " at $file line $line\n"; 19 | } 20 | 21 | our $VERSION = '0.94'; 22 | $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) 23 | 24 | use Test::Builder::Module; 25 | our @ISA = qw(Test::Builder::Module); 26 | our @EXPORT = qw(ok use_ok require_ok 27 | is isnt like unlike is_deeply 28 | cmp_ok 29 | skip todo todo_skip 30 | pass fail 31 | eq_array eq_hash eq_set 32 | $TODO 33 | plan 34 | done_testing 35 | can_ok isa_ok new_ok 36 | diag note explain 37 | subtest 38 | BAIL_OUT 39 | ); 40 | 41 | #line 164 42 | 43 | sub plan { 44 | my $tb = Test::More->builder; 45 | 46 | return $tb->plan(@_); 47 | } 48 | 49 | # This implements "use Test::More 'no_diag'" but the behavior is 50 | # deprecated. 51 | sub import_extra { 52 | my $class = shift; 53 | my $list = shift; 54 | 55 | my @other = (); 56 | my $idx = 0; 57 | while( $idx <= $#{$list} ) { 58 | my $item = $list->[$idx]; 59 | 60 | if( defined $item and $item eq 'no_diag' ) { 61 | $class->builder->no_diag(1); 62 | } 63 | else { 64 | push @other, $item; 65 | } 66 | 67 | $idx++; 68 | } 69 | 70 | @$list = @other; 71 | 72 | return; 73 | } 74 | 75 | #line 217 76 | 77 | sub done_testing { 78 | my $tb = Test::More->builder; 79 | $tb->done_testing(@_); 80 | } 81 | 82 | #line 289 83 | 84 | sub ok ($;$) { 85 | my( $test, $name ) = @_; 86 | my $tb = Test::More->builder; 87 | 88 | return $tb->ok( $test, $name ); 89 | } 90 | 91 | #line 367 92 | 93 | sub is ($$;$) { 94 | my $tb = Test::More->builder; 95 | 96 | return $tb->is_eq(@_); 97 | } 98 | 99 | sub isnt ($$;$) { 100 | my $tb = Test::More->builder; 101 | 102 | return $tb->isnt_eq(@_); 103 | } 104 | 105 | *isn't = \&isnt; 106 | 107 | #line 411 108 | 109 | sub like ($$;$) { 110 | my $tb = Test::More->builder; 111 | 112 | return $tb->like(@_); 113 | } 114 | 115 | #line 426 116 | 117 | sub unlike ($$;$) { 118 | my $tb = Test::More->builder; 119 | 120 | return $tb->unlike(@_); 121 | } 122 | 123 | #line 471 124 | 125 | sub cmp_ok($$$;$) { 126 | my $tb = Test::More->builder; 127 | 128 | return $tb->cmp_ok(@_); 129 | } 130 | 131 | #line 506 132 | 133 | sub can_ok ($@) { 134 | my( $proto, @methods ) = @_; 135 | my $class = ref $proto || $proto; 136 | my $tb = Test::More->builder; 137 | 138 | unless($class) { 139 | my $ok = $tb->ok( 0, "->can(...)" ); 140 | $tb->diag(' can_ok() called with empty class or reference'); 141 | return $ok; 142 | } 143 | 144 | unless(@methods) { 145 | my $ok = $tb->ok( 0, "$class->can(...)" ); 146 | $tb->diag(' can_ok() called with no methods'); 147 | return $ok; 148 | } 149 | 150 | my @nok = (); 151 | foreach my $method (@methods) { 152 | $tb->_try( sub { $proto->can($method) } ) or push @nok, $method; 153 | } 154 | 155 | my $name = (@methods == 1) ? "$class->can('$methods[0]')" : 156 | "$class->can(...)" ; 157 | 158 | my $ok = $tb->ok( !@nok, $name ); 159 | 160 | $tb->diag( map " $class->can('$_') failed\n", @nok ); 161 | 162 | return $ok; 163 | } 164 | 165 | #line 572 166 | 167 | sub isa_ok ($$;$) { 168 | my( $object, $class, $obj_name ) = @_; 169 | my $tb = Test::More->builder; 170 | 171 | my $diag; 172 | 173 | if( !defined $object ) { 174 | $obj_name = 'The thing' unless defined $obj_name; 175 | $diag = "$obj_name isn't defined"; 176 | } 177 | else { 178 | my $whatami = ref $object ? 'object' : 'class'; 179 | # We can't use UNIVERSAL::isa because we want to honor isa() overrides 180 | my( $rslt, $error ) = $tb->_try( sub { $object->isa($class) } ); 181 | if($error) { 182 | if( $error =~ /^Can't call method "isa" on unblessed reference/ ) { 183 | # Its an unblessed reference 184 | $obj_name = 'The reference' unless defined $obj_name; 185 | if( !UNIVERSAL::isa( $object, $class ) ) { 186 | my $ref = ref $object; 187 | $diag = "$obj_name isn't a '$class' it's a '$ref'"; 188 | } 189 | } 190 | elsif( $error =~ /Can't call method "isa" without a package/ ) { 191 | # It's something that can't even be a class 192 | $obj_name = 'The thing' unless defined $obj_name; 193 | $diag = "$obj_name isn't a class or reference"; 194 | } 195 | else { 196 | die <isa on your $whatami and got some weird error. 198 | Here's the error. 199 | $error 200 | WHOA 201 | } 202 | } 203 | else { 204 | $obj_name = "The $whatami" unless defined $obj_name; 205 | if( !$rslt ) { 206 | my $ref = ref $object; 207 | $diag = "$obj_name isn't a '$class' it's a '$ref'"; 208 | } 209 | } 210 | } 211 | 212 | my $name = "$obj_name isa $class"; 213 | my $ok; 214 | if($diag) { 215 | $ok = $tb->ok( 0, $name ); 216 | $tb->diag(" $diag\n"); 217 | } 218 | else { 219 | $ok = $tb->ok( 1, $name ); 220 | } 221 | 222 | return $ok; 223 | } 224 | 225 | #line 651 226 | 227 | sub new_ok { 228 | my $tb = Test::More->builder; 229 | $tb->croak("new_ok() must be given at least a class") unless @_; 230 | 231 | my( $class, $args, $object_name ) = @_; 232 | 233 | $args ||= []; 234 | $object_name = "The object" unless defined $object_name; 235 | 236 | my $obj; 237 | my( $success, $error ) = $tb->_try( sub { $obj = $class->new(@$args); 1 } ); 238 | if($success) { 239 | local $Test::Builder::Level = $Test::Builder::Level + 1; 240 | isa_ok $obj, $class, $object_name; 241 | } 242 | else { 243 | $tb->ok( 0, "new() died" ); 244 | $tb->diag(" Error was: $error"); 245 | } 246 | 247 | return $obj; 248 | } 249 | 250 | #line 719 251 | 252 | sub subtest($&) { 253 | my ($name, $subtests) = @_; 254 | 255 | my $tb = Test::More->builder; 256 | return $tb->subtest(@_); 257 | } 258 | 259 | #line 743 260 | 261 | sub pass (;$) { 262 | my $tb = Test::More->builder; 263 | 264 | return $tb->ok( 1, @_ ); 265 | } 266 | 267 | sub fail (;$) { 268 | my $tb = Test::More->builder; 269 | 270 | return $tb->ok( 0, @_ ); 271 | } 272 | 273 | #line 806 274 | 275 | sub use_ok ($;@) { 276 | my( $module, @imports ) = @_; 277 | @imports = () unless @imports; 278 | my $tb = Test::More->builder; 279 | 280 | my( $pack, $filename, $line ) = caller; 281 | 282 | my $code; 283 | if( @imports == 1 and $imports[0] =~ /^\d+(?:\.\d+)?$/ ) { 284 | # probably a version check. Perl needs to see the bare number 285 | # for it to work with non-Exporter based modules. 286 | $code = <ok( $eval_result, "use $module;" ); 302 | 303 | unless($ok) { 304 | chomp $eval_error; 305 | $@ =~ s{^BEGIN failed--compilation aborted at .*$} 306 | {BEGIN failed--compilation aborted at $filename line $line.}m; 307 | $tb->diag(<builder; 340 | 341 | my $pack = caller; 342 | 343 | # Try to deterine if we've been given a module name or file. 344 | # Module names must be barewords, files not. 345 | $module = qq['$module'] unless _is_module_name($module); 346 | 347 | my $code = <ok( $eval_result, "require $module;" ); 355 | 356 | unless($ok) { 357 | chomp $eval_error; 358 | $tb->diag(<builder; 391 | 392 | unless( @_ == 2 or @_ == 3 ) { 393 | my $msg = <<'WARNING'; 394 | is_deeply() takes two or three args, you gave %d. 395 | This usually means you passed an array or hash instead 396 | of a reference to it 397 | WARNING 398 | chop $msg; # clip off newline so carp() will put in line/file 399 | 400 | _carp sprintf $msg, scalar @_; 401 | 402 | return $tb->ok(0); 403 | } 404 | 405 | my( $got, $expected, $name ) = @_; 406 | 407 | $tb->_unoverload_str( \$expected, \$got ); 408 | 409 | my $ok; 410 | if( !ref $got and !ref $expected ) { # neither is a reference 411 | $ok = $tb->is_eq( $got, $expected, $name ); 412 | } 413 | elsif( !ref $got xor !ref $expected ) { # one's a reference, one isn't 414 | $ok = $tb->ok( 0, $name ); 415 | $tb->diag( _format_stack({ vals => [ $got, $expected ] }) ); 416 | } 417 | else { # both references 418 | local @Data_Stack = (); 419 | if( _deep_check( $got, $expected ) ) { 420 | $ok = $tb->ok( 1, $name ); 421 | } 422 | else { 423 | $ok = $tb->ok( 0, $name ); 424 | $tb->diag( _format_stack(@Data_Stack) ); 425 | } 426 | } 427 | 428 | return $ok; 429 | } 430 | 431 | sub _format_stack { 432 | my(@Stack) = @_; 433 | 434 | my $var = '$FOO'; 435 | my $did_arrow = 0; 436 | foreach my $entry (@Stack) { 437 | my $type = $entry->{type} || ''; 438 | my $idx = $entry->{'idx'}; 439 | if( $type eq 'HASH' ) { 440 | $var .= "->" unless $did_arrow++; 441 | $var .= "{$idx}"; 442 | } 443 | elsif( $type eq 'ARRAY' ) { 444 | $var .= "->" unless $did_arrow++; 445 | $var .= "[$idx]"; 446 | } 447 | elsif( $type eq 'REF' ) { 448 | $var = "\${$var}"; 449 | } 450 | } 451 | 452 | my @vals = @{ $Stack[-1]{vals} }[ 0, 1 ]; 453 | my @vars = (); 454 | ( $vars[0] = $var ) =~ s/\$FOO/ \$got/; 455 | ( $vars[1] = $var ) =~ s/\$FOO/\$expected/; 456 | 457 | my $out = "Structures begin differing at:\n"; 458 | foreach my $idx ( 0 .. $#vals ) { 459 | my $val = $vals[$idx]; 460 | $vals[$idx] 461 | = !defined $val ? 'undef' 462 | : _dne($val) ? "Does not exist" 463 | : ref $val ? "$val" 464 | : "'$val'"; 465 | } 466 | 467 | $out .= "$vars[0] = $vals[0]\n"; 468 | $out .= "$vars[1] = $vals[1]\n"; 469 | 470 | $out =~ s/^/ /msg; 471 | return $out; 472 | } 473 | 474 | sub _type { 475 | my $thing = shift; 476 | 477 | return '' if !ref $thing; 478 | 479 | for my $type (qw(ARRAY HASH REF SCALAR GLOB CODE Regexp)) { 480 | return $type if UNIVERSAL::isa( $thing, $type ); 481 | } 482 | 483 | return ''; 484 | } 485 | 486 | #line 1112 487 | 488 | sub diag { 489 | return Test::More->builder->diag(@_); 490 | } 491 | 492 | sub note { 493 | return Test::More->builder->note(@_); 494 | } 495 | 496 | #line 1138 497 | 498 | sub explain { 499 | return Test::More->builder->explain(@_); 500 | } 501 | 502 | #line 1204 503 | 504 | ## no critic (Subroutines::RequireFinalReturn) 505 | sub skip { 506 | my( $why, $how_many ) = @_; 507 | my $tb = Test::More->builder; 508 | 509 | unless( defined $how_many ) { 510 | # $how_many can only be avoided when no_plan is in use. 511 | _carp "skip() needs to know \$how_many tests are in the block" 512 | unless $tb->has_plan eq 'no_plan'; 513 | $how_many = 1; 514 | } 515 | 516 | if( defined $how_many and $how_many =~ /\D/ ) { 517 | _carp 518 | "skip() was passed a non-numeric number of tests. Did you get the arguments backwards?"; 519 | $how_many = 1; 520 | } 521 | 522 | for( 1 .. $how_many ) { 523 | $tb->skip($why); 524 | } 525 | 526 | no warnings 'exiting'; 527 | last SKIP; 528 | } 529 | 530 | #line 1288 531 | 532 | sub todo_skip { 533 | my( $why, $how_many ) = @_; 534 | my $tb = Test::More->builder; 535 | 536 | unless( defined $how_many ) { 537 | # $how_many can only be avoided when no_plan is in use. 538 | _carp "todo_skip() needs to know \$how_many tests are in the block" 539 | unless $tb->has_plan eq 'no_plan'; 540 | $how_many = 1; 541 | } 542 | 543 | for( 1 .. $how_many ) { 544 | $tb->todo_skip($why); 545 | } 546 | 547 | no warnings 'exiting'; 548 | last TODO; 549 | } 550 | 551 | #line 1343 552 | 553 | sub BAIL_OUT { 554 | my $reason = shift; 555 | my $tb = Test::More->builder; 556 | 557 | $tb->BAIL_OUT($reason); 558 | } 559 | 560 | #line 1382 561 | 562 | #'# 563 | sub eq_array { 564 | local @Data_Stack = (); 565 | _deep_check(@_); 566 | } 567 | 568 | sub _eq_array { 569 | my( $a1, $a2 ) = @_; 570 | 571 | if( grep _type($_) ne 'ARRAY', $a1, $a2 ) { 572 | warn "eq_array passed a non-array ref"; 573 | return 0; 574 | } 575 | 576 | return 1 if $a1 eq $a2; 577 | 578 | my $ok = 1; 579 | my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2; 580 | for( 0 .. $max ) { 581 | my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_]; 582 | my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_]; 583 | 584 | push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [ $e1, $e2 ] }; 585 | $ok = _deep_check( $e1, $e2 ); 586 | pop @Data_Stack if $ok; 587 | 588 | last unless $ok; 589 | } 590 | 591 | return $ok; 592 | } 593 | 594 | sub _deep_check { 595 | my( $e1, $e2 ) = @_; 596 | my $tb = Test::More->builder; 597 | 598 | my $ok = 0; 599 | 600 | # Effectively turn %Refs_Seen into a stack. This avoids picking up 601 | # the same referenced used twice (such as [\$a, \$a]) to be considered 602 | # circular. 603 | local %Refs_Seen = %Refs_Seen; 604 | 605 | { 606 | # Quiet uninitialized value warnings when comparing undefs. 607 | no warnings 'uninitialized'; 608 | 609 | $tb->_unoverload_str( \$e1, \$e2 ); 610 | 611 | # Either they're both references or both not. 612 | my $same_ref = !( !ref $e1 xor !ref $e2 ); 613 | my $not_ref = ( !ref $e1 and !ref $e2 ); 614 | 615 | if( defined $e1 xor defined $e2 ) { 616 | $ok = 0; 617 | } 618 | elsif( !defined $e1 and !defined $e2 ) { 619 | # Shortcut if they're both defined. 620 | $ok = 1; 621 | } 622 | elsif( _dne($e1) xor _dne($e2) ) { 623 | $ok = 0; 624 | } 625 | elsif( $same_ref and( $e1 eq $e2 ) ) { 626 | $ok = 1; 627 | } 628 | elsif($not_ref) { 629 | push @Data_Stack, { type => '', vals => [ $e1, $e2 ] }; 630 | $ok = 0; 631 | } 632 | else { 633 | if( $Refs_Seen{$e1} ) { 634 | return $Refs_Seen{$e1} eq $e2; 635 | } 636 | else { 637 | $Refs_Seen{$e1} = "$e2"; 638 | } 639 | 640 | my $type = _type($e1); 641 | $type = 'DIFFERENT' unless _type($e2) eq $type; 642 | 643 | if( $type eq 'DIFFERENT' ) { 644 | push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] }; 645 | $ok = 0; 646 | } 647 | elsif( $type eq 'ARRAY' ) { 648 | $ok = _eq_array( $e1, $e2 ); 649 | } 650 | elsif( $type eq 'HASH' ) { 651 | $ok = _eq_hash( $e1, $e2 ); 652 | } 653 | elsif( $type eq 'REF' ) { 654 | push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] }; 655 | $ok = _deep_check( $$e1, $$e2 ); 656 | pop @Data_Stack if $ok; 657 | } 658 | elsif( $type eq 'SCALAR' ) { 659 | push @Data_Stack, { type => 'REF', vals => [ $e1, $e2 ] }; 660 | $ok = _deep_check( $$e1, $$e2 ); 661 | pop @Data_Stack if $ok; 662 | } 663 | elsif($type) { 664 | push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] }; 665 | $ok = 0; 666 | } 667 | else { 668 | _whoa( 1, "No type in _deep_check" ); 669 | } 670 | } 671 | } 672 | 673 | return $ok; 674 | } 675 | 676 | sub _whoa { 677 | my( $check, $desc ) = @_; 678 | if($check) { 679 | die <<"WHOA"; 680 | WHOA! $desc 681 | This should never happen! Please contact the author immediately! 682 | WHOA 683 | } 684 | } 685 | 686 | #line 1515 687 | 688 | sub eq_hash { 689 | local @Data_Stack = (); 690 | return _deep_check(@_); 691 | } 692 | 693 | sub _eq_hash { 694 | my( $a1, $a2 ) = @_; 695 | 696 | if( grep _type($_) ne 'HASH', $a1, $a2 ) { 697 | warn "eq_hash passed a non-hash ref"; 698 | return 0; 699 | } 700 | 701 | return 1 if $a1 eq $a2; 702 | 703 | my $ok = 1; 704 | my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2; 705 | foreach my $k ( keys %$bigger ) { 706 | my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE; 707 | my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE; 708 | 709 | push @Data_Stack, { type => 'HASH', idx => $k, vals => [ $e1, $e2 ] }; 710 | $ok = _deep_check( $e1, $e2 ); 711 | pop @Data_Stack if $ok; 712 | 713 | last unless $ok; 714 | } 715 | 716 | return $ok; 717 | } 718 | 719 | #line 1572 720 | 721 | sub eq_set { 722 | my( $a1, $a2 ) = @_; 723 | return 0 unless @$a1 == @$a2; 724 | 725 | no warnings 'uninitialized'; 726 | 727 | # It really doesn't matter how we sort them, as long as both arrays are 728 | # sorted with the same algorithm. 729 | # 730 | # Ensure that references are not accidentally treated the same as a 731 | # string containing the reference. 732 | # 733 | # Have to inline the sort routine due to a threading/sort bug. 734 | # See [rt.cpan.org 6782] 735 | # 736 | # I don't know how references would be sorted so we just don't sort 737 | # them. This means eq_set doesn't really work with refs. 738 | return eq_array( 739 | [ grep( ref, @$a1 ), sort( grep( !ref, @$a1 ) ) ], 740 | [ grep( ref, @$a2 ), sort( grep( !ref, @$a2 ) ) ], 741 | ); 742 | } 743 | 744 | #line 1774 745 | 746 | 1; 747 | -------------------------------------------------------------------------------- /test/inc/Test/Base.pm: -------------------------------------------------------------------------------- 1 | #line 1 2 | # TODO: 3 | # 4 | package Test::Base; 5 | use 5.006001; 6 | use Spiffy 0.30 -Base; 7 | use Spiffy ':XXX'; 8 | our $VERSION = '0.59'; 9 | 10 | my @test_more_exports; 11 | BEGIN { 12 | @test_more_exports = qw( 13 | ok isnt like unlike is_deeply cmp_ok 14 | skip todo_skip pass fail 15 | eq_array eq_hash eq_set 16 | plan can_ok isa_ok diag 17 | use_ok 18 | $TODO 19 | ); 20 | } 21 | 22 | use Test::More import => \@test_more_exports; 23 | use Carp; 24 | 25 | our @EXPORT = (@test_more_exports, qw( 26 | is no_diff 27 | 28 | blocks next_block first_block 29 | delimiters spec_file spec_string 30 | filters filters_delay filter_arguments 31 | run run_compare run_is run_is_deeply run_like run_unlike 32 | skip_all_unless_require is_deep run_is_deep 33 | WWW XXX YYY ZZZ 34 | tie_output no_diag_on_only 35 | 36 | find_my_self default_object 37 | 38 | croak carp cluck confess 39 | )); 40 | 41 | field '_spec_file'; 42 | field '_spec_string'; 43 | field _filters => [qw(norm trim)]; 44 | field _filters_map => {}; 45 | field spec => 46 | -init => '$self->_spec_init'; 47 | field block_list => 48 | -init => '$self->_block_list_init'; 49 | field _next_list => []; 50 | field block_delim => 51 | -init => '$self->block_delim_default'; 52 | field data_delim => 53 | -init => '$self->data_delim_default'; 54 | field _filters_delay => 0; 55 | field _no_diag_on_only => 0; 56 | 57 | field block_delim_default => '==='; 58 | field data_delim_default => '---'; 59 | 60 | my $default_class; 61 | my $default_object; 62 | my $reserved_section_names = {}; 63 | 64 | sub default_object { 65 | $default_object ||= $default_class->new; 66 | return $default_object; 67 | } 68 | 69 | my $import_called = 0; 70 | sub import() { 71 | $import_called = 1; 72 | my $class = (grep /^-base$/i, @_) 73 | ? scalar(caller) 74 | : $_[0]; 75 | if (not defined $default_class) { 76 | $default_class = $class; 77 | } 78 | # else { 79 | # croak "Can't use $class after using $default_class" 80 | # unless $default_class->isa($class); 81 | # } 82 | 83 | unless (grep /^-base$/i, @_) { 84 | my @args; 85 | for (my $ii = 1; $ii <= $#_; ++$ii) { 86 | if ($_[$ii] eq '-package') { 87 | ++$ii; 88 | } else { 89 | push @args, $_[$ii]; 90 | } 91 | } 92 | Test::More->import(import => \@test_more_exports, @args) 93 | if @args; 94 | } 95 | 96 | _strict_warnings(); 97 | goto &Spiffy::import; 98 | } 99 | 100 | # Wrap Test::Builder::plan 101 | my $plan_code = \&Test::Builder::plan; 102 | my $Have_Plan = 0; 103 | { 104 | no warnings 'redefine'; 105 | *Test::Builder::plan = sub { 106 | $Have_Plan = 1; 107 | goto &$plan_code; 108 | }; 109 | } 110 | 111 | my $DIED = 0; 112 | $SIG{__DIE__} = sub { $DIED = 1; die @_ }; 113 | 114 | sub block_class { $self->find_class('Block') } 115 | sub filter_class { $self->find_class('Filter') } 116 | 117 | sub find_class { 118 | my $suffix = shift; 119 | my $class = ref($self) . "::$suffix"; 120 | return $class if $class->can('new'); 121 | $class = __PACKAGE__ . "::$suffix"; 122 | return $class if $class->can('new'); 123 | eval "require $class"; 124 | return $class if $class->can('new'); 125 | die "Can't find a class for $suffix"; 126 | } 127 | 128 | sub check_late { 129 | if ($self->{block_list}) { 130 | my $caller = (caller(1))[3]; 131 | $caller =~ s/.*:://; 132 | croak "Too late to call $caller()" 133 | } 134 | } 135 | 136 | sub find_my_self() { 137 | my $self = ref($_[0]) eq $default_class 138 | ? splice(@_, 0, 1) 139 | : default_object(); 140 | return $self, @_; 141 | } 142 | 143 | sub blocks() { 144 | (my ($self), @_) = find_my_self(@_); 145 | 146 | croak "Invalid arguments passed to 'blocks'" 147 | if @_ > 1; 148 | croak sprintf("'%s' is invalid argument to blocks()", shift(@_)) 149 | if @_ && $_[0] !~ /^[a-zA-Z]\w*$/; 150 | 151 | my $blocks = $self->block_list; 152 | 153 | my $section_name = shift || ''; 154 | my @blocks = $section_name 155 | ? (grep { exists $_->{$section_name} } @$blocks) 156 | : (@$blocks); 157 | 158 | return scalar(@blocks) unless wantarray; 159 | 160 | return (@blocks) if $self->_filters_delay; 161 | 162 | for my $block (@blocks) { 163 | $block->run_filters 164 | unless $block->is_filtered; 165 | } 166 | 167 | return (@blocks); 168 | } 169 | 170 | sub next_block() { 171 | (my ($self), @_) = find_my_self(@_); 172 | my $list = $self->_next_list; 173 | if (@$list == 0) { 174 | $list = [@{$self->block_list}, undef]; 175 | $self->_next_list($list); 176 | } 177 | my $block = shift @$list; 178 | if (defined $block and not $block->is_filtered) { 179 | $block->run_filters; 180 | } 181 | return $block; 182 | } 183 | 184 | sub first_block() { 185 | (my ($self), @_) = find_my_self(@_); 186 | $self->_next_list([]); 187 | $self->next_block; 188 | } 189 | 190 | sub filters_delay() { 191 | (my ($self), @_) = find_my_self(@_); 192 | $self->_filters_delay(defined $_[0] ? shift : 1); 193 | } 194 | 195 | sub no_diag_on_only() { 196 | (my ($self), @_) = find_my_self(@_); 197 | $self->_no_diag_on_only(defined $_[0] ? shift : 1); 198 | } 199 | 200 | sub delimiters() { 201 | (my ($self), @_) = find_my_self(@_); 202 | $self->check_late; 203 | my ($block_delimiter, $data_delimiter) = @_; 204 | $block_delimiter ||= $self->block_delim_default; 205 | $data_delimiter ||= $self->data_delim_default; 206 | $self->block_delim($block_delimiter); 207 | $self->data_delim($data_delimiter); 208 | return $self; 209 | } 210 | 211 | sub spec_file() { 212 | (my ($self), @_) = find_my_self(@_); 213 | $self->check_late; 214 | $self->_spec_file(shift); 215 | return $self; 216 | } 217 | 218 | sub spec_string() { 219 | (my ($self), @_) = find_my_self(@_); 220 | $self->check_late; 221 | $self->_spec_string(shift); 222 | return $self; 223 | } 224 | 225 | sub filters() { 226 | (my ($self), @_) = find_my_self(@_); 227 | if (ref($_[0]) eq 'HASH') { 228 | $self->_filters_map(shift); 229 | } 230 | else { 231 | my $filters = $self->_filters; 232 | push @$filters, @_; 233 | } 234 | return $self; 235 | } 236 | 237 | sub filter_arguments() { 238 | $Test::Base::Filter::arguments; 239 | } 240 | 241 | sub have_text_diff { 242 | eval { require Text::Diff; 1 } && 243 | $Text::Diff::VERSION >= 0.35 && 244 | $Algorithm::Diff::VERSION >= 1.15; 245 | } 246 | 247 | sub is($$;$) { 248 | (my ($self), @_) = find_my_self(@_); 249 | my ($actual, $expected, $name) = @_; 250 | local $Test::Builder::Level = $Test::Builder::Level + 1; 251 | if ($ENV{TEST_SHOW_NO_DIFFS} or 252 | not defined $actual or 253 | not defined $expected or 254 | $actual eq $expected or 255 | not($self->have_text_diff) or 256 | $expected !~ /\n./s 257 | ) { 258 | Test::More::is($actual, $expected, $name); 259 | } 260 | else { 261 | $name = '' unless defined $name; 262 | ok $actual eq $expected, 263 | $name . "\n" . Text::Diff::diff(\$expected, \$actual); 264 | } 265 | } 266 | 267 | sub run(&;$) { 268 | (my ($self), @_) = find_my_self(@_); 269 | my $callback = shift; 270 | for my $block (@{$self->block_list}) { 271 | $block->run_filters unless $block->is_filtered; 272 | &{$callback}($block); 273 | } 274 | } 275 | 276 | my $name_error = "Can't determine section names"; 277 | sub _section_names { 278 | return @_ if @_ == 2; 279 | my $block = $self->first_block 280 | or croak $name_error; 281 | my @names = grep { 282 | $_ !~ /^(ONLY|LAST|SKIP)$/; 283 | } @{$block->{_section_order}[0] || []}; 284 | croak "$name_error. Need two sections in first block" 285 | unless @names == 2; 286 | return @names; 287 | } 288 | 289 | sub _assert_plan { 290 | plan('no_plan') unless $Have_Plan; 291 | } 292 | 293 | sub END { 294 | run_compare() unless $Have_Plan or $DIED or not $import_called; 295 | } 296 | 297 | sub run_compare() { 298 | (my ($self), @_) = find_my_self(@_); 299 | $self->_assert_plan; 300 | my ($x, $y) = $self->_section_names(@_); 301 | local $Test::Builder::Level = $Test::Builder::Level + 1; 302 | for my $block (@{$self->block_list}) { 303 | next unless exists($block->{$x}) and exists($block->{$y}); 304 | $block->run_filters unless $block->is_filtered; 305 | if (ref $block->$x) { 306 | is_deeply($block->$x, $block->$y, 307 | $block->name ? $block->name : ()); 308 | } 309 | elsif (ref $block->$y eq 'Regexp') { 310 | my $regexp = ref $y ? $y : $block->$y; 311 | like($block->$x, $regexp, $block->name ? $block->name : ()); 312 | } 313 | else { 314 | is($block->$x, $block->$y, $block->name ? $block->name : ()); 315 | } 316 | } 317 | } 318 | 319 | sub run_is() { 320 | (my ($self), @_) = find_my_self(@_); 321 | $self->_assert_plan; 322 | my ($x, $y) = $self->_section_names(@_); 323 | local $Test::Builder::Level = $Test::Builder::Level + 1; 324 | for my $block (@{$self->block_list}) { 325 | next unless exists($block->{$x}) and exists($block->{$y}); 326 | $block->run_filters unless $block->is_filtered; 327 | is($block->$x, $block->$y, 328 | $block->name ? $block->name : () 329 | ); 330 | } 331 | } 332 | 333 | sub run_is_deeply() { 334 | (my ($self), @_) = find_my_self(@_); 335 | $self->_assert_plan; 336 | my ($x, $y) = $self->_section_names(@_); 337 | for my $block (@{$self->block_list}) { 338 | next unless exists($block->{$x}) and exists($block->{$y}); 339 | $block->run_filters unless $block->is_filtered; 340 | is_deeply($block->$x, $block->$y, 341 | $block->name ? $block->name : () 342 | ); 343 | } 344 | } 345 | 346 | sub run_like() { 347 | (my ($self), @_) = find_my_self(@_); 348 | $self->_assert_plan; 349 | my ($x, $y) = $self->_section_names(@_); 350 | for my $block (@{$self->block_list}) { 351 | next unless exists($block->{$x}) and defined($y); 352 | $block->run_filters unless $block->is_filtered; 353 | my $regexp = ref $y ? $y : $block->$y; 354 | like($block->$x, $regexp, 355 | $block->name ? $block->name : () 356 | ); 357 | } 358 | } 359 | 360 | sub run_unlike() { 361 | (my ($self), @_) = find_my_self(@_); 362 | $self->_assert_plan; 363 | my ($x, $y) = $self->_section_names(@_); 364 | for my $block (@{$self->block_list}) { 365 | next unless exists($block->{$x}) and defined($y); 366 | $block->run_filters unless $block->is_filtered; 367 | my $regexp = ref $y ? $y : $block->$y; 368 | unlike($block->$x, $regexp, 369 | $block->name ? $block->name : () 370 | ); 371 | } 372 | } 373 | 374 | sub skip_all_unless_require() { 375 | (my ($self), @_) = find_my_self(@_); 376 | my $module = shift; 377 | eval "require $module; 1" 378 | or Test::More::plan( 379 | skip_all => "$module failed to load" 380 | ); 381 | } 382 | 383 | sub is_deep() { 384 | (my ($self), @_) = find_my_self(@_); 385 | require Test::Deep; 386 | Test::Deep::cmp_deeply(@_); 387 | } 388 | 389 | sub run_is_deep() { 390 | (my ($self), @_) = find_my_self(@_); 391 | $self->_assert_plan; 392 | my ($x, $y) = $self->_section_names(@_); 393 | for my $block (@{$self->block_list}) { 394 | next unless exists($block->{$x}) and exists($block->{$y}); 395 | $block->run_filters unless $block->is_filtered; 396 | is_deep($block->$x, $block->$y, 397 | $block->name ? $block->name : () 398 | ); 399 | } 400 | } 401 | 402 | sub _pre_eval { 403 | my $spec = shift; 404 | return $spec unless $spec =~ 405 | s/\A\s*<<<(.*?)>>>\s*$//sm; 406 | my $eval_code = $1; 407 | eval "package main; $eval_code"; 408 | croak $@ if $@; 409 | return $spec; 410 | } 411 | 412 | sub _block_list_init { 413 | my $spec = $self->spec; 414 | $spec = $self->_pre_eval($spec); 415 | my $cd = $self->block_delim; 416 | my @hunks = ($spec =~ /^(\Q${cd}\E.*?(?=^\Q${cd}\E|\z))/msg); 417 | my $blocks = $self->_choose_blocks(@hunks); 418 | $self->block_list($blocks); # Need to set early for possible filter use 419 | my $seq = 1; 420 | for my $block (@$blocks) { 421 | $block->blocks_object($self); 422 | $block->seq_num($seq++); 423 | } 424 | return $blocks; 425 | } 426 | 427 | sub _choose_blocks { 428 | my $blocks = []; 429 | for my $hunk (@_) { 430 | my $block = $self->_make_block($hunk); 431 | if (exists $block->{ONLY}) { 432 | diag "I found ONLY: maybe you're debugging?" 433 | unless $self->_no_diag_on_only; 434 | return [$block]; 435 | } 436 | next if exists $block->{SKIP}; 437 | push @$blocks, $block; 438 | if (exists $block->{LAST}) { 439 | return $blocks; 440 | } 441 | } 442 | return $blocks; 443 | } 444 | 445 | sub _check_reserved { 446 | my $id = shift; 447 | croak "'$id' is a reserved name. Use something else.\n" 448 | if $reserved_section_names->{$id} or 449 | $id =~ /^_/; 450 | } 451 | 452 | sub _make_block { 453 | my $hunk = shift; 454 | my $cd = $self->block_delim; 455 | my $dd = $self->data_delim; 456 | my $block = $self->block_class->new; 457 | $hunk =~ s/\A\Q${cd}\E[ \t]*(.*)\s+// or die; 458 | my $name = $1; 459 | my @parts = split /^\Q${dd}\E +\(?(\w+)\)? *(.*)?\n/m, $hunk; 460 | my $description = shift @parts; 461 | $description ||= ''; 462 | unless ($description =~ /\S/) { 463 | $description = $name; 464 | } 465 | $description =~ s/\s*\z//; 466 | $block->set_value(description => $description); 467 | 468 | my $section_map = {}; 469 | my $section_order = []; 470 | while (@parts) { 471 | my ($type, $filters, $value) = splice(@parts, 0, 3); 472 | $self->_check_reserved($type); 473 | $value = '' unless defined $value; 474 | $filters = '' unless defined $filters; 475 | if ($filters =~ /:(\s|\z)/) { 476 | croak "Extra lines not allowed in '$type' section" 477 | if $value =~ /\S/; 478 | ($filters, $value) = split /\s*:(?:\s+|\z)/, $filters, 2; 479 | $value = '' unless defined $value; 480 | $value =~ s/^\s*(.*?)\s*$/$1/; 481 | } 482 | $section_map->{$type} = { 483 | filters => $filters, 484 | }; 485 | push @$section_order, $type; 486 | $block->set_value($type, $value); 487 | } 488 | $block->set_value(name => $name); 489 | $block->set_value(_section_map => $section_map); 490 | $block->set_value(_section_order => $section_order); 491 | return $block; 492 | } 493 | 494 | sub _spec_init { 495 | return $self->_spec_string 496 | if $self->_spec_string; 497 | local $/; 498 | my $spec; 499 | if (my $spec_file = $self->_spec_file) { 500 | open FILE, $spec_file or die $!; 501 | $spec = ; 502 | close FILE; 503 | } 504 | else { 505 | $spec = do { 506 | package main; 507 | no warnings 'once'; 508 | ; 509 | }; 510 | } 511 | return $spec; 512 | } 513 | 514 | sub _strict_warnings() { 515 | require Filter::Util::Call; 516 | my $done = 0; 517 | Filter::Util::Call::filter_add( 518 | sub { 519 | return 0 if $done; 520 | my ($data, $end) = ('', ''); 521 | while (my $status = Filter::Util::Call::filter_read()) { 522 | return $status if $status < 0; 523 | if (/^__(?:END|DATA)__\r?$/) { 524 | $end = $_; 525 | last; 526 | } 527 | $data .= $_; 528 | $_ = ''; 529 | } 530 | $_ = "use strict;use warnings;$data$end"; 531 | $done = 1; 532 | } 533 | ); 534 | } 535 | 536 | sub tie_output() { 537 | my $handle = shift; 538 | die "No buffer to tie" unless @_; 539 | tie $handle, 'Test::Base::Handle', $_[0]; 540 | } 541 | 542 | sub no_diff { 543 | $ENV{TEST_SHOW_NO_DIFFS} = 1; 544 | } 545 | 546 | package Test::Base::Handle; 547 | 548 | sub TIEHANDLE() { 549 | my $class = shift; 550 | bless \ $_[0], $class; 551 | } 552 | 553 | sub PRINT { 554 | $$self .= $_ for @_; 555 | } 556 | 557 | #=============================================================================== 558 | # Test::Base::Block 559 | # 560 | # This is the default class for accessing a Test::Base block object. 561 | #=============================================================================== 562 | package Test::Base::Block; 563 | our @ISA = qw(Spiffy); 564 | 565 | our @EXPORT = qw(block_accessor); 566 | 567 | sub AUTOLOAD { 568 | return; 569 | } 570 | 571 | sub block_accessor() { 572 | my $accessor = shift; 573 | no strict 'refs'; 574 | return if defined &$accessor; 575 | *$accessor = sub { 576 | my $self = shift; 577 | if (@_) { 578 | Carp::croak "Not allowed to set values for '$accessor'"; 579 | } 580 | my @list = @{$self->{$accessor} || []}; 581 | return wantarray 582 | ? (@list) 583 | : $list[0]; 584 | }; 585 | } 586 | 587 | block_accessor 'name'; 588 | block_accessor 'description'; 589 | Spiffy::field 'seq_num'; 590 | Spiffy::field 'is_filtered'; 591 | Spiffy::field 'blocks_object'; 592 | Spiffy::field 'original_values' => {}; 593 | 594 | sub set_value { 595 | no strict 'refs'; 596 | my $accessor = shift; 597 | block_accessor $accessor 598 | unless defined &$accessor; 599 | $self->{$accessor} = [@_]; 600 | } 601 | 602 | sub run_filters { 603 | my $map = $self->_section_map; 604 | my $order = $self->_section_order; 605 | Carp::croak "Attempt to filter a block twice" 606 | if $self->is_filtered; 607 | for my $type (@$order) { 608 | my $filters = $map->{$type}{filters}; 609 | my @value = $self->$type; 610 | $self->original_values->{$type} = $value[0]; 611 | for my $filter ($self->_get_filters($type, $filters)) { 612 | $Test::Base::Filter::arguments = 613 | $filter =~ s/=(.*)$// ? $1 : undef; 614 | my $function = "main::$filter"; 615 | no strict 'refs'; 616 | if (defined &$function) { 617 | local $_ = 618 | (@value == 1 and not defined($value[0])) ? undef : 619 | join '', @value; 620 | my $old = $_; 621 | @value = &$function(@value); 622 | if (not(@value) or 623 | @value == 1 and defined($value[0]) and $value[0] =~ /\A(\d+|)\z/ 624 | ) { 625 | if ($value[0] && $_ eq $old) { 626 | Test::Base::diag("Filters returning numbers are supposed to do munging \$_: your filter '$function' apparently doesn't."); 627 | } 628 | @value = ($_); 629 | } 630 | } 631 | else { 632 | my $filter_object = $self->blocks_object->filter_class->new; 633 | die "Can't find a function or method for '$filter' filter\n" 634 | unless $filter_object->can($filter); 635 | $filter_object->current_block($self); 636 | @value = $filter_object->$filter(@value); 637 | } 638 | # Set the value after each filter since other filters may be 639 | # introspecting. 640 | $self->set_value($type, @value); 641 | } 642 | } 643 | $self->is_filtered(1); 644 | } 645 | 646 | sub _get_filters { 647 | my $type = shift; 648 | my $string = shift || ''; 649 | $string =~ s/\s*(.*?)\s*/$1/; 650 | my @filters = (); 651 | my $map_filters = $self->blocks_object->_filters_map->{$type} || []; 652 | $map_filters = [ $map_filters ] unless ref $map_filters; 653 | my @append = (); 654 | for ( 655 | @{$self->blocks_object->_filters}, 656 | @$map_filters, 657 | split(/\s+/, $string), 658 | ) { 659 | my $filter = $_; 660 | last unless length $filter; 661 | if ($filter =~ s/^-//) { 662 | @filters = grep { $_ ne $filter } @filters; 663 | } 664 | elsif ($filter =~ s/^\+//) { 665 | push @append, $filter; 666 | } 667 | else { 668 | push @filters, $filter; 669 | } 670 | } 671 | return @filters, @append; 672 | } 673 | 674 | { 675 | %$reserved_section_names = map { 676 | ($_, 1); 677 | } keys(%Test::Base::Block::), qw( new DESTROY ); 678 | } 679 | 680 | __DATA__ 681 | 682 | =encoding utf8 683 | 684 | #line 1376 685 | --------------------------------------------------------------------------------