From: Charles McGarvey Date: Sun, 12 Mar 2017 01:31:00 +0000 (-0700) Subject: Version 0.900 X-Git-Url: https://git.dogcows.com/gitweb?a=commitdiff_plain;h=refs%2Fheads%2Fdist;p=chaz%2Fp5-HTTP-AnyUA Version 0.900 --- 37ab95fa8e56c3e7bb45016a42bb8b93cbf2f9a8 diff --git a/.travis.yml b/.travis.yml new file mode 100644 index 0000000..6e0e2fe --- /dev/null +++ b/.travis.yml @@ -0,0 +1,23 @@ +sudo: false +language: perl +perl: + - '5.24' + - '5.22' + - '5.20' + - '5.18' + - '5.16' + - '5.14' + - '5.12' + - '5.10' + - '5.8' +matrix: + allow_failures: + - perl: '5.8' + fast_finish: true +branches: + only: /^(dist|build\/.*)$/ +before_install: + - rm .travis.yml + - export AUTHOR_TESTING=0 +install: + - cpanm --installdeps --verbose . diff --git a/Changes b/Changes new file mode 100644 index 0000000..42421d4 --- /dev/null +++ b/Changes @@ -0,0 +1,6 @@ +Revision history for HTTP-AnyUA. + +0.900 2017-03-11 18:28:59-07:00 MST7MDT + + * Initial release + diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..a2abd4e --- /dev/null +++ b/LICENSE @@ -0,0 +1,379 @@ +This software is copyright (c) 2017 by Charles McGarvey. + +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) 2017 by Charles McGarvey. + +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, Fifth Floor, Boston, MA 02110-1301 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) 2017 by Charles McGarvey. + +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 + diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..3f765e2 --- /dev/null +++ b/MANIFEST @@ -0,0 +1,51 @@ +# This file was automatically generated by Dist::Zilla::Plugin::Manifest v6.009. +.travis.yml +Changes +LICENSE +MANIFEST +META.json +META.yml +Makefile.PL +README +lib/HTTP/AnyUA.pm +lib/HTTP/AnyUA/Backend.pm +lib/HTTP/AnyUA/Backend/AnyEvent/HTTP.pm +lib/HTTP/AnyUA/Backend/Furl.pm +lib/HTTP/AnyUA/Backend/HTTP/AnyUA.pm +lib/HTTP/AnyUA/Backend/HTTP/Tiny.pm +lib/HTTP/AnyUA/Backend/LWP/UserAgent.pm +lib/HTTP/AnyUA/Backend/Mojo/UserAgent.pm +lib/HTTP/AnyUA/Backend/Net/Curl/Easy.pm +lib/HTTP/AnyUA/Util.pm +t/00-compile.t +t/00-report-prereqs.dd +t/00-report-prereqs.t +t/01-new.t +t/02-shortcuts.t +t/03-post_form.t +t/04-internal-exception.t +t/10-get.t +t/11-post.t +t/12-put.t +t/13-head.t +t/14-delete.t +t/15-custom-method.t +t/20-data_callback.t +t/21-basic-auth.t +t/22-redirects.t +t/23-content-coderef.t +t/app.psgi +t/lib/MockBackend.pm +t/lib/Server.pm +t/lib/Util.pm +xt/author/clean-namespaces.t +xt/author/critic.t +xt/author/eol.t +xt/author/no-tabs.t +xt/author/pod-coverage.t +xt/author/pod-no404s.t +xt/author/pod-syntax.t +xt/author/portability.t +xt/release/cpan-changes.t +xt/release/distmeta.t +xt/release/minimum-version.t diff --git a/META.json b/META.json new file mode 100644 index 0000000..6e524f4 --- /dev/null +++ b/META.json @@ -0,0 +1,158 @@ +{ + "abstract" : "An HTTP user agent programming interface unification layer", + "author" : [ + "Charles McGarvey " + ], + "dynamic_config" : 0, + "generated_by" : "Dist::Zilla version 6.009, CPAN::Meta::Converter version 2.150005", + "license" : [ + "perl_5" + ], + "meta-spec" : { + "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", + "version" : 2 + }, + "name" : "HTTP-AnyUA", + "no_index" : { + "directory" : [ + "eg", + "share", + "shares", + "t", + "xt" + ] + }, + "prereqs" : { + "configure" : { + "requires" : { + "ExtUtils::MakeMaker" : "0" + } + }, + "develop" : { + "requires" : { + "Dist::Zilla" : "5", + "Dist::Zilla::Plugin::Prereqs" : "0", + "Dist::Zilla::PluginBundle::Author::CCM" : "0", + "English" : "0", + "Pod::Coverage::TrustPod" : "0", + "Software::License::Perl_5" : "0", + "Test::CPAN::Changes" : "0.19", + "Test::CPAN::Meta" : "0", + "Test::CleanNamespaces" : "0.15", + "Test::EOL" : "0", + "Test::MinimumVersion" : "0", + "Test::More" : "0.96", + "Test::NoTabs" : "0", + "Test::Pod" : "1.41", + "Test::Pod::Coverage" : "1.08", + "Test::Pod::No404s" : "0", + "Test::Portability::Files" : "0" + } + }, + "runtime" : { + "requires" : { + "Carp" : "0", + "Exporter" : "0", + "Fcntl" : "0", + "Future" : "0", + "MIME::Base64" : "0", + "Module::Loader" : "0", + "Scalar::Util" : "0", + "Time::Local" : "0", + "bytes" : "0", + "parent" : "0", + "perl" : "5.010", + "strict" : "0", + "warnings" : "0" + }, + "suggests" : { + "HTTP::Tiny" : "0" + } + }, + "test" : { + "recommends" : { + "CPAN::Meta" : "2.120900" + }, + "requires" : { + "ExtUtils::MakeMaker" : "0", + "File::Spec" : "0", + "IO::Handle" : "0", + "IPC::Open3" : "0", + "Test2::API" : "0", + "Test::Exception" : "0", + "Test::More" : "0", + "blib" : "1.01", + "lib" : "0" + }, + "suggests" : { + "AnyEvent::HTTP" : "0", + "Furl" : "0", + "HTTP::Tiny" : "0", + "JSON" : "0", + "LWP::UserAgent" : "0", + "Mojo::UserAgent" : "0", + "Net::Curl::Easy" : "0", + "Plack::Runner" : "0", + "Starman" : "0" + } + } + }, + "provides" : { + "HTTP::AnyUA" : { + "file" : "lib/HTTP/AnyUA.pm", + "version" : "0.900" + }, + "HTTP::AnyUA::Backend" : { + "file" : "lib/HTTP/AnyUA/Backend.pm", + "version" : "0.900" + }, + "HTTP::AnyUA::Backend::AnyEvent::HTTP" : { + "file" : "lib/HTTP/AnyUA/Backend/AnyEvent/HTTP.pm", + "version" : "0.900" + }, + "HTTP::AnyUA::Backend::Furl" : { + "file" : "lib/HTTP/AnyUA/Backend/Furl.pm", + "version" : "0.900" + }, + "HTTP::AnyUA::Backend::HTTP::AnyUA" : { + "file" : "lib/HTTP/AnyUA/Backend/HTTP/AnyUA.pm", + "version" : "0.900" + }, + "HTTP::AnyUA::Backend::HTTP::Tiny" : { + "file" : "lib/HTTP/AnyUA/Backend/HTTP/Tiny.pm", + "version" : "0.900" + }, + "HTTP::AnyUA::Backend::LWP::UserAgent" : { + "file" : "lib/HTTP/AnyUA/Backend/LWP/UserAgent.pm", + "version" : "0.900" + }, + "HTTP::AnyUA::Backend::Mojo::UserAgent" : { + "file" : "lib/HTTP/AnyUA/Backend/Mojo/UserAgent.pm", + "version" : "0.900" + }, + "HTTP::AnyUA::Backend::Net::Curl::Easy" : { + "file" : "lib/HTTP/AnyUA/Backend/Net/Curl/Easy.pm", + "version" : "0.900" + }, + "HTTP::AnyUA::Util" : { + "file" : "lib/HTTP/AnyUA/Util.pm", + "version" : "0.900" + } + }, + "release_status" : "stable", + "resources" : { + "bugtracker" : { + "web" : "https://github.com/chazmcgarvey/HTTP-AnyUA/issues" + }, + "homepage" : "https://github.com/chazmcgarvey/HTTP-AnyUA", + "repository" : { + "type" : "git", + "url" : "https://github.com/chazmcgarvey/HTTP-AnyUA.git", + "web" : "https://github.com/chazmcgarvey/HTTP-AnyUA" + } + }, + "version" : "0.900", + "x_authority" : "cpan:CCM", + "x_serialization_backend" : "Cpanel::JSON::XS version 3.0225" +} + diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..c83c73e --- /dev/null +++ b/META.yml @@ -0,0 +1,82 @@ +--- +abstract: 'An HTTP user agent programming interface unification layer' +author: + - 'Charles McGarvey ' +build_requires: + ExtUtils::MakeMaker: '0' + File::Spec: '0' + IO::Handle: '0' + IPC::Open3: '0' + Test2::API: '0' + Test::Exception: '0' + Test::More: '0' + blib: '1.01' + lib: '0' +configure_requires: + ExtUtils::MakeMaker: '0' +dynamic_config: 0 +generated_by: 'Dist::Zilla version 6.009, CPAN::Meta::Converter version 2.150005' +license: perl +meta-spec: + url: http://module-build.sourceforge.net/META-spec-v1.4.html + version: '1.4' +name: HTTP-AnyUA +no_index: + directory: + - eg + - share + - shares + - t + - xt +provides: + HTTP::AnyUA: + file: lib/HTTP/AnyUA.pm + version: '0.900' + HTTP::AnyUA::Backend: + file: lib/HTTP/AnyUA/Backend.pm + version: '0.900' + HTTP::AnyUA::Backend::AnyEvent::HTTP: + file: lib/HTTP/AnyUA/Backend/AnyEvent/HTTP.pm + version: '0.900' + HTTP::AnyUA::Backend::Furl: + file: lib/HTTP/AnyUA/Backend/Furl.pm + version: '0.900' + HTTP::AnyUA::Backend::HTTP::AnyUA: + file: lib/HTTP/AnyUA/Backend/HTTP/AnyUA.pm + version: '0.900' + HTTP::AnyUA::Backend::HTTP::Tiny: + file: lib/HTTP/AnyUA/Backend/HTTP/Tiny.pm + version: '0.900' + HTTP::AnyUA::Backend::LWP::UserAgent: + file: lib/HTTP/AnyUA/Backend/LWP/UserAgent.pm + version: '0.900' + HTTP::AnyUA::Backend::Mojo::UserAgent: + file: lib/HTTP/AnyUA/Backend/Mojo/UserAgent.pm + version: '0.900' + HTTP::AnyUA::Backend::Net::Curl::Easy: + file: lib/HTTP/AnyUA/Backend/Net/Curl/Easy.pm + version: '0.900' + HTTP::AnyUA::Util: + file: lib/HTTP/AnyUA/Util.pm + version: '0.900' +requires: + Carp: '0' + Exporter: '0' + Fcntl: '0' + Future: '0' + MIME::Base64: '0' + Module::Loader: '0' + Scalar::Util: '0' + Time::Local: '0' + bytes: '0' + parent: '0' + perl: '5.010' + strict: '0' + warnings: '0' +resources: + bugtracker: https://github.com/chazmcgarvey/HTTP-AnyUA/issues + homepage: https://github.com/chazmcgarvey/HTTP-AnyUA + repository: https://github.com/chazmcgarvey/HTTP-AnyUA.git +version: '0.900' +x_authority: cpan:CCM +x_serialization_backend: 'YAML::Tiny version 1.70' diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..f04ca02 --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,85 @@ +# This file was automatically generated by Dist::Zilla::Plugin::MakeMaker v6.009. +use strict; +use warnings; + +use 5.010; + +use ExtUtils::MakeMaker; + +my %WriteMakefileArgs = ( + "ABSTRACT" => "An HTTP user agent programming interface unification layer", + "AUTHOR" => "Charles McGarvey ", + "CONFIGURE_REQUIRES" => { + "ExtUtils::MakeMaker" => 0 + }, + "DISTNAME" => "HTTP-AnyUA", + "LICENSE" => "perl", + "MIN_PERL_VERSION" => "5.010", + "NAME" => "HTTP::AnyUA", + "PREREQ_PM" => { + "Carp" => 0, + "Exporter" => 0, + "Fcntl" => 0, + "Future" => 0, + "MIME::Base64" => 0, + "Module::Loader" => 0, + "Scalar::Util" => 0, + "Time::Local" => 0, + "bytes" => 0, + "parent" => 0, + "strict" => 0, + "warnings" => 0 + }, + "TEST_REQUIRES" => { + "ExtUtils::MakeMaker" => 0, + "File::Spec" => 0, + "IO::Handle" => 0, + "IPC::Open3" => 0, + "Test2::API" => 0, + "Test::Exception" => 0, + "Test::More" => 0, + "blib" => "1.01", + "lib" => 0 + }, + "VERSION" => "0.900", + "test" => { + "TESTS" => "t/*.t" + } +); + + +my %FallbackPrereqs = ( + "Carp" => 0, + "Exporter" => 0, + "ExtUtils::MakeMaker" => 0, + "Fcntl" => 0, + "File::Spec" => 0, + "Future" => 0, + "IO::Handle" => 0, + "IPC::Open3" => 0, + "MIME::Base64" => 0, + "Module::Loader" => 0, + "Scalar::Util" => 0, + "Test2::API" => 0, + "Test::Exception" => 0, + "Test::More" => 0, + "Time::Local" => 0, + "blib" => "1.01", + "bytes" => 0, + "lib" => 0, + "parent" => 0, + "strict" => 0, + "warnings" => 0 +); + + +unless ( eval { ExtUtils::MakeMaker->VERSION(6.63_03) } ) { + delete $WriteMakefileArgs{TEST_REQUIRES}; + delete $WriteMakefileArgs{BUILD_REQUIRES}; + $WriteMakefileArgs{PREREQ_PM} = \%FallbackPrereqs; +} + +delete $WriteMakefileArgs{CONFIGURE_REQUIRES} + unless eval { ExtUtils::MakeMaker->VERSION(6.52) }; + +WriteMakefile(%WriteMakefileArgs); diff --git a/README b/README new file mode 100644 index 0000000..17ad969 --- /dev/null +++ b/README @@ -0,0 +1,500 @@ +NAME + + HTTP::AnyUA - An HTTP user agent programming interface unification + layer + +VERSION + + version 0.900 + +SYNOPSIS + + my $any_ua = HTTP::AnyUA->new(ua => LWP::UserAgent->new); + # OR: my $any_ua = HTTP::AnyUA->new(ua => Furl->new); + # OR: my $any_ua = HTTP::AnyUA->new(ua => HTTP::Tiny->new); + # etc... + + my $response = $any_ua->get('http://www.example.com/'); + + print "$response->{status} $response->{reason}\n"; + + while (my ($k, $v) = each %{$response->{headers}}) { + for (ref $v eq 'ARRAY' ? @$v : $v) { + print "$k: $_\n"; + } + } + + print $response->{content} if length $response->{content}; + + ### Non-blocking user agents cause Future objects to be returned: + + my $any_ua = HTTP::AnyUA->new(ua => HTTP::Tiny->new, response_is_future => 1); + # OR: my $any_ua = HTTP::AnyUA->new(ua => 'AnyEvent::HTTP'); + # OR: my $any_ua = HTTP::AnyUA->new(ua => Mojo::UserAgent->new); + # etc... + + my $future = $any_ua->get('http://www.example.com/'); + + $future->on_done(sub { + my $response = shift; + + print "$response->{status} $response->{reason}\n"; + + while (my ($k, $v) = each %{$response->{headers}}) { + for (ref $v eq 'ARRAY' ? @$v : $v) { + print "$k: $_\n"; + } + } + + print $response->{content} if length $response->{content}; + }); + + $future->on_fail(sub { print STDERR "Oh no!!\n" }); + +DESCRIPTION + + This module provides a small wrapper for unifying the programming + interfaces of several different actual user agents (HTTP clients) under + one familiar interface. + + Rather than providing yet another programming interface for you to + learn, HTTP::AnyUA follows the HTTP::Tiny interface. This also means + that you can plug in any supported HTTP client (LWP::UserAgent, Furl, + etc.) and use it as if it were HTTP::Tiny. + + There are a lot of great HTTP clients available for Perl, each with + different goals, different feature sets, and of course different + programming interfaces! If you're an end user, you can just pick one of + these clients according to the needs of your project (or personal + preference). But if you're writing a module that needs to interface + with a web server (like perhaps a RESTful API wrapper) and you want + your users to be able to use whatever HTTP client they want, + HTTP::AnyUA can help you support that! + + It's a good idea to let the end user pick whatever HTTP client they + want to use, because they're the one who knows the requirements of + their application or script. If you're writing an event-driven + application, you'll need to use a non-blocking user agent like + Mojo::UserAgent. If you're writing a simple command-line script, you + may decide that your priority is to minimize dependencies and so may + want to go with HTTP::Tiny. + + Unfortunately, many modules on CPAN are hardcoded to work with specific + HTTP clients, leaving the end user unable to use the HTTP client that + would be best for them. Although the end user won't -- or at least + doesn't need to -- use HTTP::AnyUA directly, they will benefit from + client choice if their third-party modules use HTTP::AnyUA or something + like it. + + The primary goal of HTTP::AnyUA is to make it easy for module + developers to write HTTP code once that can work with any HTTP client + the end user may decide to plug in. A secondary goal is to make it easy + for anyone to add support for new or yet-unsupported user agents. + +ATTRIBUTES + + ua + + Get the user agent that was passed to "new". + + response_is_future + + Get and set whether or not responses are Future objects. + + backend + + Get the backend instance. You normally shouldn't need this. + +METHODS + + new + + $any_ua = HTTP::AnyUA->new(ua => $user_agent, %attr); + $any_ua = HTTP::AnyUA->new($user_agent, %attr); + + Construct a new HTTP::AnyUA. + + request + + $response = $any_ua->request($method, $url); + $response = $any_ua->request($method, $url, \%options); + + Make a request, get a response. + + Compare to "request" in HTTP::Tiny. + + get, head, put, post, delete + + $response = $any_ua->get($url); + $response = $any_ua->get($url, \%options); + $response = $any_ua->head($url); + $response = $any_ua->head($url, \%options); + # etc. + + Shortcuts for "request" where the method is the method name rather than + the first argument. + + Compare to "get|head|put|post|delete" in HTTP::Tiny. + + post_form + + $response = $any_ua->post_form($url, $formdata); + $response = $any_ua->post_form($url, $formdata, \%options); + + Does a POST request with the form data encoded and sets the + Content-Type header to application/x-www-form-urlencoded. + + Compare to "post_form" in HTTP::Tiny. + + mirror + + $response = $http->mirror($url, $filepath, \%options); + if ($response->{success}) { + print "$filepath is up to date\n"; + } + + Does a GET request and saves the downloaded document to a file. If the + file already exists, its timestamp will be sent using the + If-Modified-Since request header (which you can override). If the + server responds with a 304 (Not Modified) status, the success field + will be true; this is usually only the case for 2XX statuses. If the + server responds with a Last-Modified header, the file will be updated + to have the same modification timestamp. + + Compare to "mirror" in HTTP::Tiny. This version differs slightly in + that this returns internal exception responses (for cases like being + unable to write the file locally, etc.) rather than actually throwing + the exceptions. The reason for this is that exceptions as responses are + easier to deal with for non-blocking HTTP clients, and the fact that + this method throws exceptions in HTTP::Tiny seems like an inconsistency + in its interface. + + register_backend + + HTTP::AnyUA->register_backend($user_agent_package => $backend_package); + HTTP::AnyUA->register_backend('MyAgent' => 'MyBackend'); # HTTP::AnyUA::Backend::MyBackend + HTTP::AnyUA->register_backend('LWP::UserAgent' => '+SpecialBackend'); # SpecialBackend + + Register a backend for a new user agent type or override a default + backend. Backend packages are relative to the HTTP::AnyUA::Backend:: + namespace unless prefixed with a +. + + If you only need to set a backend as a one-off thing, you could also + pass an instantiated backend to "new". + +SUPPORTED USER AGENTS + + * AnyEvent::HTTP + + * Furl + + * HTTP::AnyUA - a little bit meta, but why not? + + * HTTP::Tiny + + * LWP::UserAgent + + * Mojo::UserAgent + + * Net::Curl::Easy + + Any HTTP client that inherits from one of these in a well-behaved + manner should also be supported. + + Of course, there are many other HTTP clients on CPAN that HTTP::AnyUA + doesn't yet support. I'm more than happy to help add support for + others, so send me a message if you know of an HTTP client that needs + support. See HTTP::AnyUA::Backend for how to write support for a new + HTTP client. + +NON-BLOCKING USER AGENTS + + HTTP::AnyUA tries to target the HTTP::Tiny interface, which is a + blocking interface. This means that when you call "request", it is + supposed to not return until either the response is received or an + error occurs. This doesn't jive well with non-blocking HTTP clients + which expect the flow to reenter an event loop so that the request can + complete concurrently. + + In order to reconcile this, a Future will be returned instead of the + normal hashref response if the wrapped HTTP client is non-blocking + (such as Mojo::UserAgent or AnyEvent::HTTP). This Future object may be + used to set up callbacks that will be called when the request is + completed. You can call "response_is_future" to know if the response is + or will be a Future. + + This is typically okay for the end user; since they're the one who + chose which HTTP client to use in the first place, they should know + whether they should expect a Future or a direct response when they make + an HTTP request, but it does add some burden on you as a module writer + because if you ever need to examine the response, you may need to write + code like this: + + my $resp = $any_ua->get('http://www.perl.org/'); + + if ($any_ua->response_is_future) { + $resp->on_done(sub { + my $real_resp = shift; + handle_response($real_resp); + }); + } + else { + handle_response($resp); # response is the real response already + } + + This actually isn't too annoying to deal with in practice, but you can + avoid it if you like by forcing the response to always be a Future. + Just set the "response_is_future" attribute. Then you don't need to do + an if-else because the response will always be the same type: + + $any_ua->response_is_future(1); + + my $resp = $any_ua->get('http://www.perl.org/'); + + $resp->on_done(sub { # response is always a Future + my $real_resp = shift; + handle_response($real_resp); + }); + + Note that this doesn't make a blocking HTTP client magically + non-blocking. The call to "request" will still block if the client is + blocking, and your "done" callback will simply be fired immediately. + But this does let you write the same code in your module and have it + work regardless of whether the underlying HTTP client is blocking or + non-blocking. + + The default behavior is to return a direct hashref response if the HTTP + client is blocking and a Future if the client is non-blocking. It's up + to you to decide whether or not to set response_is_future, and you + should also consider whether you want to expose the possibility of + either type of response or always returning Future objects to the end + user of your module. It doesn't matter for users who choose + non-blocking HTTP clients because they will be using Future objects + either way, but users who know they are using a blocking HTTP client + may appreciate not having to deal with Future objects at all. + +FREQUENTLY ASKED QUESTIONS + + How do I set up proxying, SSL, cookies, timeout, etc.? + + HTTP::AnyUA provides a common interface for using HTTP clients, not for + instantiating or configuring them. Proxying, SSL, and other custom + settings can be configured directly through the underlying HTTP client; + see the documentation for your particular user agent to learn how to + configure these things. + + AnyEvent::HTTP is a bit of a special case because there is no + instantiated object representing the client. For this particular user + agent, you can configure the backend to pass a default set of options + whenever it calls http_request. See "options" in + HTTP::AnyUA::Backend::AnyEvent::HTTP: + + $any_ua->backend->options({recurse => 5, timeout => 15}); + + If you are a module writer, you should probably receive a user agent + from your end user and leave this type of configuration up to them. + + Why use HTTP::AnyUA instead of some other HTTP client? + + Maybe you shouldn't. If you're an end user writing a script or + application, you can just pick the HTTP client that suits you best and + use it. For example, if you're writing a Mojolicious app, you're not + going wrong by using Mojo::UserAgent; it's loaded with features and is + well-integrated with that particular environment. + + As an end user, you could wrap the HTTP client you pick in an + HTTP::AnyUA object, but the only reason to do this is if you prefer + using the HTTP::Tiny interface. + + The real benefit of HTTP::AnyUA (or something like it) is if module + writers use it to allow end users of their modules to be able to plug + in whatever HTTP client they want. For example, a module that + implements an API wrapper that has a hard dependency on LWP::UserAgent + or even HTTP::Tiny is essentially useless for non-blocking + applications. If the same hypothetical module had been written using + HTTP::AnyUA then it would be useful in any scenario. + + Why use the HTTP::Tiny interface? + + The HTTP::Tiny interface is simple but provides all the essential + functionality needed for a capable HTTP client and little more. That + makes it easy to provide an implementation for, and it also makes it + straightforward for module authors to use. + + Marrying the HTTP::Tiny interface with Future gives us these benefits + for both blocking and non-blocking modules and applications. + +SPECIFICATION + + This section specifies a standard set of data structures that can be + used to make a request and get a response from a user agent. This is + the specification HTTP::AnyUA uses for its programming interface. It is + heavily based on HTTP::Tiny's interface, and parts of this + specification were adapted or copied verbatim from that module's + documentation. The intent is for this specification to be written such + that HTTP::Tiny is already a compliant implementor of the specification + (at least as of the specification's publication date). + + The Request + + A request is a tuple of the form (Method, URL) or (Method, URL, + Options). + + Method + + Method MUST be a string representing the HTTP verb. This is commonly + "GET", "POST", "HEAD", "DELETE", etc. + + URL + + URL MUST be a string representing the remote resource to be acted upon. + The URL MUST have unsafe characters escaped and international domain + names encoded before being passed to the user agent. A user agent MUST + generated a "Host" header based on the URL in accordance with RFC 2616; + a user agent MAY throw an error if a "Host" header is given with the + "headers". + + Options + + Options, if present, MUST be a hash reference containing zero or more + of the following keys with appropriate values. A user agent MAY support + more options than are specified here. + + headers + + The value for the headers key MUST be a hash reference containing zero + or more HTTP header names (as keys) and header values. The value for a + header MUST be either a string containing the header value OR an array + reference where each item is a string. If the value for a header is an + array reference, the user agent MUST output the header multiple times + with each value in the array. + + User agents MAY may add headers, but SHOULD NOT replace user-specified + headers unless otherwise documented. + + content + + The value for the content key MUST be a string OR a code reference. If + the value is a string, its contents will be included with the request + as the body. If the value is a code reference, the referenced code will + be called iteratively to produce the body of the request, and the code + MUST return an empty string or undef value to indicate the end of the + request body. If the value is a code reference, a user agent SHOULD use + chunked transfer encoding if it supports it, otherwise a user agent MAY + completely drain the code of content before sending the request. + + data_callback + + The value for the data_callback key MUST be a code reference that will + be called zero or more times, once for each "chunk" of response body + received. A user agent MAY send the entire response body in one call. + The referenced code MUST be given two arguments; the first is a string + containing a chunk of the response body, the second is an in-progress + response. + + The Response + + A response MUST be a hash reference containg some required keys and + values. A response MAY contain some optional keys and values. + + success + + A response MUST include a success key, the value of which is a boolean + indicating whether or not the request is to be considered a success + (true is a success). Unless otherwise documented, a successful result + means that the operation returned a 2XX status code. + + url + + A response MUST include a url key, the value of which is the URL that + provided the response. This is the URL used in the request unless there + were redirections, in which case it is the last URL queried in a + rediretion chain. + + status + + A response MUST include a status key, the value of which is the HTTP + status code of the response. If an internal exception occurs (e.g. + connection error), then the status code MUST be 599. + + reason + + A response MUST include a reason key, the value of which is the + response phrase returned by the server OR "Internal Exception" if an + internal exception occurred. + + content + + A response MAY include a content key, the value of which is the + response body returned by the server OR the text of the exception if an + internal exception occurred. This field MUST be missing or empty if the + server provided no response OR if the body was already provided via + "data_callback". + + headers + + A response SHOULD include a headers key, the value of which is a hash + reference containing zero or more HTTP header names (as keys) and + header values. Keys MUST be lowercased. The value for a header MUST be + either a string containing the header value OR an array reference where + each item is the value of one of the repeated headers. + + redirects + + A response MAY include a redirects key, the value of which is an array + reference of one or more responses from redirections that occurred to + fulfill the current request, in chronological order. + +ENVIRONMENT + + * PERL_HTTP_ANYUA_DEBUG - If 1, print some info useful for debugging + to STDERR. + +CAVEATS + + Not all HTTP clients implement the same features or in the same ways. + While the point of HTTP::AnyUA is to hide those differences, you may + notice some (hopefully) insignificant differences when plugging in + different clients. For example, LWP::UserAgent sets some headers on the + response such as client-date and client-peer that won't appear when + using other clients. Little differences like these probably aren't big + deal. Other differences may be a bigger deal, depending on what's + important to you. For example, some clients (like HTTP::Tiny) may do + chunked transfer encoding in situations where other clients won't + (probably because they don't support it). It's not a goal of this + project to eliminate all of the differences, but if you come across a + difference that is significant enough that you think you need to detect + the user agent and write special logic, I would like to learn about + your use case. + +SEE ALSO + + These modules share similar goals or provide overlapping functionality: + + * Future::HTTP + + * HTTP::Any + + * HTTP::Tinyish + + * Plient + +BUGS + + Please report any bugs or feature requests on the bugtracker website + https://github.com/chazmcgarvey/HTTP-AnyUA/issues + + When submitting a bug or request, please include a test-file or a patch + to an existing test-file that illustrates the bug or desired feature. + +AUTHOR + + Charles McGarvey + +COPYRIGHT AND LICENSE + + This software is copyright (c) 2017 by Charles McGarvey. + + This is free software; you can redistribute it and/or modify it under + the same terms as the Perl 5 programming language system itself. + diff --git a/lib/HTTP/AnyUA.pm b/lib/HTTP/AnyUA.pm new file mode 100644 index 0000000..6d44018 --- /dev/null +++ b/lib/HTTP/AnyUA.pm @@ -0,0 +1,796 @@ +package HTTP::AnyUA; +# ABSTRACT: An HTTP user agent programming interface unification layer + + +use 5.010; +use warnings; +use strict; + +our $VERSION = '0.900'; # VERSION + +use HTTP::AnyUA::Util; +use Module::Loader; +use Scalar::Util; + + +our $BACKEND_NAMESPACE; +our @BACKENDS; +our %REGISTERED_BACKENDS; + +BEGIN { + $BACKEND_NAMESPACE = __PACKAGE__ . '::Backend'; +} + + +sub _debug_log { print STDERR join(' ', @_), "\n" if $ENV{PERL_HTTP_ANYUA_DEBUG} } + +sub _croak { require Carp; Carp::croak(@_) } +sub _usage { _croak("Usage: @_\n") } + + + +sub new { + my $class = shift; + unshift @_, 'ua' if @_ % 2; + my %args = @_; + $args{ua} or _usage(q{HTTP::AnyUA->new(ua => $user_agent, %attr)}); + + my $self; + my @attr = qw(ua backend response_is_future); + + for my $attr (@attr) { + $self->{$attr} = $args{$attr} if defined $args{$attr}; + } + + bless $self, $class; + + $self->_debug_log('Created with user agent', $self->ua); + + # call accessors to get the checks to run + $self->ua; + $self->response_is_future($args{response_is_future}) if defined $args{response_is_future}; + + return $self; +} + + +sub ua { shift->{ua} or _croak 'User agent is required' } + + +sub response_is_future { + my $self = shift; + my $val = shift; + + if (defined $val) { + $self->_debug_log('Set response_is_future to', $val ? 'ON' : 'OFF'); + + $self->_check_response_is_future($val); + $self->{response_is_future} = $val; + + $self->_module_loader->load('Future') if $self->{response_is_future}; + } + elsif (!defined $self->{response_is_future} && $self->{backend}) { + $self->{response_is_future} = $self->backend->response_is_future; + + $self->_module_loader->load('Future') if $self->{response_is_future}; + } + + return $self->{response_is_future} || ''; +} + + +sub backend { + my $self = shift; + + return $self->{backend} if defined $self->{backend}; + + $self->{backend} = $self->_build_backend; + $self->_check_response_is_future($self->response_is_future); + + return $self->{backend}; +} + + +sub request { + my ($self, $method, $url, $args) = @_; + $args ||= {}; + @_ == 3 || (@_ == 4 && ref $args eq 'HASH') + or _usage(q{$any_ua->request($method, $url, \%options)}); + + my $resp = eval { $self->backend->request(uc($method) => $url, $args) }; + if (my $err = $@) { + return $self->_wrap_internal_exception($err); + } + + return $self->_wrap_response($resp); +} + + +# adapted from HTTP/Tiny.pm +for my $sub_name (qw{get head put post delete}) { + my %swap = (SUBNAME => $sub_name, METHOD => uc($sub_name)); + my $code = q[ +sub {{SUBNAME}} { + my ($self, $url, $args) = @_; + @_ == 2 || (@_ == 3 && ref $args eq 'HASH') + or _usage(q{$any_ua->{{SUBNAME}}($url, \%options)}); + return $self->request('{{METHOD}}', $url, $args); +} + ]; + $code =~ s/\{\{([A-Z_]+)\}\}/$swap{$1}/ge; + eval $code; ## no critic +} + + +# adapted from HTTP/Tiny.pm +sub post_form { + my ($self, $url, $data, $args) = @_; + (@_ == 3 || @_ == 4 && ref $args eq 'HASH') + or _usage(q{$any_ua->post_form($url, $formdata, \%options)}); + + my $headers = {}; + while (my ($key, $value) = each %{$args->{headers} || {}}) { + $headers->{lc $key} = $value; + } + delete $args->{headers}; + + return $self->request(POST => $url, { + %$args, + content => HTTP::AnyUA::Util::www_form_urlencode($data), + headers => { + %$headers, + 'content-type' => 'application/x-www-form-urlencoded', + }, + }); +} + + +# adapted from HTTP/Tiny.pm +sub mirror { + my ($self, $url, $file, $args) = @_; + @_ == 3 || (@_ == 4 && ref $args eq 'HASH') + or _usage(q{$any_ua->mirror($url, $filepath, \%options)}); + + if (exists $args->{headers}) { + my $headers = {}; + while (my ($key, $value) = each %{$args->{headers} || {}}) { + $headers->{lc($key)} = $value; + } + $args->{headers} = $headers; + } + + if (-e $file and my $mtime = (stat($file))[9]) { + $args->{headers}{'if-modified-since'} ||= HTTP::AnyUA::Util::http_date($mtime); + } + my $tempfile = $file . int(rand(2**31)); + + # set up the response body to be written to the file + require Fcntl; + sysopen(my $fh, $tempfile, Fcntl::O_CREAT()|Fcntl::O_EXCL()|Fcntl::O_WRONLY()) + or return $self->_wrap_internal_exception(qq/Error: Could not create temporary file $tempfile for downloading: $!\n/); + binmode $fh; + $args->{data_callback} = sub { print $fh $_[0] }; + + my $resp = $self->request(GET => $url, $args); + + my $finish = sub { + my $resp = shift; + + close $fh + or return HTTP::AnyUA::Util::internal_exception(qq/Error: Caught error closing temporary file $tempfile: $!\n/); + + if ($resp->{success}) { + rename($tempfile, $file) + or return HTTP::AnyUA::Util::internal_exception(qq/Error replacing $file with $tempfile: $!\n/); + my $lm = $resp->{headers}{'last-modified'}; + if ($lm and my $mtime = HTTP::AnyUA::Util::parse_http_date($lm)) { + utime($mtime, $mtime, $file); + } + } + unlink($tempfile); + + $resp->{success} ||= $resp->{status} eq '304'; + + return $resp; + }; + + if ($self->response_is_future) { + return $resp->followed_by(sub { + my $future = shift; + my @resp = $future->is_done ? $future->get : $future->failure; + my $resp = $finish->(@resp); + if ($resp->{success}) { + return Future->done(@resp); + } + else { + return Future->fail(@resp); + } + }); + } + else { + return $finish->($resp); + } +} + + +sub register_backend { + my ($class, $ua_type, $backend_class) = @_; + @_ == 3 or _usage(q{HTTP::AnyUA->register_backend($ua_type, $backend_package)}); + + if ($backend_class) { + $backend_class = "${BACKEND_NAMESPACE}::${backend_class}" unless $backend_class =~ s/^\+//; + $REGISTERED_BACKENDS{$ua_type} = $backend_class; + } + else { + delete $REGISTERED_BACKENDS{$ua_type}; + } +} + + +# turn a response into a Future if it needs to be +sub _wrap_response { + my $self = shift; + my $resp = shift; + + if ($self->response_is_future && !$self->backend->response_is_future) { + # wrap the response in a Future + if ($resp->{success}) { + $self->_debug_log('Wrapped successful response in a Future'); + $resp = Future->done($resp); + } + else { + $self->_debug_log('Wrapped failed response in a Future'); + $resp = Future->fail($resp); + } + } + + return $resp; +} + +sub _wrap_internal_exception { shift->_wrap_response(HTTP::AnyUA::Util::internal_exception(@_)) } + +# get a module loader object +sub _module_loader { shift->{_module_loader} ||= Module::Loader->new } + +# get a list of potential backends that may be able to handle the user agent +sub _build_backend { + my $self = shift; + my $ua = shift || $self->ua or _croak 'User agent is required'; + + my $ua_type = Scalar::Util::blessed($ua); + + my @classes; + + if ($ua_type) { + push @classes, $REGISTERED_BACKENDS{$ua_type} if $REGISTERED_BACKENDS{$ua_type}; + + push @classes, "${BACKEND_NAMESPACE}::${ua_type}"; + + if (!@BACKENDS) { + # search for some backends to try + @BACKENDS = sort $self->_module_loader->find_modules($BACKEND_NAMESPACE); + $self->_debug_log('Found backends to try (' . join(', ', @BACKENDS) . ')'); + } + + for my $backend_type (@BACKENDS) { + my $plugin = $backend_type; + $plugin =~ s/^\Q${BACKEND_NAMESPACE}\E:://; + push @classes, $backend_type if $ua->isa($plugin); + } + } + else { + push @classes, $REGISTERED_BACKENDS{$ua} if $REGISTERED_BACKENDS{$ua}; + push @classes, "${BACKEND_NAMESPACE}::${ua}"; + } + + for my $class (@classes) { + if (eval { $self->_module_loader->load($class); 1 }) { + $self->_debug_log("Found usable backend (${class})"); + return $class->new($self->ua); + } + else { + $self->_debug_log($@); + } + } + + _croak 'Cannot find a usable backend that supports the given user agent'; +} + +# make sure the response_is_future setting is compatible with the backend +sub _check_response_is_future { + my $self = shift; + my $val = shift; + + # make sure the user agent is not non-blocking + if (!$val && $self->{backend} && $self->backend->response_is_future) { + _croak 'Cannot disable response_is_future with a non-blocking user agent'; + } +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +HTTP::AnyUA - An HTTP user agent programming interface unification layer + +=head1 VERSION + +version 0.900 + +=head1 SYNOPSIS + + my $any_ua = HTTP::AnyUA->new(ua => LWP::UserAgent->new); + # OR: my $any_ua = HTTP::AnyUA->new(ua => Furl->new); + # OR: my $any_ua = HTTP::AnyUA->new(ua => HTTP::Tiny->new); + # etc... + + my $response = $any_ua->get('http://www.example.com/'); + + print "$response->{status} $response->{reason}\n"; + + while (my ($k, $v) = each %{$response->{headers}}) { + for (ref $v eq 'ARRAY' ? @$v : $v) { + print "$k: $_\n"; + } + } + + print $response->{content} if length $response->{content}; + + ### Non-blocking user agents cause Future objects to be returned: + + my $any_ua = HTTP::AnyUA->new(ua => HTTP::Tiny->new, response_is_future => 1); + # OR: my $any_ua = HTTP::AnyUA->new(ua => 'AnyEvent::HTTP'); + # OR: my $any_ua = HTTP::AnyUA->new(ua => Mojo::UserAgent->new); + # etc... + + my $future = $any_ua->get('http://www.example.com/'); + + $future->on_done(sub { + my $response = shift; + + print "$response->{status} $response->{reason}\n"; + + while (my ($k, $v) = each %{$response->{headers}}) { + for (ref $v eq 'ARRAY' ? @$v : $v) { + print "$k: $_\n"; + } + } + + print $response->{content} if length $response->{content}; + }); + + $future->on_fail(sub { print STDERR "Oh no!!\n" }); + +=head1 DESCRIPTION + +This module provides a small wrapper for unifying the programming interfaces of several different +actual user agents (HTTP clients) under one B interface. + +Rather than providing yet another programming interface for you to learn, HTTP::AnyUA follows the +L interface. This also means that you can plug in any supported HTTP client +(L, L, etc.) and use it as if it were L. + +There are a lot of great HTTP clients available for Perl, each with different goals, different +feature sets, and of course different programming interfaces! If you're an end user, you can just +pick one of these clients according to the needs of your project (or personal preference). But if +you're writing a module that needs to interface with a web server (like perhaps a RESTful API +wrapper) and you want your users to be able to use whatever HTTP client they want, HTTP::AnyUA can +help you support that! + +It's a good idea to let the end user pick whatever HTTP client they want to use, because they're the +one who knows the requirements of their application or script. If you're writing an event-driven +application, you'll need to use a non-blocking user agent like L. If you're writing +a simple command-line script, you may decide that your priority is to minimize dependencies and so +may want to go with L. + +Unfortunately, many modules on CPAN are hardcoded to work with specific HTTP clients, leaving the +end user unable to use the HTTP client that would be best for them. Although the end user won't -- +or at least doesn't need to -- use HTTP::AnyUA directly, they will benefit from client choice if +their third-party modules use HTTP::AnyUA or something like it. + +The primary goal of HTTP::AnyUA is to make it easy for module developers to write HTTP code once +that can work with any HTTP client the end user may decide to plug in. A secondary goal is to make +it easy for anyone to add support for new or yet-unsupported user agents. + +=head1 ATTRIBUTES + +=head2 ua + +Get the user agent that was passed to L. + +=head2 response_is_future + +Get and set whether or not responses are L objects. + +=head2 backend + +Get the backend instance. You normally shouldn't need this. + +=head1 METHODS + +=head2 new + + $any_ua = HTTP::AnyUA->new(ua => $user_agent, %attr); + $any_ua = HTTP::AnyUA->new($user_agent, %attr); + +Construct a new HTTP::AnyUA. + +=head2 request + + $response = $any_ua->request($method, $url); + $response = $any_ua->request($method, $url, \%options); + +Make a L, get a L. + +Compare to L. + +=head2 get, head, put, post, delete + + $response = $any_ua->get($url); + $response = $any_ua->get($url, \%options); + $response = $any_ua->head($url); + $response = $any_ua->head($url, \%options); + # etc. + +Shortcuts for L where the method is the method name rather than the first argument. + +Compare to LheadEputEpostEdelete>. + +=head2 post_form + + $response = $any_ua->post_form($url, $formdata); + $response = $any_ua->post_form($url, $formdata, \%options); + +Does a C request with the form data encoded and sets the C header to +C. + +Compare to L. + +=head2 mirror + + $response = $http->mirror($url, $filepath, \%options); + if ($response->{success}) { + print "$filepath is up to date\n"; + } + +Does a C request and saves the downloaded document to a file. If the file already exists, its +timestamp will be sent using the C request header (which you can override). If +the server responds with a C<304> (Not Modified) status, the C field will be true; this is +usually only the case for C<2XX> statuses. If the server responds with a C header, +the file will be updated to have the same modification timestamp. + +Compare to L. This version differs slightly in that this returns internal +exception responses (for cases like being unable to write the file locally, etc.) rather than +actually throwing the exceptions. The reason for this is that exceptions as responses are easier to +deal with for non-blocking HTTP clients, and the fact that this method throws exceptions in +L seems like an inconsistency in its interface. + +=head2 register_backend + + HTTP::AnyUA->register_backend($user_agent_package => $backend_package); + HTTP::AnyUA->register_backend('MyAgent' => 'MyBackend'); # HTTP::AnyUA::Backend::MyBackend + HTTP::AnyUA->register_backend('LWP::UserAgent' => '+SpecialBackend'); # SpecialBackend + +Register a backend for a new user agent type or override a default backend. Backend packages are +relative to the C namespace unless prefixed with a C<+>. + +If you only need to set a backend as a one-off thing, you could also pass an instantiated backend to +L. + +=head1 SUPPORTED USER AGENTS + +=over 4 + +=item * + +L + +=item * + +L + +=item * + +L - a little bit meta, but why not? + +=item * + +L + +=item * + +L + +=item * + +L + +=item * + +L + +=back + +Any HTTP client that inherits from one of these in a well-behaved manner should also be supported. + +Of course, there are many other HTTP clients on CPAN that HTTP::AnyUA doesn't yet support. I'm more +than happy to help add support for others, so send me a message if you know of an HTTP client that +needs support. See L for how to write support for a new HTTP client. + +=head1 NON-BLOCKING USER AGENTS + +HTTP::AnyUA tries to target the L interface, which is a blocking interface. This means +that when you call L, it is supposed to not return until either the response is received +or an error occurs. This doesn't jive well with non-blocking HTTP clients which expect the flow to +reenter an event loop so that the request can complete concurrently. + +In order to reconcile this, a L will be returned instead of the normal hashref response if +the wrapped HTTP client is non-blocking (such as L or L). This +L object may be used to set up callbacks that will be called when the request is completed. +You can call L to know if the response is or will be a L. + +This is typically okay for the end user; since they're the one who chose which HTTP client to use in +the first place, they should know whether they should expect a L or a direct response when +they make an HTTP request, but it does add some burden on you as a module writer because if you ever +need to examine the response, you may need to write code like this: + + my $resp = $any_ua->get('http://www.perl.org/'); + + if ($any_ua->response_is_future) { + $resp->on_done(sub { + my $real_resp = shift; + handle_response($real_resp); + }); + } + else { + handle_response($resp); # response is the real response already + } + +This actually isn't too annoying to deal with in practice, but you can avoid it if you like by +forcing the response to always be a L. Just set the L attribute. Then +you don't need to do an if-else because the response will always be the same type: + + $any_ua->response_is_future(1); + + my $resp = $any_ua->get('http://www.perl.org/'); + + $resp->on_done(sub { # response is always a Future + my $real_resp = shift; + handle_response($real_resp); + }); + +Note that this doesn't make a blocking HTTP client magically non-blocking. The call to L +will still block if the client is blocking, and your "done" callback will simply be fired +immediately. But this does let you write the same code in your module and have it work regardless of +whether the underlying HTTP client is blocking or non-blocking. + +The default behavior is to return a direct hashref response if the HTTP client is blocking and +a L if the client is non-blocking. It's up to you to decide whether or not to set +C, and you should also consider whether you want to expose the possibility of +either type of response or always returning L objects to the end user of your module. It +doesn't matter for users who choose non-blocking HTTP clients because they will be using L +objects either way, but users who know they are using a blocking HTTP client may appreciate not +having to deal with L objects at all. + +=head1 FREQUENTLY ASKED QUESTIONS + +=head2 How do I set up proxying, SSL, cookies, timeout, etc.? + +HTTP::AnyUA provides a common interface for I HTTP clients, not for instantiating or +configuring them. Proxying, SSL, and other custom settings can be configured directly through the +underlying HTTP client; see the documentation for your particular user agent to learn how to +configure these things. + +L is a bit of a special case because there is no instantiated object representing +the client. For this particular user agent, you can configure the backend to pass a default set of +options whenever it calls C. See L: + + $any_ua->backend->options({recurse => 5, timeout => 15}); + +If you are a module writer, you should probably receive a user agent from your end user and leave +this type of configuration up to them. + +=head2 Why use HTTP::AnyUA instead of some other HTTP client? + +Maybe you shouldn't. If you're an end user writing a script or application, you can just pick the +HTTP client that suits you best and use it. For example, if you're writing a L app, +you're not going wrong by using L; it's loaded with features and is well-integrated +with that particular environment. + +As an end user, you I wrap the HTTP client you pick in an HTTP::AnyUA object, but the only +reason to do this is if you prefer using the L interface. + +The real benefit of HTTP::AnyUA (or something like it) is if module writers use it to allow end +users of their modules to be able to plug in whatever HTTP client they want. For example, a module +that implements an API wrapper that has a hard dependency on L or even L +is essentially useless for non-blocking applications. If the same hypothetical module had been +written using HTTP::AnyUA then it would be useful in any scenario. + +=head2 Why use the HTTP::Tiny interface? + +The L interface is simple but provides all the essential functionality needed for +a capable HTTP client and little more. That makes it easy to provide an implementation for, and it +also makes it straightforward for module authors to use. + +Marrying the L interface with L gives us these benefits for both blocking and +non-blocking modules and applications. + +=head1 SPECIFICATION + +This section specifies a standard set of data structures that can be used to make a request and get +a response from a user agent. This is the specification HTTP::AnyUA uses for its programming +interface. It is heavily based on L's interface, and parts of this specification were +adapted or copied verbatim from that module's documentation. The intent is for this specification to +be written such that L is already a compliant implementor of the specification (at least +as of the specification's publication date). + +=head2 The Request + +A request is a tuple of the form C<(Method, URL)> or C<(Method, URL, Options)>. + +=head3 Method + +Method B be a string representing the HTTP verb. This is commonly C<"GET">, C<"POST">, +C<"HEAD">, C<"DELETE">, etc. + +=head3 URL + +URL B be a string representing the remote resource to be acted upon. The URL B have +unsafe characters escaped and international domain names encoded before being passed to the user +agent. A user agent B generated a C<"Host"> header based on the URL in accordance with RFC +2616; a user agent B throw an error if a C<"Host"> header is given with the L. + +=head3 Options + +Options, if present, B be a hash reference containing zero or more of the following keys with +appropriate values. A user agent B support more options than are specified here. + +=head4 headers + +The value for the C key B be a hash reference containing zero or more HTTP header +names (as keys) and header values. The value for a header B be either a string containing the +header value OR an array reference where each item is a string. If the value for a header is an +array reference, the user agent B output the header multiple times with each value in the +array. + +User agents B may add headers, but B replace user-specified headers unless +otherwise documented. + +=head4 content + +The value for the C key B be a string OR a code reference. If the value is a string, +its contents will be included with the request as the body. If the value is a code reference, the +referenced code will be called iteratively to produce the body of the request, and the code B +return an empty string or undef value to indicate the end of the request body. If the value is +a code reference, a user agent B use chunked transfer encoding if it supports it, otherwise +a user agent B completely drain the code of content before sending the request. + +=head4 data_callback + +The value for the C key B be a code reference that will be called zero or more +times, once for each "chunk" of response body received. A user agent B send the entire response +body in one call. The referenced code B be given two arguments; the first is a string +containing a chunk of the response body, the second is an in-progress L. + +=head2 The Response + +A response B be a hash reference containg some required keys and values. A response B +contain some optional keys and values. + +=head3 success + +A response B include a C key, the value of which is a boolean indicating whether or +not the request is to be considered a success (true is a success). Unless otherwise documented, +a successful result means that the operation returned a 2XX status code. + +=head3 url + +A response B include a C key, the value of which is the URL that provided the response. +This is the URL used in the request unless there were redirections, in which case it is the last URL +queried in a rediretion chain. + +=head3 status + +A response B include a C key, the value of which is the HTTP status code of the +response. If an internal exception occurs (e.g. connection error), then the status code B be +C<599>. + +=head3 reason + +A response B include a C key, the value of which is the response phrase returned by +the server OR "Internal Exception" if an internal exception occurred. + +=head3 content + +A response B include a C key, the value of which is the response body returned by the +server OR the text of the exception if an internal exception occurred. This field B be missing +or empty if the server provided no response OR if the body was already provided via +L. + +=head3 headers + +A response B include a C key, the value of which is a hash reference containing +zero or more HTTP header names (as keys) and header values. Keys B be lowercased. The value +for a header B be either a string containing the header value OR an array reference where each +item is the value of one of the repeated headers. + +=head3 redirects + +A response B include a C key, the value of which is an array reference of one or +more responses from redirections that occurred to fulfill the current request, in chronological +order. + +=head1 ENVIRONMENT + +=over 4 + +=item * + +C - If 1, print some info useful for debugging to C. + +=back + +=head1 CAVEATS + +Not all HTTP clients implement the same features or in the same ways. While the point of HTTP::AnyUA +is to hide those differences, you may notice some (hopefully) I differences when +plugging in different clients. For example, L sets some headers on the response such +as C and C that won't appear when using other clients. Little differences +like these probably aren't big deal. Other differences may be a bigger deal, depending on what's +important to you. For example, some clients (like L) may do chunked transfer encoding in +situations where other clients won't (probably because they don't support it). It's not a goal of +this project to eliminate I of the differences, but if you come across a difference that is +significant enough that you think you need to detect the user agent and write special logic, I would +like to learn about your use case. + +=head1 SEE ALSO + +These modules share similar goals or provide overlapping functionality: + +=over 4 + +=item * + +L + +=item * + +L + +=item * + +L + +=item * + +L + +=back + +=head1 BUGS + +Please report any bugs or feature requests on the bugtracker website +L + +When submitting a bug or request, please include a test-file or a +patch to an existing test-file that illustrates the bug or desired +feature. + +=head1 AUTHOR + +Charles McGarvey + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2017 by Charles McGarvey. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/HTTP/AnyUA/Backend.pm b/lib/HTTP/AnyUA/Backend.pm new file mode 100644 index 0000000..a3a68ec --- /dev/null +++ b/lib/HTTP/AnyUA/Backend.pm @@ -0,0 +1,172 @@ +package HTTP::AnyUA::Backend; +# ABSTRACT: A base class for HTTP::AnyUA backends + + +use warnings; +use strict; + +our $VERSION = '0.900'; # VERSION + + + +sub new { + my $class = shift; + my $ua = shift or die 'User agent is required'; + bless {ua => $ua}, $class; +} + + +sub request { + die 'Not yet implemented'; +} + + +sub ua { shift->{ua} } + + +sub response_is_future { 0 } + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +HTTP::AnyUA::Backend - A base class for HTTP::AnyUA backends + +=head1 VERSION + +version 0.900 + +=head1 SYNOPSIS + + package HTTP::AnyUA::Backend::MyUserAgent; + + use parent 'HTTP::AnyUA::Backend'; + + sub response_is_future { 0 } + + sub request { + my ($self, $method, $url, $args) = @_; + + my $ua = $self->ua; + + # Here is where you transform the arguments into a request that $ua + # understands, make the request against $ua and get a response, and + # transform the response to the expected hashref form. + + my $resp = $ua->make_request(); + + return $resp; + } + + ### Non-blocking user agents return responses as Future objects: + + sub response_is_future { 1 } + + sub request { + my ($self, $method, $url, $args) = @_; + + my $ua = $self->ua; + + my $future = Future->new; + + # Again, this example glosses over transforming the request and response + # to and from the actual user agent, but such details are the whole + # point of a backend. + + $ua->nonblocking_callback(sub { + my $resp = shift; + + if ($resp->{success}) { + $future->done($resp); + } + else { + $future->fail($resp); + } + }); + + return $future; + } + +=head1 DESCRIPTION + +This module provides an interface for an L "backend," which is an adapter that adds +support for using a type of user agent with L. + +This class should not be instantiated directly, but it may be convenient for backend implementations +to subclass it. + +At its core, a backend simply takes a set of standard arguments that represent an HTTP request, +transforms that request into a form understood by an underlying user agent, calls upon the user +agent to make the request and get a response, and then transforms that response into a standard +form. The standard forms for the request and response are based on L's arguments and +return value to and from its L method. + +=head1 ATTRIBUTES + +=head2 ua + +Get the user agent that was passed to L. + +=head2 response_is_future + +Get whether or not responses are L objects. Default is false. + +This may be overridden by implementations. + +=head1 METHODS + +=head2 new + + $backend = HTTP::AnyUA::Backend::MyUserAgent->new($my_user_agent); + +Construct a new backend. + +=head2 request + + $response = $backend->request($method => $url, \%options); + +Make a request, get a response. + +This must be overridden by implementations. + +=head1 SEE ALSO + +=over 4 + +=item * + +L - Explanation of the request arguments + +=item * + +L - Explanation of the response + +=back + +=head1 BUGS + +Please report any bugs or feature requests on the bugtracker website +L + +When submitting a bug or request, please include a test-file or a +patch to an existing test-file that illustrates the bug or desired +feature. + +=head1 AUTHOR + +Charles McGarvey + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2017 by Charles McGarvey. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/HTTP/AnyUA/Backend/AnyEvent/HTTP.pm b/lib/HTTP/AnyUA/Backend/AnyEvent/HTTP.pm new file mode 100644 index 0000000..393d6aa --- /dev/null +++ b/lib/HTTP/AnyUA/Backend/AnyEvent/HTTP.pm @@ -0,0 +1,187 @@ +package HTTP::AnyUA::Backend::AnyEvent::HTTP; +# ABSTRACT: A unified programming interface for AnyEvent::HTTP + + +use warnings; +use strict; + +our $VERSION = '0.900'; # VERSION + +use parent 'HTTP::AnyUA::Backend'; + +use Future; +use HTTP::AnyUA::Util; + + + +sub options { @_ == 2 ? $_[0]->{options} = pop : $_[0]->{options} } + +sub response_is_future { 1 } + +sub request { + my $self = shift; + my ($method, $url, $args) = @_; + + my %opts = $self->_munge_request($method, $url, $args); + my $future = Future->new; + + require AnyEvent::HTTP; + AnyEvent::HTTP::http_request($method => $url, %opts, sub { + my $resp = $self->_munge_response(@_, $args->{data_callback}); + + if ($resp->{success}) { + $future->done($resp); + } + else { + $future->fail($resp); + } + }); + + return $future; +} + + +sub _munge_request { + my $self = shift; + my $method = shift; + my $url = shift; + my $args = shift || {}; + + my %opts = %{$self->options || {}}; + + if (my $headers = $args->{headers}) { + # munge headers + my %headers; + for my $header (keys %$headers) { + my $value = $headers->{$header}; + $value = join(', ', @$value) if ref($value) eq 'ARRAY'; + $headers{$header} = $value; + } + $opts{headers} = \%headers; + } + + my @url_parts = HTTP::AnyUA::Util::split_url($url); + if (my $auth = $url_parts[4] and !$opts{headers}{'authorization'}) { + # handle auth in the URL + require MIME::Base64; + $opts{headers}{'authorization'} = 'Basic ' . MIME::Base64::encode_base64($auth, ''); + } + + my $content = HTTP::AnyUA::Util::coderef_content_to_string($args->{content}); + $opts{body} = $content if $content; + + if (my $data_cb = $args->{data_callback}) { + # stream the response + $opts{on_body} = sub { + my $data = shift; + $data_cb->($data, $self->_munge_response(undef, @_)); + 1; # continue + }; + } + + return %opts; +} + +sub _munge_response { + my $self = shift; + my $data = shift; + my $headers = shift; + my $data_cb = shift; + + # copy headers because http_request will continue to use the original + my %headers = %$headers; + + my $code = delete $headers{Status}; + my $reason = delete $headers{Reason}; + my $url = delete $headers{URL}; + + my $resp = { + success => 200 <= $code && $code <= 299, + url => $url, + status => $code, + reason => $reason, + headers => \%headers, + }; + + my $version = delete $headers{HTTPVersion}; + $resp->{protocol} = "HTTP/$version" if $version; + + $resp->{content} = $data if $data && !$data_cb; + + my @redirects; + my $redirect = delete $headers{Redirect}; + while ($redirect) { + # delete pseudo-header first so redirects aren't recursively munged + my $next = delete $redirect->[1]{Redirect}; + unshift @redirects, $self->_munge_response(@$redirect); + $redirect = $next; + } + $resp->{redirects} = \@redirects if @redirects; + + if (590 <= $code && $code <= 599) { + HTTP::AnyUA::Util::internal_exception($reason, $resp); + } + + return $resp; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +HTTP::AnyUA::Backend::AnyEvent::HTTP - A unified programming interface for AnyEvent::HTTP + +=head1 VERSION + +version 0.900 + +=head1 DESCRIPTION + +This module adds support for the HTTP client L to be used with the unified +programming interface provided by L. + +=head1 METHODS + +=head2 options + + $backend->options(\%options); + +Get and set default arguments to C. + +=head1 SEE ALSO + +=over 4 + +=item * + +L + +=back + +=head1 BUGS + +Please report any bugs or feature requests on the bugtracker website +L + +When submitting a bug or request, please include a test-file or a +patch to an existing test-file that illustrates the bug or desired +feature. + +=head1 AUTHOR + +Charles McGarvey + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2017 by Charles McGarvey. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/HTTP/AnyUA/Backend/Furl.pm b/lib/HTTP/AnyUA/Backend/Furl.pm new file mode 100644 index 0000000..1188835 --- /dev/null +++ b/lib/HTTP/AnyUA/Backend/Furl.pm @@ -0,0 +1,119 @@ +package HTTP::AnyUA::Backend::Furl; +# ABSTRACT: A unified programming interface for Furl + + +use warnings; +use strict; + +our $VERSION = '0.900'; # VERSION + +use parent 'HTTP::AnyUA::Backend'; + +use HTTP::AnyUA::Util; + + +sub request { + my $self = shift; + my ($method, $url, $args) = @_; + + local $args->{content} = HTTP::AnyUA::Util::coderef_content_to_string($args->{content}); + + my $request = HTTP::AnyUA::Util::native_to_http_request(@_); + my $ua_resp = $self->ua->request($request); + + return $self->_munge_response($ua_resp, $args->{data_callback}); +} + +sub _munge_response { + my $self = shift; + my $ua_resp = shift; + my $data_cb = shift; + + my $resp = { + success => !!$ua_resp->is_success, + url => $ua_resp->request->uri->as_string, + status => $ua_resp->code, + reason => $ua_resp->message, + headers => HTTP::AnyUA::Util::http_headers_to_native($ua_resp->headers), + }; + + $resp->{protocol} = $ua_resp->protocol if $ua_resp->protocol; + + if ($resp->{headers}{'x-internal-response'}) { + HTTP::AnyUA::Util::internal_exception($ua_resp->content, $resp); + } + elsif ($data_cb) { + $data_cb->($ua_resp->content, $resp); + } + else { + $resp->{content} = $ua_resp->content; + } + + return $resp; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +HTTP::AnyUA::Backend::Furl - A unified programming interface for Furl + +=head1 VERSION + +version 0.900 + +=head1 DESCRIPTION + +This module adds support for the HTTP client L to be used with the unified programming +interface provided by L. + +=head1 CAVEATS + +=over 4 + +=item * + +L doesn't keep a list of requests and responses along a redirect chain. As such, the C + +field in the response is always the same as the URL of the original request, and the C +field is never used. + +=back + +=head1 SEE ALSO + +=over 4 + +=item * + +L + +=back + +=head1 BUGS + +Please report any bugs or feature requests on the bugtracker website +L + +When submitting a bug or request, please include a test-file or a +patch to an existing test-file that illustrates the bug or desired +feature. + +=head1 AUTHOR + +Charles McGarvey + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2017 by Charles McGarvey. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/HTTP/AnyUA/Backend/HTTP/AnyUA.pm b/lib/HTTP/AnyUA/Backend/HTTP/AnyUA.pm new file mode 100644 index 0000000..d2eeede --- /dev/null +++ b/lib/HTTP/AnyUA/Backend/HTTP/AnyUA.pm @@ -0,0 +1,78 @@ +package HTTP::AnyUA::Backend::HTTP::AnyUA; +# ABSTRACT: A unified programming interface for HTTP::AnyUA + + +use warnings; +use strict; + +our $VERSION = '0.900'; # VERSION + +use parent 'HTTP::AnyUA::Backend'; + + +sub response_is_future { + my $self = shift; + + return $self->ua->response_is_future; +} + +sub request { + my $self = shift; + + return $self->ua->request(@_); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +HTTP::AnyUA::Backend::HTTP::AnyUA - A unified programming interface for HTTP::AnyUA + +=head1 VERSION + +version 0.900 + +=head1 DESCRIPTION + +This module adds support for the HTTP client L to be used with the unified programming +interface provided by L. + +Mind blown. + +=head1 SEE ALSO + +=over 4 + +=item * + +L + +=back + +=head1 BUGS + +Please report any bugs or feature requests on the bugtracker website +L + +When submitting a bug or request, please include a test-file or a +patch to an existing test-file that illustrates the bug or desired +feature. + +=head1 AUTHOR + +Charles McGarvey + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2017 by Charles McGarvey. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/HTTP/AnyUA/Backend/HTTP/Tiny.pm b/lib/HTTP/AnyUA/Backend/HTTP/Tiny.pm new file mode 100644 index 0000000..dbd0bd4 --- /dev/null +++ b/lib/HTTP/AnyUA/Backend/HTTP/Tiny.pm @@ -0,0 +1,70 @@ +package HTTP::AnyUA::Backend::HTTP::Tiny; +# ABSTRACT: A unified programming interface for HTTP::Tiny + + +use warnings; +use strict; + +our $VERSION = '0.900'; # VERSION + +use parent 'HTTP::AnyUA::Backend'; + + +sub request { + my $self = shift; + + return $self->ua->request(@_); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +HTTP::AnyUA::Backend::HTTP::Tiny - A unified programming interface for HTTP::Tiny + +=head1 VERSION + +version 0.900 + +=head1 DESCRIPTION + +This module adds support for the HTTP client L to be used with the unified programming +interface provided by L. + +=head1 SEE ALSO + +=over 4 + +=item * + +L + +=back + +=head1 BUGS + +Please report any bugs or feature requests on the bugtracker website +L + +When submitting a bug or request, please include a test-file or a +patch to an existing test-file that illustrates the bug or desired +feature. + +=head1 AUTHOR + +Charles McGarvey + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2017 by Charles McGarvey. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/HTTP/AnyUA/Backend/LWP/UserAgent.pm b/lib/HTTP/AnyUA/Backend/LWP/UserAgent.pm new file mode 100644 index 0000000..071bb57 --- /dev/null +++ b/lib/HTTP/AnyUA/Backend/LWP/UserAgent.pm @@ -0,0 +1,115 @@ +package HTTP::AnyUA::Backend::LWP::UserAgent; +# ABSTRACT: A unified programming interface for LWP::UserAgent + + +use warnings; +use strict; + +our $VERSION = '0.900'; # VERSION + +use parent 'HTTP::AnyUA::Backend'; + +use HTTP::AnyUA::Util; + + +sub request { + my $self = shift; + my ($method, $url, $args) = @_; + + my $r = HTTP::AnyUA::Util::native_to_http_request(@_); + + my $ua_resp = $self->ua->request($r); + + return $self->_munge_response($ua_resp, $args->{data_callback}); +} + + +sub _munge_response { + my $self = shift; + my $ua_resp = shift; + my $data_cb = shift; + my $recurse = shift; + + my $resp = { + success => !!$ua_resp->is_success, + url => $ua_resp->request->uri->as_string, + status => $ua_resp->code, + reason => $ua_resp->message, + headers => HTTP::AnyUA::Util::http_headers_to_native($ua_resp->headers), + }; + + $resp->{protocol} = $ua_resp->protocol if $ua_resp->protocol; + + if (!$recurse) { + for my $redirect ($ua_resp->redirects) { + push @{$resp->{redirects} ||= []}, $self->_munge_response($redirect, undef, 1); + } + } + + my $content_ref = $ua_resp->content_ref; + + if (($resp->{headers}{'client-warning'} || '') eq 'Internal response') { + HTTP::AnyUA::Util::internal_exception($$content_ref, $resp); + } + elsif ($data_cb) { + $data_cb->($$content_ref, $resp); + } + else { + $resp->{content} = $$content_ref; + } + + return $resp; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +HTTP::AnyUA::Backend::LWP::UserAgent - A unified programming interface for LWP::UserAgent + +=head1 VERSION + +version 0.900 + +=head1 DESCRIPTION + +This module adds support for the HTTP client L to be used with the unified +programming interface provided by L. + +=head1 SEE ALSO + +=over 4 + +=item * + +L + +=back + +=head1 BUGS + +Please report any bugs or feature requests on the bugtracker website +L + +When submitting a bug or request, please include a test-file or a +patch to an existing test-file that illustrates the bug or desired +feature. + +=head1 AUTHOR + +Charles McGarvey + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2017 by Charles McGarvey. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/HTTP/AnyUA/Backend/Mojo/UserAgent.pm b/lib/HTTP/AnyUA/Backend/Mojo/UserAgent.pm new file mode 100644 index 0000000..5f73ce8 --- /dev/null +++ b/lib/HTTP/AnyUA/Backend/Mojo/UserAgent.pm @@ -0,0 +1,200 @@ +package HTTP::AnyUA::Backend::Mojo::UserAgent; +# ABSTRACT: A unified programming interface for Mojo::UserAgent + + +use warnings; +use strict; + +our $VERSION = '0.900'; # VERSION + +use parent 'HTTP::AnyUA::Backend'; + +use Future; +use Scalar::Util; + + +sub response_is_future { 1 } + +sub request { + my $self = shift; + my ($method, $url, $args) = @_; + + my $future = Future->new; + + my $tx = $self->_munge_request(@_); + + $self->ua->start($tx => sub { + my $ua = shift; + my $tx = shift; + + my $resp = $self->_munge_response($tx, $args->{data_callback}); + + if ($resp->{success}) { + $future->done($resp); + } + else { + $future->fail($resp); + } + }); + + return $future; +} + + +sub _munge_request { + my $self = shift; + my $method = shift; + my $url = shift; + my $args = shift; + + my $headers = $args->{headers} || {}; + my $content = $args->{content}; + + my @content; + + my $content_length; + if ($content) { + for my $header (keys %$headers) { + if (lc($header) eq 'content-length') { + $content_length = $headers->{$header}; + last; + } + } + + # if we don't know the length we have to just read it all in + $content = HTTP::AnyUA::Util::coderef_content_to_string($content) if !$content_length; + + push @content, $content if ref($content) ne 'CODE'; + } + + my $tx = $self->ua->build_tx($method => $url => $headers => @content); + + if (ref($content) eq 'CODE') { + $tx->req->headers->content_length($content_length); + # stream the request + my $drain; + $drain = sub { + my $body = shift; + my $chunk = $content->() || ''; + undef $drain if !$chunk; + $body->write($chunk, $drain); + }; + $tx->req->content->$drain; + } + + if (my $data_cb = $args->{data_callback}) { + # stream the response + my $tx_copy = $tx; + Scalar::Util::weaken($tx_copy); + $tx->res->content->unsubscribe('read')->on(read => sub { + my ($content, $bytes) = @_; + my $resp = $self->_munge_response($tx_copy, undef); + $data_cb->($bytes, $resp); + }); + } + + return $tx; +} + +sub _munge_response { + my $self = shift; + my $tx = shift; + my $data_cb = shift; + my $recurse = shift; + + my $resp = { + success => !!$tx->res->is_success, + url => $tx->req->url->to_string, + status => $tx->res->code, + reason => $tx->res->message, + headers => {}, + }; + + # lowercase header keys + my $headers = $tx->res->headers->to_hash; + for my $header (keys %$headers) { + $resp->{headers}{lc($header)} = delete $headers->{$header}; + } + + my $version = $tx->res->version; + $resp->{protocol} = "HTTP/$version" if $version; + + if (!$recurse) { + for my $redirect (@{$tx->redirects}) { + push @{$resp->{redirects} ||= []}, $self->_munge_response($redirect, undef, 1); + } + } + + my $err = $tx->error; + if ($err and !$err->{code}) { + return HTTP::AnyUA::Util::internal_exception($err->{message}, $resp); + } + + my $body = $tx->res->body; + $resp->{content} = $body if $body && !$data_cb; + + return $resp; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +HTTP::AnyUA::Backend::Mojo::UserAgent - A unified programming interface for Mojo::UserAgent + +=head1 VERSION + +version 0.900 + +=head1 DESCRIPTION + +This module adds support for the HTTP client L to be used with the unified +programming interface provided by L. + +=head1 CAVEATS + +=over 4 + +=item * + +The C field in the response has the auth portion (if any) removed from the URL. + +=back + +=head1 SEE ALSO + +=over 4 + +=item * + +L + +=back + +=head1 BUGS + +Please report any bugs or feature requests on the bugtracker website +L + +When submitting a bug or request, please include a test-file or a +patch to an existing test-file that illustrates the bug or desired +feature. + +=head1 AUTHOR + +Charles McGarvey + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2017 by Charles McGarvey. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/HTTP/AnyUA/Backend/Net/Curl/Easy.pm b/lib/HTTP/AnyUA/Backend/Net/Curl/Easy.pm new file mode 100644 index 0000000..7f8ee0b --- /dev/null +++ b/lib/HTTP/AnyUA/Backend/Net/Curl/Easy.pm @@ -0,0 +1,275 @@ +package HTTP::AnyUA::Backend::Net::Curl::Easy; +# ABSTRACT: A unified programming interface for Net::Curl::Easy + + +use warnings; +use strict; + +our $VERSION = '0.900'; # VERSION + +use parent 'HTTP::AnyUA::Backend'; + +use HTTP::AnyUA::Util; +use Scalar::Util; + + +sub request { + my $self = shift; + my ($method, $url, $args) = @_; + + my $ua = $self->ua; + + # reset + $ua->setopt(Net::Curl::Easy::CURLOPT_HTTPGET(), 0); + $ua->setopt(Net::Curl::Easy::CURLOPT_NOBODY(), 0); + $ua->setopt(Net::Curl::Easy::CURLOPT_READFUNCTION(), undef); + $ua->setopt(Net::Curl::Easy::CURLOPT_POSTFIELDS(), undef); + $ua->setopt(Net::Curl::Easy::CURLOPT_POSTFIELDSIZE(), 0); + + if ($method eq 'GET') { + $ua->setopt(Net::Curl::Easy::CURLOPT_HTTPGET(), 1); + } + elsif ($method eq 'HEAD') { + $ua->setopt(Net::Curl::Easy::CURLOPT_NOBODY(), 1); + } + + if (my $content = $args->{content}) { + if (ref($content) eq 'CODE') { + my $content_length; + for my $header (keys %{$args->{headers} || {}}) { + if (lc($header) eq 'content-length') { + $content_length = $args->{headers}{$header}; + last; + } + } + + if ($content_length) { + my $chunk; + $ua->setopt(Net::Curl::Easy::CURLOPT_READFUNCTION(), sub { + my $ua = shift; + my $maxlen = shift; + + if (!$chunk) { + $chunk = $content->(); + return 0 if !$chunk; + } + + my $part = substr($chunk, 0, $maxlen, ''); + return \$part; + }); + $ua->setopt(Net::Curl::Easy::CURLOPT_POSTFIELDSIZE(), $content_length); + } + else { + # if we don't know the length we have to just read it all in + $content = HTTP::AnyUA::Util::coderef_content_to_string($content); + } + } + if (ref($content) ne 'CODE') { + $ua->setopt(Net::Curl::Easy::CURLOPT_POSTFIELDS(), $content); + $ua->setopt(Net::Curl::Easy::CURLOPT_POSTFIELDSIZE(), length $content); + } + } + + $ua->setopt(Net::Curl::Easy::CURLOPT_URL(), $url); + $ua->setopt(Net::Curl::Easy::CURLOPT_CUSTOMREQUEST(), $method); + + # munge headers + my @headers; + for my $header (keys %{$args->{headers} || {}}) { + my $value = $args->{headers}{$header}; + my @values = ref($value) eq 'ARRAY' ? @$value : $value; + for my $v (@values) { + push @headers, "${header}: $v"; + } + } + $ua->setopt(Net::Curl::Easy::CURLOPT_HTTPHEADER(), \@headers) if @headers; + + my @hdrdata; + + $ua->setopt(Net::Curl::Easy::CURLOPT_HEADERFUNCTION(), sub { + my $ua = shift; + my $data = shift; + my $size = length $data; + + my %headers = _parse_header($data); + + if ($headers{Status}) { + push @hdrdata, {}; + } + + my $resp_headers = $hdrdata[-1]; + + for my $key (keys %headers) { + if (!$resp_headers->{$key}) { + $resp_headers->{$key} = $headers{$key}; + } + else { + if (ref($resp_headers->{$key}) ne 'ARRAY') { + $resp_headers->{$key} = [$resp_headers->{$key}]; + } + push @{$resp_headers->{$key}}, $headers{$key}; + } + } + + return $size; + }); + + my $resp_body = ''; + + my $data_cb = $args->{data_callback}; + my $copy = $self; + Scalar::Util::weaken($copy); + $ua->setopt(Net::Curl::Easy::CURLOPT_WRITEFUNCTION(), sub { + my $ua = shift; + my $data = shift; + my $fh = shift; + my $size = length $data; + + if ($data_cb) { + my $resp = $copy->_munge_response(undef, undef, [@hdrdata], $data_cb); + $data_cb->($data, $resp); + } + else { + print $fh $data; + } + + return $size; + }); + open(my $fileb, '>', \$resp_body); + $ua->setopt(Net::Curl::Easy::CURLOPT_WRITEDATA(), $fileb); + + eval { $ua->perform }; + my $ret = $@; + + return $self->_munge_response($ret, $resp_body, [@hdrdata], $data_cb); +} + + +sub _munge_response { + my $self = shift; + my $error = shift; + my $body = shift; + my $hdrdata = shift; + my $data_cb = shift; + + my %headers = %{pop @$hdrdata || {}}; + + my $code = delete $headers{Status} || $self->ua->getinfo(Net::Curl::Easy::CURLINFO_RESPONSE_CODE()) || 599; + my $reason = delete $headers{Reason}; + my $url = $self->ua->getinfo(Net::Curl::Easy::CURLINFO_EFFECTIVE_URL()); + + my $resp = { + success => 200 <= $code && $code <= 299, + url => $url, + status => $code, + reason => $reason, + headers => \%headers, + }; + + my $version = delete $headers{HTTPVersion} || _http_version($self->ua->getinfo(Net::Curl::Easy::CURLINFO_HTTP_VERSION())); + $resp->{protocol} = "HTTP/$version" if $version; + + # We have the headers for the redirect chain in $hdrdata, but we don't have the contents, and we + # would also need to reconstruct the URLs. + + if ($error) { + my $err = $self->ua->strerror($error); + return HTTP::AnyUA::Util::internal_exception($err, $resp); + } + + $resp->{content} = $body if $body && !$data_cb; + + return $resp; +} + +# get the HTTP version according to the user agent object +sub _http_version { + my $version = shift; + return $version == Net::Curl::Easy::CURL_HTTP_VERSION_1_0() ? '1.0' : + $version == Net::Curl::Easy::CURL_HTTP_VERSION_1_1() ? '1.1' : + $version == Net::Curl::Easy::CURL_HTTP_VERSION_2_0() ? '2.0' : ''; +} + +# parse a header line (or status line) and return as key-value pairs +sub _parse_header { + my $data = shift; + + $data =~ s/[\x0A\x0D]*$//; + + if ($data =~ m!^HTTP/([0-9.]+) [\x09\x20]+ (\d{3}) [\x09\x20]+ ([^\x0A\x0D]*)!x) { + return ( + HTTPVersion => $1, + Status => $2, + Reason => $3, + ); + } + + my ($key, $val) = split(/:\s*/, $data, 2); + return if !$key; + return (lc($key) => $val); +} + +# no Net::Curl::Easy; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +HTTP::AnyUA::Backend::Net::Curl::Easy - A unified programming interface for Net::Curl::Easy + +=head1 VERSION + +version 0.900 + +=head1 DESCRIPTION + +This module adds support for the HTTP client L to be used with the unified +programming interface provided by L. + +=head1 CAVEATS + +=over 4 + +=item * + +The C field in the response is currently unsupported. + +=back + +=head1 SEE ALSO + +=over 4 + +=item * + +L + +=back + +=head1 BUGS + +Please report any bugs or feature requests on the bugtracker website +L + +When submitting a bug or request, please include a test-file or a +patch to an existing test-file that illustrates the bug or desired +feature. + +=head1 AUTHOR + +Charles McGarvey + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2017 by Charles McGarvey. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/HTTP/AnyUA/Util.pm b/lib/HTTP/AnyUA/Util.pm new file mode 100644 index 0000000..5bd7000 --- /dev/null +++ b/lib/HTTP/AnyUA/Util.pm @@ -0,0 +1,314 @@ +package HTTP::AnyUA::Util; +# ABSTRACT: Utility subroutines for HTTP::AnyUA backends + +use warnings; +use strict; + +our $VERSION = '0.900'; # VERSION + +use Exporter qw(import); + + +our @EXPORT_OK = qw( + http_headers_to_native + native_to_http_request + coderef_content_to_string + internal_exception + http_date + parse_http_date + uri_escape + www_form_urlencode +); + + +sub _croak { require Carp; Carp::croak(@_) } +sub _usage { _croak("Usage: @_\n") } + + +sub coderef_content_to_string { + my $content = shift; + + return $content if !$content; + + if (ref($content) eq 'CODE') { + # drain the request body + my $body = ''; + while (my $chunk = $content->()) { + $body .= $chunk; + } + $content = $body; + } + + return $content; +} + + +sub native_to_http_request { + my $method = shift; + my $url = shift; + my $args = shift || {}; + + my $headers = []; + my $content = $args->{content}; # works as either scalar or coderef + + # flatten headers + for my $header (keys %{$args->{headers} || {}}) { + my $value = $args->{headers}{$header}; + my @values = ref($value) eq 'ARRAY' ? @$value : ($value); + for my $v (@values) { + push @$headers, ($header => $v); + } + } + + require HTTP::Request; + return HTTP::Request->new($method, $url, $headers, $content); +} + + +sub http_headers_to_native { + my $http_headers = shift; + + my $native; + + for my $header ($http_headers->header_field_names) { + my @values = $http_headers->header($header); + $native->{lc($header)} = @values == 1 ? $values[0] : [@values]; + } + + return $native; +} + + +sub internal_exception { + my $e = shift or _usage(q{internal_exception($exception)}); + my $resp = shift || {}; + + $e = "$e"; + + $resp->{headers}{'client-original-status'} = $resp->{status} if $resp->{status}; + $resp->{headers}{'client-original-reason'} = $resp->{reason} if $resp->{reason}; + + $resp->{success} = ''; + $resp->{status} = 599; + $resp->{reason} = 'Internal Exception'; + $resp->{content} = $e; + $resp->{headers}{'content-type'} = 'text/plain'; + $resp->{headers}{'content-length'} = length $e; + + return $resp; +} + + +# adapted from HTTP/Tiny.pm +sub split_url { + my $url = shift or _usage(q{split_url($url)}); + + # URI regex adapted from the URI module + my ($scheme, $host, $path_query) = $url =~ m<\A([^:/?#]+)://([^/?#]*)([^#]*)> + or die(qq/Cannot parse URL: '$url'\n/); + + $scheme = lc $scheme; + $path_query = "/$path_query" unless $path_query =~ m<\A/>; + + my $auth = ''; + if ( (my $i = index $host, '@') != -1 ) { + # user:pass@host + $auth = substr $host, 0, $i, ''; # take up to the @ for auth + substr $host, 0, 1, ''; # knock the @ off the host + + # userinfo might be percent escaped, so recover real auth info + $auth =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg; + } + my $port = $host =~ s/:(\d*)\z// && length $1 ? $1 + : $scheme eq 'http' ? 80 + : $scheme eq 'https' ? 443 + : undef; + + return ($scheme, (length $host ? lc $host : "localhost") , $port, $path_query, $auth); +} + + +# Date conversions adapted from HTTP::Date +# adapted from HTTP/Tiny.pm +my $DoW = 'Sun|Mon|Tue|Wed|Thu|Fri|Sat'; +my $MoY = 'Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec'; +sub http_date { + my $time = shift or _usage(q{http_date($time)}); + my ($sec, $min, $hour, $mday, $mon, $year, $wday) = gmtime($time); + return sprintf('%s, %02d %s %04d %02d:%02d:%02d GMT', + substr($DoW,$wday*4,3), + $mday, substr($MoY,$mon*4,3), $year+1900, + $hour, $min, $sec + ); +} + + +# adapted from HTTP/Tiny.pm +sub parse_http_date { + my $str = shift or _usage(q{parse_http_date($str)}); + my @tl_parts; + if ($str =~ /^[SMTWF][a-z]+, +(\d{1,2}) ($MoY) +(\d\d\d\d) +(\d\d):(\d\d):(\d\d) +GMT$/) { + @tl_parts = ($6, $5, $4, $1, (index($MoY,$2)/4), $3); + } + elsif ($str =~ /^[SMTWF][a-z]+, +(\d\d)-($MoY)-(\d{2,4}) +(\d\d):(\d\d):(\d\d) +GMT$/ ) { + @tl_parts = ($6, $5, $4, $1, (index($MoY,$2)/4), $3); + } + elsif ($str =~ /^[SMTWF][a-z]+ +($MoY) +(\d{1,2}) +(\d\d):(\d\d):(\d\d) +(?:[^0-9]+ +)?(\d\d\d\d)$/ ) { + @tl_parts = ($5, $4, $3, $2, (index($MoY,$1)/4), $6); + } + require Time::Local; + return eval { + my $t = @tl_parts ? Time::Local::timegm(@tl_parts) : -1; + $t < 0 ? undef : $t; + }; +} + + +# URI escaping adapted from URI::Escape +# c.f. http://www.w3.org/TR/html4/interact/forms.html#h-17.13.4.1 +# perl 5.6 ready UTF-8 encoding adapted from JSON::PP +# adapted from HTTP/Tiny.pm +my %escapes = map { chr($_) => sprintf('%%%02X', $_) } 0..255; +$escapes{' '} = '+'; +my $unsafe_char = qr/[^A-Za-z0-9\-\._~]/; + +sub uri_escape { + my $str = shift or _usage(q{uri_escape($str)}); + if ($] ge '5.008') { + utf8::encode($str); + } + else { + $str = pack('U*', unpack('C*', $str)) # UTF-8 encode a byte string + if (length $str == do { use bytes; length $str }); + $str = pack('C*', unpack('C*', $str)); # clear UTF-8 flag + } + $str =~ s/($unsafe_char)/$escapes{$1}/ge; + return $str; +} + + +# adapted from HTTP/Tiny.pm +sub www_form_urlencode { + my $data = shift; + ($data && ref $data) + or _usage(q{www_form_urlencode($dataref)}); + (ref $data eq 'HASH' || ref $data eq 'ARRAY') + or _croak("form data must be a hash or array reference\n"); + + my @params = ref $data eq 'HASH' ? %$data : @$data; + @params % 2 == 0 + or _croak("form data reference must have an even number of terms\n"); + + my @terms; + while (@params) { + my ($key, $value) = splice(@params, 0, 2); + if (ref $value eq 'ARRAY') { + unshift @params, map { $key => $_ } @$value; + } + else { + push @terms, join('=', map { uri_escape($_) } $key, $value); + } + } + + return join('&', ref($data) eq 'ARRAY' ? @terms : sort @terms); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +HTTP::AnyUA::Util - Utility subroutines for HTTP::AnyUA backends + +=head1 VERSION + +version 0.900 + +=head1 FUNCTIONS + +=head2 coderef_content_to_string + + $content = coderef_content_to_string(\&code); + $content = coderef_content_to_string($content); # noop + +Convert a coderef into a string of content by iteratively calling the coderef and concatenating the +chunks it provides until the coderef returns undef or an empty string. + +=head2 native_to_http_request + + $http_request = native_to_http_request($method, $url); + $http_request = native_to_http_request($method, $url, \%options); + +Convert a "native" request tuple to an L object. + +=head2 http_headers_to_native + + $headers = http_headers_to_native($http_headers); + +Convert an L object to a "native" hashref. + +=head2 internal_exception + + $response = internal_exception($content); + $response = internal_exception($content, $response); + +Create an internal exception response. If an existing response is passed, that response will have +its fields modified to become an internal exception. + +=head2 split_url + + ($scheme, $host, $port, $path_query, $auth) = split_url($url); + +Split a URL into its components. + +=head2 http_date + + $http_date = http_date($epoch_time); + +Convert an epoch time into a date format suitable for HTTP. + +=head2 parse_http_date + + $epoch_time = parse_http_date($http_date); + +Convert an HTTP date into an epoch time. Returns undef if the date cannot be parsed. + +=head2 uri_escape + + $escaped = uri_escape($unescaped); + +Escape a string for use in a URL query param or as C data. + +=head2 www_form_urlencode + + $bytes = www_form_urlencode(\%form_data); + $bytes = www_form_urlencode(\@form_data); + +Encode a hashref or arrayref as C data. + +=head1 BUGS + +Please report any bugs or feature requests on the bugtracker website +L + +When submitting a bug or request, please include a test-file or a +patch to an existing test-file that illustrates the bug or desired +feature. + +=head1 AUTHOR + +Charles McGarvey + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2017 by Charles McGarvey. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/t/00-compile.t b/t/00-compile.t new file mode 100644 index 0000000..e47e859 --- /dev/null +++ b/t/00-compile.t @@ -0,0 +1,69 @@ +use 5.006; +use strict; +use warnings; + +# this test was generated with Dist::Zilla::Plugin::Test::Compile 2.056 + +use Test::More; + +plan tests => 10 + ($ENV{AUTHOR_TESTING} ? 1 : 0); + +my @module_files = ( + 'HTTP/AnyUA.pm', + 'HTTP/AnyUA/Backend.pm', + 'HTTP/AnyUA/Backend/AnyEvent/HTTP.pm', + 'HTTP/AnyUA/Backend/Furl.pm', + 'HTTP/AnyUA/Backend/HTTP/AnyUA.pm', + 'HTTP/AnyUA/Backend/HTTP/Tiny.pm', + 'HTTP/AnyUA/Backend/LWP/UserAgent.pm', + 'HTTP/AnyUA/Backend/Mojo/UserAgent.pm', + 'HTTP/AnyUA/Backend/Net/Curl/Easy.pm', + 'HTTP/AnyUA/Util.pm' +); + + + +# no fake home requested + +my @switches = ( + -d 'blib' ? '-Mblib' : '-Ilib', +); + +use File::Spec; +use IPC::Open3; +use IO::Handle; + +open my $stdin, '<', File::Spec->devnull or die "can't open devnull: $!"; + +my @warnings; +for my $lib (@module_files) +{ + # see L + my $stderr = IO::Handle->new; + + diag('Running: ', join(', ', map { my $str = $_; $str =~ s/'/\\'/g; q{'} . $str . q{'} } + $^X, @switches, '-e', "require q[$lib]")) + if $ENV{PERL_COMPILE_TEST_DEBUG}; + + my $pid = open3($stdin, '>&STDERR', $stderr, $^X, @switches, '-e', "require q[$lib]"); + binmode $stderr, ':crlf' if $^O eq 'MSWin32'; + my @_warnings = <$stderr>; + waitpid($pid, 0); + is($?, 0, "$lib loaded ok"); + + shift @_warnings if @_warnings and $_warnings[0] =~ /^Using .*\bblib/ + and not eval { require blib; blib->VERSION('1.01') }; + + if (@_warnings) + { + warn @_warnings; + push @warnings, @_warnings; + } +} + + + +is(scalar(@warnings), 0, 'no warnings found') + or diag 'got warnings: ', ( Test::More->can('explain') ? Test::More::explain(\@warnings) : join("\n", '', @warnings) ) if $ENV{AUTHOR_TESTING}; + + diff --git a/t/00-report-prereqs.dd b/t/00-report-prereqs.dd new file mode 100644 index 0000000..dbad75d --- /dev/null +++ b/t/00-report-prereqs.dd @@ -0,0 +1,77 @@ +do { my $x = { + 'configure' => { + 'requires' => { + 'ExtUtils::MakeMaker' => '0' + } + }, + 'develop' => { + 'requires' => { + 'Dist::Zilla' => '5', + 'Dist::Zilla::Plugin::Prereqs' => '0', + 'Dist::Zilla::PluginBundle::Author::CCM' => '0', + 'English' => '0', + 'Pod::Coverage::TrustPod' => '0', + 'Software::License::Perl_5' => '0', + 'Test::CPAN::Changes' => '0.19', + 'Test::CPAN::Meta' => '0', + 'Test::CleanNamespaces' => '0.15', + 'Test::EOL' => '0', + 'Test::MinimumVersion' => '0', + 'Test::More' => '0.96', + 'Test::NoTabs' => '0', + 'Test::Pod' => '1.41', + 'Test::Pod::Coverage' => '1.08', + 'Test::Pod::No404s' => '0', + 'Test::Portability::Files' => '0' + } + }, + 'runtime' => { + 'requires' => { + 'Carp' => '0', + 'Exporter' => '0', + 'Fcntl' => '0', + 'Future' => '0', + 'MIME::Base64' => '0', + 'Module::Loader' => '0', + 'Scalar::Util' => '0', + 'Time::Local' => '0', + 'bytes' => '0', + 'parent' => '0', + 'perl' => '5.010', + 'strict' => '0', + 'warnings' => '0' + }, + 'suggests' => { + 'HTTP::Tiny' => '0' + } + }, + 'test' => { + 'recommends' => { + 'CPAN::Meta' => '2.120900' + }, + 'requires' => { + 'ExtUtils::MakeMaker' => '0', + 'File::Spec' => '0', + 'IO::Handle' => '0', + 'IPC::Open3' => '0', + 'Test2::API' => '0', + 'Test::Exception' => '0', + 'Test::More' => '0', + 'blib' => '1.01', + 'lib' => '0' + }, + 'suggests' => { + 'AnyEvent::HTTP' => '0', + 'Furl' => '0', + 'HTTP::Tiny' => '0', + 'JSON' => '0', + 'LWP::UserAgent' => '0', + 'Mojo::UserAgent' => '0', + 'Net::Curl::Easy' => '0', + 'Plack::Runner' => '0', + 'Starman' => '0' + } + } + }; + $x; + } \ No newline at end of file diff --git a/t/00-report-prereqs.t b/t/00-report-prereqs.t new file mode 100644 index 0000000..e338372 --- /dev/null +++ b/t/00-report-prereqs.t @@ -0,0 +1,183 @@ +#!perl + +use strict; +use warnings; + +# This test was generated by Dist::Zilla::Plugin::Test::ReportPrereqs 0.025 + +use Test::More tests => 1; + +use ExtUtils::MakeMaker; +use File::Spec; + +# from $version::LAX +my $lax_version_re = + qr/(?: undef | (?: (?:[0-9]+) (?: \. | (?:\.[0-9]+) (?:_[0-9]+)? )? + | + (?:\.[0-9]+) (?:_[0-9]+)? + ) | (?: + v (?:[0-9]+) (?: (?:\.[0-9]+)+ (?:_[0-9]+)? )? + | + (?:[0-9]+)? (?:\.[0-9]+){2,} (?:_[0-9]+)? + ) + )/x; + +# hide optional CPAN::Meta modules from prereq scanner +# and check if they are available +my $cpan_meta = "CPAN::Meta"; +my $cpan_meta_pre = "CPAN::Meta::Prereqs"; +my $HAS_CPAN_META = eval "require $cpan_meta; $cpan_meta->VERSION('2.120900')" && eval "require $cpan_meta_pre"; ## no critic + +# Verify requirements? +my $DO_VERIFY_PREREQS = 1; + +sub _max { + my $max = shift; + $max = ( $_ > $max ) ? $_ : $max for @_; + return $max; +} + +sub _merge_prereqs { + my ($collector, $prereqs) = @_; + + # CPAN::Meta::Prereqs object + if (ref $collector eq $cpan_meta_pre) { + return $collector->with_merged_prereqs( + CPAN::Meta::Prereqs->new( $prereqs ) + ); + } + + # Raw hashrefs + for my $phase ( keys %$prereqs ) { + for my $type ( keys %{ $prereqs->{$phase} } ) { + for my $module ( keys %{ $prereqs->{$phase}{$type} } ) { + $collector->{$phase}{$type}{$module} = $prereqs->{$phase}{$type}{$module}; + } + } + } + + return $collector; +} + +my @include = qw( + +); + +my @exclude = qw( + +); + +# Add static prereqs to the included modules list +my $static_prereqs = do 't/00-report-prereqs.dd'; + +# Merge all prereqs (either with ::Prereqs or a hashref) +my $full_prereqs = _merge_prereqs( + ( $HAS_CPAN_META ? $cpan_meta_pre->new : {} ), + $static_prereqs +); + +# Add dynamic prereqs to the included modules list (if we can) +my ($source) = grep { -f } 'MYMETA.json', 'MYMETA.yml'; +if ( $source && $HAS_CPAN_META + && (my $meta = eval { CPAN::Meta->load_file($source) } ) +) { + $full_prereqs = _merge_prereqs($full_prereqs, $meta->prereqs); +} +else { + $source = 'static metadata'; +} + +my @full_reports; +my @dep_errors; +my $req_hash = $HAS_CPAN_META ? $full_prereqs->as_string_hash : $full_prereqs; + +# Add static includes into a fake section +for my $mod (@include) { + $req_hash->{other}{modules}{$mod} = 0; +} + +for my $phase ( qw(configure build test runtime develop other) ) { + next unless $req_hash->{$phase}; + next if ($phase eq 'develop' and not $ENV{AUTHOR_TESTING}); + + for my $type ( qw(requires recommends suggests conflicts modules) ) { + next unless $req_hash->{$phase}{$type}; + + my $title = ucfirst($phase).' '.ucfirst($type); + my @reports = [qw/Module Want Have/]; + + for my $mod ( sort keys %{ $req_hash->{$phase}{$type} } ) { + next if $mod eq 'perl'; + next if grep { $_ eq $mod } @exclude; + + my $file = $mod; + $file =~ s{::}{/}g; + $file .= ".pm"; + my ($prefix) = grep { -e File::Spec->catfile($_, $file) } @INC; + + my $want = $req_hash->{$phase}{$type}{$mod}; + $want = "undef" unless defined $want; + $want = "any" if !$want && $want == 0; + + my $req_string = $want eq 'any' ? 'any version required' : "version '$want' required"; + + if ($prefix) { + my $have = MM->parse_version( File::Spec->catfile($prefix, $file) ); + $have = "undef" unless defined $have; + push @reports, [$mod, $want, $have]; + + if ( $DO_VERIFY_PREREQS && $HAS_CPAN_META && $type eq 'requires' ) { + if ( $have !~ /\A$lax_version_re\z/ ) { + push @dep_errors, "$mod version '$have' cannot be parsed ($req_string)"; + } + elsif ( ! $full_prereqs->requirements_for( $phase, $type )->accepts_module( $mod => $have ) ) { + push @dep_errors, "$mod version '$have' is not in required range '$want'"; + } + } + } + else { + push @reports, [$mod, $want, "missing"]; + + if ( $DO_VERIFY_PREREQS && $type eq 'requires' ) { + push @dep_errors, "$mod is not installed ($req_string)"; + } + } + } + + if ( @reports ) { + push @full_reports, "=== $title ===\n\n"; + + my $ml = _max( map { length $_->[0] } @reports ); + my $wl = _max( map { length $_->[1] } @reports ); + my $hl = _max( map { length $_->[2] } @reports ); + + if ($type eq 'modules') { + splice @reports, 1, 0, ["-" x $ml, "", "-" x $hl]; + push @full_reports, map { sprintf(" %*s %*s\n", -$ml, $_->[0], $hl, $_->[2]) } @reports; + } + else { + splice @reports, 1, 0, ["-" x $ml, "-" x $wl, "-" x $hl]; + push @full_reports, map { sprintf(" %*s %*s %*s\n", -$ml, $_->[0], $wl, $_->[1], $hl, $_->[2]) } @reports; + } + + push @full_reports, "\n"; + } + } +} + +if ( @full_reports ) { + diag "\nVersions for all modules listed in $source (including optional ones):\n\n", @full_reports; +} + +if ( @dep_errors ) { + diag join("\n", + "\n*** WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING ***\n", + "The following REQUIRED prerequisites were not satisfied:\n", + @dep_errors, + "\n" + ); +} + +pass; + +# vim: ts=4 sts=4 sw=4 et: diff --git a/t/01-new.t b/t/01-new.t new file mode 100644 index 0000000..4362ef3 --- /dev/null +++ b/t/01-new.t @@ -0,0 +1,19 @@ +#!perl + +use warnings; +use strict; + +use lib 't/lib'; + +use HTTP::AnyUA; +use Test::Exception; +use Test::More tests => 3; + +my $any_ua1 = HTTP::AnyUA->new(ua => 'Mock'); +ok $any_ua1, 'can construct a new HTTP::AnyUA'; + +my $any_ua2 = HTTP::AnyUA->new('Mock'); +ok $any_ua2, 'can construct a new HTTP::AnyUA'; + +throws_ok { HTTP::AnyUA->new() } qr/^Usage:/, 'constructor requires user agent'; + diff --git a/t/02-shortcuts.t b/t/02-shortcuts.t new file mode 100644 index 0000000..768c4bd --- /dev/null +++ b/t/02-shortcuts.t @@ -0,0 +1,24 @@ +#!perl + +use warnings; +use strict; + +use lib 't/lib'; + +use HTTP::AnyUA; +use Test::More tests => 10; + +HTTP::AnyUA->register_backend(Mock => '+MockBackend'); + +my $any_ua = HTTP::AnyUA->new(ua => 'Mock'); +my $backend = $any_ua->backend; + +my $url = 'http://acme.tld/'; + +for my $shortcut (qw{get head put post delete}) { + my $resp = $any_ua->$shortcut($url); + my $request = ($backend->requests)[-1]; + is $request->[0], uc($shortcut), "$shortcut shortcut makes a request with the correct method"; + is $request->[1], $url, "$shortcut shortcut makes a request with the correct URL"; +} + diff --git a/t/03-post_form.t b/t/03-post_form.t new file mode 100644 index 0000000..d6746e6 --- /dev/null +++ b/t/03-post_form.t @@ -0,0 +1,29 @@ +#!perl + +use warnings; +use strict; + +use lib 't/lib'; + +use HTTP::AnyUA; +use Test::More tests => 4; + +HTTP::AnyUA->register_backend(Mock => '+MockBackend'); + +my $any_ua = HTTP::AnyUA->new(ua => 'Mock'); +my $backend = $any_ua->backend; + +my $url = 'http://acme.tld/'; +my $form = { + foo => 'bar', + baz => 42, +}; +my $resp = $any_ua->post_form($url, $form); + +my $request = ($backend->requests)[-1]; + +is $request->[0], 'POST', 'post_form request method is POST'; +is $request->[1], $url, 'post_form request URL is correct'; +is $request->[2]{content}, 'baz=42&foo=bar', 'post_form request body is correct'; +is $request->[2]{headers}{'content-type'}, 'application/x-www-form-urlencoded', 'post_form request content-type header is correct'; + diff --git a/t/04-internal-exception.t b/t/04-internal-exception.t new file mode 100644 index 0000000..3e02360 --- /dev/null +++ b/t/04-internal-exception.t @@ -0,0 +1,36 @@ +#!perl + +use warnings; +use strict; + +use lib 't/lib'; + +use HTTP::AnyUA; +use Test::More; +use Util qw(:test :ua); + +plan tests => scalar user_agents; + +test_all_user_agents { + plan tests => 3; + + my $ua = shift; + my $any_ua = HTTP::AnyUA->new($ua, response_is_future => 1); + + my $url = 'invalidscheme://acme.tld/hello'; + my $future = $any_ua->get($url); + + $future->on_ready(sub { + my $self = shift; + my $resp = $self->is_done ? $self->get : $self->failure; + + note explain 'RESPONSE: ', $resp; + + is_response_reason($resp, 'Internal Exception'); + is_response_status($resp, 599); + is_response_success($resp, 0); + }); + + return $future; +}; + diff --git a/t/10-get.t b/t/10-get.t new file mode 100644 index 0000000..6d2e203 --- /dev/null +++ b/t/10-get.t @@ -0,0 +1,71 @@ +#!perl + +use warnings; +use strict; + +use lib 't/lib'; + +use HTTP::AnyUA; +use Test::More; +use Util qw(:server :test :ua); + +my $server = start_server('t/app.psgi'); + +plan tests => scalar user_agents; + +test_all_user_agents { + plan tests => 14; + + my $ua = shift; + my $any_ua = HTTP::AnyUA->new($ua, response_is_future => 1); + + my $path = '/get-document'; + my $url = $server->url . $path; + my $future = $any_ua->get($url, { + headers => { + 'x-test-custom' => 'whatever', + 'x-test-multi' => [qw(foo bar baz)], + }, + }); + + $future->on_ready(sub { + my $self = shift; + my $resp = $self->is_done ? $self->get : $self->failure; + my $env = $server->read_env; + + note explain 'RESPONSE: ', $resp; + note explain 'ENV: ', $env; + + SKIP: { + skip 'unexpected env', 5 if ref($env) ne 'HASH'; + is($env->{REQUEST_METHOD}, 'GET', 'correct method sent'); + is($env->{REQUEST_URI}, $path, 'correct url sent'); + is($env->{content}, '', 'no body sent'); + is($env->{HTTP_X_TEST_CUSTOM}, 'whatever', 'custom header sent'); + like($env->{HTTP_X_TEST_MULTI}, qr/foo,\s*bar,\s*baz/, 'multi-value header sent'); + } + + is_response_content($resp, 'this is a document'); + is_response_reason($resp, 'OK'); + is_response_status($resp, 200); + is_response_success($resp, 1); + is_response_url($resp, $url); + is_response_header($resp, 'content-type', 'text/plain'); + is_response_header($resp, 'content-length', 18); + is_response_header($resp, 'x-foo', 'bar'); + response_protocol_ok($resp); + }); + + return $future; +}; + +# test: +# X custom headers +# X repeat headers (arrayref value) +# X stream request +# X stream response +# X redirect log +# X internal errors +# X all methods: get, post, put, head, delete, custom +# X basic auth in URL + diff --git a/t/11-post.t b/t/11-post.t new file mode 100644 index 0000000..80fc830 --- /dev/null +++ b/t/11-post.t @@ -0,0 +1,55 @@ +#!perl + +use warnings; +use strict; + +use lib 't/lib'; + +use HTTP::AnyUA; +use Test::More; +use Util qw(:server :test :ua); + +my $server = start_server('t/app.psgi'); + +plan tests => scalar user_agents; + +test_all_user_agents { + plan tests => 10; + + my $ua = shift; + my $any_ua = HTTP::AnyUA->new(ua => $ua, response_is_future => 1); + + my $path = '/create-document'; + my $url = $server->url . $path; + my $future = $any_ua->post($url, { + headers => {'content-type' => 'text/plain'}, + content => 'some document', + }); + + $future->on_ready(sub { + my $self = shift; + my $resp = $self->is_done ? $self->get : $self->failure; + my $env = $server->read_env; + + note explain 'RESPONSE: ', $resp; + note explain 'ENV: ', $env; + + SKIP: { + skip 'unexpected env', 3 if ref($env) ne 'HASH'; + is($env->{REQUEST_METHOD}, 'POST', 'correct method sent'); + is($env->{REQUEST_URI}, $path, 'correct url sent'); + is($env->{content}, 'some document', 'correct body sent'); + } + + is_response_content($resp, 'created document'); + is_response_reason($resp, 'Created'); + is_response_status($resp, 201); + is_response_success($resp, 1); + is_response_url($resp, $url); + is_response_header($resp, 'content-type', 'text/plain'); + response_protocol_ok($resp); + }); + + return $future; +}; + diff --git a/t/12-put.t b/t/12-put.t new file mode 100644 index 0000000..c6adb78 --- /dev/null +++ b/t/12-put.t @@ -0,0 +1,56 @@ +#!perl + +use warnings; +use strict; + +use lib 't/lib'; + +use HTTP::AnyUA; +use Test::More; +use Util qw(:server :test :ua); + +my $server = start_server('t/app.psgi'); + +plan tests => scalar user_agents; + +test_all_user_agents { + plan tests => 9; + + my $ua = shift; + my $any_ua = HTTP::AnyUA->new(ua => $ua, response_is_future => 1); + + my $path = '/modify-document'; + my $url = $server->url . $path; + my $future = $any_ua->put($url, { + headers => {'content-type' => 'text/plain'}, + content => 'some document', + }); + + $future->on_ready(sub { + my $self = shift; + my $resp = $self->is_done ? $self->get : $self->failure; + my $env = $server->read_env; + + note explain 'RESPONSE: ', $resp; + note explain 'ENV: ', $env; + + SKIP: { + skip 'unexpected env', 3 if ref($env) ne 'HASH'; + is($env->{REQUEST_METHOD}, 'PUT', 'correct method sent'); + is($env->{REQUEST_URI}, $path, 'correct url sent'); + is($env->{content}, 'some document', 'correct body sent'); + } + + is_response_reason($resp, 'No Content'); + is_response_status($resp, 204); + is_response_success($resp, 1); + is_response_url($resp, $url); + response_protocol_ok($resp); + + my $body = ref($resp) eq 'HASH' && $resp->{content}; + ok(!$body, 'response body is empty'); + }); + + return $future; +}; + diff --git a/t/13-head.t b/t/13-head.t new file mode 100644 index 0000000..9e68542 --- /dev/null +++ b/t/13-head.t @@ -0,0 +1,54 @@ +#!perl + +use warnings; +use strict; + +use lib 't/lib'; + +use HTTP::AnyUA; +use Test::More; +use Util qw(:server :test :ua); + +my $server = start_server('t/app.psgi'); + +plan tests => scalar user_agents; + +test_all_user_agents { + plan tests => 10; + + my $ua = shift; + my $any_ua = HTTP::AnyUA->new(ua => $ua, response_is_future => 1); + + my $path = '/get-document'; + my $url = $server->url . $path; + my $future = $any_ua->head($url); + + $future->on_ready(sub { + my $self = shift; + my $resp = $self->is_done ? $self->get : $self->failure; + my $env = $server->read_env; + + note explain 'RESPONSE: ', $resp; + note explain 'ENV: ', $env; + + SKIP: { + skip 'unexpected env', 2 if ref($env) ne 'HASH'; + is($env->{REQUEST_METHOD}, 'HEAD', 'correct method sent'); + is($env->{REQUEST_URI}, $path, 'correct url sent'); + } + + is_response_reason($resp, 'OK'); + is_response_status($resp, 200); + is_response_success($resp, 1); + is_response_url($resp, $url); + is_response_header($resp, 'content-type', 'text/plain'); + is_response_header($resp, 'content-length', 18); + response_protocol_ok($resp); + + my $body = ref($resp) eq 'HASH' && $resp->{content}; + ok(!$body, 'response body is empty'); + }); + + return $future; +}; + diff --git a/t/14-delete.t b/t/14-delete.t new file mode 100644 index 0000000..86682e4 --- /dev/null +++ b/t/14-delete.t @@ -0,0 +1,52 @@ +#!perl + +use warnings; +use strict; + +use lib 't/lib'; + +use HTTP::AnyUA; +use Test::More; +use Util qw(:server :test :ua); + +my $server = start_server('t/app.psgi'); + +plan tests => scalar user_agents; + +test_all_user_agents { + plan tests => 8; + + my $ua = shift; + my $any_ua = HTTP::AnyUA->new(ua => $ua, response_is_future => 1); + + my $path = '/modify-document'; + my $url = $server->url . $path; + my $future = $any_ua->delete($url); + + $future->on_ready(sub { + my $self = shift; + my $resp = $self->is_done ? $self->get : $self->failure; + my $env = $server->read_env; + + note explain 'RESPONSE: ', $resp; + note explain 'ENV: ', $env; + + SKIP: { + skip 'unexpected env', 2 if ref($env) ne 'HASH'; + is($env->{REQUEST_METHOD}, 'DELETE', 'correct method sent'); + is($env->{REQUEST_URI}, $path, 'correct url sent'); + } + + is_response_reason($resp, 'No Content'); + is_response_status($resp, 204); + is_response_success($resp, 1); + is_response_url($resp, $url); + response_protocol_ok($resp); + + my $body = ref($resp) eq 'HASH' && $resp->{content}; + ok(!$body, 'response body is empty'); + }); + + return $future; +}; + diff --git a/t/15-custom-method.t b/t/15-custom-method.t new file mode 100644 index 0000000..7dc7ab2 --- /dev/null +++ b/t/15-custom-method.t @@ -0,0 +1,56 @@ +#!perl + +use warnings; +use strict; + +use lib 't/lib'; + +use HTTP::AnyUA; +use Test::More; +use Util qw(:server :test :ua); + +my $server = start_server('t/app.psgi'); + +plan tests => scalar user_agents; + +test_all_user_agents { + plan tests => 13; + + my $ua = shift; + my $any_ua = HTTP::AnyUA->new(ua => $ua, response_is_future => 1); + + my $method = 'FOOBAR'; + my $path = '/get-document'; + my $url = $server->url . $path; + my $future = $any_ua->request($method => $url, {headers => {'x-test-custom' => 'whatever'}}); + + $future->on_ready(sub { + my $self = shift; + my $resp = $self->is_done ? $self->get : $self->failure; + my $env = $server->read_env; + + note explain 'RESPONSE: ', $resp; + note explain 'ENV: ', $env; + + SKIP: { + skip 'unexpected env', 4 if ref($env) ne 'HASH'; + is($env->{REQUEST_METHOD}, $method, 'correct method sent'); + is($env->{REQUEST_URI}, $path, 'correct url sent'); + is($env->{content}, '', 'no body sent'); + is($env->{HTTP_X_TEST_CUSTOM}, 'whatever', 'custom header sent'); + } + + is_response_content($resp, 'this is a document'); + is_response_reason($resp, 'OK'); + is_response_status($resp, 200); + is_response_success($resp, 1); + is_response_url($resp, $url); + is_response_header($resp, 'content-type', 'text/plain'); + is_response_header($resp, 'content-length', 18); + is_response_header($resp, 'x-foo', 'bar'); + response_protocol_ok($resp); + }); + + return $future; +}; + diff --git a/t/20-data_callback.t b/t/20-data_callback.t new file mode 100644 index 0000000..1e8847c --- /dev/null +++ b/t/20-data_callback.t @@ -0,0 +1,59 @@ +#!perl + +use warnings; +use strict; + +use lib 't/lib'; + +use HTTP::AnyUA; +use Test::More; +use Util qw(:server :test :ua); + +my $server = start_server('t/app.psgi'); + +plan tests => scalar user_agents; + +test_all_user_agents { + plan tests => 13; + + my $ua = shift; + my $any_ua = HTTP::AnyUA->new($ua, response_is_future => 1); + + my $path = '/get-document'; + my $url = $server->url . $path; + my $body = ''; + my $future = $any_ua->get($url, { + data_callback => sub { my ($part, $resp) = @_; $body .= $part; }, + }); + + $future->on_ready(sub { + my $self = shift; + my $resp = $self->is_done ? $self->get : $self->failure; + my $env = $server->read_env; + + note explain 'RESPONSE: ', $resp; + note explain 'ENV: ', $env; + + SKIP: { + skip 'unexpected env', 3 if ref($env) ne 'HASH'; + is($env->{REQUEST_METHOD}, 'GET', 'correct method sent'); + is($env->{REQUEST_URI}, $path, 'correct url sent'); + is($env->{content}, '', 'no body sent'); + } + + is($body, 'this is a document', 'streamed response content matches'); + ok($resp && !$resp->{content}, 'content in response structure is empty'); + + is_response_reason($resp, 'OK'); + is_response_status($resp, 200); + is_response_success($resp, 1); + is_response_url($resp, $url); + is_response_header($resp, 'content-type', 'text/plain'); + is_response_header($resp, 'content-length', 18); + is_response_header($resp, 'x-foo', 'bar'); + response_protocol_ok($resp); + }); + + return $future; +}; + diff --git a/t/21-basic-auth.t b/t/21-basic-auth.t new file mode 100644 index 0000000..0631e28 --- /dev/null +++ b/t/21-basic-auth.t @@ -0,0 +1,62 @@ +#!perl + +use warnings; +use strict; + +use lib 't/lib'; + +use HTTP::AnyUA; +use Test::More; +use Util qw(:server :test :ua); + +my $server = start_server('t/app.psgi'); + +plan tests => scalar user_agents; + +test_all_user_agents { + plan tests => 12; + + my $ua = shift; + my $any_ua = HTTP::AnyUA->new($ua, response_is_future => 1); + + my $user = 'bob'; + my $pass = 'opensesame'; + my $auth = 'Ym9iOm9wZW5zZXNhbWU='; + my $path = '/get-document'; + my $url = $server->url . $path; + $url =~ s!^(https?://)!${1}${user}:${pass}\@!; + my $future = $any_ua->get($url); + + $future->on_ready(sub { + my $self = shift; + my $resp = $self->is_done ? $self->get : $self->failure; + my $env = $server->read_env; + + note explain 'RESPONSE: ', $resp; + note explain 'ENV: ', $env; + + SKIP: { + skip 'unexpected env', 4 if ref($env) ne 'HASH'; + is($env->{REQUEST_METHOD}, 'GET', 'correct method sent'); + is($env->{REQUEST_URI}, $path, 'correct url sent'); + is($env->{content}, '', 'no body sent'); + is($env->{HTTP_AUTHORIZATION}, "Basic $auth", 'correct authorization sent'); + } + + is_response_content($resp, 'this is a document'); + is_response_reason($resp, 'OK'); + is_response_status($resp, 200); + is_response_success($resp, 1); + TODO: { + local $TODO = 'some user agents strip the auth from the URL'; + # Mojo::UserAgent strips the auth from the URL + is_response_url($resp, $url); + }; + is_response_header($resp, 'content-type', 'text/plain'); + is_response_header($resp, 'content-length', 18); + response_protocol_ok($resp); + }); + + return $future; +}; + diff --git a/t/22-redirects.t b/t/22-redirects.t new file mode 100644 index 0000000..d3491f4 --- /dev/null +++ b/t/22-redirects.t @@ -0,0 +1,93 @@ +#!perl + +use warnings; +use strict; + +use lib 't/lib'; + +use HTTP::AnyUA; +use Test::More; +use Util qw(:server :test :ua); + +my $server = start_server('t/app.psgi'); + +plan tests => scalar user_agents; + +test_all_user_agents { + plan tests => 29; + + my $ua = shift; + my $any_ua = HTTP::AnyUA->new($ua, response_is_future => 1); + + # enable redirects for useragents that don't do it by default + if ($ua->isa('Mojo::UserAgent')) { + $ua->max_redirects(5); + } + elsif ($ua->isa('Net::Curl::Easy')) { + $ua->setopt(Net::Curl::Easy::CURLOPT_FOLLOWLOCATION(), 1); + } + + my $path = '/foo'; + my $url = $server->url . $path; + my $future = $any_ua->get($url); + + $future->on_ready(sub { + my $self = shift; + my $resp = $self->is_done ? $self->get : $self->failure; + my $env = $server->read_env; + + note explain 'RESPONSE: ', $resp; + note explain 'ENV: ', $env; + + SKIP: { + skip 'unexpected env', 3 if ref($env) ne 'HASH'; + is($env->{REQUEST_METHOD}, 'GET', 'correct method sent'); + is($env->{REQUEST_URI}, '/baz', 'correct url sent'); + is($env->{content}, '', 'no body sent'); + } + + is_response_content($resp, 'you found it'); + is_response_reason($resp, 'OK'); + is_response_status($resp, 200); + is_response_success($resp, 1); + TODO: { + local $TODO = 'some user agents do not support this correctly'; + # Furl has the URL from the original request, not the last request + is_response_url($resp, $server->url . '/baz'); + }; + is_response_header($resp, 'content-type', 'text/plain'); + is_response_header($resp, 'content-length', 12); + response_protocol_ok($resp); + + SKIP: { + skip 'no redirect chain', 18 if !$resp || !$resp->{redirects}; + + my $chain = $resp->{redirects}; + isa_ok($chain, 'ARRAY', 'redirect chain'); + is(scalar @$chain, 2, 'redirect chain has two redirections'); + + my $r1 = $chain->[0]; + is_response_content($r1, 'the thing you seek is not here'); + is_response_reason($r1, 'Found'); + is_response_status($r1, 302); + is_response_success($r1, 0); + is_response_url($r1, $server->url . '/foo'); + is_response_header($r1, 'content-type', 'text/plain'); + is_response_header($r1, 'content-length', 30); + response_protocol_ok($r1); + + my $r2 = $chain->[1]; + is_response_content($r2, 'not here either'); + is_response_reason($r2, 'Moved Permanently'); + is_response_status($r2, 301); + is_response_success($r2, 0); + is_response_url($r2, $server->url . '/bar'); + is_response_header($r2, 'content-type', 'text/plain'); + is_response_header($r2, 'content-length', 15); + response_protocol_ok($r2); + } + }); + + return $future; +}; + diff --git a/t/23-content-coderef.t b/t/23-content-coderef.t new file mode 100644 index 0000000..c87833c --- /dev/null +++ b/t/23-content-coderef.t @@ -0,0 +1,65 @@ +#!perl + +use warnings; +use strict; + +use lib 't/lib'; + +use HTTP::AnyUA; +use Test::More; +use Util qw(:server :test :ua); + +# using Starman because we need a server that can handle chunked requests +my $server = start_server('t/app.psgi', type => 'Starman'); + +plan tests => scalar user_agents; + +test_all_user_agents { + plan tests => 10; + + my $ua = shift; + my $any_ua = HTTP::AnyUA->new(ua => $ua, response_is_future => 1); + + if ($ua->isa('Mojo::UserAgent')) { + # disable keep-alive to avoid Mojo::Reactor::EV warnings + $ua->max_connections(0); + } + + my $chunk = 0; + my @chunk = ('some ', 'document'); + my $code = sub { return $chunk[$chunk++] }; + + my $path = '/create-document'; + my $url = $server->url . $path; + my $future = $any_ua->post($url, { + headers => {'content-type' => 'text/plain'}, + content => $code, + }); + + $future->on_ready(sub { + my $self = shift; + my $resp = $self->is_done ? $self->get : $self->failure; + my $env = $server->read_env; + + note explain 'RESPONSE: ', $resp; + note explain 'ENV: ', $env; + + SKIP: { + skip 'unexpected env', 3 if ref($env) ne 'HASH'; + is($env->{REQUEST_METHOD}, 'POST', 'correct method sent'); + is($env->{REQUEST_URI}, $path, 'correct url sent'); + is($env->{content}, 'some document', 'correct body sent'); + } + + is_response_content($resp, 'created document'); + is_response_reason($resp, 'Created'); + is_response_status($resp, 201); + is_response_success($resp, 1); + is_response_url($resp, $url); + is_response_header($resp, 'content-type', 'text/plain'); + response_protocol_ok($resp); + }); + + return $future; +}; + diff --git a/t/app.psgi b/t/app.psgi new file mode 100644 index 0000000..c860c07 --- /dev/null +++ b/t/app.psgi @@ -0,0 +1,46 @@ +# A little plack app for testing HTTP::AnyUA + +# When a request is made, the environment will be sent back to the test which will assert that the +# request was made correctly. + +use Plack::Builder; +use Util qw(send_env); + +builder { + + mount '/create-document' => sub { + my $env = shift; + send_env($env); + [201, ['Content-Type' => 'text/plain'], ['created document']]; + }; + + mount '/get-document' => sub { + my $env = shift; + send_env($env); + [200, ['Content-Type' => 'text/plain', 'x-foo' => 'bar'], ['this is a document']]; + }; + + mount '/modify-document' => sub { + my $env = shift; + send_env($env); + [204, [], ['']]; + }; + + mount '/foo' => sub { + [302, ['Content-Type' => 'text/plain', 'Location' => '/bar'], ['the thing you seek is not here']]; + }; + mount '/bar' => sub { + [301, ['Content-Type' => 'text/plain', 'Location' => '/baz'], ['not here either']]; + }; + mount '/baz' => sub { + my $env = shift; + send_env($env); + [200, ['Content-Type' => 'text/plain'], ['you found it']]; + }; + + mount '/' => sub { + [200, ['Content-Type' => 'text/plain'], ['this is a test server']]; + }; + +} + diff --git a/t/lib/MockBackend.pm b/t/lib/MockBackend.pm new file mode 100644 index 0000000..c8b6535 --- /dev/null +++ b/t/lib/MockBackend.pm @@ -0,0 +1,45 @@ +package MockBackend; +# ABSTRACT: A backend for testing HTTP::AnyUA + +use warnings; +use strict; + +use parent 'HTTP::AnyUA::Backend'; + + +=method response + + $response = $backend->response; + $response = $backend->response($response); + +Get and set the response hashref or L that this backend will always respond with. + +=cut + +sub response { @_ == 2 ? $_[0]->{response} = pop : $_[0]->{response} } + +=method requests + + @requests = $backend->requests; + +Get the requests the backend has handled so far. + +=cut + +sub requests { @{$_[0]->{requests} || []} } + +sub request { + my $self = shift; + + push @{$self->{requests} ||= []}, [@_]; + + return $self->response || { + success => '', + status => 599, + reason => 'Internal Exception', + content => "No response mocked.\n", + }; +} + + +1; diff --git a/t/lib/Server.pm b/t/lib/Server.pm new file mode 100644 index 0000000..fbac0da --- /dev/null +++ b/t/lib/Server.pm @@ -0,0 +1,185 @@ +package Server; +# ABSTRACT: A runner for test HTTP servers + +=head1 SYNOPSIS + + use Server; + my $server = Server->new('app.psgi'); + +=head1 DESCRIPTION + +Throws up an HTTP server on a random port, suitable for testing. Server logs will be printed to +C as test notes. + +=cut + +use warnings; +use strict; + +use IO::Handle; +use Plack::Runner; +use Util qw(recv_env); + +=method new + + $server = Server->new($path); + $server = Server->new(\&app); + $server = Server->new(\&app, type => 'Starman'); + +Construct and L a new test HTTP server. + +=cut + +sub new { + my $class = shift; + my $app = shift or die 'PSGI app required'; + my %args = @_; + + $args{type} ||= 'HTTP::Server::PSGI'; + + my $self = bless {app => $app, %args}, $class; + return $self->start; +} + +=attr app + +Get the app that was passed to L. + +=attr in + +Get a filehandle for reading the server's STDOUT. + +=attr pid + +Get the process identifier of the server. + +=attr port + +Get the port number the server is listening on. + +=attr url + +Get the URL for the server. + +=attr type + +Get the type of server that was passed to L. + +=cut + +sub app { shift->{app} } +sub in { shift->{in} } +sub pid { shift->{pid} } +sub port { shift->{port} } +sub url { 'http://localhost:' . shift->port } +sub type { shift->{type} } + +=method start + + $server->start; + +Start the server. + +=cut + +sub start { + my $self = shift; + + # do not start on top of an already-started server + return $self if $self->{pid}; + + my $type = $self->type; + + my $pid = open(my $pipe, '-|'); + defined $pid or die "fork failed: $!"; + + $pipe->autoflush(1); + + if ($pid) { + my $port = <$pipe>; + die 'Could not start test server' if !$port; + chomp $port; + + $self->{in} = $pipe; + $self->{pid} = $pid; + $self->{port} = $port; + } + else { + tie *STDERR, 'Server::RedirectToTestHarness'; + + autoflush STDOUT 1; + + for my $try (1..10) { + my $port_num = $ENV{PERL_HTTP_ANYUA_TEST_PORT} || int(rand(32768)) + 32768; + print STDERR sprintf('Try %02d - Attempting to start a server on port %d for testing...', $try, $port_num); + + local $SIG{ALRM} = sub { print "$port_num\n" }; + alarm 1; + + eval { + my $runner = Plack::Runner->new; + $runner->parse_options('-s', $type, '-p', $port_num); + $runner->run($self->app); + }; + warn $@ if $@; + + alarm 0; + } + + print STDERR "Giving up..."; + exit; + } + + return $self; +} + +=method stop + + $server->stop; + +Stop the server. Called implicitly by C. + +=cut + +sub stop { + my $self = shift; + + if (my $pid = $self->pid) { + kill 'TERM', $pid; + waitpid $pid, 0; + $? = 0; # don't let child exit status affect parent + } + %$self = (app => $self->app); +} + +sub DESTROY { + my $self = shift; + $self->stop; +} + + +=method read_env + + $env = $server->read_env; + +Read a L environment from the server, sent by L. + +=cut + +sub read_env { + my $self = shift; + return recv_env($self->in or die 'Not connected'); +} + + +{ + package Server::RedirectToTestHarness; + + use Test::More (); + + sub TIEHANDLE { bless {} } + sub PRINT { shift; Test::More::note('Server: ', @_) } + sub PRINTF { shift; Test::More::note('Server: ', sprintf(@_)) } +} + +1; diff --git a/t/lib/Util.pm b/t/lib/Util.pm new file mode 100644 index 0000000..892e085 --- /dev/null +++ b/t/lib/Util.pm @@ -0,0 +1,343 @@ +package Util; +# ABSTRACT: Utility subroutines for testing HTTP::AnyUA + +=head1 SYNOPSIS + + use Util qw(:server :test :ua); + +=cut + +use warnings; +use strict; + +use Exporter qw(import); +use Future; +use Test2::API qw(context release); +use Test::More; + +our @EXPORT_OK = qw( + recv_env + send_env + start_server + use_server + + is_response_content + is_response_header + is_response_reason + is_response_status + is_response_success + is_response_url + response_protocol_ok + + test_all_user_agents + test_user_agent + user_agents +); +our %EXPORT_TAGS = ( + server => [qw( + recv_env + send_env + start_server + use_server + )], + test => [qw( + is_response_content + is_response_header + is_response_reason + is_response_status + is_response_success + is_response_url + response_protocol_ok + )], + ua => [qw( + test_all_user_agents + test_user_agent + user_agents + )], +); + +our @USER_AGENTS = qw( + AnyEvent::HTTP + Furl + HTTP::Tiny + LWP::UserAgent + Mojo::UserAgent + Net::Curl::Easy +); +our %USER_AGENT_TEST_WRAPPER; + +sub _croak { require Carp; Carp::croak(@_) } +sub _carp { require Carp; Carp::carp(@_) } + + +=func use_server + + use_server; + +Try to use the test server package. If it fails, the test plan is set to C. + +=cut + +sub use_server { + eval 'use Server'; + if (my $err = $@) { + diag $err; + plan skip_all => 'Could not compile test server runner.'; + } +} + +=func start_server + + $server = start_server('app.psgi'); + +Start a test server. + +=cut + +sub start_server { + use_server; + my $server = eval { Server->new(@_) }; + if (my $err = $@) { + diag $err; + plan skip_all => 'Could not start test server.'; + } + return $server; +} + +=func send_env + + send_env(\%env); + +Encode and send a L environment over C, to be received by L. + +=cut + +sub send_env { + my $env = shift || {}; + my $fh = shift || *STDOUT; + + my %data = map { !/^psgi/ ? ($_ => $env->{$_}) : () } keys %$env; + + # read in the request body + my $buffer; + my $body = ''; + $env->{'psgix.input.buffered'} or die 'Expected buffered input'; + while (1) { + my $bytes = $env->{'psgi.input'}->read($buffer, 32768); + defined $bytes or die 'Error while reading input stream'; + last if !$bytes; + $body .= $buffer; + } + $data{content} = $body; + + require JSON; + print $fh JSON::encode_json(\%data), "\n"; +} + +=func recv_env + + my $env = recv_env($fh); + +Receive and decode a L environment over a filehandle, sent by L. + +=cut + +sub recv_env { + my $fh = shift; + + my $data = <$fh>; + + require JSON; + return JSON::decode_json($data); +} + + +=func is_response_content, is_response_reason, is_response_status, is_response_success, is_response_url, is_response_header + + is_response_content($resp, $body, $test_name); + is_response_content($resp, $body); + # etc. + +Test a response for various fields. + +=cut + +sub is_response_content { my $ctx = context; release $ctx, _test_response_field($_[0], 'content', @_[1,2]) } +sub is_response_reason { my $ctx = context; release $ctx, _test_response_field($_[0], 'reason', @_[1,2]) } +sub is_response_status { my $ctx = context; release $ctx, _test_response_field($_[0], 'status', @_[1,2]) } +sub is_response_success { my $ctx = context; release $ctx, _test_response_field($_[0], 'success', @_[1,2], 'bool') } +sub is_response_url { my $ctx = context; release $ctx, _test_response_field($_[0], 'url', @_[1,2]) } +sub is_response_header { my $ctx = context; release $ctx, _test_response_header(@_) } + +=func response_protocol_ok + + response_protocol_ok($resp); + +Test that a response protocol is well-formed. + +=cut + +sub response_protocol_ok { + my ($resp) = @_; + my $ctx = context; + my $test; + if (ref($resp) ne 'HASH') { + $test = isa_ok($resp, 'HASH', 'response'); + } + else { + my $proto = $resp->{protocol}; + $test = ok(!$proto || $proto =~ m!^HTTP/!, 'response protocol matches or is missing'); + } + release $ctx, $test; +} + +sub _test_response_field { + my ($resp, $key, $val, $name, $type) = @_; + if (ref($resp) ne 'HASH') { + return isa_ok($resp, 'HASH', 'response'); + } + elsif (defined $val) { + $type ||= ''; + if ($type eq 'bool') { + my $disp = $val ? 'true' : 'false'; + return is(!!$resp->{$key}, !!$val, $name || "response $key matches \"$disp\""); + } + else { + my $disp = $val; + $disp =~ s/(.{40}).{4,}/$1.../; + return is($resp->{$key}, $val, $name || "response $key matches \"$disp\""); + } + } + else { + return ok(exists $resp->{$key}, $name || "response $key exists"); + } +} + +sub _test_response_header { + my ($resp, $key, $val, $name) = @_; + if (ref($resp) ne 'HASH') { + return isa_ok($resp, 'HASH', 'response'); + } + elsif (ref($resp->{headers}) ne 'HASH') { + return isa_ok($resp, 'HASH', 'response headers'); + } + elsif (defined $val) { + my $disp = $val; + $disp =~ s/(.{40}).{4,}/$1.../; + return is($resp->{headers}{$key}, $val, $name || "response header \"$key\" matches \"$disp\""); + } + else { + return ok(exists $resp->{headers}{$key}, $name || "response header $key exists"); + } +} + + +=func user_agents + + @user_agents = user_agents; + +Get a list of user agents available for testing. Shortcut for C<@Util::USER_AGENTS>. + +=cut + +sub user_agents { @USER_AGENTS } + +=func test_user_agent + + test_user_agent($ua_type, \&test); + +Run a subtest against one user agent. + +=cut + +sub test_user_agent { + my $name = shift; + my $code = shift; + + my $wrapper = $USER_AGENT_TEST_WRAPPER{$name} || sub { + my $name = shift; + my $code = shift; + + if (!eval "require $name") { + diag $@; + return; + } + + my $ua = $name->new; + $code->($ua); + + return 1; + }; + + # this is quite gross, but we don't want any active event loops from preventing us from + # committing suicide if things are looking deadlocked + local $SIG{ALRM} = sub { $@ = 'Deadlock or test is slow'; _carp $@; exit 1 }; + alarm 5; + my $ret = $wrapper->($name, $code); + alarm 0; + + plan skip_all => "Cannot create user agent ${name}" if !$ret; +} + +=func test_all_user_agents + + test_all_user_agents { ... }; + +Run the same subtest against all user agents returned by L. + +=cut + +sub test_all_user_agents(&) { + my $code = shift; + + for my $name (user_agents) { + subtest $name => sub { + test_user_agent($name, $code); + }; + } +} + + +$USER_AGENT_TEST_WRAPPER{'AnyEvent::HTTP'} = sub { + my $name = shift; + my $code = shift; + + if (!eval "require $name") { + diag $@; + return; + } + + require AnyEvent; + my $cv = AnyEvent->condvar; + + my $ua = 'AnyEvent::HTTP'; + my @futures = $code->($ua); + my $waiting = Future->wait_all(@futures)->on_ready(sub { $cv->send }); + + $cv->recv; + + return 1; +}; + +$USER_AGENT_TEST_WRAPPER{'Mojo::UserAgent'} = sub { + my $name = shift; + my $code = shift; + + if (!eval "require $name") { + diag $@; + return; + } + + require Mojo::IOLoop; + my $loop = Mojo::IOLoop->singleton; + + my $ua = Mojo::UserAgent->new; + my @futures = $code->($ua); + my $waiting = Future->wait_all(@futures)->on_ready(sub { $loop->reset }); + + $loop->start; + + return 1; +}; + +1; diff --git a/xt/author/clean-namespaces.t b/xt/author/clean-namespaces.t new file mode 100644 index 0000000..36387da --- /dev/null +++ b/xt/author/clean-namespaces.t @@ -0,0 +1,11 @@ +use strict; +use warnings; + +# this test was generated with Dist::Zilla::Plugin::Test::CleanNamespaces 0.006 + +use Test::More 0.94; +use Test::CleanNamespaces 0.15; + +subtest all_namespaces_clean => sub { all_namespaces_clean() }; + +done_testing; diff --git a/xt/author/critic.t b/xt/author/critic.t new file mode 100644 index 0000000..d5b4c96 --- /dev/null +++ b/xt/author/critic.t @@ -0,0 +1,12 @@ +#!perl + +use strict; +use warnings; + +use Test::More; +use English qw(-no_match_vars); + +eval "use Test::Perl::Critic"; +plan skip_all => 'Test::Perl::Critic required to criticise code' if $@; +Test::Perl::Critic->import( -profile => "perlcritic.rc" ) if -e "perlcritic.rc"; +all_critic_ok(); diff --git a/xt/author/eol.t b/xt/author/eol.t new file mode 100644 index 0000000..da57476 --- /dev/null +++ b/xt/author/eol.t @@ -0,0 +1,55 @@ +use strict; +use warnings; + +# this test was generated with Dist::Zilla::Plugin::Test::EOL 0.19 + +use Test::More 0.88; +use Test::EOL; + +my @files = ( + 'lib/HTTP/AnyUA.pm', + 'lib/HTTP/AnyUA/Backend.pm', + 'lib/HTTP/AnyUA/Backend/AnyEvent/HTTP.pm', + 'lib/HTTP/AnyUA/Backend/Furl.pm', + 'lib/HTTP/AnyUA/Backend/HTTP/AnyUA.pm', + 'lib/HTTP/AnyUA/Backend/HTTP/Tiny.pm', + 'lib/HTTP/AnyUA/Backend/LWP/UserAgent.pm', + 'lib/HTTP/AnyUA/Backend/Mojo/UserAgent.pm', + 'lib/HTTP/AnyUA/Backend/Net/Curl/Easy.pm', + 'lib/HTTP/AnyUA/Util.pm', + 't/00-compile.t', + 't/00-report-prereqs.dd', + 't/00-report-prereqs.t', + 't/01-new.t', + 't/02-shortcuts.t', + 't/03-post_form.t', + 't/04-internal-exception.t', + 't/10-get.t', + 't/11-post.t', + 't/12-put.t', + 't/13-head.t', + 't/14-delete.t', + 't/15-custom-method.t', + 't/20-data_callback.t', + 't/21-basic-auth.t', + 't/22-redirects.t', + 't/23-content-coderef.t', + 't/app.psgi', + 't/lib/MockBackend.pm', + 't/lib/Server.pm', + 't/lib/Util.pm', + 'xt/author/clean-namespaces.t', + 'xt/author/critic.t', + 'xt/author/eol.t', + 'xt/author/no-tabs.t', + 'xt/author/pod-coverage.t', + 'xt/author/pod-no404s.t', + 'xt/author/pod-syntax.t', + 'xt/author/portability.t', + 'xt/release/cpan-changes.t', + 'xt/release/distmeta.t', + 'xt/release/minimum-version.t' +); + +eol_unix_ok($_, { trailing_whitespace => 1 }) foreach @files; +done_testing; diff --git a/xt/author/no-tabs.t b/xt/author/no-tabs.t new file mode 100644 index 0000000..e67433f --- /dev/null +++ b/xt/author/no-tabs.t @@ -0,0 +1,55 @@ +use strict; +use warnings; + +# this test was generated with Dist::Zilla::Plugin::Test::NoTabs 0.15 + +use Test::More 0.88; +use Test::NoTabs; + +my @files = ( + 'lib/HTTP/AnyUA.pm', + 'lib/HTTP/AnyUA/Backend.pm', + 'lib/HTTP/AnyUA/Backend/AnyEvent/HTTP.pm', + 'lib/HTTP/AnyUA/Backend/Furl.pm', + 'lib/HTTP/AnyUA/Backend/HTTP/AnyUA.pm', + 'lib/HTTP/AnyUA/Backend/HTTP/Tiny.pm', + 'lib/HTTP/AnyUA/Backend/LWP/UserAgent.pm', + 'lib/HTTP/AnyUA/Backend/Mojo/UserAgent.pm', + 'lib/HTTP/AnyUA/Backend/Net/Curl/Easy.pm', + 'lib/HTTP/AnyUA/Util.pm', + 't/00-compile.t', + 't/00-report-prereqs.dd', + 't/00-report-prereqs.t', + 't/01-new.t', + 't/02-shortcuts.t', + 't/03-post_form.t', + 't/04-internal-exception.t', + 't/10-get.t', + 't/11-post.t', + 't/12-put.t', + 't/13-head.t', + 't/14-delete.t', + 't/15-custom-method.t', + 't/20-data_callback.t', + 't/21-basic-auth.t', + 't/22-redirects.t', + 't/23-content-coderef.t', + 't/app.psgi', + 't/lib/MockBackend.pm', + 't/lib/Server.pm', + 't/lib/Util.pm', + 'xt/author/clean-namespaces.t', + 'xt/author/critic.t', + 'xt/author/eol.t', + 'xt/author/no-tabs.t', + 'xt/author/pod-coverage.t', + 'xt/author/pod-no404s.t', + 'xt/author/pod-syntax.t', + 'xt/author/portability.t', + 'xt/release/cpan-changes.t', + 'xt/release/distmeta.t', + 'xt/release/minimum-version.t' +); + +notabs_ok($_) foreach @files; +done_testing; diff --git a/xt/author/pod-coverage.t b/xt/author/pod-coverage.t new file mode 100644 index 0000000..66b3b64 --- /dev/null +++ b/xt/author/pod-coverage.t @@ -0,0 +1,7 @@ +#!perl +# This file was automatically generated by Dist::Zilla::Plugin::PodCoverageTests. + +use Test::Pod::Coverage 1.08; +use Pod::Coverage::TrustPod; + +all_pod_coverage_ok({ coverage_class => 'Pod::Coverage::TrustPod' }); diff --git a/xt/author/pod-no404s.t b/xt/author/pod-no404s.t new file mode 100644 index 0000000..eb9760c --- /dev/null +++ b/xt/author/pod-no404s.t @@ -0,0 +1,21 @@ +#!perl + +use strict; +use warnings; +use Test::More; + +foreach my $env_skip ( qw( + SKIP_POD_NO404S + AUTOMATED_TESTING +) ){ + plan skip_all => "\$ENV{$env_skip} is set, skipping" + if $ENV{$env_skip}; +} + +eval "use Test::Pod::No404s"; +if ( $@ ) { + plan skip_all => 'Test::Pod::No404s required for testing POD'; +} +else { + all_pod_files_ok(); +} diff --git a/xt/author/pod-syntax.t b/xt/author/pod-syntax.t new file mode 100644 index 0000000..e563e5d --- /dev/null +++ b/xt/author/pod-syntax.t @@ -0,0 +1,7 @@ +#!perl +# This file was automatically generated by Dist::Zilla::Plugin::PodSyntaxTests. +use strict; use warnings; +use Test::More; +use Test::Pod 1.41; + +all_pod_files_ok(); diff --git a/xt/author/portability.t b/xt/author/portability.t new file mode 100644 index 0000000..c531252 --- /dev/null +++ b/xt/author/portability.t @@ -0,0 +1,10 @@ +use strict; +use warnings; + +use Test::More; + +eval 'use Test::Portability::Files'; +plan skip_all => 'Test::Portability::Files required for testing portability' + if $@; + +run_tests(); diff --git a/xt/release/cpan-changes.t b/xt/release/cpan-changes.t new file mode 100644 index 0000000..286005a --- /dev/null +++ b/xt/release/cpan-changes.t @@ -0,0 +1,10 @@ +use strict; +use warnings; + +# this test was generated with Dist::Zilla::Plugin::Test::CPAN::Changes 0.012 + +use Test::More 0.96 tests => 1; +use Test::CPAN::Changes; +subtest 'changes_ok' => sub { + changes_file_ok('Changes'); +}; diff --git a/xt/release/distmeta.t b/xt/release/distmeta.t new file mode 100644 index 0000000..c2280dc --- /dev/null +++ b/xt/release/distmeta.t @@ -0,0 +1,6 @@ +#!perl +# This file was automatically generated by Dist::Zilla::Plugin::MetaTests. + +use Test::CPAN::Meta; + +meta_yaml_ok(); diff --git a/xt/release/minimum-version.t b/xt/release/minimum-version.t new file mode 100644 index 0000000..ff71971 --- /dev/null +++ b/xt/release/minimum-version.t @@ -0,0 +1,8 @@ +#!perl + +use Test::More; + +eval "use Test::MinimumVersion"; +plan skip_all => "Test::MinimumVersion required for testing minimum versions" + if $@; +all_minimum_version_ok( qq{5.10.1} );