├── CHANGES ├── test ├── test.sh ├── 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 ├── README ├── lib │ └── Test │ │ ├── Nginx.pm │ │ └── Nginx │ │ ├── Util.pm │ │ ├── LWP.pm │ │ └── Socket.pm └── t │ ├── simple_get.t │ ├── simple_header.t │ └── simple_post.t ├── util ├── update-readme.sh └── wiki2pod.pl ├── ngx_http_oauth_module.h ├── config └── doc └── README.wiki /CHANGES: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /test/test.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | PATH=/home/yaoweibin/nginx/sbin:$PATH prove -r t 4 | -------------------------------------------------------------------------------- /util/update-readme.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | perl util/wiki2pod.pl doc/README.wiki > /tmp/a.pod && pod2text /tmp/a.pod > doc/README.txt 4 | cp doc/README.txt README 5 | -------------------------------------------------------------------------------- /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_oauth_module.h: -------------------------------------------------------------------------------- 1 | 2 | #ifndef _NGX_HTTP_OAUTH_MODULE_H_ 3 | #define _NGX_HTTP_OAUTH_MODULE_H_ 4 | 5 | #define SIGNATURE_HMAC_SHA1 0x01 6 | #define SIGNATURE_PLAINTEXT 0x02 7 | #define SIGNATURE_RSA_SHA1 0x04 8 | 9 | typedef struct { 10 | ngx_flag_t enable; 11 | ngx_str_t consumer_key; 12 | ngx_str_t consumer_secret; 13 | ngx_str_t realm; 14 | 15 | ngx_str_t request_token_uri; 16 | ngx_str_t call_back_uri; 17 | ngx_str_t request_auth_uri; 18 | ngx_str_t callback_confirmed; 19 | ngx_str_t access_token_uri; 20 | ngx_str_t authenticated_call_uri; 21 | 22 | ngx_uint_t signature_methods; 23 | ngx_uint_t version; 24 | 25 | ngx_uint_t token_index; 26 | ngx_uint_t token_secret_index; 27 | ngx_uint_t proxy_uri_index; 28 | 29 | ngx_uint_t body_length_index; 30 | ngx_uint_t verifier_index; 31 | ngx_uint_t session_handle_index; 32 | ngx_uint_t expries_in_index; 33 | } ngx_http_oauth_loc_conf_t; 34 | 35 | typedef struct { 36 | ngx_str_t token; 37 | ngx_str_t token_secret; 38 | } ngx_http_oauth_ctx_t; 39 | 40 | extern ngx_module_t ngx_http_oauth_module; 41 | 42 | #endif /* _NGX_HTTP_OAUTH_MODULE_H_ */ 43 | -------------------------------------------------------------------------------- /config: -------------------------------------------------------------------------------- 1 | ngx_feature="ngx_http_oauth_module" 2 | ngx_feature_name= 3 | ngx_feature_run=no 4 | ngx_feature_incs= 5 | ngx_feature_path="$ngx_addon_dir/modules $ngx_addon_dir" 6 | ngx_feature_deps="$ngx_addon_dir/ngx_http_oauth_module.h" 7 | ngx_oauth_src="$ngx_addon_dir/ngx_http_oauth_module.c" 8 | ngx_feature_libs="-loauth" 9 | ngx_feature_test="oauth_gen_nonce();" 10 | . auto/feature 11 | 12 | if [ $ngx_found = no ]; then 13 | # FreeBSD, OpenBSD 14 | ngx_feature="liboauth library in /usr/local/" 15 | ngx_feature_path="$ngx_feature_path /usr/local/include" 16 | if [ $NGX_RPATH = YES ]; then 17 | ngx_feature_libs="-R/usr/local/lib -L/usr/local/lib -loauth" 18 | else 19 | ngx_feature_libs="-L/usr/local/lib -loauth" 20 | fi 21 | . auto/feature 22 | fi 23 | 24 | if [ $ngx_found = yes ]; then 25 | CORE_INCS="$CORE_INCS $ngx_feature_path" 26 | ngx_addon_name=ngx_http_oauth_module 27 | HTTP_MODULES="$HTTP_MODULES ngx_http_oauth_module" 28 | NGX_ADDON_DEPS="$NGX_ADDON_DEPS $ngx_feature_deps" 29 | NGX_ADDON_SRCS="$NGX_ADDON_SRCS $ngx_oauth_src" 30 | CORE_INCS="$CORE_INCS $ngx_feature_path" 31 | CORE_LIBS="$CORE_LIBS $ngx_feature_libs" 32 | else 33 | cat << END 34 | $0: error: the ngx_http_oauth_module addon needs liboauth. 35 | END 36 | exit 1 37 | fi 38 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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/simple_get.t: -------------------------------------------------------------------------------- 1 | # 2 | #=============================================================================== 3 | # 4 | # DESCRIPTION: test 5 | # 6 | # FILES: --- 7 | # BUGS: --- 8 | # NOTES: --- 9 | # AUTHOR: Weibin Yao (http://yaoweibin.cn/), yaoweibin@gmail.com 10 | # COMPANY: 11 | # VERSION: 1.0 12 | # CREATED: 03/02/2010 03:18:28 PM 13 | # REVISION: --- 14 | #=============================================================================== 15 | 16 | 17 | # vi:filetype=perl 18 | 19 | use lib 'lib'; 20 | use Test::Nginx::LWP; 21 | 22 | plan tests => repeat_each() * 2 * blocks(); 23 | 24 | #no_diff; 25 | 26 | run_tests(); 27 | 28 | __DATA__ 29 | 30 | === TEST 1: the simple_get test 31 | --- config 32 | resolver 192.168.203.2; 33 | server { 34 | listen 1982; 35 | server_name localhost; 36 | 37 | oauth_consumer_key key; 38 | oauth_consumer_secret secret; 39 | oauth_realm "http://example.org"; 40 | oauth_variables $oauth_token $oauth_token_secret $proxy_uri; 41 | session_zone $user_id zone=test:10m; 42 | 43 | #two step oauth 44 | location /{ 45 | set $user_id yaoweibin; 46 | 47 | if ($user_id = "") { 48 | rewrite (.*) /session last; 49 | } 50 | 51 | rewrite (.*) /get_local_session last; 52 | 53 | return 404; 54 | } 55 | 56 | location /get_local_session { 57 | session_get zone=test $oauth_token $oauth_token_secret; 58 | 59 | if ($oauth_token = "") { 60 | rewrite (.*) /session last; 61 | } 62 | 63 | if ($oauth_token_secret = "") { 64 | rewrite (.*) /session last; 65 | } 66 | 67 | rewrite (.*) /oauth_proxy last; 68 | } 69 | 70 | location /oauth_proxy { 71 | if ($oauth_token = "") { 72 | return 403; 73 | } 74 | 75 | if ($oauth_token_secret = "") { 76 | return 403; 77 | } 78 | 79 | set $proxy_uri "http://term.ie/oauth/example/echo_api.php?method=foo&bar=baz"; 80 | proxy_pass $oauth_signed_authenticated_call_uri; 81 | } 82 | 83 | location /session { 84 | eval_override_content_type application/x-www-form-urlencoded; 85 | eval $oauth_token $oauth_token_secret { 86 | set $proxy_uri "http://term.ie/oauth/example/request_token.php"; 87 | proxy_pass $oauth_signed_request_token_uri; 88 | } 89 | 90 | eval $oauth_token $oauth_token_secret { 91 | set $proxy_uri "http://term.ie/oauth/example/access_token.php"; 92 | proxy_pass $oauth_signed_access_token_uri; 93 | } 94 | 95 | if ($oauth_token = "") { 96 | return 403; 97 | } 98 | 99 | if ($oauth_token_secret = "") { 100 | return 403; 101 | } 102 | 103 | session_store zone=test $oauth_token $oauth_token_secret expire=1d; 104 | 105 | add_header Location http://127.0.0.1:1982/; 106 | 107 | return 302; 108 | } 109 | } 110 | --- request 111 | GET / 112 | --- response_body_like: ^bar=baz&method=foo$ 113 | -------------------------------------------------------------------------------- /test/t/simple_header.t: -------------------------------------------------------------------------------- 1 | # 2 | #=============================================================================== 3 | # 4 | # DESCRIPTION: test 5 | # 6 | # FILES: --- 7 | # BUGS: --- 8 | # NOTES: --- 9 | # AUTHOR: Weibin Yao (http://yaoweibin.cn/), yaoweibin@gmail.com 10 | # COMPANY: 11 | # VERSION: 1.0 12 | # CREATED: 03/02/2010 03:18:28 PM 13 | # REVISION: --- 14 | #=============================================================================== 15 | 16 | 17 | # vi:filetype=perl 18 | 19 | use lib 'lib'; 20 | use Test::Nginx::LWP; 21 | 22 | plan tests => repeat_each() * 2 * blocks(); 23 | 24 | #no_diff; 25 | 26 | run_tests(); 27 | 28 | __DATA__ 29 | 30 | === TEST 1: the simple_get test 31 | --- config 32 | resolver 192.168.203.2; 33 | server { 34 | listen 1982; 35 | server_name localhost; 36 | 37 | oauth_consumer_key key; 38 | oauth_consumer_secret secret; 39 | oauth_realm "http://example.org"; 40 | oauth_variables $oauth_token $oauth_token_secret $proxy_uri; 41 | session_zone $user_id zone=test:10m; 42 | 43 | #two step oauth 44 | location /{ 45 | set $user_id yaoweibin; 46 | 47 | if ($user_id = "") { 48 | rewrite (.*) /session last; 49 | } 50 | 51 | rewrite (.*) /get_local_session last; 52 | 53 | return 404; 54 | } 55 | 56 | location /get_local_session { 57 | session_get zone=test $oauth_token $oauth_token_secret; 58 | 59 | if ($oauth_token = "") { 60 | rewrite (.*) /session last; 61 | } 62 | 63 | if ($oauth_token_secret = "") { 64 | rewrite (.*) /session last; 65 | } 66 | 67 | rewrite (.*) /oauth_proxy last; 68 | } 69 | 70 | location /oauth_proxy { 71 | if ($oauth_token = "") { 72 | return 403; 73 | } 74 | 75 | if ($oauth_token_secret = "") { 76 | return 403; 77 | } 78 | 79 | set $proxy_uri "http://term.ie/oauth/example/echo_api.php?method=foo&bar=baz"; 80 | proxy_set_header Authorization $oauth_signed_authenticated_call_header; 81 | proxy_pass $proxy_uri; 82 | } 83 | 84 | location /session { 85 | eval_override_content_type application/x-www-form-urlencoded; 86 | eval $oauth_token $oauth_token_secret { 87 | set $proxy_uri "http://term.ie/oauth/example/request_token.php"; 88 | proxy_set_header Authorization $oauth_signed_request_token_header; 89 | proxy_pass $proxy_uri; 90 | } 91 | 92 | eval $oauth_token $oauth_token_secret { 93 | set $proxy_uri "http://term.ie/oauth/example/access_token.php"; 94 | proxy_set_header Authorization $oauth_signed_access_token_header; 95 | proxy_pass $proxy_uri; 96 | } 97 | 98 | if ($oauth_token = "") { 99 | return 403; 100 | } 101 | 102 | if ($oauth_token_secret = "") { 103 | return 403; 104 | } 105 | 106 | session_store zone=test $oauth_token $oauth_token_secret expire=1d; 107 | 108 | add_header Location http://localhost:1982/; 109 | 110 | return 302; 111 | } 112 | } 113 | --- request 114 | GET / 115 | --- response_body_like: ^method=foo&bar=baz$ 116 | -------------------------------------------------------------------------------- /util/wiki2pod.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use bytes; 6 | 7 | my @nl_counts; 8 | my $last_nl_count_level; 9 | 10 | my @bl_counts; 11 | my $last_bl_count_level; 12 | 13 | sub fmt_pos ($) { 14 | (my $s = $_[0]) =~ s{\#(.*)}{/"$1"}; 15 | $s; 16 | } 17 | 18 | sub fmt_mark ($$) { 19 | my ($tag, $s) = @_; 20 | my $max_level = 0; 21 | while ($s =~ /([<>])\1*/g) { 22 | my $level = length $&; 23 | if ($level > $max_level) { 24 | $max_level = $level; 25 | } 26 | } 27 | 28 | my $times = $max_level + 1; 29 | if ($times > 1) { 30 | $s = " $s "; 31 | } 32 | return $tag . ('<' x $times) . $s . ('>' x $times); 33 | } 34 | 35 | print "=encoding utf-8\n\n"; 36 | 37 | while (<>) { 38 | if ($. == 1) { 39 | # strip the leading U+FEFF byte in MS-DOS text files 40 | my $first = ord(substr($_, 0, 1)); 41 | #printf STDERR "0x%x", $first; 42 | #my $second = ord(substr($_, 2, 1)); 43 | #printf STDERR "0x%x", $second; 44 | if ($first == 0xEF) { 45 | substr($_, 0, 1, ''); 46 | #warn "Hit!"; 47 | } 48 | } 49 | s{\[(http[^ \]]+) ([^\]]*)\]}{$2 (L<$1>)}gi; 50 | s{ \[\[ ( [^\]\|]+ ) \| ([^\]]*) \]\] }{"L<$2|" . fmt_pos($1) . ">"}gixe; 51 | s{(.*?)}{fmt_mark('C', $1)}gie; 52 | s{'''(.*?)'''}{fmt_mark('B', $1)}ge; 53 | s{''(.*?)''}{fmt_mark('I', $1)}ge; 54 | if (s{^\s*<[^>]+>\s*$}{}) { 55 | next; 56 | } 57 | 58 | if (/^\s*$/) { 59 | print "\n"; 60 | next; 61 | } 62 | 63 | =begin cmt 64 | 65 | if ($. == 1) { 66 | warn $_; 67 | for my $i (0..length($_) - 1) { 68 | my $chr = substr($_, $i, 1); 69 | warn "chr ord($i): ".ord($chr)." \"$chr\"\n"; 70 | } 71 | } 72 | 73 | =end cmt 74 | =cut 75 | 76 | if (/(=+) (.*) \1$/) { 77 | #warn "HERE! $_" if $. == 1; 78 | my ($level, $title) = (length $1, $2); 79 | collapse_lists(); 80 | 81 | print "\n=head$level $title\n\n"; 82 | } elsif (/^(\#+) (.*)/) { 83 | my ($level, $txt) = (length($1) - 1, $2); 84 | if (defined $last_nl_count_level && $level != $last_nl_count_level) { 85 | print "\n=back\n\n"; 86 | } 87 | $last_nl_count_level = $level; 88 | $nl_counts[$level] ||= 0; 89 | if ($nl_counts[$level] == 0) { 90 | print "\n=over\n\n"; 91 | } 92 | $nl_counts[$level]++; 93 | print "\n=item $nl_counts[$level].\n\n"; 94 | print "$txt\n"; 95 | } elsif (/^(\*+) (.*)/) { 96 | my ($level, $txt) = (length($1) - 1, $2); 97 | if (defined $last_bl_count_level && $level != $last_bl_count_level) { 98 | print "\n=back\n\n"; 99 | } 100 | $last_bl_count_level = $level; 101 | $bl_counts[$level] ||= 0; 102 | if ($bl_counts[$level] == 0) { 103 | print "\n=over\n\n"; 104 | } 105 | $bl_counts[$level]++; 106 | print "\n=item *\n\n"; 107 | print "$txt\n"; 108 | } else { 109 | collapse_lists(); 110 | print; 111 | } 112 | } 113 | 114 | collapse_lists(); 115 | 116 | sub collapse_lists { 117 | while (defined $last_nl_count_level && $last_nl_count_level >= 0) { 118 | print "\n=back\n\n"; 119 | $last_nl_count_level--; 120 | } 121 | undef $last_nl_count_level; 122 | undef @nl_counts; 123 | 124 | while (defined $last_bl_count_level && $last_bl_count_level >= 0) { 125 | print "\n=back\n\n"; 126 | $last_bl_count_level--; 127 | } 128 | undef $last_bl_count_level; 129 | undef @bl_counts; 130 | } 131 | 132 | -------------------------------------------------------------------------------- /test/t/simple_post.t: -------------------------------------------------------------------------------- 1 | # 2 | #=============================================================================== 3 | # 4 | # DESCRIPTION: test 5 | # 6 | # FILES: --- 7 | # BUGS: --- 8 | # NOTES: --- 9 | # AUTHOR: Weibin Yao (http://yaoweibin.cn/), yaoweibin@gmail.com 10 | # COMPANY: 11 | # VERSION: 1.0 12 | # CREATED: 03/02/2010 03:18:28 PM 13 | # REVISION: --- 14 | #=============================================================================== 15 | 16 | 17 | # vi:filetype=perl 18 | 19 | use lib 'lib'; 20 | use Test::Nginx::LWP; 21 | 22 | plan tests => repeat_each() * 2 * blocks(); 23 | 24 | #no_diff; 25 | 26 | run_tests(); 27 | 28 | __DATA__ 29 | 30 | === TEST 1: the simple_get test 31 | --- config 32 | resolver 192.168.203.2; 33 | server { 34 | listen 1982; 35 | server_name localhost; 36 | 37 | oauth_consumer_key key; 38 | oauth_consumer_secret secret; 39 | oauth_realm "http://example.org"; 40 | oauth_variables $oauth_token $oauth_token_secret $proxy_uri; 41 | session_zone $user_id zone=test:10m; 42 | 43 | #two step oauth 44 | location /{ 45 | set $user_id yaoweibin; 46 | 47 | if ($user_id = "") { 48 | rewrite (.*) /session last; 49 | } 50 | 51 | rewrite (.*) /get_local_session last; 52 | 53 | return 404; 54 | } 55 | 56 | location /get_local_session { 57 | session_get zone=test $oauth_token $oauth_token_secret; 58 | 59 | if ($oauth_token = "") { 60 | rewrite (.*) /session last; 61 | } 62 | 63 | if ($oauth_token_secret = "") { 64 | rewrite (.*) /session last; 65 | } 66 | 67 | rewrite (.*) /oauth_proxy last; 68 | } 69 | 70 | location /oauth_proxy { 71 | if ($oauth_token = "") { 72 | return 403; 73 | } 74 | 75 | if ($oauth_token_secret = "") { 76 | return 403; 77 | } 78 | 79 | set $proxy_uri "http://term.ie/oauth/example/echo_api.php?method=foo&bar=baz"; 80 | 81 | proxy_set_body $oauth_signed_authenticated_call_postargs; 82 | proxy_method POST; 83 | proxy_set_header Content-Type application/x-www-form-urlencoded; 84 | 85 | proxy_pass http://term.ie/oauth/example/echo_api.php; 86 | } 87 | 88 | location /session { 89 | eval_override_content_type application/x-www-form-urlencoded; 90 | eval $oauth_token $oauth_token_secret { 91 | proxy_method POST; 92 | set $proxy_uri "http://term.ie/oauth/example/request_token.php"; 93 | proxy_set_body $oauth_signed_request_token_postargs; 94 | proxy_set_header Content-Type application/x-www-form-urlencoded; 95 | 96 | proxy_pass "http://term.ie/oauth/example/request_token.php"; 97 | } 98 | 99 | eval $oauth_token $oauth_token_secret { 100 | proxy_method POST; 101 | set $proxy_uri "http://term.ie/oauth/example/access_token.php"; 102 | proxy_set_body $oauth_signed_access_token_postargs; 103 | proxy_set_header Content-Type application/x-www-form-urlencoded; 104 | 105 | proxy_pass "http://term.ie/oauth/example/access_token.php"; 106 | } 107 | 108 | if ($oauth_token = "") { 109 | return 403; 110 | } 111 | 112 | if ($oauth_token_secret = "") { 113 | return 403; 114 | } 115 | 116 | session_store zone=test $oauth_token $oauth_token_secret expire=1d; 117 | 118 | add_header Location http://localhost:1982/; 119 | 120 | return 302; 121 | } 122 | } 123 | --- request 124 | GET / 125 | --- response_body_like: ^bar=baz&method=foo$ 126 | -------------------------------------------------------------------------------- /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 | 17 | our $NoNginxManager = 0; 18 | our $Profiling = 0; 19 | 20 | our $RepeatEach = 1; 21 | our $MAX_PROCESSES = 10; 22 | 23 | our $ForkManager; 24 | 25 | if ($Profiling) { 26 | eval "use Parallel::ForkManager"; 27 | if ($@) { 28 | die "Failed to load Parallel::ForkManager: $@\n"; 29 | } 30 | $ForkManager = new Parallel::ForkManager($MAX_PROCESSES); 31 | } 32 | 33 | our $Workers = 2; 34 | our $WorkerConnections = 1024; 35 | our $LogLevel = 'debug'; 36 | our $MasterProcessEnabled = 'off'; 37 | our $DaemonEnabled = 'on'; 38 | our $ServerPort = 1982; 39 | our $ServerPortForClient = 1982; 40 | #our $ServerPortForClient = 1984; 41 | 42 | 43 | sub repeat_each (@) { 44 | if (@_) { 45 | $RepeatEach = shift; 46 | } else { 47 | return $RepeatEach; 48 | } 49 | } 50 | 51 | sub worker_connections (@) { 52 | if (@_) { 53 | $WorkerConnections = shift; 54 | } else { 55 | return $WorkerConnections; 56 | } 57 | } 58 | 59 | sub workers (@) { 60 | if (@_) { 61 | #warn "setting workers to $_[0]"; 62 | $Workers = shift; 63 | } else { 64 | return $Workers; 65 | } 66 | } 67 | 68 | sub log_level (@) { 69 | if (@_) { 70 | $LogLevel = shift; 71 | } else { 72 | return $LogLevel; 73 | } 74 | } 75 | 76 | sub master_on () { 77 | $MasterProcessEnabled = 'on'; 78 | } 79 | 80 | sub master_process_enabled (@) { 81 | if (@_) { 82 | $MasterProcessEnabled = shift() ? 'on' : 'off'; 83 | } else { 84 | return $MasterProcessEnabled; 85 | } 86 | } 87 | 88 | our @EXPORT_OK = qw( 89 | setup_server_root 90 | write_config_file 91 | get_canon_version 92 | get_nginx_version 93 | trim 94 | show_all_chars 95 | parse_headers 96 | run_tests 97 | $ServerPortForClient 98 | $ServerPort 99 | $NginxVersion 100 | $PidFile 101 | $ServRoot 102 | $ConfFile 103 | $RunTestHelper 104 | $NoNginxManager 105 | $RepeatEach 106 | worker_connections 107 | workers 108 | master_on 109 | config_preamble 110 | repeat_each 111 | master_process_enabled 112 | log_level 113 | ); 114 | 115 | 116 | if ($Profiling) { 117 | $DaemonEnabled = 'off'; 118 | $MasterProcessEnabled = 'off'; 119 | } 120 | 121 | our $ConfigPreamble = ''; 122 | 123 | sub config_preamble ($) { 124 | $ConfigPreamble = shift; 125 | } 126 | 127 | our $RunTestHelper; 128 | 129 | our $NginxVersion; 130 | our $NginxRawVersion; 131 | our $TODO; 132 | 133 | #our ($PrevRequest, $PrevConfig); 134 | 135 | our $ServRoot = File::Spec->catfile(cwd(), 't/servroot'); 136 | our $LogDir = File::Spec->catfile($ServRoot, 'logs'); 137 | our $ErrLogFile = File::Spec->catfile($LogDir, 'error.log'); 138 | our $AccLogFile = File::Spec->catfile($LogDir, 'access.log'); 139 | our $HtmlDir = File::Spec->catfile($ServRoot, 'html'); 140 | our $ConfDir = File::Spec->catfile($ServRoot, 'conf'); 141 | our $ConfFile = File::Spec->catfile($ConfDir, 'nginx.conf'); 142 | our $PidFile = File::Spec->catfile($LogDir, 'nginx.pid'); 143 | 144 | sub run_tests () { 145 | $NginxVersion = get_nginx_version(); 146 | 147 | if (defined $NginxVersion) { 148 | #warn "[INFO] Using nginx version $NginxVersion ($NginxRawVersion)\n"; 149 | } 150 | 151 | for my $block (shuffle Test::Base::blocks()) { 152 | #for (1..3) { 153 | run_test($block); 154 | #} 155 | } 156 | 157 | if ($Profiling) { 158 | $ForkManager->wait_all_children; 159 | } 160 | } 161 | 162 | sub setup_server_root () { 163 | if (-d $ServRoot) { 164 | #sleep 0.5; 165 | #die ".pid file $PidFile exists.\n"; 166 | system("rm -rf t/servroot > /dev/null") == 0 or 167 | die "Can't remove t/servroot"; 168 | #sleep 0.5; 169 | } 170 | mkdir $ServRoot or 171 | die "Failed to do mkdir $ServRoot\n"; 172 | mkdir $LogDir or 173 | die "Failed to do mkdir $LogDir\n"; 174 | mkdir $HtmlDir or 175 | die "Failed to do mkdir $HtmlDir\n"; 176 | 177 | my $index_file = "$HtmlDir/index.html"; 178 | 179 | open my $out, ">$index_file" or 180 | die "Can't open $index_file for writing: $!\n"; 181 | 182 | print $out 'It works!It works!'; 183 | 184 | close $out; 185 | 186 | mkdir $ConfDir or 187 | die "Failed to do mkdir $ConfDir\n"; 188 | } 189 | 190 | sub write_config_file ($$) { 191 | my ($config, $http_config) = @_; 192 | 193 | if (!defined $config) { 194 | $config = ''; 195 | } 196 | 197 | if (!defined $http_config) { 198 | $http_config = ''; 199 | } 200 | 201 | open my $out, ">$ConfFile" or 202 | die "Can't open $ConfFile for writing: $!\n"; 203 | print $out <<_EOC_; 204 | worker_processes $Workers; 205 | daemon $DaemonEnabled; 206 | master_process $MasterProcessEnabled; 207 | error_log $ErrLogFile $LogLevel; 208 | pid $PidFile; 209 | 210 | http { 211 | # Begin test case config... 212 | $config 213 | # End test case config. 214 | } 215 | 216 | events { 217 | worker_connections $WorkerConnections; 218 | } 219 | 220 | _EOC_ 221 | close $out; 222 | } 223 | 224 | sub get_canon_version (@) { 225 | sprintf "%d.%03d%03d", $_[0], $_[1], $_[2]; 226 | } 227 | 228 | sub get_nginx_version () { 229 | my $out = `nginx -V 2>&1`; 230 | if (!defined $out || $? != 0) { 231 | warn "Failed to get the version of the Nginx in PATH.\n"; 232 | } 233 | if ($out =~ m{nginx/(\d+)\.(\d+)\.(\d+)}s) { 234 | $NginxRawVersion = "$1.$2.$3"; 235 | return get_canon_version($1, $2, $3); 236 | } 237 | warn "Failed to parse the output of \"nginx -V\": $out\n"; 238 | return undef; 239 | } 240 | 241 | sub get_pid_from_pidfile ($) { 242 | my ($name) = @_; 243 | open my $in, $PidFile or 244 | Test::More::BAIL_OUT("$name - Failed to open the pid file $PidFile for reading: $!"); 245 | my $pid = do { local $/; <$in> }; 246 | #warn "Pid: $pid\n"; 247 | close $in; 248 | $pid; 249 | } 250 | 251 | sub trim ($) { 252 | (my $s = shift) =~ s/^\s+|\s+$//g; 253 | $s =~ s/\n/ /gs; 254 | $s =~ s/\s{2,}/ /gs; 255 | $s; 256 | } 257 | 258 | sub show_all_chars ($) { 259 | my $s = shift; 260 | $s =~ s/\n/\\n/gs; 261 | $s =~ s/\r/\\r/gs; 262 | $s =~ s/\t/\\t/gs; 263 | $s; 264 | } 265 | 266 | sub parse_headers ($) { 267 | my $s = shift; 268 | my %headers; 269 | open my $in, '<', \$s; 270 | while (<$in>) { 271 | s/^\s+|\s+$//g; 272 | my ($key, $val) = split /\s*:\s*/, $_, 2; 273 | $headers{$key} = $val; 274 | } 275 | close $in; 276 | return \%headers; 277 | } 278 | 279 | sub run_test ($) { 280 | my $block = shift; 281 | my $name = $block->name; 282 | 283 | my $config = $block->config; 284 | if (!defined $config) { 285 | Test::More::BAIL_OUT("$name - No '--- config' section specified"); 286 | #$config = $PrevConfig; 287 | die; 288 | } 289 | 290 | my $skip_nginx = $block->skip_nginx; 291 | my ($tests_to_skip, $should_skip, $skip_reason); 292 | if (defined $skip_nginx) { 293 | if ($skip_nginx =~ m{ 294 | ^ \s* (\d+) \s* : \s* 295 | ([<>]=?) \s* (\d+)\.(\d+)\.(\d+) 296 | (?: \s* : \s* (.*) )? 297 | \s*$}x) { 298 | $tests_to_skip = $1; 299 | my ($op, $ver1, $ver2, $ver3) = ($2, $3, $4, $5); 300 | $skip_reason = $6; 301 | #warn "$ver1 $ver2 $ver3"; 302 | my $ver = get_canon_version($ver1, $ver2, $ver3); 303 | if ((!defined $NginxVersion and $op =~ /^todo_nginx; 319 | my ($should_todo, $todo_reason); 320 | if (defined $todo_nginx) { 321 | if ($todo_nginx =~ m{ 322 | ^ \s* 323 | ([<>]=?) \s* (\d+)\.(\d+)\.(\d+) 324 | (?: \s* : \s* (.*) )? 325 | \s*$}x) { 326 | my ($op, $ver1, $ver2, $ver3) = ($1, $2, $3, $4); 327 | $todo_reason = $5; 328 | my $ver = get_canon_version($ver1, $ver2, $ver3); 329 | if ((!defined $NginxVersion and $op =~ /^ /dev/null") == 0) { 355 | #warn "found running nginx..."; 356 | write_config_file($config, $block->http_config); 357 | if (kill(SIGQUIT, $pid) == 0) { # send quit signal 358 | #warn("$name - Failed to send quit signal to the nginx process with PID $pid"); 359 | } 360 | sleep 0.02; 361 | if (system("ps $pid > /dev/null") == 0) { 362 | #warn "killing with force...\n"; 363 | kill(SIGKILL, $pid); 364 | sleep 0.02; 365 | } 366 | undef $nginx_is_running; 367 | } else { 368 | unlink $PidFile or 369 | die "Failed to remove pid file $PidFile\n"; 370 | undef $nginx_is_running; 371 | } 372 | } else { 373 | undef $nginx_is_running; 374 | } 375 | 376 | start_nginx: 377 | 378 | unless ($nginx_is_running) { 379 | #system("killall -9 nginx"); 380 | 381 | #warn "*** Restarting the nginx server...\n"; 382 | setup_server_root(); 383 | write_config_file($config, $block->http_config); 384 | if ( ! Module::Install::Can->can_run('nginx') ) { 385 | Test::More::BAIL_OUT("$name - Cannot find the nginx executable in the PATH environment"); 386 | die; 387 | } 388 | #if (system("nginx -p $ServRoot -c $ConfFile -t") != 0) { 389 | #Test::More::BAIL_OUT("$name - Invalid config file"); 390 | #} 391 | #my $cmd = "nginx -p $ServRoot -c $ConfFile > /dev/null"; 392 | my $cmd; 393 | if ($NginxVersion >= 0.007053) { 394 | $cmd = "nginx -p $ServRoot/ -c $ConfFile > /dev/null"; 395 | } else { 396 | $cmd = "nginx -c $ConfFile > /dev/null"; 397 | } 398 | 399 | if ($Profiling) { 400 | my $pid = $ForkManager->start; 401 | if (!$pid) { 402 | # child process 403 | if (system($cmd) != 0) { 404 | Test::More::BAIL_OUT("$name - Cannot start nginx using command \"$cmd\"."); 405 | } 406 | 407 | $ForkManager->finish; # terminate the child process 408 | } 409 | } else { 410 | if (system($cmd) != 0) { 411 | Test::More::BAIL_OUT("$name - Cannot start nginx using command \"$cmd\"."); 412 | } 413 | } 414 | 415 | sleep 6; 416 | } 417 | } 418 | 419 | my $i = 0; 420 | while ($i++ < $RepeatEach) { 421 | if ($should_skip) { 422 | SKIP: { 423 | Test::More::skip("$name - $skip_reason", $tests_to_skip); 424 | 425 | $RunTestHelper->($block); 426 | } 427 | } elsif ($should_todo) { 428 | TODO: { 429 | local $TODO = "$name - $todo_reason"; 430 | 431 | $RunTestHelper->($block); 432 | } 433 | } else { 434 | $RunTestHelper->($block); 435 | } 436 | } 437 | 438 | if (defined $block->quit && $Profiling) { 439 | warn "Found quit..."; 440 | if (-f $PidFile) { 441 | my $pid = get_pid_from_pidfile($name); 442 | if (system("ps $pid > /dev/null") == 0) { 443 | write_config_file($config, $block->http_config); 444 | if (kill(SIGQUIT, $pid) == 0) { # send quit signal 445 | #warn("$name - Failed to send quit signal to the nginx process with PID $pid"); 446 | } 447 | sleep 0.02; 448 | if (system("ps $pid > /dev/null") == 0) { 449 | #warn "killing with force...\n"; 450 | kill(SIGKILL, $pid); 451 | sleep 0.02; 452 | } 453 | } else { 454 | unlink $PidFile or 455 | die "Failed to remove pid file $PidFile\n"; 456 | } 457 | } 458 | } 459 | } 460 | 461 | 1; 462 | -------------------------------------------------------------------------------- /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 | ); 36 | 37 | our $UserAgent = LWP::UserAgent->new; 38 | $UserAgent->agent(__PACKAGE__); 39 | #$UserAgent->default_headers(HTTP::Headers->new); 40 | 41 | #use Smart::Comments::JSON '##'; 42 | 43 | our @EXPORT = qw( plan run_tests run_test 44 | repeat_each config_preamble worker_connections 45 | master_process_enabled 46 | no_long_string); 47 | 48 | sub no_long_string () { 49 | $NoLongString = 1; 50 | } 51 | 52 | sub run_test_helper ($); 53 | 54 | $RunTestHelper = \&run_test_helper; 55 | 56 | sub parse_request ($$) { 57 | my ($name, $rrequest) = @_; 58 | open my $in, '<', $rrequest; 59 | my $first = <$in>; 60 | if (!$first) { 61 | Test::More::BAIL_OUT("$name - Request line should be non-empty"); 62 | die; 63 | } 64 | $first =~ s/^\s+|\s+$//g; 65 | my ($meth, $rel_url) = split /\s+/, $first, 2; 66 | my $url = "http://localhost:$ServerPortForClient" . $rel_url; 67 | 68 | my $content = do { local $/; <$in> }; 69 | if ($content) { 70 | $content =~ s/^\s+|\s+$//s; 71 | } 72 | 73 | close $in; 74 | 75 | return { 76 | method => $meth, 77 | url => $url, 78 | content => $content, 79 | }; 80 | } 81 | 82 | sub chunk_it ($$$) { 83 | my ($chunks, $start_delay, $middle_delay) = @_; 84 | my $i = 0; 85 | return sub { 86 | if ($i == 0) { 87 | if ($start_delay) { 88 | sleep($start_delay); 89 | } 90 | } elsif ($middle_delay) { 91 | sleep($middle_delay); 92 | } 93 | return $chunks->[$i++]; 94 | } 95 | } 96 | 97 | sub run_test_helper ($) { 98 | my ($block) = @_; 99 | 100 | my $request = $block->request; 101 | 102 | my $name = $block->name; 103 | #if (defined $TODO) { 104 | #$name .= "# $TODO"; 105 | #} 106 | 107 | my $req_spec = parse_request($name, \$request); 108 | ## $req_spec 109 | my $method = $req_spec->{method}; 110 | my $req = HTTP::Request->new($method); 111 | my $content = $req_spec->{content}; 112 | 113 | if (defined ($block->request_headers)) { 114 | my $headers = parse_headers($block->request_headers); 115 | while (my ($key, $val) = each %$headers) { 116 | $req->header($key => $val); 117 | } 118 | } 119 | 120 | #$req->header('Accept', '*/*'); 121 | $req->url($req_spec->{url}); 122 | if ($content) { 123 | if ($method eq 'GET' or $method eq 'HEAD') { 124 | croak "HTTP 1.0/1.1 $method request should not have content: $content"; 125 | } 126 | $req->content($content); 127 | } elsif ($method eq 'POST' or $method eq 'PUT') { 128 | my $chunks = $block->chunked_body; 129 | if (defined $chunks) { 130 | if (!ref $chunks or ref $chunks ne 'ARRAY') { 131 | 132 | Test::More::BAIL_OUT("$name - --- chunked_body should takes a Perl array ref as its value"); 133 | } 134 | 135 | my $start_delay = $block->start_chunk_delay || 0; 136 | my $middle_delay = $block->middle_chunk_delay || 0; 137 | $req->content(chunk_it($chunks, $start_delay, $middle_delay)); 138 | if (!defined $req->header('Content-Type')) { 139 | $req->header('Content-Type' => 'text/plain'); 140 | } 141 | } else { 142 | if (!defined $req->header('Content-Type')) { 143 | $req->header('Content-Type' => 'text/plain'); 144 | } 145 | 146 | $req->header('Content-Length' => 0); 147 | } 148 | } 149 | 150 | if ($block->more_headers) { 151 | my @headers = split /\n+/, $block->more_headers; 152 | for my $header (@headers) { 153 | next if $header =~ /^\s*\#/; 154 | my ($key, $val) = split /:\s*/, $header, 2; 155 | #warn "[$key, $val]\n"; 156 | $req->header($key => $val); 157 | } 158 | } 159 | 160 | #warn "req: ", $req->as_string, "\n"; 161 | #warn "DONE!!!!!!!!!!!!!!!!!!!!"; 162 | 163 | my $res = $UserAgent->request($req); 164 | 165 | #warn "res returned!!!"; 166 | 167 | if (defined $block->error_code) { 168 | is($res->code, $block->error_code, "$name - status code ok"); 169 | } else { 170 | is($res->code, 200, "$name - status code ok"); 171 | } 172 | 173 | if (defined $block->response_headers) { 174 | my $headers = parse_headers($block->response_headers); 175 | while (my ($key, $val) = each %$headers) { 176 | my $expected_val = $res->header($key); 177 | if (!defined $expected_val) { 178 | $expected_val = ''; 179 | } 180 | is $expected_val, $val, 181 | "$name - header $key ok"; 182 | } 183 | } elsif (defined $block->response_headers_like) { 184 | my $headers = parse_headers($block->response_headers_like); 185 | while (my ($key, $val) = each %$headers) { 186 | my $expected_val = $res->header($key); 187 | if (!defined $expected_val) { 188 | $expected_val = ''; 189 | } 190 | like $expected_val, qr/^$val$/, 191 | "$name - header $key like ok"; 192 | } 193 | } 194 | 195 | if (defined $block->response_body) { 196 | my $content = $res->content; 197 | if (defined $content) { 198 | $content =~ s/^TE: deflate,gzip;q=0\.3\r\n//gms; 199 | } 200 | 201 | $content =~ s/^Connection: TE, close\r\n//gms; 202 | my $expected = $block->response_body; 203 | $expected =~ s/\$ServerPort\b/$ServerPort/g; 204 | $expected =~ s/\$ServerPortForClient\b/$ServerPortForClient/g; 205 | #warn show_all_chars($content); 206 | 207 | if ($NoLongString) { 208 | is($content, $expected, "$name - response_body - response is expected"); 209 | } else { 210 | is_string($content, $expected, "$name - response_body - response is expected"); 211 | } 212 | #is($content, $expected, "$name - response_body - response is expected"); 213 | 214 | } elsif (defined $block->response_body_like) { 215 | my $content = $res->content; 216 | if (defined $content) { 217 | $content =~ s/^TE: deflate,gzip;q=0\.3\r\n//gms; 218 | } 219 | $content =~ s/^Connection: TE, close\r\n//gms; 220 | my $expected_pat = $block->response_body_like; 221 | $expected_pat =~ s/\$ServerPort\b/$ServerPort/g; 222 | $expected_pat =~ s/\$ServerPortForClient\b/$ServerPortForClient/g; 223 | my $summary = trim($content); 224 | like($content, qr/$expected_pat/s, "$name - response_body_like - response is expected ($summary)"); 225 | } 226 | } 227 | 228 | 1; 229 | __END__ 230 | 231 | =encoding utf-8 232 | 233 | =head1 NAME 234 | 235 | Test::Nginx::LWP - LWP-backed test scaffold for the Nginx C modules 236 | 237 | =head1 SYNOPSIS 238 | 239 | use Test::Nginx::LWP; 240 | 241 | plan tests => $Test::Nginx::LWP::RepeatEach * 2 * blocks(); 242 | 243 | run_tests(); 244 | 245 | __DATA__ 246 | 247 | === TEST 1: sanity 248 | --- config 249 | location /echo { 250 | echo_before_body hello; 251 | echo world; 252 | } 253 | --- request 254 | GET /echo 255 | --- response_body 256 | hello 257 | world 258 | --- error_code: 200 259 | 260 | 261 | === TEST 2: set Server 262 | --- config 263 | location /foo { 264 | echo hi; 265 | more_set_headers 'Server: Foo'; 266 | } 267 | --- request 268 | GET /foo 269 | --- response_headers 270 | Server: Foo 271 | --- response_body 272 | hi 273 | 274 | 275 | === TEST 3: clear Server 276 | --- config 277 | location /foo { 278 | echo hi; 279 | more_clear_headers 'Server: '; 280 | } 281 | --- request 282 | GET /foo 283 | --- response_headers_like 284 | Server: nginx.* 285 | --- response_body 286 | hi 287 | 288 | 289 | === TEST 4: set request header at client side and rewrite it 290 | --- config 291 | location /foo { 292 | more_set_input_headers 'X-Foo: howdy'; 293 | echo $http_x_foo; 294 | } 295 | --- request 296 | GET /foo 297 | --- request_headers 298 | X-Foo: blah 299 | --- response_headers 300 | X-Foo: 301 | --- response_body 302 | howdy 303 | 304 | 305 | === TEST 3: rewrite content length 306 | --- config 307 | location /bar { 308 | more_set_input_headers 'Content-Length: 2048'; 309 | echo_read_request_body; 310 | echo_request_body; 311 | } 312 | --- request eval 313 | "POST /bar\n" . 314 | "a" x 4096 315 | --- response_body eval 316 | "a" x 2048 317 | 318 | 319 | === TEST 4: timer without explicit reset 320 | --- config 321 | location /timer { 322 | echo_sleep 0.03; 323 | echo "elapsed $echo_timer_elapsed sec."; 324 | } 325 | --- request 326 | GET /timer 327 | --- response_body_like 328 | ^elapsed 0\.0(2[6-9]|3[0-6]) sec\.$ 329 | 330 | 331 | === TEST 5: small buf (using 2-byte buf) 332 | --- config 333 | chunkin on; 334 | location /main { 335 | client_body_buffer_size 2; 336 | echo "body:"; 337 | echo $echo_request_body; 338 | echo_request_body; 339 | } 340 | --- request 341 | POST /main 342 | --- start_chunk_delay: 0.01 343 | --- middle_chunk_delay: 0.01 344 | --- chunked_body eval 345 | ["hello", "world"] 346 | --- error_code: 200 347 | --- response_body eval 348 | "body: 349 | 350 | helloworld" 351 | 352 | =head1 DESCRIPTION 353 | 354 | This module provides a test scaffold based on L for automated testing in Nginx C module development. 355 | 356 | This class inherits from L, thus bringing all its 357 | declarative power to the Nginx C module testing practices. 358 | 359 | 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 360 | 361 | killall nginx 362 | PATH=/path/to/your/nginx-with-memc-module:$PATH prove -r t 363 | 364 | 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. 365 | 366 | You will often want to look into F 367 | when things go wrong ;) 368 | 369 | =head1 Sections supported 370 | 371 | The following sections are supported: 372 | 373 | =over 374 | 375 | =item config 376 | 377 | =item http_config 378 | 379 | =item request 380 | 381 | =item request_headers 382 | 383 | =item more_headers 384 | 385 | =item response_body 386 | 387 | =item response_body_like 388 | 389 | =item response_headers 390 | 391 | =item response_headers_like 392 | 393 | =item error_code 394 | 395 | =item chunked_body 396 | 397 | =item middle_chunk_delay 398 | 399 | =item start_chunk_delay 400 | 401 | =back 402 | 403 | =head1 Samples 404 | 405 | You'll find live samples in the following Nginx 3rd-party modules: 406 | 407 | =over 408 | 409 | =item ngx_echo 410 | 411 | L 412 | 413 | =item ngx_headers_more 414 | 415 | L 416 | 417 | =item ngx_chunkin 418 | 419 | L 420 | 421 | =item ngx_memc 422 | 423 | L 424 | 425 | =back 426 | 427 | =head1 SOURCE REPOSITORY 428 | 429 | This module has a Git repository on Github, which has access for all. 430 | 431 | http://github.com/agentzh/test-nginx 432 | 433 | If you want a commit bit, feel free to drop me a line. 434 | 435 | =head1 AUTHOR 436 | 437 | agentzh (章亦春) C<< >> 438 | 439 | =head1 COPYRIGHT & LICENSE 440 | 441 | Copyright (c) 2009, Taobao Inc., Alibaba Group (L). 442 | 443 | Copyright (c) 2009, agentzh C<< >>. 444 | 445 | This module is licensed under the terms of the BSD license. 446 | 447 | Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 448 | 449 | =over 450 | 451 | =item * 452 | 453 | Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 454 | 455 | =item * 456 | 457 | 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. 458 | 459 | =item * 460 | 461 | 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. 462 | 463 | =back 464 | 465 | 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. 466 | 467 | =head1 SEE ALSO 468 | 469 | L, L. 470 | 471 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /test/lib/Test/Nginx/Socket.pm: -------------------------------------------------------------------------------- 1 | package Test::Nginx::Socket; 2 | 3 | use lib 'lib'; 4 | use lib 'inc'; 5 | 6 | use Test::Base -Base; 7 | 8 | our $VERSION = '0.08'; 9 | 10 | use Data::Dumper; 11 | use Time::HiRes qw(sleep time); 12 | use Test::LongString; 13 | use List::MoreUtils qw( any ); 14 | use IO::Select (); 15 | 16 | our $Timeout = 2; 17 | 18 | use Test::Nginx::Util qw( 19 | setup_server_root 20 | write_config_file 21 | get_canon_version 22 | get_nginx_version 23 | trim 24 | show_all_chars 25 | parse_headers 26 | run_tests 27 | $ServerPortForClient 28 | $ServerPort 29 | $PidFile 30 | $ServRoot 31 | $ConfFile 32 | $RunTestHelper 33 | $RepeatEach 34 | worker_connections 35 | master_process_enabled 36 | config_preamble 37 | repeat_each 38 | workers 39 | master_on 40 | log_level 41 | ); 42 | 43 | #use Smart::Comments::JSON '###'; 44 | use Fcntl qw(F_GETFL F_SETFL O_NONBLOCK); 45 | use POSIX qw(EAGAIN); 46 | use IO::Socket; 47 | 48 | #our ($PrevRequest, $PrevConfig); 49 | 50 | our $NoLongString = undef; 51 | 52 | our @EXPORT = qw( plan run_tests run_test 53 | repeat_each config_preamble worker_connections 54 | master_process_enabled 55 | no_long_string workers master_on 56 | log_level); 57 | 58 | sub send_request ($$$); 59 | 60 | sub run_test_helper ($); 61 | 62 | sub error_event_handler ($); 63 | sub read_event_handler ($); 64 | sub write_event_handler ($); 65 | 66 | sub no_long_string () { 67 | $NoLongString = 1; 68 | } 69 | 70 | $RunTestHelper = \&run_test_helper; 71 | 72 | sub parse_request ($$) { 73 | my ($name, $rrequest) = @_; 74 | open my $in, '<', $rrequest; 75 | my $first = <$in>; 76 | if (!$first) { 77 | Test::More::BAIL_OUT("$name - Request line should be non-empty"); 78 | die; 79 | } 80 | $first =~ s/^\s+|\s+$//gs; 81 | my ($meth, $rel_url) = split /\s+/, $first, 2; 82 | if (!defined $rel_url) { 83 | $rel_url = "/"; 84 | } 85 | #my $url = "http://localhost:$ServerPortForClient" . $rel_url; 86 | 87 | my $content = do { local $/; <$in> }; 88 | if (!defined $content) { 89 | $content = ""; 90 | } 91 | #warn Dumper($content); 92 | 93 | close $in; 94 | 95 | return { 96 | method => $meth, 97 | url => $rel_url, 98 | content => $content, 99 | }; 100 | } 101 | 102 | sub run_test_helper ($) { 103 | my $block = shift; 104 | 105 | my $name = $block->name; 106 | 107 | my $req; 108 | 109 | if (defined $block->raw_request) { 110 | $req = $block->raw_request; 111 | } else { 112 | my $request; 113 | if (defined $block->request_eval) { 114 | $request = eval $block->request_eval; 115 | if ($@) { 116 | warn $@; 117 | } 118 | } else { 119 | $request = $block->request; 120 | } 121 | 122 | my $is_chunked = 0; 123 | my $more_headers = ''; 124 | if ($block->more_headers) { 125 | my @headers = split /\n+/, $block->more_headers; 126 | for my $header (@headers) { 127 | next if $header =~ /^\s*\#/; 128 | my ($key, $val) = split /:\s*/, $header, 2; 129 | if (lc($key) eq 'transfer-encoding' and $val eq 'chunked') { 130 | $is_chunked = 1; 131 | } 132 | #warn "[$key, $val]\n"; 133 | $more_headers .= "$key: $val\r\n"; 134 | } 135 | } 136 | 137 | if ($block->pipelined_requests) { 138 | my $reqs = $block->pipelined_requests; 139 | if (!ref $reqs || ref $reqs ne 'ARRAY') { 140 | Test::More::BAIL_OUT("$name - invalid entries in --- pipelined_requests"); 141 | } 142 | my $i = 0; 143 | for my $request (@$reqs) { 144 | my $conn_type; 145 | if ($i++ == @$reqs - 1) { 146 | $conn_type = 'close'; 147 | } else { 148 | $conn_type = 'keep-alive'; 149 | } 150 | my $parsed_req = parse_request($name, \$request); 151 | 152 | my $len_header = ''; 153 | if (!$is_chunked && defined $parsed_req->{content} 154 | && $parsed_req->{content} ne '' 155 | && $more_headers !~ /\bContent-Length:/) 156 | { 157 | $parsed_req->{content} =~ s/^\s+|\s+$//gs; 158 | 159 | $len_header .= "Content-Length: " . length($parsed_req->{content}) . "\r\n"; 160 | } 161 | 162 | $req .= "$parsed_req->{method} $parsed_req->{url} HTTP/1.1\r 163 | Host: localhost\r 164 | Connection: $conn_type\r 165 | $more_headers$len_header\r 166 | $parsed_req->{content}"; 167 | } 168 | } else { 169 | my $parsed_req = parse_request($name, \$request); 170 | ### $parsed_req 171 | 172 | my $len_header = ''; 173 | if (!$is_chunked && defined $parsed_req->{content} 174 | && $parsed_req->{content} ne '' 175 | && $more_headers !~ /\bContent-Length:/) 176 | { 177 | $parsed_req->{content} =~ s/^\s+|\s+$//gs; 178 | $len_header .= "Content-Length: " . length($parsed_req->{content}) . "\r\n"; 179 | } 180 | 181 | $req = "$parsed_req->{method} $parsed_req->{url} HTTP/1.1\r 182 | Host: localhost\r 183 | Connection: Close\r 184 | $more_headers$len_header\r 185 | $parsed_req->{content}"; 186 | } 187 | 188 | } 189 | 190 | if (!$req) { 191 | Test::More::BAIL_OUT("$name - request empty"); 192 | } 193 | 194 | #warn "request: $req\n"; 195 | 196 | my $timeout = $block->timeout; 197 | if (!defined $timeout) { 198 | $timeout = $Timeout; 199 | } 200 | 201 | my $raw_resp = send_request($req, $block->raw_request_middle_delay, 202 | $timeout); 203 | 204 | #warn "raw resonse: [$raw_resp]\n"; 205 | 206 | my $res = HTTP::Response->parse($raw_resp); 207 | my $enc = $res->header('Transfer-Encoding'); 208 | 209 | if (defined $enc && $enc eq 'chunked') { 210 | #warn "Found chunked!"; 211 | my $raw = $res->content; 212 | if (!defined $raw) { 213 | $raw = ''; 214 | } 215 | 216 | my $decoded = ''; 217 | while (1) { 218 | if ($raw =~ /\G 0 [\ \t]* \r\n \r\n /gcsx) { 219 | last; 220 | } 221 | if ($raw =~ m{ \G [\ \t]* ( [A-Fa-f0-9]+ ) [\ \t]* \r\n }gcsx) { 222 | my $rest = hex($1); 223 | #warn "chunk size: $rest\n"; 224 | my $bit_sz = 32765; 225 | while ($rest > 0) { 226 | my $bit = $rest < $bit_sz ? $rest : $bit_sz; 227 | #warn "bit: $bit\n"; 228 | if ($raw =~ /\G(.{$bit})/gcs) { 229 | $decoded .= $1; 230 | #warn "decoded: [$1]\n"; 231 | } else { 232 | fail("$name - invalid chunked data received (not enought octets for the data section)"); 233 | return; 234 | } 235 | 236 | $rest -= $bit; 237 | } 238 | if ($raw !~ /\G\r\n/gcs) { 239 | fail("$name - invalid chunked data received (expected CRLF)."); 240 | return; 241 | } 242 | } elsif ($raw =~ /\G.+/gcs) { 243 | fail "$name - invalid chunked body received: $&"; 244 | return; 245 | } else { 246 | fail "$name - no last chunk found"; 247 | return; 248 | } 249 | } 250 | #warn "decoded: $decoded\n"; 251 | $res->content($decoded); 252 | } 253 | 254 | if (defined $block->error_code) { 255 | is($res->code || '', $block->error_code, "$name - status code ok"); 256 | } else { 257 | is($res->code || '', 200, "$name - status code ok"); 258 | } 259 | 260 | if (defined $block->response_headers) { 261 | my $headers = parse_headers($block->response_headers); 262 | while (my ($key, $val) = each %$headers) { 263 | my $expected_val = $res->header($key); 264 | if (!defined $expected_val) { 265 | $expected_val = ''; 266 | } 267 | is $expected_val, $val, 268 | "$name - header $key ok"; 269 | } 270 | } elsif (defined $block->response_headers_like) { 271 | my $headers = parse_headers($block->response_headers_like); 272 | while (my ($key, $val) = each %$headers) { 273 | my $expected_val = $res->header($key); 274 | if (!defined $expected_val) { 275 | $expected_val = ''; 276 | } 277 | like $expected_val, qr/^$val$/, 278 | "$name - header $key like ok"; 279 | } 280 | } 281 | 282 | if (defined $block->response_body 283 | || defined $block->response_body_eval) { 284 | my $content = $res->content; 285 | if (defined $content) { 286 | $content =~ s/^TE: deflate,gzip;q=0\.3\r\n//gms; 287 | $content =~ s/^Connection: TE, close\r\n//gms; 288 | } 289 | 290 | my $expected; 291 | if ($block->response_body_eval) { 292 | $expected = eval $block->response_body_eval; 293 | if ($@) { 294 | warn $@; 295 | } 296 | } else { 297 | $expected = $block->response_body; 298 | } 299 | 300 | $expected =~ s/\$ServerPort\b/$ServerPort/g; 301 | $expected =~ s/\$ServerPortForClient\b/$ServerPortForClient/g; 302 | #warn show_all_chars($content); 303 | 304 | #warn "no long string: $NoLongString"; 305 | if ($NoLongString) { 306 | is($content, $expected, "$name - response_body - response is expected"); 307 | } else { 308 | is_string($content, $expected, "$name - response_body - response is expected"); 309 | } 310 | 311 | } elsif (defined $block->response_body_like) { 312 | my $content = $res->content; 313 | if (defined $content) { 314 | $content =~ s/^TE: deflate,gzip;q=0\.3\r\n//gms; 315 | } 316 | $content =~ s/^Connection: TE, close\r\n//gms; 317 | my $expected_pat = $block->response_body_like; 318 | $expected_pat =~ s/\$ServerPort\b/$ServerPort/g; 319 | $expected_pat =~ s/\$ServerPortForClient\b/$ServerPortForClient/g; 320 | my $summary = trim($content); 321 | like($content, qr/$expected_pat/s, "$name - response_body_like - response is expected ($summary)"); 322 | } 323 | } 324 | 325 | sub send_request ($$$) { 326 | my ($req, $middle_delay, $timeout) = @_; 327 | 328 | my @req_bits = ref $req ? @$req : ($req); 329 | 330 | my $sock = IO::Socket::INET->new( 331 | PeerAddr => 'localhost', 332 | PeerPort => $ServerPortForClient, 333 | Proto => 'tcp' 334 | ) or die "Can't connect to localhost:$ServerPortForClient: $!\n"; 335 | 336 | my $flags = fcntl $sock, F_GETFL, 0 337 | or die "Failed to get flags: $!\n"; 338 | 339 | fcntl $sock, F_SETFL, $flags | O_NONBLOCK 340 | or die "Failed to set flags: $!\n"; 341 | 342 | my $ctx = { 343 | resp => '', 344 | write_offset => 0, 345 | buf_size => 1024, 346 | req_bits => \@req_bits, 347 | write_buf => shift @req_bits, 348 | middle_delay => $middle_delay, 349 | sock => $sock, 350 | }; 351 | 352 | my $readable_hdls = IO::Select->new($sock); 353 | my $writable_hdls = IO::Select->new($sock); 354 | my $err_hdls = IO::Select->new($sock); 355 | 356 | while (1) { 357 | if ($readable_hdls->count == 0 && $writable_hdls->count == 0 && $err_hdls->count == 0) { 358 | last; 359 | } 360 | 361 | my ($new_readable, $new_writable, $new_err) = 362 | IO::Select->select($readable_hdls, $writable_hdls, 363 | $err_hdls, $timeout); 364 | 365 | if (!defined $new_err && !defined $new_readable 366 | && !defined $new_writable) 367 | { 368 | # timed out 369 | timeout_event_handler($ctx); 370 | last; 371 | } 372 | 373 | for my $hdl (@$new_err) { 374 | next if !defined $hdl; 375 | 376 | error_event_handler($ctx); 377 | 378 | if ($err_hdls->exists($hdl)) { 379 | $err_hdls->remove($hdl); 380 | } 381 | 382 | if ($readable_hdls->exists($hdl)) { 383 | $readable_hdls->remove($hdl); 384 | } 385 | 386 | if ($writable_hdls->exists($hdl)) { 387 | $writable_hdls->remove($hdl); 388 | } 389 | 390 | for my $h (@$readable_hdls) { 391 | next if !defined $h; 392 | if ($h eq $hdl) { 393 | undef $h; 394 | last; 395 | } 396 | } 397 | 398 | for my $h (@$writable_hdls) { 399 | next if !defined $h; 400 | if ($h eq $hdl) { 401 | undef $h; 402 | last; 403 | } 404 | } 405 | 406 | close $hdl; 407 | } 408 | 409 | for my $hdl (@$new_readable) { 410 | next if !defined $hdl; 411 | 412 | my $res = read_event_handler($ctx); 413 | if (!$res) { 414 | # error occured 415 | if ($err_hdls->exists($hdl)) { 416 | $err_hdls->remove($hdl); 417 | } 418 | 419 | if ($readable_hdls->exists($hdl)) { 420 | $readable_hdls->remove($hdl); 421 | } 422 | 423 | if ($writable_hdls->exists($hdl)) { 424 | $writable_hdls->remove($hdl); 425 | } 426 | 427 | for my $h (@$writable_hdls) { 428 | next if !defined $h; 429 | if ($h eq $hdl) { 430 | undef $h; 431 | last; 432 | } 433 | } 434 | 435 | close $hdl; 436 | } 437 | } 438 | 439 | for my $hdl (@$new_writable) { 440 | next if !defined $hdl; 441 | 442 | my $res = write_event_handler($ctx); 443 | if (!$res) { 444 | # error occured 445 | if ($err_hdls->exists($hdl)) { 446 | $err_hdls->remove($hdl); 447 | } 448 | 449 | if ($readable_hdls->exists($hdl)) { 450 | $readable_hdls->remove($hdl); 451 | } 452 | 453 | if ($writable_hdls->exists($hdl)) { 454 | $writable_hdls->remove($hdl); 455 | } 456 | 457 | close $hdl; 458 | } 459 | 460 | if ($res == 2) { 461 | if ($writable_hdls->exists($hdl)) { 462 | $writable_hdls->remove($hdl); 463 | } 464 | } 465 | } 466 | } 467 | 468 | return $ctx->{resp}; 469 | } 470 | 471 | sub timeout_event_handler ($) { 472 | warn "socket client: timed out"; 473 | } 474 | 475 | sub error_event_handler ($) { 476 | warn "exception occurs on the socket: $!\n"; 477 | } 478 | 479 | sub write_event_handler ($) { 480 | my ($ctx) = @_; 481 | 482 | while (1) { 483 | return undef if !defined $ctx->{write_buf}; 484 | 485 | my $rest = length($ctx->{write_buf}) - $ctx->{write_offset}; 486 | #warn "offset: $write_offset, rest: $rest, length ", length($write_buf), "\n"; 487 | #die; 488 | 489 | if ($rest > 0) { 490 | my $bytes = syswrite($ctx->{sock}, $ctx->{write_buf}, $rest, $ctx->{write_offset}); 491 | 492 | if (!defined $bytes) { 493 | if ($! == EAGAIN) { 494 | #warn "write again..."; 495 | #sleep 0.002; 496 | return 1; 497 | } 498 | my $errmsg = "write failed: $!"; 499 | warn "$errmsg\n"; 500 | if (!$ctx->{resp}) { 501 | $ctx->{resp} = "$errmsg"; 502 | } 503 | return undef; 504 | } 505 | 506 | #warn "wrote $bytes bytes.\n"; 507 | $ctx->{write_offset} += $bytes; 508 | } else { 509 | $ctx->{write_buf} = shift @{$ctx->{req_bits}} or return 2; 510 | $ctx->{write_offset} = 0; 511 | if (defined $ctx->{middle_delay}) { 512 | #warn "sleeping.."; 513 | sleep $ctx->{middle_delay}; 514 | } 515 | } 516 | } 517 | 518 | # impossible to reach here... 519 | return undef; 520 | } 521 | 522 | sub read_event_handler ($) { 523 | my ($ctx) = @_; 524 | while (1) { 525 | my $read_buf; 526 | my $bytes = sysread($ctx->{sock}, $read_buf, $ctx->{buf_size}); 527 | 528 | if (!defined $bytes) { 529 | if ($! == EAGAIN) { 530 | #warn "read again..."; 531 | #sleep 0.002; 532 | return 1; 533 | } 534 | $ctx->{resp} = "500 read failed: $!"; 535 | return undef; 536 | } 537 | 538 | if ($bytes == 0) { 539 | return undef; # connection closed 540 | } 541 | 542 | $ctx->{resp} .= $read_buf; 543 | #warn "read $bytes ($read_buf) bytes.\n"; 544 | } 545 | 546 | # impossible to reach here... 547 | return undef; 548 | } 549 | 550 | 1; 551 | __END__ 552 | 553 | =encoding utf-8 554 | 555 | =head1 NAME 556 | 557 | Test::Nginx::Socket - Socket-backed test scaffold for the Nginx C modules 558 | 559 | =head1 SYNOPSIS 560 | 561 | use Test::Nginx::Socket; 562 | 563 | plan tests => $Test::Nginx::Socket::RepeatEach * 2 * blocks(); 564 | 565 | run_tests(); 566 | 567 | __DATA__ 568 | 569 | === TEST 1: sanity 570 | --- config 571 | location /echo { 572 | echo_before_body hello; 573 | echo world; 574 | } 575 | --- request 576 | GET /echo 577 | --- response_body 578 | hello 579 | world 580 | --- error_code: 200 581 | 582 | 583 | === TEST 2: set Server 584 | --- config 585 | location /foo { 586 | echo hi; 587 | more_set_headers 'Server: Foo'; 588 | } 589 | --- request 590 | GET /foo 591 | --- response_headers 592 | Server: Foo 593 | --- response_body 594 | hi 595 | 596 | 597 | === TEST 3: clear Server 598 | --- config 599 | location /foo { 600 | echo hi; 601 | more_clear_headers 'Server: '; 602 | } 603 | --- request 604 | GET /foo 605 | --- response_headers_like 606 | Server: nginx.* 607 | --- response_body 608 | hi 609 | 610 | 611 | === TEST 3: chunk size too small 612 | --- config 613 | chunkin on; 614 | location /main { 615 | echo_request_body; 616 | } 617 | --- more_headers 618 | Transfer-Encoding: chunked 619 | --- request eval 620 | "POST /main 621 | 4\r 622 | hello\r 623 | 0\r 624 | \r 625 | " 626 | --- error_code: 400 627 | --- response_body_like: 400 Bad Request 628 | 629 | =head1 DESCRIPTION 630 | 631 | This module provides a test scaffold based on non-blocking L for automated testing in Nginx C module development. 632 | 633 | This class inherits from L, thus bringing all its 634 | declarative power to the Nginx C module testing practices. 635 | 636 | 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 637 | 638 | killall nginx 639 | PATH=/path/to/your/nginx-with-memc-module:$PATH prove -r t 640 | 641 | 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. 642 | 643 | You will often want to look into F 644 | when things go wrong ;) 645 | 646 | =head1 Sections supported 647 | 648 | The following sections are supported: 649 | 650 | =over 651 | 652 | =item config 653 | 654 | =item http_config 655 | 656 | =item request 657 | 658 | =item request_eval 659 | 660 | =item more_headers 661 | 662 | =item response_body 663 | 664 | =item response_body_eval 665 | 666 | =item response_body_like 667 | 668 | =item response_headers 669 | 670 | =item response_headers_like 671 | 672 | =item error_code 673 | 674 | =item raw_request 675 | 676 | Both string scalar and string arrays are supported as values. 677 | 678 | =item raw_request_middle_delay 679 | 680 | Delay in sec between sending successive packets in the "raw_request" array value. 681 | 682 | =back 683 | 684 | =head1 Samples 685 | 686 | You'll find live samples in the following Nginx 3rd-party modules: 687 | 688 | =over 689 | 690 | =item ngx_chunkin 691 | 692 | L 693 | 694 | =item ngx_memc 695 | 696 | L 697 | 698 | =item ngx_drizzle 699 | 700 | L 701 | 702 | =item ngx_rds_json 703 | 704 | L 705 | 706 | =item ngx_xss 707 | 708 | L 709 | 710 | =back 711 | 712 | =head1 SOURCE REPOSITORY 713 | 714 | This module has a Git repository on Github, which has access for all. 715 | 716 | http://github.com/agentzh/test-nginx 717 | 718 | If you want a commit bit, feel free to drop me a line. 719 | 720 | =head1 AUTHOR 721 | 722 | agentzh (章亦春) C<< >> 723 | 724 | =head1 COPYRIGHT & LICENSE 725 | 726 | Copyright (c) 2009, Taobao Inc., Alibaba Group (L). 727 | 728 | Copyright (c) 2009, agentzh C<< >>. 729 | 730 | This module is licensed under the terms of the BSD license. 731 | 732 | Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 733 | 734 | =over 735 | 736 | =item * 737 | 738 | Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 739 | 740 | =item * 741 | 742 | 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. 743 | 744 | =item * 745 | 746 | 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. 747 | 748 | =back 749 | 750 | 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. 751 | 752 | =head1 SEE ALSO 753 | 754 | L, L. 755 | 756 | -------------------------------------------------------------------------------- /doc/README.wiki: -------------------------------------------------------------------------------- 1 | = Name = 2 | 3 | '''nginx_http_oauth_module''' - support oauth client with Nginx 4 | 5 | 6 | = Status = 7 | 8 | This module is at its very early phase of development and considered highly experimental. But you're encouraged to test it out on your side and report any quirks that you experience. 9 | 10 | We need your help! If you find this module useful and/or interesting, please consider joining the development! 11 | 12 | 13 | = examples = 14 | 15 | == a simple get example == 16 | 17 | 18 | 19 | http { 20 | 21 | resolver your_dns_server; 22 | server { 23 | listen 80; 24 | server_name localhost; 25 | 26 | oauth_consumer_key key; 27 | oauth_consumer_secret secret; 28 | oauth_realm "http://example.org"; 29 | oauth_variables $oauth_token $oauth_token_secret $proxy_uri; 30 | session_zone $user_id zone=test:10m; 31 | 32 | #two step oauth 33 | location /{ 34 | set $user_id yaoweibin; 35 | 36 | if ($user_id = "") { 37 | rewrite (.*) /session last; 38 | } 39 | 40 | rewrite (.*) /get_local_session last; 41 | 42 | return 404; 43 | } 44 | 45 | location /get_local_session { 46 | session_get zone=test $oauth_token $oauth_token_secret; 47 | 48 | if ($oauth_token = "") { 49 | rewrite (.*) /session last; 50 | } 51 | 52 | if ($oauth_token_secret = "") { 53 | rewrite (.*) /session last; 54 | } 55 | 56 | rewrite (.*) /oauth_proxy last; 57 | } 58 | 59 | location /oauth_proxy { 60 | if ($oauth_token = "") { 61 | return 403; 62 | } 63 | 64 | if ($oauth_token_secret = "") { 65 | return 403; 66 | } 67 | 68 | set $proxy_uri "http://term.ie/oauth/example/echo_api.php?method=foo&bar=baz"; 69 | proxy_pass $oauth_signed_authenticated_call_uri; 70 | } 71 | 72 | location /session { 73 | eval_override_content_type application/x-www-form-urlencoded; 74 | eval $oauth_token $oauth_token_secret { 75 | set $proxy_uri "http://term.ie/oauth/example/request_token.php"; 76 | proxy_pass $oauth_signed_request_token_uri; 77 | } 78 | 79 | eval $oauth_token $oauth_token_secret { 80 | set $proxy_uri "http://term.ie/oauth/example/access_token.php"; 81 | proxy_pass $oauth_signed_access_token_uri; 82 | } 83 | 84 | if ($oauth_token = "") { 85 | return 403; 86 | } 87 | 88 | if ($oauth_token_secret = "") { 89 | return 403; 90 | } 91 | 92 | session_store zone=test $oauth_token $oauth_token_secret expire=1d; 93 | 94 | add_header Location http://localhost/; 95 | 96 | return 302; 97 | } 98 | } 99 | } 100 | 101 | 102 | 103 | == a simple post example == 104 | 105 | 106 | 107 | resolver your_dns_server; 108 | 109 | http { 110 | 111 | server { 112 | listen 80; 113 | server_name localhost; 114 | 115 | oauth_consumer_key key; 116 | oauth_consumer_secret secret; 117 | oauth_realm "http://example.org"; 118 | oauth_variables $oauth_token $oauth_token_secret $proxy_uri; 119 | session_zone $user_id zone=test:10m; 120 | 121 | #two step oauth 122 | location /{ 123 | set $user_id yaoweibin; 124 | 125 | if ($user_id = "") { 126 | rewrite (.*) /session last; 127 | } 128 | 129 | rewrite (.*) /get_local_session last; 130 | 131 | return 404; 132 | } 133 | 134 | location /get_local_session { 135 | session_get zone=test $oauth_token $oauth_token_secret; 136 | 137 | if ($oauth_token = "") { 138 | rewrite (.*) /session last; 139 | } 140 | 141 | if ($oauth_token_secret = "") { 142 | rewrite (.*) /session last; 143 | } 144 | 145 | rewrite (.*) /oauth_proxy last; 146 | } 147 | 148 | location /oauth_proxy { 149 | if ($oauth_token = "") { 150 | return 403; 151 | } 152 | 153 | if ($oauth_token_secret = "") { 154 | return 403; 155 | } 156 | 157 | set $proxy_uri "http://term.ie/oauth/example/echo_api.php?method=foo&bar=baz"; 158 | 159 | proxy_set_body $oauth_signed_authenticated_call_postargs; 160 | proxy_method POST; 161 | proxy_set_header Content-Type application/x-www-form-urlencoded; 162 | 163 | proxy_pass http://term.ie/oauth/example/echo_api.php; 164 | } 165 | 166 | location /session { 167 | eval_override_content_type application/x-www-form-urlencoded; 168 | eval $oauth_token $oauth_token_secret { 169 | proxy_method POST; 170 | set $proxy_uri "http://term.ie/oauth/example/request_token.php"; 171 | proxy_set_body $oauth_signed_request_token_postargs; 172 | proxy_set_header Content-Type application/x-www-form-urlencoded; 173 | 174 | proxy_pass "http://term.ie/oauth/example/request_token.php"; 175 | } 176 | 177 | eval $oauth_token $oauth_token_secret { 178 | proxy_method POST; 179 | set $proxy_uri "http://term.ie/oauth/example/access_token.php"; 180 | proxy_set_body $oauth_signed_access_token_postargs; 181 | proxy_set_header Content-Type application/x-www-form-urlencoded; 182 | 183 | proxy_pass "http://term.ie/oauth/example/access_token.php"; 184 | } 185 | 186 | if ($oauth_token = "") { 187 | return 403; 188 | } 189 | 190 | if ($oauth_token_secret = "") { 191 | return 403; 192 | } 193 | 194 | session_store zone=test $oauth_token $oauth_token_secret expire=1d; 195 | 196 | add_header Location http://localhost/; 197 | 198 | return 302; 199 | } 200 | } 201 | } 202 | 203 | 204 | 205 | == a simple authorization header example == 206 | 207 | 208 | 209 | resolver your_dns_server; 210 | 211 | http { 212 | 213 | server { 214 | listen 80; 215 | server_name localhost; 216 | 217 | oauth_consumer_key key; 218 | oauth_consumer_secret secret; 219 | oauth_realm "http://example.org"; 220 | oauth_variables $oauth_token $oauth_token_secret $proxy_uri; 221 | session_zone $user_id zone=test:10m; 222 | 223 | #two step oauth 224 | location /{ 225 | set $user_id yaoweibin; 226 | 227 | if ($user_id = "") { 228 | rewrite (.*) /session last; 229 | } 230 | 231 | rewrite (.*) /get_local_session last; 232 | 233 | return 404; 234 | } 235 | 236 | location /get_local_session { 237 | session_get zone=test $oauth_token $oauth_token_secret; 238 | 239 | if ($oauth_token = "") { 240 | rewrite (.*) /session last; 241 | } 242 | 243 | if ($oauth_token_secret = "") { 244 | rewrite (.*) /session last; 245 | } 246 | 247 | rewrite (.*) /oauth_proxy last; 248 | } 249 | 250 | location /oauth_proxy { 251 | if ($oauth_token = "") { 252 | return 403; 253 | } 254 | 255 | if ($oauth_token_secret = "") { 256 | return 403; 257 | } 258 | 259 | set $proxy_uri "http://term.ie/oauth/example/echo_api.php?method=foo&bar=baz"; 260 | proxy_set_header Authorization $oauth_signed_authenticated_call_header; 261 | proxy_pass $proxy_uri; 262 | } 263 | 264 | location /session { 265 | eval_override_content_type application/x-www-form-urlencoded; 266 | eval $oauth_token $oauth_token_secret { 267 | set $proxy_uri "http://term.ie/oauth/example/request_token.php"; 268 | proxy_set_header Authorization $oauth_signed_request_token_header; 269 | proxy_pass $proxy_uri; 270 | } 271 | 272 | eval $oauth_token $oauth_token_secret { 273 | set $proxy_uri "http://term.ie/oauth/example/access_token.php"; 274 | proxy_set_header Authorization $oauth_signed_access_token_header; 275 | proxy_pass $proxy_uri; 276 | } 277 | 278 | if ($oauth_token = "") { 279 | return 403; 280 | } 281 | 282 | if ($oauth_token_secret = "") { 283 | return 403; 284 | } 285 | 286 | session_store zone=test $oauth_token $oauth_token_secret expire=1d; 287 | 288 | add_header Location http://localhost/; 289 | 290 | return 302; 291 | } 292 | } 293 | } 294 | 295 | 296 | 297 | == a full get example == 298 | 299 | 300 | 301 | resolver your_dns_server; 302 | 303 | http { 304 | 305 | resolver your_dns_server; 306 | server { 307 | listen 80; 308 | server_name _ localhost example.cn; 309 | 310 | oauth_consumer_key J7ohNh8uATJugHZW2g5A; 311 | oauth_consumer_secret W9c6ucRYCTTD4Y13v7wQ6iTLNYs1cHDzGa2PHCDkg; 312 | oauth_variables $oauth_token $oauth_token_secret $proxy_uri; 313 | session_zone $binary_remote_addr zone=test:10M; 314 | session_zone $screen_name zone=twitter:10M; 315 | 316 | location / { 317 | 318 | set $screen_name yaoweibin; 319 | 320 | if ($screen_name = "") { 321 | rewrite (.*) /session last; 322 | } 323 | 324 | rewrite (.*) /get_local_session last; 325 | 326 | return 404; 327 | } 328 | 329 | location /get_local_session { 330 | session_get zone=twitter $oauth_token $oauth_token_secret; 331 | 332 | if ($oauth_token = "") { 333 | rewrite (.*) /session last; 334 | } 335 | 336 | if ($oauth_token_secret = "") { 337 | rewrite (.*) /session last; 338 | } 339 | 340 | rewrite (.*) /oauth_proxy last; 341 | } 342 | 343 | location /oauth_proxy { 344 | if ($oauth_token = "") { 345 | return 403; 346 | } 347 | 348 | if ($oauth_token_secret = "") { 349 | return 403; 350 | } 351 | 352 | set $proxy_uri http://api.twitter.com$request_uri; 353 | proxy_pass $oauth_signed_authenticated_call_uri; 354 | } 355 | 356 | location /session { 357 | eval_override_content_type application/x-www-form-urlencoded; 358 | eval $oauth_token $oauth_token_secret { 359 | set $proxy_uri "http://api.twitter.com/oauth/request_token?oauth_callback=http://example.cn/ready"; 360 | proxy_set_body $oauth_signed_request_token_postargs; 361 | proxy_method POST; 362 | proxy_set_header Accept-Encoding identity; 363 | proxy_set_header Content-Type application/x-www-form-urlencoded; 364 | 365 | proxy_pass "http://api.twitter.com/oauth/request_token"; 366 | } 367 | 368 | if ($oauth_token = "") { 369 | return 403; 370 | } 371 | 372 | if ($oauth_token_secret = "") { 373 | return 403; 374 | } 375 | 376 | session_store zone=test $oauth_token $oauth_token_secret; 377 | 378 | add_header Location http://api.twitter.com/oauth/authorize?oauth_token=$oauth_token; 379 | 380 | return 302; 381 | } 382 | 383 | location /ready { 384 | eval_override_content_type application/x-www-form-urlencoded; 385 | 386 | eval $oauth_token $oauth_token_secret $screen_name { 387 | session_get zone=test $session_oauth_token $oauth_token_secret; 388 | 389 | set $proxy_uri http://api.twitter.com/oauth/access_token?oauth_verifier=$arg_oauth_verifier; 390 | set $oauth_token $arg_oauth_token; 391 | 392 | proxy_set_body $oauth_signed_access_token_postargs; 393 | proxy_method POST; 394 | proxy_set_header Content-Type application/x-www-form-urlencoded; 395 | proxy_set_header Accept-Encoding identity; 396 | 397 | proxy_pass $proxy_uri; 398 | } 399 | 400 | if ($oauth_token = "") { 401 | return 403; 402 | } 403 | 404 | if ($oauth_token_secret = "") { 405 | return 403; 406 | } 407 | 408 | session_store zone=twitter $oauth_token $oauth_token_secret expire=1d; 409 | 410 | add_header Location http://example.cn/1/statuses/friends_timeline.xml; 411 | 412 | return 302; 413 | } 414 | } 415 | } 416 | 417 | 418 | 419 | 420 | = Description = 421 | 422 | Add the support oauth client with Nginx. 423 | 424 | = Directives = 425 | 426 | == oauth_consumer_key == 427 | 428 | '''syntax:'''''oauth_consumer_key key_string'' 429 | 430 | '''default:''' ''none'' 431 | 432 | '''context:''' ''http, server, location'' 433 | 434 | '''description:''' The string of consumer key. 435 | 436 | == oauth_consumer_secret == 437 | 438 | '''syntax:'''''oauth_consumer_secret secret_string'' 439 | 440 | '''default:''' ''none'' 441 | 442 | '''context:''' ''http, server, location'' 443 | 444 | '''description:''' The string of consumer secret. 445 | 446 | == oauth_realm == 447 | 448 | '''syntax:'''''oauth_realm realm_string'' 449 | 450 | '''default:''' ''none'' 451 | 452 | '''context:''' ''http, server, location'' 453 | 454 | '''description:''' The string of realm when you use in the authorization header. 455 | 456 | == oauth_signature_method == 457 | 458 | '''syntax:''''oauth_signature_method HMAC-SHA1 | PLAINTEXT | RSA-SHA1'' 459 | 460 | '''default:''' ''oauth_signature_method HMAC-SHA1'' 461 | 462 | '''context:''' ''http, server, location'' 463 | 464 | '''description:''' The oauth signature method. 465 | 466 | == oauth_variables == 467 | 468 | '''syntax:''''oauth_variables $oauth_token $oauth_token_secret $proxy_uri'' 469 | 470 | '''default:''' ''none'' 471 | 472 | '''context:''' ''http, server, location'' 473 | 474 | '''description:''' The variables used in the protocol exchanging, especially the signed uri variables below. These variables are changable and has different meanings in differet stages of oauth. 475 | 476 | 477 | = Variables = 478 | 479 | == $oauth_signed_request_token_uri == 480 | 481 | '''description:''' You can fetch the request token with this uri. The base uri is the variable of $proxy_uri. This request token uri outputs like this: 482 | http://api.t.sina.com.cn/oauth/request_token?oauth_consumer_key=190008619&oauth_nonce=akQcG8ydQ77lftD23F&oauth_signature_method=HMAC-SHA1&oauth_timestamp=1286614404&oauth_version=1.0&oauth_signature=NqchRk%2F9wfwNybQovV0j8QofCww%3D 483 | 484 | The signature is constructed by $proxy_uri, oauth_consumer_key and oauth_consumer_secret etc. See rfc5849 for detail. 485 | 486 | == $oauth_signed_access_token_uri == 487 | 488 | '''description:''' You can fetch the access token with this uri. The base uri is the variable of $proxy_uri. This access token uri outputs like this: 489 | http://api.t.sina.com.cn/oauth/access_token?oauth_consumer_key=190008619&oauth_nonce=WiVUancz2jFbdhqfDxdUT&oauth_signature_method=HMAC-SHA1&oauth_timestamp=1286614914&oauth_token=1b9ded6ed3b49a0e147e32245e53a152&oauth_verifier=762191&oauth_version=1.0&oauth_signature=zK6c%2BNlL5w6PW0K7I3JinXjDrss%3D 490 | 491 | The signature is constructed by $proxy_uri, $oauth_token, $oauth_token_secret, oauth_consumer_key and oauth_consumer_secret etc. See rfc5849 for detail. 492 | 493 | == $oauth_signed_authenticated_call_uri == 494 | 495 | '''description:''' You can fetch the authenticated data with this uri. The base uri is the variable of $proxy_uri. This uri outputs like this: 496 | http://api.t.sina.com.cn/statuses/friends_timeline.xml?count=20&oauth_consumer_key=190008619&oauth_nonce=vhNCl3O2KDR63mDzIMCtXNB&oauth_signature_method=HMAC-SHA1&oauth_timestamp=1286614915&oauth_token=cf6f67f79500f8bb5803465ef9d28e33&oauth_version=1.0&oauth_signature=UQt%2B%2FmY3UruvoguaIXbzyENCQbA%3D 497 | 498 | The signature is constructed by $proxy_uri, $oauth_token, $oauth_token_secret, oauth_consumer_key and oauth_consumer_secret etc. See rfc5849 for detail. 499 | 500 | == $oauth_signed_request_token_postargs == 501 | 502 | '''description:''' You can fetch the request token with this post body when you use the post form-encoded body for parameter transmission. The base uri is the variable of $proxy_uri. This request token post arguments output like this: 503 | oauth_consumer_key=190008619&oauth_nonce=akQcG8ydQ77lftD23F&oauth_signature_method=HMAC-SHA1&oauth_timestamp=1286614404&oauth_version=1.0&oauth_signature=NqchRk%2F9wfwNybQovV0j8QofCww%3D 504 | 505 | The signature is constructed by $proxy_uri, oauth_consumer_key and oauth_consumer_secret etc. See rfc5849 for detail. You can set the request body with the directive of '''proxy_set_body'''. Also you should set the request's content-type header like this: 506 | 507 | proxy_set_header Content-Type application/x-www-form-urlencoded; 508 | 509 | == $oauth_signed_access_token_postargs == 510 | 511 | '''description:''' You can fetch the access token with this post arguments. The base uri is the variable of $proxy_uri. This access token post arguments output like this: 512 | oauth_consumer_key=190008619&oauth_nonce=WiVUancz2jFbdhqfDxdUT&oauth_signature_method=HMAC-SHA1&oauth_timestamp=1286614914&oauth_token=1b9ded6ed3b49a0e147e32245e53a152&oauth_verifier=762191&oauth_version=1.0&oauth_signature=zK6c%2BNlL5w6PW0K7I3JinXjDrss%3D 513 | 514 | The signature is constructed by $proxy_uri, $oauth_token, $oauth_token_secret, oauth_consumer_key and oauth_consumer_secret etc. See rfc5849 for detail. You can set the request body with the directive of '''proxy_set_body'''. Also you should set the request's content-type header like this: 515 | 516 | proxy_set_header Content-Type application/x-www-form-urlencoded; 517 | 518 | == $oauth_signed_authenticated_call_postargs == 519 | 520 | '''description:''' You can fetch the authenticated data with this post arguments. The base uri is the variable of $proxy_uri. This post arguments output like this: 521 | oauth_consumer_key=190008619&oauth_nonce=vhNCl3O2KDR63mDzIMCtXNB&oauth_signature_method=HMAC-SHA1&oauth_timestamp=1286614915&oauth_token=cf6f67f79500f8bb5803465ef9d28e33&oauth_version=1.0&oauth_signature=UQt%2B%2FmY3UruvoguaIXbzyENCQbA%3D 522 | 523 | The signature is constructed by $proxy_uri, $oauth_token, $oauth_token_secret, oauth_consumer_key and oauth_consumer_secret etc. See rfc5849 for detail. You can set the request body with the directive of '''proxy_set_body'''. Also you should set the request's content-type header like this: 524 | 525 | proxy_set_header Content-Type application/x-www-form-urlencoded; 526 | 527 | == $oauth_signed_request_token_header == 528 | 529 | '''description:''' You can fetch the request token with this authorization header when you use the header for parameter transmission. The base uri is the variable of $proxy_uri. This request token header value output like this: 530 | OAuth realm="http://api.douban.com/", oauth_consumer_key="08d97fc919fee0b41a8c7f5b4dfca21c", oauth_nonce="gIfvcyr9c5oUOhL2F3Y8", oauth_signature_method="HMAC-SHA1", oauth_timestamp="1287128845", oauth_version="1.0", oauth_signature="VewnNJT0kh5fQFWkBFsYZ5GS37k%3D" 531 | 532 | The signature is constructed by $proxy_uri, oauth_consumer_key and oauth_consumer_secret etc. See rfc5849 for detail. You can set the request body with the directive of '''proxy_set_body'''. You could set the request's authorrization header like this: 533 | 534 | proxy_set_header Authorization $oauth_signed_request_token_header; 535 | 536 | == $oauth_signed_access_token_header == 537 | 538 | '''description:''' You can fetch the access token with this authorization header when you use the header for parameter transmission. The base uri is the variable of $proxy_uri. This access token header value output like this: 539 | OAuth realm="http://api.douban.com/", oauth_consumer_key="08d97fc919fee0b41a8c7f5b4dfca21c", oauth_nonce="GMkRTCr5dHueZQlIX", oauth_signature_method="HMAC-SHA1", oauth_timestamp="1287128847", oauth_token="0a820ee61c07a2e81f862cb25416e8b8", oauth_version="1.0", oauth_signature="EqlVebguiov1%2Fsa79xqWoxhYVWA%3D" 540 | 541 | The signature is constructed by $proxy_uri, oauth_consumer_key and oauth_consumer_secret etc. See rfc5849 for detail. You can set the request body with the directive of '''proxy_set_body'''. You could set the request's authorrization header like this: 542 | 543 | proxy_set_header Authorization $oauth_signed_access_token_header; 544 | 545 | == $oauth_signed_authenticated_call_header == 546 | 547 | '''description:''' You can fetch the authenticated data with this authorization header when you use the header for parameter transmission. The base uri is the variable of $proxy_uri. This header value output like this: 548 | OAuth realm="http://api.douban.com/", oauth_consumer_key="08d97fc919fee0b41a8c7f5b4dfca21c", oauth_nonce="1gJxmVBe0oDFtkRS1EjZhxKODKqvLE", oauth_signature_method="HMAC-SHA1", oauth_timestamp="1287128847", oauth_token="77f5806f876136be67e0814e9623a43a", oauth_version="1.0", oauth_signature="ss43G54qkh3Wb8A8SyPhMD76ia4%3D" 549 | 550 | The signature is constructed by $proxy_uri, oauth_consumer_key and oauth_consumer_secret etc. See rfc5849 for detail. You can set the request body with the directive of '''proxy_set_body'''. You could set the request's authorrization header like this: 551 | 552 | proxy_set_header Authorization $oauth_signed_authenticated_call_header; 553 | 554 | 555 | = Installation = 556 | 557 | Get the [http://liboauth.sourceforge.net/ liboauth], and install it. 558 | 559 | Download the latest version of the release tarball of this module from [http://github.com/yaoweibin/nginx_http_oauth_module github]. Also this module need the [http://github.com/yaoweibin/nginx_session_store_module nginx_session_store_module] and [http://github.com/yaoweibin/nginx-eval-module nginx_eval_module]. 560 | 561 | Grab the nginx source code from [http://nginx.org/ nginx.org], for example, the version 0.7.67 (see nginx compatibility), and then build the source with this module: 562 | 563 | 564 | $ wget 'http://nginx.org/download/nginx-0.7.67.tar.gz' 565 | $ tar -xzvf nginx-0.7.67.tar.gz 566 | $ cd nginx-0.7.67/ 567 | 568 | $ ./configure --add-module=/path/to/nginx_session_store_module --add-module=/path/to/nginx_http_oauth_module --add-module=/path/to/nginx_eval_module 569 | 570 | $ make 571 | $ make install 572 | 573 | 574 | 575 | = Compatibility = 576 | 577 | * My test bed is 0.7.67 and 0.8.42. 578 | 579 | = TODO = 580 | 581 | = Known Issues = 582 | 583 | * Developing 584 | 585 | = Changelogs = 586 | 587 | == v0.1 == 588 | * first release 589 | 590 | = Authors = 591 | 592 | Weibin Yao(姚伟斌) ''yaoweibin at gmail dot com'' 593 | 594 | = Copyright & License = 595 | 596 | This README template copy from [http://github.com/agentzh agentzh]. 597 | 598 | This module is licensed under the BSD license. 599 | 600 | Copyright (C) 2010 by Weibin Yao . 601 | 602 | All rights reserved. 603 | 604 | Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 605 | 606 | * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 607 | * 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. 608 | 609 | 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. 610 | 611 | --------------------------------------------------------------------------------