Build.PL100664001750001750 310612560625033 15162 0ustar00tokuhiromtokuhirom000000000000Furl-3.08# ========================================================================= # THIS FILE IS AUTOMATICALLY GENERATED BY MINILLA. # DO NOT EDIT DIRECTLY. # ========================================================================= use 5.008_001; use strict; use warnings; use utf8; use Module::Build; use File::Basename; use File::Spec; my %args = ( license => 'perl', dynamic_config => 0, configure_requires => { 'Module::Build' => 0.38, }, name => 'Furl', module_name => 'Furl', allow_pureperl => 0, script_files => [glob('script/*'), glob('bin/*')], c_source => [qw()], PL_files => {}, test_files => ((-d '.git' || $ENV{RELEASE_TESTING}) && -d 'xt') ? 't/ xt/' : 't/', recursive_test_files => 1, ); if (-d 'share') { $args{share_dir} = 'share'; } my $builder = Module::Build->subclass( class => 'MyBuilder', code => q{ sub ACTION_distmeta { die "Do not run distmeta. Install Minilla and `minil install` instead.\n"; } sub ACTION_installdeps { die "Do not run installdeps. Run `cpanm --installdeps .` instead.\n"; } } )->new(%args); $builder->create_build_script(); use File::Copy; print "cp META.json MYMETA.json\n"; copy("META.json","MYMETA.json") or die "Copy failed(META.json): $!"; if (-f 'META.yml') { print "cp META.yml MYMETA.yml\n"; copy("META.yml","MYMETA.yml") or die "Copy failed(META.yml): $!"; } else { print "There is no META.yml... You may install this module from the repository...\n"; } Changes100664001750001750 2637512560625033 15216 0ustar00tokuhiromtokuhirom000000000000Furl-3.08Revision history for Perl module Furl 3.08 2015-08-06T09:32:19Z - Handle cookies while redirection. (tokuhirom) - delete method accept message body (kimoto) 3.07 2015-04-21T03:42:39Z - Depends on latest Test::TCP https://github.com/tokuhirom/Test-TCP/issues/31#issuecomment-94378132 3.06 2015-02-09T23:05:09Z commit 8a7786905c101eeab9db1d7baa8c4ec2076f9514 Author: Jari Salmela Date: Fri Feb 6 08:36:55 2015 +0200 Update HTTP.pm fix for keep-alive as zmmail proposed. "In line 526 of Furl/HTTP.pm, FURL checks the HTTP response headers it gets from the server. It will read the C onnection from the response header there, and compare the header value with the string keep-alive. The problem is t hat this does not take into account a different case of the response header. Some HTTP server returns a header valu e of Keep-Alive (mind the caps), so FURL does not recognize it properly. I think the following change to Furl/HTTP.pm is more robust. if ($connection_header eq 'keep-alive') { if (lc($connection_header) eq 'keep-alive') {" commit 91ebdf86693c5bfbda497df167977813e2ad75aa Author: Kazuho Oku Date: Wed Dec 24 16:26:07 2014 +0900 fix incorrect regex used for testing the response line (amends #80) commit 65d0bc170a6344ebd24e0726a44260f3771fda0b Author: HIROSE Masaaki Date: Wed Dec 24 13:49:43 2014 +0900 Check only status code when connect SSL over proxy 3.05 2014-09-24T03:47:02Z - Validate content-length before processing. (Implemented by tokuhirom) (Reviewed by kazuho++) 3.04 2014-09-22T10:08:04Z - remove trailing whitespace of Authorization header (kazeburo++) 3.03 2014-07-09T23:33:51Z commit 8da0f43f2a6b3f04806288ce63a7bdc4df7f9a46 Author: Toshio Ito Date: Sat Jun 7 10:34:13 2014 +0900 t/100_low/07_timeout.t: iteratively increase content size instead of guessing the size of the se c.f: gh #71, gh #56 3.02 2014-03-18T20:52:07Z - Added new experimental cookie_jar support. (tokuhirom) 3.01 2014-02-13T06:19:47Z - Fixed documentation bug(Reported by Yappo++) 3.00 2013-11-13T09:39:38Z - implement inactivity_timeout (for read / write), requested by autarch++ (kazuho) - Implemented a new callback called `get_address`. That fixes the two shortcomings of the existing inet_aton callback listed below. * cannot override the port number * cannot support protocols other than IPv4 (e.g. IPv6, unix socket, ...) (kazuho) 2.19 2013-08-26T02:10:09Z - Testing fix for Starlet >= 0.20. force response HTTP/1.0. Starlet >= 0.20 support HTTP/1.1 (kazeburo) 2.18 2013-08-08T07:11:30Z - Furl::Response::decoded_content returns undef if user specifies 'Accept-Encoding' for data compression. Because content is already inflated, so HTTP::Message::decoded_content failed and return undef. (syohex) 2.17 2013-07-01T03:11:49Z - Fix Furl::Request#as_string the request contains ARRAY or HASH. (tokuhirom) 2.16 2013-05-22T07:48:21Z - Fix timeout problem(#56) on recent Linux(3.8 or later) (syohex) - Added Furl::Request#as_string (tokuhirom) 2.15 2013-05-10T08:40:10Z - Added Furl::Response#as_string. (tokuhirom) 2.14 2013-04-19T02:11:43Z - Fixed testing issue 2.13 2013-04-17T07:52:37Z - Tiny test fix. (tokuhirom) 2.12 2013-04-15T08:38:49Z - Clean up dependencies. I confused about 'recommends' and 'suggests'. Do not use 'recommends' for optional things. (tokuhirom) 2.11 2013-04-04T03:02:13Z - [EXPERIMENTAL] Added Furl::Response#encoding (tokuhirom) 2.10 2013-03-18T16:08:02 [INCOMPATIBLE CHANGES] - 'keep_request' parameter introduced in 2.08 was *removed*. - Furl::Response#request is always useful if you are using highlevel API. - Added Furl::Response#captured_req_content and Furl::Response#captured_req_headers 2.09 2013-03-07T06:59:44 - switch to cpanfile(no feature changes) (tokuhirom) 2.08 2013-03-06T18:42:22 - Added Furl::Request (ikasam_a) 2.07 2013-03-02T18:52:33 - added Furl::Response#to_psgi (tokuhirom) 2.06 2013-02-14T19:01:27 - Added Furl::Response#as_hashref 2.05 2013-02-12T15:00:31 [EXPERIMENTAL FEATURE] - Add "X-Internal-Respponse: 1" header for Internal response. It's compatible with LWP. (tokuhirom) - Reverted Client-Warning header introduced in 2.04 2.04 2013-02-12T14:28:53 [EXPERIMENTAL FEATURE] - Add "Client-Warning: Internal Response" header for Internal response. It's compatible with LWP. (tokuhirom) 2.03 2013-02-09T18:17:13 - Support URL based authorization. Both Proxy-Authorization and Basic Authorization. 2.02 2013-02-06T17:25:11 - Added Furl::Response#decoded_content (xaicron++) - Added Furl::Headers#clone (tokuhirom) 2.01 2013-01-23T19:17:47 - pass SSL_verifycn_name on connecting ssl over proxy. IO::Socket::SSL detects host name from PeerHost, but it can't when user is using proxy. (aska++) - SSL_verifycn_scheme is not required if skipping verification if skip verification, does not requires SSL_verifycn_scheme (kazeburo++) 2.00 2013-01-23T15:46:46 *** VERY IMPORTANT INCOMPATIBLE CHANGE *** - Furl verify SSL certs by default. If it's fail, furl returns error response. (tokuhirom) *** VERY IMPORTANT INCOMPATIBLE CHANGE *** 1.04 2013-01-22 - use `ssl_opts` option in SSL over http proxy (aska++) 1.03 2013-01-12 - fixed testing issue on perl 5.18 hash randomization (gfx) 1.02 2013-01-07 - Use Mozilla::CA if SSL_ca_file and SSL_ca_path is not set. This behavior respects LWP::Protocol::https. (tokuhirom) 1.01 2013-01-03 - added `ssl_opts` option to configuring IO::Socket::SSL (gfx) 1.00 2012-10-19 - Bump up version 0.42 2012-10-15 [INCOMPATIBLE CHANGE] - Furl::HTTP is no longer reading Furl.pm. This change may breaks your code. If you are using Furl class without loading Furl::HTTP, it will fail after this release. 0.41 2012-09-25 [BUG FIX] - Furl#agent does not works in past version. (Syohei YOSHIDA) 0.40 2012-06-04 - fixed meta data(Slaven++) https://github.com/tokuhirom/Furl/issues/35 0.39 2012-05-29 - unexpected eof in reading chunked body. It makes busy loop. (kazeburo++) 0.38 2011-09-05 - added ->agent method(bayashi++) 0.37 2011-08-24 - fixed SSL closing issue (reported by sugyan++, resolved by kazuho++, and implemented by gfx++) 0.36 2011-08-23 - win32 ssl proxy fix(mattn++) 0.35 2011-08-11 - Compensate for slash of path-query.(xaicron) 'http://example.com?foo=bar' → 'http://example.com/?foo=bar' 0.34 2011-07-15 - accept the domain using '_' charcter(xaicron) 0.33 2011-07-13 - support url doesn't have trailing slash like 'http://example.com?gfx=isogashi' (xaicron++) 0.32 2011-05-30 - remove duplicated Host header on high level API(xaicron) 0.31 2011-02-25 - CarpLevel++(xaicron) 0.30 2011-02-25 - allow '0000000' as end of chunked response. 0.29 2011-02-23 - move live tests to xt/. 0.28 2011-02-22 - fixed bug on proxy with redirect(mattn) 0.27 2011-02-20 - Add support for 307 (it was not handled as a redirect), with tests for all redirects. (307 is implemented the same as 301, preserving the original requesting method.) (audreyt++) 0.26 2011-02-17 - tiny pod fix(tokuhirom) 0.25 2011-02-16 - move fucking ssl test to xt/. 0.24 2011-02-08 - workaround for windows (mattn++, xaicron++) 0.23 2011-01-30 - properly implement Furl::env_proxy as a delegate to Furl::HTTP::env_proxy (as was already documented) (lestrrat) 0.22 2011-01-25 - Remove default ports from the Host header 0.21 2011-01-11 - use keep-alive on redirection, do not activate the "write_code" or the "write_func" feature when redirection(kazuho) - silently try to resend a request only when the server returned no respnose at all(kazuho) 0.20 2010-12-20 - add internal error response message to status message (tokuhirom) 0.19 2010-12-20 - fixed documentation bug(tokuhirom) - errorneously returned 500 error when closing of the socket was used to indicate eof (i.e. no Content-Encoding or Content-Length) (Kazuho Oku) 0.18 2010-12-06 - fixed testing issue(reported by many people) 0.17 2010-12-03 - only send the connection header with the highest precedence (Furl::request => Furl::new) (Kazuho Oku) - close the connection when furl requested as such, even if the server sent "connection: keep-alive" (Kazuho Oku) - support keep-alive for $furl->request(method => 'HEAD', headers => [ qw(connection keep-alive) ]) (Kazuho Oku) - always send the connection header (support for automatic keep-alive with HTTP/1.0 servers) (Kazuho Oku) 0.16 2010-12-01 - support for status codes wo. content(kazuho oku) 0.15 2010-11-28 - doc enhancements(tokuhirom) 0.14 2010-11-22 - changed the semantics of the "timeout" parameter from per-IO timeout to request timeout(Kazuho Oku) - optional support for name resolution timeouts using Net::DNS::Lite(Kazuho Oku) - make blocking operations cancellable (through the "stop_if" callback)(Kazuho Oku) 0.13 2010-11-15 - do not die when $content is empty string. 0.12 2010-11-10 - fixed testing issue. 0.11 2010-11-04 - fixed testing issue gh#6 (reported by ichesnokov) 0.10 2010-11-02 - change request() to accept HTTP::Request, and remove request_with_http_request(lestrrat) - Furl::ConnPool.pm was renamed to Furl::ConnectionCache.pm(tokuhirom) 0.09 2010-11-01 - fixed packaging. 0.08 2010-11-01 - rewrote connection pooling strategy(tokuhirom) (suggested by kazuho++) - updated docs(tokuhirom) - support relative url in redirection #5(tokuhirom) 0.07 2010-11-01 - Do not use reference_from, it makes installing issue(reported by y). http://github.com/tokuhirom/p5-Furl/issues#issue/4 0.06 2010-10-31 - now Perl 5.8.1 or later is required.(tokuhirom) - High level interface is now available(tokuhirom) - Keep alive on HTTP/1.0(kazuho, gfx) - Retry requests if the connection is closed while in keep-alive(gfx) 0.05 2010-10-30 - use HTTP::Parser::XS - optimization - users can be set your own special headers. - fixed Deep recursion when redirect over max_redirects. - now, header_get is not public api. 0.04 2010-10-26 - fixed retval handling around Compress::Raw::Zlib(gfx) - Change chuked tests not to use Starman(gfx) - use binmode() for fucking win32(gfx) 0.03 2010-10-25 - support no_proxy - fixed keep-alive issue - fix ppport issue for perl < 5.12 - THX fix - doc fix - micro optimization - a lot of tweaks [0.02 not released] - doc enhancements - micro optimization - more test cases 0.01 2010-10-24 - original version LICENSE100664001750001750 4363412560625033 14725 0ustar00tokuhiromtokuhirom000000000000Furl-3.08This software is copyright (c) 2013 by unknown. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. Terms of the Perl programming language system itself a) the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version, or b) the "Artistic License" --- The GNU General Public License, Version 1, February 1989 --- This software is Copyright (c) 2013 by unknown. This is free software, licensed under: The GNU General Public License, Version 1, February 1989 GNU GENERAL PUBLIC LICENSE Version 1, February 1989 Copyright (C) 1989 Free Software Foundation, Inc. 51 Franklin St, Suite 500, Boston, MA 02110-1335 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The license agreements of most software companies try to keep users at the mercy of those companies. By contrast, our General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. The General Public License applies to the Free Software Foundation's software and to any other program whose authors commit to using it. You can use it for your programs, too. When we speak of free software, we are referring to freedom, not price. Specifically, the General Public License is designed to make sure that you have the freedom to give away or sell copies of free software, that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of a such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must tell them their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any work containing the Program or a portion of it, either verbatim or with modifications. Each licensee is addressed as "you". 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this General Public License and to the absence of any warranty; and give any other recipients of the Program a copy of this General Public License along with the Program. You may charge a fee for the physical act of transferring a copy. 2. You may modify your copy or copies of the Program or any portion of it, and copy and distribute such modifications under the terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains the Program or any part thereof, either with or without modifications, to be licensed at no charge to all third parties under the terms of this General Public License (except that you may choose to grant warranty protection to some or all third parties, at your option). c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the simplest and most usual way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this General Public License. d) You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. Mere aggregation of another independent work with the Program (or its derivative) on a volume of a storage or distribution medium does not bring the other work under the scope of these terms. 3. You may copy and distribute the Program (or a portion or derivative of it, under Paragraph 2) in object code or executable form under the terms of Paragraphs 1 and 2 above provided that you also do one of the following: a) accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) accompany it with a written offer, valid for at least three years, to give any third party free (except for a nominal charge for the cost of distribution) a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) accompany it with the information you received as to where the corresponding source code may be obtained. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form alone.) Source code for a work means the preferred form of the work for making modifications to it. For an executable file, complete source code means all the source code for all modules it contains; but, as a special exception, it need not include source code for modules which are standard libraries that accompany the operating system on which the executable file runs, or for standard header files or definitions files that accompany that operating system. 4. You may not copy, modify, sublicense, distribute or transfer the Program except as expressly provided under this General Public License. Any attempt otherwise to copy, modify, sublicense, distribute or transfer the Program is void, and will automatically terminate your rights to use the Program under this License. However, parties who have received copies, or rights to use copies, from you under this General Public License will not have their licenses terminated so long as such parties remain in full compliance. 5. By copying, distributing or modifying the Program (or any work based on the Program) you indicate your acceptance of this license to do so, and all its terms and conditions. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. 7. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of the license which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the license, you may choose any version ever published by the Free Software Foundation. 8. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS Appendix: How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to humanity, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) 19yy This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston MA 02110-1301 USA Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) 19xx name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (a program to direct compilers to make passes at assemblers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice That's all there is to it! --- The Artistic License 1.0 --- This software is Copyright (c) 2013 by unknown. This is free software, licensed under: The Artistic License 1.0 The Artistic License Preamble The intent of this document is to state the conditions under which a Package may be copied, such that the Copyright Holder maintains some semblance of artistic control over the development of the package, while giving the users of the package the right to use and distribute the Package in a more-or-less customary fashion, plus the right to make reasonable modifications. Definitions: - "Package" refers to the collection of files distributed by the Copyright Holder, and derivatives of that collection of files created through textual modification. - "Standard Version" refers to such a Package if it has not been modified, or has been modified in accordance with the wishes of the Copyright Holder. - "Copyright Holder" is whoever is named in the copyright or copyrights for the package. - "You" is you, if you're thinking about copying or distributing this Package. - "Reasonable copying fee" is whatever you can justify on the basis of media cost, duplication charges, time of people involved, and so on. (You will not be required to justify it to the Copyright Holder, but only to the computing community at large as a market that must bear the fee.) - "Freely Available" means that no fee is charged for the item itself, though there may be fees involved in handling the item. It also means that recipients of the item may redistribute it under the same conditions they received it. 1. You may make and give away verbatim copies of the source form of the Standard Version of this Package without restriction, provided that you duplicate all of the original copyright notices and associated disclaimers. 2. You may apply bug fixes, portability fixes and other modifications derived from the Public Domain or from the Copyright Holder. A Package modified in such a way shall still be considered the Standard Version. 3. You may otherwise modify your copy of this Package in any way, provided that you insert a prominent notice in each changed file stating how and when you changed that file, and provided that you do at least ONE of the following: a) place your modifications in the Public Domain or otherwise make them Freely Available, such as by posting said modifications to Usenet or an equivalent medium, or placing the modifications on a major archive site such as ftp.uu.net, or by allowing the Copyright Holder to include your modifications in the Standard Version of the Package. b) use the modified Package only within your corporation or organization. c) rename any non-standard executables so the names do not conflict with standard executables, which must also be provided, and provide a separate manual page for each non-standard executable that clearly documents how it differs from the Standard Version. d) make other distribution arrangements with the Copyright Holder. 4. You may distribute the programs of this Package in object code or executable form, provided that you do at least ONE of the following: a) distribute a Standard Version of the executables and library files, together with instructions (in the manual page or equivalent) on where to get the Standard Version. b) accompany the distribution with the machine-readable source of the Package with your modifications. c) accompany any non-standard executables with their corresponding Standard Version executables, giving the non-standard executables non-standard names, and clearly documenting the differences in manual pages (or equivalent), together with instructions on where to get the Standard Version. d) make other distribution arrangements with the Copyright Holder. 5. You may charge a reasonable copying fee for any distribution of this Package. You may charge any fee you choose for support of this Package. You may not charge a fee for this Package itself. However, you may distribute this Package in aggregate with other (possibly commercial) programs as part of a larger (possibly commercial) software distribution provided that you do not advertise this Package as a product of your own. 6. The scripts and library files supplied as input to or produced as output from the programs of this Package do not automatically fall under the copyright of this Package, but belong to whomever generated them, and may be sold commercially, and may be aggregated with this Package. 7. C or perl subroutines supplied by you and linked into this Package shall not be considered part of this Package. 8. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. 9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. The End META.json100664001750001750 1115512560625033 15332 0ustar00tokuhiromtokuhirom000000000000Furl-3.08{ "abstract" : "Lightning-fast URL fetcher", "author" : [ "Tokuhiro Matsuno " ], "dynamic_config" : 0, "generated_by" : "Minilla/v2.4.1", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Furl", "no_index" : { "directory" : [ "t", "xt", "inc", "share", "eg", "examples", "author", "builder" ] }, "prereqs" : { "configure" : { "requires" : { "Module::Build" : "0.38" } }, "develop" : { "requires" : { "Test::CPAN::Meta" : "0", "Test::MinimumVersion::Fast" : "0.04", "Test::PAUSE::Permissions" : "0.04", "Test::Pod" : "1.41", "Test::Spellunker" : "v0.2.7" }, "suggests" : { "Child" : "0", "Getopt::Long" : "0", "HTTP::Lite" : "0", "IO::Callback" : "0", "LWP::UserAgent" : "0", "Net::DNS::Lite" : "0", "Net::IDN::Encode" : "0", "Plack::Loader" : "0", "Starman" : "0", "Test::LeakTrace" : "0", "Test::More" : "0", "Test::Requires" : "0", "Test::TCP" : "0", "URI" : "0", "WWW::Curl::Easy" : "4.14", "autodie" : "0", "parent" : "0" } }, "runtime" : { "recommends" : { "Compress::Raw::Zlib" : "0", "HTTP::CookieJar" : "0", "IO::Socket::SSL" : "0", "Net::IDN::Encode" : "0" }, "requires" : { "Class::Accessor::Lite" : "0", "Encode" : "0", "HTTP::Parser::XS" : "0.11", "MIME::Base64" : "0", "Mozilla::CA" : "0", "Scalar::Util" : "0", "Socket" : "0", "Time::HiRes" : "0", "perl" : "5.008001" }, "suggests" : { "HTTP::Headers" : "0", "HTTP::Request" : "0", "HTTP::Response" : "0" } }, "test" : { "requires" : { "File::Temp" : "0", "Test::More" : "0.96", "Test::Requires" : "0", "Test::TCP" : "2.11" }, "suggests" : { "HTTP::CookieJar" : "0", "HTTP::Proxy" : "0", "HTTP::Server::PSGI" : "0", "Plack" : "0", "Plack::Loader" : "0", "Plack::Request" : "0", "Starlet::Server" : "0", "Test::Fake::HTTPD" : "0", "Test::SharedFork" : "0", "Test::Valgrind" : "0", "URI" : "0", "parent" : "0" } } }, "provides" : { "Furl" : { "file" : "lib/Furl.pm", "version" : "3.08" }, "Furl::ConnectionCache" : { "file" : "lib/Furl/ConnectionCache.pm" }, "Furl::HTTP" : { "file" : "lib/Furl/HTTP.pm", "version" : "3.08" }, "Furl::Headers" : { "file" : "lib/Furl/Headers.pm" }, "Furl::Request" : { "file" : "lib/Furl/Request.pm" }, "Furl::Response" : { "file" : "lib/Furl/Response.pm" }, "Furl::ZlibStream" : { "file" : "lib/Furl/ZlibStream.pm" } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/tokuhirom/Furl/issues" }, "homepage" : "https://github.com/tokuhirom/Furl", "repository" : { "url" : "git://github.com/tokuhirom/Furl.git", "web" : "https://github.com/tokuhirom/Furl" } }, "version" : "3.08", "x_contributors" : [ "Keiji, Yoshimi ", "Fuji, Goro ", "lestrrat ", "Audrey Tang ", "mattn ", "Fuji Goro ", "Fuji, Goro ", "s-aska ", "ikasam_a ", "xaicron ", "Syohei YOSHIDA ", "Neil Bowers ", "Toshio Ito ", "bayashi ", "Masahiro Nagano ", "HIROSE Masaaki ", "Kazuho Oku ", "Jari Salmela ", "tarao ", "kimoto " ] } README.md100664001750001750 2053612560625033 15173 0ustar00tokuhiromtokuhirom000000000000Furl-3.08# NAME Furl - Lightning-fast URL fetcher # SYNOPSIS use Furl; my $furl = Furl->new( agent => 'MyGreatUA/2.0', timeout => 10, ); my $res = $furl->get('http://example.com/'); die $res->status_line unless $res->is_success; print $res->content; my $res = $furl->post( 'http://example.com/', # URL [...], # headers [ foo => 'bar' ], # form data (HashRef/FileHandle are also okay) ); # Accept-Encoding is supported but optional $furl = Furl->new( headers => [ 'Accept-Encoding' => 'gzip' ], ); my $body = $furl->get('http://example.com/some/compressed'); # DESCRIPTION Furl is yet another HTTP client library. LWP is the de facto standard HTTP client for Perl 5, but it is too slow for some critical jobs, and too complex for weekend hacking. Furl resolves these issues. Enjoy it! # INTERFACE ## Class Methods ### `Furl->new(%args | \%args) :Furl` Creates and returns a new Furl client with _%args_. Dies on errors. _%args_ might be: - agent :Str = "Furl/$VERSION" - timeout :Int = 10 - max\_redirects :Int = 7 - capture\_request :Bool = false If this parameter is true, [Furl::HTTP](https://metacpan.org/pod/Furl::HTTP) captures raw request string. You can get it by `$res->captured_req_headers` and `$res->captured_req_content`. - proxy :Str - no\_proxy :Str - headers :ArrayRef - cookie\_jar :Object (EXPERIMENTAL) An instance of HTTP::CookieJar or equivalent class that supports the add and cookie\_header methods ## Instance Methods ### `$furl->request([$request,] %args) :Furl::Response` Sends an HTTP request to a specified URL and returns a instance of [Furl::Response](https://metacpan.org/pod/Furl::Response). _%args_ might be: - scheme :Str = "http" Protocol scheme. May be `http` or `https`. - host :Str Server host to connect. You must specify at least `host` or `url`. - port :Int = 80 Server port to connect. The default is 80 on `scheme => 'http'`, or 443 on `scheme => 'https'`. - path\_query :Str = "/" Path and query to request. - url :Str URL to request. You can use `url` instead of `scheme`, `host`, `port` and `path_query`. - headers :ArrayRef HTTP request headers. e.g. `headers => [ 'Accept-Encoding' => 'gzip' ]`. - content : Str | ArrayRef\[Str\] | HashRef\[Str\] | FileHandle Content to request. If the number of arguments is an odd number, this method assumes that the first argument is an instance of `HTTP::Request`. Remaining arguments can be any of the previously describe values (but currently there's no way to really utilize them, so don't use it) my $req = HTTP::Request->new(...); my $res = $furl->request($req); You can also specify an object other than HTTP::Request (e.g. Furl::Request), but the object must implement the following methods: - uri - method - content - headers These must return the same type of values as their counterparts in `HTTP::Request`. You must encode all the queries or this method will die, saying `Wide character in ...`. ### `$furl->get($url :Str, $headers :ArrayRef[Str] )` This is an easy-to-use alias to `request()`, sending the `GET` method. ### `$furl->head($url :Str, $headers :ArrayRef[Str] )` This is an easy-to-use alias to `request()`, sending the `HEAD` method. ### `$furl->post($url :Str, $headers :ArrayRef[Str], $content :Any)` This is an easy-to-use alias to `request()`, sending the `POST` method. ### `$furl->put($url :Str, $headers :ArrayRef[Str], $content :Any)` This is an easy-to-use alias to `request()`, sending the `PUT` method. ### `$furl->delete($url :Str, $headers :ArrayRef[Str] )` This is an easy-to-use alias to `request()`, sending the `DELETE` method. ### `$furl->env_proxy()` Loads proxy settings from `$ENV{HTTP_PROXY}` and `$ENV{NO_PROXY}`. # FAQ - Does Furl depends on XS modules? No. Although some optional features require XS modules, basic features are available without XS modules. Note that Furl requires HTTP::Parser::XS, which seems an XS module but includes a pure Perl backend, HTTP::Parser::XS::PP. - I need more speed. See [Furl::HTTP](https://metacpan.org/pod/Furl::HTTP), which provides the low level interface of [Furl](https://metacpan.org/pod/Furl). It is faster than `Furl.pm` since [Furl::HTTP](https://metacpan.org/pod/Furl::HTTP) does not create response objects. - How do you use cookie\_jar? Furl does not directly support the cookie\_jar option available in LWP. You can use [HTTP::Cookies](https://metacpan.org/pod/HTTP::Cookies), [HTTP::Request](https://metacpan.org/pod/HTTP::Request), [HTTP::Response](https://metacpan.org/pod/HTTP::Response) like following. my $f = Furl->new(); my $cookies = HTTP::Cookies->new(); my $req = HTTP::Request->new(...); $cookies->add_cookie_header($req); my $res = $f->request($req)->as_http_response; $res->request($req); $cookies->extract_cookies($res); # and use $res. - How do you limit the response content length? You can limit the content length by callback function. my $f = Furl->new(); my $content = ''; my $limit = 1_000_000; my %special_headers = ('content-length' => undef); my $res = $f->request( method => 'GET', url => $url, special_headers => \%special_headers, write_code => sub { my ( $status, $msg, $headers, $buf ) = @_; if (($special_headers{'content-length'}||0) > $limit || length($content) > $limit) { die "over limit: $limit"; } $content .= $buf; } ); - How do you display the progress bar? my $bar = Term::ProgressBar->new({count => 1024, ETA => 'linear'}); $bar->minor(0); $bar->max_update_rate(1); my $f = Furl->new(); my $content = ''; my %special_headers = ('content-length' => undef);; my $did_set_target = 0; my $received_size = 0; my $next_update = 0; $f->request( method => 'GET', url => $url, special_headers => \%special_headers, write_code => sub { my ( $status, $msg, $headers, $buf ) = @_; unless ($did_set_target) { if ( my $cl = $special_headers{'content-length'} ) { $bar->target($cl); $did_set_target++; } else { $bar->target( $received_size + 2 * length($buf) ); } } $received_size += length($buf); $content .= $buf; $next_update = $bar->update($received_size) if $received_size >= $next_update; } ); - HTTPS requests claims warnings! When you make https requests, IO::Socket::SSL may complain about it like: ******************************************************************* Using the default of SSL_verify_mode of SSL_VERIFY_NONE for client is depreciated! Please set SSL_verify_mode to SSL_VERIFY_PEER together with SSL_ca_file|SSL_ca_path for verification. If you really don't want to verify the certificate and keep the connection open to Man-In-The-Middle attacks please set SSL_verify_mode explicitly to SSL_VERIFY_NONE in your application. ******************************************************************* You should set `SSL_verify_mode` explicitly with Furl's `ssl_opts`. use IO::Socket::SSL; my $ua = Furl->new( ssl_opts => { SSL_verify_mode => SSL_VERIFY_PEER(), }, ); See [IO::Socket::SSL](https://metacpan.org/pod/IO::Socket::SSL) for details. # AUTHOR Tokuhiro Matsuno Fuji, Goro (gfx) # THANKS TO Kazuho Oku mala mattn lestrrat walf443 lestrrat audreyt # SEE ALSO [LWP](https://metacpan.org/pod/LWP) [IO::Socket::SSL](https://metacpan.org/pod/IO::Socket::SSL) [Furl::HTTP](https://metacpan.org/pod/Furl::HTTP) [Furl::Response](https://metacpan.org/pod/Furl::Response) # LICENSE Copyright (C) Tokuhiro Matsuno. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. TODO100664001750001750 14112560625033 14332 0ustar00tokuhiromtokuhirom000000000000Furl-3.08- max_redirects - redirect support - win32 support - ssl support - 多言語ドメイン support byown.pl100664001750001750 316012560625033 20615 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/author/benchmarkuse strict; use warnings; use autodie; use Benchmark ':all'; use Starman; use LWP::UserAgent; use WWW::Curl::Easy 4.14; use Furl::HTTP; use Child; use Test::TCP qw/empty_port/; use Plack::Loader; use Config; use HTTP::Lite; printf "Perl/%vd on %s\n", $^V, $Config{archname}; printf "Furl/$Furl::VERSION, LWP/$LWP::VERSION, WWW::Curl/$WWW::Curl::VERSION, HTTP::Lite/$HTTP::Lite::VERSION, libcurl[@{[ WWW::Curl::Easy::version() ]}]\n"; my $port = empty_port(); my $ua = LWP::UserAgent->new(parse_head => 0, keep_alive => 1); my $curl = WWW::Curl::Easy->new(); my $furl = Furl::HTTP->new(parse_header => 0); my $url = "http://127.0.0.1:$port/foo/bar"; my $child = Child->new( sub { Plack::Loader->load( 'Starman', port => $port ) ->run( sub { [ 200, ['Content-Length' => length('Hi')], ['Hi'] ] } ); } ); my $proc = $child->start(); cmpthese( -1, { lwp => sub { my $res = $ua->get($url); }, curl => sub { my @headers; $curl->setopt(CURLOPT_URL, $url); $curl->setopt(CURLOPT_HTTPGET, 1); $curl->setopt(CURLOPT_HEADER, 0); $curl->setopt(CURLOPT_NOPROGRESS, 1); $curl->setopt(CURLOPT_HEADERFUNCTION, sub { push @headers, @_; length($_[0]); }); my $content = ''; $curl->setopt(CURLOPT_WRITEDATA, \$content); $curl->perform(); my $code = $curl->getinfo(CURLINFO_HTTP_CODE); }, furl => sub { $furl->request(method => 'GET', url => $url); }, }, ); $proc->kill('TERM'); note.mkdn100664001750001750 1652612560625033 20774 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/author/benchmark### On tokuhirom's SC440 0.01 3534c7b341136a18bd52449af6e28570ca87a36f Rate lwp furl curl lwp 792/s -- -88% -90% furl 6461/s 715% -- -15% curl 7587/s 857% 17% -- 0.02 fbb922531d3236b2da84acd0c22f554e61060446 Rate lwp http_lite furl curl lwp 823/s -- -8% -74% -89% http_lite 896/s 9% -- -72% -88% furl 3170/s 285% 254% -- -59% curl 7657/s 831% 754% 142% -- 25998b62ae12445ae0a8bdd5329ffe8f9bd71dd2 Rate lwp http_lite furl curl lwp 792/s -- -25% -76% -91% http_lite 1056/s 33% -- -68% -88% furl 3326/s 320% 215% -- -62% curl 8783/s 1010% 732% 164% -- 496a941ca1fd8cfcc8925c91fab501d516fdfa8e fixed bug. Rate lwp http_lite furl curl lwp 767/s -- -27% -88% -91% http_lite 1046/s 36% -- -84% -88% furl 6461/s 742% 518% -- -26% curl 8783/s 1045% 740% 36% -- #### micro optimization commit c8f4c4655966ecb1b2fef98769a72e437dd467fe Perl/5.12.1 on x86_64-linux Furl/0.02, LWP/5.837, WWW::Curl/4.14, HTTP::Lite/2.2 Server: nginx/0.8.48 -- Rate lwp http_lite furl curl lwp 800/s -- -23% -88% -91% http_lite 1036/s 30% -- -84% -88% furl 6587/s 723% 536% -- -24% curl 8650/s 981% 735% 31% -- #### 0.04 0065f2144c7636fc79ae1b30ae01c8e5f25de178 Perl/5.12.1 on x86_64-linux Furl/0.04, LWP/5.837, WWW::Curl/4.14, HTTP::Lite/2.2 Server: nginx/0.8.48 -- Rate lwp http_lite furl curl lwp 807/s -- -23% -88% -91% http_lite 1046/s 30% -- -84% -88% furl 6698/s 730% 540% -- -22% curl 8615/s 968% 724% 29% -- #### http-parser-xs 9cf2a06ee9aed52232effdeb432f5a6668f42636 Perl/5.12.1 on x86_64-linux Furl/0.04, LWP/5.837, WWW::Curl/4.14, HTTP::Lite/2.2, libcurl[libcurl/7.21.0 OpenSSL/0.9.8o zlib/1.2.3.4 libidn/1.18] Server: nginx/0.8.48 Content-Length: 2947 -- Rate lwp http_lite furl curl lwp 800/s -- -24% -88% -91% http_lite 1047/s 31% -- -84% -88% furl 6575/s 722% 528% -- -25% curl 8727/s 991% 734% 33% -- ##### same revsion, but access to real server 9cf2a06ee9aed52232effdeb432f5a6668f42636 Perl/5.12.1 on x86_64-linux Furl/0.04, LWP/5.837, WWW::Curl/4.14, HTTP::Lite/2.2, libcurl[libcurl/7.21.0 OpenSSL/0.9.8o zlib/1.2.3.4 libidn/1.18] Server: Apache -- Rate lwp http_lite furl curl lwp 111/s -- -61% -62% -81% http_lite 288/s 159% -- -3% -50% furl 296/s 166% 3% -- -49% curl 581/s 422% 102% 96% -- ##### 1MB response 7389e930aa93b20a56eb2e7a9408c4b2ff056c8d Perl/5.12.1 on x86_64-linux Furl/0.04, LWP/5.837, WWW::Curl/4.14, HTTP::Lite/2.2, libcurl[libcurl/7.21.0 OpenSSL/0.9.8o zlib/1.2.3.4 libidn/1.18] Date: Fri, 29 Oct 2010 11:43:37 GMT Server: KyotoTycoon/0.8.1 Content-Length: 1000000 Client-Date: Fri, 29 Oct 2010 11:43:37 GMT Client-Peer: 127.0.0.1:1978 Client-Response-Num: 1 -- Rate lwp http_lite furl curl lwp 74.1/s -- -62% -72% -90% http_lite 196/s 165% -- -26% -74% furl 265/s 258% 35% -- -65% curl 760/s 926% 287% 187% -- ### useragent branch. fbe216421eaa343ed86a8a3636a9ac3925018f61 Perl/5.12.1 on x86_64-linux Furl/0.04, LWP/5.837, WWW::Curl/4.14, HTTP::Lite/2.2, libcurl[libcurl/7.21.0 OpenSSL/0.9.8o zlib/1.2.3.4 libidn/1.18] -- Connection: keep-alive Date: Mon, 01 Nov 2010 03:16:02 GMT Accept-Ranges: bytes Server: nginx/0.8.48 Content-Length: 2947 Content-Type: text/html Last-Modified: Sat, 05 Jun 2010 23:53:36 GMT Client-Date: Mon, 01 Nov 2010 03:16:02 GMT Client-Peer: 192.168.1.3:80 Client-Response-Num: 1 -- bufsize: 10240 -- Rate lwp http_lite furl_high furl_low curl lwp 799/s -- -24% -83% -88% -91% http_lite 1057/s 32% -- -78% -84% -88% furl_high 4699/s 488% 345% -- -31% -46% furl_low 6762/s 746% 540% 44% -- -22% curl 8650/s 982% 719% 84% 28% -- ### 0.07 58868db2dbe06394ac6b8344fbbf47acf334daf1 Perl/5.12.1 on x86_64-linux Furl/0.07, LWP/5.837, WWW::Curl/4.14, HTTP::Lite/2.2, libcurl[libcurl/7.21.0 OpenSSL/0.9.8o zlib/1.2.3.4 libidn/1.18] -- Connection: keep-alive Date: Tue, 02 Nov 2010 00:24:44 GMT Accept-Ranges: bytes Server: nginx/0.8.48 Content-Length: 2947 Content-Type: text/html Last-Modified: Sat, 05 Jun 2010 23:53:36 GMT Client-Date: Tue, 02 Nov 2010 00:24:44 GMT Client-Peer: 192.168.1.3:80 Client-Response-Num: 1 -- bufsize: 10240 -- Rate lwp http_lite furl_high furl_low curl lwp 792/s -- -24% -83% -88% -91% http_lite 1046/s 32% -- -78% -84% -88% furl_high 4757/s 501% 355% -- -25% -45% furl_low 6342/s 701% 506% 33% -- -27% curl 8650/s 993% 727% 82% 36% -- ### kazuho perl -Ilib benchmperl -Ilib benchmark/simple.pl [~/dev/Furl] 水 17 19:05 65d1df9882c8f5330f9cc93a03722887867e303c Perl/5.12.1 on x86_64-linux Furl/0.13, LWP/5.837, WWW::Curl/4.14, HTTP::Lite/2.2, libcurl[libcurl/7.21.0 OpenSSL/0.9.8o zlib/1.2.3.4 libidn/1.18] -- Connection: keep-alive Date: Wed, 17 Nov 2010 10:05:52 GMT Accept-Ranges: bytes Server: nginx/0.8.48 Content-Length: 2947 Content-Type: text/html Last-Modified: Sat, 05 Jun 2010 23:53:36 GMT Client-Date: Wed, 17 Nov 2010 10:05:52 GMT Client-Peer: 192.168.1.3:80 Client-Response-Num: 1 -- bufsize: 10240 -- Rate lwp http_lite furl_high furl_low curl lwp 800/s -- -24% -79% -84% -91% http_lite 1056/s 32% -- -72% -79% -88% furl_high 3759/s 370% 256% -- -24% -57% furl_low 4978/s 522% 372% 32% -- -43% curl 8698/s 987% 724% 131% 75% -- profile.pl100664001750001750 114112560625033 21114 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/author/benchmarkuse strict; use warnings; use Furl::HTTP qw/HEADERS_NONE HEADERS_AS_ARRAYREF/; use URI; my $url = shift @ARGV || 'http://127.0.0.1:80/'; my $uri = URI->new($url); my $host = $uri->host; my $port = $uri->port; my $path_query = $uri->path_query; my $furl = Furl::HTTP->new(header_format => HEADERS_NONE, bufsize => 10_000_000); for (1..1000) { my ( $version, $code, $msg, $headers, $content ) = $furl->request( method => 'GET', host => $host, port => $port, path_query => $path_query, ); $code == 200 or die "oops : $code, $content"; } simple.pl100664001750001750 671312560625033 20757 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/author/benchmarkuse strict; use warnings; use Benchmark ':all'; use LWP::UserAgent; use WWW::Curl::Easy 4.14; use HTTP::Lite; use Furl::HTTP qw/HEADERS_NONE HEADERS_AS_ARRAYREF/; use Furl; use Config; use Getopt::Long; GetOptions( 'busize=i' => \my $bufsize, ); printf `git rev-parse HEAD`; printf "Perl/%vd on %s\n", $^V, $Config{archname}; printf "Furl/$Furl::VERSION, LWP/$LWP::VERSION, WWW::Curl/$WWW::Curl::VERSION, HTTP::Lite/$HTTP::Lite::VERSION, libcurl[@{[ WWW::Curl::Easy::version() ]}]\n"; my $url = shift @ARGV || 'http://192.168.1.3:80/'; my $ua = LWP::UserAgent->new(parse_head => 0, keep_alive => 1); my $curl = WWW::Curl::Easy->new(); my $furl_low = Furl::HTTP->new(header_format => HEADERS_NONE); my $furl_high = Furl->new(); $furl_high->{bufsize} = $bufsize if defined $bufsize; $furl_low->{bufsize} = $bufsize if defined $bufsize; my $uri = URI->new($url); my $host = $uri->host; my $scheme = $uri->scheme; my $port = $uri->port; my $path_query = $uri->path_query; my $lite = HTTP::Lite->new(); $lite->http11_mode(1); my $res = $ua->get($url); print "--\n"; print $res->headers_as_string; print "--\n"; printf "bufsize: %d\n", $furl_low->{bufsize}; print "--\n\n"; my $body_content_length = length($res->content); $body_content_length == $res->content_length or die; cmpthese( -1, { http_lite => sub { my $req = $lite->request($url) or die; $lite->status == 200 or die; length($lite->body) == $body_content_length or die "Lite failed: @{[ length($lite->body) ]} != $body_content_length"; $lite->reset(); # This is *required* for re-use instance. }, lwp => sub { my $res = $ua->get($url); $res->code == 200 or die; length($res->content) == $body_content_length or die; }, curl => sub { my @headers; $curl->setopt(CURLOPT_HEADER, 0); $curl->setopt(CURLOPT_NOPROGRESS, 1); $curl->setopt(CURLOPT_URL, $url); $curl->setopt(CURLOPT_HTTPGET, 1); $curl->setopt(CURLOPT_HEADERFUNCTION, sub { push @headers, @_; length($_[0]); }); my $content = ''; $curl->setopt(CURLOPT_WRITEDATA, \$content); my $ret = $curl->perform(); $ret == 0 or die "$ret : " . $curl->strerror($ret); my $code = $curl->getinfo(CURLINFO_HTTP_CODE); $code == 200 or die "oops: $code"; length($content) == $body_content_length or die; }, furl_high => sub { my $res = $furl_high->request( method => 'GET', host => $host, port => $port, scheme => $scheme, path_query => $path_query, headers => [ 'Content-Length' => 0 ] ); $res->code == 200 or die "oops"; length($res->content) == $body_content_length or die; }, furl_low => sub { my ( $version, $code, $msg, $headers, $content ) = $furl_low->request( method => 'GET', host => $host, port => $port, scheme => $scheme, path_query => $path_query, headers => [ 'Content-Length' => 0 ] ); $code == 200 or die "oops: $code, $content"; length($content) == $body_content_length or die; }, }, ); mk-chunked-response.pl100664001750001750 123312560625033 21406 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/author#!perl -w use strict; use Furl; use Plack::Loader; use Child; { package Furl::Verbose; use parent qw(Furl); sub read_timeout { my $self = shift; my $ret = $self->SUPER::read_timeout(@_); print ${$_[1]}; return $ret; } } my $content = "The quick brown fox jumps over the lazy dog.\n" x 100; my $child = Child->new( sub { Plack::Loader->load('Starman', host => '127.0.0.1', port => 1234 ) ->run( sub { [ 200, ['Transfer-Encoding' => 'chunked' ], [$content] ] } ); } ); my $proc = $child->start(); sleep 1; Furl::Verbose->new->get('http://127.0.0.1:1234/'); $proc->kill('TERM'); cpanfile100664001750001750 307412560625033 15376 0ustar00tokuhiromtokuhirom000000000000Furl-3.08requires 'perl', 5.008_001; requires 'HTTP::Parser::XS' => 0.11; requires 'Mozilla::CA'; requires 'MIME::Base64'; requires 'Class::Accessor::Lite'; requires 'Encode'; requires 'Scalar::Util'; requires 'Socket'; requires 'Time::HiRes'; suggests 'HTTP::Headers'; # Furl::Headers suggests 'HTTP::Request'; # Furl::Request suggests 'HTTP::Response'; # Furl::Response recommends 'Net::IDN::Encode'; # for International Domain Name recommends 'IO::Socket::SSL'; # for SSL recommends 'Compress::Raw::Zlib'; # for Content-Encoding recommends 'HTTP::CookieJar'; on test => sub { requires 'Test::More' => 0.96; # done_testing, subtest requires 'Test::TCP' => '2.11'; requires 'Test::Requires'; requires 'File::Temp'; suggests 'Test::Fake::HTTPD'; suggests 'HTTP::Proxy'; suggests 'HTTP::Server::PSGI'; suggests 'Plack::Loader'; suggests 'Plack::Request'; suggests 'Starlet::Server'; suggests 'Test::SharedFork'; suggests 'URI'; suggests 'parent'; suggests 'Plack'; suggests 'Test::Valgrind'; suggests 'HTTP::CookieJar'; }; on develop => sub { suggests 'Child'; suggests 'Getopt::Long'; suggests 'HTTP::Lite'; suggests 'LWP::UserAgent'; suggests 'Plack::Loader'; suggests 'Starman'; suggests 'Test::More'; suggests 'Test::Requires'; suggests 'Test::TCP'; suggests 'URI'; suggests 'WWW::Curl::Easy', '4.14'; suggests 'IO::Callback'; suggests 'autodie'; suggests 'parent'; suggests 'Net::IDN::Encode'; suggests 'Test::LeakTrace'; suggests 'Net::DNS::Lite'; }; get.pl100664001750001750 35612560625033 16421 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/example#!perl -w use strict; use Furl; use HTTP::Response; my $uri = shift(@ARGV) or die "Usage: $0 URI\n"; my $furl = Furl->new(headers => ['Accept-Encoding' => 'gzip']); $furl->env_proxy; print $furl->get($uri)->as_http_response->as_string; Furl.pm100664001750001750 2461112560625033 15726 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/libpackage Furl; use strict; use warnings; use utf8; use Furl::HTTP; use Furl::Request; use Furl::Response; use Carp (); our $VERSION = '3.08'; use 5.008001; $Carp::Internal{+__PACKAGE__} = 1; sub new { my $class = shift; bless \(Furl::HTTP->new(header_format => Furl::HTTP::HEADERS_AS_HASHREF(), @_)), $class; } sub get { my ( $self, $url, $headers ) = @_; $self->request( method => 'GET', url => $url, headers => $headers ); } sub head { my ( $self, $url, $headers ) = @_; $self->request( method => 'HEAD', url => $url, headers => $headers ); } sub post { my ( $self, $url, $headers, $content ) = @_; $self->request( method => 'POST', url => $url, headers => $headers, content => $content ); } sub put { my ( $self, $url, $headers, $content ) = @_; $self->request( method => 'PUT', url => $url, headers => $headers, content => $content ); } sub delete { my ( $self, $url, $headers, $content ) = @_; $self->request( method => 'DELETE', url => $url, headers => $headers, content => $content ); } sub agent { @_ == 2 ? ${$_[0]}->agent($_[1]) : ${$_[0]}->agent; } sub env_proxy { my $self = shift; $$self->env_proxy; } sub request { my $self = shift; my %args; if (@_ % 2 == 0) { %args = @_; } else { # convert HTTP::Request to hash for Furl::HTTP. my $req = shift; %args = @_; my $req_headers= $req->headers; $req_headers->remove_header('Host'); # suppress duplicate Host header my $headers = +[ map { my $k = $_; map { ( $k => $_ ) } $req_headers->header($_); } $req_headers->header_field_names ]; $args{url} = $req->uri; $args{method} = $req->method; $args{content} = $req->content; $args{headers} = $headers; } my ( $res_minor_version, $res_status, $res_msg, $res_headers, $res_content, $captured_req_headers, $captured_req_content, $captured_res_headers, $captured_res_content, $request_info, ) = ${$self}->request(%args); my $res = Furl::Response->new($res_minor_version, $res_status, $res_msg, $res_headers, $res_content); $res->set_request_info(\%args, $captured_req_headers, $captured_req_content); return $res; } 1; __END__ =encoding utf8 =head1 NAME Furl - Lightning-fast URL fetcher =head1 SYNOPSIS use Furl; my $furl = Furl->new( agent => 'MyGreatUA/2.0', timeout => 10, ); my $res = $furl->get('http://example.com/'); die $res->status_line unless $res->is_success; print $res->content; my $res = $furl->post( 'http://example.com/', # URL [...], # headers [ foo => 'bar' ], # form data (HashRef/FileHandle are also okay) ); # Accept-Encoding is supported but optional $furl = Furl->new( headers => [ 'Accept-Encoding' => 'gzip' ], ); my $body = $furl->get('http://example.com/some/compressed'); =head1 DESCRIPTION Furl is yet another HTTP client library. LWP is the de facto standard HTTP client for Perl 5, but it is too slow for some critical jobs, and too complex for weekend hacking. Furl resolves these issues. Enjoy it! =head1 INTERFACE =head2 Class Methods =head3 C<< Furl->new(%args | \%args) :Furl >> Creates and returns a new Furl client with I<%args>. Dies on errors. I<%args> might be: =over =item agent :Str = "Furl/$VERSION" =item timeout :Int = 10 =item max_redirects :Int = 7 =item capture_request :Bool = false If this parameter is true, L captures raw request string. You can get it by C<< $res->captured_req_headers >> and C<< $res->captured_req_content >>. =item proxy :Str =item no_proxy :Str =item headers :ArrayRef =item cookie_jar :Object (EXPERIMENTAL) An instance of HTTP::CookieJar or equivalent class that supports the add and cookie_header methods =back =head2 Instance Methods =head3 C<< $furl->request([$request,] %args) :Furl::Response >> Sends an HTTP request to a specified URL and returns a instance of L. I<%args> might be: =over =item scheme :Str = "http" Protocol scheme. May be C or C. =item host :Str Server host to connect. You must specify at least C or C. =item port :Int = 80 Server port to connect. The default is 80 on C<< scheme => 'http' >>, or 443 on C<< scheme => 'https' >>. =item path_query :Str = "/" Path and query to request. =item url :Str URL to request. You can use C instead of C, C, C and C. =item headers :ArrayRef HTTP request headers. e.g. C<< headers => [ 'Accept-Encoding' => 'gzip' ] >>. =item content : Str | ArrayRef[Str] | HashRef[Str] | FileHandle Content to request. =back If the number of arguments is an odd number, this method assumes that the first argument is an instance of C. Remaining arguments can be any of the previously describe values (but currently there's no way to really utilize them, so don't use it) my $req = HTTP::Request->new(...); my $res = $furl->request($req); You can also specify an object other than HTTP::Request (e.g. Furl::Request), but the object must implement the following methods: =over 4 =item uri =item method =item content =item headers =back These must return the same type of values as their counterparts in C. You must encode all the queries or this method will die, saying C. =head3 C<< $furl->get($url :Str, $headers :ArrayRef[Str] ) >> This is an easy-to-use alias to C, sending the C method. =head3 C<< $furl->head($url :Str, $headers :ArrayRef[Str] ) >> This is an easy-to-use alias to C, sending the C method. =head3 C<< $furl->post($url :Str, $headers :ArrayRef[Str], $content :Any) >> This is an easy-to-use alias to C, sending the C method. =head3 C<< $furl->put($url :Str, $headers :ArrayRef[Str], $content :Any) >> This is an easy-to-use alias to C, sending the C method. =head3 C<< $furl->delete($url :Str, $headers :ArrayRef[Str] ) >> This is an easy-to-use alias to C, sending the C method. =head3 C<< $furl->env_proxy() >> Loads proxy settings from C<< $ENV{HTTP_PROXY} >> and C<< $ENV{NO_PROXY} >>. =head1 FAQ =over 4 =item Does Furl depends on XS modules? No. Although some optional features require XS modules, basic features are available without XS modules. Note that Furl requires HTTP::Parser::XS, which seems an XS module but includes a pure Perl backend, HTTP::Parser::XS::PP. =item I need more speed. See L, which provides the low level interface of L. It is faster than C since L does not create response objects. =item How do you use cookie_jar? Furl does not directly support the cookie_jar option available in LWP. You can use L, L, L like following. my $f = Furl->new(); my $cookies = HTTP::Cookies->new(); my $req = HTTP::Request->new(...); $cookies->add_cookie_header($req); my $res = $f->request($req)->as_http_response; $res->request($req); $cookies->extract_cookies($res); # and use $res. =item How do you limit the response content length? You can limit the content length by callback function. my $f = Furl->new(); my $content = ''; my $limit = 1_000_000; my %special_headers = ('content-length' => undef); my $res = $f->request( method => 'GET', url => $url, special_headers => \%special_headers, write_code => sub { my ( $status, $msg, $headers, $buf ) = @_; if (($special_headers{'content-length'}||0) > $limit || length($content) > $limit) { die "over limit: $limit"; } $content .= $buf; } ); =item How do you display the progress bar? my $bar = Term::ProgressBar->new({count => 1024, ETA => 'linear'}); $bar->minor(0); $bar->max_update_rate(1); my $f = Furl->new(); my $content = ''; my %special_headers = ('content-length' => undef);; my $did_set_target = 0; my $received_size = 0; my $next_update = 0; $f->request( method => 'GET', url => $url, special_headers => \%special_headers, write_code => sub { my ( $status, $msg, $headers, $buf ) = @_; unless ($did_set_target) { if ( my $cl = $special_headers{'content-length'} ) { $bar->target($cl); $did_set_target++; } else { $bar->target( $received_size + 2 * length($buf) ); } } $received_size += length($buf); $content .= $buf; $next_update = $bar->update($received_size) if $received_size >= $next_update; } ); =item HTTPS requests claims warnings! When you make https requests, IO::Socket::SSL may complain about it like: ******************************************************************* Using the default of SSL_verify_mode of SSL_VERIFY_NONE for client is depreciated! Please set SSL_verify_mode to SSL_VERIFY_PEER together with SSL_ca_file|SSL_ca_path for verification. If you really don't want to verify the certificate and keep the connection open to Man-In-The-Middle attacks please set SSL_verify_mode explicitly to SSL_VERIFY_NONE in your application. ******************************************************************* You should set C explicitly with Furl's C. use IO::Socket::SSL; my $ua = Furl->new( ssl_opts => { SSL_verify_mode => SSL_VERIFY_PEER(), }, ); See L for details. =back =head1 AUTHOR Tokuhiro Matsuno Etokuhirom@gmail.comE Fuji, Goro (gfx) =head1 THANKS TO Kazuho Oku mala mattn lestrrat walf443 lestrrat audreyt =head1 SEE ALSO L L L L =head1 LICENSE Copyright (C) Tokuhiro Matsuno. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut ConnectionCache.pm100664001750001750 64712560625033 20714 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/lib/Furlpackage Furl::ConnectionCache; use strict; use warnings; use utf8; sub new { bless [''], shift } sub steal { my ($self, $host, $port) = @_; if ($self->[0] eq "$host:$port") { my $sock = $self->[1]; @{$self} = (''); return $sock; } else { return undef; } } sub push { my ($self, $host, $port, $sock) = @_; $self->[0] = "$host:$port"; $self->[1] = $sock; } 1; HTTP.pm100664001750001750 13046412560625033 16531 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/lib/Furlpackage Furl::HTTP; use strict; use warnings; use base qw/Exporter/; use 5.008001; our $VERSION = '3.08'; use Carp (); use Furl::ConnectionCache; use Scalar::Util (); use Errno qw(EAGAIN ECONNRESET EINPROGRESS EINTR EWOULDBLOCK ECONNABORTED EISCONN); use Fcntl qw(F_GETFL F_SETFL O_NONBLOCK SEEK_SET SEEK_END); use Socket qw( PF_INET SOCK_STREAM IPPROTO_TCP TCP_NODELAY pack_sockaddr_in ); use Time::HiRes qw(time); use constant WIN32 => $^O eq 'MSWin32'; use HTTP::Parser::XS qw/HEADERS_NONE HEADERS_AS_ARRAYREF HEADERS_AS_HASHREF/; our @EXPORT_OK = qw/HEADERS_NONE HEADERS_AS_ARRAYREF HEADERS_AS_HASHREF/; # ref. RFC 2616, 3.5 Content Codings: # For compatibility with previous implementations of HTTP, # applications SHOULD consider "x-gzip" and "x-compress" to be # equivalent to "gzip" and "compress" respectively. # ("compress" is not supported, though) my %COMPRESSED = map { $_ => undef } qw(gzip x-gzip deflate); my $HTTP_TOKEN = '[^\x00-\x31\x7F]+'; my $HTTP_QUOTED_STRING = q{"([^"]+|\\.)*"}; sub new { my $class = shift; my %args = @_ == 1 ? %{$_[0]} : @_; my @headers = ( 'User-Agent' => (delete($args{agent}) || __PACKAGE__ . '/' . $Furl::HTTP::VERSION), ); my $connection_header = 'keep-alive'; if(defined $args{headers}) { my $in_headers = delete $args{headers}; for (my $i = 0; $i < @$in_headers; $i += 2) { my $name = $in_headers->[$i]; if (lc($name) eq 'connection') { $connection_header = $in_headers->[$i + 1]; } else { push @headers, $name, $in_headers->[$i + 1]; } } } bless { timeout => 10, max_redirects => 7, bufsize => 10*1024, # no mmap headers => \@headers, connection_header => $connection_header, proxy => '', no_proxy => '', connection_pool => Furl::ConnectionCache->new(), header_format => HEADERS_AS_ARRAYREF, stop_if => sub {}, inet_aton => sub { Socket::inet_aton($_[0]) }, ssl_opts => {}, capture_request => $args{capture_request} || 0, inactivity_timeout => 600, %args }, $class; } sub get { my ( $self, $url, $headers ) = @_; $self->request( method => 'GET', url => $url, headers => $headers ); } sub head { my ( $self, $url, $headers ) = @_; $self->request( method => 'HEAD', url => $url, headers => $headers ); } sub post { my ( $self, $url, $headers, $content ) = @_; $self->request( method => 'POST', url => $url, headers => $headers, content => $content ); } sub put { my ( $self, $url, $headers, $content ) = @_; $self->request( method => 'PUT', url => $url, headers => $headers, content => $content ); } sub delete { my ( $self, $url, $headers, $content ) = @_; $self->request( method => 'DELETE', url => $url, headers => $headers, content => $content ); } sub agent { if ( @_ == 2 ) { _header_set(shift->{headers}, 'User-Agent', shift); } else { return _header_get(shift->{headers}, 'User-Agent'); } } sub _header_set { my ($headers, $key, $value) = (shift, lc shift, shift); for (my $i=0; $i<@$headers; $i+=2) { if (lc($headers->[$i]) eq $key) { $headers->[$i+1] = $value; return; } } push @$headers, $key, $value; } sub _header_get { my ($headers, $key) = (shift, lc shift); for (my $i=0; $i<@$headers; $i+=2) { return $headers->[$i+1] if lc($headers->[$i]) eq $key; } return undef; } sub _requires { my($file, $feature, $library) = @_; return if exists $INC{$file}; unless(eval { require $file }) { if ($@ =~ /^Can't locate/) { $library ||= do { local $_ = $file; s/ \.pm \z//xms; s{/}{::}g; $_; }; Carp::croak( "$feature requires $library, but it is not available." . " Please install $library using your prefer CPAN client" ); } else { die $@; } } } # returns $scheme, $host, $port, $path_query sub _parse_url { my($self, $url) = @_; $url =~ m{\A ([a-z]+) # scheme :// (?: ([^/:@?]+) # user : ([^/:@?]+) # password @ )? ([^/:?]+) # host (?: : (\d+) )? # port (?: ( /? \? .* | / .*) )? # path_query \z}xms or Carp::croak("Passed malformed URL: $url"); return( $1, $2, $3, $4, $5, $6 ); } sub make_x_www_form_urlencoded { my($self, $content) = @_; my @params; my @p = ref($content) eq 'HASH' ? %{$content} : ref($content) eq 'ARRAY' ? @{$content} : Carp::croak("Cannot coerce $content to x-www-form-urlencoded"); while ( my ( $k, $v ) = splice @p, 0, 2 ) { foreach my $s($k, $v) { utf8::downgrade($s); # will die in wide characters # escape unsafe chars (defined by RFC 3986) $s =~ s/ ([^A-Za-z0-9\-\._~]) / sprintf '%%%02X', ord $1 /xmsge; } push @params, "$k=$v"; } return join( "&", @params ); } sub env_proxy { my $self = shift; $self->{proxy} = $ENV{HTTP_PROXY} || ''; $self->{no_proxy} = $ENV{NO_PROXY} || ''; $self; } sub request { my $self = shift; my %args = @_; my $timeout_at = time + $self->{timeout}; my ($scheme, $username, $password, $host, $port, $path_query); if (defined(my $url = $args{url})) { ($scheme, $username, $password, $host, $port, $path_query) = $self->_parse_url($url); } else { ($scheme, $host, $port, $path_query) = @args{qw/scheme host port path_query/}; if (not defined $host) { Carp::croak("Missing host name in arguments"); } } if (not defined $scheme) { $scheme = 'http'; } elsif($scheme ne 'http' && $scheme ne 'https') { Carp::croak("Unsupported scheme: $scheme"); } my $default_port = $scheme eq 'http' ? 80 : 443; if(not defined $port) { $port = $default_port; } if(not defined $path_query) { $path_query = '/'; } unless (substr($path_query, 0, 1) eq '/') { $path_query = "/$path_query"; # Compensate for slash (?foo=bar => /?foo=bar) } # Note. '_' is a invalid character for URI, but some servers using fucking underscore for domain name. Then, I accept the '_' character for domain name. if ($host =~ /[^A-Za-z0-9._-]/) { _requires('Net/IDN/Encode.pm', 'Internationalized Domain Name (IDN)'); $host = Net::IDN::Encode::domain_to_ascii($host); } my $proxy = $self->{proxy}; my $no_proxy = $self->{no_proxy}; if ($proxy && $no_proxy) { if ($self->match_no_proxy($no_proxy, $host)) { undef $proxy; } } local $SIG{PIPE} = 'IGNORE'; my $sock = $self->{connection_pool}->steal($host, $port); my $in_keepalive = defined $sock; if(!$in_keepalive) { my $err_reason; if ($proxy) { my (undef, $proxy_user, $proxy_pass, $proxy_host, $proxy_port, undef) = $self->_parse_url($proxy); my $proxy_authorization; if (defined $proxy_user) { _requires('MIME/Base64.pm', 'Basic auth'); $proxy_authorization = 'Basic ' . MIME::Base64::encode_base64("$proxy_user:$proxy_pass",""); } if ($scheme eq 'http') { ($sock, $err_reason) = $self->connect($proxy_host, $proxy_port, $timeout_at); if (defined $proxy_authorization) { $self->{proxy_authorization} = $proxy_authorization; } } else { ($sock, $err_reason) = $self->connect_ssl_over_proxy( $proxy_host, $proxy_port, $host, $port, $timeout_at, $proxy_authorization); } } else { if ($scheme eq 'http') { ($sock, $err_reason) = $self->connect($host, $port, $timeout_at); } else { ($sock, $err_reason) = $self->connect_ssl($host, $port, $timeout_at); } } return $self->_r500($err_reason) unless $sock; } # keep request dump my ($req_headers, $req_content) = ("", ""); # write request my $method = $args{method} || 'GET'; my $connection_header = $self->{connection_header}; my $cookie_jar = $self->{cookie_jar}; { my @headers = @{$self->{headers}}; $connection_header = 'close' if $method eq 'HEAD'; if (my $in_headers = $args{headers}) { for (my $i = 0; $i < @$in_headers; $i += 2) { my $name = $in_headers->[$i]; if (lc($name) eq 'connection') { $connection_header = $in_headers->[$i + 1]; } else { push @headers, $name, $in_headers->[$i + 1]; } } } unshift @headers, 'Connection', $connection_header; if (exists $self->{proxy_authorization}) { push @headers, 'Proxy-Authorization', $self->{proxy_authorization}; } if (defined $username) { _requires('MIME/Base64.pm', 'Basic auth'); push @headers, 'Authorization', 'Basic ' . MIME::Base64::encode_base64("${username}:${password}",""); } # set Cookie header if (defined $cookie_jar) { my $url; if ($args{url}) { $url = $args{url}; } else { $url = join( '', $args{scheme}, '://', $args{host}, (exists($args{port}) ? ":$args{port}" : ()), exists($args{path_query}) ? $args{path_query} : '/', ); } push @headers, 'Cookie' => $cookie_jar->cookie_header($url); } my $content = $args{content}; my $content_is_fh = 0; if(defined $content) { $content_is_fh = Scalar::Util::openhandle($content); if(!$content_is_fh && ref $content) { $content = $self->make_x_www_form_urlencoded($content); if(!defined _header_get(\@headers, 'Content-Type')) { push @headers, 'Content-Type' => 'application/x-www-form-urlencoded'; } } if(!defined _header_get(\@headers, 'Content-Length')) { my $content_length; if($content_is_fh) { my $assert = sub { $_[0] or Carp::croak( "Failed to $_[1] for Content-Length: $!", ); }; $assert->(defined(my $cur_pos = tell($content)), 'tell'); $assert->(seek($content, 0, SEEK_END), 'seek'); $assert->(defined(my $end_pos = tell($content)), 'tell'); $assert->(seek($content, $cur_pos, SEEK_SET), 'seek'); $content_length = $end_pos - $cur_pos; } else { $content_length = length($content); } push @headers, 'Content-Length' => $content_length; } } # finally, set Host header my $request_target = ($port == $default_port) ? $host : "$host:$port"; push @headers, 'Host' => $request_target; my $request_uri = $proxy && $scheme eq 'http' ? "$scheme://$request_target$path_query" : $path_query; my $p = "$method $request_uri HTTP/1.1\015\012"; for (my $i = 0; $i < @headers; $i += 2) { my $val = $headers[ $i + 1 ]; # the de facto standard way to handle [\015\012](by kazuho-san) $val =~ tr/\015\012/ /; $p .= "$headers[$i]: $val\015\012"; } $p .= "\015\012"; $self->write_all($sock, $p, $timeout_at) or return $self->_r500( "Failed to send HTTP request: " . _strerror_or_timeout()); if ($self->{capture_request}) { $req_headers = $p; } if (defined $content) { if ($content_is_fh) { my $ret; my $buf; SENDFILE: while (1) { $ret = read($content, $buf, $self->{bufsize}); if (not defined $ret) { Carp::croak("Failed to read request content: $!"); } elsif ($ret == 0) { # EOF last SENDFILE; } $self->write_all($sock, $buf, $timeout_at) or return $self->_r500( "Failed to send content: " . _strerror_or_timeout() ); if ($self->{capture_request}) { $req_content .= $buf; } } } else { # simple string if (length($content) > 0) { $self->write_all($sock, $content, $timeout_at) or return $self->_r500( "Failed to send content: " . _strerror_or_timeout() ); if ($self->{capture_request}) { $req_content = $content; } } } } } # read response my $buf = ''; my $rest_header; my $res_minor_version; my $res_status; my $res_msg; my $res_headers; my $special_headers = $args{special_headers} || +{}; $special_headers->{'connection'} = ''; $special_headers->{'content-length'} = undef; $special_headers->{'location'} = ''; $special_headers->{'content-encoding'} = ''; $special_headers->{'transfer-encoding'} = ''; LOOP: while (1) { my $n = $self->read_timeout($sock, \$buf, $self->{bufsize}, length($buf), $timeout_at); if(!$n) { # error or eof if ($in_keepalive && length($buf) == 0 && (defined($n) || $!==ECONNRESET || (WIN32 && $! == ECONNABORTED))) { # the server closes the connection (maybe because of keep-alive timeout) return $self->request(%args); } return $self->_r500( !defined($n) ? "Cannot read response header: " . _strerror_or_timeout() : "Unexpected EOF while reading response header" ); } else { my $ret; ( $ret, $res_minor_version, $res_status, $res_msg, $res_headers ) = HTTP::Parser::XS::parse_http_response( $buf, $self->{header_format}, $special_headers ); if ( $ret == -1 ) { return $self->_r500("Invalid HTTP response"); } elsif ( $ret == -2 ) { # partial response next LOOP; } else { # succeeded $rest_header = substr( $buf, $ret ); last LOOP; } } } my $max_redirects = 0; my $do_redirect = undef; if ($special_headers->{location}) { $max_redirects = defined($args{max_redirects}) ? $args{max_redirects} : $self->{max_redirects}; $do_redirect = $max_redirects && $res_status =~ /^30[1237]$/; } my $res_content = ''; unless ($do_redirect) { if (my $fh = $args{write_file}) { $res_content = Furl::FileStream->new( $fh ); } elsif (my $coderef = $args{write_code}) { $res_content = Furl::CallbackStream->new( sub { $coderef->($res_status, $res_msg, $res_headers, @_) } ); } } if (exists $COMPRESSED{ $special_headers->{'content-encoding'} }) { _requires('Furl/ZlibStream.pm', 'Content-Encoding', 'Compress::Raw::Zlib'); $res_content = Furl::ZlibStream->new($res_content); } my $chunked = ($special_headers->{'transfer-encoding'} eq 'chunked'); my $content_length = $special_headers->{'content-length'}; if (defined($content_length) && $content_length !~ /\A[0-9]+\z/) { return $self->_r500("Bad Content-Length: ${content_length}"); } unless ($method eq 'HEAD' || ($res_status < 200 && $res_status >= 100) || $res_status == 204 || $res_status == 304) { my @err; if ( $chunked ) { @err = $self->_read_body_chunked($sock, \$res_content, $rest_header, $timeout_at); } else { $res_content .= $rest_header; if (ref $res_content || !defined($content_length)) { @err = $self->_read_body_normal($sock, \$res_content, length($rest_header), $content_length, $timeout_at); } else { @err = $self->_read_body_normal_to_string_buffer($sock, \$res_content, length($rest_header), $content_length, $timeout_at); } } if(@err) { return @err; } } # manage connection cache (i.e. keep-alive) if (lc($connection_header) eq 'keep-alive') { my $connection = lc $special_headers->{'connection'}; if (($res_minor_version == 0 ? $connection eq 'keep-alive' # HTTP/1.0 needs explicit keep-alive : $connection ne 'close') # HTTP/1.1 can keep alive by default && ( defined $content_length or $chunked)) { $self->{connection_pool}->push($host, $port, $sock); } } # explicitly close here, just after returning the socket to the pool, # since it might be reused in the upcoming recursive call undef $sock; # process 'Set-Cookie' header. if (defined $cookie_jar) { my $req_url = join( '', $scheme, '://', (defined($username) && defined($password) ? "${username}:${password}@" : ()), "$host:${port}${path_query}", ); my $cookies = $res_headers->{'set-cookie'}; $cookies = [$cookies] if !ref$cookies; for my $cookie (@$cookies) { $cookie_jar->add($req_url, $cookie); } } if ($do_redirect) { my $location = $special_headers->{location}; unless ($location =~ m{^[a-z0-9]+://}) { # RFC 2616 14.30 says Location header is absolute URI. # But, a lot of servers return relative URI. _requires("URI.pm", "redirect with relative url"); $location = URI->new_abs($location, "$scheme://$host:$port$path_query")->as_string; } # Note: RFC 1945 and RFC 2068 specify that the client is not allowed # to change the method on the redirected request. However, most # existing user agent implementations treat 302 as if it were a 303 # response, performing a GET on the Location field-value regardless # of the original request method. The status codes 303 and 307 have # been added for servers that wish to make unambiguously clear which # kind of reaction is expected of the client. return $self->request( @_, method => ($res_status eq '301' or $res_status eq '307') ? $method : 'GET', url => $location, max_redirects => $max_redirects - 1, ); } # return response. if (ref $res_content) { $res_content = $res_content->get_response_string; } return ( $res_minor_version, $res_status, $res_msg, $res_headers, $res_content, $req_headers, $req_content, undef, undef, [$scheme, $username, $password, $host, $port, $path_query], ); } # connects to $host:$port and returns $socket sub connect :method { my($self, $host, $port, $timeout_at) = @_; my $sock; my $timeout = $timeout_at - time; return (undef, "Failed to resolve host name: timeout") if $timeout <= 0; my ($sock_addr, $err_reason) = $self->_get_address($host, $port, $timeout); return (undef, "Cannot resolve host name: $host (port: $port), " . ($err_reason || $!)) unless $sock_addr; RETRY: socket($sock, Socket::sockaddr_family($sock_addr), SOCK_STREAM, 0) or Carp::croak("Cannot create socket: $!"); _set_sockopts($sock); if (connect($sock, $sock_addr)) { # connected } elsif ($! == EINPROGRESS || (WIN32 && $! == EWOULDBLOCK)) { $self->do_select(1, $sock, $timeout_at) or return (undef, "Cannot connect to ${host}:${port}: timeout"); # connected } else { if ($! == EINTR && ! $self->{stop_if}->()) { close $sock; goto RETRY; } return (undef, "Cannot connect to ${host}:${port}: $!"); } $sock; } sub _get_address { my ($self, $host, $port, $timeout) = @_; if ($self->{get_address}) { return $self->{get_address}->($host, $port, $timeout); } # default rule (TODO add support for IPv6) my $iaddr = $self->{inet_aton}->($host, $timeout) or return (undef, $!); pack_sockaddr_in($port, $iaddr); } sub _ssl_opts { my $self = shift; my $ssl_opts = $self->{ssl_opts}; unless (exists $ssl_opts->{SSL_verify_mode}) { # set SSL_VERIFY_PEER as default. $ssl_opts->{SSL_verify_mode} = IO::Socket::SSL::SSL_VERIFY_PEER(); unless (exists $ssl_opts->{SSL_verifycn_scheme}) { $ssl_opts->{SSL_verifycn_scheme} = 'www' } } if ($ssl_opts->{SSL_verify_mode}) { unless (exists $ssl_opts->{SSL_ca_file} || exists $ssl_opts->{SSL_ca_path}) { require Mozilla::CA; $ssl_opts->{SSL_ca_file} = Mozilla::CA::SSL_ca_file(); } } $ssl_opts; } # connect SSL socket. # You can override this method in your child class, if you want to use Crypt::SSLeay or some other library. # @return file handle like object sub connect_ssl { my ($self, $host, $port, $timeout_at) = @_; _requires('IO/Socket/SSL.pm', 'SSL'); my ($sock, $err_reason) = $self->connect($host, $port, $timeout_at); return (undef, $err_reason) unless $sock; my $timeout = $timeout_at - time; return (undef, "Cannot create SSL connection: timeout") if $timeout <= 0; my $ssl_opts = $self->_ssl_opts; IO::Socket::SSL->start_SSL( $sock, PeerHost => $host, PeerPort => $port, Timeout => $timeout, %$ssl_opts, ) or return (undef, "Cannot create SSL connection: " . IO::Socket::SSL::errstr()); _set_sockopts($sock); $sock; } sub connect_ssl_over_proxy { my ($self, $proxy_host, $proxy_port, $host, $port, $timeout_at, $proxy_authorization) = @_; _requires('IO/Socket/SSL.pm', 'SSL'); my $sock = $self->connect($proxy_host, $proxy_port, $timeout_at); my $p = "CONNECT $host:$port HTTP/1.0\015\012Server: $host\015\012"; if (defined $proxy_authorization) { $p .= "Proxy-Authorization: $proxy_authorization\015\012"; } $p .= "\015\012"; $self->write_all($sock, $p, $timeout_at) or return $self->_r500( "Failed to send HTTP request to proxy: " . _strerror_or_timeout()); my $buf = ''; my $read = $self->read_timeout($sock, \$buf, $self->{bufsize}, length($buf), $timeout_at); if (not defined $read) { return (undef, "Cannot read proxy response: " . _strerror_or_timeout()); } elsif ( $read == 0 ) { # eof return (undef, "Unexpected EOF while reading proxy response"); } elsif ( $buf !~ /^HTTP\/1\.[0-9] 200 .+\015\012/ ) { return (undef, "Invalid HTTP Response via proxy"); } my $timeout = $timeout_at - time; return (undef, "Cannot start SSL connection: timeout") if $timeout_at <= 0; my $ssl_opts = $self->_ssl_opts; unless (exists $ssl_opts->{SSL_verifycn_name}) { $ssl_opts->{SSL_verifycn_name} = $host; } IO::Socket::SSL->start_SSL( $sock, PeerHost => $host, PeerPort => $port, Timeout => $timeout, %$ssl_opts ) or return (undef, "Cannot start SSL connection: " . IO::Socket::SSL::errstr()); _set_sockopts($sock); # just in case (20101118 kazuho) $sock; } sub _read_body_chunked { my ($self, $sock, $res_content, $rest_header, $timeout_at) = @_; my $buf = $rest_header; READ_LOOP: while (1) { if ( my ( $header, $next_len ) = ( $buf =~ m{\A ( # header ( [0-9a-fA-F]+ ) # next_len (hex number) (?:; $HTTP_TOKEN = (?: $HTTP_TOKEN | $HTTP_QUOTED_STRING ) )* # optional chunk-extensions [ ]* # www.yahoo.com adds spaces here. # Is this valid? \015\012 # CR+LF ) }xmso ) ) { $buf = substr($buf, length($header)); # remove header from buf $next_len = hex($next_len); if ($next_len == 0) { last READ_LOOP; } # +2 means trailing CRLF READ_CHUNK: while ( $next_len+2 > length($buf) ) { my $n = $self->read_timeout( $sock, \$buf, $self->{bufsize}, length($buf), $timeout_at ); if (!$n) { return $self->_r500( !defined($n) ? "Cannot read chunk: " . _strerror_or_timeout() : "Unexpected EOF while reading packets" ); } } $$res_content .= substr($buf, 0, $next_len); $buf = substr($buf, $next_len+2); if (length($buf) > 0) { next; # re-parse header } } my $n = $self->read_timeout( $sock, \$buf, $self->{bufsize}, length($buf), $timeout_at ); if (!$n) { return $self->_r500( !defined($n) ? "Cannot read chunk: " . _strerror_or_timeout() : "Unexpected EOF while reading packets" ); } } # read last CRLF return $self->_read_body_normal( $sock, \$buf, length($buf), 2, $timeout_at); } sub _read_body_normal { my ($self, $sock, $res_content, $nread, $res_content_length, $timeout_at) = @_; while (!defined($res_content_length) || $res_content_length != $nread) { my $n = $self->read_timeout( $sock, \my $buf, $self->{bufsize}, 0, $timeout_at ); if (!$n) { last if ! defined($res_content_length); return $self->_r500( !defined($n) ? "Cannot read content body: " . _strerror_or_timeout() : "Unexpected EOF while reading content body" ); } $$res_content .= $buf; $nread += $n; } return; } # This function loads all content at once if it's possible. Since $res_content is just a plain scalar. # Buffering is not needed. sub _read_body_normal_to_string_buffer { my ($self, $sock, $res_content, $nread, $res_content_length, $timeout_at) = @_; while ($res_content_length != $nread) { my $n = $self->read_timeout( $sock, $res_content, $res_content_length, $nread, $timeout_at ); if (!$n) { return $self->_r500( !defined($n) ? "Cannot read content body: " . _strerror_or_timeout() : "Unexpected EOF while reading content body" ); } $nread += $n; } return; } # returns true if the socket is ready to read, false if timeout has occurred ($! will be cleared upon timeout) sub do_select { my($self, $is_write, $sock, $timeout_at) = @_; my $now = time; my $inactivity_timeout_at = $now + $self->{inactivity_timeout}; $timeout_at = $inactivity_timeout_at if $timeout_at > $inactivity_timeout_at; # wait for data while (1) { my $timeout = $timeout_at - $now; if ($timeout <= 0) { $! = 0; return 0; } my($rfd, $wfd); my $efd = ''; vec($efd, fileno($sock), 1) = 1; if ($is_write) { $wfd = $efd; } else { $rfd = $efd; } my $nfound = select($rfd, $wfd, $efd, $timeout); return 1 if $nfound > 0; return 0 if $nfound == -1 && $! == EINTR && $self->{stop_if}->(); $now = time; } die 'not reached'; } # returns (positive) number of bytes read, or undef if the socket is to be closed sub read_timeout { my ($self, $sock, $buf, $len, $off, $timeout_at) = @_; my $ret; # NOTE: select-read-select may get stuck in SSL, # so we use read-select-read instead. while(1) { # try to do the IO defined($ret = sysread($sock, $$buf, $len, $off)) and return $ret; if ($! == EAGAIN || $! == EWOULDBLOCK || (WIN32 && $! == EISCONN)) { # passthru } elsif ($! == EINTR) { return undef if $self->{stop_if}->(); # otherwise passthru } else { return undef; } # on EINTER/EAGAIN/EWOULDBLOCK $self->do_select(0, $sock, $timeout_at) or return undef; } } # returns (positive) number of bytes written, or undef if the socket is to be closed sub write_timeout { my ($self, $sock, $buf, $len, $off, $timeout_at) = @_; my $ret; while(1) { # try to do the IO defined($ret = syswrite($sock, $buf, $len, $off)) and return $ret; if ($! == EAGAIN || $! == EWOULDBLOCK || (WIN32 && $! == EISCONN)) { # passthru } elsif ($! == EINTR) { return undef if $self->{stop_if}->(); # otherwise passthru } else { return undef; } $self->do_select(1, $sock, $timeout_at) or return undef; } } # writes all data in buf and returns number of bytes written or undef if failed sub write_all { my ($self, $sock, $buf, $timeout_at) = @_; my $off = 0; while (my $len = length($buf) - $off) { my $ret = $self->write_timeout($sock, $buf, $len, $off, $timeout_at) or return undef; $off += $ret; } return $off; } sub _r500 { my($self, $message) = @_; $message = Carp::shortmess($message); # add lineno and filename return(0, 500, "Internal Response: $message", [ 'Content-Length' => length($message), 'X-Internal-Response' => 1, # XXX ^^ EXPERIMENTAL header. Do not depend to this. ], $message ); } sub _strerror_or_timeout { $! != 0 ? "$!" : 'timeout'; } sub _set_sockopts { my $sock = shift; setsockopt( $sock, IPPROTO_TCP, TCP_NODELAY, 1 ) or Carp::croak("Failed to setsockopt(TCP_NODELAY): $!"); if (WIN32) { if (ref($sock) ne 'IO::Socket::SSL') { my $tmp = 1; ioctl( $sock, 0x8004667E, \$tmp ) or Carp::croak("Cannot set flags for the socket: $!"); } } else { my $flags = fcntl( $sock, F_GETFL, 0 ) or Carp::croak("Cannot get flags for the socket: $!"); $flags = fcntl( $sock, F_SETFL, $flags | O_NONBLOCK ) or Carp::croak("Cannot set flags for the socket: $!"); } { # no buffering my $orig = select(); select($sock); $|=1; select($orig); } binmode $sock; } # You can override this method if you want to use more powerful matcher. sub match_no_proxy { my ( $self, $no_proxy, $host ) = @_; # ref. curl.1. # list of host names that shouldn't go through any proxy. # If set to a asterisk '*' only, it matches all hosts. if ( $no_proxy eq '*' ) { return 1; } else { for my $pat ( split /\s*,\s*/, lc $no_proxy ) { if ( $host =~ /\Q$pat\E$/ ) { # suffix match(same behavior with LWP) return 1; } } } return 0; } # utility class { package # hide from pause Furl::FileStream; use overload '.=' => 'append', fallback => 1; sub new { my ($class, $fh) = @_; bless {fh => $fh}, $class; } sub append { my($self, $partial) = @_; print {$self->{fh}} $partial; return $self; } sub get_response_string { undef } } { package # hide from pause Furl::CallbackStream; use overload '.=' => 'append', fallback => 1; sub new { my ($class, $cb) = @_; bless {cb => $cb}, $class; } sub append { my($self, $partial) = @_; $self->{cb}->($partial); return $self; } sub get_response_string { undef } } 1; __END__ =for stopwords sockaddr =encoding utf8 =head1 NAME Furl::HTTP - Low level interface to Furl =head1 SYNOPSIS use Furl; my $furl = Furl::HTTP->new( agent => 'MyGreatUA/2.0', timeout => 10, ); my ($minor_version, $code, $msg, $headers, $body) = $furl->request( method => 'GET', host => 'example.com', port => 80, path_query => '/' ); # or # Accept-Encoding is supported but optional $furl = Furl->new( headers => [ 'Accept-Encoding' => 'gzip' ], ); my $body = $furl->get('http://example.com/some/compressed'); =head1 DESCRIPTION Furl is yet another HTTP client library. LWP is the de facto standard HTTP client for Perl 5, but it is too slow for some critical jobs, and too complex for weekend hacking. Furl resolves these issues. Enjoy it! =head1 INTERFACE =head2 Class Methods =head3 C<< Furl::HTTP->new(%args | \%args) :Furl >> Creates and returns a new Furl client with I<%args>. Dies on errors. I<%args> might be: =over =item agent :Str = "Furl/$VERSION" =item timeout :Int = 10 Seconds until the call to $furl->request returns a timeout error (as an internally generated 500 error). The timeout might not be accurate since some underlying modules / built-ins function may block longer than the specified timeout. See the FAQ for how to support timeout during name resolution. =item inactivity_timeout :Int = 600 An inactivity timer for TCP read/write (in seconds). $furl->request returns a timeout error if no additional data arrives (or is sent) within the specified threshold. =item max_redirects :Int = 7 =item proxy :Str =item no_proxy :Str =item headers :ArrayRef =item header_format :Int = HEADERS_AS_ARRAYREF This option choose return value format of C<< $furl->request >>. This option allows HEADERS_NONE or HEADERS_AS_ARRAYREF. B is a default value. This makes B<$headers> as ArrayRef. B makes B<$headers> as undef. Furl does not return parsing result of headers. You should take needed headers from B. =item connection_pool :Object This is the connection pool object for keep-alive requests. By default, it is a instance of L. You may not customize this variable otherwise to use L. This attribute requires a duck type object. It has two methods, C<< $obj->steal($host, $port >> and C<< $obj->push($host, $port, $sock) >>. =item stop_if :CodeRef A callback function that is called by Furl after when a blocking function call returns EINTR. Furl will abort the HTTP request and return immediately if the callback returns true. Otherwise the operation is continued (the default behaviour). =item get_address :CodeRef A callback function to override the default address resolution logic. Takes three arguments: ($hostname, $port, $timeout_in_seconds) and returns: ($sockaddr, $errReason). If the returned $sockaddr is undef, then the resolution is considered as a failure and $errReason is propagated to the caller. =item inet_aton :CodeRef Deprecated. New applications should use B instead. A callback function to customize name resolution. Takes two arguments: ($hostname, $timeout_in_seconds). If omitted, Furl calls L. =item ssl_opts :HashRef SSL configuration used on https requests, passed directly to C<< IO::Socket::SSL->new() >>, for example: use IO::Socket::SSL; my $ua = Furl::HTTP->new( ssl_opts => { SSL_verify_mode => SSL_VERIFY_PEER(), }, }); See L for details. =back =head2 Instance Methods =head3 C<< $furl->request(%args) :($protocol_minor_version, $code, $msg, \@headers, $body) >> Sends an HTTP request to a specified URL and returns a protocol minor version, status code, status message, response headers, response body respectively. I<%args> might be: =over =item scheme :Str = "http" Protocol scheme. May be C or C. =item host :Str Server host to connect. You must specify at least C or C. =item port :Int = 80 Server port to connect. The default is 80 on C<< scheme => 'http' >>, or 443 on C<< scheme => 'https' >>. =item path_query :Str = "/" Path and query to request. =item url :Str URL to request. You can use C instead of C, C, C and C. =item headers :ArrayRef HTTP request headers. e.g. C<< headers => [ 'Accept-Encoding' => 'gzip' ] >>. =item content : Str | ArrayRef[Str] | HashRef[Str] | FileHandle Content to request. =item write_file : FileHandle If this parameter is set, the response content will be saved here instead of in the response object. It's like a C<:content_file> in L. =item write_code : CodeRef If a callback is provided with the "write_code" option then this function will be called for each chunk of the response content as it is received from the server. It's like a C<:content_cb> in L. =back The C method assumes the first argument to be an instance of C if the arguments are an odd number: my $req = HTTP::Request->new(...); my @res = $furl->request($req); # allowed You must encode all the queries or this method will die, saying C. =head3 C<< $furl->get($url :Str, $headers :ArrayRef[Str] ) >> This is an easy-to-use alias to C, sending the C method. =head3 C<< $furl->head($url :Str, $headers :ArrayRef[Str] ) >> This is an easy-to-use alias to C, sending the C method. =head3 C<< $furl->post($url :Str, $headers :ArrayRef[Str], $content :Any) >> This is an easy-to-use alias to C, sending the C method. =head3 C<< $furl->put($url :Str, $headers :ArrayRef[Str], $content :Any) >> This is an easy-to-use alias to C, sending the C method. =head3 C<< $furl->delete($url :Str, $headers :ArrayRef[Str] ) >> This is an easy-to-use alias to C, sending the C method. =head1 FAQ =over 4 =item Why IO::Socket::SSL? Net::SSL is not well documented. =item Why is env_proxy optional? Environment variables are highly dependent on each users' environment, and we think it may confuse users when something doesn't go right. =item What operating systems are supported? Linux 2.6 or higher, OSX Tiger or higher, Windows XP or higher. And other operating systems will be supported if you send a patch. =item Why doesn't Furl support chunked upload? There are reasons why chunked POST/PUTs should not be used in general. First, you cannot send chunked requests unless the peer server at the other end of the established TCP connection is known to be a HTTP/1.1 server. Second, HTTP/1.1 servers disconnect their persistent connection quite quickly (compared to the time they wait for the first request), so it is not a good idea to post non-idempotent requests (e.g. POST, PUT, etc.) as a succeeding request over persistent connections. These facts together makes using chunked requests virtually impossible (unless you _know_ that the server supports HTTP/1.1), and this is why we decided that supporting the feature is NOT of high priority. =item How do you build the response content as it arrives? You can use L for this purpose. my $fh = IO::Callback->new( '<', sub { my $x = shift @data; $x ? "-$x" : undef; } ); my ( $code, $msg, $headers, $content ) = $furl->put( "http://127.0.0.1:$port/", [ 'Content-Length' => $len ], $fh, ); =item How do you use gzip/deflate compressed communication? Add an B header to your request. Furl inflates response bodies transparently according to the B response header. =item How do you use multipart/form-data? You can use multipart/form-data with L. use HTTP::Request::Common; my $furl = Furl->new(); $req = POST 'http://www.perl.org/survey.cgi', Content_Type => 'form-data', Content => [ name => 'Hiromu Tokunaga', email => 'tokuhirom@example.com', gender => 'F', born => '1978', init => ["$ENV{HOME}/.profile"], ]; $furl->request($req); Native multipart/form-data support for L is available if you can send a patch for me. =item How do you use Keep-Alive and what happens on the HEAD method? Furl supports HTTP/1.1, hence C. However, if you use the HEAD method, the connection is closed immediately. RFC 2616 section 9.4 says: The HEAD method is identical to GET except that the server MUST NOT return a message-body in the response. Some web applications, however, returns message bodies on the HEAD method, which might confuse C processes, so Furl closes connection in such cases. Anyway, the HEAD method is not so useful nowadays. The GET method and C are more suitable to cache HTTP contents. =item Why does Furl take longer than specified until it returns a timeout error? Although Furl itself supports timeout, some underlying modules / functions do not. And the most noticeable one is L, the function used for name resolution (a function that converts host names to IP addresses). If you need accurate and short timeout for name resolution, the use of L is recommended. The following code snippet describes how to use the module in conjunction with Furl. use Net::DNS::Lite qw(); my $furl = Furl->new( timeout => $my_timeout_in_seconds, inet_aton => sub { Net::DNS::Lite::inet_aton(@_) }, ); =item How can I replace Host header instead of hostname? Furl::HTTP does not provide a way to replace the Host header because such a design leads to security issues. If you want to send HTTP requests to a dedicated server (or a UNIX socket), you should use the B callback to designate the peer to which L should connect as B. The example below sends all requests to 127.0.0.1:8080. my $ua = Furl::HTTP->new( get_address => sub { my ($host, $port, $timeout) = @_; pack_sockaddr_in(8080, inet_aton("127.0.0.1")); }, ); my ($minor_version, $code, $msg, $headers, $body) = $furl->request( url => 'http://example.com/foo', method => 'GET' ); =back =head1 TODO - AnyEvent::Furl? - ipv6 support - better docs for NO_PROXY =head1 OPTIONAL FEATURES =head2 Internationalized Domain Name (IDN) This feature requires Net::IDN::Encode. =head2 SSL This feature requires IO::Socket::SSL. =head2 Content-Encoding (deflate, gzip) This feature requires Compress::Raw::Zlib. =head1 DEVELOPMENT To setup your environment: $ git clone http://github.com/tokuhirom/p5-Furl.git $ cd p5-Furl To get picohttpparser: $ git submodule init $ git submodule update $ perl Makefile.PL $ make $ sudo make install =head2 HOW TO CONTRIBUTE Please send the pull request via L. =head1 SEE ALSO L HTTP specs: L L =head1 LICENSE Copyright (C) Tokuhiro Matsuno. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Headers.pm100664001750001750 1022412560625033 17274 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/lib/Furlpackage Furl::Headers; use strict; use warnings; use utf8; use Carp (); sub new { my ($class, $headers) = @_; # $headers is HashRef or ArrayRef my $self = {}; if (ref $headers eq 'ARRAY') { my @h = @$headers; # copy while (my ($k, $v) = splice @h, 0, 2) { push @{$self->{lc $k}}, $v; } } elsif(ref $headers eq 'HASH') { while (my ($k, $v) = each %$headers) { push @{$self->{$k}}, ref($v) eq 'ARRAY' ? @$v : $v; } } else { Carp::confess($class . ': $headers must be an ARRAY or HASH reference'); } bless $self, $class; } sub header { my ($self, $key, $new) = @_; if ($new) { # setter $new = [$new] unless ref $new; $self->{lc $key} = $new; return; } else { my $val = $self->{lc $key}; return unless $val; return wantarray ? @$val : join(", ", @$val); } } sub remove_header { my ($self, $key) = @_; delete $self->{lc $key}; } sub flatten { my $self = shift; my @ret; while (my ($k, $v) = each %$self) { for my $e (@$v) { push @ret, $k, $e; } } return @ret; } sub keys :method { my $self = shift; keys %$self; } sub header_field_names { shift->keys } sub as_string { my $self = shift; my $ret = ''; for my $k (sort keys %$self) { for my $e (@{$self->{$k}}) { $ret .= "$k: $e\015\012"; } } return $ret; } sub as_http_headers { my ($self, $key) = @_; require HTTP::Headers; return HTTP::Headers->new($self->flatten); } # shortcut for popular headers. sub referer { [ shift->header( 'Referer' => @_ ) ]->[0] } sub expires { [ shift->header( 'Expires' => @_ ) ]->[0] } sub last_modified { [ shift->header( 'Last-Modified' => @_ ) ]->[0] } sub if_modified_since { [ shift->header( 'If-Modified-Since' => @_ ) ]->[0] } sub content_type { [ shift->header( 'Content-Type' => @_ ) ]->[0] } sub content_length { [ shift->header( 'Content-Length' => @_ ) ]->[0] } sub content_encoding { [ shift->header( 'Content-Encoding' => @_ ) ]->[0] } sub clone { require Storable; Storable::dclone($_[0]); } 1; __END__ =head1 NAME Furl::Headers - HTTP Headers object =head1 SYNOPSIS =head1 CONSTRUCTOR =over 4 =item my $headers = Furl::Headers->new(\%headers); The constructor takes one argument. It is a hashref. Every key of hashref must be lower-cased. The format of the argument is like following: +{ 'content-length' => [30], 'set-cookies' => ['auth_token=; path=/; expires=Thu, 01 Jan 1970 00:00:00 GMT', '_twitter_sess=JKLJBNBLKSFJBLKSJBLKSJLKJFLSDJFjkDKFUFIOSDUFSDVjOTUzNzUwNTE2%250AZWFiMWRiNDZhMDcwOWEwMWQ5IgpmbGFzaElDOidBY3Rpb25Db250cm9sbGVy%250AOjpGbGFzaDo6Rmxhc2hIYXNoewAGOgpAdXNlZHsA--d9ce07496a22525bc178jlkhafklsdjflajfl411; domain=.twitter.com; path=/'], } =back =head1 INSTANCE METHODS =over 4 =item my @values = $headers->header($key); Get the header value in array. =item my $values_joined = $headers->header($key); Get the header value in scalar. This is not a first value of header. This is same as: my $values = join(", ", $headers->header($key)) =item $headers->header($key, $val); =item $headers->header($key, \@val); Set the new value of headers. =item $headers->remove_header($key); Delete key from headers. =item my @h = $headers->flatten(); Gets pairs of keys and values. =item my @keys = $headers->keys(); =item my @keys = $headers->header_field_names(); Returns keys of headers in array. The return value do not contains duplicated value. =item my $str = $headers->as_string(); Return the header fields as a formatted MIME header. =item my $val = $headers->referer() =item my $val = $headers->expires() =item my $val = $headers->last_modified() =item my $val = $headers->if_modified_since() =item my $val = $headers->content_type() =item my $val = $headers->content_length() =item my $val = $headers->content_encoding() These methods are shortcut for popular headers. =item $headers->clone(); Returns a copy of this "Furl::Headers" object. =back =head1 SEE ALSO L =cut Request.pm100664001750001750 1055412560625033 17357 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/lib/Furlpackage Furl::Request; use strict; use warnings; use utf8; use Class::Accessor::Lite; use Furl::Headers; use Furl::HTTP; Class::Accessor::Lite->mk_accessors(qw/ method uri protocol headers content /); sub new { my $class = shift; my ($method, $uri, $headers, $content) = @_; unless (defined $headers) { $headers = +{}; } unless (defined $content) { $content = ''; } bless +{ method => $method, uri => $uri, headers => Furl::Headers->new($headers), content => $content, }, $class; } sub parse { my $class = shift; my $raw_request = shift; # I didn't use HTTP::Parser::XS for following reasons: # 1. parse_http_request() function omits request content, but need to deal it. # 2. this function parses header to PSGI env, but env/header mapping is troublesome. return unless $raw_request =~ s!^(.+) (.+) (HTTP/1.\d+)\s*!!; my ($method, $uri, $protocol) = ($1, $2, $3); my ($header_str, $content) = split /\015?\012\015?\012/, $raw_request, 2; my $headers = +{}; for (split /\015?\012/, $header_str) { tr/\015\012//d; my ($k, $v) = split /\s*:\s*/, $_, 2; $headers->{lc $k} = $v; # complete host_port if (lc $k eq 'host') { $uri = $v . $uri; } } unless ($uri =~ /^http/) { $uri = "http://$uri"; } my $req = $class->new($method, $uri, $headers, $content); $req->protocol($protocol); return $req; } # alias *body = \&content; # shorthand sub content_length { shift->headers->content_length } sub content_type { shift->headers->content_type } sub header { shift->headers->header(@_) } sub request_line { my $self = shift; my $path_query = $self->uri . ''; # for URI.pm $path_query =~ s!^https?://[^/]+!!; my $method = $self->method || ''; my $protocol = $self->protocol || ''; return "$method $path_query $protocol"; } sub as_http_request { my $self = shift; require HTTP::Request; my $req = HTTP::Request->new( $self->method, $self->uri, [ $self->headers->flatten ], $self->content, ); $req->protocol($self->protocol); return $req; } sub as_hashref { my $self = shift; return +{ method => $self->method, uri => $self->uri, protocol => $self->protocol, headers => [ $self->headers->flatten ], content => $self->content, }; } sub as_string { my $self = shift; join("\015\012", $self->method . ' ' . $self->uri . (defined($self->protocol) ? ' ' . $self->protocol : ''), $self->headers->as_string, ref($self->content) =~ qr{\A(?:ARRAY|HASH)\z} ? Furl::HTTP->make_x_www_form_urlencoded($self->content) : $self->content, ); } 1; __END__ =head1 NAME Furl::Request - Request object for Furl =head1 SYNOPSIS my $f = Furl->new; my $req = Furl::Request->new($method, $uri, $headers, $content); my $res = $f->request($req); print $req->request_line, "\n"; my $http_req = $req->as_http_request; my $req_hash = $req->as_hashref; =head1 DESCRIPTION This is a HTTP request object in Furl. =head1 CONSTRUCTOR my $req = Furl::Request->new($method, $uri); # or my $req = Furl::Request->new($method, $uri, \%headers); # or my $req = Furl::Request->new($method, $uri, \%headers, $content); # and my $req = Furl::Request->parse($http_request_raw_string); =head1 INSTANCE METHODS =over 4 =item $req->method($method) Gets/Sets HTTP request method =item $req->uri($uri) Gets/Sets request URI =item $req->headers($headers) Gets/Sets instance of L =item $req->content($content) =item $req->body($content) Gets/Sets request body in scalar. =item $req->protocol($protocol) $req->protocol('HTTP/1.1'); print $req->protocol; #=> "HTTP/1.1" Gets/Sets HTTP protocol in string. =item $req->content_length =item $req->content_type =item $req->header Shorthand to access L. =item $req->as_http_request Make instance of L from L. =item $req->as_hashref Convert request object to HashRef. Format is following: method: Str uri: Str protocol: Str headers: ArrayRef[Str] content: Str =item $req->request_line print $req->request_line; #=> "GET / HTTP/1.1" Returns HTTP request line. =back Response.pm100664001750001750 1712312560625033 17524 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/lib/Furlpackage Furl::Response; use strict; use warnings; use utf8; use Furl::Headers; sub new { my ($class, $minor_version, $code, $message, $headers, $content) = @_; bless { minor_version => $minor_version, code => $code, message => $message, headers => Furl::Headers->new($headers), content => $content, }, $class; } # DO NOT CALL this method DIRECTLY. sub set_request_info { my ($self, $request_src, $captured_req_headers, $captured_req_content) = @_; $self->{request_src} = $request_src; if (defined $captured_req_headers) { $self->{captured_req_headers} = $captured_req_headers; $self->{captured_req_content} = $captured_req_content; } else { $self->{captured_req_headers} = undef; $self->{captured_req_content} = undef; } return; } sub captured_req_headers { my $self = shift; unless (exists $self->{captured_req_headers}) { Carp::croak("You can't call cpatured_req_headers method without 'capture_request' options for Furl#new"); } return $self->{captured_req_headers}; } sub captured_req_content { my $self = shift; unless (exists $self->{captured_req_content}) { Carp::croak("You can't call cpatured_req_content method without 'capture_request' options for Furl#new"); } return $self->{captured_req_content}; } # accessors sub code { shift->{code} } sub message { shift->{message} } sub headers { shift->{headers} } sub content { shift->{content} } sub request { my $self = shift; if (!exists $self->{request}) { if (!exists $self->{request_src}) { Carp::croak("This request object does not have a request information"); } # my ($method, $uri, $headers, $content) = @_; $self->{request} = Furl::Request->new( $self->{request_src}->{method}, $self->{request_src}->{url}, $self->{request_src}->{headers}, $self->{request_src}->{content}, ); } return $self->{request}; } # alias sub status { shift->code() } sub body { shift->content() } # shorthand sub content_length { shift->headers->content_length() } sub content_type { shift->headers->content_type() } sub content_encoding { shift->headers->content_encoding() } sub header { shift->headers->header(@_) } sub protocol { "HTTP/1." . $_[0]->{minor_version} } sub decoded_content { my $self = shift; my $cloned = $self->headers->clone; # 'HTTP::Message::decoded_content' tries to decompress content # if response header contains 'Content-Encoding' field. # However 'Furl' decompresses content by itself, 'Content-Encoding' field # whose value is supported encoding type should be removed from response header. my @removed = grep { ! m{\b(?:gzip|x-gzip|deflate)\b} } $cloned->header('content-encoding'); $cloned->header('content-encoding', \@removed); $self->_as_http_response_internal([ $cloned->flatten ])->decoded_content(@_); } sub as_http_response { my ($self) = @_; return $self->_as_http_response_internal([ $self->headers->flatten ]) } sub _as_http_response_internal { my ($self, $flatten_headers) = @_; require HTTP::Response; my $res = HTTP::Response->new( $self->code, $self->message, $flatten_headers, $self->content ); $res->protocol($self->protocol); if ($self->{request_src} || $self->{request}) { if (my $req = $self->request) { $res->request($req->as_http_request); } } return $res; } sub to_psgi { my ($self) = @_; return [ $self->code, [$self->headers->flatten], [$self->content] ]; } sub as_string { my ($self) = @_; return join("", $self->status_line . "\015\012", $self->headers->as_string, "\015\012", $self->content, ); } sub as_hashref { my $self = shift; return +{ code => $self->code, message => $self->message, protocol => $self->protocol, headers => [$self->headers->flatten], content => $self->content, }; } sub is_success { substr( $_[0]->code, 0, 1 ) eq '2' } sub status_line { $_[0]->code . ' ' . $_[0]->message } sub charset { my $self = shift; return $self->{__charset} if exists $self->{__charset}; if ($self->can('content_charset')){ # To suppress: # Parsing of undecoded UTF-8 will give garbage when decoding entities local $SIG{__WARN__} = sub {}; my $charset = $self->content_charset; $self->{__charset} = $charset; return $charset; } my $content_type = $self->headers->header('Content-Type'); return unless $content_type; $content_type =~ /charset=([A-Za-z0-9_\-]+)/io; $self->{__charset} = $1 || undef; # Detect charset from HTML unless (defined($self->{__charset}) && $self->content_type =~ m{text/html}) { # I guess, this is not so perfect regexp. patches welcome. # # $self->content =~ m!/]+)['"]\s*/?>!smi; $self->{__charset} = $1; } $self->{__charset}; } sub encoder { require Encode; my $self = shift; return $self->{__encoder} if exists $self->{__encoder}; my $charset = $self->charset or return; my $enc = Encode::find_encoding($charset); $self->{__encoder} = $enc; } sub encoding { my $enc = shift->encoder or return; $enc->name; } 1; __END__ =encoding utf-8 =for stopwords charsets =head1 NAME Furl::Response - Response object for Furl =head1 SYNOPSIS my $res = Furl::Response->new($minor_version, $code, $message, $headers, $content); print $res->status, "\n"; =head1 DESCRIPTION This is a HTTP response object in Furl. =head1 CONSTRUCTOR my $res = Furl::Response->new($minor_version, $code, $msg, \%headers, $content); =head1 INSTANCE METHODS =over 4 =item $res->code =item $res->status Returns HTTP status code. =item $res->message Returns HTTP status message. =item $res->headers Returns instance of L =item $res->content =item $res->body Returns response body in scalar. =item $res->decoded_content This will return the content after any C<< Content-Encoding >> and charsets have been decoded. See L<< HTTP::Message >> for details =item $res->request Returns instance of L related this response. =item $res->content_length =item $res->content_type =item $res->content_encoding =item $res->header Shorthand to access L. =item $res->protocol $res->protocol(); # => "HTTP/1.1" Returns HTTP protocol in string. =item $res->as_http_response Make instance of L from L. =item $res->to_psgi() Convert object to L response. It's very useful to make proxy. =item $res->as_hashref() Convert response object to HashRef. Format is following: code: Int message: Str protocol: Str headers: ArrayRef[Str] content: Str =item $res->is_success Returns true if status code is 2xx. =item $res->status_line $res->status_line() # => "200 OK" Returns status line. =item my $headers = $res->captured_req_headers() : Str Captured request headers in raw string. This method is only for debugging. You can use this method if you are using C<< capture_request >> parameter is true. =item my $content = $res->captured_req_content() : Str Captured request content in raw string. This method is only for debugging. You can use this method if you are using C<< capture_request >> parameter is true. =back ZlibStream.pm100664001750001750 151212560625033 17755 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/lib/Furlpackage Furl::ZlibStream; # internal class. use strict; use warnings; use overload '.=' => 'append', fallback => 1; use Carp (); use Compress::Raw::Zlib qw(Z_OK Z_STREAM_END); sub new { my ( $class, $buffer ) = @_; my ( $zlib, $status ) = Compress::Raw::Zlib::Inflate->new( -WindowBits => Compress::Raw::Zlib::WANT_GZIP_OR_ZLIB(), ); $status == Z_OK or Carp::croak("Cannot initialize zlib: $status"); bless { buffer => $buffer, zlib => $zlib }, $class; } sub append { my ( $self, $partial ) = @_; my $status = $self->{zlib}->inflate( $partial, \my $deflated ); ($status == Z_OK or $status == Z_STREAM_END) or Carp::croak("Uncompress error: $status"); $self->{buffer} .= $deflated; return $self; } sub get_response_string { ref $_[0]->{buffer} ? undef : $_[0]->{buffer} } 1; 00_compile.t100664001750001750 44712560625033 16232 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/tuse strict; use Test::More tests => 1; BEGIN { use_ok 'Furl' } diag "Perl/$^V"; diag "Furl/$Furl::VERSION"; for my $optional(qw( Net::IDN::Encode IO::Socket::SSL Compress::Raw::Zlib )) { eval qq{ require $optional }; diag $optional . '/' . ($optional->VERSION || '(not installed)'); } 01_version.t100664001750001750 21112560625033 16255 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/tuse strict; use warnings; use utf8; use Test::More; use Furl::HTTP; use Furl; is($Furl::VERSION, $Furl::HTTP::VERSION); done_testing; 01_simple.t100664001750001750 340712560625033 17274 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/t/100_lowuse strict; use warnings; use Furl::HTTP; use Test::TCP; use Test::More; use t::HTTPServer; my $n = shift(@ARGV) || 3; test_tcp( client => sub { my $port = shift; my $furl = Furl::HTTP->new(bufsize => 10, timeout => 3); for (1 .. $n) { my ( undef, $code, $msg, $headers, $content ) = $furl->request( port => $port, path_query => '/foo', host => '127.0.0.1', headers => [ "X-Foo" => "ppp" ] ); is $code, 200, "request()/$_"; is $msg, "OK"; is Furl::HTTP::_header_get($headers, 'Content-Length'), 4, 'header' or diag(explain($headers)); is $content, '/foo' or do{ require Devel::Peek; Devel::Peek::Dump($content) }; } for (1..3) { my $path_query = '/foo/bar?a=b;c=d&e=f'; my ( undef, $code, $msg, $headers, $content ) = $furl->request(url => "http://127.0.0.1:$port$path_query", method => 'GET'); is $code, 200, "get()/$_"; is $msg, "OK"; is Furl::HTTP::_header_get($headers, 'Content-Length'), length($path_query), 'header'; is $content, $path_query; } done_testing; }, server => sub { my $port = shift; t::HTTPServer->new(port => $port)->run(sub {; my $env = shift; is $env->{HTTP_X_FOO}, "ppp" if $env->{REQUEST_URI} eq '/foo'; like $env->{'HTTP_USER_AGENT'}, qr/\A Furl::HTTP /xms; return [ 200, [ 'Content-Length' => length($env->{REQUEST_URI}) ], [$env->{REQUEST_URI}] ]; }); } ); 03_redirect.t100664001750001750 713212560625033 17605 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/t/100_lowuse strict; use warnings; use Furl::HTTP; use Test::TCP; use Test::More; use Test::Requires qw(Plack::Request HTTP::Body), 'Plack::Loader', 'Plack::Request'; use Plack::Loader; use Plack::Request; $ENV{LANG} = 'C'; test_tcp( client => sub { my $port = shift; subtest 'redirect' => sub { my $furl = Furl::HTTP->new(); my ( undef, $code, $msg, $headers, $content ) = $furl->request( url => "http://127.0.0.1:$port/1", ); is $code, 200; is $msg, "OK"; is Furl::HTTP::_header_get($headers, 'Content-Length'), 2; is $content, 'OK'; }; subtest 'not enough redirect' => sub { my $furl = Furl::HTTP->new(max_redirects => 0); my ( undef, $code, $msg, $headers, $content ) = $furl->request( url => "http://127.0.0.1:$port/1", ); is $code, 302; is $msg, 'Found'; is Furl::HTTP::_header_get($headers, 'Content-Length'), 0; is Furl::HTTP::_header_get($headers, 'Location'), "http://127.0.0.1:$port/2"; is $content, ''; }; subtest 'over max redirect' => sub { my $max_redirects = 7; my $furl = Furl::HTTP->new(max_redirects => $max_redirects); my $start_num = 4; my ( undef, $code, $msg, $headers, $content ) = $furl->request( url => "http://127.0.0.1:$port/$start_num"); is $code, 302, 'code ok'; is $msg, 'Found', 'msg ok'; is Furl::HTTP::_header_get($headers, 'Content-Length'), 0, 'content length ok'; is Furl::HTTP::_header_get($headers, 'Location'), "http://127.0.0.1:$port/" . ( $max_redirects + $start_num + 1 ), 'url ok'; is $content, '', 'content ok'; }; subtest 'POST redirects' => sub { my $furl = Furl::HTTP->new(); my ( undef, undef, undef, undef, $content ) = $furl->post("http://127.0.0.1:$port/301", [], ""); is $content, 'POST', 'POST into 301 results in a POST'; ( undef, undef, undef, undef, $content ) = $furl->post("http://127.0.0.1:$port/302", [], ""); is $content, 'GET', 'POST into 302 is implemented as 303'; ( undef, undef, undef, undef, $content ) = $furl->post("http://127.0.0.1:$port/303", [], ""); is $content, 'GET', 'POST into 303 results in a GET'; ( undef, undef, undef, undef, $content ) = $furl->post("http://127.0.0.1:$port/307", [], ""); is $content, 'POST', 'POST into 307 results in a POST'; }; done_testing; }, server => sub { my $port = shift; Plack::Loader->auto(port => $port)->run(sub { my $env = shift; my $req = Plack::Request->new($env); $req->path_info =~ m{/(\d+)$} or die; my $id = $1; if ($id == 3) { return [ 200, [ 'Content-Length' => 2 ], ['OK'] ]; } elsif ($id =~ /^3\d\d$/) { my $base = $req->base; $base->path("/200"); # redirect target, see below return [ $id, [ 'Location' => $base->as_string ] ]; } elsif ($id == 200) { # redirect target, see above my $method = $req->method; return [ 200, [ 'Content-Length' => length $method ], [$method] ]; } else { my $base = $req->base; $base->path('/' . ($id + 1)); return [ 302, ['Location' => $base->as_string], []]; } }); } ); 04_chunked.t100664001750001750 273212560625033 17427 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/t/100_lowuse strict; use warnings; use Test::TCP; use Test::More; use Furl::HTTP; use t::HTTPServer; my $s = q{The quick brown fox jumps over the lazy dog.\n}; my $chunk = sprintf qq{%x;foo=bar;baz="qux"\015\012%s\015\012}, length($s), $s; test_tcp( client => sub { my $port = shift; my $furl = Furl::HTTP->new(bufsize => 80); # some httpd(e.g. ASP.NET) returns 00000000 as chunked end. for my $chunk_end (qw(0 00000000)) { for my $i(1, 3, 1024) { note "-- TEST (packets: $i)"; my ( undef, $code, $msg, $headers, $content ) = $furl->request( port => $port, path => '/', host => '127.0.0.1', headers => ['X-Packet-Size', $i, 'X-Chunck-End' => $chunk_end], ); is $code, 200, 'status'; is $content, $s x $i, 'content'; } } done_testing; }, server => sub { my $port = shift; t::HTTPServer->new( port => $port, enable_chunked => 0 )->run( sub { my $env = shift; my $size = $env->{HTTP_X_PACKET_SIZE} or die '???'; my $end_mark = $env->{HTTP_X_CHUNCK_END}; return [ 200, [ 'Transfer-Encoding' => 'chunked' ], [ $chunk x $size, $end_mark, "\015\012" x 2 ] ]; } ); } ); 05_slowloris.t100664001750001750 315712560625033 20046 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/t/100_lowuse strict; use warnings; use Furl::HTTP; use Test::TCP; use Test::More; use Test::Requires qw(Plack::Request HTTP::Body), 'Plack'; use Plack::Request; use t::Slowloris; my $n = shift(@ARGV) || 3; test_tcp( client => sub { my $port = shift; my $furl = Furl::HTTP->new(); for (1..$n) { my ( undef, $code, $msg, $headers, $content ) = $furl->request( port => $port, path_query => '/foo', host => '127.0.0.1', headers => [ "X-Foo" => "ppp" ] ); is $code, 200, "request()/$_"; is $msg, "OK"; is Furl::HTTP::_header_get($headers, 'Content-Length'), 4; is $content, '/foo'; } for (1..3) { my $path_query = '/bar?a=b;c=d&e=f'; my ( undef, $code, $msg, $headers, $content ) = $furl->request(url => "http://127.0.0.1:$port$path_query", method => 'GET'); is $code, 200, "get()/$_"; is $msg, "OK"; is Furl::HTTP::_header_get($headers, 'Content-Length'), length($path_query); is $content, $path_query; } done_testing; }, server => sub { my $port = shift; Slowloris::Server->new(port => $port)->run(sub { my $env = shift; is $env->{'HTTP_X_FOO'}, "ppp" if $env->{REQUEST_URI} eq '/foo'; return [ 200, [ 'Content-Length' => length($env->{REQUEST_URI}) ], [$env->{REQUEST_URI}] ]; }); } ); 06_errors.t100664001750001750 500512560625033 17320 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/t/100_lowuse strict; use warnings; use Furl::HTTP; use Test::TCP; use Test::More; use Test::Requires qw(Plack::Request HTTP::Body), 'Plack'; use Plack::Request; use Errno (); { my $furl = Furl::HTTP->new(); eval { $furl->request(); }; like $@, qr/missing host name/i, 'missuse'; eval { $furl->request(url => 'ftp://ftp.example.com/', method => 'GET'); }; like $@, qr/unsupported scheme/i, 'missuse'; foreach my $bad_url(qw( hogehoge http://example.com:80foobar http://example.com: )) { eval { $furl->request(url => $bad_url, method => 'GET'); }; like $@, qr/malformed URL/, "malformed URL: $bad_url"; } } my $n = shift(@ARGV) || 3; my $fail_on_syswrite = 1; { package Errorneous::Socket; use parent qw(IO::Socket::INET); sub syswrite { my($sock, $buff, $len, $off) = @_; if($fail_on_syswrite) { $sock->SUPER::syswrite($buff, $len - 1, $off); close $sock; $! = Errno::EPIPE; return undef; } return $sock->SUPER::syswrite($buff, $len, $off); } package Errorneous::Server; use parent qw(HTTP::Server::PSGI); sub setup_listener { my $self = shift; $self->SUPER::setup_listener(@_); bless $self->{listen_sock}, 'Errorneous::Socket'; ::note 'Errorneous::Server listening'; } } test_tcp( client => sub { my $port = shift; my $furl = Furl::HTTP->new(); for (1..$n) { my ( undef, $code, $msg, $headers, $content ) = $furl->request( port => $port, path_query => '/foo', host => '127.0.0.1', headers => [ "X-Foo" => "ppp" ] ); is $code, 500, "request()/$_"; like $msg, qr/Internal Response: Unexpected EOF while reading response header/; is ref($headers), "ARRAY"; ok $content, 'content: ' . $content; } done_testing; }, server => sub { my $port = shift; Errorneous::Server->new(port => $port)->run(sub { my $env = shift; #note explain $env; my $req = Plack::Request->new($env); is $req->header('X-Foo'), "ppp" if $env->{REQUEST_URI} eq '/foo'; return [ 200, [ 'Content-Length' => length($env->{REQUEST_URI}) ], [$env->{REQUEST_URI}] ]; }); } ); 07_timeout.t100664001750001750 632012560625033 17474 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/t/100_lowuse strict; use warnings; use Furl::HTTP; use Test::TCP; use Test::More; use Time::HiRes qw(time); use Test::Requires qw(Plack::Util Plack::Request HTTP::Body), 'Plack::Request', 'Plack::Loader'; use t::Slowloris; my $n = shift(@ARGV) || 2; $Slowloris::SleepBeforeRead = 1; $Slowloris::SleepBeforeWrite = 3; test_tcp( client => sub { my $port = shift; my $furl = Furl::HTTP->new(timeout => 1.5); note 'read_timeout'; for (1 .. $n) { my $start_at = time; my ( undef, $code, $msg, $headers, $content ) = $furl->request( port => $port, path_query => '/foo', host => '127.0.0.1', ); my $elapsed = time - $start_at; is $code, 500, "request()/$_"; like $msg, qr/Internal Response: Cannot read response header: timeout/; is ref($headers), "ARRAY"; ok $content, 'content: ' . $content; ok 1.3 <= $elapsed && $elapsed <= 2; } $furl = Furl::HTTP->new(timeout => 0.5); note 'write_timeout'; my $CONTENT_SIZE_MB_MAX = 256; WRITE_TIMEOUT_TEST: for (1 .. $n) { my $content_size_mb = 1; my ($elapsed, $code, $msg, $headers, $content); while(1) { note "Try sending $content_size_mb MiB content."; my $start_at = time; ( undef, $code, $msg, $headers, $content ) = $furl->request( host => '127.0.0.1', port => $port, method => 'POST', path_query => '/foo', content => do { # should be larger than SO_SNDBUF + SO_RCVBUF + TCP_window_size my $content = "0123456789abcdef" x 64 x 1024 x $content_size_mb; open my $fh, '<', \$content or die "oops"; $fh; }, ); $elapsed = time - $start_at; if($msg !~ qr/Internal Response: Cannot read response header: timeout/) { ## It's not read timeout. It seems OK. last; } if($content_size_mb >= $CONTENT_SIZE_MB_MAX) { fail "send $content_size_mb MiB but still write timeout did not occur."; next WRITE_TIMEOUT_TEST; } note "Read timeout. Retry with more POST content"; $content_size_mb *= 2; } is $code, 500, "request()/$_"; like $msg, qr/Internal Response: Failed to send content: timeout/; is ref($headers), "ARRAY"; is Plack::Util::header_get($headers, 'X-Internal-Response'), 1; ok $content, 'content: ' . $content; ok 0.4 <= $elapsed && $elapsed <= 1; } done_testing; }, server => sub { my $port = shift; Slowloris::Server->new(port => $port)->run(sub { my $env = shift; return [ 200, [], [$env->{REQUEST_URI}] ]; }); } ); 08_proxy.t100664001750001750 1261412560625033 17213 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/t/100_lowuse strict; use warnings; use Furl::HTTP; use Test::TCP; use Test::Requires qw(Plack::Request HTTP::Body), 'Plack'; use Plack::Loader; use Test::More; use Plack::Request; use Test::Requires qw(Plack::Request HTTP::Body), 'HTTP::Proxy'; plan tests => (10*2 + 8)*3; my $verbose = 1; { package Test::HTTP::Proxy; use parent qw(HTTP::Proxy); sub log { my($self, $level, $prefix, $msg) = @_; ::note "$prefix: $msg" if $verbose; } } { package Test::UserAgent; use parent qw(LWP::UserAgent); use Test::More; sub real_httpd_port { my ($self, $port) = @_; $self->{httpd_port} = $port if defined $port; return $self->{httpd_port}; } sub simple_request { my ($self, $req, @args) = @_; my $uri = $req->uri; my $host = $req->header('Host'); if ($self->real_httpd_port) { # test for URL with a default port like $uri.q(), qr!^http://[^:]+/!, 'No port number in the request line'; unlike $host, qr!:!, 'No port number in Host header'; # replace the port number to correctly connect to the test server $uri->port($self->real_httpd_port); } else { # test for URL with non-default port like $uri.q(), qr!^http://[^/]+:[0-9]+/!, 'A port number in the request line'; like $host, qr/:[0-9]+$/, 'A port number in Host header'; } return $self->SUPER::simple_request($req, @args); } } my $via = "VIA!VIA!VIA!"; my $httpd = Test::TCP->new(code => sub { my $httpd_port = shift; Plack::Loader->auto(port => $httpd_port)->run(sub { my $env = shift; my $req = Plack::Request->new($env); is $req->path, '/foo'; is $req->header('X-Foo'), "ppp"; like $req->header('User-Agent'), qr/\A Furl::HTTP /xms; my $content = "Hello, foo"; return [ 200, [ 'Content-Length' => length($content) ], [ $content ] ]; }); }); sub client (%) { my (%args) = @_; for (1..3) { # run some times for testing keep-alive. my $furl = Furl::HTTP->new(proxy => $args{proxy}); my ( undef, $code, $msg, $headers, $content ) = $furl->request( url => $args{request}, headers => [ "X-Foo" => "ppp" ] ); is $code, 200, "request()"; is $msg, "OK"; is Furl::HTTP::_header_get($headers, 'Content-Length'), 10; is Furl::HTTP::_header_get($headers, 'Via'), $args{via}; is $content, 'Hello, foo' or do{ require Devel::Peek; Devel::Peek::Dump($content) }; } } sub test_agent () { return Test::UserAgent->new( env_proxy => 1, keep_alive => 2, parse_head => 0, ); } local $ENV{'HTTP_PROXY'} = ''; # Request target with non-default port test_tcp( client => sub { my $proxy_port = shift; my $httpd_port = $httpd->port; client( proxy => "http://127.0.0.1:$proxy_port", request => "http://127.0.0.1:$httpd_port/foo", via => '1.0 VIA!VIA!VIA!', ); }, server => sub { # proxy server my $proxy_port = shift; my $proxy = Test::HTTP::Proxy->new(port => $proxy_port, via => $via); $proxy->agent(test_agent); $proxy->start(); }, ); # Request target with default port test_tcp( client => sub { my $proxy_port = shift; my $httpd_port = $httpd->port; client( proxy => "http://127.0.0.1:$proxy_port", request => "http://127.0.0.1/foo", # default port via => '1.0 VIA!VIA!VIA!', ); }, server => sub { # proxy server my $proxy_port = shift; my $proxy = Test::HTTP::Proxy->new(port => $proxy_port, via => $via); $proxy->agent(test_agent); $proxy->agent->real_httpd_port($httpd->port); $proxy->start(); }, ); # SSL over proxy test_tcp( client => sub { # emulate CONNECT for SSL proxying without a real SSL connection no warnings 'redefine'; local *Furl::HTTP::connect_ssl_over_proxy = sub { my ($self, $proxy_host, $proxy_port, $host, $port, $timeout_at, $proxy_authorization) = @_; my $sock = $self->connect($proxy_host, $proxy_port, $timeout_at); my $p = "CONNECT $host:$port HTTP/1.0\015\012Server: $host\015\012"; $p .= "\015\012"; $self->write_all($sock, $p, $timeout_at) or fail; # read the entire response of CONNECT method my $buf = ''; while ($buf !~ qr!(?:\015\012){2}!) { my $read = $self->read_timeout( $sock, \$buf, $self->{bufsize}, length($buf), $timeout_at ); defined $read or fail; $read != 0 or fail; } $sock; }; my $proxy_port = shift; my $httpd_port = $httpd->port; client( proxy => "http://127.0.0.1:$proxy_port", request => "https://127.0.0.1:$httpd_port/foo", # no via since the request goes directly to the origin server ); }, server => sub { # proxy server my $proxy_port = shift; my $proxy = Test::HTTP::Proxy->new(port => $proxy_port, via => $via); $proxy->start(); }, ); 09_body.t100664001750001750 515412560625033 16751 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/t/100_lowuse strict; use warnings; use Furl::HTTP; use Test::TCP; use Test::Requires qw(Plack::Request HTTP::Body), 'Plack'; use Plack::Loader; use Test::More; use Fcntl qw(SEEK_SET); use Plack::Request; test_tcp( client => sub { my $port = shift; my $furl = Furl::HTTP->new(bufsize => 80); for my $x(1, 1000) { my $req_content = "WOWOW!" x $x; note 'request content length: ', length $req_content; open my $req_content_fh, '<', \$req_content or die "oops"; my ( undef, $code, $msg, $headers, $content ) = $furl->request( method => 'POST', port => $port, path_query => '/foo', host => '127.0.0.1', headers => [ "X-Foo" => "ppp" ], content => $req_content_fh, ); is $code, 200, "request()"; is $msg, "OK"; is Furl::HTTP::_header_get($headers, 'Content-Length'), length($req_content); is $content, $req_content or do{ require Devel::Peek; Devel::Peek::Dump($content) }; } { open my $req_content_fh, '<', $0 or die "oops"; note 'request $0: ', -s $req_content_fh; my $req_content = do{ local $/; <$req_content_fh> }; seek $req_content_fh, 0, SEEK_SET; my ( undef, $code, $msg, $headers, $content ) = $furl->request( method => 'POST', port => $port, path_query => '/foo', host => '127.0.0.1', headers => [ "X-Foo" => "ppp" ], content => $req_content_fh, ); is $code, 200, "request()"; is $msg, "OK"; is Furl::HTTP::_header_get($headers, 'Content-Length'), length($req_content); is $content, $req_content or do{ require Devel::Peek; Devel::Peek::Dump($content) }; } done_testing; }, server => sub { my $port = shift; Plack::Loader->auto(port => $port)->run(sub { my $env = shift; #note explain $env; my $req = Plack::Request->new($env); is $req->header('X-Foo'), "ppp" if $env->{REQUEST_URI} eq '/foo'; like $req->header('User-Agent'), qr/\A Furl::HTTP /xms; return [ 200, [ 'Content-Length' => length($req->content) ], [$req->content] ]; }); } ); 11_write_file.t100664001750001750 210112560625033 20123 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/t/100_lowuse strict; use warnings; use Furl::HTTP; use Test::TCP; use Test::Requires qw(Plack::Request HTTP::Body), 'Plack'; use Plack::Loader; use Test::More; use Plack::Request; use File::Temp; use Fcntl qw/:seek/; test_tcp( client => sub { my $port = shift; my $furl = Furl::HTTP->new(); my $tmp = File::Temp->new(UNLINK => 1); my ( undef, $code, $msg, $headers, ) = $furl->request( port => $port, path_query => '/foo', host => '127.0.0.1', write_file => $tmp, ); is $code, 200, "request()"; seek $tmp, 0, SEEK_SET; my $content = do { local $/; <$tmp> }; is $content, "OK!YAY!"; done_testing; }, server => sub { my $port = shift; Plack::Loader->auto(port => $port)->run(sub { my $env = shift; my $content = "OK!YAY!"; return [ 200, [ 'Content-Length' => length($content) ], [$content] ]; }); } ); 12_write_code.t100664001750001750 175312560625033 20133 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/t/100_lowuse strict; use warnings; use Furl::HTTP; use Test::TCP; use Test::Requires qw(Plack::Request HTTP::Body), 'Plack'; use Plack::Loader; use Test::More; use Plack::Request; use File::Temp; use Fcntl qw/:seek/; test_tcp( client => sub { my $port = shift; my $furl = Furl::HTTP->new(); my $content; my ( undef, $code, $msg, $headers, ) = $furl->request( port => $port, path_query => '/foo', host => '127.0.0.1', write_code => sub { $content .= $_[3] }, ); is $code, 200, "request()"; is $content, "OK!YAY!"; done_testing; }, server => sub { my $port = shift; Plack::Loader->auto(port => $port)->run(sub { my $env = shift; my $content = "OK!YAY!"; return [ 200, [ 'Content-Length' => length($content) ], [$content] ]; }); } ); 13_deflate.t100664001750001750 602312560625033 17407 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/t/100_lowuse strict; use warnings; use Test::Requires qw(Plack::Request HTTP::Body), 'Plack'; use Test::Requires qw(Plack::Request HTTP::Body), 'Plack::Middleware::Deflater', 'Compress::Raw::Zlib'; use Furl; use Furl::HTTP; use Test::TCP; use Test::More; use Plack::Request; use File::Temp; use t::Slowloris; my $n = 10; my $CONTENT = 'OK! YAY!' x 100; test_tcp( client => sub { my $port = shift; for my $encoding (qw/gzip deflate/) { my $furl = Furl::HTTP->new( headers => ['Accept-Encoding' => $encoding], ); for(1 .. $n) { note "normal $_ $encoding"; my ( undef, $code, $msg, $headers, $content ) = $furl->request( url => "http://127.0.0.1:$port/", ); is $code, 200, "request()"; is Furl::HTTP::_header_get($headers, 'content-encoding'), $encoding; is($content, $CONTENT) or do { require Devel::Peek; Devel::Peek::Dump($content) }; } for(1 .. $n) { note "to filehandle $_ $encoding"; open my $fh, '>', \my $content; my ( undef, $code, $msg, $headers ) = $furl->request( url => "http://127.0.0.1:$port/", write_file => $fh, ); is $code, 200, "request()"; is Furl::HTTP::_header_get($headers, 'content-encoding'), $encoding; is($content, $CONTENT) or do { require Devel::Peek; Devel::Peek::Dump($content) }; } for(1 .. $n){ note "to callback $_ $encoding"; my $content = ''; my ( undef, $code, $msg, $headers ) = $furl->request( url => "http://127.0.0.1:$port/", write_code => sub { $content .= $_[3] }, ); is $code, 200, "request()"; is Furl::HTTP::_header_get($headers, 'content-encoding'), $encoding; is($content, $CONTENT) or do { require Devel::Peek; Devel::Peek::Dump($content) }; } for(1 .. $n){ note "decoded_content $_"; my $res = Furl->new( headers => ['Accept-Encoding' => $encoding] )->get("http://127.0.0.1:$port/"); ok defined($res->decoded_content); } } done_testing; }, server => sub { my $port = shift; Slowloris::Server->new( port => $port )->run( Plack::Middleware::Deflater->wrap( sub { my $env = shift; like $env->{HTTP_USER_AGENT}, qr/\A Furl::HTTP/xms; return [ 200, [ 'Content-Length' => length($CONTENT) ], [$CONTENT] ]; } ) ); } ); 15_multiline_header.t100664001750001750 153612560625033 21323 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/t/100_lowuse strict; use warnings; use Furl::HTTP; use Test::TCP; use Test::Requires qw(Plack::Request HTTP::Body), 'Plack'; use Plack::Loader; use Test::More; use Plack::Request; use File::Temp; use Fcntl qw/:seek/; test_tcp( client => sub { my $port = shift; my $furl = Furl::HTTP->new(); my ( undef, $status, $msg, $headers, $body ) = $furl->request( url => "http://127.0.0.1:$port/", headers => [ 'X-Foo' => "bar\015\012baz" ], method => 'GET' ); is $status, 200; done_testing; }, server => sub { my $port = shift; Plack::Loader->auto( port => $port )->run( sub { my $req = Plack::Request->new(shift); is $req->header('X-Foo'), "bar baz"; return [ 200, [ 'Content-Length' => 2 ], ['OK'] ]; } ); } ); 16_read_callback.t100664001750001750 232012560625033 20531 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/t/100_lowuse strict; use warnings; use Furl::HTTP; use Test::TCP; use Test::Requires qw(Plack::Request HTTP::Body), 'Plack'; use Plack::Loader; use Test::More; use Plack::Request; use Test::Requires qw(Plack::Request HTTP::Body), 'IO::Callback'; my @data = qw/foo bar baz/; test_tcp( client => sub { my $port = shift; my $furl = Furl::HTTP->new(); my $fh = IO::Callback->new( '<', sub { my $x = shift @data; $x ? "-$x" : undef } ); my ( undef, $code, $msg, $headers, $content ) = $furl->request( method => 'PUT', url => "http://127.0.0.1:$port/", headers => ['Content-Length' => length(join('', map { "-$_" } @data)) ], content => $fh, ); is $code, 200, "request()"; done_testing; }, server => sub { my $port = shift; Plack::Loader->auto(port => $port)->run(sub { my $env = shift; my $req = Plack::Request->new($env); is $req->content, "-foo-bar-baz"; return [ 200, [ 'Content-Length' => length($req->content) ], [$req->content] ]; }); } ); 17_keep_alive.t100664001750001750 256412560625033 20121 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/t/100_lowuse strict; use warnings; use Furl::HTTP; use Test::TCP; use Test::More; use t::HTTPServer; my ($stealed, $pushed) = (0, 0); { package MyConnPool; sub new { bless [], shift } sub steal { $stealed++; undef } sub push { $pushed++; undef } } test_tcp( client => sub { my $port = shift; my $furl = Furl::HTTP->new(connection_pool => MyConnPool->new()); for (1 .. 3) { note "-- TEST $_"; my ( undef, $code, $msg, $headers, $content ) = $furl->request( port => $port, path => '/', host => '127.0.0.1', ); is $code, 200; is $content, 'OK' x 100; } is $stealed, 3, 'stealed'; is $pushed, 3; $pushed = 0; $stealed = 0; $furl->request( method => 'HEAD', port => $port, path => '/', host => '127.0.0.1', ); is $pushed, 0, 'HEAD forces to close connections'; is $stealed, 1; done_testing; }, server => sub { my $port = shift; t::HTTPServer->new( port => $port )->run( sub { my $env = shift; return [ 200, [ ], [ 'OK' x 100 ] ]; } ); } ); 18_no_proxy.t100664001750001750 532412560625033 17670 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/t/100_lowuse strict; use warnings; use Furl::HTTP; use Test::TCP; use Test::Requires qw(Plack::Request HTTP::Body), 'Plack'; use Plack::Loader; use Test::More; use Plack::Request; use Test::Requires qw(Plack::Request HTTP::Body), 'HTTP::Proxy'; plan tests => 4 + 7*3; my $verbose = 1; { package Test::HTTP::Proxy; use parent qw(HTTP::Proxy); sub log { my($self, $level, $prefix, $msg) = @_; ::note "$prefix: $msg" if $verbose; } } { my $furl = Furl::HTTP->new; ok $furl->match_no_proxy(".google.com", "www.google.com"); ok $furl->match_no_proxy("google.com", "www.google.com"); ok $furl->match_no_proxy("google.com,.yahoo.com", "mail.yahoo.com"); ok $furl->match_no_proxy(",twitter.com , facebook.com", "www.twitter.com"); } my $via = "VIA!VIA!VIA!"; test_tcp( client => sub { my $proxy_port = shift; test_tcp( client => sub { # http client my $httpd_port = shift; for (1..3) { # run some times for testing keep-alive. my $furl = Furl::HTTP->new(proxy => "http://127.0.0.1:$proxy_port", no_proxy => "127.0.0.1"); my ( undef,$code, $msg, $headers, $content ) = $furl->request( url => "http://127.0.0.1:$httpd_port/foo", headers => [ "X-Foo" => "ppp" ] ); is $code, 200, "request()"; is $msg, "OK"; is Furl::HTTP::_header_get($headers, 'Content-Length'), 10; isnt Furl::HTTP::_header_get($headers, 'Via'), "1.0 $via", "passing through the proxy"; is $content, 'Hello, foo' or do{ require Devel::Peek; Devel::Peek::Dump($content) }; } }, server => sub { # http server my $httpd_port = shift; Plack::Loader->auto(port => $httpd_port)->run(sub { my $env = shift; my $req = Plack::Request->new($env); is $req->header('X-Foo'), "ppp" if $env->{REQUEST_URI} eq '/foo'; like $req->header('User-Agent'), qr/\A Furl::HTTP /xms; my $content = "Hello, foo"; return [ 200, [ 'Content-Length' => length($content) ], [ $content ] ]; }); }, ); }, server => sub { # proxy server my $proxy_port = shift; my $proxy = Test::HTTP::Proxy->new(port => $proxy_port, via => $via); $proxy->start(); }, ); 19_special_headers.t100664001750001750 322712560625033 21127 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/t/100_lowuse strict; use warnings; use Furl::HTTP; use Test::TCP; use Test::Requires qw(Plack::Request HTTP::Body), 'Plack'; use Plack::Loader; use Test::More; use Plack::Request; my $n = shift(@ARGV) || 3; test_tcp( client => sub { my $port = shift; my $furl = Furl::HTTP->new(bufsize => 10); for (1 .. $n) { my %special_headers = ( 'x-bar' => '', ); my ( undef, $code, $msg, $headers, $content ) = $furl->request( port => $port, path_query => '/foo', host => '127.0.0.1', headers => [ "X-Foo" => "ppp" ], special_headers => \%special_headers, ); is $code, 200, "request()/$_"; is $msg, "OK"; is $special_headers{'content-length'}, 4, 'header' or diag(explain(\%special_headers)); is $special_headers{'x-bar'}, 10; is $content, '/foo' or do{ require Devel::Peek; Devel::Peek::Dump($content) }; } done_testing; }, server => sub { my $port = shift; Plack::Loader->auto(port => $port)->run(sub { my $env = shift; #note explain $env; my $req = Plack::Request->new($env); is $req->header('X-Foo'), "ppp" if $env->{REQUEST_URI} eq '/foo'; like $req->header('User-Agent'), qr/\A Furl::HTTP /xms; return [ 200, [ 'Content-Length' => length($env->{REQUEST_URI}), 'X-Bar' => 10 ], [$env->{REQUEST_URI}] ]; }); } ); 20_header_format_none.t100664001750001750 342012560625033 21616 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/t/100_lowuse strict; use warnings; use Furl::HTTP qw/HEADERS_NONE/; use Test::TCP; use Test::Requires qw(Plack::Request HTTP::Body), 'Plack'; use Plack::Loader; use Test::More; use Plack::Request; my $n = shift(@ARGV) || 3; test_tcp( client => sub { my $port = shift; my $furl = Furl::HTTP->new( bufsize => 10, header_format => HEADERS_NONE, ); for (1 .. $n) { my %special_headers = ( 'x-bar' => '', ); my ( undef, $code, $msg, $headers, $content ) = $furl->request( port => $port, path_query => '/foo', host => '127.0.0.1', headers => [ "X-Foo" => "ppp" ], special_headers => \%special_headers, ); is $code, 200, "request()/$_"; is $msg, "OK"; is $special_headers{'content-length'}, 4, 'header' or diag(explain(\%special_headers)); is $special_headers{'x-bar'}, 10; is $content, '/foo' or do{ require Devel::Peek; Devel::Peek::Dump($content) }; is $headers, undef; } done_testing; }, server => sub { my $port = shift; Plack::Loader->auto(port => $port)->run(sub { my $env = shift; #note explain $env; my $req = Plack::Request->new($env); is $req->header('X-Foo'), "ppp" if $env->{REQUEST_URI} eq '/foo'; like $req->header('User-Agent'), qr/\A Furl::HTTP /xms; return [ 200, [ 'Content-Length' => length($env->{REQUEST_URI}), 'X-Bar' => 10 ], [$env->{REQUEST_URI}] ]; }); } ); 21_keep_alive_timedout.t100664001750001750 262012560625033 22017 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/t/100_low#!perl -w use strict; use warnings; use Furl::HTTP; use Test::TCP; use Test::More; use t::HTTPServer; my $n = shift(@ARGV) || 3; test_tcp( client => sub { my $port = shift; my $furl = Furl::HTTP->new(timeout => 1); for (1 .. $n) { note "request/$_"; my ( undef, $code, $msg, $headers, $content ) = $furl->request( port => $port, path_query => '/foo', host => '127.0.0.1', ); is $code, 200, "request()/$_"; is $msg, "OK"; is Furl::HTTP::_header_get($headers, 'Content-Length'), 2, 'header' or diag(explain($headers)); is Furl::HTTP::_header_get($headers, 'Connection'), 'keep-alive'; is $content, 'OK' or do{ require Devel::Peek; Devel::Peek::Dump($content) }; } done_testing; }, server => sub { my $port = shift; t::HTTPServer->new( port => $port )->add_trigger( "AFTER_HANDLE_REQUEST" => sub { my ( $s, $csock ) = @_; $csock->close(); } )->run( sub { +[ 200, [ 'Content-Length' => 2, 'Connection' => 'keep-alive' ], ['OK'] ]; } ); } ); 22_keep_alive_http10.t100664001750001750 323512560625033 21311 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/t/100_low#!perl -w use strict; use warnings; use Test::Requires { 'Plack::Request' => 0, 'HTTP::Body' => 0, Starlet => 0.11 }; use Furl::HTTP; use Test::TCP; use Test::More; use Starlet::Server; my $n = shift(@ARGV) || 3; my $host = '127.0.0.1'; test_tcp( client => sub { my $port = shift; my $furl = Furl::HTTP->new(); for (1 .. $n) { note "request/$_"; my ( undef, $code, $msg, $headers, $content ) = $furl->request( host => $host, port => $port, path_query => '/foo', ); is $code, 200, "request()/$_"; is $msg, "OK"; is Furl::HTTP::_header_get($headers, 'Content-Length'), 4, 'header' or diag(explain($headers)); is Furl::HTTP::_header_get($headers, 'Connection'), 'keep-alive' or diag(explain($headers)); is $content, '/foo' or do{ require Devel::Peek; Devel::Peek::Dump($content) }; ok defined( $furl->{connection_pool}->steal($host, $port) ), 'in keep-alive'; } done_testing; }, server => sub { my $port = shift; Starlet::Server->new( host => $host, port => $port, max_keepalive_reqs => 10, )->run(sub { my $env = shift; $env->{SERVER_PROTOCOL} = 'HTTP/1.0'; #force response HTTP/1.0 return [ 200, [ 'Content-Length' => length($env->{REQUEST_URI}) ], [$env->{REQUEST_URI}] ]; }); } ); 23_redirect_relative.t100664001750001750 317012560625033 21500 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/t/100_lowuse strict; use warnings; use Furl::HTTP; use Test::TCP; use Test::Requires qw(Plack::Request HTTP::Body), 'Plack'; use Plack::Loader; use Test::More; use Test::Requires qw(Plack::Request HTTP::Body), 'URI'; use Plack::Request; test_tcp( client => sub { my $port = shift; subtest 'redirect' => sub { my $furl = Furl::HTTP->new(); my ( undef, $code, $msg, $headers, $content ) = $furl->request( url => "http://127.0.0.1:$port/foo/" ); is $code, 200; is $msg, "OK"; is Furl::HTTP::_header_get($headers, 'Content-Length'), 2; is $content, 'OK'; }; subtest 'redirect to root' => sub { my $furl = Furl::HTTP->new(max_redirects => 0); my ( undef, $code, $msg, $headers, $content ) = $furl->request( url => "http://127.0.0.1:$port/baz/" ); is $code, 302; is $msg, "Found"; is Furl::HTTP::_header_get($headers, 'location'), "/foo/"; }; done_testing; }, server => sub { my $port = shift; Plack::Loader->auto(port => $port)->run(sub { my $env = shift; my $req = Plack::Request->new($env); if ($env->{PATH_INFO} eq '/foo/bar') { return [ 200, [ 'Content-Length' => 2 ], ['OK'] ]; } elsif ($env->{PATH_INFO} eq '/baz/') { return [ 302, [ 'Location' => '/foo/', 'Content-Length' => 0 ], [] ]; } else { return [ 302, [ 'Location' => './bar', 'Content-Length' => 0 ], [] ]; } }); } ); 24_no_content.t100664001750001750 167212560625033 20160 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/t/100_lowuse strict; use warnings; use Test::More; use Furl::HTTP; use Test::TCP; use t::HTTPServer; my $n = shift(@ARGV) || 3; test_tcp( client => sub { my $port = shift; my $furl = Furl::HTTP->new(bufsize => 10, timeout => 3); for (1 .. $n) { my ( undef, $code, $msg, $headers, $content ) = $furl->request( port => $port, path_query => '/foo', host => '127.0.0.1', content => '', ); is $code, 200, "request()/$_"; is $msg, "OK"; } done_testing; }, server => sub { my $port = shift; t::HTTPServer->new(port => $port)->run(sub {; my $env = shift; return [ 200, [ 'Content-Length' => length($env->{REQUEST_URI}) ], [$env->{REQUEST_URI}] ]; }); } ); 25_signal.t100664001750001750 363012560625033 17264 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/t/100_low# to test "stop_if" use strict; use warnings; use Furl::HTTP; use Test::TCP; use Test::More; use t::HTTPServer; plan skip_all => "Win32 is not supported" if Furl::HTTP::WIN32; my $n = shift(@ARGV) || 3; test_tcp( client => sub { my $port = shift; my $stop_if = 0; my $furl = Furl::HTTP->new( bufsize => 10, stop_if => sub { $stop_if }, ); local $SIG{ALRM} = sub { note "caught ALRM"; }; for (1 .. $n) { note "try it $_ with stop_if=false"; # ignore signal $stop_if = undef; alarm(2); my ($undef, $code, $msg, $headers, $content) = $furl->request( port => $port, path_query => '/', host => '127.0.0.1', ); is $code, 200, "ignore signal ($_)"; alarm(0); sleep(4); # wait until the server stops handling the request # cancel on signal note "try it $_ with stop_if=true"; $stop_if = 1; alarm(2); ($undef, $code, $msg, $headers, $content) = $furl->request( port => $port, path_query => '/5', host => '127.0.0.1', ); is $code, 500, "cancelled ($_)"; alarm(0); sleep(4); # wait until the server stops handling the request } done_testing; }, server => sub { my $port = shift; t::HTTPServer->new(port => $port)->run(sub { my $env = shift; sleep(4); return [ 200, [ 'Content-Type' => 'text/plain', 'Content-Length' => 5, ], [ 'hello' ], ]; }); }, ); 26_headers_only.t100664001750001750 447112560625033 20470 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/t/100_lowuse strict; use warnings; use HTTP::Parser::XS qw(parse_http_request); use IO::Socket::INET; use Test::More; use Furl::HTTP; use Test::TCP; my $n = shift(@ARGV) || 3; test_tcp( client => sub { my $port = shift; my $furl = Furl::HTTP->new( bufsize => 10, timeout => 3, ); for my $req_code (qw(100 199 204 304)) { for (1 .. $n) { my (undef, $code, $msg, $headers, $content) = $furl->request( port => $port, path_query => "/$req_code", host => '127.0.0.1', ); is $code, $req_code, "$msg"; is $content, ''; } } }, server => sub { my $port = shift; my $listen_sock = IO::Socket::INET->new( Listen => 5, LocalHost => '127.0.0.1', LocalPort => $port, ReuseAddr => 1, ) or die $!; MAIN_LOOP: while (1) { my $sock = $listen_sock->accept or next; my $buf = ''; my %env; PARSE_HTTP_REQUEST: while (1) { my $nread = sysread( $sock, $buf, 1048576, length($buf)); $buf =~ s!^(\015\012)*!!; if (! defined $nread) { die "cannot read HTTP request header: $!"; } if ($nread == 0) { # unexpected EOF while reading HTTP request header warn "received a broken HTTP request"; next MAIN_LOOP; } my $ret = parse_http_request($buf, \%env); if ($ret == -2) { # incomplete. next; } elsif ($ret == -1) { # request is broken die "broken HTTP header"; } else { $buf = substr($buf, $ret); last PARSE_HTTP_REQUEST; } } my $code = $env{PATH_INFO} =~ m{^/([0-9]+)$} ? $1 : 200; print $sock '', << "EOT"; HTTP/1.0 $code love\r Connection: close\r Content-Length: 100\r \r you shall never see this message! EOT close $sock; } }, ); done_testing; 27_close_on_eof.t100664001750001750 214112560625033 20437 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/t/100_lowuse strict; use warnings; use Furl::HTTP; use IO::Socket::INET; use Test::More; use Test::TCP; test_tcp( client => sub { my $port = shift; my (undef, $code, undef, undef, $body) = Furl::HTTP->new->request( method => 'GET', host => '127.0.0.1', port => $port, path => '/', ); is $code, 200, 'code'; is $body, 'abcde', 'body'; }, server => sub { my $port = shift; my $listen_sock = IO::Socket::INET->new( Listen => 5, LocalHost => '127.0.0.1', LocalPort => $port, ReuseAddr => 1, ) or die $!; local $SIG{PIPE} = 'IGNORE'; while (1) { my $sock = $listen_sock->accept or next; sysread($sock, my $buf, 1048576, 0); # read request syswrite $sock, join( "\r\n", "HTTP/1.0 200 OK", "Content-Type: text/plain", "", "abcde", ); close $sock; } }, ); done_testing; 28_idn.t100664001750001750 274312560625033 16570 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/t/100_lowuse strict; use warnings; use Furl::HTTP; use t::HTTPServer; use Test::TCP; use Test::More; use Test::Requires qw(Plack::Request HTTP::Body), 'Net::IDN::Encode'; sub test_uses_idn { my %specs = @_; my ($host, $expects, $desc) = @specs{qw/host expects desc/}; subtest $desc => sub { test_tcp( client => sub { my $port = shift; my $furl = Furl::HTTP->new(timeout => 0.3); my $used = 0; no warnings 'redefine'; local *Net::IDN::Encode::domain_to_ascii = sub { $used = 1; return '127.0.0.1', }; my (undef, $code, $msg, $headers, $content) = $furl->request( port => $port, path_query => '/', host => $host, ); is $used, $expects, 'result'; }, server => sub { my $port = shift; t::HTTPServer->new(port => $port)->run(sub { my $env = shift; return [200, [], ['OK']]; }); }, ); }; } test_uses_idn( host => '127.0.0.1', expects => 0, desc => 'local host', ); test_uses_idn( host => '例え.テスト', expects => 1, desc => 'uses idn', ); test_uses_idn( host => '127.0.0._', expects => 0, desc => 'in underscore', ); done_testing; 29_completion_slash.t100664001750001750 704112560625033 21356 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/t/100_lowuse strict; use warnings; use Furl::HTTP; use Test::TCP; use Test::More; use t::HTTPServer; my $server = sub { my $port = shift; t::HTTPServer->new(port => $port)->run(sub { my $env = shift; return [ 200, [ 'Content-Length' => length($env->{REQUEST_URI}) ], [ $env->{REQUEST_URI} ], ]; }); }; note '/foo => /foo'; test_tcp( server => $server, client => sub { my $port = shift; my $furl = Furl::HTTP->new(bufsize => 10, timeout => 3); do { my (undef, $code, $msg, $headers, $content) = $furl->request( port => $port, path_query => '/foo', host => '127.0.0.1', ); is $code, 200, "code"; is $msg, "OK" , "msg"; is $content, "/foo", "return path query"; }; do { my $path_query = '/foo'; my ( undef, $code, $msg, $headers, $content ) = $furl->request( url => "http://127.0.0.1:$port$path_query", method => 'GET', ); is $code, 200, 'code'; is $msg, 'OK', 'msg'; is $content, '/foo'; }; }, ); note 'foo => /foo'; test_tcp( server => $server, client => sub { my $port = shift; my $furl = Furl::HTTP->new(bufsize => 10, timeout => 3); do { my (undef, $code, $msg, $headers, $content) = $furl->request( port => $port, path_query => 'foo', host => '127.0.0.1', ); is $code, 200, 'code'; is $msg, 'OK' , 'msg'; is $content, '/foo', 'return path query'; }; }, ); note '/?foo=bar => /?foo=bar'; test_tcp( server => $server, client => sub { my $port = shift; my $furl = Furl::HTTP->new(bufsize => 10, timeout => 3); do { my (undef, $code, $msg, $headers, $content) = $furl->request( port => $port, path_query => '/?foo=bar', host => '127.0.0.1', ); is $code, 200, 'code'; is $msg, 'OK' , 'msg'; is $content, '/?foo=bar', 'return path query'; }; do { my $path_query = '/?foo=bar'; my ( undef, $code, $msg, $headers, $content ) = $furl->request( url => "http://127.0.0.1:$port$path_query", method => 'GET', ); is $code, 200, 'code'; is $msg, 'OK', 'msg'; is $content, '/?foo=bar'; }; }, ); note '?foo=bar => /?foo=bar'; test_tcp( server => $server, client => sub { my $port = shift; my $furl = Furl::HTTP->new(bufsize => 10, timeout => 3); do { my (undef, $code, $msg, $headers, $content) = $furl->request( port => $port, path_query => '?foo=bar', host => '127.0.0.1', ); is $code, 200, "code"; is $msg, "OK" , "msg"; is $content, "/?foo=bar", "return path query"; }; do { my $path_query = '?foo=bar'; my ( undef, $code, $msg, $headers, $content ) = $furl->request( url => "http://127.0.0.1:$port$path_query", method => 'GET', ); is $code, 200, 'code'; is $msg, 'OK', 'msg'; is $content, '/?foo=bar'; }; }, ); done_testing; 30_user_agent.t100664001750001750 321312560625033 20134 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/t/100_lowuse strict; use warnings; use Furl::HTTP; use Test::TCP; use Test::More; use t::HTTPServer; test_tcp( client => sub { my $port = shift; subtest 'set agent' => sub { my $furl = Furl::HTTP->new(); $furl->agent('foobot'); my ( undef, $code, $msg, $headers, $content ) = $furl->request( url => "http://127.0.0.1:$port/1", ); is $code, 200; is $content, 'foobot'; }; subtest 'set agent at request' => sub { my $furl = Furl::HTTP->new(); my ( undef, $code, $msg, $headers, $content ) = $furl->request( url => "http://127.0.0.1:$port/2", headers => [ "User-Agent" => "foobot" ] ); is $code, 200; like $content, qr/\A Furl::HTTP\/[^,]+,\sfoobot /xms; }; subtest 'set agent and request with agent' => sub { my $furl = Furl::HTTP->new(); $furl->agent('foobot'); my ( undef, $code, $msg, $headers, $content ) = $furl->request( url => "http://127.0.0.1:$port/3", headers => [ "User-Agent" => "barbot" ] ); is $code, 200; is $content, 'foobot, barbot'; }; }, server => sub { my $port = shift; t::HTTPServer->new(port => $port)->run(sub { my $env = shift; return [ 200, [ 'Content-Length' => length($env->{'HTTP_USER_AGENT'}) ], [$env->{'HTTP_USER_AGENT'}] ]; }); } ); done_testing; 31_chunked_unexpected_eof.t100664001750001750 245412560625033 22505 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/t/100_lowuse strict; use warnings; use Furl::HTTP; use IO::Socket::INET; use Test::More; use Test::TCP; my $chunk = "x"x1024; my @res; for ( 1..20) { push @res, '400', $chunk; } test_tcp( client => sub { my $port = shift; my (undef, $code, undef, undef, $body) = Furl::HTTP->new->request( method => 'GET', host => '127.0.0.1', port => $port, path => '/', ); is $code, 500, 'code'; like $body, qr/Unexpected EOF/, 'body'; }, server => sub { my $port = shift; my $listen_sock = IO::Socket::INET->new( Listen => 5, LocalHost => '127.0.0.1', LocalPort => $port, ReuseAddr => 1, ) or die $!; local $SIG{PIPE} = 'IGNORE'; while (1) { my $sock = $listen_sock->accept or next; sysread($sock, my $buf, 1048576, 0); # read request my $n = syswrite $sock, join( "\r\n", "HTTP/1.1 200 OK", "Content-Type: text/plain", "Transfer-Encoding: chunked", "Connection: close", "", @res, "5", ); close $sock; } }, ); done_testing; 32_proxy_auth.t100664001750001750 615712560625033 20216 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/t/100_lowuse strict; use warnings; use Furl::HTTP; use Test::TCP; use Test::Requires qw(Plack::Request HTTP::Body), 'Plack', 'MIME::Base64'; use Plack::Loader; use Test::More; use Plack::Request; use Test::Requires qw(Plack::Request HTTP::Proxy::HeaderFilter::simple HTTP::Body), 'HTTP::Proxy'; use MIME::Base64 qw/encode_base64/; plan tests => 7*3; my $verbose = 1; { package Test::HTTP::Proxy; use parent qw(HTTP::Proxy); sub log { my($self, $level, $prefix, $msg) = @_; ::note "$prefix: $msg" if $verbose; } } my $via = "VIA!VIA!VIA!"; local $ENV{'HTTP_PROXY'} = ''; test_tcp( client => sub { my $proxy_port = shift; test_tcp( client => sub { # http client my $httpd_port = shift; for (1..3) { # run some times for testing keep-alive. my $furl = Furl::HTTP->new(proxy => "http://dankogai:kogaidan\@127.0.0.1:$proxy_port"); my ( undef, $code, $msg, $headers, $content ) = $furl->request( url => "http://127.0.0.1:$httpd_port/foo", headers => [ "X-Foo" => "ppp" ] ); is $code, 200, "request()"; is $msg, "OK"; is Furl::HTTP::_header_get($headers, 'Content-Length'), 10; is Furl::HTTP::_header_get($headers, 'Via'), "1.0 $via"; is $content, 'Hello, foo' or do{ require Devel::Peek; Devel::Peek::Dump($content) }; } }, server => sub { # http server my $httpd_port = shift; Plack::Loader->auto(port => $httpd_port)->run(sub { my $env = shift; my $req = Plack::Request->new($env); is $req->header('X-Foo'), "ppp" if $env->{REQUEST_URI} eq '/foo'; like $req->header('User-Agent'), qr/\A Furl::HTTP /xms; my $content = "Hello, foo"; return [ 200, [ 'Content-Length' => length($content) ], [ $content ] ]; }); }, ); }, server => sub { # proxy server my $proxy_port = shift; my $proxy = Test::HTTP::Proxy->new(port => $proxy_port, via => $via); my $token = "Basic " . encode_base64( "dankogai:kogaidan", "" ); $proxy->push_filter( request => HTTP::Proxy::HeaderFilter::simple->new( sub { my ( $self, $headers, $request ) = @_; my $auth = $self->proxy->hop_headers->header('Proxy-Authorization') || ''; # check the credentials if ( $auth ne $token ) { my $response = HTTP::Response->new(407); $response->header( Proxy_Authenticate => 'Basic realm= +"HTTP::Proxy"' ); $self->proxy->response($response); } } ) ); $proxy->start(); }, ); 33_basic_auth.t100664001750001750 222312560625033 20105 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/t/100_lowuse strict; use warnings; use Furl::HTTP; use Test::TCP; use Test::More; use t::HTTPServer; my $n = shift(@ARGV) || 3; test_tcp( client => sub { my $port = shift; my $furl = Furl::HTTP->new(bufsize => 10, timeout => 3); for (1 .. $n) { my ( undef, $code, $msg, $headers, $content ) = $furl->request( url => "http://dankogai:kogaidan\@127.0.0.1:${port}/foo", ); is $code, 200, "request()/$_"; is $msg, "OK"; is Furl::HTTP::_header_get($headers, 'Content-Length'), 4, 'header' or diag(explain($headers)); is $content, '/foo' or do{ require Devel::Peek; Devel::Peek::Dump($content) }; } done_testing; }, server => sub { my $port = shift; t::HTTPServer->new(port => $port)->run(sub {; my $env = shift; is($env->{HTTP_AUTHORIZATION}, 'Basic ZGFua29nYWk6a29nYWlkYW4='); return [ 200, [ 'Content-Length' => length($env->{REQUEST_URI}) ], [$env->{REQUEST_URI}] ]; }); } ); 34_keep_request.t100664001750001750 232512560625033 20503 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/t/100_lowuse strict; use warnings; use Furl::HTTP; use Furl::Request; use Test::TCP; use Test::More; use t::HTTPServer; test_tcp( client => sub { my $port = shift; subtest 'return request info' => sub { my $furl = Furl::HTTP->new(capture_request => 1); my @res = $furl->request( url => "http://127.0.0.1:$port/1", ); my ( $res_minor_version, $res_status, $res_msg, $res_headers, $res_content, $captured_req_headers, $captured_req_content, $captured_res_headers, $captured_res_content, $request_info, ) = @res; my $req = Furl::Request->parse($captured_req_headers . $captured_req_content); is $req->method, 'GET'; is $req->uri, "http://127.0.0.1:$port/1"; }; }, server => sub { my $port = shift; t::HTTPServer->new(port => $port)->run(sub { my $env = shift; return [ 200, [ 'Content-Length' => length('keep request') ], [ 'keep request' ] ]; }); } ); done_testing; 35_get_address.t100664001750001750 161712560625033 20277 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/t/100_lowuse strict; use warnings; use Socket qw(inet_aton pack_sockaddr_in); use Test::More; use Test::TCP; use Furl::HTTP; use t::HTTPServer; test_tcp( client => sub { my $serverPort = shift; my $furl = Furl::HTTP->new( get_address => sub { my ($host, $port, $timeout) = @_; is $host, "nowhere.example.com", "get_address:hostname"; is $port, 80, "get_address:port"; return pack_sockaddr_in($serverPort, inet_aton("127.0.0.1")); }, ); my ($minor_version, $code, $msg, $headers, $body) = $furl->request( method => "GET", host => "nowhere.example.com", port => 80, path_query => "/abc", ); is $code, 200, "status code"; is $body, "hello furl", "content"; }, server => sub { my $port = shift; ok "yes"; t::HTTPServer->new(port => $port)->run(sub { my $env = shift; return [ 200, [], [ "hello furl" ] ]; }); } ); done_testing; 36_inactivity_timeout.t100664001750001750 242112560625033 21737 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/t/100_lowuse strict; use warnings; use Socket qw(inet_aton pack_sockaddr_in); use Test::More; use Test::TCP; use Test::Requires qw(HTTP::Server::PSGI); use Furl::HTTP; use t::Slowloris; test_tcp( server => sub { my $port = shift; $Slowloris::SleepBeforeWrite = 1; Slowloris::Server->new(port => $port)->run(sub { my $env = shift; return [ 200, [], [ "hello" ] ]; }); }, client => sub { my $port = shift; # should not timeout my $furl = Furl::HTTP->new( timeout => 10, inactivity_timeout => 10, ); my $start = time; my ($minor_version, $code, $msg, $headers, $body) = $furl->request( method => "GET", host => "127.0.0.1", port => $port, path_query => "/", ); is $code, 200, "status code:inactivity_timeout=10"; is $body, "hello", "content:inactivity_timeout=10"; diag "took @{[time - $start]} seconds"; # should timeout $furl = Furl::HTTP->new( timeout => 10, inactivity_timeout => 0.5, ); $start = time; ($minor_version, $code, $msg, $headers, $body) = $furl->request( method => "GET", host => "127.0.0.1", port => $port, path_query => "/", ); is $code, 500, "status code:inactivity_timeout=0.5"; diag "took @{[time - $start]} seconds"; }, ); done_testing; 37_bad_content_length.t100664001750001750 260412560625033 21633 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/t/100_lowuse strict; use warnings; use utf8; use Furl::HTTP; use Test::TCP; use Test::More; use t::HTTPServer; # Scenario: The server returns bad content-length. # RFC 2616 says Content-Length header's format is: # # Content-Length = "Content-Length" ":" 1*DIGIT # # But some server returns invalid format. # It makes mysterious error message by Perl interpreter. # # Then, Furl validates content-length header before processing. # # ref. https://www.ietf.org/rfc/rfc2616.txt my $n = shift(@ARGV) || 3; test_tcp( client => sub { my $port = shift; my $furl = Furl::HTTP->new(bufsize => 10, timeout => 3); my ( undef, $code, $msg, $headers, $content ) = $furl->request( port => $port, path_query => '/foo', host => '127.0.0.1', headers => [ "X-Foo" => "ppp" ] ); is $code, 500, "request()/$_"; like $msg, qr/Internal Response/; like $content, qr/Bad Content-Length: 5963,5963/ or do{ require Devel::Peek; Devel::Peek::Dump($content) }; done_testing; }, server => sub { my $port = shift; t::HTTPServer->new(port => $port)->run(sub {; my $env = shift; return [ 200, [ 'Content-Length' => '5963,5963' ], [$env->{REQUEST_URI}] ]; }); } ); 01_simple.t100664001750001750 560112560625033 17412 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/t/300_highuse strict; use warnings; use Furl; use Test::TCP; use Test::Requires qw(Plack::Request HTTP::Body), 'Plack'; use Plack::Loader; use Test::More; use Plack::Request; use File::Temp; use Fcntl qw/:seek/; my @data = ( ['get', [], sub { }], ['get', [['X-Foo' => 'bar']], sub { is $_->header('X-Foo'), 'bar'; }], ['head', [], sub { }], ['head', [['X-Foo' => 'bar']], sub { is $_->header('X-Foo'), 'bar'; }], ['post', [[], 'doya'], sub { is $_->content_length, 4; is $_->content, 'doya' }], ['post', [undef, 'doya'], sub { is $_->content_length, 4; is $_->content, 'doya' }], ['post', [[], ['do' => 'ya']], sub { is $_->content_length, 5; is $_->content, 'do=ya' }], ['post', [[], {'do' => 'ya'}], sub { is $_->content_length, 5; is $_->content, 'do=ya' }], ['post', [[], ['do' => 'ya', '=foo=' => 'bar baz']], sub { my $c = 'do=ya&%3Dfoo%3D=bar%20baz'; is $_->content_length, length($c); is $_->content, $c; }, ], ['put', [[], 'doya'], sub { is $_->content_length, 4; is $_->content, 'doya' }], ['put', [undef, 'doya'], sub { is $_->content_length, 4; is $_->content, 'doya' }], ['put', [[], ['do' => 'ya']], sub { is $_->content_length, 5; is $_->content, 'do=ya' }], ['put', [[], {'do' => 'ya'}], sub { is $_->content_length, 5; is $_->content, 'do=ya' }], ['put', [[], ['do' => 'ya', '=foo=' => 'bar baz']], sub { my $c = 'do=ya&%3Dfoo%3D=bar%20baz'; is $_->content_length, length($c); is $_->content, $c; }, ], ['delete', [], sub { }], ['delete', [['X-Foo' => 'bar']], sub { is $_->header('X-Foo'), 'bar'; }], ['delete', [undef, 'doya'], sub { is $_->content_length, 4; is $_->content, 'doya'; }], ); test_tcp( client => sub { my $port = shift; my $furl = Furl->new(); my $url = "http://127.0.0.1:$port"; my @d = @data; while (my $row = shift @d) { my ($method, $args) = @$row; note "-- $method"; my $res = $furl->$method($url, @$args); is $res->status, 200, "client: status by $method()" or die "BAD: " . join(', ', $res->status, $res->message, $res->content); } done_testing; }, server => sub { my $port = shift; my @d = @data; Plack::Loader->auto( port => $port )->run(sub { while (my $row = shift @d) { my $env = shift; my $row = shift @data; my ($method, $args, $code) = @$row; local $_ = Plack::Request->new($env); is uc($_->method), uc($method), 'server: method'; $code->(); return [ 200, [ 'Content-Length' => 2 ], ['OK'] ]; } }); } ); 02_agent.t100664001750001750 43512560625033 17200 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/t/300_highuse strict; use warnings; use Test::More; use Furl; subtest 'agent' => sub { my $furl = Furl->new( agent => 'Furl/test' ); is $furl->agent, "Furl/test", 'get User-Agent'; $furl->agent('Furl/new'); is $furl->agent, "Furl/new", 'set new User-Agent'; }; done_testing; 04_http_request.t100664001750001750 224512560625033 20654 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/t/300_highuse strict; use warnings; use Furl; use Test::TCP; use Test::Requires qw(Plack::Request HTTP::Body), 'Plack'; use Plack::Loader; use Test::More; use Plack::Request; use Test::Requires qw(Plack::Request HTTP::Body), 'HTTP::Request'; test_tcp( client => sub { my $port = shift; my $furl = Furl->new(); my $req = HTTP::Request->new(POST => "http://127.0.0.1:$port/foo", ['X-Foo' => 'ppp', 'Content-Length' => 3], 'yay'); my $res = $furl->request( $req ); is $res->code, 200, "request()"; done_testing; }, server => sub { my $port = shift; Plack::Loader->auto(port => $port)->run(sub { my $env = shift; #note explain $env; my $req = Plack::Request->new($env); is $req->header('X-Foo'), "ppp"; is $req->header('Host'), "127.0.0.1:$port"; is $req->path_info, "/foo"; is $req->content, "yay"; is $req->content_length, 3; is $req->method, "POST"; return [ 200, [ 'Content-Length' => length($req->content) ], [$req->content] ]; }); } ); 05_suppress_dup_host_header.t100664001750001750 235512560625033 23231 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/t/300_highuse strict; use warnings; use Furl; use Test::TCP; use Test::More; use Test::Requires qw(Plack::Request HTTP::Body), 'HTTP::Request'; use t::HTTPServer; test_tcp( client => sub { my $port = shift; my $furl = Furl->new(); my $req = HTTP::Request->new(GET => "http://127.0.0.1:$port/foo"); $req->headers->header('Host' => '127.0.0.1'); my $res = $furl->request( $req ); is $res->code, 200, "HTTP status ok"; }, server => sub { my $port = shift; my $request; { no warnings 'redefine'; my $org = t::HTTPServer->can('parse_http_request'); *t::HTTPServer::parse_http_request = sub { $request .= $_[0]; $org->(@_); }; } t::HTTPServer->new(port => $port)->run(sub { my $env = shift; my $hash; for my $line (split /\n/, $request) { my ($k) = (split ':', $line)[0]; $hash->{$k}++; } is $hash->{Host}, 1, 'Host header is one'; is $env->{HTTP_HOST}, "127.0.0.1:$port", 'Host header is ok'; return [200, ['Content-Length' => 2], ['ok']]; }); }, ); done_testing; 06_keep_request.t100664001750001750 1516512560625033 20650 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/t/300_highuse strict; use warnings; use Furl; use Test::TCP; use Test::Requires qw(Plack::Request HTTP::Body), 'Plack'; use Plack::Loader; use Test::More; use Data::Dumper; use Plack::Request; use Test::Requires qw(Plack::Request HTTP::Body), 'HTTP::Request'; test_tcp( client => sub { my $port = shift; my $furl = Furl->new(capture_request => 1); # request(GET) { my $res = $furl->request(url => "http://127.0.0.1:$port/foo", method => "GET"); is $res->code, 200, "request()"; is $res->body, 'OK'; can_ok $res => 'request'; my $req = $res->request; isa_ok $req => 'Furl::Request'; is $req->uri => "http://127.0.0.1:$port/foo"; is $req->method => 'GET'; } # request(POST) { my $res = $furl->request(url => "http://127.0.0.1:$port/foo", method => "POST", content => 'GAH'); is $res->code, 200, "request()"; is $res->body, 'OK'; can_ok $res => 'request'; my $req = $res->request; isa_ok $req => 'Furl::Request'; is $req->uri => "http://127.0.0.1:$port/foo"; is $req->method => 'POST'; is $req->content => 'GAH'; } # ->get { my $res = $furl->get("http://127.0.0.1:$port/foo"); is $res->code, 200, "request()"; is $res->body, 'OK'; can_ok $res => 'request'; my $req = $res->request; isa_ok $req => 'Furl::Request'; is $req->uri => "http://127.0.0.1:$port/foo"; is $req->method => 'GET'; is $req->content => ''; } # ->get with headers { my $res = $furl->get("http://127.0.0.1:$port/foo", [ 'X-Furl-Requst' => 1, ]); is $res->code, 200, "request()"; is $res->body, 'OK'; can_ok $res => 'request'; my $req = $res->request; isa_ok $req => 'Furl::Request'; is $req->uri => "http://127.0.0.1:$port/foo"; is $req->method => 'GET'; is $req->content => ''; is($req->headers->header('X-Furl-Requst'), 1) or diag Dumper($req->headers); is($req->header('X-Furl-Requst'), 1) or diag Dumper($req->headers); is join(',', $req->headers->keys), 'x-furl-requst'; } # ->head { my $res = $furl->head("http://127.0.0.1:$port/foo"); is $res->code, 200, "request()"; is $res->body, ''; can_ok $res => 'request'; my $req = $res->request; isa_ok $req => 'Furl::Request'; is $req->uri => "http://127.0.0.1:$port/foo"; is $req->method => 'HEAD'; is $req->content => ''; } # ->head with headers { my $res = $furl->head("http://127.0.0.1:$port/foo", [ 'X-Furl-Requst' => 1, ]); is $res->code, 200, "request()"; is $res->body, ''; can_ok $res => 'request'; my $req = $res->request; isa_ok $req => 'Furl::Request'; is $req->uri => "http://127.0.0.1:$port/foo"; is $req->method => 'HEAD'; is $req->content => ''; is $req->header('X-Furl-Requst'), 1; } # ->post { my $res = $furl->post("http://127.0.0.1:$port/foo", [], 'GAH'); is $res->code, 200, "request()"; is $res->body, 'OK'; can_ok $res => 'request'; my $req = $res->request; isa_ok $req => 'Furl::Request'; is $req->uri => "http://127.0.0.1:$port/foo"; is $req->method => 'POST'; is $req->content => 'GAH'; } # ->post with headers { my $res = $furl->post("http://127.0.0.1:$port/foo", [ 'X-Furl-Requst' => 1, ], 'GAH'); is $res->code, 200, "request()"; is $res->body, 'OK'; can_ok $res => 'request'; my $req = $res->request; isa_ok $req => 'Furl::Request'; is $req->uri => "http://127.0.0.1:$port/foo"; is $req->method => 'POST'; is $req->content => 'GAH'; is $req->header('X-Furl-Requst'), 1; } # ->put { my $res = $furl->put("http://127.0.0.1:$port/foo", [], 'GAH'); is $res->code, 200, "request()"; is $res->body, 'OK'; can_ok $res => 'request'; my $req = $res->request; isa_ok $req => 'Furl::Request'; is $req->uri => "http://127.0.0.1:$port/foo"; is $req->method => 'PUT'; is $req->content => 'GAH'; } # ->put with headers { my $res = $furl->put("http://127.0.0.1:$port/foo", [ 'X-Furl-Requst' => 1, ], 'GAH'); is $res->code, 200, "request()"; is $res->body, 'OK'; can_ok $res => 'request'; my $req = $res->request; isa_ok $req => 'Furl::Request'; is $req->uri => "http://127.0.0.1:$port/foo"; is $req->method => 'PUT'; is $req->content => 'GAH'; is $req->header('X-Furl-Requst'), 1; } # ->delete { my $res = $furl->delete("http://127.0.0.1:$port/foo"); is $res->code, 200, "request()"; is $res->body, 'OK'; can_ok $res => 'request'; my $req = $res->request; isa_ok $req => 'Furl::Request'; is $req->uri => "http://127.0.0.1:$port/foo"; is $req->method => 'DELETE'; is $req->content => ''; } # ->delete with headers { my $res = $furl->delete("http://127.0.0.1:$port/foo", [ 'X-Furl-Requst' => 1, ]); is $res->code, 200, "request()"; is $res->body, 'OK'; can_ok $res => 'request'; my $req = $res->request; isa_ok $req => 'Furl::Request'; is $req->uri => "http://127.0.0.1:$port/foo"; is $req->method => 'DELETE'; is $req->content => ''; is $req->header('X-Furl-Requst'), 1; } done_testing; }, server => sub { my $port = shift; Plack::Loader->auto(port => $port)->run(sub { my $env = shift; my $req = Plack::Request->new($env); return [ 200, [ 'Content-Length' => 2 ], [ 'OK' ] ]; }); } ); 07_cookie.t100664001750001750 1272012560625033 17420 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/t/300_highuse strict; use warnings; use utf8; use Test::More; use Test::Requires 'HTTP::CookieJar', 'Plack::Request', 'Plack::Loader', 'Plack::Builder', 'Plack::Response'; use Test::TCP; use Furl; subtest 'Simple case', sub { test_tcp( client => sub { my $port = shift; my $furl = Furl->new( cookie_jar => HTTP::CookieJar->new() ); my $url = "http://127.0.0.1:$port"; subtest 'first time access', sub { my $res = $furl->get("${url}/"); note "Then, response should be 200 OK"; is $res->status, 200; note "And, content should be 'OK 1'"; is $res->content, 'OK 1'; }; subtest 'Second time access', sub { my $res = $furl->get("${url}/"); note "Then, response should be 200 OK"; is $res->status, 200; note "And, content should be 'OK 2'"; is $res->content, 'OK 2'; }; }, server => \&session_server, ); }; subtest '->request(host => ...) style simple interface', sub { test_tcp( client => sub { my $port = shift; my $furl = Furl->new( cookie_jar => HTTP::CookieJar->new() ); subtest 'first time access', sub { my $res = $furl->request( method => 'GET', scheme => 'http', host => '127.0.0.1', port => $port, ); note "Then, response should be 200 OK"; is $res->status, 200; note "And, content should be 'OK 1'"; is $res->content, 'OK 1'; }; subtest 'Second time access', sub { my $res = $furl->request( method => 'GET', scheme => 'http', host => '127.0.0.1', port => $port, ); note "Then, response should be 200 OK"; is $res->status, 200; note "And, content should be 'OK 2'"; is $res->content, 'OK 2'; }; }, server => \&session_server, ); }; subtest 'With redirect', sub { test_tcp( client => sub { my $port = shift; my $furl = Furl->new( cookie_jar => HTTP::CookieJar->new() ); my $url = "http://127.0.0.1:$port"; subtest 'first time access', sub { my $res = $furl->get("${url}/login"); note "Then, response should be 200 OK"; is $res->status, 200; note "And, content should be 'ok'"; is $res->content, 'ok'; }; subtest 'Second time access', sub { my $res = $furl->get("${url}/user_name"); note "Then, response should be 200 OK"; is $res->status, 200; note "And, content should be 'Nick'"; is $res->content, 'Nick'; }; }, server => sub { my $port = shift; my %SESSION_STORE; Plack::Loader->auto( port => $port )->run(builder { enable 'ContentLength'; enable 'StackTrace'; sub { my $env = shift; my $req = Plack::Request->new($env); my $path_info = $env->{PATH_INFO}; $path_info =~ s!^//!/!; if ($path_info eq '/login') { my $res = Plack::Response->new( 302, ['Location' => $req->uri_for('/login_done')], [] ); $res->cookies->{'user_name'} = 'Nick'; return $res->finalize; } elsif ($path_info eq '/login_done') { my $res = Plack::Response->new( 200, [], ['ok'] ); return $res->finalize; } elsif ($path_info eq '/user_name') { my $res = Plack::Response->new( 200, [], [$req->cookies->{'user_name'}] ); return $res->finalize; } else { my $res = Plack::Response->new( 404, [], ['not found:' . $env->{PATH_INFO}] ); return $res->finalize; } }; }); } ); }; done_testing; sub session_server { my $port = shift; my %SESSION_STORE; Plack::Loader->auto( port => $port )->run(builder { enable 'ContentLength'; sub { my $env = shift; my $req = Plack::Request->new($env); my $session_key = $req->cookies->{session_key} || rand(); my $cnt = ++$SESSION_STORE{$session_key}; note "CNT: $cnt"; my $res = Plack::Response->new( 200, [], ["OK ${cnt}"] ); $res->cookies->{'session_key'} = $session_key; return $res->finalize; }; }); } sub Plack::Request::uri_for { my($self, $path, $args) = @_; my $uri = $self->base; $uri->path($uri->path . $path); $uri->query_form(@$args) if $args; $uri; } 99_error.t100664001750001750 125012560625033 17267 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/t/300_highuse strict; use warnings; use Furl; use Test::More; use File::Basename qw/basename/; my $furl = Furl->new; my $file_name = basename $0; sub test_error_message (&) { my $code = shift; local $@; eval { $code->() }; like $@, qr/$file_name/; } test_error_message { $furl->get('ttp://example.com/') }; test_error_message { $furl->head('ttp://example.com/') }; test_error_message { $furl->post('ttp://example.com/') }; test_error_message { $furl->delete('ttp://example.com/') }; test_error_message { $furl->put('ttp://example.com/') }; test_error_message { $furl->request( method => 'GET', url => 'ttp://example.com/', ); }; done_testing; 01-file.t100664001750001750 325612560625033 23710 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/t/400_components/001_response-coding#!perl use strict; use warnings; use Furl; use File::Spec; use Encode; use Cwd; use Test::Requires 'Test::Fake::HTTPD', 'URI'; use URI; use Test::More tests => 13; use Test::TCP; use Test::Fake::HTTPD; my $ua = Furl->new; my $cwd = getcwd; #BEGIN{ # package LWP::Protocol; # $^W = 0; #} my $httpd = run_http_server { my $req = shift; my $path = 't/400_components/001_response-coding' . $req->uri->path; open my $fh, '<', $path or die "$path: $!"; return [ 200, [ 'Content-Type' => 'text/html' ], $fh ]; }; note $httpd->host_port; for my $meth (qw/charset encoder encoding decoded_content/){ can_ok('Furl::Response', $meth); } my %charset = qw( UTF-8 utf-8-strict; EUC-JP EUC-JP Shift_JIS SHIFT_JIS ISO-2022-JP ISO-2022-JP ); my %filename = qw( UTF-8 t-utf-8.html EUC-JP t-euc-jp.html Shift_JIS t-shiftjis.html ISO-2022-JP t-iso-2022-jp.html ); for my $charset (sort keys %charset){ my $uri = URI->new('http://' . $httpd->host_port); $uri->path(File::Spec->catfile($filename{$charset})); my $res; { local $^W = 0; # to quiet LWP::Protocol $res = $ua->get($uri); } die unless $res->is_success; is $res->charset, $charset, "\$res->charset eq '$charset'"; my $canon = find_encoding($charset)->name; is $res->encoding, $canon, "\$res->encoding eq '$canon'"; } my $uri = URI->new('http://' . $httpd->host_port); $uri->path("t-null.html"); my $res = $ua->get($uri); die unless $res->is_success; if (defined $res->encoding){ is $res->encoding, "ascii", "res->encoding is ascii"; }else{ ok !$res->encoding, "res->encoding is undef"; } t-euc-jp.html100664001750001750 51312560625033 24651 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/t/400_components/001_response-coding Test

ʡҤ餬ʤähtml.

t-iso-2022-jp.html100664001750001750 52612560625033 25256 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/t/400_components/001_response-coding Test

$B4A;z!"%+%?%+%J!"$R$i$,$J$NF~$C$?(Bhtml.

t-null.html100664001750001750 42212560625033 24437 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/t/400_components/001_response-coding Test

The quick brown fox jumps over the black lazy dog.

t-shiftjis.html100664001750001750 51612560625033 25314 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/t/400_components/001_response-coding Test

AJ^JiAЂ炪Ȃ̓html.

t-utf-8.html100664001750001750 53212560625033 24432 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/t/400_components/001_response-coding Test

漢字、カタカナ、ひらがなの入ったhtml.

01_headers.t100664001750001750 472012560625033 21004 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/t/400_componentsuse strict; use warnings; use Test::More; use Furl::Headers; use Test::Requires qw(Plack::Request HTTP::Body), 'HTTP::Headers'; use HTTP::Headers; subtest 'total test' => sub { my $h = Furl::Headers->new([ 'x-foo' => 1, 'x-bar' => 2, 'x-foo' => 3, ]); is_deeply( +{%$h}, +{ 'x-foo' => [qw/1 3/], 'x-bar' => [2] }, 'make from arrayref' ); is( $h->header('X-Foo'), "1, 3" ); is_deeply( [$h->header('X-Foo')], [qw/1 3/] ); is( $h->header('X-Bar'), 2 ); is( $h->header('X-Bar'), 2 ); is_deeply( [$h->header('X-Foo')], [qw/1 3/] ); $h->header('X-Poo', 'san'); is( $h->header('X-Poo'), 'san' ); $h->header('X-Poo', ['san', 'winnie']); is( $h->header('X-Poo'), 'san, winnie' ); is_deeply( [$h->header('X-Poo')], ['san', 'winnie'] ); is(join(',', sort $h->keys), 'x-bar,x-foo,x-poo'); $h->remove_header('x-foo'); is(join(',', sort $h->keys), 'x-bar,x-poo'); is(join(',', sort $h->header_field_names), 'x-bar,x-poo', 'header_field_names'); is_deeply([sort split /\015\012/, $h->as_string], [sort split /\015\012/, "x-bar: 2\015\012x-poo: san\015\012x-poo: winnie\015\012"], 'as_string'); is(join(',', sort $h->flatten), '2,san,winnie,x-bar,x-poo,x-poo'); my $hh = $h->as_http_headers; is $hh->header('x-bar'), '2'; is $hh->header('x-poo'), 'san, winnie'; }; subtest 'from hashref' => sub { my $h = Furl::Headers->new({ 'x-foo' => [1, 3], 'x-bar' => [2], }); is( $h->header('X-Foo'), '1, 3', 'make from hashref' ); is_deeply( [$h->header('X-Foo')], [qw/1 3/] ); is( $h->header('X-Bar'), 2 ); is_deeply( [$h->header('X-Bar')], [2] ); }; subtest 'shorthand' => sub { my $h = Furl::Headers->new( [ 'expires' => '1111', 'last-modified' => '2222', 'if-modified-since' => '3333', 'content-type' => 'text/html', 'content-length' => '4444', ] ); is $h->expires, '1111'; is $h->last_modified, '2222'; is $h->if_modified_since, '3333'; is $h->content_type, 'text/html'; is $h->content_length, 4444; }; subtest 'clone' => sub { my $h1 = Furl::Headers->new([ expires => 1111, ]); my $h2 = $h1->clone(); is $h2->expires, '1111'; $h2->last_modified('2222'); is $h2->last_modified, '2222'; isnt $h1->last_modified, '2222'; }; # TODO make from hashref done_testing; 02_response.t100664001750001750 553712560625033 21237 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/t/400_componentsuse strict; use warnings; use Test::More; use Test::Requires qw(Plack::Request HTTP::Body), 'HTTP::Response'; use Furl::Response; my $res = Furl::Response->new( 1, 200, 'OK', +{ 'x-foo' => ['yay'], 'x-bar' => ['hoge'], 'content-length' => [9], 'content-type' => ['text/html'], 'content-encoding' => ['chunked'], }, 'hit man' ); is $res->protocol, 'HTTP/1.1'; is $res->code, 200; is $res->message, 'OK'; isa_ok $res->headers, 'Furl::Headers'; is $res->content, 'hit man'; is($res->headers->header('X-Foo'), 'yay'); ok $res->is_success; is $res->status_line, '200 OK'; is $res->content_length, 9; is $res->content_type, 'text/html'; is $res->content_encoding, 'chunked'; my $hres = $res->as_http_response; isa_ok $hres, 'HTTP::Response'; is $hres->code, 200; is $hres->message, 'OK'; isa_ok $hres->headers, 'HTTP::Headers'; is $hres->content_type, 'text/html'; is $hres->content, 'hit man'; is $hres->protocol, 'HTTP/1.1'; subtest 'as_hashref' => sub { my $dat = $res->as_hashref; my $headers = delete $dat->{headers}; is_deeply( $dat, { message => 'OK', code => 200, content => 'hit man', protocol => 'HTTP/1.1', } ); is_deeply( [sort @{$headers}], [sort qw( content-type text/html x-foo yay x-bar hoge content-length 9 content-encoding chunked )] ); }; subtest 'to_psgi' => sub { my $dat = $res->to_psgi; is(0+@$dat, 3); is($dat->[0], 200); is_deeply( [sort @{$dat->[1]}], [sort qw( content-type text/html x-foo yay x-bar hoge content-length 9 content-encoding chunked )] ); is_deeply($dat->[2], ['hit man']); }; subtest decoded_content => sub { my $res = Furl::Response->new( 1, 200, 'OK', +{ 'content-type' => ['text/plain; charset=UTF-8'], }, "\343\201\202\343\201\204\343\201\206\343\201\210\343\201\212", ); is $res->decoded_content, "\x{3042}\x{3044}\x{3046}\x{3048}\x{304a}"; }; subtest 'as_string' => sub { my $res = Furl::Response->new( 1, 200, 'OK', +{ 'x-foo' => ['yay'], 'x-bar' => ['hoge'], 'content-length' => [9], 'content-type' => ['text/html'], 'content-encoding' => ['chunked'], }, 'hit man' ); my $expected = join("\015\012", '200 OK', 'content-encoding: chunked', 'content-length: 9', 'content-type: text/html', 'x-bar: hoge', 'x-foo: yay', '', 'hit man', ); is($res->as_string, $expected); is(length($res->as_string), length($expected)); }; done_testing; 03_request.t100664001750001750 1051212560625033 21077 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/t/400_componentsuse strict; use warnings; use Test::More; use Test::Requires 'HTTP::Request'; use Furl::Request; subtest 'normally' => sub { my $req = Furl::Request->new( 'POST', 'http://example.com/foo?q=bar', +{ 'x-foo' => ['yay'], 'x-bar' => ['hoge'], 'content-length' => [7], 'content-type' => ['text/plain'], }, 'hit man' ); $req->protocol('HTTP/1.0'); is $req->method, 'POST'; is $req->uri, 'http://example.com/foo?q=bar'; isa_ok $req->headers, 'Furl::Headers'; is($req->header('X-Foo'), 'yay'); is $req->content, 'hit man'; is $req->protocol, 'HTTP/1.0'; is $req->request_line, 'POST /foo?q=bar HTTP/1.0'; is $req->content_length, 7; is $req->content_type, 'text/plain'; my $hreq = $req->as_http_request; isa_ok $hreq, 'HTTP::Request'; is $hreq->method, 'POST'; is $hreq->uri, 'http://example.com/foo?q=bar'; isa_ok $hreq->headers, 'HTTP::Headers'; is $hreq->content_type, 'text/plain'; is $hreq->content, 'hit man'; is $hreq->protocol, 'HTTP/1.0'; }; subtest 'parse' => sub { my $body = <<__REQ__; POST /foo?q=bar HTTP/1.1 Host: example.com X-Foo: yay X-Bar: hoge Content-Length: 7 Content-Type: text/plain hit man __REQ__ chomp $body; my $req = Furl::Request->parse($body); is $req->method, 'POST'; is $req->uri, 'http://example.com/foo?q=bar'; isa_ok $req->headers, 'Furl::Headers'; is($req->headers->header('X-Foo'), 'yay'); is $req->content, 'hit man'; is $req->protocol, 'HTTP/1.1'; is $req->request_line, 'POST /foo?q=bar HTTP/1.1'; is $req->content_length, 7; is $req->content_type, 'text/plain'; my $hreq = $req->as_http_request; isa_ok $hreq, 'HTTP::Request'; is $hreq->method, 'POST'; is $hreq->uri, 'http://example.com/foo?q=bar'; isa_ok $hreq->headers, 'HTTP::Headers'; is $hreq->content_type, 'text/plain'; is $hreq->content, 'hit man'; is $hreq->protocol, 'HTTP/1.1'; }; subtest 'as_hashref' => sub { my $req = Furl::Request->new( 'POST', 'http://example.com/foo?q=bar', +{ 'x-foo' => ['yay'], 'x-bar' => ['hoge'], 'content-length' => [7], 'content-type' => ['text/plain'], }, 'hit man' ); $req->protocol('HTTP/1.1'); my $dat = $req->as_hashref; my $headers = delete $dat->{headers}; is_deeply( $dat, { method => 'POST', uri => 'http://example.com/foo?q=bar', content => 'hit man', protocol => 'HTTP/1.1', } ); is_deeply( [sort @{$headers}], [sort qw( content-type text/plain content-length 7 x-foo yay x-bar hoge )] ); }; subtest 'as_string' => sub { subtest 'simple' => sub { my $req = Furl::Request->new( 'POST', 'http://example.com/foo?q=bar', +{ 'x-foo' => ['yay'], 'x-bar' => ['hoge'], 'content-length' => [7], 'content-type' => ['text/plain'], }, 'hit man' ); $req->protocol('HTTP/1.1'); my $expected = join("\015\012", 'POST http://example.com/foo?q=bar HTTP/1.1', 'content-length: 7', 'content-type: text/plain', 'x-bar: hoge', 'x-foo: yay', '', 'hit man', ); is($req->as_string, $expected); }; subtest 'Furl#post' => sub { my $req = Furl::Request->new( 'POST', 'http://example.com/foo?q=bar', +{ 'x-foo' => ['yay'], 'x-bar' => ['hoge'], 'content-length' => [7], 'content-type' => ['text/plain'], }, [X => 'Y'], ); # no protocol my $expected = join("\015\012", 'POST http://example.com/foo?q=bar', 'content-length: 7', 'content-type: text/plain', 'x-bar: hoge', 'x-foo: yay', '', 'X=Y', ); is($req->as_string, $expected); }; }; done_testing; 01_capture_request.t100664001750001750 40412560625033 22556 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/t/800_regression#!perl -Ilib use strict; use warnings; use utf8; use Test::More; use Furl; my $f=Furl->new(capture_request=>1, timeout=>5); my $r=$f->post("http://example.com.local"); is($r->captured_req_headers, undef); is($r->captured_req_content, undef); done_testing; parse_url.t100664001750001750 504212560625033 20541 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/t/999_intrenaluse strict; use warnings; use Furl::HTTP; use Test::More; sub test_parse_url { my ($uri, $expects, $desc) = @_; local $@; my @parsed = eval { Furl::HTTP->_parse_url($uri) }; unless ($@) { is_deeply \@parsed, $expects, $desc; } else { like $@, $expects; } } test_parse_url( 'http://example.com/', [ 'http', undef, undef, 'example.com', undef, '/', ], 'root', ); test_parse_url( 'http://example.com', [ 'http', undef, undef, 'example.com', undef, undef, ], 'root (omit /)', ); test_parse_url( 'http://example.com/?foo=bar', [ 'http', undef, undef, 'example.com', undef, '/?foo=bar', ], 'root with query string' ); test_parse_url( 'http://example.com?foo=bar', [ 'http', undef, undef, 'example.com', undef, '?foo=bar', ], 'root with query string (omit /)' ); test_parse_url( 'http://example.com:5000/', [ 'http', undef, undef, 'example.com', 5000, '/', ], 'with port', ); test_parse_url( 'http://example.com:5000', [ 'http', undef, undef, 'example.com', 5000, undef, ], 'with port (omit /)', ); test_parse_url( 'http://example.com:5000/?foo=bar', [ 'http', undef, undef, 'example.com', 5000, '/?foo=bar', ], 'with port and query string', ); test_parse_url( 'http://example.com:5000?foo=bar', [ 'http', undef, undef, 'example.com', 5000, '?foo=bar', ], 'with port (omit /)', ); test_parse_url( 'http://example.com:5000/hoge/fuga?foo=bar', [ 'http', undef, undef, 'example.com', 5000, '/hoge/fuga?foo=bar', ], 'popular url', ); test_parse_url( 'http://user:pass@example.com/', [ 'http', 'user', 'pass', 'example.com', undef, '/', ], 'auth url without port number', ); test_parse_url( 'http://user:pass@example.com:5000/hoge/fuga?foo=bar', [ 'http', 'user', 'pass', 'example.com', 5000, '/hoge/fuga?foo=bar', ], 'auth & popular url', ); test_parse_url( 'http://example.com:5000foobar', qr/Passed malformed URL:/, ); done_testing; HTTPServer.pm100664001750001750 2475012560625033 16465 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/tpackage t::HTTPServer; use strict; use warnings; use IO::Socket::INET; use Socket qw(IPPROTO_TCP TCP_NODELAY); use Carp (); # taken from HTTP::Status our %STATUS_CODE = ( 100 => 'Continue', 101 => 'Switching Protocols', 102 => 'Processing', # RFC 2518 (WebDAV) 200 => 'OK', 201 => 'Created', 202 => 'Accepted', 203 => 'Non-Authoritative Information', 204 => 'No Content', 205 => 'Reset Content', 206 => 'Partial Content', 207 => 'Multi-Status', # RFC 2518 (WebDAV) 300 => 'Multiple Choices', 301 => 'Moved Permanently', 302 => 'Found', 303 => 'See Other', 304 => 'Not Modified', 305 => 'Use Proxy', 307 => 'Temporary Redirect', 400 => 'Bad Request', 401 => 'Unauthorized', 402 => 'Payment Required', 403 => 'Forbidden', 404 => 'Not Found', 405 => 'Method Not Allowed', 406 => 'Not Acceptable', 407 => 'Proxy Authentication Required', 408 => 'Request Timeout', 409 => 'Conflict', 410 => 'Gone', 411 => 'Length Required', 412 => 'Precondition Failed', 413 => 'Request Entity Too Large', 414 => 'Request-URI Too Large', 415 => 'Unsupported Media Type', 416 => 'Request Range Not Satisfiable', 417 => 'Expectation Failed', 422 => 'Unprocessable Entity', # RFC 2518 (WebDAV) 423 => 'Locked', # RFC 2518 (WebDAV) 424 => 'Failed Dependency', # RFC 2518 (WebDAV) 425 => 'No code', # WebDAV Advanced Collections 426 => 'Upgrade Required', # RFC 2817 449 => 'Retry with', # unofficial Microsoft 500 => 'Internal Server Error', 501 => 'Not Implemented', 502 => 'Bad Gateway', 503 => 'Service Unavailable', 504 => 'Gateway Timeout', 505 => 'HTTP Version Not Supported', 506 => 'Variant Also Negotiates', # RFC 2295 507 => 'Insufficient Storage', # RFC 2518 (WebDAV) 509 => 'Bandwidth Limit Exceeded', # unofficial 510 => 'Not Extended', # RFC 2774 ); sub new { my $class = shift; my %args = @_ == 1 ? %{$_[0]} : @_; $args{port} || Carp::croak("missing mandatory parameter 'port'"); bless { bufsize => 10*1024, protocol => "HTTP/1.1", enable_chunked => 1, %args }, $class; } sub add_trigger { my ($self, $name, $code) = @_; push @{$self->{triggers}->{$name}}, $code; return $self; } sub call_trigger { my ($self, $name, @args) = @_; for my $code (@{ $self->{triggers}->{$name} || +[] }) { $code->($self, @args); } } sub run { my ( $self, $app ) = @_; $app = $self->fill_content_length($app); local $SIG{PIPE} = "IGNORE"; my $sock = IO::Socket::INET->new( Listen => SOMAXCONN, Proto => 'tcp', ReuseAddr => 1, LocalAddr => '127.0.0.1', LocalPort => $self->{port}, Timeout => 3, ) or die $!; $sock->autoflush(1); while ( my $csock = $sock->accept ) { $csock->setsockopt( IPPROTO_TCP, TCP_NODELAY, 1 ) or die "setsockopt(TCP_NODELAY) failed:$!"; eval { $self->handle_connection($csock => $app); }; print STDERR "# $@" if $@; } } sub make_header { my ($self, $code, $headers) = @_; my $msg = $STATUS_CODE{$code} || $code; my $ret = "$self->{protocol} $code $msg\015\012"; for (my $i=0; $i<@$headers; $i+=2) { $ret .= $headers->[$i] . ': ' . $headers->[$i+1] . "\015\012"; } return $ret; } sub handle_connection { my ($self, $csock, $app) = @_; $self->call_trigger( "BEFORE_HANDLE_CONNECTION", $csock ); HANDLE_LOOP: while (1) { $self->call_trigger( "BEFORE_HANDLE_REQUEST", $csock ); my %env; my $buf = ''; PARSE_HTTP_REQUEST: while (1) { my $nread = sysread( $csock, $buf, $self->{bufsize}, length($buf) ); $buf =~ s!^(\015\012)*!! if defined($buf); # for keep-alive if ( !defined $nread ) { die "cannot read HTTP request header: $!"; } if ( $nread == 0 ) { # unexpected EOF while reading HTTP request header last HANDLE_LOOP; } my $ret = parse_http_request( $buf, \%env ); if ( $ret == -2 ) { # incomplete. next; } elsif ( $ret == -1 ) { # request is broken die "broken HTTP header"; } else { $buf = substr( $buf, $ret ); last PARSE_HTTP_REQUEST; } } my $res = $app->( \%env ); my $res_header = $self->make_header( $res->[0], $res->[1] ) . "\015\012"; $self->write_all( $csock, $res_header ); for my $body (@{$res->[2]}) { $self->write_all( $csock, $body ); } $self->call_trigger( "AFTER_HANDLE_REQUEST", $csock ); last HANDLE_LOOP unless $csock->opened; } $self->call_trigger( "AFTER_HANDLE_CONNECTION", $csock ); } sub fill_content_length { my ($self, $app) = @_; sub { my $env = shift; my $res = $app->($env); my $h = t::HTTPServer::Headers->new( $res->[1] ); if ( !t::HTTPServer::Util::status_with_no_entity_body( $res->[0] ) && !$h->exists('Content-Length') && !$h->exists('Transfer-Encoding') && defined( my $content_length = t::HTTPServer::Util::content_length( $res->[2] ) ) ) { push @{$res->[1]}, 'Content-Length' => $content_length; } return $res; } } sub write_all { my ( $self, $csock, $buf ) = @_; my $off = 0; while ( my $len = length($buf) - $off ) { my $nwrite = $csock->syswrite( $buf, $len, $off ) or die "Cannot write response: $!"; $off += $nwrite; } return $off; } sub parse_http_request { my ( $chunk, $env ) = @_; Carp::croak("second param to parse_http_request should be a hashref") unless ( ref $env || '' ) eq 'HASH'; # pre-header blank lines are allowed (RFC 2616 4.1) $chunk =~ s/^(\x0d?\x0a)+//; return -2 unless length $chunk; # double line break indicates end of header; parse it if ( $chunk =~ /^(.*?\x0d?\x0a\x0d?\x0a)/s ) { return _parse_header( $chunk, length $1, $env ); } return -2; # still waiting for unknown amount of header lines } sub _parse_header { my($chunk, $eoh, $env) = @_; my $header = substr($chunk, 0, $eoh,''); $chunk =~ s/^\x0d?\x0a\x0d?\x0a//; # parse into lines my @header = split /\x0d?\x0a/,$header; my $request = shift @header; # join folded lines my @out; for(@header) { if(/^[ \t]+/) { return -1 unless @out; $out[-1] .= $_; } else { push @out, $_; } } # parse request or response line my $obj; my ($major, $minor); my ($method,$uri,$http) = split / /,$request; return -1 unless $http and $http =~ /^HTTP\/(\d+)\.(\d+)$/i; ($major, $minor) = ($1, $2); my($path, $query) = ( $uri =~ /^([^?]*)(?:\?(.*))?$/s ); # following validations are just needed to pass t/01simple.t if ($path =~ /%(?:[0-9a-f][^0-9a-f]|[^0-9a-f][0-9a-f])/i) { # invalid char in url-encoded path return -1; } if ($path =~ /%(?:[0-9a-f])$/i) { # partially url-encoded return -1; } $env->{REQUEST_METHOD} = $method; $env->{REQUEST_URI} = $uri; $env->{SERVER_PROTOCOL} = "HTTP/$major.$minor"; $env->{PATH_INFO} = uri_unescape($path); $env->{QUERY_STRING} = $query || ''; $env->{SCRIPT_NAME} = ''; # import headers my $token = qr/[^][\x00-\x1f\x7f()<>@,;:\\"\/?={} \t]+/; my $k; for my $header (@out) { if ( $header =~ s/^($token): ?// ) { $k = $1; $k =~ s/-/_/g; $k = uc $k; if ($k !~ /^(?:CONTENT_LENGTH|CONTENT_TYPE)$/) { $k = "HTTP_$k"; } } elsif ( $header =~ /^\s+/) { # multiline header } else { return -1; } if (exists $env->{$k}) { $env->{$k} .= ", $header"; } else { $env->{$k} = $header; } } return $eoh; } sub uri_unescape { local $_ = shift; $_ =~ s/%([0−9A−Fa−f]{2})/chr(hex($1))/eg; $_; } package t::HTTPServer::Util; # code taken from Plack::Util. use Scalar::Util (); sub status_with_no_entity_body { my $status = shift; return $status < 200 || $status == 204 || $status == 304; } sub content_length { my $body = shift; return unless defined $body; if (ref $body eq 'ARRAY') { my $cl = 0; for my $chunk (@$body) { $cl += length $chunk; } return $cl; } elsif ( is_real_fh($body) ) { return (-s $body) - tell($body); } return; } sub is_real_fh ($) { my $fh = shift; my $reftype = Scalar::Util::reftype($fh) or return; if ( $reftype eq 'IO' or $reftype eq 'GLOB' && *{$fh}{IO} ) { # if it's a blessed glob make sure to not break encapsulation with # fileno($fh) (e.g. if you are filtering output then file descriptor # based operations might no longer be valid). # then ensure that the fileno *opcode* agrees too, that there is a # valid IO object inside $fh either directly or indirectly and that it # corresponds to a real file descriptor. my $m_fileno = $fh->fileno; return 0 unless defined $m_fileno; return 0 unless $m_fileno >= 0; my $f_fileno = fileno($fh); return 0 unless defined $f_fileno; return 0 unless $f_fileno >= 0; return 1; } else { # anything else, including GLOBS without IO (even if they are blessed) # and non GLOB objects that look like filehandle objects cannot have a # valid file descriptor in fileno($fh) context so may break. return 0; } } package t::HTTPServer::Headers; sub new { my ($class, $headers) = @_; my %h; for (my $i=0; $i<@$headers; $i++) { my ($k, $v) = ($headers->[$i], $headers->[$i+1]); push @{$h{lc $k}}, $v; } return bless \%h, $class; } sub exists { my ($self, $key) = @_; $self->{lc $key} ? 1 : 0; } sub header { my ($self, $key) = @_; my $val = $self->{lc $key}; return unless $val; return wantarray ? @$val : join(', ', @$val); } 1; Slowloris.pm100664001750001750 160212560625033 16463 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/tpackage t::Slowloris; use strict; use warnings; package Slowloris; use Test::SharedFork; our $WriteBytes = 1; our $SleepBeforeWrite = 0; our $SleepBeforeRead = 0; package Slowloris::Socket; use parent qw(IO::Socket::INET); use Time::HiRes qw(sleep); sub syswrite { my($sock, $buff, $len, $off) = @_; sleep $SleepBeforeWrite if $SleepBeforeWrite; my $w = $off; while($off < $len) { my $n = $sock->SUPER::syswrite($buff, $Slowloris::WriteBytes, $off); defined($n) or return undef; $off += $n; } return $off - $w; } sub sysread { my $sock = shift; sleep $SleepBeforeRead if $SleepBeforeRead; return $sock->SUPER::sysread(@_); } package Slowloris::Server; use parent qw(HTTP::Server::PSGI); sub setup_listener { my $self = shift; $self->SUPER::setup_listener(@_); bless $self->{listen_sock}, 'Slowloris::Socket'; } 1; Util.pm100664001750001750 373412560625033 15413 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/tpackage t::Util; use strict; use warnings; use base qw/Exporter/; use Test::More; use Furl::HTTP; use Fcntl qw(O_CREAT O_RDWR SEEK_SET); our @EXPORT = qw/online skip_if_offline/; my $orig = \&Furl::new; sub wrapped_env_proxy { my ($class, %args) = @_; $args{proxy} = $ENV{HTTP_PROXY} if ($args{url}||'') !~ /^https?:\/\/\d+/; return $orig->($class, %args); }; { no strict 'refs'; no warnings 'redefine'; *Furl::new = \&wrapped_env_proxy if $ENV{TEST_ENV_PROXY}; } # taken from LWP::Online my @RELIABLE_HTTP = ( # These are some initial trivial checks. # The regex are case-sensitive to at least # deal with the "couldn't get site.com case". 'http://google.com/' => sub { /About Google/ }, 'http://yahoo.com/' => sub { $_ =~ /Yahoo!/ }, 'http://amazon.com/' => sub { /Amazon/ and /Cart/ }, 'http://cnn.com/' => sub { /CNN/ }, ); sub online () { # return the cache if exists sysopen my $cache, '.online', O_CREAT | O_RDWR or return 0; my $online = <$cache>; if(defined $online) { return $online; # cache } my $furl = Furl::HTTP->new(timeout => 5); my $good = 0; my $bad = 0; note 'checking if online'; $online = eval { for (my $i=0; $i<@RELIABLE_HTTP; $i+=2) { my ($url, $check) = @RELIABLE_HTTP[$i, $i+1]; note "getting $url"; my ($version, $code, $msg, $headers, $content) = $furl->request(url => $url); note "$code $msg"; local $_ = $content; if ($code == 200 && $check->()) { $good++; } else { $bad++; } return 1 if $good > 1; return 0 if $bad > 2; } }; diag $@ if $@; seek $cache, 0, SEEK_SET; print $cache $online ? 1 : 0; close $cache; return $online; } sub skip_if_offline { plan skip_all => "This test requires online env" unless online(); } 1; 02_perlcritic.t100664001750001750 240312560625033 17146 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/xtuse strict; use warnings; use Test::More; eval { require Perl::Critic; Perl::Critic->VERSION(1.105); require Test::Perl::Critic; Test::Perl::Critic->VERSION(1.02); Test::Perl::Critic->import( -profile => \(join q{}, ) ); }; note $@ if $@; plan skip_all => "Perl::Critic 1.105+ or Test::Perl::Critic 1.02+ is not installed." if $@; all_critic_ok('lib', 'script', 'bin'); __END__ only=1 # ------------------------------------------------------------------------- # Not important. [BuiltinFunctions::ProhibitSleepViaSelect] [BuiltinFunctions::RequireGlobFunction] [ClassHierarchies::ProhibitOneArgBless] # ------------------------------------------------------------------------- # Bug detection [InputOutput::ProhibitBarewordFileHandles] [Modules::RequireFilenameMatchesPackage] [Subroutines::ProhibitNestedSubs] [Subroutines::ProhibitReturnSort] [TestingAndDebugging::RequireUseStrict] [Variables::ProhibitConditionalDeclarations] [Variables::RequireLexicalLoopIterators] [TestingAndDebugging::ProhibitNoStrict] allow=refs # ------------------------------------------------------------------------- # Security issue detection [InputOutput::RequireEncodingWithUTF8Layer] [Modules::ProhibitEvilModules] [InputOutput::ProhibitTwoArgOpen] 04_leaktrace.t100664001750001750 113212560625033 16741 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/xt#!perl -w use strict; use Test::Requires qw(Plack::Request HTTP::Body), qw(Test::LeakTrace); use Test::More; use Furl; no_leaks_ok { my $furl = Furl->new(); my $res = $furl->request( method => 'GET', host => 'example.com', path => '/', ); $res->is_success or die $res->status_line; }; my $furl = Furl->new(); no_leaks_ok { for(1 .. 5) { my $res = $furl->request( method => 'GET', host => 'example.com', path => '/', ); $res->is_success or die $res->status_line; } }; done_testing; 05_valgrind.t100664001750001750 22512560625033 16577 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/xtuse Test::More; eval 'use Test::Valgrind'; plan skip_all => 'Test::Valgrind is required to test your distribution with valgrind' if $@; leaky(); 01_idn.t100664001750001750 61712560625033 17411 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/xt/200_onlineuse strict; use warnings; use utf8; use t::Util; use Test::More; use Furl; use Test::Requires qw(Plack::Request HTTP::Body), 'Net::IDN::Encode'; skip_if_offline(); my $url = 'http://日本語.jp/'; my $furl = Furl->new(); my $res = $furl->get($url); ok $res->is_success or $res->status_line; utf8::decode($url); $res = $furl->get($url); ok $res->is_success or $res->status_line; done_testing; 02_google.t100664001750001750 51012560625033 20104 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/xt/200_onlineuse strict; use warnings; use utf8; use t::Util; use Test::More; use Furl; skip_if_offline(); my $url = 'http://www.google.co.jp/'; my $furl = Furl->new(); $furl->env_proxy(); for(1 .. 2) { note "getting"; my $res = $furl->get($url); note "done"; ok $res->is_success or diag $res->status_line } done_testing; 03_yahoo_com.t100664001750001750 57212560625033 20616 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/xt/200_onlineuse strict; use warnings; use utf8; use t::Util; use Test::More; use Furl; plan skip_all => 'SSL cert error' if $ENV{TRAVIS}; skip_if_offline(); my $url = 'http://www.yahoo.com/'; my $furl = Furl->new(); $furl->env_proxy(); for(1 .. 2) { note "getting"; my $res = $furl->get($url); note "done"; ok $res->is_success or die $res->status_line; } done_testing; 04_ssl.t100664001750001750 75412560625033 17445 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/xt/200_onlineuse strict; use warnings; use utf8; use Test::More; use Test::Requires qw(Plack::Request HTTP::Body), qw(IO::Socket::SSL); use Furl; use IO::Socket::SSL; use t::Util; # this test moved to xt/ since mixi's ssl sucks. # ref. http://www.machu.jp/diary/20080918.html#p01 skip_if_offline(); my $furl = Furl->new(); $furl->env_proxy(); for my $url('https://mixi.jp/', 'https://mixi.jp') { my $res = $furl->get($url); ok $res->is_success, $url or diag $res->status_line; } done_testing; 05_connect_error.t100664001750001750 517112560625033 21525 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/xt/200_onlineuse strict; use warnings; use Furl::HTTP; use Test::More; use Test::Requires qw(Plack::Request HTTP::Body), qw(IO::Socket::SSL); use Time::HiRes qw(time); my $n = shift(@ARGV) || 2; # TODO add proxy tests note 'name resolution error'; { my $furl = Furl::HTTP->new(timeout => 60); my (undef, $code, $msg, $headers, $content) = $furl->request( host => 'a.', # an non-existent gTLD port => 80, path_query => '/foo', ); is $code, 500, "nameerror"; like $msg, qr/Internal Response: Cannot resolve host name: a/; is ref($headers), 'ARRAY'; ok $content, "content: $content"; } note 'refused error'; { my $furl = Furl::HTTP->new( timeout => 60, ssl_opts => { SSL_verify_mode => IO::Socket::SSL::SSL_VERIFY_PEER(), }, ); for my $scheme (qw(http https)) { for (1 .. $n) { my $start_at = time; my (undef, $code, $msg, $headers, $content) = $furl->request( host => '255.255.255.255', port => 80, scheme => $scheme, path_query => '/foo', ); my $elapsed = time - $start_at; is $code, 500, "request/$scheme/$_"; if (Furl::HTTP::WIN32) { like $msg, qr/Internal Response: (Failed to send HTTP request:|Cannot create SSL connection:)/; } else { like $msg, qr/Internal Response: (Cannot connect to 255.255.255.255:80:|Cannot create SSL connection:)/; } is ref($headers), 'ARRAY'; ok $content, "content: $content"; ok $elapsed < 0.5 unless Furl::HTTP::WIN32 && $scheme eq 'https'; } } } note 'timeout error'; # Timeout parameter of IO::Socket::SSL does not seem to be accurate, so only test http for my $scheme (qw(http)) { for my $timeout (1.5, 4, 8) { my $furl = Furl::HTTP->new(timeout => $timeout); my $start_at = time; my (undef, $code, $msg, $headers, $content) = $furl->request( host => 'google.com', port => 81, scheme => $scheme, path_query => '/foo', ); my $elapsed = time - $start_at; is $code, 500, "request/$scheme/timeout/$timeout"; like $msg, qr/Internal Response: Cannot connect to google.com:81:/; is ref($headers), 'ARRAY'; ok $content, "content: $content"; ok $timeout - 0.1 <= $elapsed && $elapsed <= $timeout + 1, "elapsed: $elapsed"; } } done_testing; 06_net-dns-lite.t100664001750001750 324212560625033 21164 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/xt/200_onlineuse strict; use warnings; use Furl::HTTP; use Test::More; use Test::Requires qw(Plack::Request HTTP::Body), qw(Net::DNS::Lite); use Time::HiRes qw(time sleep); my $n = shift(@ARGV) || 2; # TODO add proxy tests { my $furl = Furl::HTTP->new( inet_aton => sub { Net::DNS::Lite::inet_aton(@_) }, ); for (1 .. $n) { my $start_at = time; my (undef, $code, $msg, $headers, $content) = $furl->request( host => 'google.com', # authoritative dns does not respond port => 80, path_query => '/', ); my $elapsed = time - $start_at; is $code, 200, "request/$_"; is ref($headers), 'ARRAY'; } } note 'dns timeout'; { my $called_inet_aton = 0; my $furl = Furl::HTTP->new( timeout => 1, inet_aton => sub { # mimic timeout my ($name, $timeout) = @_; $called_inet_aton++; sleep $timeout; return undef; } ); for (1 .. $n) { my $start_at = time; my (undef, $code, $msg, $headers, $content) = $furl->request( host => 'www.google.com.', # would fail anyway, since inet_aton always returns timeout port => 80, path_query => '/foo', ); my $elapsed = time - $start_at; is $code, 500, "request/$_"; like $msg, qr/Internal Response: Cannot resolve host name: www\.google\.com/; is ref($headers), 'ARRAY'; ok $content, "content: $content"; ok 0.5 <= $elapsed && $elapsed < 1.5, "elapsed: $elapsed"; note "inet_aton calling count: $called_inet_aton"; } } done_testing; 07_ssl_shutdown.t100664001750001750 40412560625033 21373 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/xt/200_online#!perl use strict; use warnings; use Test::More; use Furl; use IO::Socket::SSL; my $res = Furl->new( ssl_opts => { SSL_verify_mode => SSL_VERIFY_PEER(), }, )->get('https://foursquare.com/login'); ok $res->is_success, 'SSL get'; done_testing; perlcriticrc100664001750001750 40712560625033 16712 0ustar00tokuhiromtokuhirom000000000000Furl-3.08/xt[TestingAndDebugging::ProhibitNoStrict] allow=refs [-Subroutines::ProhibitSubroutinePrototypes] [-Subroutines::ProhibitExplicitReturnUndef] [TestingAndDebugging::RequireUseStrict] equivalent_modules = perl5i::2 [-ControlStructures::ProhibitMutatingListFunctions] META.yml100664001750001750 422712560625033 15144 0ustar00tokuhiromtokuhirom000000000000Furl-3.08--- abstract: 'Lightning-fast URL fetcher' author: - 'Tokuhiro Matsuno ' build_requires: File::Temp: '0' Test::More: '0.96' Test::Requires: '0' Test::TCP: '2.11' configure_requires: Module::Build: '0.38' dynamic_config: 0 generated_by: 'Minilla/v2.4.1, CPAN::Meta::Converter version 2.150001' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Furl no_index: directory: - t - xt - inc - share - eg - examples - author - builder provides: Furl: file: lib/Furl.pm version: '3.08' Furl::ConnectionCache: file: lib/Furl/ConnectionCache.pm Furl::HTTP: file: lib/Furl/HTTP.pm version: '3.08' Furl::Headers: file: lib/Furl/Headers.pm Furl::Request: file: lib/Furl/Request.pm Furl::Response: file: lib/Furl/Response.pm Furl::ZlibStream: file: lib/Furl/ZlibStream.pm recommends: Compress::Raw::Zlib: '0' HTTP::CookieJar: '0' IO::Socket::SSL: '0' Net::IDN::Encode: '0' requires: Class::Accessor::Lite: '0' Encode: '0' HTTP::Parser::XS: '0.11' MIME::Base64: '0' Mozilla::CA: '0' Scalar::Util: '0' Socket: '0' Time::HiRes: '0' perl: '5.008001' resources: bugtracker: https://github.com/tokuhirom/Furl/issues homepage: https://github.com/tokuhirom/Furl repository: git://github.com/tokuhirom/Furl.git version: '3.08' x_contributors: - 'Keiji, Yoshimi ' - 'Fuji, Goro ' - 'lestrrat ' - 'Audrey Tang ' - 'mattn ' - 'Fuji Goro ' - 'Fuji, Goro ' - 's-aska ' - 'ikasam_a ' - 'xaicron ' - 'Syohei YOSHIDA ' - 'Neil Bowers ' - 'Toshio Ito ' - 'bayashi ' - 'Masahiro Nagano ' - 'HIROSE Masaaki ' - 'Kazuho Oku ' - 'Jari Salmela ' - 'tarao ' - 'kimoto ' MANIFEST100664001750001750 435612560625033 15027 0ustar00tokuhiromtokuhirom000000000000Furl-3.08Build.PL Changes LICENSE META.json README.md TODO author/benchmark/byown.pl author/benchmark/note.mkdn author/benchmark/profile.pl author/benchmark/simple.pl author/mk-chunked-response.pl cpanfile example/get.pl lib/Furl.pm lib/Furl/ConnectionCache.pm lib/Furl/HTTP.pm lib/Furl/Headers.pm lib/Furl/Request.pm lib/Furl/Response.pm lib/Furl/ZlibStream.pm t/00_compile.t t/01_version.t t/100_low/01_simple.t t/100_low/03_redirect.t t/100_low/04_chunked.t t/100_low/05_slowloris.t t/100_low/06_errors.t t/100_low/07_timeout.t t/100_low/08_proxy.t t/100_low/09_body.t t/100_low/11_write_file.t t/100_low/12_write_code.t t/100_low/13_deflate.t t/100_low/15_multiline_header.t t/100_low/16_read_callback.t t/100_low/17_keep_alive.t t/100_low/18_no_proxy.t t/100_low/19_special_headers.t t/100_low/20_header_format_none.t t/100_low/21_keep_alive_timedout.t t/100_low/22_keep_alive_http10.t t/100_low/23_redirect_relative.t t/100_low/24_no_content.t t/100_low/25_signal.t t/100_low/26_headers_only.t t/100_low/27_close_on_eof.t t/100_low/28_idn.t t/100_low/29_completion_slash.t t/100_low/30_user_agent.t t/100_low/31_chunked_unexpected_eof.t t/100_low/32_proxy_auth.t t/100_low/33_basic_auth.t t/100_low/34_keep_request.t t/100_low/35_get_address.t t/100_low/36_inactivity_timeout.t t/100_low/37_bad_content_length.t t/300_high/01_simple.t t/300_high/02_agent.t t/300_high/04_http_request.t t/300_high/05_suppress_dup_host_header.t t/300_high/06_keep_request.t t/300_high/07_cookie.t t/300_high/99_error.t t/400_components/001_response-coding/01-file.t t/400_components/001_response-coding/t-euc-jp.html t/400_components/001_response-coding/t-iso-2022-jp.html t/400_components/001_response-coding/t-null.html t/400_components/001_response-coding/t-shiftjis.html t/400_components/001_response-coding/t-utf-8.html t/400_components/01_headers.t t/400_components/02_response.t t/400_components/03_request.t t/800_regression/01_capture_request.t t/999_intrenal/parse_url.t t/HTTPServer.pm t/Slowloris.pm t/Util.pm xt/02_perlcritic.t xt/04_leaktrace.t xt/05_valgrind.t xt/200_online/01_idn.t xt/200_online/02_google.t xt/200_online/03_yahoo_com.t xt/200_online/04_ssl.t xt/200_online/05_connect_error.t xt/200_online/06_net-dns-lite.t xt/200_online/07_ssl_shutdown.t xt/perlcriticrc META.yml MANIFEST