2015-01-20 29 views
4

我試圖調試一個奇怪的警告,當正在解析Plack::Request時,它出現在服務器日誌中。在某些情況下,破壞的UserAgent會發送一個類似「6375,6375」的Content-Length頭,這顯然是錯誤的。如何使用Perl爲HTTP請求發送不正確的Content-Length標頭?

爲了解決這個問題,我需要能夠重現警告。我想在一個單元測試中包含這個,這樣我可以確保在警告消失後沒有迴歸。但是,我在使用Perl時遇到了麻煩。我知道這可以使用netcatsocat完成,但我不希望單元測試必須依賴其他二進制文件進行安裝。

這裏是我試過:

#!/usr/bin/env perl 

use strict; 
use warnings; 

use JSON::XS qw(encode_json); 
use WWW::Mechanize; 

my $mech = WWW::Mechanize->new; 

$mech->add_handler(
    request_prepare => sub { 
     my ($req, $ua, $h) = @_; 
     $req->headers->header('Content-Length' => 9999); 
     return; 
    } 
); 

my $json = encode_json({ foo => 'bar' }); 

$mech->post(
    'http://example.com'/url, 
    'Content-Length' => 999, 
    Content   => $json 
); 

輸出是:

Content-Length header value was wrong, fixed at /opt/perl5.16.3/lib/site_perl/5.16.3/LWP/Protocol/http.pm line 260. 
200 

這完全是太有幫助了我。 :)

如果我使用HTTP::RequestLWP::UserAgent,它是相同的最終結果。

所以,我試了HTTP::Tiny

#!/usr/bin/env perl 

use strict; 
use warnings; 

use DDP; 
use HTTP::Tiny; 
use JSON::XS qw(encode_json); 

my $http = HTTP::Tiny->new; 

my $json = encode_json({ foo => 'bar' }); 
my $response = $http->request(
    'POST', 
    'http://example.com'/url', 
    { headers => { 'Content-Length' => 999, }, 
     content => $json, 
    } 
); 

p $response; 

輸出是:

{ content => "Content-Length missmatch (got: 13 expected: 999) 
", 
    headers => { 
     content 
      -length => 49, 
     content-type => "text/plain", 
    }, 
    reason => "Internal Exception", 
    status => 599, 
    success => "", 
    url  => "http://example.com'/url", 
} 

同樣,也有幫助。在這一點上,我可以使用一些建議。

回答

1

好像更高級別的API正在修復您的錯誤;這裏有一個使用原始套接字的例子,它克服了這個問題。

#!/usr/bin/env perl 
use strict 'vars'; 
use warnings; 
use Socket; 

# initialize host and port 
my $host = 'www.example.com'; 
my $port = 80; 

# contact the server 
open_tcp(F, $host, $port) 
    or die 'Could not connect to server'; 

# Send request data 
while (my $request = <DATA>) { 
    print F $request; 
} 

# Get Response 
while (my $response = <F>) { 
    print "Response:> $response"; 
} 

close(F); 

# TCP Helper 
sub open_tcp 
{ 
    # get parameters 
    my ($FS, $dest, $port) = @_; 

    my $proto = getprotobyname('tcp'); 
    socket($FS, PF_INET, SOCK_STREAM, $proto); 
    my $sin = sockaddr_in($port,inet_aton($dest)); 
    connect($FS,$sin); 

    my $old_fh = select($FS); 
    $| = 1; # don't buffer output 
    select($old_fh); 
} 

__DATA__ 
GET/HTTP/1.1 
Host: example.com 
Content-Length: 999 


-END- 
相關問題