3676
3674
return ($scheme, $host, $port, $path_query);
3680
HTTPMicro::Handle; # hide from PAUSE/indexers
3685
use Errno qw[EINTR EPIPE];
3686
use IO::Socket qw[SOCK_STREAM];
3688
sub BUFSIZE () { 32768 }
3690
my $Printable = sub {
3695
s/([^\x20-\x7E])/sprintf('\\x%.2X', ord($1))/ge;
3700
my ($class, %args) = @_;
3704
max_line_size => 16384,
3709
my $ssl_verify_args = {
3710
check_cn => "when_only",
3711
wildcards_in_alt => "anywhere",
3712
wildcards_in_cn => "anywhere"
3716
@_ == 4 || croak(q/Usage: $handle->connect(scheme, host, port)/);
3717
my ($self, $scheme, $host, $port) = @_;
3719
if ( $scheme eq 'https' ) {
3720
eval "require IO::Socket::SSL"
3721
unless exists $INC{'IO/Socket/SSL.pm'};
3722
croak(qq/IO::Socket::SSL must be installed for https support\n/)
3723
unless $INC{'IO/Socket/SSL.pm'};
3725
elsif ( $scheme ne 'http' ) {
3726
croak(qq/Unsupported URL scheme '$scheme'\n/);
3729
$self->{fh} = 'IO::Socket::INET'->new(
3733
Type => SOCK_STREAM,
3734
Timeout => $self->{timeout}
3735
) or croak(qq/Could not connect to '$host:$port': $@/);
3737
binmode($self->{fh})
3738
or croak(qq/Could not binmode() socket: '$!'/);
3740
if ( $scheme eq 'https') {
3741
IO::Socket::SSL->start_SSL($self->{fh});
3742
ref($self->{fh}) eq 'IO::Socket::SSL'
3743
or die(qq/SSL connection failed for $host\n/);
3744
if ( $self->{fh}->can("verify_hostname") ) {
3745
$self->{fh}->verify_hostname( $host, $ssl_verify_args );
3748
my $fh = $self->{fh};
3749
_verify_hostname_of_cert($host, _peer_certificate($fh), $ssl_verify_args)
3750
or die(qq/SSL certificate not valid for $host\n/);
3754
$self->{host} = $host;
3755
$self->{port} = $port;
3761
@_ == 1 || croak(q/Usage: $handle->close()/);
3763
CORE::close($self->{fh})
3764
or croak(qq/Could not close socket: '$!'/);
3768
@_ == 2 || croak(q/Usage: $handle->write(buf)/);
3769
my ($self, $buf) = @_;
3771
my $len = length $buf;
3774
local $SIG{PIPE} = 'IGNORE';
3778
or croak(q/Timed out while waiting for socket to become ready for writing/);
3779
my $r = syswrite($self->{fh}, $buf, $len, $off);
3783
last unless $len > 0;
3785
elsif ($! == EPIPE) {
3786
croak(qq/Socket closed by remote server: $!/);
3788
elsif ($! != EINTR) {
3789
croak(qq/Could not write to socket: '$!'/);
3796
@_ == 2 || @_ == 3 || croak(q/Usage: $handle->read(len)/);
3797
my ($self, $len) = @_;
3800
my $got = length $self->{rbuf};
3803
my $take = ($got < $len) ? $got : $len;
3804
$buf = substr($self->{rbuf}, 0, $take, '');
3810
or croak(q/Timed out while waiting for socket to become ready for reading/);
3811
my $r = sysread($self->{fh}, $buf, $len, length $buf);
3816
elsif ($! != EINTR) {
3817
croak(qq/Could not read from socket: '$!'/);
3821
croak(q/Unexpected end of stream/);
3827
@_ == 1 || croak(q/Usage: $handle->readline()/);
3831
if ($self->{rbuf} =~ s/\A ([^\x0D\x0A]* \x0D?\x0A)//x) {
3835
or croak(q/Timed out while waiting for socket to become ready for reading/);
3836
my $r = sysread($self->{fh}, $self->{rbuf}, BUFSIZE, length $self->{rbuf});
3840
elsif ($! != EINTR) {
3841
croak(qq/Could not read from socket: '$!'/);
3844
croak(q/Unexpected end of stream while looking for line/);
3847
sub read_header_lines {
3848
@_ == 1 || @_ == 2 || croak(q/Usage: $handle->read_header_lines([headers])/);
3849
my ($self, $headers) = @_;
3855
my $line = $self->readline;
3857
if ($line =~ /\A ([^\x00-\x1F\x7F:]+) : [\x09\x20]* ([^\x0D\x0A]*)/x) {
3858
my ($field_name) = lc $1;
3859
$val = \($headers->{$field_name} = $2);
3861
elsif ($line =~ /\A [\x09\x20]+ ([^\x0D\x0A]*)/x) {
3863
or croak(q/Unexpected header continuation line/);
3864
next unless length $1;
3865
$$val .= ' ' if length $$val;
3868
elsif ($line =~ /\A \x0D?\x0A \z/x) {
3872
croak(q/Malformed header line: / . $Printable->($line));
3878
sub write_header_lines {
3879
(@_ == 2 && ref $_[1] eq 'HASH') || croak(q/Usage: $handle->write_header_lines(headers)/);
3880
my($self, $headers) = @_;
3883
while (my ($k, $v) = each %$headers) {
3884
my $field_name = lc $k;
3885
$field_name =~ /\A [\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]+ \z/x
3886
or croak(q/Invalid HTTP header field name: / . $Printable->($field_name));
3887
$field_name =~ s/\b(\w)/\u$1/g;
3888
$buf .= "$field_name: $v\x0D\x0A";
3891
return $self->write($buf);
3894
sub read_content_body {
3895
@_ == 3 || @_ == 4 || croak(q/Usage: $handle->read_content_body(callback, response, [read_length])/);
3896
my ($self, $cb, $response, $len) = @_;
3897
$len ||= $response->{headers}{'content-length'};
3899
croak("No content-length in the returned response, and this "
3900
. "UA doesn't implement chunking") unless defined $len;
3903
my $read = ($len > BUFSIZE) ? BUFSIZE : $len;
3904
$cb->($self->read($read), $response);
3911
sub write_content_body {
3912
@_ == 2 || croak(q/Usage: $handle->write_content_body(request)/);
3913
my ($self, $request) = @_;
3914
my ($len, $content_length) = (0, $request->{headers}{'content-length'});
3916
$len += $self->write($request->{content});
3918
$len == $content_length
3919
or croak(qq/Content-Length missmatch (got: $len expected: $content_length)/);
3924
sub read_response_header {
3925
@_ == 1 || croak(q/Usage: $handle->read_response_header()/);
3928
my $line = $self->readline;
3930
$line =~ /\A (HTTP\/(0*\d+\.0*\d+)) [\x09\x20]+ ([0-9]{3}) [\x09\x20]+ ([^\x0D\x0A]*) \x0D?\x0A/x
3931
or croak(q/Malformed Status-Line: / . $Printable->($line));
3933
my ($protocol, $version, $status, $reason) = ($1, $2, $3, $4);
3938
headers => $self->read_header_lines,
3939
protocol => $protocol,
3943
sub write_request_header {
3944
@_ == 4 || croak(q/Usage: $handle->write_request_header(method, request_uri, headers)/);
3945
my ($self, $method, $request_uri, $headers) = @_;
3947
return $self->write("$method $request_uri HTTP/1.1\x0D\x0A")
3948
+ $self->write_header_lines($headers);
3952
my ($self, $type, $timeout) = @_;
3953
$timeout = $self->{timeout}
3954
unless defined $timeout && $timeout >= 0;
3956
my $fd = fileno $self->{fh};
3957
defined $fd && $fd >= 0
3958
or croak(q/select(2): 'Bad file descriptor'/);
3961
my $pending = $timeout;
3964
vec(my $fdset = '', $fd, 1) = 1;
3967
$nfound = ($type eq 'read')
3968
? select($fdset, undef, undef, $pending)
3969
: select(undef, $fdset, undef, $pending) ;
3970
if ($nfound == -1) {
3972
or croak(qq/select(2): '$!'/);
3973
redo if !$timeout || ($pending = $timeout - (time - $initial)) > 0;
3983
@_ == 1 || @_ == 2 || croak(q/Usage: $handle->can_read([timeout])/);
3985
return $self->_do_timeout('read', @_)
3989
@_ == 1 || @_ == 2 || croak(q/Usage: $handle->can_write([timeout])/);
3991
return $self->_do_timeout('write', @_)
3680
package HTTP::Micro::Handle;
3683
use warnings FATAL => 'all';
3684
use English qw(-no_match_vars);
3687
use Errno qw(EINTR EPIPE);
3688
use IO::Socket qw(SOCK_STREAM);
3690
sub BUFSIZE () { 32768 }
3692
my $Printable = sub {
3697
s/([^\x20-\x7E])/sprintf('\\x%.2X', ord($1))/ge;
3702
my ($class, %args) = @_;
3706
max_line_size => 16384,
3711
my $ssl_verify_args = {
3712
check_cn => "when_only",
3713
wildcards_in_alt => "anywhere",
3714
wildcards_in_cn => "anywhere"
3718
@_ == 4 || croak(q/Usage: $handle->connect(scheme, host, port)/);
3719
my ($self, $scheme, $host, $port) = @_;
3721
if ( $scheme eq 'https' ) {
3722
eval "require IO::Socket::SSL"
3723
unless exists $INC{'IO/Socket/SSL.pm'};
3724
croak(qq/IO::Socket::SSL must be installed for https support\n/)
3725
unless $INC{'IO/Socket/SSL.pm'};
3727
elsif ( $scheme ne 'http' ) {
3728
croak(qq/Unsupported URL scheme '$scheme'\n/);
3731
$self->{fh} = IO::Socket::INET->new(
3735
Type => SOCK_STREAM,
3736
Timeout => $self->{timeout}
3737
) or croak(qq/Could not connect to '$host:$port': $@/);
3739
binmode($self->{fh})
3740
or croak(qq/Could not binmode() socket: '$!'/);
3742
if ( $scheme eq 'https') {
3743
IO::Socket::SSL->start_SSL($self->{fh});
3744
ref($self->{fh}) eq 'IO::Socket::SSL'
3745
or die(qq/SSL connection failed for $host\n/);
3746
if ( $self->{fh}->can("verify_hostname") ) {
3747
$self->{fh}->verify_hostname( $host, $ssl_verify_args );
3750
my $fh = $self->{fh};
3751
_verify_hostname_of_cert($host, _peer_certificate($fh), $ssl_verify_args)
3752
or die(qq/SSL certificate not valid for $host\n/);
3756
$self->{host} = $host;
3757
$self->{port} = $port;
3763
@_ == 1 || croak(q/Usage: $handle->close()/);
3765
CORE::close($self->{fh})
3766
or croak(qq/Could not close socket: '$!'/);
3770
@_ == 2 || croak(q/Usage: $handle->write(buf)/);
3771
my ($self, $buf) = @_;
3773
my $len = length $buf;
3776
local $SIG{PIPE} = 'IGNORE';
3780
or croak(q/Timed out while waiting for socket to become ready for writing/);
3781
my $r = syswrite($self->{fh}, $buf, $len, $off);
3785
last unless $len > 0;
3787
elsif ($! == EPIPE) {
3788
croak(qq/Socket closed by remote server: $!/);
3790
elsif ($! != EINTR) {
3791
croak(qq/Could not write to socket: '$!'/);
3798
@_ == 2 || @_ == 3 || croak(q/Usage: $handle->read(len)/);
3799
my ($self, $len) = @_;
3802
my $got = length $self->{rbuf};
3805
my $take = ($got < $len) ? $got : $len;
3806
$buf = substr($self->{rbuf}, 0, $take, '');
3812
or croak(q/Timed out while waiting for socket to become ready for reading/);
3813
my $r = sysread($self->{fh}, $buf, $len, length $buf);
3818
elsif ($! != EINTR) {
3819
croak(qq/Could not read from socket: '$!'/);
3823
croak(q/Unexpected end of stream/);
3829
@_ == 1 || croak(q/Usage: $handle->readline()/);
3833
if ($self->{rbuf} =~ s/\A ([^\x0D\x0A]* \x0D?\x0A)//x) {
3837
or croak(q/Timed out while waiting for socket to become ready for reading/);
3838
my $r = sysread($self->{fh}, $self->{rbuf}, BUFSIZE, length $self->{rbuf});
3842
elsif ($! != EINTR) {
3843
croak(qq/Could not read from socket: '$!'/);
3846
croak(q/Unexpected end of stream while looking for line/);
3849
sub read_header_lines {
3850
@_ == 1 || @_ == 2 || croak(q/Usage: $handle->read_header_lines([headers])/);
3851
my ($self, $headers) = @_;
3857
my $line = $self->readline;
3859
if ($line =~ /\A ([^\x00-\x1F\x7F:]+) : [\x09\x20]* ([^\x0D\x0A]*)/x) {
3860
my ($field_name) = lc $1;
3861
$val = \($headers->{$field_name} = $2);
3863
elsif ($line =~ /\A [\x09\x20]+ ([^\x0D\x0A]*)/x) {
3865
or croak(q/Unexpected header continuation line/);
3866
next unless length $1;
3867
$$val .= ' ' if length $$val;
3870
elsif ($line =~ /\A \x0D?\x0A \z/x) {
3874
croak(q/Malformed header line: / . $Printable->($line));
3880
sub write_header_lines {
3881
(@_ == 2 && ref $_[1] eq 'HASH') || croak(q/Usage: $handle->write_header_lines(headers)/);
3882
my($self, $headers) = @_;
3885
while (my ($k, $v) = each %$headers) {
3886
my $field_name = lc $k;
3887
$field_name =~ /\A [\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]+ \z/x
3888
or croak(q/Invalid HTTP header field name: / . $Printable->($field_name));
3889
$field_name =~ s/\b(\w)/\u$1/g;
3890
$buf .= "$field_name: $v\x0D\x0A";
3893
return $self->write($buf);
3896
sub read_content_body {
3897
@_ == 3 || @_ == 4 || croak(q/Usage: $handle->read_content_body(callback, response, [read_length])/);
3898
my ($self, $cb, $response, $len) = @_;
3899
$len ||= $response->{headers}{'content-length'};
3901
croak("No content-length in the returned response, and this "
3902
. "UA doesn't implement chunking") unless defined $len;
3905
my $read = ($len > BUFSIZE) ? BUFSIZE : $len;
3906
$cb->($self->read($read), $response);
3913
sub write_content_body {
3914
@_ == 2 || croak(q/Usage: $handle->write_content_body(request)/);
3915
my ($self, $request) = @_;
3916
my ($len, $content_length) = (0, $request->{headers}{'content-length'});
3918
$len += $self->write($request->{content});
3920
$len == $content_length
3921
or croak(qq/Content-Length missmatch (got: $len expected: $content_length)/);
3926
sub read_response_header {
3927
@_ == 1 || croak(q/Usage: $handle->read_response_header()/);
3930
my $line = $self->readline;
3932
$line =~ /\A (HTTP\/(0*\d+\.0*\d+)) [\x09\x20]+ ([0-9]{3}) [\x09\x20]+ ([^\x0D\x0A]*) \x0D?\x0A/x
3933
or croak(q/Malformed Status-Line: / . $Printable->($line));
3935
my ($protocol, $version, $status, $reason) = ($1, $2, $3, $4);
3940
headers => $self->read_header_lines,
3941
protocol => $protocol,
3945
sub write_request_header {
3946
@_ == 4 || croak(q/Usage: $handle->write_request_header(method, request_uri, headers)/);
3947
my ($self, $method, $request_uri, $headers) = @_;
3949
return $self->write("$method $request_uri HTTP/1.1\x0D\x0A")
3950
+ $self->write_header_lines($headers);
3954
my ($self, $type, $timeout) = @_;
3955
$timeout = $self->{timeout}
3956
unless defined $timeout && $timeout >= 0;
3958
my $fd = fileno $self->{fh};
3959
defined $fd && $fd >= 0
3960
or croak(q/select(2): 'Bad file descriptor'/);
3963
my $pending = $timeout;
3966
vec(my $fdset = '', $fd, 1) = 1;
3969
$nfound = ($type eq 'read')
3970
? select($fdset, undef, undef, $pending)
3971
: select(undef, $fdset, undef, $pending) ;
3972
if ($nfound == -1) {
3974
or croak(qq/select(2): '$!'/);
3975
redo if !$timeout || ($pending = $timeout - (time - $initial)) > 0;
3985
@_ == 1 || @_ == 2 || croak(q/Usage: $handle->can_read([timeout])/);
3987
return $self->_do_timeout('read', @_)
3991
@_ == 1 || @_ == 2 || croak(q/Usage: $handle->can_write([timeout])/);
3993
return $self->_do_timeout('write', @_)
3995
} # HTTP::Micro::Handle
3994
3997
my $prog = <<'EOP';