PageRenderTime 25ms CodeModel.GetById 54ms RepoModel.GetById 0ms app.codeStats 0ms

/Master/tlpkg/tlperl/lib/LWP/Protocol/http.pm

https://bitbucket.org/preining/tex-live
Perl | 501 lines | 402 code | 60 blank | 39 comment | 95 complexity | c29094750c18e3fb6dee85eb5b92c97e MD5 | raw file
  1. package LWP::Protocol::http;
  2. use strict;
  3. require HTTP::Response;
  4. require HTTP::Status;
  5. require Net::HTTP;
  6. use vars qw(@ISA @EXTRA_SOCK_OPTS);
  7. require LWP::Protocol;
  8. @ISA = qw(LWP::Protocol);
  9. my $CRLF = "\015\012";
  10. sub _new_socket
  11. {
  12. my($self, $host, $port, $timeout) = @_;
  13. my $conn_cache = $self->{ua}{conn_cache};
  14. if ($conn_cache) {
  15. if (my $sock = $conn_cache->withdraw($self->socket_type, "$host:$port")) {
  16. return $sock if $sock && !$sock->can_read(0);
  17. # if the socket is readable, then either the peer has closed the
  18. # connection or there are some garbage bytes on it. In either
  19. # case we abandon it.
  20. $sock->close;
  21. }
  22. }
  23. local($^W) = 0; # IO::Socket::INET can be noisy
  24. my $sock = $self->socket_class->new(PeerAddr => $host,
  25. PeerPort => $port,
  26. LocalAddr => $self->{ua}{local_address},
  27. Proto => 'tcp',
  28. Timeout => $timeout,
  29. KeepAlive => !!$conn_cache,
  30. SendTE => 1,
  31. $self->_extra_sock_opts($host, $port),
  32. );
  33. unless ($sock) {
  34. # IO::Socket::INET leaves additional error messages in $@
  35. my $status = "Can't connect to $host:$port";
  36. if ($@ =~ /\bconnect: (.*)/ ||
  37. $@ =~ /\b(Bad hostname)\b/ ||
  38. $@ =~ /\b(certificate verify failed)\b/ ||
  39. $@ =~ /\b(Crypt-SSLeay can't verify hostnames)\b/
  40. ) {
  41. $status .= " ($1)";
  42. }
  43. die "$status\n\n$@";
  44. }
  45. # perl 5.005's IO::Socket does not have the blocking method.
  46. eval { $sock->blocking(0); };
  47. $sock;
  48. }
  49. sub socket_type
  50. {
  51. return "http";
  52. }
  53. sub socket_class
  54. {
  55. my $self = shift;
  56. (ref($self) || $self) . "::Socket";
  57. }
  58. sub _extra_sock_opts # to be overridden by subclass
  59. {
  60. return @EXTRA_SOCK_OPTS;
  61. }
  62. sub _check_sock
  63. {
  64. #my($self, $req, $sock) = @_;
  65. }
  66. sub _get_sock_info
  67. {
  68. my($self, $res, $sock) = @_;
  69. if (defined(my $peerhost = $sock->peerhost)) {
  70. $res->header("Client-Peer" => "$peerhost:" . $sock->peerport);
  71. }
  72. }
  73. sub _fixup_header
  74. {
  75. my($self, $h, $url, $proxy) = @_;
  76. # Extract 'Host' header
  77. my $hhost = $url->authority;
  78. if ($hhost =~ s/^([^\@]*)\@//) { # get rid of potential "user:pass@"
  79. # add authorization header if we need them. HTTP URLs do
  80. # not really support specification of user and password, but
  81. # we allow it.
  82. if (defined($1) && not $h->header('Authorization')) {
  83. require URI::Escape;
  84. $h->authorization_basic(map URI::Escape::uri_unescape($_),
  85. split(":", $1, 2));
  86. }
  87. }
  88. $h->init_header('Host' => $hhost);
  89. if ($proxy) {
  90. # Check the proxy URI's userinfo() for proxy credentials
  91. # export http_proxy="http://proxyuser:proxypass@proxyhost:port"
  92. my $p_auth = $proxy->userinfo();
  93. if(defined $p_auth) {
  94. require URI::Escape;
  95. $h->proxy_authorization_basic(map URI::Escape::uri_unescape($_),
  96. split(":", $p_auth, 2))
  97. }
  98. }
  99. }
  100. sub hlist_remove {
  101. my($hlist, $k) = @_;
  102. $k = lc $k;
  103. for (my $i = @$hlist - 2; $i >= 0; $i -= 2) {
  104. next unless lc($hlist->[$i]) eq $k;
  105. splice(@$hlist, $i, 2);
  106. }
  107. }
  108. sub request
  109. {
  110. my($self, $request, $proxy, $arg, $size, $timeout) = @_;
  111. $size ||= 4096;
  112. # check method
  113. my $method = $request->method;
  114. unless ($method =~ /^[A-Za-z0-9_!\#\$%&\'*+\-.^\`|~]+$/) { # HTTP token
  115. return HTTP::Response->new( &HTTP::Status::RC_BAD_REQUEST,
  116. 'Library does not allow method ' .
  117. "$method for 'http:' URLs");
  118. }
  119. my $url = $request->uri;
  120. my($host, $port, $fullpath);
  121. # Check if we're proxy'ing
  122. if (defined $proxy) {
  123. # $proxy is an URL to an HTTP server which will proxy this request
  124. $host = $proxy->host;
  125. $port = $proxy->port;
  126. $fullpath = $method eq "CONNECT" ?
  127. ($url->host . ":" . $url->port) :
  128. $url->as_string;
  129. }
  130. else {
  131. $host = $url->host;
  132. $port = $url->port;
  133. $fullpath = $url->path_query;
  134. $fullpath = "/$fullpath" unless $fullpath =~ m,^/,;
  135. }
  136. # connect to remote site
  137. my $socket = $self->_new_socket($host, $port, $timeout);
  138. my $http_version = "";
  139. if (my $proto = $request->protocol) {
  140. if ($proto =~ /^(?:HTTP\/)?(1.\d+)$/) {
  141. $http_version = $1;
  142. $socket->http_version($http_version);
  143. $socket->send_te(0) if $http_version eq "1.0";
  144. }
  145. }
  146. $self->_check_sock($request, $socket);
  147. my @h;
  148. my $request_headers = $request->headers->clone;
  149. $self->_fixup_header($request_headers, $url, $proxy);
  150. $request_headers->scan(sub {
  151. my($k, $v) = @_;
  152. $k =~ s/^://;
  153. $v =~ s/\n/ /g;
  154. push(@h, $k, $v);
  155. });
  156. my $content_ref = $request->content_ref;
  157. $content_ref = $$content_ref if ref($$content_ref);
  158. my $chunked;
  159. my $has_content;
  160. if (ref($content_ref) eq 'CODE') {
  161. my $clen = $request_headers->header('Content-Length');
  162. $has_content++ if $clen;
  163. unless (defined $clen) {
  164. push(@h, "Transfer-Encoding" => "chunked");
  165. $has_content++;
  166. $chunked++;
  167. }
  168. }
  169. else {
  170. # Set (or override) Content-Length header
  171. my $clen = $request_headers->header('Content-Length');
  172. if (defined($$content_ref) && length($$content_ref)) {
  173. $has_content = length($$content_ref);
  174. if (!defined($clen) || $clen ne $has_content) {
  175. if (defined $clen) {
  176. warn "Content-Length header value was wrong, fixed";
  177. hlist_remove(\@h, 'Content-Length');
  178. }
  179. push(@h, 'Content-Length' => $has_content);
  180. }
  181. }
  182. elsif ($clen) {
  183. warn "Content-Length set when there is no content, fixed";
  184. hlist_remove(\@h, 'Content-Length');
  185. }
  186. }
  187. my $write_wait = 0;
  188. $write_wait = 2
  189. if ($request_headers->header("Expect") || "") =~ /100-continue/;
  190. my $req_buf = $socket->format_request($method, $fullpath, @h);
  191. #print "------\n$req_buf\n------\n";
  192. if (!$has_content || $write_wait || $has_content > 8*1024) {
  193. WRITE:
  194. {
  195. # Since this just writes out the header block it should almost
  196. # always succeed to send the whole buffer in a single write call.
  197. my $n = $socket->syswrite($req_buf, length($req_buf));
  198. unless (defined $n) {
  199. redo WRITE if $!{EINTR};
  200. if ($!{EAGAIN}) {
  201. select(undef, undef, undef, 0.1);
  202. redo WRITE;
  203. }
  204. die "write failed: $!";
  205. }
  206. if ($n) {
  207. substr($req_buf, 0, $n, "");
  208. }
  209. else {
  210. select(undef, undef, undef, 0.5);
  211. }
  212. redo WRITE if length $req_buf;
  213. }
  214. }
  215. my($code, $mess, @junk);
  216. my $drop_connection;
  217. if ($has_content) {
  218. my $eof;
  219. my $wbuf;
  220. my $woffset = 0;
  221. INITIAL_READ:
  222. if ($write_wait) {
  223. # skip filling $wbuf when waiting for 100-continue
  224. # because if the response is a redirect or auth required
  225. # the request will be cloned and there is no way
  226. # to reset the input stream
  227. # return here via the label after the 100-continue is read
  228. }
  229. elsif (ref($content_ref) eq 'CODE') {
  230. my $buf = &$content_ref();
  231. $buf = "" unless defined($buf);
  232. $buf = sprintf "%x%s%s%s", length($buf), $CRLF, $buf, $CRLF
  233. if $chunked;
  234. substr($buf, 0, 0) = $req_buf if $req_buf;
  235. $wbuf = \$buf;
  236. }
  237. else {
  238. if ($req_buf) {
  239. my $buf = $req_buf . $$content_ref;
  240. $wbuf = \$buf;
  241. }
  242. else {
  243. $wbuf = $content_ref;
  244. }
  245. $eof = 1;
  246. }
  247. my $fbits = '';
  248. vec($fbits, fileno($socket), 1) = 1;
  249. WRITE:
  250. while ($write_wait || $woffset < length($$wbuf)) {
  251. my $sel_timeout = $timeout;
  252. if ($write_wait) {
  253. $sel_timeout = $write_wait if $write_wait < $sel_timeout;
  254. }
  255. my $time_before;
  256. $time_before = time if $sel_timeout;
  257. my $rbits = $fbits;
  258. my $wbits = $write_wait ? undef : $fbits;
  259. my $sel_timeout_before = $sel_timeout;
  260. SELECT:
  261. {
  262. my $nfound = select($rbits, $wbits, undef, $sel_timeout);
  263. if ($nfound < 0) {
  264. if ($!{EINTR} || $!{EAGAIN}) {
  265. if ($time_before) {
  266. $sel_timeout = $sel_timeout_before - (time - $time_before);
  267. $sel_timeout = 0 if $sel_timeout < 0;
  268. }
  269. redo SELECT;
  270. }
  271. die "select failed: $!";
  272. }
  273. }
  274. if ($write_wait) {
  275. $write_wait -= time - $time_before;
  276. $write_wait = 0 if $write_wait < 0;
  277. }
  278. if (defined($rbits) && $rbits =~ /[^\0]/) {
  279. # readable
  280. my $buf = $socket->_rbuf;
  281. my $n = $socket->sysread($buf, 1024, length($buf));
  282. unless (defined $n) {
  283. die "read failed: $!" unless $!{EINTR} || $!{EAGAIN};
  284. # if we get here the rest of the block will do nothing
  285. # and we will retry the read on the next round
  286. }
  287. elsif ($n == 0) {
  288. # the server closed the connection before we finished
  289. # writing all the request content. No need to write any more.
  290. $drop_connection++;
  291. last WRITE;
  292. }
  293. $socket->_rbuf($buf);
  294. if (!$code && $buf =~ /\015?\012\015?\012/) {
  295. # a whole response header is present, so we can read it without blocking
  296. ($code, $mess, @h) = $socket->read_response_headers(laxed => 1,
  297. junk_out => \@junk,
  298. );
  299. if ($code eq "100") {
  300. $write_wait = 0;
  301. undef($code);
  302. goto INITIAL_READ;
  303. }
  304. else {
  305. $drop_connection++;
  306. last WRITE;
  307. # XXX should perhaps try to abort write in a nice way too
  308. }
  309. }
  310. }
  311. if (defined($wbits) && $wbits =~ /[^\0]/) {
  312. my $n = $socket->syswrite($$wbuf, length($$wbuf), $woffset);
  313. unless (defined $n) {
  314. die "write failed: $!" unless $!{EINTR} || $!{EAGAIN};
  315. $n = 0; # will retry write on the next round
  316. }
  317. elsif ($n == 0) {
  318. die "write failed: no bytes written";
  319. }
  320. $woffset += $n;
  321. if (!$eof && $woffset >= length($$wbuf)) {
  322. # need to refill buffer from $content_ref code
  323. my $buf = &$content_ref();
  324. $buf = "" unless defined($buf);
  325. $eof++ unless length($buf);
  326. $buf = sprintf "%x%s%s%s", length($buf), $CRLF, $buf, $CRLF
  327. if $chunked;
  328. $wbuf = \$buf;
  329. $woffset = 0;
  330. }
  331. }
  332. } # WRITE
  333. }
  334. ($code, $mess, @h) = $socket->read_response_headers(laxed => 1, junk_out => \@junk)
  335. unless $code;
  336. ($code, $mess, @h) = $socket->read_response_headers(laxed => 1, junk_out => \@junk)
  337. if $code eq "100";
  338. my $response = HTTP::Response->new($code, $mess);
  339. my $peer_http_version = $socket->peer_http_version;
  340. $response->protocol("HTTP/$peer_http_version");
  341. {
  342. local $HTTP::Headers::TRANSLATE_UNDERSCORE;
  343. $response->push_header(@h);
  344. }
  345. $response->push_header("Client-Junk" => \@junk) if @junk;
  346. $response->request($request);
  347. $self->_get_sock_info($response, $socket);
  348. if ($method eq "CONNECT") {
  349. $response->{client_socket} = $socket; # so it can be picked up
  350. return $response;
  351. }
  352. if (my @te = $response->remove_header('Transfer-Encoding')) {
  353. $response->push_header('Client-Transfer-Encoding', \@te);
  354. }
  355. $response->push_header('Client-Response-Num', scalar $socket->increment_response_count);
  356. my $complete;
  357. $response = $self->collect($arg, $response, sub {
  358. my $buf = ""; #prevent use of uninitialized value in SSLeay.xs
  359. my $n;
  360. READ:
  361. {
  362. $n = $socket->read_entity_body($buf, $size);
  363. unless (defined $n) {
  364. redo READ if $!{EINTR} || $!{EAGAIN};
  365. die "read failed: $!";
  366. }
  367. redo READ if $n == -1;
  368. }
  369. $complete++ if !$n;
  370. return \$buf;
  371. } );
  372. $drop_connection++ unless $complete;
  373. @h = $socket->get_trailers;
  374. if (@h) {
  375. local $HTTP::Headers::TRANSLATE_UNDERSCORE;
  376. $response->push_header(@h);
  377. }
  378. # keep-alive support
  379. unless ($drop_connection) {
  380. if (my $conn_cache = $self->{ua}{conn_cache}) {
  381. my %connection = map { (lc($_) => 1) }
  382. split(/\s*,\s*/, ($response->header("Connection") || ""));
  383. if (($peer_http_version eq "1.1" && !$connection{close}) ||
  384. $connection{"keep-alive"})
  385. {
  386. $conn_cache->deposit($self->socket_type, "$host:$port", $socket);
  387. }
  388. }
  389. }
  390. $response;
  391. }
  392. #-----------------------------------------------------------
  393. package LWP::Protocol::http::SocketMethods;
  394. sub sysread {
  395. my $self = shift;
  396. if (my $timeout = ${*$self}{io_socket_timeout}) {
  397. die "read timeout" unless $self->can_read($timeout);
  398. }
  399. else {
  400. # since we have made the socket non-blocking we
  401. # use select to wait for some data to arrive
  402. $self->can_read(undef) || die "Assert";
  403. }
  404. sysread($self, $_[0], $_[1], $_[2] || 0);
  405. }
  406. sub can_read {
  407. my($self, $timeout) = @_;
  408. my $fbits = '';
  409. vec($fbits, fileno($self), 1) = 1;
  410. SELECT:
  411. {
  412. my $before;
  413. $before = time if $timeout;
  414. my $nfound = select($fbits, undef, undef, $timeout);
  415. if ($nfound < 0) {
  416. if ($!{EINTR} || $!{EAGAIN}) {
  417. # don't really think EAGAIN can happen here
  418. if ($timeout) {
  419. $timeout -= time - $before;
  420. $timeout = 0 if $timeout < 0;
  421. }
  422. redo SELECT;
  423. }
  424. die "select failed: $!";
  425. }
  426. return $nfound > 0;
  427. }
  428. }
  429. sub ping {
  430. my $self = shift;
  431. !$self->can_read(0);
  432. }
  433. sub increment_response_count {
  434. my $self = shift;
  435. return ++${*$self}{'myhttp_response_count'};
  436. }
  437. #-----------------------------------------------------------
  438. package LWP::Protocol::http::Socket;
  439. use vars qw(@ISA);
  440. @ISA = qw(LWP::Protocol::http::SocketMethods Net::HTTP);
  441. 1;