use strict; use warnings; use diagnostics; # ugly use lib to let it run from everywhere use lib '../../../../example/lib'; use lib '../example/lib'; use lib 'example/lib'; use lib 'lib'; use lib 't/lib'; use warnings; use Test::More; #qw(no_plan); use MyElements::sayHello; eval { require Test::MockObject } or plan skip_all => 'Test::MockObject required for faking mod_perl'; plan tests => 13; my @ERROR_FROM = (); my $REQUEST = 'Foo', my $RESPONSE; my %DIR_CONFIG_OF = ( dispatch_to => 'Mod_Perl2Test', soap_service => 'MyServer::HelloWorld::HelloWorldSoap', ); # Ouch, testing mod_perl without mod_perl is pain in the arse. # # This is what we have to mock # #use Apache2::RequestIO (); # $r->read() #use Apache2::RequestRec (); # $r->headers_in #use Apache2::RequestUtil(); # $r->dir_config() #use APR::Table (); # $r->headers_in->get() #use Apache2::Log (); # $r->log #use Apache2::Const -compile => qw( # OK # SERVER_ERROR # HTTP_LENGTH_REQUIRED # ); my $mock = Test::MockObject->new(); $mock->fake_module('Apache2::Const' => OK => sub { 1 }, SERVER_ERROR => sub { 500 }, HTTP_LENGTH_REQUIRED => sub { 411 }, import => sub {}, ); $mock->fake_module('Apache2::Headers' => new => sub { my $class = shift; return bless { @_ }, $class }, get => sub { return $_[0]->{ $_[1] } }, ); $mock->fake_module('Apache2::Log' => new => sub { return bless {}, 'Apache2::Log' }, error => sub { shift; push @ERROR_FROM, @_ }, warn => sub { shift; push @ERROR_FROM, @_ }, ); $mock->fake_module('Apache2::RequestIO'); $mock->fake_module('Apache2::RequestRec' => new => sub { return bless {}, 'Apache2::RequestRec' }, log => sub { return Apache2::Log->new() }, dir_config => sub { return $DIR_CONFIG_OF{$_[1]}}, headers_in => sub { return Apache2::Headers->new( 'content-length' => length($REQUEST), 'SOAPAction' => 'urn:HelloWorld#sayHello', ) }, 'read' => sub { $_[1] = $REQUEST; my $length = length($REQUEST); $REQUEST = q{}; return $length; }, method => sub { 'POST' }, uri => sub { 'http://example.org/soap-wsdl/helloWorld/' }, content_type => sub {}, 'print' => sub { shift; $RESPONSE .= join(q{}, @_) }, ); $mock->fake_module('Apache2::RequestUtil'); $mock->fake_module('APR::Table'); use_ok qw(SOAP::WSDL::Server::Mod_Perl2); ok my $obj = SOAP::WSDL::Server::Mod_Perl2->new(), 'instantiate object'; my $r = Apache2::RequestRec->new(); # block for scoping local { # dirty but useful... local $DIR_CONFIG_OF{dispatch_to} = undef; SOAP::WSDL::Server::Mod_Perl2::handler($r); like $ERROR_FROM[0], qr{\A No \s 'dispatch_to' \s variable \s set \s in \s httpd.conf }x , 'error on bad dispatch_to'; @ERROR_FROM = (); } # block for scoping local { # dirty but useful... local $DIR_CONFIG_OF{dispatch_to} = 'main'; SOAP::WSDL::Server::Mod_Perl2::handler($r); like $ERROR_FROM[0], qr{\A Failed \s to \s require \s \[main\] }x, 'error on bad dispatch_to'; @ERROR_FROM = (); } # block for scoping local { # dirty but useful... local $DIR_CONFIG_OF{soap_service} = undef; SOAP::WSDL::Server::Mod_Perl2::handler($r); like $ERROR_FROM[0], qr{\A No \s 'soap_service' \s variable \s set \s in \s httpd.conf }x , 'error on bad dispatch_to'; @ERROR_FROM = (); } # block for scoping local { # dirty but useful... local $DIR_CONFIG_OF{soap_service} = 'soap_service'; SOAP::WSDL::Server::Mod_Perl2::handler($r); like $ERROR_FROM[0], qr{\A Failed \s to \s require \s \[soap_service\] }x, 'error on bad dispatch_to'; @ERROR_FROM = (); } # block for scoping local { # dirty but useful... local $DIR_CONFIG_OF{transport_class} = 'transport_class'; SOAP::WSDL::Server::Mod_Perl2::handler($r); like $ERROR_FROM[0], qr{\A Failed \s to \s require \s \[transport_class\] }x, 'error on bad transport_class'; @ERROR_FROM = (); } # block for scoping local { # dirty but useful... local $DIR_CONFIG_OF{transport_class} = 'SOAP::WSDL::Server::Mod_Perl2'; $REQUEST = q{Foobar}; SOAP::WSDL::Server::Mod_Perl2::handler($r); like $ERROR_FROM[0], qr{\A Failed \s to \s handle \s request }x, 'error on bad request'; @ERROR_FROM = (); } # just a block - got used to it. { SOAP::WSDL::Server::Mod_Perl2::handler($r); like $ERROR_FROM[0], qr{\A No \s content-length \s provided }x, 'error on missing content-length'; @ERROR_FROM = (); } { my $hello = MyElements::sayHello->new({ name => 'Kutter', givenName => 'Martin' }); $REQUEST = ' ' . $hello->serialize_qualified() . ''; SOAP::WSDL::Server::Mod_Perl2::handler($r); like $RESPONSE, qr{Hello \s Martin \sKutter}x, 'SOAP response'; @ERROR_FROM = (); } { my $hello = MyElements::sayHello->new({ name => '__DIE__', }); $REQUEST = ' ' . $hello->serialize_qualified() . ''; SOAP::WSDL::Server::Mod_Perl2::handler($r); like $ERROR_FROM[0], qr{Failed \s to \s handle \s request: \s FOO}x, 'SOAP response'; } { my $hello = MyElements::sayHello->new({ name => '__DIE__', }); $REQUEST = ' ' . $hello->serialize_qualified() . '' . ''; SOAP::WSDL::Server::Mod_Perl2::handler($r); like $ERROR_FROM[0], qr{Failed \s to \s handle \s request: \s FOO}x, 'SOAP response'; } # This test breaks the read() method. Be sure to add tests needing it above. { no warnings qw(redefine once); $REQUEST = 'FOOBAR'; *Apache2::RequestRec::read = sub { $_[1] = "BA"; $REQUEST = q{}; return length($REQUEST) }; my $hello = MyElements::sayHello->new({ name => 'Kutter', }); $REQUEST = ' ' . $hello->serialize_qualified() . ''; SOAP::WSDL::Server::Mod_Perl2::handler($r); like $ERROR_FROM[0], qr{Failed \s to \s handle \s request: \s FOO}x, 'SOAP response'; }