--- /dev/null
+*.bs
+*.o
+*.tar*
+*~
+/.build
+/.perl-version
+/HTTP-AnyUA-*
+/MYMETA.*
+/blib
+/local*
+/pm_to_blib
--- /dev/null
+sudo: false
+language: perl
+perl:
+ - '5.24'
+ - '5.22'
+ - '5.20'
+ - '5.18'
+ - '5.16'
+ - '5.14'
+matrix:
+ fast_finish: true
+before_install:
+ - git config --global user.name "TravisCI"
+ - git config --global user.email $HOSTNAME":not-for-mail@travis-ci.org"
+install:
+ - cpanm --quiet --notest --skip-satisfied Dist::Zilla
+ - "dzil authordeps --missing | grep -vP '[^\\w:]' | xargs -n 5 -P 10 cpanm --quiet --notest"
+ - "dzil listdeps --author --missing | grep -vP '[^\\w:]' | cpanm --verbose"
+script:
+ - dzil smoke --release --author
--- /dev/null
+Revision history for HTTP-AnyUA.
+
+{{$NEXT}}
+
--- /dev/null
+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.
+
+ <one line to give the program's name and a brief idea of what it does.>
+ Copyright (C) 19yy <name of author>
+
+ 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.
+
+ <signature of Ty Coon>, 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
+
--- /dev/null
+
+# This is not a Perl distribution, but it can build one using Dist::Zilla.
+
+CPANM = cpanm
+DZIL = dzil
+PERL = perl
+PROVE = prove
+
+all: bootstrap dist
+
+bootstrap:
+ $(CPANM) Dist::Zilla
+ $(DZIL) authordeps --missing | $(CPANM)
+ $(DZIL) listdeps --develop --missing | $(CPANM)
+
+clean:
+ $(DZIL) $@
+
+dist:
+ $(DZIL) build
+
+test:
+ $(PROVE) -l
+
+.PHONY: all bootstrap clean dist test
+
--- /dev/null
+
+name = HTTP-AnyUA
+author = Charles McGarvey <chazmcgarvey@brokenzipper.com>
+copyright_holder = Charles McGarvey
+copyright_year = 2017
+license = Perl_5
+
+[@Author::CCM]
+AutoPrereqs.skip[0] = ^(AnyEvent::.+|HTTP::Request|Net::Curl::Easy)$
+AutoPrereqs.skip[1] = ^(JSON|AnyEvent|Plack::.+|Mojo::.+)$
+
+[Prereqs / RuntimeSuggests]
+HTTP::Tiny = 0
+
+[Prereqs / TestSuggests]
+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
+
--- /dev/null
+package HTTP::AnyUA;
+# ABSTRACT: An HTTP user agent programming interface unification layer
+
+=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<familiar> interface.
+
+Rather than providing yet another programming interface for you to learn, HTTP::AnyUA follows the
+L<HTTP::Tiny> interface. This also means that you can plug in any supported HTTP client
+(L<LWP::UserAgent>, L<Furl>, etc.) and use it as if it were L<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 L<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 L<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.
+
+=head1 SUPPORTED USER AGENTS
+
+=for :list
+* L<AnyEvent::HTTP>
+* L<Furl>
+* L<HTTP::AnyUA> - a little bit meta, but why not?
+* L<HTTP::Tiny>
+* L<LWP::UserAgent>
+* L<Mojo::UserAgent>
+* L<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 L<HTTP::AnyUA::Backend> for how to write support for a new HTTP client.
+
+=head1 NON-BLOCKING USER AGENTS
+
+HTTP::AnyUA tries to target the L<HTTP::Tiny> interface, which is a blocking interface. This means
+that when you call L</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 L<Future> will be returned instead of the normal hashref response if
+the wrapped HTTP client is non-blocking (such as L<Mojo::UserAgent> or L<AnyEvent::HTTP>). This
+L<Future> object may be used to set up callbacks that will be called when the request is completed.
+You can call L</response_is_future> to know if the response is or will be a L<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 L<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 L<Future>. Just set the L</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 L</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 L<Future> if the client is non-blocking. It's up to you to decide whether or not to set
+C<response_is_future>, and you should also consider whether you want to expose the possibility of
+either type of response or always returning L<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 L<Future>
+objects either way, but users who know they are using a blocking HTTP client may appreciate not
+having to deal with L<Future> 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<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.
+
+L<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 C<http_request>. See L<HTTP::AnyUA::Backend::AnyEvent::HTTP/options>:
+
+ $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<Mojolicious> app,
+you're not going wrong by using L<Mojo::UserAgent>; it's loaded with features and is well-integrated
+with that particular environment.
+
+As an end user, you I<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 L<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 L<LWP::UserAgent> or even L<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.
+
+=head2 Why use the HTTP::Tiny interface?
+
+The L<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 L<HTTP::Tiny> interface with L<Future> 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<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 L<HTTP::Tiny> 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<MUST> be a string representing the HTTP verb. This is commonly C<"GET">, C<"POST">,
+C<"HEAD">, C<"DELETE">, etc.
+
+=head3 URL
+
+URL B<MUST> be a string representing the remote resource to be acted upon. The URL B<MUST> have
+unsafe characters escaped and international domain names encoded before being passed to the user
+agent. A user agent B<MUST> generated a C<"Host"> header based on the URL in accordance with RFC
+2616; a user agent B<MAY> throw an error if a C<"Host"> header is given with the L</headers>.
+
+=head3 Options
+
+Options, if present, B<MUST> be a hash reference containing zero or more of the following keys with
+appropriate values. A user agent B<MAY> support more options than are specified here.
+
+=head4 headers
+
+The value for the C<headers> key B<MUST> be a hash reference containing zero or more HTTP header
+names (as keys) and header values. The value for a header B<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 B<MUST> output the header multiple times with each value in the
+array.
+
+User agents B<MAY> may add headers, but B<SHOULD NOT> replace user-specified headers unless
+otherwise documented.
+
+=head4 content
+
+The value for the C<content> key B<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 B<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 B<SHOULD> use chunked transfer encoding if it supports it, otherwise
+a user agent B<MAY> completely drain the code of content before sending the request.
+
+=head4 data_callback
+
+The value for the C<data_callback> key B<MUST> be a code reference that will be called zero or more
+times, once for each "chunk" of response body received. A user agent B<MAY> send the entire response
+body in one call. The referenced code B<MUST> be given two arguments; the first is a string
+containing a chunk of the response body, the second is an in-progress L<response|/The Response>.
+
+=head2 The Response
+
+A response B<MUST> be a hash reference containg some required keys and values. A response B<MAY>
+contain some optional keys and values.
+
+=head3 success
+
+A response B<MUST> include a C<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.
+
+=head3 url
+
+A response B<MUST> include a C<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.
+
+=head3 status
+
+A response B<MUST> include a C<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 B<MUST> be
+C<599>.
+
+=head3 reason
+
+A response B<MUST> include a C<reason> 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<MAY> include a C<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 B<MUST> be missing
+or empty if the server provided no response OR if the body was already provided via
+L</data_callback>.
+
+=head3 headers
+
+A response B<SHOULD> include a C<headers> key, the value of which is a hash reference containing
+zero or more HTTP header names (as keys) and header values. Keys B<MUST> be lowercased. The value
+for a header B<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.
+
+=head3 redirects
+
+A response B<MAY> include a C<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.
+
+=head1 ENVIRONMENT
+
+=for :list
+* C<PERL_HTTP_ANYUA_DEBUG> - If 1, print some info useful for debugging to C<STDERR>.
+
+=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<insignificant> differences when
+plugging in different clients. For example, L<LWP::UserAgent> sets some headers on the response such
+as C<client-date> and C<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 L<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 I<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.
+
+=head1 SEE ALSO
+
+These modules share similar goals or provide overlapping functionality:
+
+=for :list
+* L<Future::HTTP>
+* L<HTTP::Any>
+* L<HTTP::Tinyish>
+* L<Plient>
+
+=cut
+
+use 5.010;
+use warnings;
+use strict;
+
+our $VERSION = '9999.999'; # 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") }
+
+
+=method new
+
+ $any_ua = HTTP::AnyUA->new(ua => $user_agent, %attr);
+ $any_ua = HTTP::AnyUA->new($user_agent, %attr);
+
+Construct a new HTTP::AnyUA.
+
+=cut
+
+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;
+}
+
+=attr ua
+
+Get the user agent that was passed to L</new>.
+
+=cut
+
+sub ua { shift->{ua} or _croak 'User agent is required' }
+
+=attr response_is_future
+
+Get and set whether or not responses are L<Future> objects.
+
+=cut
+
+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} || '';
+}
+
+=attr backend
+
+Get the backend instance. You normally shouldn't need this.
+
+=cut
+
+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};
+}
+
+=method request
+
+ $response = $any_ua->request($method, $url);
+ $response = $any_ua->request($method, $url, \%options);
+
+Make a L<request|/"The Request">, get a L<response|/"The Response">.
+
+Compare to L<HTTP::Tiny/request>.
+
+=cut
+
+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);
+}
+
+=method 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</request> where the method is the method name rather than the first argument.
+
+Compare to L<HTTP::Tiny/getE<verbar>headE<verbar>putE<verbar>postE<verbar>delete>.
+
+=cut
+
+# 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
+}
+
+=method post_form
+
+ $response = $any_ua->post_form($url, $formdata);
+ $response = $any_ua->post_form($url, $formdata, \%options);
+
+Does a C<POST> request with the form data encoded and sets the C<Content-Type> header to
+C<application/x-www-form-urlencoded>.
+
+Compare to L<HTTP::Tiny/post_form>.
+
+=cut
+
+# 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',
+ },
+ });
+}
+
+=method mirror
+
+ $response = $http->mirror($url, $filepath, \%options);
+ if ($response->{success}) {
+ print "$filepath is up to date\n";
+ }
+
+Does a C<GET> request and saves the downloaded document to a file. If the file already exists, its
+timestamp will be sent using the C<If-Modified-Since> request header (which you can override). If
+the server responds with a C<304> (Not Modified) status, the C<success> field will be true; this is
+usually only the case for C<2XX> statuses. If the server responds with a C<Last-Modified> header,
+the file will be updated to have the same modification timestamp.
+
+Compare to L<HTTP::Tiny/mirror>. 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<HTTP::Tiny> seems like an inconsistency in its interface.
+
+=cut
+
+# 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);
+ }
+}
+
+=method 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<HTTP::AnyUA::Backend::> 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</new>.
+
+=cut
+
+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;
--- /dev/null
+package HTTP::AnyUA::Backend;
+# ABSTRACT: A base class for HTTP::AnyUA backends
+
+=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<HTTP::AnyUA> "backend," which is an adapter that adds
+support for using a type of user agent with L<HTTP::AnyUA>.
+
+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<HTTP::Tiny>'s arguments and
+return value to and from its L<request|HTTP::Tiny/request> method.
+
+=head1 SEE ALSO
+
+=for :list
+* L<HTTP::AnyUA/REQUEST> - Explanation of the request arguments
+* L<HTTP::AnyUA/RESPONSE> - Explanation of the response
+
+=cut
+
+use warnings;
+use strict;
+
+our $VERSION = '9999.999'; # VERSION
+
+
+=method new
+
+ $backend = HTTP::AnyUA::Backend::MyUserAgent->new($my_user_agent);
+
+Construct a new backend.
+
+=cut
+
+sub new {
+ my $class = shift;
+ my $ua = shift or die 'User agent is required';
+ bless {ua => $ua}, $class;
+}
+
+=method request
+
+ $response = $backend->request($method => $url, \%options);
+
+Make a request, get a response.
+
+This must be overridden by implementations.
+
+=cut
+
+sub request {
+ die 'Not yet implemented';
+}
+
+=attr ua
+
+Get the user agent that was passed to L</new>.
+
+=cut
+
+sub ua { shift->{ua} }
+
+=attr response_is_future
+
+Get whether or not responses are L<Future> objects. Default is false.
+
+This may be overridden by implementations.
+
+=cut
+
+sub response_is_future { 0 }
+
+1;
--- /dev/null
+package HTTP::AnyUA::Backend::AnyEvent::HTTP;
+# ABSTRACT: A unified programming interface for AnyEvent::HTTP
+
+=head1 DESCRIPTION
+
+This module adds support for the HTTP client L<AnyEvent::HTTP> to be used with the unified
+programming interface provided by L<HTTP::AnyUA>.
+
+=head1 SEE ALSO
+
+=for :list
+* L<HTTP::AnyUA::Backend>
+
+=cut
+
+use warnings;
+use strict;
+
+our $VERSION = '9999.999'; # VERSION
+
+use parent 'HTTP::AnyUA::Backend';
+
+use Future;
+use HTTP::AnyUA::Util;
+
+
+=method options
+
+ $backend->options(\%options);
+
+Get and set default arguments to C<http_request>.
+
+=cut
+
+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;
--- /dev/null
+package HTTP::AnyUA::Backend::Furl;
+# ABSTRACT: A unified programming interface for Furl
+
+=head1 DESCRIPTION
+
+This module adds support for the HTTP client L<Furl> to be used with the unified programming
+interface provided by L<HTTP::AnyUA>.
+
+=head1 CAVEATS
+
+=for :list
+* L<Furl> doesn't keep a list of requests and responses along a redirect chain. As such, the C<url>
+field in the response is always the same as the URL of the original request, and the C<redirects>
+field is never used.
+
+=head1 SEE ALSO
+
+=for :list
+* L<HTTP::AnyUA::Backend>
+
+=cut
+
+use warnings;
+use strict;
+
+our $VERSION = '9999.999'; # 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;
--- /dev/null
+package HTTP::AnyUA::Backend::HTTP::AnyUA;
+# ABSTRACT: A unified programming interface for HTTP::AnyUA
+
+=head1 DESCRIPTION
+
+This module adds support for the HTTP client L<HTTP::AnyUA> to be used with the unified programming
+interface provided by L<HTTP::AnyUA>.
+
+Mind blown.
+
+=head1 SEE ALSO
+
+=for :list
+* L<HTTP::AnyUA::Backend>
+
+=cut
+
+use warnings;
+use strict;
+
+our $VERSION = '9999.999'; # 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;
--- /dev/null
+package HTTP::AnyUA::Backend::HTTP::Tiny;
+# ABSTRACT: A unified programming interface for HTTP::Tiny
+
+=head1 DESCRIPTION
+
+This module adds support for the HTTP client L<HTTP::Tiny> to be used with the unified programming
+interface provided by L<HTTP::AnyUA>.
+
+=head1 SEE ALSO
+
+=for :list
+* L<HTTP::AnyUA::Backend>
+
+=cut
+
+use warnings;
+use strict;
+
+our $VERSION = '9999.999'; # VERSION
+
+use parent 'HTTP::AnyUA::Backend';
+
+
+sub request {
+ my $self = shift;
+
+ return $self->ua->request(@_);
+}
+
+1;
--- /dev/null
+package HTTP::AnyUA::Backend::LWP::UserAgent;
+# ABSTRACT: A unified programming interface for LWP::UserAgent
+
+=head1 DESCRIPTION
+
+This module adds support for the HTTP client L<LWP::UserAgent> to be used with the unified
+programming interface provided by L<HTTP::AnyUA>.
+
+=head1 SEE ALSO
+
+=for :list
+* L<HTTP::AnyUA::Backend>
+
+=cut
+
+use warnings;
+use strict;
+
+our $VERSION = '9999.999'; # 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;
--- /dev/null
+package HTTP::AnyUA::Backend::Mojo::UserAgent;
+# ABSTRACT: A unified programming interface for Mojo::UserAgent
+
+=head1 DESCRIPTION
+
+This module adds support for the HTTP client L<Mojo::UserAgent> to be used with the unified
+programming interface provided by L<HTTP::AnyUA>.
+
+=head1 CAVEATS
+
+=for :list
+* The C<url> field in the response has the auth portion (if any) removed from the URL.
+
+=head1 SEE ALSO
+
+=for :list
+* L<HTTP::AnyUA::Backend>
+
+=cut
+
+use warnings;
+use strict;
+
+our $VERSION = '9999.999'; # 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;
--- /dev/null
+package HTTP::AnyUA::Backend::Net::Curl::Easy;
+# ABSTRACT: A unified programming interface for Net::Curl::Easy
+
+=head1 DESCRIPTION
+
+This module adds support for the HTTP client L<Net::Curl::Easy> to be used with the unified
+programming interface provided by L<HTTP::AnyUA>.
+
+=head1 CAVEATS
+
+=for :list
+* The C<redirects> field in the response is currently unsupported.
+
+=head1 SEE ALSO
+
+=for :list
+* L<HTTP::AnyUA::Backend>
+
+=cut
+
+use warnings;
+use strict;
+
+our $VERSION = '9999.999'; # 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;
--- /dev/null
+package HTTP::AnyUA::Util;
+# ABSTRACT: Utility subroutines for HTTP::AnyUA backends
+
+use warnings;
+use strict;
+
+our $VERSION = '9999.999'; # 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") }
+
+=func 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.
+
+=cut
+
+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;
+}
+
+=func 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<HTTP::Request> object.
+
+=cut
+
+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);
+}
+
+=func http_headers_to_native
+
+ $headers = http_headers_to_native($http_headers);
+
+Convert an L<HTTP::Headers> object to a "native" hashref.
+
+=cut
+
+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;
+}
+
+=func 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.
+
+=cut
+
+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;
+}
+
+=func split_url
+
+ ($scheme, $host, $port, $path_query, $auth) = split_url($url);
+
+Split a URL into its components.
+
+=cut
+
+# 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);
+}
+
+=func http_date
+
+ $http_date = http_date($epoch_time);
+
+Convert an epoch time into a date format suitable for HTTP.
+
+=cut
+
+# 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
+ );
+}
+
+=func 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.
+
+=cut
+
+# 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;
+ };
+}
+
+=func uri_escape
+
+ $escaped = uri_escape($unescaped);
+
+Escape a string for use in a URL query param or as C<application/x-www-form-urlencoded> data.
+
+=cut
+
+# 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;
+}
+
+=func www_form_urlencode
+
+ $bytes = www_form_urlencode(\%form_data);
+ $bytes = www_form_urlencode(\@form_data);
+
+Encode a hashref or arrayref as C<application/x-www-form-urlencoded> data.
+
+=cut
+
+# 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;
--- /dev/null
+#!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';
+
--- /dev/null
+#!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";
+}
+
--- /dev/null
+#!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';
+
--- /dev/null
+#!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;
+};
+
--- /dev/null
+#!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
+
--- /dev/null
+#!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;
+};
+
--- /dev/null
+#!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;
+};
+
--- /dev/null
+#!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;
+};
+
--- /dev/null
+#!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;
+};
+
--- /dev/null
+#!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;
+};
+
--- /dev/null
+#!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;
+};
+
--- /dev/null
+#!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;
+};
+
--- /dev/null
+#!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;
+};
+
--- /dev/null
+#!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;
+};
+
--- /dev/null
+# 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']];
+ };
+
+}
+
--- /dev/null
+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<Future> 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;
--- /dev/null
+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<STDERR> 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</start> 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</new>.
+
+=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</new>.
+
+=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<DESTROY>.
+
+=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<PSGI> environment from the server, sent by L<Util/send_env>.
+
+=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;
--- /dev/null
+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<skip_all>.
+
+=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<PSGI> environment over C<STDOUT>, to be received by L</recv_env>.
+
+=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<PSGI> environment over a filehandle, sent by L</send_env>.
+
+=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</user_agents>.
+
+=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;
projects / chaz / p5-HTTP-AnyUA / commitdiff
