diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md new file mode 100644 index 0000000..f9958ae --- /dev/null +++ b/CONTRIBUTING.md @@ -0,0 +1,117 @@ +# HOW TO CONTRIBUTE + +Thank you for considering contributing to this distribution. This file +contains instructions that will help you work with the source code. + +The distribution is managed with [Dist::Zilla](https://metacpan.org/pod/Dist::Zilla). +This means that many of the usual files you might expect are not in the +repository, but are generated at release time. Some generated files are kept +in the repository as a convenience (e.g. Build.PL/Makefile.PL and META.json). + +Generally, **you do not need Dist::Zilla to contribute patches**. You may need +Dist::Zilla to create a tarball. See below for guidance. + +## Getting dependencies + +If you have App::cpanminus 1.6 or later installed, you can use +[cpanm](https://metacpan.org/pod/cpanm) to satisfy dependencies like this: + + $ cpanm --installdeps --with-develop . + +You can also run this command (or any other cpanm command) without installing +App::cpanminus first, using the fatpacked `cpanm` script via curl or wget: + + $ curl -L https://cpanmin.us | perl - --installdeps --with-develop . + $ wget -qO - https://cpanmin.us | perl - --installdeps --with-develop . + +Otherwise, look for either a `cpanfile` or `META.json` file for a list of +dependencies to satisfy. + +## Running tests + +You can run tests directly using the `prove` tool: + + $ prove -l + $ prove -lv t/some_test_file.t + + +## Code style and tidying + +This distribution contains a `.perltidyrc` file in the root of the repository. +Please install Perl::Tidy and use `perltidy` before submitting patches. However, +as this is an old distribution and styling has changed somewhat over the years, +please keep your tidying constrained to the portion of code or function in which +you're patching. + + $ perltidy lib/HTTP/Status.pm -o my_tidy_copy.pm + +The above command, for example, would provide you with a copy of `Status.pm` +that has been cleaned according to our `.perltidyrc` settings. You'd then look +at the newly created `my_tidy_copy.pm` in the dist root and replace your work +with the cleaned up copy if there are differences. + +This may seem like an arbitrary thing, but it is immensely helpful if all code +is written in a singular style. If everything were tidy, it'd look like one +single person wrote the code rather than a mish-mash. + +## Installing and using Dist::Zilla + +[Dist::Zilla](https://metacpan.org/pod/Dist::Zilla) is a very powerful +authoring tool, optimized for maintaining a large number of distributions with +a high degree of automation, but it has a large dependency chain, a bit of a +learning curve and requires a number of author-specific plugins. + +To install it from CPAN, I recommend one of the following approaches for the +quickest installation: + + # using CPAN.pm, but bypassing non-functional pod tests + $ cpan TAP::Harness::Restricted + $ PERL_MM_USE_DEFAULT=1 HARNESS_CLASS=TAP::Harness::Restricted cpan Dist::Zilla + + # using cpanm, bypassing *all* tests + $ cpanm -n Dist::Zilla + +In either case, it's probably going to take about 10 minutes. Go for a walk, +go get a cup of your favorite beverage, take a bathroom break, or whatever. +When you get back, Dist::Zilla should be ready for you. + +Then you need to install any plugins specific to this distribution: + + $ dzil authordeps --missing | cpanm + +You can use Dist::Zilla to install the distribution's dependencies if you +haven't already installed them with cpanm: + + $ dzil listdeps --missing --develop | cpanm + +Once everything is installed, here are some dzil commands you might try: + + $ dzil build + $ dzil test + $ dzil regenerate + +You can learn more about Dist::Zilla at http://dzil.org/ + +## Other notes + +This distribution maintains the generated `META.json` and either `Makefile.PL` +or `Build.PL` in the repository. This allows two things: +[Travis CI](https://travis-ci.org/) can build and test the distribution without +requiring Dist::Zilla, and the distribution can be installed directly from +Github or a local git repository using `cpanm` for testing (again, not +requiring Dist::Zilla). + + $ cpanm git://github.com/Author/Distribution-Name.git + $ cd Distribution-Name; cpanm . + +Contributions are preferred in the form of a Github pull request. See +[Using pull requests](https://help.github.com/articles/using-pull-requests/) +for further information. You can use the Github issue tracker to report issues +without an accompanying patch. + +# CREDITS + +This file was adapted from an initial `CONTRIBUTING.mkdn` file from David +Golden under the terms of the [CC0](https://creativecommons.org/share-your-work/public-domain/cc0/), with inspiration from the +contributing documents from [Dist::Zilla::Plugin::Author::KENTNL::CONTRIBUTING](https://metacpan.org/pod/Dist::Zilla::Plugin::Author::KENTNL::CONTRIBUTING) +and [Dist::Zilla::PluginBundle::Author::ETHER](https://metacpan.org/pod/Dist::Zilla::PluginBundle::Author::ETHER). diff --git a/CONTRIBUTORS b/CONTRIBUTORS new file mode 100644 index 0000000..0088f26 --- /dev/null +++ b/CONTRIBUTORS @@ -0,0 +1,77 @@ + +# HTTP-MESSAGE CONTRIBUTORS # + +This is the (likely incomplete) list of people who have helped +make this distribution what it is, either via code contributions, +patches, bug reports, help with troubleshooting, etc. A huge +'thank you' to all of them. + + * Adam Kennedy + * Adam Sjogren + * Alexey Tourbin + * Alex Kapranoff + * amire80 + * Andreas J. Koenig + * Bill Mann + * Brendan Byrd + * Bron Gondwana + * Chase Whitener + * Christopher J. Madsen + * chromatic + * Daniel Hedlund + * David E. Wheeler + * DAVIDRW + * David Steinbrunner + * Father Chrysostomos + * Felipe Gasper + * FWILES + * Gavin Peters + * Gisle Aas + * Graeme Thompson + * Graham Knop + * Hans-H. Froehlich + * Ian Kilgore + * Jacob J + * jefflee + * Jerome Eteve + * john9art + * jonasbn + * Karen Etheridge + * Mark Overmeer + * Mark Stosberg + * Martin H. Sluka + * Mickey Nasriachi + * Mike Schilli + * murphy + * Olaf Alders + * Olivier Mengué + * Ondrej Hanak + * openstrike + * Peter Rabbitson + * phrstbrn + * Robert Rothenberg + * Robert Rothenberg + * Robert Stone + * Rolf Grossmann + * ruff + * sasao + * Saturday Walkers Club + * Sean M. Burke + * Slaven Rezic + * Spiros Denaxas + * Steve Hay + * Tatsuhiko Miyagawa + * Tatsuhiko Miyagawa + * Theo van Hoesel + * Tobias Leich + * Todd Lipcon + * tokuhirom + * Tom Hukins + * Tony Finch + * Toru Yamaguchi + * uid39246 + * Ville Skyttä + * Yuri Karaban + * Zefram + + diff --git a/Changes b/Changes new file mode 100644 index 0000000..7513211 --- /dev/null +++ b/Changes @@ -0,0 +1,115 @@ +Revision history for HTTP-Message + +6.18 2018-06-05 16:29:15Z + - Revert status_message to original code (GH#111) (Theo van Hoesel) + +6.17 2018-06-05 01:55:34Z + - Documented status code 451 in the list of constants (GH #104) (Robert Rothenberg) + - Status code 451 is cachable by default, as per RFC 7725 (GH #104) (Robert Rothenberg) + - Add default status_message for unknown status codes (GH#105) (Robert Rothenberg) + - Corrections to the documentation (GH#102) (Jonas B. Nielsen) + +6.16 2018-03-28 14:09:17Z + - Update status codes to official IANA list (GH#100) (Theo van Hoesel) + +6.15 2018-03-13 13:02:56Z + - Whenever possible, use an absolute four digit year for Time::Local (GH#97) + - Add is_cacheable_by_default() (GH#98) (Theo van Hoesel) + +6.14 2017-12-20 22:28:48Z + - Add some useful examples in HTTP::Request (GH #92) (Chase Whitener). + Batch requests are now explained. + - PUT and PATCH docs updated (GH #84) (saturdaywalkers) + - Trim trailing \r from status line so message() doesn't return it (GH #87) (Felipe Gasper) + - Bring test coverage of HTTP::Config to 100% (GH #85) (Pete Houston) + - Add 103 Early Hints to HTTP::Status (GH #94) (Tatsuhiko Miyagawa) + +6.13 2017-06-20 01:07:03Z + - Non-TRIAL release of changes found in 6.12 + +6.12 2017-06-15 18:03:50Z (TRIAL RELEASE) + - If an object is passed to HTTP::Request, it must provide a canonical() + method (Olaf Alders) + - Make sure status messages don't die by checking the status exists before + checking the value range (Kent Fredric, GH #39) + - Add a .mailmap file to clean up the contributors list + - Avoid inconsistent setting of content to undef (Jerome Eteve) + - Simplify the way some methods are created (Tom Hukins) + - Remove some indirect object notation (Chase Whitener) + - Fix example in Pod (Tobias Leich) + - Add support for HTTP PATCH method (Mickey Nasriachi) + +6.11 2015-09-09 + - fix an undefined value warning in HTTP::Headers::as_string + +6.10 2015-07-19 + - fix uses of qr/.../m in tests that do not work in 5.8.x + +6.09 2015-07-19 + - converted all uses of Test.pm to Test::More + - fix uninitialized warning in HTTP::Config (RT#105929) + +6.08 2015-07-10 + - Resolve new uninitialized warning from + HTTP::Request::Common::request_type_with_data (RT#105787) + +6.07 2015-07-09 + - Allow subclasses to override the class of parts - it used to be hardcoded + to HTTP::Message. (Gisle Aas, RT#79239) + - Added support for is_client_error, is_server_error to HTTP::Response + (Karen Etheridge) + - Added flatten interface to HTTP::Headers (Tokuhiro Matsuno, GH#5) + - Allow PUT to pass content data via hashrefs just like with POST (Michael + Schilli, GH#9) + - Fix for "Content-Encoding: none" header (Gisle Aas, RT#94882) + - Add support for HTTP status 308, defined in RFC 7238 (Olivier Mengué, + RT#104102) + - drop the use of "use vars" (Karen Etheridge) + +6.06 2012-10-21 + - More forgiving test on croak message [RT#80302] (Gisle Aas) + - Added test for multipart parsing (Gisle Aas) + - Multipart end boundary doesn't need match a complete line [RT#79239] + (Mark Overmeer) + +6.05 2012-10-20 + - Updated ignores (Gisle Aas) + - No need to prevent visiting field values starting with '_' (Gisle Aas) + - Report the correct croak caller for delegated methods (Gisle Aas) + - Disallow empty field names or field names containing ':' (Gisle Aas) + - Make the extra std_case entries local to each header (Gisle Aas) + +6.04 2012-09-30 + - Updated repository URL (Gisle Aas) + - Avoid undef warning for empty content (Gisle Aas) + - Teach $m->content_charset about JSON (Gisle Aas) + - Use the canonical charset name for UTF-16LE (and frieds) (Gisle Aas) + - Add option to override the "(no content)" marker of $m->dump (Gisle Aas) + - Use IO::HTML for encoding sniffing (Christopher J. Madsen) + - mime_name was introduced in Encode 2.21 (Christopher J. Madsen) + - Remove an unneeded "require" (Tom Hukins) + - Spelling fixes. (Ville Skyttä) + - Sanitized PERL_HTTP_URI_CLASS environment variable. (chromatic) + - Add test from RT#77466 (Martin H. Sluka) + - Fix doc grammo [RT#75831] (Father Chrysostomos) + +6.03 2012-02-16 + - Support 'bzip2' as alternative to Content-Encoding: x-bzip2. Some + servers seem to return it. + - Make newlines in forms be "\r\n" terminated. + - Added some more status codes. + - Restore perl-5.8.1 compatibility. + +6.02 2011-03-20 + - Declare dependency on Bunzip2 v2.021 [RT#66593] + +6.01 2011-03-07 + - Avoid loading XML::Simple to avoid test failures. + - Eliminate the HTML::Entities dependency. + +6.00 2011-02-27 + - Initial release of HTTP-Message as a separate distribution. There are no + code changes besides incrementing the version number since + libwww-perl-5.837. + - The HTTP::Message module with friends used to be bundled with the + libwww-perl distribution. diff --git a/INSTALL b/INSTALL new file mode 100644 index 0000000..f49573b --- /dev/null +++ b/INSTALL @@ -0,0 +1,52 @@ +This is the Perl distribution HTTP-Message. + +Installing HTTP-Message is straightforward. + +## Installation with cpanm + +If you have cpanm, you only need one line: + + % cpanm HTTP::Message + +If it does not have permission to install modules to the current perl, cpanm +will automatically set up and install to a local::lib in your home directory. +See the local::lib documentation (https://metacpan.org/pod/local::lib) for +details on enabling it in your environment. + +## Installing with the CPAN shell + +Alternatively, if your CPAN shell is set up, you should just be able to do: + + % cpan HTTP::Message + +## Manual installation + +As a last resort, you can manually install it. Download the tarball, untar it, +then build it: + + % perl Makefile.PL + % make && make test + +Then install it: + + % make install + +On Windows platforms, you should use `dmake` or `nmake`, instead of `make`. + +If your perl is system-managed, you can create a local::lib in your home +directory to install modules to. For details, see the local::lib documentation: +https://metacpan.org/pod/local::lib + + +The prerequisites of this distribution will also have to be installed manually. The +prerequisites are listed in one of the files: `MYMETA.yml` or `MYMETA.json` generated +by running the manual build process described above. + +## Documentation + +HTTP-Message documentation is available as POD. +You can run `perldoc` from a shell to read the documentation: + + % perldoc HTTP::Message +For more information on installing Perl modules via CPAN, please see: +https://www.cpan.org/modules/INSTALL.html diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..b6ed512 --- /dev/null +++ b/LICENSE @@ -0,0 +1,379 @@ +This software is copyright (c) 1994-2017 by Gisle Aas. + +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) 1994-2017 by Gisle Aas. + +This is free software, licensed under: + + The GNU General Public License, Version 1, February 1989 + + GNU GENERAL PUBLIC LICENSE + Version 1, February 1989 + + Copyright (C) 1989 Free Software Foundation, Inc. + 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The license agreements of most software companies try to keep users +at the mercy of those companies. By contrast, our General Public +License is intended to guarantee your freedom to share and change free +software--to make sure the software is free for all its users. The +General Public License applies to the Free Software Foundation's +software and to any other program whose authors commit to using it. +You can use it for your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Specifically, the General Public License is designed to make +sure that you have the freedom to give away or sell copies of free +software, that you receive source code or can get it if you want it, +that you can change the software or use pieces of it in new free +programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if you +distribute copies of the software, or if you modify it. + + For example, if you distribute copies of a such a program, whether +gratis or for a fee, you must give the recipients all the rights that +you have. You must make sure that they, too, receive or can get the +source code. And you must tell them their rights. + + We protect your rights with two steps: (1) copyright the software, and +(2) offer you this license which gives you legal permission to copy, +distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain +that everyone understands that there is no warranty for this free +software. If the software is modified by someone else and passed on, we +want its recipients to know that what they have is not the original, so +that any problems introduced by others will not reflect on the original +authors' reputations. + + The precise terms and conditions for copying, distribution and +modification follow. + + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License Agreement applies to any program or other work which +contains a notice placed by the copyright holder saying it may be +distributed under the terms of this General Public License. The +"Program", below, refers to any such program or work, and a "work based +on the Program" means either the Program or any work containing the +Program or a portion of it, either verbatim or with modifications. Each +licensee is addressed as "you". + + 1. You may copy and distribute verbatim copies of the Program's source +code as you receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice and +disclaimer of warranty; keep intact all the notices that refer to this +General Public License and to the absence of any warranty; and give any +other recipients of the Program a copy of this General Public License +along with the Program. You may charge a fee for the physical act of +transferring a copy. + + 2. You may modify your copy or copies of the Program or any portion of +it, and copy and distribute such modifications under the terms of Paragraph +1 above, provided that you also do the following: + + a) cause the modified files to carry prominent notices stating that + you changed the files and the date of any change; and + + b) cause the whole of any work that you distribute or publish, that + in whole or in part contains the Program or any part thereof, either + with or without modifications, to be licensed at no charge to all + third parties under the terms of this General Public License (except + that you may choose to grant warranty protection to some or all + third parties, at your option). + + c) If the modified program normally reads commands interactively when + run, you must cause it, when started running for such interactive use + in the simplest and most usual way, to print or display an + announcement including an appropriate copyright notice and a notice + that there is no warranty (or else, saying that you provide a + warranty) and that users may redistribute the program under these + conditions, and telling the user how to view a copy of this General + Public License. + + d) You may charge a fee for the physical act of transferring a + copy, and you may at your option offer warranty protection in + exchange for a fee. + +Mere aggregation of another independent work with the Program (or its +derivative) on a volume of a storage or distribution medium does not bring +the other work under the scope of these terms. + + 3. You may copy and distribute the Program (or a portion or derivative of +it, under Paragraph 2) in object code or executable form under the terms of +Paragraphs 1 and 2 above provided that you also do one of the following: + + a) accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of + Paragraphs 1 and 2 above; or, + + b) accompany it with a written offer, valid for at least three + years, to give any third party free (except for a nominal charge + for the cost of distribution) a complete machine-readable copy of the + corresponding source code, to be distributed under the terms of + Paragraphs 1 and 2 above; or, + + c) accompany it with the information you received as to where the + corresponding source code may be obtained. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form alone.) + +Source code for a work means the preferred form of the work for making +modifications to it. For an executable file, complete source code means +all the source code for all modules it contains; but, as a special +exception, it need not include source code for modules which are standard +libraries that accompany the operating system on which the executable +file runs, or for standard header files or definitions files that +accompany that operating system. + + 4. You may not copy, modify, sublicense, distribute or transfer the +Program except as expressly provided under this General Public License. +Any attempt otherwise to copy, modify, sublicense, distribute or transfer +the Program is void, and will automatically terminate your rights to use +the Program under this License. However, parties who have received +copies, or rights to use copies, from you under this General Public +License will not have their licenses terminated so long as such parties +remain in full compliance. + + 5. By copying, distributing or modifying the Program (or any work based +on the Program) you indicate your acceptance of this license to do so, +and all its terms and conditions. + + 6. Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the original +licensor to copy, distribute or modify the Program subject to these +terms and conditions. You may not impose any further restrictions on the +recipients' exercise of the rights granted herein. + + 7. The Free Software Foundation may publish revised and/or new versions +of the General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + +Each version is given a distinguishing version number. If the Program +specifies a version number of the license which applies to it and "any +later version", you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +the license, you may choose any version ever published by the Free Software +Foundation. + + 8. If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. + + NO WARRANTY + + 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED +OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS +TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE +PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, +REPAIR OR CORRECTION. + + 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, +INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING +OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED +TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY +YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER +PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. + + END OF TERMS AND CONDITIONS + + Appendix: How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to humanity, the best way to achieve this is to make it +free software which everyone can redistribute and change under these +terms. + + To do so, attach the following notices to the program. It is safest to +attach them to the start of each source file to most effectively convey +the exclusion of warranty; and each file should have at least the +"copyright" line and a pointer to where the full notice is found. + + + Copyright (C) 19yy + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 1, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston MA 02110-1301 USA + + +Also add information on how to contact you by electronic and paper mail. + +If the program is interactive, make it output a short notice like this +when it starts in an interactive mode: + + Gnomovision version 69, Copyright (C) 19xx name of author + Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the +appropriate parts of the General Public License. Of course, the +commands you use may be called something other than `show w' and `show +c'; they could even be mouse-clicks or menu items--whatever suits your +program. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the program, if +necessary. Here a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the + program `Gnomovision' (a program to direct compilers to make passes + at assemblers) written by James Hacker. + + , 1 April 1989 + Ty Coon, President of Vice + +That's all there is to it! + + +--- The Artistic License 1.0 --- + +This software is Copyright (c) 1994-2017 by Gisle Aas. + +This is free software, licensed under: + + The Artistic License 1.0 + +The Artistic License + +Preamble + +The intent of this document is to state the conditions under which a Package +may be copied, such that the Copyright Holder maintains some semblance of +artistic control over the development of the package, while giving the users of +the package the right to use and distribute the Package in a more-or-less +customary fashion, plus the right to make reasonable modifications. + +Definitions: + + - "Package" refers to the collection of files distributed by the Copyright + Holder, and derivatives of that collection of files created through + textual modification. + - "Standard Version" refers to such a Package if it has not been modified, + or has been modified in accordance with the wishes of the Copyright + Holder. + - "Copyright Holder" is whoever is named in the copyright or copyrights for + the package. + - "You" is you, if you're thinking about copying or distributing this Package. + - "Reasonable copying fee" is whatever you can justify on the basis of media + cost, duplication charges, time of people involved, and so on. (You will + not be required to justify it to the Copyright Holder, but only to the + computing community at large as a market that must bear the fee.) + - "Freely Available" means that no fee is charged for the item itself, though + there may be fees involved in handling the item. It also means that + recipients of the item may redistribute it under the same conditions they + received it. + +1. You may make and give away verbatim copies of the source form of the +Standard Version of this Package without restriction, provided that you +duplicate all of the original copyright notices and associated disclaimers. + +2. You may apply bug fixes, portability fixes and other modifications derived +from the Public Domain or from the Copyright Holder. A Package modified in such +a way shall still be considered the Standard Version. + +3. You may otherwise modify your copy of this Package in any way, provided that +you insert a prominent notice in each changed file stating how and when you +changed that file, and provided that you do at least ONE of the following: + + a) place your modifications in the Public Domain or otherwise make them + Freely Available, such as by posting said modifications to Usenet or an + equivalent medium, or placing the modifications on a major archive site + such as ftp.uu.net, or by allowing the Copyright Holder to include your + modifications in the Standard Version of the Package. + + b) use the modified Package only within your corporation or organization. + + c) rename any non-standard executables so the names do not conflict with + standard executables, which must also be provided, and provide a separate + manual page for each non-standard executable that clearly documents how it + differs from the Standard Version. + + d) make other distribution arrangements with the Copyright Holder. + +4. You may distribute the programs of this Package in object code or executable +form, provided that you do at least ONE of the following: + + a) distribute a Standard Version of the executables and library files, + together with instructions (in the manual page or equivalent) on where to + get the Standard Version. + + b) accompany the distribution with the machine-readable source of the Package + with your modifications. + + c) accompany any non-standard executables with their corresponding Standard + Version executables, giving the non-standard executables non-standard + names, and clearly documenting the differences in manual pages (or + equivalent), together with instructions on where to get the Standard + Version. + + d) make other distribution arrangements with the Copyright Holder. + +5. You may charge a reasonable copying fee for any distribution of this +Package. You may charge any fee you choose for support of this Package. You +may not charge a fee for this Package itself. However, you may distribute this +Package in aggregate with other (possibly commercial) programs as part of a +larger (possibly commercial) software distribution provided that you do not +advertise this Package as a product of your own. + +6. The scripts and library files supplied as input to or produced as output +from the programs of this Package do not automatically fall under the copyright +of this Package, but belong to whomever generated them, and may be sold +commercially, and may be aggregated with this Package. + +7. C or perl subroutines supplied by you and linked into this Package shall not +be considered part of this Package. + +8. The name of the Copyright Holder may not be used to endorse or promote +products derived from this software without specific prior written permission. + +9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED +WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF +MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. + +The End + diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..74e0a12 --- /dev/null +++ b/MANIFEST @@ -0,0 +1,45 @@ +# This file was automatically generated by Dist::Zilla::Plugin::Manifest v6.012. +CONTRIBUTING.md +CONTRIBUTORS +Changes +INSTALL +LICENSE +MANIFEST +META.json +META.yml +Makefile.PL +README.md +cpanfile +dist.ini +lib/HTTP/Config.pm +lib/HTTP/Headers.pm +lib/HTTP/Headers/Auth.pm +lib/HTTP/Headers/ETag.pm +lib/HTTP/Headers/Util.pm +lib/HTTP/Message.pm +lib/HTTP/Request.pm +lib/HTTP/Request/Common.pm +lib/HTTP/Response.pm +lib/HTTP/Status.pm +perlcriticrc +perltidyrc +t/00-report-prereqs.dd +t/00-report-prereqs.t +t/common-req.t +t/headers-auth.t +t/headers-etag.t +t/headers-util.t +t/headers.t +t/http-config.t +t/message-charset.t +t/message-decode-xml.t +t/message-old.t +t/message-parts.t +t/message.t +t/request.t +t/request_type_with_data.t +t/response.t +t/status-old.t +t/status.t +tidyall.ini +xt/release/cpan-changes.t diff --git a/META.json b/META.json new file mode 100644 index 0000000..c0e23e2 --- /dev/null +++ b/META.json @@ -0,0 +1,772 @@ +{ + "abstract" : "HTTP style message (base class)", + "author" : [ + "Gisle Aas " + ], + "dynamic_config" : 0, + "generated_by" : "Dist::Zilla version 6.012, CPAN::Meta::Converter version 2.150010", + "license" : [ + "perl_5" + ], + "meta-spec" : { + "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", + "version" : 2 + }, + "name" : "HTTP-Message", + "no_index" : { + "directory" : [ + "examples", + "t", + "xt" + ] + }, + "prereqs" : { + "configure" : { + "requires" : { + "ExtUtils::MakeMaker" : "0", + "perl" : "5.006" + }, + "suggests" : { + "JSON::PP" : "2.27300" + } + }, + "develop" : { + "requires" : { + "Test::CPAN::Changes" : "0.19", + "Test::More" : "0.96" + } + }, + "runtime" : { + "requires" : { + "Carp" : "0", + "Compress::Raw::Zlib" : "0", + "Encode" : "2.21", + "Encode::Locale" : "1", + "Exporter" : "5.57", + "HTTP::Date" : "6", + "IO::Compress::Bzip2" : "2.021", + "IO::Compress::Deflate" : "0", + "IO::Compress::Gzip" : "0", + "IO::HTML" : "0", + "IO::Uncompress::Bunzip2" : "2.021", + "IO::Uncompress::Gunzip" : "0", + "IO::Uncompress::Inflate" : "0", + "IO::Uncompress::RawInflate" : "0", + "LWP::MediaTypes" : "6", + "MIME::Base64" : "2.1", + "MIME::QuotedPrint" : "0", + "Storable" : "0", + "URI" : "1.10", + "base" : "0", + "perl" : "5.008001", + "strict" : "0", + "warnings" : "0" + } + }, + "test" : { + "recommends" : { + "CPAN::Meta" : "2.120900" + }, + "requires" : { + "ExtUtils::MakeMaker" : "0", + "File::Spec" : "0", + "PerlIO::encoding" : "0", + "Test::More" : "0.88", + "Time::Local" : "0", + "Try::Tiny" : "0", + "perl" : "5.008001" + } + } + }, + "release_status" : "stable", + "resources" : { + "bugtracker" : { + "web" : "https://github.com/libwww-perl/HTTP-Message/issues" + }, + "homepage" : "https://github.com/libwww-perl/HTTP-Message", + "repository" : { + "type" : "git", + "url" : "https://github.com/libwww-perl/HTTP-Message.git", + "web" : "https://github.com/libwww-perl/HTTP-Message" + }, + "x_IRC" : "irc://irc.perl.org/#lwp", + "x_MailingList" : "mailto:libwww@perl.org" + }, + "version" : "6.18", + "x_Dist_Zilla" : { + "perl" : { + "version" : "5.026001" + }, + "plugins" : [ + { + "class" : "Dist::Zilla::Plugin::MetaResources", + "name" : "MetaResources", + "version" : "6.012" + }, + { + "class" : "Dist::Zilla::Plugin::Prereqs", + "config" : { + "Dist::Zilla::Plugin::Prereqs" : { + "phase" : "runtime", + "type" : "requires" + } + }, + "name" : "Prereqs", + "version" : "6.012" + }, + { + "class" : "Dist::Zilla::Plugin::PromptIfStale", + "config" : { + "Dist::Zilla::Plugin::PromptIfStale" : { + "check_all_plugins" : 0, + "check_all_prereqs" : 0, + "modules" : [ + "Dist::Zilla::PluginBundle::Author::OALDERS" + ], + "phase" : "build", + "run_under_travis" : 0, + "skip" : [] + } + }, + "name" : "@Author::OALDERS/stale modules, build", + "version" : "0.055" + }, + { + "class" : "Dist::Zilla::Plugin::PromptIfStale", + "config" : { + "Dist::Zilla::Plugin::PromptIfStale" : { + "check_all_plugins" : 1, + "check_all_prereqs" : 1, + "modules" : [], + "phase" : "release", + "run_under_travis" : 0, + "skip" : [] + } + }, + "name" : "@Author::OALDERS/stale modules, release", + "version" : "0.055" + }, + { + "class" : "Dist::Zilla::Plugin::MAXMIND::TidyAll", + "name" : "@Author::OALDERS/MAXMIND::TidyAll", + "version" : "0.13" + }, + { + "class" : "Dist::Zilla::Plugin::AutoPrereqs", + "name" : "@Author::OALDERS/AutoPrereqs", + "version" : "6.012" + }, + { + "class" : "Dist::Zilla::Plugin::CheckChangesHasContent", + "name" : "@Author::OALDERS/CheckChangesHasContent", + "version" : "0.011" + }, + { + "class" : "Dist::Zilla::Plugin::MakeMaker", + "config" : { + "Dist::Zilla::Role::TestRunner" : { + "default_jobs" : 1 + } + }, + "name" : "@Author::OALDERS/MakeMaker", + "version" : "6.012" + }, + { + "class" : "Dist::Zilla::Plugin::CPANFile", + "name" : "@Author::OALDERS/CPANFile", + "version" : "6.012" + }, + { + "class" : "Dist::Zilla::Plugin::ContributorsFile", + "name" : "@Author::OALDERS/ContributorsFile", + "version" : "0.3.0" + }, + { + "class" : "Dist::Zilla::Plugin::MetaJSON", + "name" : "@Author::OALDERS/MetaJSON", + "version" : "6.012" + }, + { + "class" : "Dist::Zilla::Plugin::MetaYAML", + "name" : "@Author::OALDERS/MetaYAML", + "version" : "6.012" + }, + { + "class" : "Dist::Zilla::Plugin::Manifest", + "name" : "@Author::OALDERS/Manifest", + "version" : "6.012" + }, + { + "class" : "Dist::Zilla::Plugin::MetaNoIndex", + "name" : "@Author::OALDERS/MetaNoIndex", + "version" : "6.012" + }, + { + "class" : "Dist::Zilla::Plugin::MetaConfig", + "name" : "@Author::OALDERS/MetaConfig", + "version" : "6.012" + }, + { + "class" : "Dist::Zilla::Plugin::MetaResources", + "name" : "@Author::OALDERS/MetaResources", + "version" : "6.012" + }, + { + "class" : "Dist::Zilla::Plugin::License", + "name" : "@Author::OALDERS/License", + "version" : "6.012" + }, + { + "class" : "Dist::Zilla::Plugin::InstallGuide", + "name" : "@Author::OALDERS/InstallGuide", + "version" : "1.200009" + }, + { + "class" : "Dist::Zilla::Plugin::ExecDir", + "name" : "@Author::OALDERS/ExecDir", + "version" : "6.012" + }, + { + "class" : "Dist::Zilla::Plugin::Test::CPAN::Changes", + "config" : { + "Dist::Zilla::Plugin::Test::CPAN::Changes" : { + "changelog" : "Changes" + } + }, + "name" : "@Author::OALDERS/Test::CPAN::Changes", + "version" : "0.012" + }, + { + "class" : "Dist::Zilla::Plugin::TestRelease", + "name" : "@Author::OALDERS/TestRelease", + "version" : "6.012" + }, + { + "class" : "Dist::Zilla::Plugin::Test::ReportPrereqs", + "name" : "@Author::OALDERS/Test::ReportPrereqs", + "version" : "0.027" + }, + { + "class" : "Dist::Zilla::Plugin::RunExtraTests", + "config" : { + "Dist::Zilla::Role::TestRunner" : { + "default_jobs" : 1 + } + }, + "name" : "@Author::OALDERS/RunExtraTests", + "version" : "0.029" + }, + { + "class" : "Dist::Zilla::Plugin::MinimumPerl", + "name" : "@Author::OALDERS/MinimumPerl", + "version" : "1.006" + }, + { + "class" : "Dist::Zilla::Plugin::PodWeaver", + "config" : { + "Dist::Zilla::Plugin::PodWeaver" : { + "finder" : [ + ":InstallModules", + ":ExecFiles" + ], + "plugins" : [ + { + "class" : "Pod::Weaver::Plugin::EnsurePod5", + "name" : "@CorePrep/EnsurePod5", + "version" : "4.015" + }, + { + "class" : "Pod::Weaver::Plugin::H1Nester", + "name" : "@CorePrep/H1Nester", + "version" : "4.015" + }, + { + "class" : "Pod::Weaver::Plugin::SingleEncoding", + "name" : "@Default/SingleEncoding", + "version" : "4.015" + }, + { + "class" : "Pod::Weaver::Section::Name", + "name" : "@Default/Name", + "version" : "4.015" + }, + { + "class" : "Pod::Weaver::Section::Version", + "name" : "@Default/Version", + "version" : "4.015" + }, + { + "class" : "Pod::Weaver::Section::Region", + "name" : "@Default/prelude", + "version" : "4.015" + }, + { + "class" : "Pod::Weaver::Section::Generic", + "name" : "SYNOPSIS", + "version" : "4.015" + }, + { + "class" : "Pod::Weaver::Section::Generic", + "name" : "DESCRIPTION", + "version" : "4.015" + }, + { + "class" : "Pod::Weaver::Section::Generic", + "name" : "OVERVIEW", + "version" : "4.015" + }, + { + "class" : "Pod::Weaver::Section::Collect", + "name" : "ATTRIBUTES", + "version" : "4.015" + }, + { + "class" : "Pod::Weaver::Section::Collect", + "name" : "METHODS", + "version" : "4.015" + }, + { + "class" : "Pod::Weaver::Section::Collect", + "name" : "FUNCTIONS", + "version" : "4.015" + }, + { + "class" : "Pod::Weaver::Section::Leftovers", + "name" : "@Default/Leftovers", + "version" : "4.015" + }, + { + "class" : "Pod::Weaver::Section::Region", + "name" : "@Default/postlude", + "version" : "4.015" + }, + { + "class" : "Pod::Weaver::Section::Authors", + "name" : "@Default/Authors", + "version" : "4.015" + }, + { + "class" : "Pod::Weaver::Section::Legal", + "name" : "@Default/Legal", + "version" : "4.015" + } + ] + } + }, + "name" : "@Author::OALDERS/PodWeaver", + "version" : "4.008" + }, + { + "class" : "Dist::Zilla::Plugin::PruneCruft", + "name" : "@Author::OALDERS/PruneCruft", + "version" : "6.012" + }, + { + "class" : "Dist::Zilla::Plugin::CopyFilesFromBuild", + "name" : "@Author::OALDERS/CopyFilesFromBuild", + "version" : "0.170880" + }, + { + "class" : "Dist::Zilla::Plugin::GithubMeta", + "name" : "@Author::OALDERS/GithubMeta", + "version" : "0.58" + }, + { + "class" : "Dist::Zilla::Plugin::Git::GatherDir", + "config" : { + "Dist::Zilla::Plugin::GatherDir" : { + "exclude_filename" : [ + "Install", + "LICENSE", + "META.json", + "Makefile.PL", + "README.md", + "cpanfile" + ], + "exclude_match" : [], + "follow_symlinks" : 0, + "include_dotfiles" : 0, + "prefix" : "", + "prune_directory" : [], + "root" : "." + }, + "Dist::Zilla::Plugin::Git::GatherDir" : { + "include_untracked" : 0 + } + }, + "name" : "@Author::OALDERS/Git::GatherDir", + "version" : "2.045" + }, + { + "class" : "Dist::Zilla::Plugin::CopyFilesFromRelease", + "config" : { + "Dist::Zilla::Plugin::CopyFilesFromRelease" : { + "filename" : [ + "Install" + ], + "match" : [] + } + }, + "name" : "@Author::OALDERS/CopyFilesFromRelease", + "version" : "0.006" + }, + { + "class" : "Dist::Zilla::Plugin::Git::Check", + "config" : { + "Dist::Zilla::Plugin::Git::Check" : { + "untracked_files" : "die" + }, + "Dist::Zilla::Role::Git::DirtyFiles" : { + "allow_dirty" : [ + "Changes", + "Install", + "LICENSE", + "META.json", + "Makefile.PL", + "README.md", + "cpanfile", + "dist.ini" + ], + "allow_dirty_match" : [], + "changelog" : "Changes" + }, + "Dist::Zilla::Role::Git::Repo" : { + "git_version" : "2.17.1", + "repo_root" : "." + } + }, + "name" : "@Author::OALDERS/Git::Check", + "version" : "2.045" + }, + { + "class" : "Dist::Zilla::Plugin::Git::Contributors", + "config" : { + "Dist::Zilla::Plugin::Git::Contributors" : { + "git_version" : "2.17.1", + "include_authors" : 0, + "include_releaser" : 1, + "order_by" : "name", + "paths" : [] + } + }, + "name" : "@Author::OALDERS/Git::Contributors", + "version" : "0.034" + }, + { + "class" : "Dist::Zilla::Plugin::ReadmeAnyFromPod", + "config" : { + "Dist::Zilla::Role::FileWatcher" : { + "version" : "0.006" + } + }, + "name" : "@Author::OALDERS/ReadmeMdInBuild", + "version" : "0.163250" + }, + { + "class" : "Dist::Zilla::Plugin::ShareDir", + "name" : "@Author::OALDERS/ShareDir", + "version" : "6.012" + }, + { + "class" : "Dist::Zilla::Plugin::TravisCI::StatusBadge", + "name" : "@Author::OALDERS/TravisCI::StatusBadge", + "version" : "0.007" + }, + { + "class" : "Dist::Zilla::Plugin::ConfirmRelease", + "name" : "@Author::OALDERS/ConfirmRelease", + "version" : "6.012" + }, + { + "class" : "Dist::Zilla::Plugin::UploadToCPAN", + "name" : "@Author::OALDERS/UploadToCPAN", + "version" : "6.012" + }, + { + "class" : "Dist::Zilla::Plugin::RewriteVersion::Transitional", + "config" : { + "Dist::Zilla::Plugin::RewriteVersion" : { + "add_tarball_name" : 0, + "finders" : [ + ":ExecFiles", + ":InstallModules" + ], + "global" : 0, + "skip_version_provider" : 0 + }, + "Dist::Zilla::Plugin::RewriteVersion::Transitional" : {} + }, + "name" : "@Author::OALDERS/@Git::VersionManager/RewriteVersion::Transitional", + "version" : "0.009" + }, + { + "class" : "Dist::Zilla::Plugin::MetaProvides::Update", + "name" : "@Author::OALDERS/@Git::VersionManager/MetaProvides::Update", + "version" : "0.007" + }, + { + "class" : "Dist::Zilla::Plugin::CopyFilesFromRelease", + "config" : { + "Dist::Zilla::Plugin::CopyFilesFromRelease" : { + "filename" : [ + "Changes" + ], + "match" : [] + } + }, + "name" : "@Author::OALDERS/@Git::VersionManager/CopyFilesFromRelease", + "version" : "0.006" + }, + { + "class" : "Dist::Zilla::Plugin::Git::Commit", + "config" : { + "Dist::Zilla::Plugin::Git::Commit" : { + "add_files_in" : [], + "commit_msg" : "v%v%n%n%c" + }, + "Dist::Zilla::Role::Git::DirtyFiles" : { + "allow_dirty" : [ + "Changes", + "Install", + "LICENSE", + "META.json", + "Makefile.PL", + "README.md", + "cpanfile", + "dist.ini" + ], + "allow_dirty_match" : [], + "changelog" : "Changes" + }, + "Dist::Zilla::Role::Git::Repo" : { + "git_version" : "2.17.1", + "repo_root" : "." + }, + "Dist::Zilla::Role::Git::StringFormatter" : { + "time_zone" : "local" + } + }, + "name" : "@Author::OALDERS/@Git::VersionManager/release snapshot", + "version" : "2.045" + }, + { + "class" : "Dist::Zilla::Plugin::Git::Tag", + "config" : { + "Dist::Zilla::Plugin::Git::Tag" : { + "branch" : null, + "changelog" : "Changes", + "signed" : 0, + "tag" : "v6.18", + "tag_format" : "v%v", + "tag_message" : "v%v" + }, + "Dist::Zilla::Role::Git::Repo" : { + "git_version" : "2.17.1", + "repo_root" : "." + }, + "Dist::Zilla::Role::Git::StringFormatter" : { + "time_zone" : "local" + } + }, + "name" : "@Author::OALDERS/@Git::VersionManager/Git::Tag", + "version" : "2.045" + }, + { + "class" : "Dist::Zilla::Plugin::BumpVersionAfterRelease::Transitional", + "config" : { + "Dist::Zilla::Plugin::BumpVersionAfterRelease" : { + "finders" : [ + ":ExecFiles", + ":InstallModules" + ], + "global" : 0, + "munge_makefile_pl" : 1 + }, + "Dist::Zilla::Plugin::BumpVersionAfterRelease::Transitional" : {} + }, + "name" : "@Author::OALDERS/@Git::VersionManager/BumpVersionAfterRelease::Transitional", + "version" : "0.009" + }, + { + "class" : "Dist::Zilla::Plugin::NextRelease", + "name" : "@Author::OALDERS/@Git::VersionManager/NextRelease", + "version" : "6.012" + }, + { + "class" : "Dist::Zilla::Plugin::Git::Commit", + "config" : { + "Dist::Zilla::Plugin::Git::Commit" : { + "add_files_in" : [], + "commit_msg" : "increment $VERSION after %v release" + }, + "Dist::Zilla::Role::Git::DirtyFiles" : { + "allow_dirty" : [ + "Build.PL", + "Changes", + "Makefile.PL" + ], + "allow_dirty_match" : [ + "(?^:^lib/.*\\.pm$)" + ], + "changelog" : "Changes" + }, + "Dist::Zilla::Role::Git::Repo" : { + "git_version" : "2.17.1", + "repo_root" : "." + }, + "Dist::Zilla::Role::Git::StringFormatter" : { + "time_zone" : "local" + } + }, + "name" : "@Author::OALDERS/@Git::VersionManager/post-release commit", + "version" : "2.045" + }, + { + "class" : "Dist::Zilla::Plugin::Git::Push", + "config" : { + "Dist::Zilla::Plugin::Git::Push" : { + "push_to" : [ + "origin" + ], + "remotes_must_exist" : 1 + }, + "Dist::Zilla::Role::Git::Repo" : { + "git_version" : "2.17.1", + "repo_root" : "." + } + }, + "name" : "@Author::OALDERS/Git::Push", + "version" : "2.045" + }, + { + "class" : "Dist::Zilla::Plugin::FinderCode", + "name" : ":InstallModules", + "version" : "6.012" + }, + { + "class" : "Dist::Zilla::Plugin::FinderCode", + "name" : ":IncModules", + "version" : "6.012" + }, + { + "class" : "Dist::Zilla::Plugin::FinderCode", + "name" : ":TestFiles", + "version" : "6.012" + }, + { + "class" : "Dist::Zilla::Plugin::FinderCode", + "name" : ":ExtraTestFiles", + "version" : "6.012" + }, + { + "class" : "Dist::Zilla::Plugin::FinderCode", + "name" : ":ExecFiles", + "version" : "6.012" + }, + { + "class" : "Dist::Zilla::Plugin::FinderCode", + "name" : ":PerlExecFiles", + "version" : "6.012" + }, + { + "class" : "Dist::Zilla::Plugin::FinderCode", + "name" : ":ShareFiles", + "version" : "6.012" + }, + { + "class" : "Dist::Zilla::Plugin::FinderCode", + "name" : ":MainModule", + "version" : "6.012" + }, + { + "class" : "Dist::Zilla::Plugin::FinderCode", + "name" : ":AllFiles", + "version" : "6.012" + }, + { + "class" : "Dist::Zilla::Plugin::FinderCode", + "name" : ":NoFiles", + "version" : "6.012" + } + ], + "zilla" : { + "class" : "Dist::Zilla::Dist::Builder", + "config" : { + "is_trial" : 0 + }, + "version" : "6.012" + } + }, + "x_contributors" : [ + "Adam Kennedy ", + "Adam Sjogren ", + "Alexey Tourbin ", + "Alex Kapranoff ", + "amire80 ", + "Andreas J. Koenig ", + "Bill Mann ", + "Brendan Byrd ", + "Bron Gondwana ", + "Chase Whitener ", + "Christopher J. Madsen ", + "chromatic ", + "Daniel Hedlund ", + "David E. Wheeler ", + "DAVIDRW ", + "David Steinbrunner ", + "Father Chrysostomos ", + "Felipe Gasper ", + "FWILES ", + "Gavin Peters ", + "Gisle Aas ", + "Graeme Thompson ", + "Graham Knop ", + "Hans-H. Froehlich ", + "Ian Kilgore ", + "Jacob J ", + "jefflee ", + "Jerome Eteve ", + "john9art ", + "jonasbn ", + "Karen Etheridge ", + "Mark Overmeer ", + "Mark Stosberg ", + "Martin H. Sluka ", + "Mickey Nasriachi ", + "Mike Schilli ", + "murphy ", + "Olaf Alders ", + "Olivier Mengu\u00e9 ", + "Ondrej Hanak ", + "openstrike ", + "Peter Rabbitson ", + "phrstbrn ", + "Robert Rothenberg ", + "Robert Rothenberg ", + "Robert Stone ", + "Rolf Grossmann ", + "ruff ", + "sasao ", + "Saturday Walkers Club ", + "Sean M. Burke ", + "Slaven Rezic ", + "Spiros Denaxas ", + "Steve Hay ", + "Tatsuhiko Miyagawa ", + "Tatsuhiko Miyagawa ", + "Theo van Hoesel ", + "Tobias Leich ", + "Todd Lipcon ", + "tokuhirom ", + "Tom Hukins ", + "Tony Finch ", + "Toru Yamaguchi ", + "uid39246 ", + "Ville Skytt\u00e4 ", + "Yuri Karaban ", + "Zefram " + ], + "x_generated_by_perl" : "v5.26.1", + "x_serialization_backend" : "Cpanel::JSON::XS version 3.0239" +} + diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..25c4375 --- /dev/null +++ b/META.yml @@ -0,0 +1,592 @@ +--- +abstract: 'HTTP style message (base class)' +author: + - 'Gisle Aas ' +build_requires: + ExtUtils::MakeMaker: '0' + File::Spec: '0' + PerlIO::encoding: '0' + Test::More: '0.88' + Time::Local: '0' + Try::Tiny: '0' + perl: '5.008001' +configure_requires: + ExtUtils::MakeMaker: '0' + perl: '5.006' +dynamic_config: 0 +generated_by: 'Dist::Zilla version 6.012, CPAN::Meta::Converter version 2.150010' +license: perl +meta-spec: + url: http://module-build.sourceforge.net/META-spec-v1.4.html + version: '1.4' +name: HTTP-Message +no_index: + directory: + - examples + - t + - xt +requires: + Carp: '0' + Compress::Raw::Zlib: '0' + Encode: '2.21' + Encode::Locale: '1' + Exporter: '5.57' + HTTP::Date: '6' + IO::Compress::Bzip2: '2.021' + IO::Compress::Deflate: '0' + IO::Compress::Gzip: '0' + IO::HTML: '0' + IO::Uncompress::Bunzip2: '2.021' + IO::Uncompress::Gunzip: '0' + IO::Uncompress::Inflate: '0' + IO::Uncompress::RawInflate: '0' + LWP::MediaTypes: '6' + MIME::Base64: '2.1' + MIME::QuotedPrint: '0' + Storable: '0' + URI: '1.10' + base: '0' + perl: '5.008001' + strict: '0' + warnings: '0' +resources: + IRC: irc://irc.perl.org/#lwp + MailingList: mailto:libwww@perl.org + bugtracker: https://github.com/libwww-perl/HTTP-Message/issues + homepage: https://github.com/libwww-perl/HTTP-Message + repository: https://github.com/libwww-perl/HTTP-Message.git +version: '6.18' +x_Dist_Zilla: + perl: + version: '5.026001' + plugins: + - + class: Dist::Zilla::Plugin::MetaResources + name: MetaResources + version: '6.012' + - + class: Dist::Zilla::Plugin::Prereqs + config: + Dist::Zilla::Plugin::Prereqs: + phase: runtime + type: requires + name: Prereqs + version: '6.012' + - + class: Dist::Zilla::Plugin::PromptIfStale + config: + Dist::Zilla::Plugin::PromptIfStale: + check_all_plugins: 0 + check_all_prereqs: 0 + modules: + - Dist::Zilla::PluginBundle::Author::OALDERS + phase: build + run_under_travis: 0 + skip: [] + name: '@Author::OALDERS/stale modules, build' + version: '0.055' + - + class: Dist::Zilla::Plugin::PromptIfStale + config: + Dist::Zilla::Plugin::PromptIfStale: + check_all_plugins: 1 + check_all_prereqs: 1 + modules: [] + phase: release + run_under_travis: 0 + skip: [] + name: '@Author::OALDERS/stale modules, release' + version: '0.055' + - + class: Dist::Zilla::Plugin::MAXMIND::TidyAll + name: '@Author::OALDERS/MAXMIND::TidyAll' + version: '0.13' + - + class: Dist::Zilla::Plugin::AutoPrereqs + name: '@Author::OALDERS/AutoPrereqs' + version: '6.012' + - + class: Dist::Zilla::Plugin::CheckChangesHasContent + name: '@Author::OALDERS/CheckChangesHasContent' + version: '0.011' + - + class: Dist::Zilla::Plugin::MakeMaker + config: + Dist::Zilla::Role::TestRunner: + default_jobs: 1 + name: '@Author::OALDERS/MakeMaker' + version: '6.012' + - + class: Dist::Zilla::Plugin::CPANFile + name: '@Author::OALDERS/CPANFile' + version: '6.012' + - + class: Dist::Zilla::Plugin::ContributorsFile + name: '@Author::OALDERS/ContributorsFile' + version: 0.3.0 + - + class: Dist::Zilla::Plugin::MetaJSON + name: '@Author::OALDERS/MetaJSON' + version: '6.012' + - + class: Dist::Zilla::Plugin::MetaYAML + name: '@Author::OALDERS/MetaYAML' + version: '6.012' + - + class: Dist::Zilla::Plugin::Manifest + name: '@Author::OALDERS/Manifest' + version: '6.012' + - + class: Dist::Zilla::Plugin::MetaNoIndex + name: '@Author::OALDERS/MetaNoIndex' + version: '6.012' + - + class: Dist::Zilla::Plugin::MetaConfig + name: '@Author::OALDERS/MetaConfig' + version: '6.012' + - + class: Dist::Zilla::Plugin::MetaResources + name: '@Author::OALDERS/MetaResources' + version: '6.012' + - + class: Dist::Zilla::Plugin::License + name: '@Author::OALDERS/License' + version: '6.012' + - + class: Dist::Zilla::Plugin::InstallGuide + name: '@Author::OALDERS/InstallGuide' + version: '1.200009' + - + class: Dist::Zilla::Plugin::ExecDir + name: '@Author::OALDERS/ExecDir' + version: '6.012' + - + class: Dist::Zilla::Plugin::Test::CPAN::Changes + config: + Dist::Zilla::Plugin::Test::CPAN::Changes: + changelog: Changes + name: '@Author::OALDERS/Test::CPAN::Changes' + version: '0.012' + - + class: Dist::Zilla::Plugin::TestRelease + name: '@Author::OALDERS/TestRelease' + version: '6.012' + - + class: Dist::Zilla::Plugin::Test::ReportPrereqs + name: '@Author::OALDERS/Test::ReportPrereqs' + version: '0.027' + - + class: Dist::Zilla::Plugin::RunExtraTests + config: + Dist::Zilla::Role::TestRunner: + default_jobs: 1 + name: '@Author::OALDERS/RunExtraTests' + version: '0.029' + - + class: Dist::Zilla::Plugin::MinimumPerl + name: '@Author::OALDERS/MinimumPerl' + version: '1.006' + - + class: Dist::Zilla::Plugin::PodWeaver + config: + Dist::Zilla::Plugin::PodWeaver: + finder: + - ':InstallModules' + - ':ExecFiles' + plugins: + - + class: Pod::Weaver::Plugin::EnsurePod5 + name: '@CorePrep/EnsurePod5' + version: '4.015' + - + class: Pod::Weaver::Plugin::H1Nester + name: '@CorePrep/H1Nester' + version: '4.015' + - + class: Pod::Weaver::Plugin::SingleEncoding + name: '@Default/SingleEncoding' + version: '4.015' + - + class: Pod::Weaver::Section::Name + name: '@Default/Name' + version: '4.015' + - + class: Pod::Weaver::Section::Version + name: '@Default/Version' + version: '4.015' + - + class: Pod::Weaver::Section::Region + name: '@Default/prelude' + version: '4.015' + - + class: Pod::Weaver::Section::Generic + name: SYNOPSIS + version: '4.015' + - + class: Pod::Weaver::Section::Generic + name: DESCRIPTION + version: '4.015' + - + class: Pod::Weaver::Section::Generic + name: OVERVIEW + version: '4.015' + - + class: Pod::Weaver::Section::Collect + name: ATTRIBUTES + version: '4.015' + - + class: Pod::Weaver::Section::Collect + name: METHODS + version: '4.015' + - + class: Pod::Weaver::Section::Collect + name: FUNCTIONS + version: '4.015' + - + class: Pod::Weaver::Section::Leftovers + name: '@Default/Leftovers' + version: '4.015' + - + class: Pod::Weaver::Section::Region + name: '@Default/postlude' + version: '4.015' + - + class: Pod::Weaver::Section::Authors + name: '@Default/Authors' + version: '4.015' + - + class: Pod::Weaver::Section::Legal + name: '@Default/Legal' + version: '4.015' + name: '@Author::OALDERS/PodWeaver' + version: '4.008' + - + class: Dist::Zilla::Plugin::PruneCruft + name: '@Author::OALDERS/PruneCruft' + version: '6.012' + - + class: Dist::Zilla::Plugin::CopyFilesFromBuild + name: '@Author::OALDERS/CopyFilesFromBuild' + version: '0.170880' + - + class: Dist::Zilla::Plugin::GithubMeta + name: '@Author::OALDERS/GithubMeta' + version: '0.58' + - + class: Dist::Zilla::Plugin::Git::GatherDir + config: + Dist::Zilla::Plugin::GatherDir: + exclude_filename: + - Install + - LICENSE + - META.json + - Makefile.PL + - README.md + - cpanfile + exclude_match: [] + follow_symlinks: 0 + include_dotfiles: 0 + prefix: '' + prune_directory: [] + root: . + Dist::Zilla::Plugin::Git::GatherDir: + include_untracked: 0 + name: '@Author::OALDERS/Git::GatherDir' + version: '2.045' + - + class: Dist::Zilla::Plugin::CopyFilesFromRelease + config: + Dist::Zilla::Plugin::CopyFilesFromRelease: + filename: + - Install + match: [] + name: '@Author::OALDERS/CopyFilesFromRelease' + version: '0.006' + - + class: Dist::Zilla::Plugin::Git::Check + config: + Dist::Zilla::Plugin::Git::Check: + untracked_files: die + Dist::Zilla::Role::Git::DirtyFiles: + allow_dirty: + - Changes + - Install + - LICENSE + - META.json + - Makefile.PL + - README.md + - cpanfile + - dist.ini + allow_dirty_match: [] + changelog: Changes + Dist::Zilla::Role::Git::Repo: + git_version: 2.17.1 + repo_root: . + name: '@Author::OALDERS/Git::Check' + version: '2.045' + - + class: Dist::Zilla::Plugin::Git::Contributors + config: + Dist::Zilla::Plugin::Git::Contributors: + git_version: 2.17.1 + include_authors: 0 + include_releaser: 1 + order_by: name + paths: [] + name: '@Author::OALDERS/Git::Contributors' + version: '0.034' + - + class: Dist::Zilla::Plugin::ReadmeAnyFromPod + config: + Dist::Zilla::Role::FileWatcher: + version: '0.006' + name: '@Author::OALDERS/ReadmeMdInBuild' + version: '0.163250' + - + class: Dist::Zilla::Plugin::ShareDir + name: '@Author::OALDERS/ShareDir' + version: '6.012' + - + class: Dist::Zilla::Plugin::TravisCI::StatusBadge + name: '@Author::OALDERS/TravisCI::StatusBadge' + version: '0.007' + - + class: Dist::Zilla::Plugin::ConfirmRelease + name: '@Author::OALDERS/ConfirmRelease' + version: '6.012' + - + class: Dist::Zilla::Plugin::UploadToCPAN + name: '@Author::OALDERS/UploadToCPAN' + version: '6.012' + - + class: Dist::Zilla::Plugin::RewriteVersion::Transitional + config: + Dist::Zilla::Plugin::RewriteVersion: + add_tarball_name: 0 + finders: + - ':ExecFiles' + - ':InstallModules' + global: 0 + skip_version_provider: 0 + Dist::Zilla::Plugin::RewriteVersion::Transitional: {} + name: '@Author::OALDERS/@Git::VersionManager/RewriteVersion::Transitional' + version: '0.009' + - + class: Dist::Zilla::Plugin::MetaProvides::Update + name: '@Author::OALDERS/@Git::VersionManager/MetaProvides::Update' + version: '0.007' + - + class: Dist::Zilla::Plugin::CopyFilesFromRelease + config: + Dist::Zilla::Plugin::CopyFilesFromRelease: + filename: + - Changes + match: [] + name: '@Author::OALDERS/@Git::VersionManager/CopyFilesFromRelease' + version: '0.006' + - + class: Dist::Zilla::Plugin::Git::Commit + config: + Dist::Zilla::Plugin::Git::Commit: + add_files_in: [] + commit_msg: v%v%n%n%c + Dist::Zilla::Role::Git::DirtyFiles: + allow_dirty: + - Changes + - Install + - LICENSE + - META.json + - Makefile.PL + - README.md + - cpanfile + - dist.ini + allow_dirty_match: [] + changelog: Changes + Dist::Zilla::Role::Git::Repo: + git_version: 2.17.1 + repo_root: . + Dist::Zilla::Role::Git::StringFormatter: + time_zone: local + name: '@Author::OALDERS/@Git::VersionManager/release snapshot' + version: '2.045' + - + class: Dist::Zilla::Plugin::Git::Tag + config: + Dist::Zilla::Plugin::Git::Tag: + branch: ~ + changelog: Changes + signed: 0 + tag: v6.18 + tag_format: v%v + tag_message: v%v + Dist::Zilla::Role::Git::Repo: + git_version: 2.17.1 + repo_root: . + Dist::Zilla::Role::Git::StringFormatter: + time_zone: local + name: '@Author::OALDERS/@Git::VersionManager/Git::Tag' + version: '2.045' + - + class: Dist::Zilla::Plugin::BumpVersionAfterRelease::Transitional + config: + Dist::Zilla::Plugin::BumpVersionAfterRelease: + finders: + - ':ExecFiles' + - ':InstallModules' + global: 0 + munge_makefile_pl: 1 + Dist::Zilla::Plugin::BumpVersionAfterRelease::Transitional: {} + name: '@Author::OALDERS/@Git::VersionManager/BumpVersionAfterRelease::Transitional' + version: '0.009' + - + class: Dist::Zilla::Plugin::NextRelease + name: '@Author::OALDERS/@Git::VersionManager/NextRelease' + version: '6.012' + - + class: Dist::Zilla::Plugin::Git::Commit + config: + Dist::Zilla::Plugin::Git::Commit: + add_files_in: [] + commit_msg: 'increment $VERSION after %v release' + Dist::Zilla::Role::Git::DirtyFiles: + allow_dirty: + - Build.PL + - Changes + - Makefile.PL + allow_dirty_match: + - (?^:^lib/.*\.pm$) + changelog: Changes + Dist::Zilla::Role::Git::Repo: + git_version: 2.17.1 + repo_root: . + Dist::Zilla::Role::Git::StringFormatter: + time_zone: local + name: '@Author::OALDERS/@Git::VersionManager/post-release commit' + version: '2.045' + - + class: Dist::Zilla::Plugin::Git::Push + config: + Dist::Zilla::Plugin::Git::Push: + push_to: + - origin + remotes_must_exist: 1 + Dist::Zilla::Role::Git::Repo: + git_version: 2.17.1 + repo_root: . + name: '@Author::OALDERS/Git::Push' + version: '2.045' + - + class: Dist::Zilla::Plugin::FinderCode + name: ':InstallModules' + version: '6.012' + - + class: Dist::Zilla::Plugin::FinderCode + name: ':IncModules' + version: '6.012' + - + class: Dist::Zilla::Plugin::FinderCode + name: ':TestFiles' + version: '6.012' + - + class: Dist::Zilla::Plugin::FinderCode + name: ':ExtraTestFiles' + version: '6.012' + - + class: Dist::Zilla::Plugin::FinderCode + name: ':ExecFiles' + version: '6.012' + - + class: Dist::Zilla::Plugin::FinderCode + name: ':PerlExecFiles' + version: '6.012' + - + class: Dist::Zilla::Plugin::FinderCode + name: ':ShareFiles' + version: '6.012' + - + class: Dist::Zilla::Plugin::FinderCode + name: ':MainModule' + version: '6.012' + - + class: Dist::Zilla::Plugin::FinderCode + name: ':AllFiles' + version: '6.012' + - + class: Dist::Zilla::Plugin::FinderCode + name: ':NoFiles' + version: '6.012' + zilla: + class: Dist::Zilla::Dist::Builder + config: + is_trial: '0' + version: '6.012' +x_contributors: + - 'Adam Kennedy ' + - 'Adam Sjogren ' + - 'Alexey Tourbin ' + - 'Alex Kapranoff ' + - 'amire80 ' + - 'Andreas J. Koenig ' + - 'Bill Mann ' + - 'Brendan Byrd ' + - 'Bron Gondwana ' + - 'Chase Whitener ' + - 'Christopher J. Madsen ' + - 'chromatic ' + - 'Daniel Hedlund ' + - 'David E. Wheeler ' + - 'DAVIDRW ' + - 'David Steinbrunner ' + - 'Father Chrysostomos ' + - 'Felipe Gasper ' + - 'FWILES ' + - 'Gavin Peters ' + - 'Gisle Aas ' + - 'Graeme Thompson ' + - 'Graham Knop ' + - 'Hans-H. Froehlich ' + - 'Ian Kilgore ' + - 'Jacob J ' + - 'jefflee ' + - 'Jerome Eteve ' + - 'john9art ' + - 'jonasbn ' + - 'Karen Etheridge ' + - 'Mark Overmeer ' + - 'Mark Stosberg ' + - 'Martin H. Sluka ' + - 'Mickey Nasriachi ' + - 'Mike Schilli ' + - 'murphy ' + - 'Olaf Alders ' + - 'Olivier Mengué ' + - 'Ondrej Hanak ' + - 'openstrike ' + - 'Peter Rabbitson ' + - 'phrstbrn ' + - 'Robert Rothenberg ' + - 'Robert Rothenberg ' + - 'Robert Stone ' + - 'Rolf Grossmann ' + - 'ruff ' + - 'sasao ' + - 'Saturday Walkers Club ' + - 'Sean M. Burke ' + - 'Slaven Rezic ' + - 'Spiros Denaxas ' + - 'Steve Hay ' + - 'Tatsuhiko Miyagawa ' + - 'Tatsuhiko Miyagawa ' + - 'Theo van Hoesel ' + - 'Tobias Leich ' + - 'Todd Lipcon ' + - 'tokuhirom ' + - 'Tom Hukins ' + - 'Tony Finch ' + - 'Toru Yamaguchi ' + - 'uid39246 ' + - 'Ville Skyttä ' + - 'Yuri Karaban ' + - 'Zefram ' +x_generated_by_perl: v5.26.1 +x_serialization_backend: 'YAML::Tiny version 1.70' diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..f450f85 --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,99 @@ +# This file was automatically generated by Dist::Zilla::Plugin::MakeMaker v6.012. +use strict; +use warnings; + +use 5.008001; + +use ExtUtils::MakeMaker; + +my %WriteMakefileArgs = ( + "ABSTRACT" => "HTTP style message (base class)", + "AUTHOR" => "Gisle Aas ", + "CONFIGURE_REQUIRES" => { + "ExtUtils::MakeMaker" => 0 + }, + "DISTNAME" => "HTTP-Message", + "LICENSE" => "perl", + "MIN_PERL_VERSION" => "5.008001", + "NAME" => "HTTP::Message", + "PREREQ_PM" => { + "Carp" => 0, + "Compress::Raw::Zlib" => 0, + "Encode" => "2.21", + "Encode::Locale" => 1, + "Exporter" => "5.57", + "HTTP::Date" => 6, + "IO::Compress::Bzip2" => "2.021", + "IO::Compress::Deflate" => 0, + "IO::Compress::Gzip" => 0, + "IO::HTML" => 0, + "IO::Uncompress::Bunzip2" => "2.021", + "IO::Uncompress::Gunzip" => 0, + "IO::Uncompress::Inflate" => 0, + "IO::Uncompress::RawInflate" => 0, + "LWP::MediaTypes" => 6, + "MIME::Base64" => "2.1", + "MIME::QuotedPrint" => 0, + "Storable" => 0, + "URI" => "1.10", + "base" => 0, + "strict" => 0, + "warnings" => 0 + }, + "TEST_REQUIRES" => { + "ExtUtils::MakeMaker" => 0, + "File::Spec" => 0, + "PerlIO::encoding" => 0, + "Test::More" => "0.88", + "Time::Local" => 0, + "Try::Tiny" => 0 + }, + "VERSION" => "6.18", + "test" => { + "TESTS" => "t/*.t" + } +); + + +my %FallbackPrereqs = ( + "Carp" => 0, + "Compress::Raw::Zlib" => 0, + "Encode" => "2.21", + "Encode::Locale" => 1, + "Exporter" => "5.57", + "ExtUtils::MakeMaker" => 0, + "File::Spec" => 0, + "HTTP::Date" => 6, + "IO::Compress::Bzip2" => "2.021", + "IO::Compress::Deflate" => 0, + "IO::Compress::Gzip" => 0, + "IO::HTML" => 0, + "IO::Uncompress::Bunzip2" => "2.021", + "IO::Uncompress::Gunzip" => 0, + "IO::Uncompress::Inflate" => 0, + "IO::Uncompress::RawInflate" => 0, + "LWP::MediaTypes" => 6, + "MIME::Base64" => "2.1", + "MIME::QuotedPrint" => 0, + "PerlIO::encoding" => 0, + "Storable" => 0, + "Test::More" => "0.88", + "Time::Local" => 0, + "Try::Tiny" => 0, + "URI" => "1.10", + "base" => 0, + "strict" => 0, + "warnings" => 0 +); + + +unless ( eval { ExtUtils::MakeMaker->VERSION(6.63_03) } ) { + delete $WriteMakefileArgs{TEST_REQUIRES}; + delete $WriteMakefileArgs{BUILD_REQUIRES}; + $WriteMakefileArgs{PREREQ_PM} = \%FallbackPrereqs; +} + +delete $WriteMakefileArgs{CONFIGURE_REQUIRES} + unless eval { ExtUtils::MakeMaker->VERSION(6.52) }; + +WriteMakefile(%WriteMakefileArgs); diff --git a/README.md b/README.md new file mode 100644 index 0000000..ec4a434 --- /dev/null +++ b/README.md @@ -0,0 +1,326 @@ +# NAME + +HTTP::Message - HTTP style message (base class) + +# VERSION + +version 6.18 + +# SYNOPSIS + + use base 'HTTP::Message'; + +# DESCRIPTION + +An `HTTP::Message` object contains some headers and a content body. +The following methods are available: + +- $mess = HTTP::Message->new +- $mess = HTTP::Message->new( $headers ) +- $mess = HTTP::Message->new( $headers, $content ) + + This constructs a new message object. Normally you would want + construct `HTTP::Request` or `HTTP::Response` objects instead. + + The optional $header argument should be a reference to an + `HTTP::Headers` object or a plain array reference of key/value pairs. + If an `HTTP::Headers` object is provided then a copy of it will be + embedded into the constructed message, i.e. it will not be owned and + can be modified afterwards without affecting the message. + + The optional $content argument should be a string of bytes. + +- $mess = HTTP::Message->parse( $str ) + + This constructs a new message object by parsing the given string. + +- $mess->headers + + Returns the embedded `HTTP::Headers` object. + +- $mess->headers\_as\_string +- $mess->headers\_as\_string( $eol ) + + Call the as\_string() method for the headers in the + message. This will be the same as + + $mess->headers->as_string + + but it will make your program a whole character shorter :-) + +- $mess->content +- $mess->content( $bytes ) + + The content() method sets the raw content if an argument is given. If no + argument is given the content is not touched. In either case the + original raw content is returned. + + If the `undef` argument is given, the content is reset to its default value, + which is an empty string. + + Note that the content should be a string of bytes. Strings in perl + can contain characters outside the range of a byte. The `Encode` + module can be used to turn such strings into a string of bytes. + +- $mess->add\_content( $bytes ) + + The add\_content() methods appends more data bytes to the end of the + current content buffer. + +- $mess->add\_content\_utf8( $string ) + + The add\_content\_utf8() method appends the UTF-8 bytes representing the + string to the end of the current content buffer. + +- $mess->content\_ref +- $mess->content\_ref( \\$bytes ) + + The content\_ref() method will return a reference to content buffer string. + It can be more efficient to access the content this way if the content + is huge, and it can even be used for direct manipulation of the content, + for instance: + + ${$res->content_ref} =~ s/\bfoo\b/bar/g; + + This example would modify the content buffer in-place. + + If an argument is passed it will setup the content to reference some + external source. The content() and add\_content() methods + will automatically dereference scalar references passed this way. For + other references content() will return the reference itself and + add\_content() will refuse to do anything. + +- $mess->content\_charset + + This returns the charset used by the content in the message. The + charset is either found as the charset attribute of the + `Content-Type` header or by guessing. + + See [http://www.w3.org/TR/REC-html40/charset.html#spec-char-encoding](http://www.w3.org/TR/REC-html40/charset.html#spec-char-encoding) + for details about how charset is determined. + +- $mess->decoded\_content( %options ) + + Returns the content with any `Content-Encoding` undone and for textual content + the raw content encoded to Perl's Unicode strings. If the `Content-Encoding` + or `charset` of the message is unknown this method will fail by returning + `undef`. + + The following options can be specified. + + - `charset` + + This override the charset parameter for text content. The value + `none` can used to suppress decoding of the charset. + + - `default_charset` + + This override the default charset guessed by content\_charset() or + if that fails "ISO-8859-1". + + - `alt_charset` + + If decoding fails because the charset specified in the Content-Type header + isn't recognized by Perl's Encode module, then try decoding using this charset + instead of failing. The `alt_charset` might be specified as `none` to simply + return the string without any decoding of charset as alternative. + + - `charset_strict` + + Abort decoding if malformed characters is found in the content. By + default you get the substitution character ("\\x{FFFD}") in place of + malformed characters. + + - `raise_error` + + If TRUE then raise an exception if not able to decode content. Reason + might be that the specified `Content-Encoding` or `charset` is not + supported. If this option is FALSE, then decoded\_content() will return + `undef` on errors, but will still set $@. + + - `ref` + + If TRUE then a reference to decoded content is returned. This might + be more efficient in cases where the decoded content is identical to + the raw content as no data copying is required in this case. + +- $mess->decodable +- HTTP::Message::decodable() + + This returns the encoding identifiers that decoded\_content() can + process. In scalar context returns a comma separated string of + identifiers. + + This value is suitable for initializing the `Accept-Encoding` request + header field. + +- $mess->decode + + This method tries to replace the content of the message with the + decoded version and removes the `Content-Encoding` header. Returns + TRUE if successful and FALSE if not. + + If the message does not have a `Content-Encoding` header this method + does nothing and returns TRUE. + + Note that the content of the message is still bytes after this method + has been called and you still need to call decoded\_content() if you + want to process its content as a string. + +- $mess->encode( $encoding, ... ) + + Apply the given encodings to the content of the message. Returns TRUE + if successful. The "identity" (non-)encoding is always supported; other + currently supported encodings, subject to availability of required + additional modules, are "gzip", "deflate", "x-bzip2" and "base64". + + A successful call to this function will set the `Content-Encoding` + header. + + Note that `multipart/*` or `message/*` messages can't be encoded and + this method will croak if you try. + +- $mess->parts +- $mess->parts( @parts ) +- $mess->parts( \\@parts ) + + Messages can be composite, i.e. contain other messages. The composite + messages have a content type of `multipart/*` or `message/*`. This + method give access to the contained messages. + + The argumentless form will return a list of `HTTP::Message` objects. + If the content type of $msg is not `multipart/*` or `message/*` then + this will return the empty list. In scalar context only the first + object is returned. The returned message parts should be regarded as + read-only (future versions of this library might make it possible + to modify the parent by modifying the parts). + + If the content type of $msg is `message/*` then there will only be + one part returned. + + If the content type is `message/http`, then the return value will be + either an `HTTP::Request` or an `HTTP::Response` object. + + If a @parts argument is given, then the content of the message will be + modified. The array reference form is provided so that an empty list + can be provided. The @parts array should contain `HTTP::Message` + objects. The @parts objects are owned by $mess after this call and + should not be modified or made part of other messages. + + When updating the message with this method and the old content type of + $mess is not `multipart/*` or `message/*`, then the content type is + set to `multipart/mixed` and all other content headers are cleared. + + This method will croak if the content type is `message/*` and more + than one part is provided. + +- $mess->add\_part( $part ) + + This will add a part to a message. The $part argument should be + another `HTTP::Message` object. If the previous content type of + $mess is not `multipart/*` then the old content (together with all + content headers) will be made part #1 and the content type made + `multipart/mixed` before the new part is added. The $part object is + owned by $mess after this call and should not be modified or made part + of other messages. + + There is no return value. + +- $mess->clear + + Will clear the headers and set the content to the empty string. There + is no return value + +- $mess->protocol +- $mess->protocol( $proto ) + + Sets the HTTP protocol used for the message. The protocol() is a string + like `HTTP/1.0` or `HTTP/1.1`. + +- $mess->clone + + Returns a copy of the message object. + +- $mess->as\_string +- $mess->as\_string( $eol ) + + Returns the message formatted as a single string. + + The optional $eol parameter specifies the line ending sequence to use. + The default is "\\n". If no $eol is given then as\_string will ensure + that the returned string is newline terminated (even when the message + content is not). No extra newline is appended if an explicit $eol is + passed. + +- $mess->dump( %opt ) + + Returns the message formatted as a string. In void context print the string. + + This differs from `$mess->as_string` in that it escapes the bytes + of the content so that it's safe to print them and it limits how much + content to print. The escapes syntax used is the same as for Perl's + double quoted strings. If there is no content the string "(no + content)" is shown in its place. + + Options to influence the output can be passed as key/value pairs. The + following options are recognized: + + - maxlength => $num + + How much of the content to show. The default is 512. Set this to 0 + for unlimited. + + If the content is longer then the string is chopped at the limit and + the string "...\\n(### more bytes not shown)" appended. + + - no\_content => $str + + Replaces the "(no content)" marker. + + - prefix => $str + + A string that will be prefixed to each line of the dump. + +All methods unknown to `HTTP::Message` itself are delegated to the +`HTTP::Headers` object that is part of every message. This allows +convenient access to these methods. Refer to [HTTP::Headers](https://metacpan.org/pod/HTTP::Headers) for +details of these methods: + + $mess->header( $field => $val ) + $mess->push_header( $field => $val ) + $mess->init_header( $field => $val ) + $mess->remove_header( $field ) + $mess->remove_content_headers + $mess->header_field_names + $mess->scan( \&doit ) + + $mess->date + $mess->expires + $mess->if_modified_since + $mess->if_unmodified_since + $mess->last_modified + $mess->content_type + $mess->content_encoding + $mess->content_length + $mess->content_language + $mess->title + $mess->user_agent + $mess->server + $mess->from + $mess->referer + $mess->www_authenticate + $mess->authorization + $mess->proxy_authorization + $mess->authorization_basic + $mess->proxy_authorization_basic + +# AUTHOR + +Gisle Aas + +# COPYRIGHT AND LICENSE + +This software is copyright (c) 1994-2017 by Gisle Aas. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. diff --git a/cpanfile b/cpanfile new file mode 100644 index 0000000..c3a7748 --- /dev/null +++ b/cpanfile @@ -0,0 +1,51 @@ +requires "Carp" => "0"; +requires "Compress::Raw::Zlib" => "0"; +requires "Encode" => "2.21"; +requires "Encode::Locale" => "1"; +requires "Exporter" => "5.57"; +requires "HTTP::Date" => "6"; +requires "IO::Compress::Bzip2" => "2.021"; +requires "IO::Compress::Deflate" => "0"; +requires "IO::Compress::Gzip" => "0"; +requires "IO::HTML" => "0"; +requires "IO::Uncompress::Bunzip2" => "2.021"; +requires "IO::Uncompress::Gunzip" => "0"; +requires "IO::Uncompress::Inflate" => "0"; +requires "IO::Uncompress::RawInflate" => "0"; +requires "LWP::MediaTypes" => "6"; +requires "MIME::Base64" => "2.1"; +requires "MIME::QuotedPrint" => "0"; +requires "Storable" => "0"; +requires "URI" => "1.10"; +requires "base" => "0"; +requires "perl" => "5.008001"; +requires "strict" => "0"; +requires "warnings" => "0"; + +on 'test' => sub { + requires "ExtUtils::MakeMaker" => "0"; + requires "File::Spec" => "0"; + requires "PerlIO::encoding" => "0"; + requires "Test::More" => "0.88"; + requires "Time::Local" => "0"; + requires "Try::Tiny" => "0"; + requires "perl" => "5.008001"; +}; + +on 'test' => sub { + recommends "CPAN::Meta" => "2.120900"; +}; + +on 'configure' => sub { + requires "ExtUtils::MakeMaker" => "0"; + requires "perl" => "5.006"; +}; + +on 'configure' => sub { + suggests "JSON::PP" => "2.27300"; +}; + +on 'develop' => sub { + requires "Test::CPAN::Changes" => "0.19"; + requires "Test::More" => "0.96"; +}; diff --git a/dist.ini b/dist.ini new file mode 100644 index 0000000..fa2ac8f --- /dev/null +++ b/dist.ini @@ -0,0 +1,31 @@ +name = HTTP-Message +author = Gisle Aas +license = Perl_5 +main_module = lib/HTTP/Message.pm +copyright_holder = Gisle Aas +copyright_year = 1994-2017 + +[MetaResources] +x_IRC = irc://irc.perl.org/#lwp +x_MailingList = mailto:libwww@perl.org + +[Prereqs] +Compress::Raw::Zlib = 0 +Encode = 2.21 +Encode::Locale = 1 +Exporter = 5.57 +HTTP::Date = 6 +IO::Compress::Bzip2 = 2.021 +IO::Uncompress::Bunzip2 = 2.021 +LWP::MediaTypes = 6 +MIME::Base64 = 2.1 +perl = 5.008001 +URI = 1.10 + +[@Author::OALDERS] +-remove = PodCoverageTests +-remove = Prereqs +-remove = Test::Perl::Critic +-remove = Test::PodSpelling +-remove = Test::Synopsis +-remove = Test::TidyAll diff --git a/lib/HTTP/Config.pm b/lib/HTTP/Config.pm new file mode 100644 index 0000000..0742c93 --- /dev/null +++ b/lib/HTTP/Config.pm @@ -0,0 +1,454 @@ +package HTTP::Config; + +use strict; +use warnings; + +our $VERSION = '6.18'; + +use URI; + +sub new { + my $class = shift; + return bless [], $class; +} + +sub entries { + my $self = shift; + @$self; +} + +sub empty { + my $self = shift; + not @$self; +} + +sub add { + if (@_ == 2) { + my $self = shift; + push(@$self, shift); + return; + } + my($self, %spec) = @_; + push(@$self, \%spec); + return; +} + +sub find2 { + my($self, %spec) = @_; + my @found; + my @rest; + ITEM: + for my $item (@$self) { + for my $k (keys %spec) { + no warnings 'uninitialized'; + if (!exists $item->{$k} || $spec{$k} ne $item->{$k}) { + push(@rest, $item); + next ITEM; + } + } + push(@found, $item); + } + return \@found unless wantarray; + return \@found, \@rest; +} + +sub find { + my $self = shift; + my $f = $self->find2(@_); + return @$f if wantarray; + return $f->[0]; +} + +sub remove { + my($self, %spec) = @_; + my($removed, $rest) = $self->find2(%spec); + @$self = @$rest if @$removed; + return @$removed; +} + +my %MATCH = ( + m_scheme => sub { + my($v, $uri) = @_; + return $uri->_scheme eq $v; # URI known to be canonical + }, + m_secure => sub { + my($v, $uri) = @_; + my $secure = $uri->can("secure") ? $uri->secure : $uri->_scheme eq "https"; + return $secure == !!$v; + }, + m_host_port => sub { + my($v, $uri) = @_; + return unless $uri->can("host_port"); + return $uri->host_port eq $v, 7; + }, + m_host => sub { + my($v, $uri) = @_; + return unless $uri->can("host"); + return $uri->host eq $v, 6; + }, + m_port => sub { + my($v, $uri) = @_; + return unless $uri->can("port"); + return $uri->port eq $v; + }, + m_domain => sub { + my($v, $uri) = @_; + return unless $uri->can("host"); + my $h = $uri->host; + $h = "$h.local" unless $h =~ /\./; + $v = ".$v" unless $v =~ /^\./; + return length($v), 5 if substr($h, -length($v)) eq $v; + return 0; + }, + m_path => sub { + my($v, $uri) = @_; + return unless $uri->can("path"); + return $uri->path eq $v, 4; + }, + m_path_prefix => sub { + my($v, $uri) = @_; + return unless $uri->can("path"); + my $path = $uri->path; + my $len = length($v); + return $len, 3 if $path eq $v; + return 0 if length($path) <= $len; + $v .= "/" unless $v =~ m,/\z,,; + return $len, 3 if substr($path, 0, length($v)) eq $v; + return 0; + }, + m_path_match => sub { + my($v, $uri) = @_; + return unless $uri->can("path"); + return $uri->path =~ $v; + }, + m_uri__ => sub { + my($v, $k, $uri) = @_; + return unless $uri->can($k); + return 1 unless defined $v; + return $uri->$k eq $v; + }, + m_method => sub { + my($v, $uri, $request) = @_; + return $request && $request->method eq $v; + }, + m_proxy => sub { + my($v, $uri, $request) = @_; + return $request && ($request->{proxy} || "") eq $v; + }, + m_code => sub { + my($v, $uri, $request, $response) = @_; + $v =~ s/xx\z//; + return unless $response; + return length($v), 2 if substr($response->code, 0, length($v)) eq $v; + }, + m_media_type => sub { # for request too?? + my($v, $uri, $request, $response) = @_; + return unless $response; + return 1, 1 if $v eq "*/*"; + my $ct = $response->content_type; + return 2, 1 if $v =~ s,/\*\z,, && $ct =~ m,^\Q$v\E/,; + return 3, 1 if $v eq "html" && $response->content_is_html; + return 4, 1 if $v eq "xhtml" && $response->content_is_xhtml; + return 10, 1 if $v eq $ct; + return 0; + }, + m_header__ => sub { + my($v, $k, $uri, $request, $response) = @_; + return unless $request; + return 1 if $request->header($k) eq $v; + return 1 if $response && $response->header($k) eq $v; + return 0; + }, + m_response_attr__ => sub { + my($v, $k, $uri, $request, $response) = @_; + return unless $response; + return 1 if !defined($v) && exists $response->{$k}; + return 0 unless exists $response->{$k}; + return 1 if $response->{$k} eq $v; + return 0; + }, +); + +sub matching { + my $self = shift; + if (@_ == 1) { + if ($_[0]->can("request")) { + unshift(@_, $_[0]->request); + unshift(@_, undef) unless defined $_[0]; + } + unshift(@_, $_[0]->uri_canonical) if $_[0] && $_[0]->can("uri_canonical"); + } + my($uri, $request, $response) = @_; + $uri = URI->new($uri) unless ref($uri); + + my @m; + ITEM: + for my $item (@$self) { + my $order; + for my $ikey (keys %$item) { + my $mkey = $ikey; + my $k; + $k = $1 if $mkey =~ s/__(.*)/__/; + if (my $m = $MATCH{$mkey}) { + #print "$ikey $mkey\n"; + my($c, $o); + my @arg = ( + defined($k) ? $k : (), + $uri, $request, $response + ); + my $v = $item->{$ikey}; + $v = [$v] unless ref($v) eq "ARRAY"; + for (@$v) { + ($c, $o) = $m->($_, @arg); + #print " - $_ ==> $c $o\n"; + last if $c; + } + next ITEM unless $c; + $order->[$o || 0] += $c; + } + } + $order->[7] ||= 0; + $item->{_order} = join(".", reverse map sprintf("%03d", $_ || 0), @$order); + push(@m, $item); + } + @m = sort { $b->{_order} cmp $a->{_order} } @m; + delete $_->{_order} for @m; + return @m if wantarray; + return $m[0]; +} + +sub add_item { + my $self = shift; + my $item = shift; + return $self->add(item => $item, @_); +} + +sub remove_items { + my $self = shift; + return map $_->{item}, $self->remove(@_); +} + +sub matching_items { + my $self = shift; + return map $_->{item}, $self->matching(@_); +} + +1; + +=pod + +=encoding UTF-8 + +=head1 NAME + +HTTP::Config - Configuration for request and response objects + +=head1 VERSION + +version 6.18 + +=head1 SYNOPSIS + + use HTTP::Config; + my $c = HTTP::Config->new; + $c->add(m_domain => ".example.com", m_scheme => "http", verbose => 1); + + use HTTP::Request; + my $request = HTTP::Request->new(GET => "http://www.example.com"); + + if (my @m = $c->matching($request)) { + print "Yadayada\n" if $m[0]->{verbose}; + } + +=head1 DESCRIPTION + +An C object is a list of entries that +can be matched against request or request/response pairs. Its +purpose is to hold configuration data that can be looked up given a +request or response object. + +Each configuration entry is a hash. Some keys specify matching to +occur against attributes of request/response objects. Other keys can +be used to hold user data. + +The following methods are provided: + +=over 4 + +=item $conf = HTTP::Config->new + +Constructs a new empty C object and returns it. + +=item $conf->entries + +Returns the list of entries in the configuration object. +In scalar context returns the number of entries. + +=item $conf->empty + +Return true if there are no entries in the configuration object. +This is just a shorthand for C<< not $conf->entries >>. + +=item $conf->add( %matchspec, %other ) + +=item $conf->add( \%entry ) + +Adds a new entry to the configuration. +You can either pass separate key/value pairs or a hash reference. + +=item $conf->remove( %spec ) + +Removes (and returns) the entries that have matches for all the key/value pairs in %spec. +If %spec is empty this will match all entries; so it will empty the configuration object. + +=item $conf->matching( $uri, $request, $response ) + +=item $conf->matching( $uri ) + +=item $conf->matching( $request ) + +=item $conf->matching( $response ) + +Returns the entries that match the given $uri, $request and $response triplet. + +If called with a single $request object then the $uri is obtained by calling its 'uri_canonical' method. +If called with a single $response object, then the request object is obtained by calling its 'request' method; +and then the $uri is obtained as if a single $request was provided. + +The entries are returned with the most specific matches first. +In scalar context returns the most specific match or C in none match. + +=item $conf->add_item( $item, %matchspec ) + +=item $conf->remove_items( %spec ) + +=item $conf->matching_items( $uri, $request, $response ) + +Wrappers that hides the entries themselves. + +=back + +=head2 Matching + +The following keys on a configuration entry specify matching. For all +of these you can provide an array of values instead of a single value. +The entry matches if at least one of the values in the array matches. + +Entries that require match against a response object attribute will never match +unless a response object was provided. + +=over + +=item m_scheme => $scheme + +Matches if the URI uses the specified scheme; e.g. "http". + +=item m_secure => $bool + +If $bool is TRUE; matches if the URI uses a secure scheme. If $bool +is FALSE; matches if the URI does not use a secure scheme. An example +of a secure scheme is "https". + +=item m_host_port => "$hostname:$port" + +Matches if the URI's host_port method return the specified value. + +=item m_host => $hostname + +Matches if the URI's host method returns the specified value. + +=item m_port => $port + +Matches if the URI's port method returns the specified value. + +=item m_domain => ".$domain" + +Matches if the URI's host method return a value that within the given +domain. The hostname "www.example.com" will for instance match the +domain ".com". + +=item m_path => $path + +Matches if the URI's path method returns the specified value. + +=item m_path_prefix => $path + +Matches if the URI's path is the specified path or has the specified +path as prefix. + +=item m_path_match => $Regexp + +Matches if the regular expression matches the URI's path. Eg. qr/\.html$/. + +=item m_method => $method + +Matches if the request method matches the specified value. Eg. "GET" or "POST". + +=item m_code => $digit + +=item m_code => $status_code + +Matches if the response status code matches. If a single digit is +specified; matches for all response status codes beginning with that digit. + +=item m_proxy => $url + +Matches if the request is to be sent to the given Proxy server. + +=item m_media_type => "*/*" + +=item m_media_type => "text/*" + +=item m_media_type => "html" + +=item m_media_type => "xhtml" + +=item m_media_type => "text/html" + +Matches if the response media type matches. + +With a value of "html" matches if $response->content_is_html returns TRUE. +With a value of "xhtml" matches if $response->content_is_xhtml returns TRUE. + +=item m_uri__I<$method> => undef + +Matches if the URI object provides the method. + +=item m_uri__I<$method> => $string + +Matches if the URI's $method method returns the given value. + +=item m_header__I<$field> => $string + +Matches if either the request or the response have a header $field with the given value. + +=item m_response_attr__I<$key> => undef + +=item m_response_attr__I<$key> => $string + +Matches if the response object has that key, or the entry has the given value. + +=back + +=head1 SEE ALSO + +L, L, L + +=head1 AUTHOR + +Gisle Aas + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 1994-2017 by Gisle Aas. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut + +__END__ + + +#ABSTRACT: Configuration for request and response objects + diff --git a/lib/HTTP/Headers.pm b/lib/HTTP/Headers.pm new file mode 100644 index 0000000..1c25c79 --- /dev/null +++ b/lib/HTTP/Headers.pm @@ -0,0 +1,890 @@ +package HTTP::Headers; + +use strict; +use warnings; + +our $VERSION = '6.18'; + +use Carp (); + +# The $TRANSLATE_UNDERSCORE variable controls whether '_' can be used +# as a replacement for '-' in header field names. +our $TRANSLATE_UNDERSCORE = 1 unless defined $TRANSLATE_UNDERSCORE; + +# "Good Practice" order of HTTP message headers: +# - General-Headers +# - Request-Headers +# - Response-Headers +# - Entity-Headers + +my @general_headers = qw( + Cache-Control Connection Date Pragma Trailer Transfer-Encoding Upgrade + Via Warning +); + +my @request_headers = qw( + Accept Accept-Charset Accept-Encoding Accept-Language + Authorization Expect From Host + If-Match If-Modified-Since If-None-Match If-Range If-Unmodified-Since + Max-Forwards Proxy-Authorization Range Referer TE User-Agent +); + +my @response_headers = qw( + Accept-Ranges Age ETag Location Proxy-Authenticate Retry-After Server + Vary WWW-Authenticate +); + +my @entity_headers = qw( + Allow Content-Encoding Content-Language Content-Length Content-Location + Content-MD5 Content-Range Content-Type Expires Last-Modified +); + +my %entity_header = map { lc($_) => 1 } @entity_headers; + +my @header_order = ( + @general_headers, + @request_headers, + @response_headers, + @entity_headers, +); + +# Make alternative representations of @header_order. This is used +# for sorting and case matching. +my %header_order; +my %standard_case; + +{ + my $i = 0; + for (@header_order) { + my $lc = lc $_; + $header_order{$lc} = ++$i; + $standard_case{$lc} = $_; + } +} + + + +sub new +{ + my($class) = shift; + my $self = bless {}, $class; + $self->header(@_) if @_; # set up initial headers + $self; +} + + +sub header +{ + my $self = shift; + Carp::croak('Usage: $h->header($field, ...)') unless @_; + my(@old); + my %seen; + while (@_) { + my $field = shift; + my $op = @_ ? ($seen{lc($field)}++ ? 'PUSH' : 'SET') : 'GET'; + @old = $self->_header($field, shift, $op); + } + return @old if wantarray; + return $old[0] if @old <= 1; + join(", ", @old); +} + +sub clear +{ + my $self = shift; + %$self = (); +} + + +sub push_header +{ + my $self = shift; + return $self->_header(@_, 'PUSH_H') if @_ == 2; + while (@_) { + $self->_header(splice(@_, 0, 2), 'PUSH_H'); + } +} + + +sub init_header +{ + Carp::croak('Usage: $h->init_header($field, $val)') if @_ != 3; + shift->_header(@_, 'INIT'); +} + + +sub remove_header +{ + my($self, @fields) = @_; + my $field; + my @values; + foreach $field (@fields) { + $field =~ tr/_/-/ if $field !~ /^:/ && $TRANSLATE_UNDERSCORE; + my $v = delete $self->{lc $field}; + push(@values, ref($v) eq 'ARRAY' ? @$v : $v) if defined $v; + } + return @values; +} + +sub remove_content_headers +{ + my $self = shift; + unless (defined(wantarray)) { + # fast branch that does not create return object + delete @$self{grep $entity_header{$_} || /^content-/, keys %$self}; + return; + } + + my $c = ref($self)->new; + for my $f (grep $entity_header{$_} || /^content-/, keys %$self) { + $c->{$f} = delete $self->{$f}; + } + if (exists $self->{'::std_case'}) { + $c->{'::std_case'} = $self->{'::std_case'}; + } + $c; +} + + +sub _header +{ + my($self, $field, $val, $op) = @_; + + Carp::croak("Illegal field name '$field'") + if rindex($field, ':') > 1 || !length($field); + + unless ($field =~ /^:/) { + $field =~ tr/_/-/ if $TRANSLATE_UNDERSCORE; + my $old = $field; + $field = lc $field; + unless($standard_case{$field} || $self->{'::std_case'}{$field}) { + # generate a %std_case entry for this field + $old =~ s/\b(\w)/\u$1/g; + $self->{'::std_case'}{$field} = $old; + } + } + + $op ||= defined($val) ? 'SET' : 'GET'; + if ($op eq 'PUSH_H') { + # Like PUSH but where we don't care about the return value + if (exists $self->{$field}) { + my $h = $self->{$field}; + if (ref($h) eq 'ARRAY') { + push(@$h, ref($val) eq "ARRAY" ? @$val : $val); + } + else { + $self->{$field} = [$h, ref($val) eq "ARRAY" ? @$val : $val] + } + return; + } + $self->{$field} = $val; + return; + } + + my $h = $self->{$field}; + my @old = ref($h) eq 'ARRAY' ? @$h : (defined($h) ? ($h) : ()); + + unless ($op eq 'GET' || ($op eq 'INIT' && @old)) { + if (defined($val)) { + my @new = ($op eq 'PUSH') ? @old : (); + if (ref($val) ne 'ARRAY') { + push(@new, $val); + } + else { + push(@new, @$val); + } + $self->{$field} = @new > 1 ? \@new : $new[0]; + } + elsif ($op ne 'PUSH') { + delete $self->{$field}; + } + } + @old; +} + + +sub _sorted_field_names +{ + my $self = shift; + return [ sort { + ($header_order{$a} || 999) <=> ($header_order{$b} || 999) || + $a cmp $b + } grep !/^::/, keys %$self ]; +} + + +sub header_field_names { + my $self = shift; + return map $standard_case{$_} || $self->{'::std_case'}{$_} || $_, @{ $self->_sorted_field_names }, + if wantarray; + return grep !/^::/, keys %$self; +} + + +sub scan +{ + my($self, $sub) = @_; + my $key; + for $key (@{ $self->_sorted_field_names }) { + my $vals = $self->{$key}; + if (ref($vals) eq 'ARRAY') { + my $val; + for $val (@$vals) { + $sub->($standard_case{$key} || $self->{'::std_case'}{$key} || $key, $val); + } + } + else { + $sub->($standard_case{$key} || $self->{'::std_case'}{$key} || $key, $vals); + } + } +} + +sub flatten { + my($self)=@_; + + ( + map { + my $k = $_; + map { + ( $k => $_ ) + } $self->header($_); + } $self->header_field_names + ); +} + +sub as_string +{ + my($self, $endl) = @_; + $endl = "\n" unless defined $endl; + + my @result = (); + for my $key (@{ $self->_sorted_field_names }) { + next if index($key, '_') == 0; + my $vals = $self->{$key}; + if ( ref($vals) eq 'ARRAY' ) { + for my $val (@$vals) { + $val = '' if not defined $val; + my $field = $standard_case{$key} || $self->{'::std_case'}{$key} || $key; + $field =~ s/^://; + if ( index($val, "\n") >= 0 ) { + $val = _process_newline($val, $endl); + } + push @result, $field . ': ' . $val; + } + } + else { + $vals = '' if not defined $vals; + my $field = $standard_case{$key} || $self->{'::std_case'}{$key} || $key; + $field =~ s/^://; + if ( index($vals, "\n") >= 0 ) { + $vals = _process_newline($vals, $endl); + } + push @result, $field . ': ' . $vals; + } + } + + join($endl, @result, ''); +} + +sub _process_newline { + local $_ = shift; + my $endl = shift; + # must handle header values with embedded newlines with care + s/\s+$//; # trailing newlines and space must go + s/\n(\x0d?\n)+/\n/g; # no empty lines + s/\n([^\040\t])/\n $1/g; # initial space for continuation + s/\n/$endl/g; # substitute with requested line ending + $_; +} + + + +if (eval { require Storable; 1 }) { + *clone = \&Storable::dclone; +} else { + *clone = sub { + my $self = shift; + my $clone = HTTP::Headers->new; + $self->scan(sub { $clone->push_header(@_);} ); + $clone; + }; +} + + +sub _date_header +{ + require HTTP::Date; + my($self, $header, $time) = @_; + my($old) = $self->_header($header); + if (defined $time) { + $self->_header($header, HTTP::Date::time2str($time)); + } + $old =~ s/;.*// if defined($old); + HTTP::Date::str2time($old); +} + + +sub date { shift->_date_header('Date', @_); } +sub expires { shift->_date_header('Expires', @_); } +sub if_modified_since { shift->_date_header('If-Modified-Since', @_); } +sub if_unmodified_since { shift->_date_header('If-Unmodified-Since', @_); } +sub last_modified { shift->_date_header('Last-Modified', @_); } + +# This is used as a private LWP extension. The Client-Date header is +# added as a timestamp to a response when it has been received. +sub client_date { shift->_date_header('Client-Date', @_); } + +# The retry_after field is dual format (can also be a expressed as +# number of seconds from now), so we don't provide an easy way to +# access it until we have know how both these interfaces can be +# addressed. One possibility is to return a negative value for +# relative seconds and a positive value for epoch based time values. +#sub retry_after { shift->_date_header('Retry-After', @_); } + +sub content_type { + my $self = shift; + my $ct = $self->{'content-type'}; + $self->{'content-type'} = shift if @_; + $ct = $ct->[0] if ref($ct) eq 'ARRAY'; + return '' unless defined($ct) && length($ct); + my @ct = split(/;\s*/, $ct, 2); + for ($ct[0]) { + s/\s+//g; + $_ = lc($_); + } + wantarray ? @ct : $ct[0]; +} + +sub content_type_charset { + my $self = shift; + require HTTP::Headers::Util; + my $h = $self->{'content-type'}; + $h = $h->[0] if ref($h); + $h = "" unless defined $h; + my @v = HTTP::Headers::Util::split_header_words($h); + if (@v) { + my($ct, undef, %ct_param) = @{$v[0]}; + my $charset = $ct_param{charset}; + if ($ct) { + $ct = lc($ct); + $ct =~ s/\s+//; + } + if ($charset) { + $charset = uc($charset); + $charset =~ s/^\s+//; $charset =~ s/\s+\z//; + undef($charset) if $charset eq ""; + } + return $ct, $charset if wantarray; + return $charset; + } + return undef, undef if wantarray; + return undef; +} + +sub content_is_text { + my $self = shift; + return $self->content_type =~ m,^text/,; +} + +sub content_is_html { + my $self = shift; + return $self->content_type eq 'text/html' || $self->content_is_xhtml; +} + +sub content_is_xhtml { + my $ct = shift->content_type; + return $ct eq "application/xhtml+xml" || + $ct eq "application/vnd.wap.xhtml+xml"; +} + +sub content_is_xml { + my $ct = shift->content_type; + return 1 if $ct eq "text/xml"; + return 1 if $ct eq "application/xml"; + return 1 if $ct =~ /\+xml$/; + return 0; +} + +sub referer { + my $self = shift; + if (@_ && $_[0] =~ /#/) { + # Strip fragment per RFC 2616, section 14.36. + my $uri = shift; + if (ref($uri)) { + $uri = $uri->clone; + $uri->fragment(undef); + } + else { + $uri =~ s/\#.*//; + } + unshift @_, $uri; + } + ($self->_header('Referer', @_))[0]; +} +*referrer = \&referer; # on tchrist's request + +sub title { (shift->_header('Title', @_))[0] } +sub content_encoding { (shift->_header('Content-Encoding', @_))[0] } +sub content_language { (shift->_header('Content-Language', @_))[0] } +sub content_length { (shift->_header('Content-Length', @_))[0] } + +sub user_agent { (shift->_header('User-Agent', @_))[0] } +sub server { (shift->_header('Server', @_))[0] } + +sub from { (shift->_header('From', @_))[0] } +sub warning { (shift->_header('Warning', @_))[0] } + +sub www_authenticate { (shift->_header('WWW-Authenticate', @_))[0] } +sub authorization { (shift->_header('Authorization', @_))[0] } + +sub proxy_authenticate { (shift->_header('Proxy-Authenticate', @_))[0] } +sub proxy_authorization { (shift->_header('Proxy-Authorization', @_))[0] } + +sub authorization_basic { shift->_basic_auth("Authorization", @_) } +sub proxy_authorization_basic { shift->_basic_auth("Proxy-Authorization", @_) } + +sub _basic_auth { + require MIME::Base64; + my($self, $h, $user, $passwd) = @_; + my($old) = $self->_header($h); + if (defined $user) { + Carp::croak("Basic authorization user name can't contain ':'") + if $user =~ /:/; + $passwd = '' unless defined $passwd; + $self->_header($h => 'Basic ' . + MIME::Base64::encode("$user:$passwd", '')); + } + if (defined $old && $old =~ s/^\s*Basic\s+//) { + my $val = MIME::Base64::decode($old); + return $val unless wantarray; + return split(/:/, $val, 2); + } + return; +} + + +1; + +=pod + +=encoding UTF-8 + +=head1 NAME + +HTTP::Headers - Class encapsulating HTTP Message headers + +=head1 VERSION + +version 6.18 + +=head1 SYNOPSIS + + require HTTP::Headers; + $h = HTTP::Headers->new; + + $h->header('Content-Type' => 'text/plain'); # set + $ct = $h->header('Content-Type'); # get + $h->remove_header('Content-Type'); # delete + +=head1 DESCRIPTION + +The C class encapsulates HTTP-style message headers. +The headers consist of attribute-value pairs also called fields, which +may be repeated, and which are printed in a particular order. The +field names are cases insensitive. + +Instances of this class are usually created as member variables of the +C and C classes, internal to the +library. + +The following methods are available: + +=over 4 + +=item $h = HTTP::Headers->new + +Constructs a new C object. You might pass some initial +attribute-value pairs as parameters to the constructor. I: + + $h = HTTP::Headers->new( + Date => 'Thu, 03 Feb 1994 00:00:00 GMT', + Content_Type => 'text/html; version=3.2', + Content_Base => 'http://www.perl.org/'); + +The constructor arguments are passed to the C
method which is +described below. + +=item $h->clone + +Returns a copy of this C object. + +=item $h->header( $field ) + +=item $h->header( $field => $value ) + +=item $h->header( $f1 => $v1, $f2 => $v2, ... ) + +Get or set the value of one or more header fields. The header field +name ($field) is not case sensitive. To make the life easier for perl +users who wants to avoid quoting before the => operator, you can use +'_' as a replacement for '-' in header names. + +The header() method accepts multiple ($field => $value) pairs, which +means that you can update several fields with a single invocation. + +The $value argument may be a plain string or a reference to an array +of strings for a multi-valued field. If the $value is provided as +C then the field is removed. If the $value is not given, then +that header field will remain unchanged. + +The old value (or values) of the last of the header fields is returned. +If no such field exists C will be returned. + +A multi-valued field will be returned as separate values in list +context and will be concatenated with ", " as separator in scalar +context. The HTTP spec (RFC 2616) promises that joining multiple +values in this way will not change the semantic of a header field, but +in practice there are cases like old-style Netscape cookies (see +L) where "," is used as part of the syntax of a single +field value. + +Examples: + + $header->header(MIME_Version => '1.0', + User_Agent => 'My-Web-Client/0.01'); + $header->header(Accept => "text/html, text/plain, image/*"); + $header->header(Accept => [qw(text/html text/plain image/*)]); + @accepts = $header->header('Accept'); # get multiple values + $accepts = $header->header('Accept'); # get values as a single string + +=item $h->push_header( $field => $value ) + +=item $h->push_header( $f1 => $v1, $f2 => $v2, ... ) + +Add a new field value for the specified header field. Previous values +for the same field are retained. + +As for the header() method, the field name ($field) is not case +sensitive and '_' can be used as a replacement for '-'. + +The $value argument may be a scalar or a reference to a list of +scalars. + + $header->push_header(Accept => 'image/jpeg'); + $header->push_header(Accept => [map "image/$_", qw(gif png tiff)]); + +=item $h->init_header( $field => $value ) + +Set the specified header to the given value, but only if no previous +value for that field is set. + +The header field name ($field) is not case sensitive and '_' +can be used as a replacement for '-'. + +The $value argument may be a scalar or a reference to a list of +scalars. + +=item $h->remove_header( $field, ... ) + +This function removes the header fields with the specified names. + +The header field names ($field) are not case sensitive and '_' +can be used as a replacement for '-'. + +The return value is the values of the fields removed. In scalar +context the number of fields removed is returned. + +Note that if you pass in multiple field names then it is generally not +possible to tell which of the returned values belonged to which field. + +=item $h->remove_content_headers + +This will remove all the header fields used to describe the content of +a message. All header field names prefixed with C fall +into this category, as well as C, C and +C. RFC 2616 denotes these fields as I. + +The return value is a new C object that contains the +removed headers only. + +=item $h->clear + +This will remove all header fields. + +=item $h->header_field_names + +Returns the list of distinct names for the fields present in the +header. The field names have case as suggested by HTTP spec, and the +names are returned in the recommended "Good Practice" order. + +In scalar context return the number of distinct field names. + +=item $h->scan( \&process_header_field ) + +Apply a subroutine to each header field in turn. The callback routine +is called with two parameters; the name of the field and a single +value (a string). If a header field is multi-valued, then the +routine is called once for each value. The field name passed to the +callback routine has case as suggested by HTTP spec, and the headers +will be visited in the recommended "Good Practice" order. + +Any return values of the callback routine are ignored. The loop can +be broken by raising an exception (C), but the caller of scan() +would have to trap the exception itself. + +=item $h->flatten() + +Returns the list of pairs of keys and values. + +=item $h->as_string + +=item $h->as_string( $eol ) + +Return the header fields as a formatted MIME header. Since it +internally uses the C method to build the string, the result +will use case as suggested by HTTP spec, and it will follow +recommended "Good Practice" of ordering the header fields. Long header +values are not folded. + +The optional $eol parameter specifies the line ending sequence to +use. The default is "\n". Embedded "\n" characters in header field +values will be substituted with this line ending sequence. + +=back + +=head1 CONVENIENCE METHODS + +The most frequently used headers can also be accessed through the +following convenience methods. Most of these methods can both be used to read +and to set the value of a header. The header value is set if you pass +an argument to the method. The old header value is always returned. +If the given header did not exist then C is returned. + +Methods that deal with dates/times always convert their value to system +time (seconds since Jan 1, 1970) and they also expect this kind of +value when the header value is set. + +=over 4 + +=item $h->date + +This header represents the date and time at which the message was +originated. I: + + $h->date(time); # set current date + +=item $h->expires + +This header gives the date and time after which the entity should be +considered stale. + +=item $h->if_modified_since + +=item $h->if_unmodified_since + +These header fields are used to make a request conditional. If the requested +resource has (or has not) been modified since the time specified in this field, +then the server will return a C<304 Not Modified> response instead of +the document itself. + +=item $h->last_modified + +This header indicates the date and time at which the resource was last +modified. I: + + # check if document is more than 1 hour old + if (my $last_mod = $h->last_modified) { + if ($last_mod < time - 60*60) { + ... + } + } + +=item $h->content_type + +The Content-Type header field indicates the media type of the message +content. I: + + $h->content_type('text/html'); + +The value returned will be converted to lower case, and potential +parameters will be chopped off and returned as a separate value if in +an array context. If there is no such header field, then the empty +string is returned. This makes it safe to do the following: + + if ($h->content_type eq 'text/html') { + # we enter this place even if the real header value happens to + # be 'TEXT/HTML; version=3.0' + ... + } + +=item $h->content_type_charset + +Returns the upper-cased charset specified in the Content-Type header. In list +context return the lower-cased bare content type followed by the upper-cased +charset. Both values will be C if not specified in the header. + +=item $h->content_is_text + +Returns TRUE if the Content-Type header field indicate that the +content is textual. + +=item $h->content_is_html + +Returns TRUE if the Content-Type header field indicate that the +content is some kind of HTML (including XHTML). This method can't be +used to set Content-Type. + +=item $h->content_is_xhtml + +Returns TRUE if the Content-Type header field indicate that the +content is XHTML. This method can't be used to set Content-Type. + +=item $h->content_is_xml + +Returns TRUE if the Content-Type header field indicate that the +content is XML. This method can't be used to set Content-Type. + +=item $h->content_encoding + +The Content-Encoding header field is used as a modifier to the +media type. When present, its value indicates what additional +encoding mechanism has been applied to the resource. + +=item $h->content_length + +A decimal number indicating the size in bytes of the message content. + +=item $h->content_language + +The natural language(s) of the intended audience for the message +content. The value is one or more language tags as defined by RFC +1766. Eg. "no" for some kind of Norwegian and "en-US" for English the +way it is written in the US. + +=item $h->title + +The title of the document. In libwww-perl this header will be +initialized automatically from the ETITLE>...E/TITLE> element +of HTML documents. I + +=item $h->user_agent + +This header field is used in request messages and contains information +about the user agent originating the request. I: + + $h->user_agent('Mozilla/5.0 (compatible; MSIE 7.0; Windows NT 6.0)'); + +=item $h->server + +The server header field contains information about the software being +used by the originating server program handling the request. + +=item $h->from + +This header should contain an Internet e-mail address for the human +user who controls the requesting user agent. The address should be +machine-usable, as defined by RFC822. E.g.: + + $h->from('King Kong '); + +I + +=item $h->referer + +Used to specify the address (URI) of the document from which the +requested resource address was obtained. + +The "Free On-line Dictionary of Computing" as this to say about the +word I: + + A misspelling of "referrer" which + somehow made it into the {HTTP} standard. A given {web + page}'s referer (sic) is the {URL} of whatever web page + contains the link that the user followed to the current + page. Most browsers pass this information as part of a + request. + + (1998-10-19) + +By popular demand C exists as an alias for this method so you +can avoid this misspelling in your programs and still send the right +thing on the wire. + +When setting the referrer, this method removes the fragment from the +given URI if it is present, as mandated by RFC2616. Note that +the removal does I happen automatically if using the header(), +push_header() or init_header() methods to set the referrer. + +=item $h->www_authenticate + +This header must be included as part of a C<401 Unauthorized> response. +The field value consist of a challenge that indicates the +authentication scheme and parameters applicable to the requested URI. + +=item $h->proxy_authenticate + +This header must be included in a C<407 Proxy Authentication Required> +response. + +=item $h->authorization + +=item $h->proxy_authorization + +A user agent that wishes to authenticate itself with a server or a +proxy, may do so by including these headers. + +=item $h->authorization_basic + +This method is used to get or set an authorization header that use the +"Basic Authentication Scheme". In array context it will return two +values; the user name and the password. In scalar context it will +return I<"uname:password"> as a single string value. + +When used to set the header value, it expects two arguments. I: + + $h->authorization_basic($uname, $password); + +The method will croak if the $uname contains a colon ':'. + +=item $h->proxy_authorization_basic + +Same as authorization_basic() but will set the "Proxy-Authorization" +header instead. + +=back + +=head1 NON-CANONICALIZED FIELD NAMES + +The header field name spelling is normally canonicalized including the +'_' to '-' translation. There are some application where this is not +appropriate. Prefixing field names with ':' allow you to force a +specific spelling. For example if you really want a header field name +to show up as C instead of "Foo-Bar", you might set it like +this: + + $h->header(":foo_bar" => 1); + +These field names are returned with the ':' intact for +$h->header_field_names and the $h->scan callback, but the colons do +not show in $h->as_string. + +=head1 AUTHOR + +Gisle Aas + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 1994-2017 by Gisle Aas. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut + +__END__ + + +#ABSTRACT: Class encapsulating HTTP Message headers + diff --git a/lib/HTTP/Headers/Auth.pm b/lib/HTTP/Headers/Auth.pm new file mode 100644 index 0000000..462cf62 --- /dev/null +++ b/lib/HTTP/Headers/Auth.pm @@ -0,0 +1,127 @@ +package HTTP::Headers::Auth; + +use strict; +use warnings; + +our $VERSION = '6.18'; + +use HTTP::Headers; + +package + HTTP::Headers; + +BEGIN { + # we provide a new (and better) implementations below + undef(&www_authenticate); + undef(&proxy_authenticate); +} + +require HTTP::Headers::Util; + +sub _parse_authenticate +{ + my @ret; + for (HTTP::Headers::Util::split_header_words(@_)) { + if (!defined($_->[1])) { + # this is a new auth scheme + push(@ret, shift(@$_) => {}); + shift @$_; + } + if (@ret) { + # this a new parameter pair for the last auth scheme + while (@$_) { + my $k = shift @$_; + my $v = shift @$_; + $ret[-1]{$k} = $v; + } + } + else { + # something wrong, parameter pair without any scheme seen + # IGNORE + } + } + @ret; +} + +sub _authenticate +{ + my $self = shift; + my $header = shift; + my @old = $self->_header($header); + if (@_) { + $self->remove_header($header); + my @new = @_; + while (@new) { + my $a_scheme = shift(@new); + if ($a_scheme =~ /\s/) { + # assume complete valid value, pass it through + $self->push_header($header, $a_scheme); + } + else { + my @param; + if (@new) { + my $p = $new[0]; + if (ref($p) eq "ARRAY") { + @param = @$p; + shift(@new); + } + elsif (ref($p) eq "HASH") { + @param = %$p; + shift(@new); + } + } + my $val = ucfirst(lc($a_scheme)); + if (@param) { + my $sep = " "; + while (@param) { + my $k = shift @param; + my $v = shift @param; + if ($v =~ /[^0-9a-zA-Z]/ || lc($k) eq "realm") { + # must quote the value + $v =~ s,([\\\"]),\\$1,g; + $v = qq("$v"); + } + $val .= "$sep$k=$v"; + $sep = ", "; + } + } + $self->push_header($header, $val); + } + } + } + return unless defined wantarray; + wantarray ? _parse_authenticate(@old) : join(", ", @old); +} + + +sub www_authenticate { shift->_authenticate("WWW-Authenticate", @_) } +sub proxy_authenticate { shift->_authenticate("Proxy-Authenticate", @_) } + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +HTTP::Headers::Auth + +=head1 VERSION + +version 6.18 + +=head1 AUTHOR + +Gisle Aas + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 1994-2017 by Gisle Aas. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/HTTP/Headers/ETag.pm b/lib/HTTP/Headers/ETag.pm new file mode 100644 index 0000000..02d6249 --- /dev/null +++ b/lib/HTTP/Headers/ETag.pm @@ -0,0 +1,123 @@ +package HTTP::Headers::ETag; + +use strict; +use warnings; + +our $VERSION = '6.18'; + +require HTTP::Date; + +require HTTP::Headers; +package + HTTP::Headers; + +sub _etags +{ + my $self = shift; + my $header = shift; + my @old = _split_etag_list($self->_header($header)); + if (@_) { + $self->_header($header => join(", ", _split_etag_list(@_))); + } + wantarray ? @old : join(", ", @old); +} + +sub etag { shift->_etags("ETag", @_); } +sub if_match { shift->_etags("If-Match", @_); } +sub if_none_match { shift->_etags("If-None-Match", @_); } + +sub if_range { + # Either a date or an entity-tag + my $self = shift; + my @old = $self->_header("If-Range"); + if (@_) { + my $new = shift; + if (!defined $new) { + $self->remove_header("If-Range"); + } + elsif ($new =~ /^\d+$/) { + $self->_date_header("If-Range", $new); + } + else { + $self->_etags("If-Range", $new); + } + } + return unless defined(wantarray); + for (@old) { + my $t = HTTP::Date::str2time($_); + $_ = $t if $t; + } + wantarray ? @old : join(", ", @old); +} + + +# Split a list of entity tag values. The return value is a list +# consisting of one element per entity tag. Suitable for parsing +# headers like C, C. You might even want to +# use it on C and C entity tag values, because it will +# normalize them to the common form. +# +# entity-tag = [ weak ] opaque-tag +# weak = "W/" +# opaque-tag = quoted-string + + +sub _split_etag_list +{ + my(@val) = @_; + my @res; + for (@val) { + while (length) { + my $weak = ""; + $weak = "W/" if s,^\s*[wW]/,,; + my $etag = ""; + if (s/^\s*(\"[^\"\\]*(?:\\.[^\"\\]*)*\")//) { + push(@res, "$weak$1"); + } + elsif (s/^\s*,//) { + push(@res, qq(W/"")) if $weak; + } + elsif (s/^\s*([^,\s]+)//) { + $etag = $1; + $etag =~ s/([\"\\])/\\$1/g; + push(@res, qq($weak"$etag")); + } + elsif (s/^\s+// || !length) { + push(@res, qq(W/"")) if $weak; + } + else { + die "This should not happen: '$_'"; + } + } + } + @res; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +HTTP::Headers::ETag + +=head1 VERSION + +version 6.18 + +=head1 AUTHOR + +Gisle Aas + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 1994-2017 by Gisle Aas. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/HTTP/Headers/Util.pm b/lib/HTTP/Headers/Util.pm new file mode 100644 index 0000000..dc07eb3 --- /dev/null +++ b/lib/HTTP/Headers/Util.pm @@ -0,0 +1,213 @@ +package HTTP::Headers::Util; + +use strict; +use warnings; + +our $VERSION = '6.18'; + +use base 'Exporter'; + +our @EXPORT_OK=qw(split_header_words _split_header_words join_header_words); + + +sub split_header_words { + my @res = &_split_header_words; + for my $arr (@res) { + for (my $i = @$arr - 2; $i >= 0; $i -= 2) { + $arr->[$i] = lc($arr->[$i]); + } + } + return @res; +} + +sub _split_header_words +{ + my(@val) = @_; + my @res; + for (@val) { + my @cur; + while (length) { + if (s/^\s*(=*[^\s=;,]+)//) { # 'token' or parameter 'attribute' + push(@cur, $1); + # a quoted value + if (s/^\s*=\s*\"([^\"\\]*(?:\\.[^\"\\]*)*)\"//) { + my $val = $1; + $val =~ s/\\(.)/$1/g; + push(@cur, $val); + # some unquoted value + } + elsif (s/^\s*=\s*([^;,\s]*)//) { + my $val = $1; + $val =~ s/\s+$//; + push(@cur, $val); + # no value, a lone token + } + else { + push(@cur, undef); + } + } + elsif (s/^\s*,//) { + push(@res, [@cur]) if @cur; + @cur = (); + } + elsif (s/^\s*;// || s/^\s+//) { + # continue + } + else { + die "This should not happen: '$_'"; + } + } + push(@res, \@cur) if @cur; + } + @res; +} + + +sub join_header_words +{ + @_ = ([@_]) if @_ && !ref($_[0]); + my @res; + for (@_) { + my @cur = @$_; + my @attr; + while (@cur) { + my $k = shift @cur; + my $v = shift @cur; + if (defined $v) { + if ($v =~ /[\x00-\x20()<>@,;:\\\"\/\[\]?={}\x7F-\xFF]/ || !length($v)) { + $v =~ s/([\"\\])/\\$1/g; # escape " and \ + $k .= qq(="$v"); + } + else { + # token + $k .= "=$v"; + } + } + push(@attr, $k); + } + push(@res, join("; ", @attr)) if @attr; + } + join(", ", @res); +} + + +1; + +=pod + +=encoding UTF-8 + +=head1 NAME + +HTTP::Headers::Util - Header value parsing utility functions + +=head1 VERSION + +version 6.18 + +=head1 SYNOPSIS + + use HTTP::Headers::Util qw(split_header_words); + @values = split_header_words($h->header("Content-Type")); + +=head1 DESCRIPTION + +This module provides a few functions that helps parsing and +construction of valid HTTP header values. None of the functions are +exported by default. + +The following functions are available: + +=over 4 + +=item split_header_words( @header_values ) + +This function will parse the header values given as argument into a +list of anonymous arrays containing key/value pairs. The function +knows how to deal with ",", ";" and "=" as well as quoted values after +"=". A list of space separated tokens are parsed as if they were +separated by ";". + +If the @header_values passed as argument contains multiple values, +then they are treated as if they were a single value separated by +comma ",". + +This means that this function is useful for parsing header fields that +follow this syntax (BNF as from the HTTP/1.1 specification, but we relax +the requirement for tokens). + + headers = #header + header = (token | parameter) *( [";"] (token | parameter)) + + token = 1* + separators = "(" | ")" | "<" | ">" | "@" + | "," | ";" | ":" | "\" | <"> + | "/" | "[" | "]" | "?" | "=" + | "{" | "}" | SP | HT + + quoted-string = ( <"> *(qdtext | quoted-pair ) <"> ) + qdtext = > + quoted-pair = "\" CHAR + + parameter = attribute "=" value + attribute = token + value = token | quoted-string + +Each I
is represented by an anonymous array of key/value +pairs. The keys will be all be forced to lower case. +The value for a simple token (not part of a parameter) is C. +Syntactically incorrect headers will not necessarily be parsed as you +would want. + +This is easier to describe with some examples: + + split_header_words('foo="bar"; port="80,81"; DISCARD, BAR=baz'); + split_header_words('text/html; charset="iso-8859-1"'); + split_header_words('Basic realm="\\"foo\\\\bar\\""'); + +will return + + [foo=>'bar', port=>'80,81', discard=> undef], [bar=>'baz' ] + ['text/html' => undef, charset => 'iso-8859-1'] + [basic => undef, realm => "\"foo\\bar\""] + +If you don't want the function to convert tokens and attribute keys to +lower case you can call it as C<_split_header_words> instead (with a +leading underscore). + +=item join_header_words( @arrays ) + +This will do the opposite of the conversion done by split_header_words(). +It takes a list of anonymous arrays as arguments (or a list of +key/value pairs) and produces a single header value. Attribute values +are quoted if needed. + +Example: + + join_header_words(["text/plain" => undef, charset => "iso-8859/1"]); + join_header_words("text/plain" => undef, charset => "iso-8859/1"); + +will both return the string: + + text/plain; charset="iso-8859/1" + +=back + +=head1 AUTHOR + +Gisle Aas + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 1994-2017 by Gisle Aas. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut + +__END__ + + +#ABSTRACT: Header value parsing utility functions + diff --git a/lib/HTTP/Message.pm b/lib/HTTP/Message.pm new file mode 100644 index 0000000..078209e --- /dev/null +++ b/lib/HTTP/Message.pm @@ -0,0 +1,1133 @@ +package HTTP::Message; + +use strict; +use warnings; + +our $VERSION = '6.18'; + +require HTTP::Headers; +require Carp; + +my $CRLF = "\015\012"; # "\r\n" is not portable +unless ($HTTP::URI_CLASS) { + if ($ENV{PERL_HTTP_URI_CLASS} + && $ENV{PERL_HTTP_URI_CLASS} =~ /^([\w:]+)$/) { + $HTTP::URI_CLASS = $1; + } else { + $HTTP::URI_CLASS = "URI"; + } +} +eval "require $HTTP::URI_CLASS"; die $@ if $@; + +*_utf8_downgrade = defined(&utf8::downgrade) ? + sub { + utf8::downgrade($_[0], 1) or + Carp::croak("HTTP::Message content must be bytes") + } + : + sub { + }; + +sub new +{ + my($class, $header, $content) = @_; + if (defined $header) { + Carp::croak("Bad header argument") unless ref $header; + if (ref($header) eq "ARRAY") { + $header = HTTP::Headers->new(@$header); + } + else { + $header = $header->clone; + } + } + else { + $header = HTTP::Headers->new; + } + if (defined $content) { + _utf8_downgrade($content); + } + else { + $content = ''; + } + + bless { + '_headers' => $header, + '_content' => $content, + }, $class; +} + + +sub parse +{ + my($class, $str) = @_; + + my @hdr; + while (1) { + if ($str =~ s/^([^\s:]+)[ \t]*: ?(.*)\n?//) { + push(@hdr, $1, $2); + $hdr[-1] =~ s/\r\z//; + } + elsif (@hdr && $str =~ s/^([ \t].*)\n?//) { + $hdr[-1] .= "\n$1"; + $hdr[-1] =~ s/\r\z//; + } + else { + $str =~ s/^\r?\n//; + last; + } + } + local $HTTP::Headers::TRANSLATE_UNDERSCORE; + new($class, \@hdr, $str); +} + + +sub clone +{ + my $self = shift; + my $clone = HTTP::Message->new($self->headers, + $self->content); + $clone->protocol($self->protocol); + $clone; +} + + +sub clear { + my $self = shift; + $self->{_headers}->clear; + $self->content(""); + delete $self->{_parts}; + return; +} + + +sub protocol { + shift->_elem('_protocol', @_); +} + +sub headers { + my $self = shift; + + # recalculation of _content might change headers, so we + # need to force it now + $self->_content unless exists $self->{_content}; + + $self->{_headers}; +} + +sub headers_as_string { + shift->headers->as_string(@_); +} + + +sub content { + + my $self = $_[0]; + if (defined(wantarray)) { + $self->_content unless exists $self->{_content}; + my $old = $self->{_content}; + $old = $$old if ref($old) eq "SCALAR"; + &_set_content if @_ > 1; + return $old; + } + + if (@_ > 1) { + &_set_content; + } + else { + Carp::carp("Useless content call in void context") if $^W; + } +} + + +sub _set_content { + my $self = $_[0]; + _utf8_downgrade($_[1]); + if (!ref($_[1]) && ref($self->{_content}) eq "SCALAR") { + ${$self->{_content}} = defined( $_[1] ) ? $_[1] : ''; + } + else { + die "Can't set content to be a scalar reference" if ref($_[1]) eq "SCALAR"; + $self->{_content} = defined( $_[1] ) ? $_[1] : ''; + delete $self->{_content_ref}; + } + delete $self->{_parts} unless $_[2]; +} + + +sub add_content +{ + my $self = shift; + $self->_content unless exists $self->{_content}; + my $chunkref = \$_[0]; + $chunkref = $$chunkref if ref($$chunkref); # legacy + + _utf8_downgrade($$chunkref); + + my $ref = ref($self->{_content}); + if (!$ref) { + $self->{_content} .= $$chunkref; + } + elsif ($ref eq "SCALAR") { + ${$self->{_content}} .= $$chunkref; + } + else { + Carp::croak("Can't append to $ref content"); + } + delete $self->{_parts}; +} + +sub add_content_utf8 { + my($self, $buf) = @_; + utf8::upgrade($buf); + utf8::encode($buf); + $self->add_content($buf); +} + +sub content_ref +{ + my $self = shift; + $self->_content unless exists $self->{_content}; + delete $self->{_parts}; + my $old = \$self->{_content}; + my $old_cref = $self->{_content_ref}; + if (@_) { + my $new = shift; + Carp::croak("Setting content_ref to a non-ref") unless ref($new); + delete $self->{_content}; # avoid modifying $$old + $self->{_content} = $new; + $self->{_content_ref}++; + } + $old = $$old if $old_cref; + return $old; +} + + +sub content_charset +{ + my $self = shift; + if (my $charset = $self->content_type_charset) { + return $charset; + } + + # time to start guessing + my $cref = $self->decoded_content(ref => 1, charset => "none"); + + # Unicode BOM + for ($$cref) { + return "UTF-8" if /^\xEF\xBB\xBF/; + return "UTF-32LE" if /^\xFF\xFE\x00\x00/; + return "UTF-32BE" if /^\x00\x00\xFE\xFF/; + return "UTF-16LE" if /^\xFF\xFE/; + return "UTF-16BE" if /^\xFE\xFF/; + } + + if ($self->content_is_xml) { + # http://www.w3.org/TR/2006/REC-xml-20060816/#sec-guessing + # XML entity not accompanied by external encoding information and not + # in UTF-8 or UTF-16 encoding must begin with an XML encoding declaration, + # in which the first characters must be ')/) { + if ($1 =~ /\sencoding\s*=\s*(["'])(.*?)\1/) { + my $enc = $2; + $enc =~ s/^\s+//; $enc =~ s/\s+\z//; + return $enc if $enc; + } + } + } + return "UTF-8"; + } + elsif ($self->content_is_html) { + # look for or + # http://dev.w3.org/html5/spec/Overview.html#determining-the-character-encoding + require IO::HTML; + # Use relaxed search to match previous versions of HTTP::Message: + my $encoding = IO::HTML::find_charset_in($$cref, { encoding => 1, + need_pragma => 0 }); + return $encoding->mime_name if $encoding; + } + elsif ($self->content_type eq "application/json") { + for ($$cref) { + # RFC 4627, ch 3 + return "UTF-32BE" if /^\x00\x00\x00./s; + return "UTF-32LE" if /^.\x00\x00\x00/s; + return "UTF-16BE" if /^\x00.\x00./s; + return "UTF-16LE" if /^.\x00.\x00/s; + return "UTF-8"; + } + } + if ($self->content_type =~ /^text\//) { + for ($$cref) { + if (length) { + return "US-ASCII" unless /[\x80-\xFF]/; + require Encode; + eval { + Encode::decode_utf8($_, Encode::FB_CROAK() | Encode::LEAVE_SRC()); + }; + return "UTF-8" unless $@; + return "ISO-8859-1"; + } + } + } + + return undef; +} + + +sub decoded_content +{ + my($self, %opt) = @_; + my $content_ref; + my $content_ref_iscopy; + + eval { + $content_ref = $self->content_ref; + die "Can't decode ref content" if ref($content_ref) ne "SCALAR"; + + if (my $h = $self->header("Content-Encoding")) { + $h =~ s/^\s+//; + $h =~ s/\s+$//; + for my $ce (reverse split(/\s*,\s*/, lc($h))) { + next unless $ce; + next if $ce eq "identity" || $ce eq "none"; + if ($ce eq "gzip" || $ce eq "x-gzip") { + require IO::Uncompress::Gunzip; + my $output; + IO::Uncompress::Gunzip::gunzip($content_ref, \$output, Transparent => 0) + or die "Can't gunzip content: $IO::Uncompress::Gunzip::GunzipError"; + $content_ref = \$output; + $content_ref_iscopy++; + } + elsif ($ce eq "x-bzip2" or $ce eq "bzip2") { + require IO::Uncompress::Bunzip2; + my $output; + IO::Uncompress::Bunzip2::bunzip2($content_ref, \$output, Transparent => 0) + or die "Can't bunzip content: $IO::Uncompress::Bunzip2::Bunzip2Error"; + $content_ref = \$output; + $content_ref_iscopy++; + } + elsif ($ce eq "deflate") { + require IO::Uncompress::Inflate; + my $output; + my $status = IO::Uncompress::Inflate::inflate($content_ref, \$output, Transparent => 0); + my $error = $IO::Uncompress::Inflate::InflateError; + unless ($status) { + # "Content-Encoding: deflate" is supposed to mean the + # "zlib" format of RFC 1950, but Microsoft got that + # wrong, so some servers sends the raw compressed + # "deflate" data. This tries to inflate this format. + $output = undef; + require IO::Uncompress::RawInflate; + unless (IO::Uncompress::RawInflate::rawinflate($content_ref, \$output)) { + $self->push_header("Client-Warning" => + "Could not raw inflate content: $IO::Uncompress::RawInflate::RawInflateError"); + $output = undef; + } + } + die "Can't inflate content: $error" unless defined $output; + $content_ref = \$output; + $content_ref_iscopy++; + } + elsif ($ce eq "compress" || $ce eq "x-compress") { + die "Can't uncompress content"; + } + elsif ($ce eq "base64") { # not really C-T-E, but should be harmless + require MIME::Base64; + $content_ref = \MIME::Base64::decode($$content_ref); + $content_ref_iscopy++; + } + elsif ($ce eq "quoted-printable") { # not really C-T-E, but should be harmless + require MIME::QuotedPrint; + $content_ref = \MIME::QuotedPrint::decode($$content_ref); + $content_ref_iscopy++; + } + else { + die "Don't know how to decode Content-Encoding '$ce'"; + } + } + } + + if ($self->content_is_text || (my $is_xml = $self->content_is_xml)) { + my $charset = lc( + $opt{charset} || + $self->content_type_charset || + $opt{default_charset} || + $self->content_charset || + "ISO-8859-1" + ); + if ($charset eq "none") { + # leave it as is + } + elsif ($charset eq "us-ascii" || $charset eq "iso-8859-1") { + if ($$content_ref =~ /[^\x00-\x7F]/ && defined &utf8::upgrade) { + unless ($content_ref_iscopy) { + my $copy = $$content_ref; + $content_ref = \$copy; + $content_ref_iscopy++; + } + utf8::upgrade($$content_ref); + } + } + else { + require Encode; + eval { + $content_ref = \Encode::decode($charset, $$content_ref, + ($opt{charset_strict} ? Encode::FB_CROAK() : 0) | Encode::LEAVE_SRC()); + }; + if ($@) { + my $retried; + if ($@ =~ /^Unknown encoding/) { + my $alt_charset = lc($opt{alt_charset} || ""); + if ($alt_charset && $charset ne $alt_charset) { + # Retry decoding with the alternative charset + $content_ref = \Encode::decode($alt_charset, $$content_ref, + ($opt{charset_strict} ? Encode::FB_CROAK() : 0) | Encode::LEAVE_SRC()) + unless $alt_charset eq "none"; + $retried++; + } + } + die unless $retried; + } + die "Encode::decode() returned undef improperly" unless defined $$content_ref; + if ($is_xml) { + # Get rid of the XML encoding declaration if present + $$content_ref =~ s/^\x{FEFF}//; + if ($$content_ref =~ /^(\s*<\?xml[^\x00]*?\?>)/) { + substr($$content_ref, 0, length($1)) =~ s/\sencoding\s*=\s*(["']).*?\1//; + } + } + } + } + }; + if ($@) { + Carp::croak($@) if $opt{raise_error}; + return undef; + } + + return $opt{ref} ? $content_ref : $$content_ref; +} + + +sub decodable +{ + # should match the Content-Encoding values that decoded_content can deal with + my $self = shift; + my @enc; + # XXX preferably we should determine if the modules are available without loading + # them here + eval { + require IO::Uncompress::Gunzip; + push(@enc, "gzip", "x-gzip"); + }; + eval { + require IO::Uncompress::Inflate; + require IO::Uncompress::RawInflate; + push(@enc, "deflate"); + }; + eval { + require IO::Uncompress::Bunzip2; + push(@enc, "x-bzip2", "bzip2"); + }; + # we don't care about announcing the 'identity', 'base64' and + # 'quoted-printable' stuff + return wantarray ? @enc : join(", ", @enc); +} + + +sub decode +{ + my $self = shift; + return 1 unless $self->header("Content-Encoding"); + if (defined(my $content = $self->decoded_content(charset => "none"))) { + $self->remove_header("Content-Encoding", "Content-Length", "Content-MD5"); + $self->content($content); + return 1; + } + return 0; +} + + +sub encode +{ + my($self, @enc) = @_; + + Carp::croak("Can't encode multipart/* messages") if $self->content_type =~ m,^multipart/,; + Carp::croak("Can't encode message/* messages") if $self->content_type =~ m,^message/,; + + return 1 unless @enc; # nothing to do + + my $content = $self->content; + for my $encoding (@enc) { + if ($encoding eq "identity" || $encoding eq "none") { + # nothing to do + } + elsif ($encoding eq "base64") { + require MIME::Base64; + $content = MIME::Base64::encode($content); + } + elsif ($encoding eq "gzip" || $encoding eq "x-gzip") { + require IO::Compress::Gzip; + my $output; + IO::Compress::Gzip::gzip(\$content, \$output, Minimal => 1) + or die "Can't gzip content: $IO::Compress::Gzip::GzipError"; + $content = $output; + } + elsif ($encoding eq "deflate") { + require IO::Compress::Deflate; + my $output; + IO::Compress::Deflate::deflate(\$content, \$output) + or die "Can't deflate content: $IO::Compress::Deflate::DeflateError"; + $content = $output; + } + elsif ($encoding eq "x-bzip2" || $encoding eq "bzip2") { + require IO::Compress::Bzip2; + my $output; + IO::Compress::Bzip2::bzip2(\$content, \$output) + or die "Can't bzip2 content: $IO::Compress::Bzip2::Bzip2Error"; + $content = $output; + } + elsif ($encoding eq "rot13") { # for the fun of it + $content =~ tr/A-Za-z/N-ZA-Mn-za-m/; + } + else { + return 0; + } + } + my $h = $self->header("Content-Encoding"); + unshift(@enc, $h) if $h; + $self->header("Content-Encoding", join(", ", @enc)); + $self->remove_header("Content-Length", "Content-MD5"); + $self->content($content); + return 1; +} + + +sub as_string +{ + my($self, $eol) = @_; + $eol = "\n" unless defined $eol; + + # The calculation of content might update the headers + # so we need to do that first. + my $content = $self->content; + + return join("", $self->{'_headers'}->as_string($eol), + $eol, + $content, + (@_ == 1 && length($content) && + $content !~ /\n\z/) ? "\n" : "", + ); +} + + +sub dump +{ + my($self, %opt) = @_; + my $content = $self->content; + my $chopped = 0; + if (!ref($content)) { + my $maxlen = $opt{maxlength}; + $maxlen = 512 unless defined($maxlen); + if ($maxlen && length($content) > $maxlen * 1.1 + 3) { + $chopped = length($content) - $maxlen; + $content = substr($content, 0, $maxlen) . "..."; + } + + $content =~ s/\\/\\\\/g; + $content =~ s/\t/\\t/g; + $content =~ s/\r/\\r/g; + + # no need for 3 digits in escape for these + $content =~ s/([\0-\11\13-\037])(?!\d)/sprintf('\\%o',ord($1))/eg; + + $content =~ s/([\0-\11\13-\037\177-\377])/sprintf('\\x%02X',ord($1))/eg; + $content =~ s/([^\12\040-\176])/sprintf('\\x{%X}',ord($1))/eg; + + # remaining whitespace + $content =~ s/( +)\n/("\\40" x length($1)) . "\n"/eg; + $content =~ s/(\n+)\n/("\\n" x length($1)) . "\n"/eg; + $content =~ s/\n\z/\\n/; + + my $no_content = $opt{no_content}; + $no_content = "(no content)" unless defined $no_content; + if ($content eq $no_content) { + # escape our $no_content marker + $content =~ s/^(.)/sprintf('\\x%02X',ord($1))/eg; + } + elsif ($content eq "") { + $content = $no_content; + } + } + + my @dump; + push(@dump, $opt{preheader}) if $opt{preheader}; + push(@dump, $self->{_headers}->as_string, $content); + push(@dump, "(+ $chopped more bytes not shown)") if $chopped; + + my $dump = join("\n", @dump, ""); + $dump =~ s/^/$opt{prefix}/gm if $opt{prefix}; + + print $dump unless defined wantarray; + return $dump; +} + +# allow subclasses to override what will handle individual parts +sub _part_class { + return __PACKAGE__; +} + +sub parts { + my $self = shift; + if (defined(wantarray) && (!exists $self->{_parts} || ref($self->{_content}) eq "SCALAR")) { + $self->_parts; + } + my $old = $self->{_parts}; + if (@_) { + my @parts = map { ref($_) eq 'ARRAY' ? @$_ : $_ } @_; + my $ct = $self->content_type || ""; + if ($ct =~ m,^message/,) { + Carp::croak("Only one part allowed for $ct content") + if @parts > 1; + } + elsif ($ct !~ m,^multipart/,) { + $self->remove_content_headers; + $self->content_type("multipart/mixed"); + } + $self->{_parts} = \@parts; + _stale_content($self); + } + return @$old if wantarray; + return $old->[0]; +} + +sub add_part { + my $self = shift; + if (($self->content_type || "") !~ m,^multipart/,) { + my $p = $self->_part_class->new( + $self->remove_content_headers, + $self->content(""), + ); + $self->content_type("multipart/mixed"); + $self->{_parts} = []; + if ($p->headers->header_field_names || $p->content ne "") { + push(@{$self->{_parts}}, $p); + } + } + elsif (!exists $self->{_parts} || ref($self->{_content}) eq "SCALAR") { + $self->_parts; + } + + push(@{$self->{_parts}}, @_); + _stale_content($self); + return; +} + +sub _stale_content { + my $self = shift; + if (ref($self->{_content}) eq "SCALAR") { + # must recalculate now + $self->_content; + } + else { + # just invalidate cache + delete $self->{_content}; + delete $self->{_content_ref}; + } +} + + +# delegate all other method calls to the headers object. +our $AUTOLOAD; +sub AUTOLOAD +{ + my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2); + + # We create the function here so that it will not need to be + # autoloaded the next time. + no strict 'refs'; + *$method = sub { local $Carp::Internal{+__PACKAGE__} = 1; shift->headers->$method(@_) }; + goto &$method; +} + + +sub DESTROY {} # avoid AUTOLOADing it + + +# Private method to access members in %$self +sub _elem +{ + my $self = shift; + my $elem = shift; + my $old = $self->{$elem}; + $self->{$elem} = $_[0] if @_; + return $old; +} + + +# Create private _parts attribute from current _content +sub _parts { + my $self = shift; + my $ct = $self->content_type; + if ($ct =~ m,^multipart/,) { + require HTTP::Headers::Util; + my @h = HTTP::Headers::Util::split_header_words($self->header("Content-Type")); + die "Assert" unless @h; + my %h = @{$h[0]}; + if (defined(my $b = $h{boundary})) { + my $str = $self->content; + $str =~ s/\r?\n--\Q$b\E--.*//s; + if ($str =~ s/(^|.*?\r?\n)--\Q$b\E\r?\n//s) { + $self->{_parts} = [map $self->_part_class->parse($_), + split(/\r?\n--\Q$b\E\r?\n/, $str)] + } + } + } + elsif ($ct eq "message/http") { + require HTTP::Request; + require HTTP::Response; + my $content = $self->content; + my $class = ($content =~ m,^(HTTP/.*)\n,) ? + "HTTP::Response" : "HTTP::Request"; + $self->{_parts} = [$class->parse($content)]; + } + elsif ($ct =~ m,^message/,) { + $self->{_parts} = [ $self->_part_class->parse($self->content) ]; + } + + $self->{_parts} ||= []; +} + + +# Create private _content attribute from current _parts +sub _content { + my $self = shift; + my $ct = $self->{_headers}->header("Content-Type") || "multipart/mixed"; + if ($ct =~ m,^\s*message/,i) { + _set_content($self, $self->{_parts}[0]->as_string($CRLF), 1); + return; + } + + require HTTP::Headers::Util; + my @v = HTTP::Headers::Util::split_header_words($ct); + Carp::carp("Multiple Content-Type headers") if @v > 1; + @v = @{$v[0]}; + + my $boundary; + my $boundary_index; + for (my @tmp = @v; @tmp;) { + my($k, $v) = splice(@tmp, 0, 2); + if ($k eq "boundary") { + $boundary = $v; + $boundary_index = @v - @tmp - 1; + last; + } + } + + my @parts = map $_->as_string($CRLF), @{$self->{_parts}}; + + my $bno = 0; + $boundary = _boundary() unless defined $boundary; + CHECK_BOUNDARY: + { + for (@parts) { + if (index($_, $boundary) >= 0) { + # must have a better boundary + $boundary = _boundary(++$bno); + redo CHECK_BOUNDARY; + } + } + } + + if ($boundary_index) { + $v[$boundary_index] = $boundary; + } + else { + push(@v, boundary => $boundary); + } + + $ct = HTTP::Headers::Util::join_header_words(@v); + $self->{_headers}->header("Content-Type", $ct); + + _set_content($self, "--$boundary$CRLF" . + join("$CRLF--$boundary$CRLF", @parts) . + "$CRLF--$boundary--$CRLF", + 1); +} + + +sub _boundary +{ + my $size = shift || return "xYzZY"; + require MIME::Base64; + my $b = MIME::Base64::encode(join("", map chr(rand(256)), 1..$size*3), ""); + $b =~ s/[\W]/X/g; # ensure alnum only + $b; +} + + +1; + +=pod + +=encoding UTF-8 + +=head1 NAME + +HTTP::Message - HTTP style message (base class) + +=head1 VERSION + +version 6.18 + +=head1 SYNOPSIS + + use base 'HTTP::Message'; + +=head1 DESCRIPTION + +An C object contains some headers and a content body. +The following methods are available: + +=over 4 + +=item $mess = HTTP::Message->new + +=item $mess = HTTP::Message->new( $headers ) + +=item $mess = HTTP::Message->new( $headers, $content ) + +This constructs a new message object. Normally you would want +construct C or C objects instead. + +The optional $header argument should be a reference to an +C object or a plain array reference of key/value pairs. +If an C object is provided then a copy of it will be +embedded into the constructed message, i.e. it will not be owned and +can be modified afterwards without affecting the message. + +The optional $content argument should be a string of bytes. + +=item $mess = HTTP::Message->parse( $str ) + +This constructs a new message object by parsing the given string. + +=item $mess->headers + +Returns the embedded C object. + +=item $mess->headers_as_string + +=item $mess->headers_as_string( $eol ) + +Call the as_string() method for the headers in the +message. This will be the same as + + $mess->headers->as_string + +but it will make your program a whole character shorter :-) + +=item $mess->content + +=item $mess->content( $bytes ) + +The content() method sets the raw content if an argument is given. If no +argument is given the content is not touched. In either case the +original raw content is returned. + +If the C argument is given, the content is reset to its default value, +which is an empty string. + +Note that the content should be a string of bytes. Strings in perl +can contain characters outside the range of a byte. The C +module can be used to turn such strings into a string of bytes. + +=item $mess->add_content( $bytes ) + +The add_content() methods appends more data bytes to the end of the +current content buffer. + +=item $mess->add_content_utf8( $string ) + +The add_content_utf8() method appends the UTF-8 bytes representing the +string to the end of the current content buffer. + +=item $mess->content_ref + +=item $mess->content_ref( \$bytes ) + +The content_ref() method will return a reference to content buffer string. +It can be more efficient to access the content this way if the content +is huge, and it can even be used for direct manipulation of the content, +for instance: + + ${$res->content_ref} =~ s/\bfoo\b/bar/g; + +This example would modify the content buffer in-place. + +If an argument is passed it will setup the content to reference some +external source. The content() and add_content() methods +will automatically dereference scalar references passed this way. For +other references content() will return the reference itself and +add_content() will refuse to do anything. + +=item $mess->content_charset + +This returns the charset used by the content in the message. The +charset is either found as the charset attribute of the +C header or by guessing. + +See L +for details about how charset is determined. + +=item $mess->decoded_content( %options ) + +Returns the content with any C undone and for textual content +the raw content encoded to Perl's Unicode strings. If the C +or C of the message is unknown this method will fail by returning +C. + +The following options can be specified. + +=over + +=item C + +This override the charset parameter for text content. The value +C can used to suppress decoding of the charset. + +=item C + +This override the default charset guessed by content_charset() or +if that fails "ISO-8859-1". + +=item C + +If decoding fails because the charset specified in the Content-Type header +isn't recognized by Perl's Encode module, then try decoding using this charset +instead of failing. The C might be specified as C to simply +return the string without any decoding of charset as alternative. + +=item C + +Abort decoding if malformed characters is found in the content. By +default you get the substitution character ("\x{FFFD}") in place of +malformed characters. + +=item C + +If TRUE then raise an exception if not able to decode content. Reason +might be that the specified C or C is not +supported. If this option is FALSE, then decoded_content() will return +C on errors, but will still set $@. + +=item C + +If TRUE then a reference to decoded content is returned. This might +be more efficient in cases where the decoded content is identical to +the raw content as no data copying is required in this case. + +=back + +=item $mess->decodable + +=item HTTP::Message::decodable() + +This returns the encoding identifiers that decoded_content() can +process. In scalar context returns a comma separated string of +identifiers. + +This value is suitable for initializing the C request +header field. + +=item $mess->decode + +This method tries to replace the content of the message with the +decoded version and removes the C header. Returns +TRUE if successful and FALSE if not. + +If the message does not have a C header this method +does nothing and returns TRUE. + +Note that the content of the message is still bytes after this method +has been called and you still need to call decoded_content() if you +want to process its content as a string. + +=item $mess->encode( $encoding, ... ) + +Apply the given encodings to the content of the message. Returns TRUE +if successful. The "identity" (non-)encoding is always supported; other +currently supported encodings, subject to availability of required +additional modules, are "gzip", "deflate", "x-bzip2" and "base64". + +A successful call to this function will set the C +header. + +Note that C or C messages can't be encoded and +this method will croak if you try. + +=item $mess->parts + +=item $mess->parts( @parts ) + +=item $mess->parts( \@parts ) + +Messages can be composite, i.e. contain other messages. The composite +messages have a content type of C or C. This +method give access to the contained messages. + +The argumentless form will return a list of C objects. +If the content type of $msg is not C or C then +this will return the empty list. In scalar context only the first +object is returned. The returned message parts should be regarded as +read-only (future versions of this library might make it possible +to modify the parent by modifying the parts). + +If the content type of $msg is C then there will only be +one part returned. + +If the content type is C, then the return value will be +either an C or an C object. + +If a @parts argument is given, then the content of the message will be +modified. The array reference form is provided so that an empty list +can be provided. The @parts array should contain C +objects. The @parts objects are owned by $mess after this call and +should not be modified or made part of other messages. + +When updating the message with this method and the old content type of +$mess is not C or C, then the content type is +set to C and all other content headers are cleared. + +This method will croak if the content type is C and more +than one part is provided. + +=item $mess->add_part( $part ) + +This will add a part to a message. The $part argument should be +another C object. If the previous content type of +$mess is not C then the old content (together with all +content headers) will be made part #1 and the content type made +C before the new part is added. The $part object is +owned by $mess after this call and should not be modified or made part +of other messages. + +There is no return value. + +=item $mess->clear + +Will clear the headers and set the content to the empty string. There +is no return value + +=item $mess->protocol + +=item $mess->protocol( $proto ) + +Sets the HTTP protocol used for the message. The protocol() is a string +like C or C. + +=item $mess->clone + +Returns a copy of the message object. + +=item $mess->as_string + +=item $mess->as_string( $eol ) + +Returns the message formatted as a single string. + +The optional $eol parameter specifies the line ending sequence to use. +The default is "\n". If no $eol is given then as_string will ensure +that the returned string is newline terminated (even when the message +content is not). No extra newline is appended if an explicit $eol is +passed. + +=item $mess->dump( %opt ) + +Returns the message formatted as a string. In void context print the string. + +This differs from C<< $mess->as_string >> in that it escapes the bytes +of the content so that it's safe to print them and it limits how much +content to print. The escapes syntax used is the same as for Perl's +double quoted strings. If there is no content the string "(no +content)" is shown in its place. + +Options to influence the output can be passed as key/value pairs. The +following options are recognized: + +=over + +=item maxlength => $num + +How much of the content to show. The default is 512. Set this to 0 +for unlimited. + +If the content is longer then the string is chopped at the limit and +the string "...\n(### more bytes not shown)" appended. + +=item no_content => $str + +Replaces the "(no content)" marker. + +=item prefix => $str + +A string that will be prefixed to each line of the dump. + +=back + +=back + +All methods unknown to C itself are delegated to the +C object that is part of every message. This allows +convenient access to these methods. Refer to L for +details of these methods: + + $mess->header( $field => $val ) + $mess->push_header( $field => $val ) + $mess->init_header( $field => $val ) + $mess->remove_header( $field ) + $mess->remove_content_headers + $mess->header_field_names + $mess->scan( \&doit ) + + $mess->date + $mess->expires + $mess->if_modified_since + $mess->if_unmodified_since + $mess->last_modified + $mess->content_type + $mess->content_encoding + $mess->content_length + $mess->content_language + $mess->title + $mess->user_agent + $mess->server + $mess->from + $mess->referer + $mess->www_authenticate + $mess->authorization + $mess->proxy_authorization + $mess->authorization_basic + $mess->proxy_authorization_basic + +=head1 AUTHOR + +Gisle Aas + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 1994-2017 by Gisle Aas. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut + +__END__ + + +#ABSTRACT: HTTP style message (base class) + diff --git a/lib/HTTP/Request.pm b/lib/HTTP/Request.pm new file mode 100644 index 0000000..8998ced --- /dev/null +++ b/lib/HTTP/Request.pm @@ -0,0 +1,344 @@ +package HTTP::Request; + +use strict; +use warnings; + +our $VERSION = '6.18'; + +use base 'HTTP::Message'; + +sub new +{ + my($class, $method, $uri, $header, $content) = @_; + my $self = $class->SUPER::new($header, $content); + $self->method($method); + $self->uri($uri); + $self; +} + + +sub parse +{ + my($class, $str) = @_; + Carp::carp('Undefined argument to parse()') if $^W && ! defined $str; + my $request_line; + if (defined $str && $str =~ s/^(.*)\n//) { + $request_line = $1; + } + else { + $request_line = $str; + $str = ""; + } + + my $self = $class->SUPER::parse($str); + if (defined $request_line) { + my($method, $uri, $protocol) = split(' ', $request_line); + $self->method($method); + $self->uri($uri) if defined($uri); + $self->protocol($protocol) if $protocol; + } + $self; +} + + +sub clone +{ + my $self = shift; + my $clone = bless $self->SUPER::clone, ref($self); + $clone->method($self->method); + $clone->uri($self->uri); + $clone; +} + + +sub method +{ + shift->_elem('_method', @_); +} + + +sub uri +{ + my $self = shift; + my $old = $self->{'_uri'}; + if (@_) { + my $uri = shift; + if (!defined $uri) { + # that's ok + } + elsif (ref $uri) { + Carp::croak("A URI can't be a " . ref($uri) . " reference") + if ref($uri) eq 'HASH' or ref($uri) eq 'ARRAY'; + Carp::croak("Can't use a " . ref($uri) . " object as a URI") + unless $uri->can('scheme') && $uri->can('canonical'); + $uri = $uri->clone; + unless ($HTTP::URI_CLASS eq "URI") { + # Argh!! Hate this... old LWP legacy! + eval { local $SIG{__DIE__}; $uri = $uri->abs; }; + die $@ if $@ && $@ !~ /Missing base argument/; + } + } + else { + $uri = $HTTP::URI_CLASS->new($uri); + } + $self->{'_uri'} = $uri; + delete $self->{'_uri_canonical'}; + } + $old; +} + +*url = \&uri; # legacy + +sub uri_canonical +{ + my $self = shift; + return $self->{'_uri_canonical'} ||= $self->{'_uri'}->canonical; +} + + +sub accept_decodable +{ + my $self = shift; + $self->header("Accept-Encoding", scalar($self->decodable)); +} + +sub as_string +{ + my $self = shift; + my($eol) = @_; + $eol = "\n" unless defined $eol; + + my $req_line = $self->method || "-"; + my $uri = $self->uri; + $uri = (defined $uri) ? $uri->as_string : "-"; + $req_line .= " $uri"; + my $proto = $self->protocol; + $req_line .= " $proto" if $proto; + + return join($eol, $req_line, $self->SUPER::as_string(@_)); +} + +sub dump +{ + my $self = shift; + my @pre = ($self->method || "-", $self->uri || "-"); + if (my $prot = $self->protocol) { + push(@pre, $prot); + } + + return $self->SUPER::dump( + preheader => join(" ", @pre), + @_, + ); +} + + +1; + +=pod + +=encoding UTF-8 + +=head1 NAME + +HTTP::Request - HTTP style request message + +=head1 VERSION + +version 6.18 + +=head1 SYNOPSIS + + require HTTP::Request; + $request = HTTP::Request->new(GET => 'http://www.example.com/'); + +and usually used like this: + + $ua = LWP::UserAgent->new; + $response = $ua->request($request); + +=head1 DESCRIPTION + +C is a class encapsulating HTTP style requests, +consisting of a request line, some headers, and a content body. Note +that the LWP library uses HTTP style requests even for non-HTTP +protocols. Instances of this class are usually passed to the +request() method of an C object. + +C is a subclass of C and therefore +inherits its methods. The following additional methods are available: + +=over 4 + +=item $r = HTTP::Request->new( $method, $uri ) + +=item $r = HTTP::Request->new( $method, $uri, $header ) + +=item $r = HTTP::Request->new( $method, $uri, $header, $content ) + +Constructs a new C object describing a request on the +object $uri using method $method. The $method argument must be a +string. The $uri argument can be either a string, or a reference to a +C object. The optional $header argument should be a reference to +an C object or a plain array reference of key/value +pairs. The optional $content argument should be a string of bytes. + +=item $r = HTTP::Request->parse( $str ) + +This constructs a new request object by parsing the given string. + +=item $r->method + +=item $r->method( $val ) + +This is used to get/set the method attribute. The method should be a +short string like "GET", "HEAD", "PUT", "PATCH" or "POST". + +=item $r->uri + +=item $r->uri( $val ) + +This is used to get/set the uri attribute. The $val can be a +reference to a URI object or a plain string. If a string is given, +then it should be parsable as an absolute URI. + +=item $r->header( $field ) + +=item $r->header( $field => $value ) + +This is used to get/set header values and it is inherited from +C via C. See L for +details and other similar methods that can be used to access the +headers. + +=item $r->accept_decodable + +This will set the C header to the list of encodings +that decoded_content() can decode. + +=item $r->content + +=item $r->content( $bytes ) + +This is used to get/set the content and it is inherited from the +C base class. See L for details and +other methods that can be used to access the content. + +Note that the content should be a string of bytes. Strings in perl +can contain characters outside the range of a byte. The C +module can be used to turn such strings into a string of bytes. + +=item $r->as_string + +=item $r->as_string( $eol ) + +Method returning a textual representation of the request. + +=back + +=head1 EXAMPLES + +Creating requests to be sent with L or others can be easy. Here +are a few examples. + +=head2 Simple POST + +Here, we'll create a simple POST request that could be used to send JSON data +to an endpoint. + + #!/usr/bin/env perl + + use strict; + use warnings; + + use Encode qw(encode_utf8); + use HTTP::Request (); + use JSON::MaybeXS qw(encode_json); + + my $url = 'https://www.example.com/api/user/123'; + my $header = ['Content-Type' => 'application/json; charset=UTF-8']; + my $data = {foo => 'bar', baz => 'quux'}; + my $encoded_data = encode_utf8(encode_json($data)); + + my $r = HTTP::Request->new('POST', $url, $header, $encoded_data); + # at this point, we could send it via LWP::UserAgent + # my $ua = LWP::UserAgent->new(); + # my $res = $ua->request($r); + +=head2 Batch POST Request + +Some services, like Google, allow multiple requests to be sent in one batch. +L for example. Using the +C method from L makes this simple. + + #!/usr/bin/env perl + + use strict; + use warnings; + + use Encode qw(encode_utf8); + use HTTP::Request (); + use JSON::MaybeXS qw(encode_json); + + my $auth_token = 'auth_token'; + my $batch_url = 'https://www.googleapis.com/batch'; + my $url = 'https://www.googleapis.com/drive/v3/files/fileId/permissions?fields=id'; + my $url_no_email = 'https://www.googleapis.com/drive/v3/files/fileId/permissions?fields=id&sendNotificationEmail=false'; + + # generate a JSON post request for one of the batch entries + my $req1 = build_json_request($url, { + emailAddress => 'example@appsrocks.com', + role => "writer", + type => "user", + }); + + # generate a JSON post request for one of the batch entries + my $req2 = build_json_request($url_no_email, { + domain => "appsrocks.com", + role => "reader", + type => "domain", + }); + + # generate a multipart request to send all of the other requests + my $r = HTTP::Request->new('POST', $batch_url, [ + 'Accept-Encoding' => 'gzip', + # if we don't provide a boundary here, HTTP::Message will generate + # one for us. We could use UUID::uuid() here if we wanted. + 'Content-Type' => 'multipart/mixed; boundary=END_OF_PART' + ]); + + # add the two POST requests to the main request + $r->add_part($req1, $req2); + # at this point, we could send it via LWP::UserAgent + # my $ua = LWP::UserAgent->new(); + # my $res = $ua->request($r); + exit(); + + sub build_json_request { + my ($url, $href) = @_; + my $header = ['Authorization' => "Bearer $auth_token", 'Content-Type' => 'application/json; charset=UTF-8']; + return HTTP::Request->new('POST', $url, $header, encode_utf8(encode_json($href))); + } + +=head1 SEE ALSO + +L, L, L, +L + +=head1 AUTHOR + +Gisle Aas + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 1994-2017 by Gisle Aas. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut + +__END__ + + +#ABSTRACT: HTTP style request message diff --git a/lib/HTTP/Request/Common.pm b/lib/HTTP/Request/Common.pm new file mode 100644 index 0000000..d70a939 --- /dev/null +++ b/lib/HTTP/Request/Common.pm @@ -0,0 +1,560 @@ +package HTTP::Request::Common; + +use strict; +use warnings; + +our $VERSION = '6.18'; + +our $DYNAMIC_FILE_UPLOAD ||= 0; # make it defined (don't know why) + +use Exporter 5.57 'import'; + +our @EXPORT =qw(GET HEAD PUT PATCH POST); +our @EXPORT_OK = qw($DYNAMIC_FILE_UPLOAD DELETE); + +require HTTP::Request; +use Carp(); + +my $CRLF = "\015\012"; # "\r\n" is not portable + +sub GET { _simple_req('GET', @_); } +sub HEAD { _simple_req('HEAD', @_); } +sub DELETE { _simple_req('DELETE', @_); } +sub PATCH { request_type_with_data('PATCH', @_); } +sub POST { request_type_with_data('POST', @_); } +sub PUT { request_type_with_data('PUT', @_); } + +sub request_type_with_data +{ + my $type = shift; + my $url = shift; + my $req = HTTP::Request->new($type => $url); + my $content; + $content = shift if @_ and ref $_[0]; + my($k, $v); + while (($k,$v) = splice(@_, 0, 2)) { + if (lc($k) eq 'content') { + $content = $v; + } + else { + $req->push_header($k, $v); + } + } + my $ct = $req->header('Content-Type'); + unless ($ct) { + $ct = 'application/x-www-form-urlencoded'; + } + elsif ($ct eq 'form-data') { + $ct = 'multipart/form-data'; + } + + if (ref $content) { + if ($ct =~ m,^multipart/form-data\s*(;|$),i) { + require HTTP::Headers::Util; + my @v = HTTP::Headers::Util::split_header_words($ct); + Carp::carp("Multiple Content-Type headers") if @v > 1; + @v = @{$v[0]}; + + my $boundary; + my $boundary_index; + for (my @tmp = @v; @tmp;) { + my($k, $v) = splice(@tmp, 0, 2); + if ($k eq "boundary") { + $boundary = $v; + $boundary_index = @v - @tmp - 1; + last; + } + } + + ($content, $boundary) = form_data($content, $boundary, $req); + + if ($boundary_index) { + $v[$boundary_index] = $boundary; + } + else { + push(@v, boundary => $boundary); + } + + $ct = HTTP::Headers::Util::join_header_words(@v); + } + else { + # We use a temporary URI object to format + # the application/x-www-form-urlencoded content. + require URI; + my $url = URI->new('http:'); + $url->query_form(ref($content) eq "HASH" ? %$content : @$content); + $content = $url->query; + + # HTML/4.01 says that line breaks are represented as "CR LF" pairs (i.e., `%0D%0A') + $content =~ s/(?header('Content-Type' => $ct); # might be redundant + if (defined($content)) { + $req->header('Content-Length' => + length($content)) unless ref($content); + $req->content($content); + } + else { + $req->header('Content-Length' => 0); + } + $req; +} + + +sub _simple_req +{ + my($method, $url) = splice(@_, 0, 2); + my $req = HTTP::Request->new($method => $url); + my($k, $v); + my $content; + while (($k,$v) = splice(@_, 0, 2)) { + if (lc($k) eq 'content') { + $req->add_content($v); + $content++; + } + else { + $req->push_header($k, $v); + } + } + if ($content && !defined($req->header("Content-Length"))) { + $req->header("Content-Length", length(${$req->content_ref})); + } + $req; +} + + +sub form_data # RFC1867 +{ + my($data, $boundary, $req) = @_; + my @data = ref($data) eq "HASH" ? %$data : @$data; # copy + my $fhparts; + my @parts; + while (my ($k,$v) = splice(@data, 0, 2)) { + if (!ref($v)) { + $k =~ s/([\\\"])/\\$1/g; # escape quotes and backslashes + no warnings 'uninitialized'; + push(@parts, + qq(Content-Disposition: form-data; name="$k"$CRLF$CRLF$v)); + } + else { + my($file, $usename, @headers) = @$v; + unless (defined $usename) { + $usename = $file; + $usename =~ s,.*/,, if defined($usename); + } + $k =~ s/([\\\"])/\\$1/g; + my $disp = qq(form-data; name="$k"); + if (defined($usename) and length($usename)) { + $usename =~ s/([\\\"])/\\$1/g; + $disp .= qq(; filename="$usename"); + } + my $content = ""; + my $h = HTTP::Headers->new(@headers); + if ($file) { + open(my $fh, "<", $file) or Carp::croak("Can't open file $file: $!"); + binmode($fh); + if ($DYNAMIC_FILE_UPLOAD) { + # will read file later, close it now in order to + # not accumulate to many open file handles + close($fh); + $content = \$file; + } + else { + local($/) = undef; # slurp files + $content = <$fh>; + close($fh); + } + unless ($h->header("Content-Type")) { + require LWP::MediaTypes; + LWP::MediaTypes::guess_media_type($file, $h); + } + } + if ($h->header("Content-Disposition")) { + # just to get it sorted first + $disp = $h->header("Content-Disposition"); + $h->remove_header("Content-Disposition"); + } + if ($h->header("Content")) { + $content = $h->header("Content"); + $h->remove_header("Content"); + } + my $head = join($CRLF, "Content-Disposition: $disp", + $h->as_string($CRLF), + ""); + if (ref $content) { + push(@parts, [$head, $$content]); + $fhparts++; + } + else { + push(@parts, $head . $content); + } + } + } + return ("", "none") unless @parts; + + my $content; + if ($fhparts) { + $boundary = boundary(10) # hopefully enough randomness + unless $boundary; + + # add the boundaries to the @parts array + for (1..@parts-1) { + splice(@parts, $_*2-1, 0, "$CRLF--$boundary$CRLF"); + } + unshift(@parts, "--$boundary$CRLF"); + push(@parts, "$CRLF--$boundary--$CRLF"); + + # See if we can generate Content-Length header + my $length = 0; + for (@parts) { + if (ref $_) { + my ($head, $f) = @$_; + my $file_size; + unless ( -f $f && ($file_size = -s _) ) { + # The file is either a dynamic file like /dev/audio + # or perhaps a file in the /proc file system where + # stat may return a 0 size even though reading it + # will produce data. So we cannot make + # a Content-Length header. + undef $length; + last; + } + $length += $file_size + length $head; + } + else { + $length += length; + } + } + $length && $req->header('Content-Length' => $length); + + # set up a closure that will return content piecemeal + $content = sub { + for (;;) { + unless (@parts) { + defined $length && $length != 0 && + Carp::croak "length of data sent did not match calculated Content-Length header. Probably because uploaded file changed in size during transfer."; + return; + } + my $p = shift @parts; + unless (ref $p) { + $p .= shift @parts while @parts && !ref($parts[0]); + defined $length && ($length -= length $p); + return $p; + } + my($buf, $fh) = @$p; + unless (ref($fh)) { + my $file = $fh; + undef($fh); + open($fh, "<", $file) || Carp::croak("Can't open file $file: $!"); + binmode($fh); + } + my $buflength = length $buf; + my $n = read($fh, $buf, 2048, $buflength); + if ($n) { + $buflength += $n; + unshift(@parts, ["", $fh]); + } + else { + close($fh); + } + if ($buflength) { + defined $length && ($length -= $buflength); + return $buf + } + } + }; + + } + else { + $boundary = boundary() unless $boundary; + + my $bno = 0; + CHECK_BOUNDARY: + { + for (@parts) { + if (index($_, $boundary) >= 0) { + # must have a better boundary + $boundary = boundary(++$bno); + redo CHECK_BOUNDARY; + } + } + last; + } + $content = "--$boundary$CRLF" . + join("$CRLF--$boundary$CRLF", @parts) . + "$CRLF--$boundary--$CRLF"; + } + + wantarray ? ($content, $boundary) : $content; +} + + +sub boundary +{ + my $size = shift || return "xYzZY"; + require MIME::Base64; + my $b = MIME::Base64::encode(join("", map chr(rand(256)), 1..$size*3), ""); + $b =~ s/[\W]/X/g; # ensure alnum only + $b; +} + +1; + +=pod + +=encoding UTF-8 + +=head1 NAME + +HTTP::Request::Common - Construct common HTTP::Request objects + +=head1 VERSION + +version 6.18 + +=head1 SYNOPSIS + + use HTTP::Request::Common; + $ua = LWP::UserAgent->new; + $ua->request(GET 'http://www.sn.no/'); + $ua->request(POST 'http://somewhere/foo', [foo => bar, bar => foo]); + $ua->request(PATCH 'http://somewhere/foo', [foo => bar, bar => foo]); + $ua->request(PUT 'http://somewhere/foo', [foo => bar, bar => foo]); + +=head1 DESCRIPTION + +This module provides functions that return newly created C +objects. These functions are usually more convenient to use than the +standard C constructor for the most common requests. + +Note that L has several convenience methods, including +C, C, C, C and C. + +The following functions are provided: + +=over 4 + +=item GET $url + +=item GET $url, Header => Value,... + +The C function returns an L object initialized with +the "GET" method and the specified URL. It is roughly equivalent to the +following call + + HTTP::Request->new( + GET => $url, + HTTP::Headers->new(Header => Value,...), + ) + +but is less cluttered. What is different is that a header named +C will initialize the content part of the request instead of +setting a header field. Note that GET requests should normally not +have a content, so this hack makes more sense for the C, C + and C functions described below. + +The C method of L exists as a shortcut for +C<< $ua->request(GET ...) >>. + +=item HEAD $url + +=item HEAD $url, Header => Value,... + +Like GET() but the method in the request is "HEAD". + +The C method of L exists as a shortcut for +C<< $ua->request(HEAD ...) >>. + +=item DELETE $url + +=item DELETE $url, Header => Value,... + +Like C but the method in the request is C. This function +is not exported by default. + +=item PATCH $url + +=item PATCH $url, Header => Value,... + +=item PATCH $url, $form_ref, Header => Value,... + +=item PATCH $url, Header => Value,..., Content => $form_ref + +=item PATCH $url, Header => Value,..., Content => $content + +The same as C below, but the method in the request is C. + +=item PUT $url + +=item PUT $url, Header => Value,... + +=item PUT $url, $form_ref, Header => Value,... + +=item PUT $url, Header => Value,..., Content => $form_ref + +=item PUT $url, Header => Value,..., Content => $content + +The same as C below, but the method in the request is C + +=item POST $url + +=item POST $url, Header => Value,... + +=item POST $url, $form_ref, Header => Value,... + +=item POST $url, Header => Value,..., Content => $form_ref + +=item POST $url, Header => Value,..., Content => $content + +C, C and C all work with the same parameters. + + %data = ( title => 'something', body => something else' ); + $ua = LWP::UserAgent->new(); + $request = HTTP::Request::Common::POST( $url, [ %data ] ); + $response = $ua->request($request); + +They take a second optional array or hash reference +parameter C<$form_ref>. The content can also be specified +directly using the C pseudo-header, and you may also provide +the C<$form_ref> this way. + +The C pseudo-header steals a bit of the header field namespace as +there is no way to directly specify a header that is actually called +"Content". If you really need this you must update the request +returned in a separate statement. + +The C<$form_ref> argument can be used to pass key/value pairs for the +form content. By default we will initialize a request using the +C content type. This means that +you can emulate an HTML Eform> POSTing like this: + + POST 'http://www.perl.org/survey.cgi', + [ name => 'Gisle Aas', + email => 'gisle@aas.no', + gender => 'M', + born => '1964', + perc => '3%', + ]; + +This will create an L object that looks like this: + + POST http://www.perl.org/survey.cgi + Content-Length: 66 + Content-Type: application/x-www-form-urlencoded + + name=Gisle%20Aas&email=gisle%40aas.no&gender=M&born=1964&perc=3%25 + +Multivalued form fields can be specified by either repeating the field +name or by passing the value as an array reference. + +The POST method also supports the C content used +for I as specified in RFC 1867. You trigger +this content format by specifying a content type of C<'form-data'> as +one of the request headers. If one of the values in the C<$form_ref> is +an array reference, then it is treated as a file part specification +with the following interpretation: + + [ $file, $filename, Header => Value... ] + [ undef, $filename, Header => Value,..., Content => $content ] + +The first value in the array ($file) is the name of a file to open. +This file will be read and its content placed in the request. The +routine will croak if the file can't be opened. Use an C as +$file value if you want to specify the content directly with a +C header. The $filename is the filename to report in the +request. If this value is undefined, then the basename of the $file +will be used. You can specify an empty string as $filename if you +want to suppress sending the filename when you provide a $file value. + +If a $file is provided by no C header, then C +and C will be filled in automatically with the values +returned by C + +Sending my F<~/.profile> to the survey used as example above can be +achieved by this: + + POST 'http://www.perl.org/survey.cgi', + Content_Type => 'form-data', + Content => [ name => 'Gisle Aas', + email => 'gisle@aas.no', + gender => 'M', + born => '1964', + init => ["$ENV{HOME}/.profile"], + ] + +This will create an L object that almost looks this (the +boundary and the content of your F<~/.profile> is likely to be +different): + + POST http://www.perl.org/survey.cgi + Content-Length: 388 + Content-Type: multipart/form-data; boundary="6G+f" + + --6G+f + Content-Disposition: form-data; name="name" + + Gisle Aas + --6G+f + Content-Disposition: form-data; name="email" + + gisle@aas.no + --6G+f + Content-Disposition: form-data; name="gender" + + M + --6G+f + Content-Disposition: form-data; name="born" + + 1964 + --6G+f + Content-Disposition: form-data; name="init"; filename=".profile" + Content-Type: text/plain + + PATH=/local/perl/bin:$PATH + export PATH + + --6G+f-- + +If you set the C<$DYNAMIC_FILE_UPLOAD> variable (exportable) to some TRUE +value, then you get back a request object with a subroutine closure as +the content attribute. This subroutine will read the content of any +files on demand and return it in suitable chunks. This allow you to +upload arbitrary big files without using lots of memory. You can even +upload infinite files like F if you wish; however, if +the file is not a plain file, there will be no C header +defined for the request. Not all servers (or server +applications) like this. Also, if the file(s) change in size between +the time the C is calculated and the time that the last +chunk is delivered, the subroutine will C. + +The C method of L exists as a shortcut for +C<< $ua->request(POST ...) >>. + +=back + +=head1 SEE ALSO + +L, L + +Also, there are some examples in L that you might +find useful. For example, batch requests are explained there. + +=head1 AUTHOR + +Gisle Aas + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 1994-2017 by Gisle Aas. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut + +__END__ + + +#ABSTRACT: Construct common HTTP::Request objects diff --git a/lib/HTTP/Response.pm b/lib/HTTP/Response.pm new file mode 100644 index 0000000..31d7a38 --- /dev/null +++ b/lib/HTTP/Response.pm @@ -0,0 +1,665 @@ +package HTTP::Response; + +use strict; +use warnings; + +our $VERSION = '6.18'; + +use base 'HTTP::Message'; + +use HTTP::Status (); + + +sub new +{ + my($class, $rc, $msg, $header, $content) = @_; + my $self = $class->SUPER::new($header, $content); + $self->code($rc); + $self->message($msg); + $self; +} + + +sub parse +{ + my($class, $str) = @_; + Carp::carp('Undefined argument to parse()') if $^W && ! defined $str; + my $status_line; + if (defined $str && $str =~ s/^(.*)\n//) { + $status_line = $1; + } + else { + $status_line = $str; + $str = ""; + } + + $status_line =~ s/\r\z// if defined $status_line; + + my $self = $class->SUPER::parse($str); + if (defined $status_line) { + my($protocol, $code, $message); + if ($status_line =~ /^\d{3} /) { + # Looks like a response created by HTTP::Response->new + ($code, $message) = split(' ', $status_line, 2); + } else { + ($protocol, $code, $message) = split(' ', $status_line, 3); + } + $self->protocol($protocol) if $protocol; + $self->code($code) if defined($code); + $self->message($message) if defined($message); + } + $self; +} + + +sub clone +{ + my $self = shift; + my $clone = bless $self->SUPER::clone, ref($self); + $clone->code($self->code); + $clone->message($self->message); + $clone->request($self->request->clone) if $self->request; + # we don't clone previous + $clone; +} + + +sub code { shift->_elem('_rc', @_); } +sub message { shift->_elem('_msg', @_); } +sub previous { shift->_elem('_previous',@_); } +sub request { shift->_elem('_request', @_); } + + +sub status_line +{ + my $self = shift; + my $code = $self->{'_rc'} || "000"; + my $mess = $self->{'_msg'} || HTTP::Status::status_message($code) || "Unknown code"; + return "$code $mess"; +} + + +sub base +{ + my $self = shift; + my $base = ( + $self->header('Content-Base'), # used to be HTTP/1.1 + $self->header('Content-Location'), # HTTP/1.1 + $self->header('Base'), # HTTP/1.0 + )[0]; + if ($base && $base =~ /^$URI::scheme_re:/o) { + # already absolute + return $HTTP::URI_CLASS->new($base); + } + + my $req = $self->request; + if ($req) { + # if $base is undef here, the return value is effectively + # just a copy of $self->request->uri. + return $HTTP::URI_CLASS->new_abs($base, $req->uri); + } + + # can't find an absolute base + return undef; +} + + +sub redirects { + my $self = shift; + my @r; + my $r = $self; + while (my $p = $r->previous) { + push(@r, $p); + $r = $p; + } + return @r unless wantarray; + return reverse @r; +} + + +sub filename +{ + my $self = shift; + my $file; + + my $cd = $self->header('Content-Disposition'); + if ($cd) { + require HTTP::Headers::Util; + if (my @cd = HTTP::Headers::Util::split_header_words($cd)) { + my ($disposition, undef, %cd_param) = @{$cd[-1]}; + $file = $cd_param{filename}; + + # RFC 2047 encoded? + if ($file && $file =~ /^=\?(.+?)\?(.+?)\?(.+)\?=$/) { + my $charset = $1; + my $encoding = uc($2); + my $encfile = $3; + + if ($encoding eq 'Q' || $encoding eq 'B') { + local($SIG{__DIE__}); + eval { + if ($encoding eq 'Q') { + $encfile =~ s/_/ /g; + require MIME::QuotedPrint; + $encfile = MIME::QuotedPrint::decode($encfile); + } + else { # $encoding eq 'B' + require MIME::Base64; + $encfile = MIME::Base64::decode($encfile); + } + + require Encode; + require Encode::Locale; + Encode::from_to($encfile, $charset, "locale_fs"); + }; + + $file = $encfile unless $@; + } + } + } + } + + unless (defined($file) && length($file)) { + my $uri; + if (my $cl = $self->header('Content-Location')) { + $uri = URI->new($cl); + } + elsif (my $request = $self->request) { + $uri = $request->uri; + } + + if ($uri) { + $file = ($uri->path_segments)[-1]; + } + } + + if ($file) { + $file =~ s,.*[\\/],,; # basename + } + + if ($file && !length($file)) { + $file = undef; + } + + $file; +} + + +sub as_string +{ + my $self = shift; + my($eol) = @_; + $eol = "\n" unless defined $eol; + + my $status_line = $self->status_line; + my $proto = $self->protocol; + $status_line = "$proto $status_line" if $proto; + + return join($eol, $status_line, $self->SUPER::as_string(@_)); +} + + +sub dump +{ + my $self = shift; + + my $status_line = $self->status_line; + my $proto = $self->protocol; + $status_line = "$proto $status_line" if $proto; + + return $self->SUPER::dump( + preheader => $status_line, + @_, + ); +} + + +sub is_info { HTTP::Status::is_info (shift->{'_rc'}); } +sub is_success { HTTP::Status::is_success (shift->{'_rc'}); } +sub is_redirect { HTTP::Status::is_redirect (shift->{'_rc'}); } +sub is_error { HTTP::Status::is_error (shift->{'_rc'}); } +sub is_client_error { HTTP::Status::is_client_error (shift->{'_rc'}); } +sub is_server_error { HTTP::Status::is_server_error (shift->{'_rc'}); } + + +sub error_as_HTML +{ + my $self = shift; + my $title = 'An Error Occurred'; + my $body = $self->status_line; + $body =~ s/&/&/g; + $body =~ s/ +$title + +

$title

+

$body

+ + +EOM +} + + +sub current_age +{ + my $self = shift; + my $time = shift; + + # Implementation of RFC 2616 section 13.2.3 + # (age calculations) + my $response_time = $self->client_date; + my $date = $self->date; + + my $age = 0; + if ($response_time && $date) { + $age = $response_time - $date; # apparent_age + $age = 0 if $age < 0; + } + + my $age_v = $self->header('Age'); + if ($age_v && $age_v > $age) { + $age = $age_v; # corrected_received_age + } + + if ($response_time) { + my $request = $self->request; + if ($request) { + my $request_time = $request->date; + if ($request_time && $request_time < $response_time) { + # Add response_delay to age to get 'corrected_initial_age' + $age += $response_time - $request_time; + } + } + $age += ($time || time) - $response_time; + } + return $age; +} + + +sub freshness_lifetime +{ + my($self, %opt) = @_; + + # First look for the Cache-Control: max-age=n header + for my $cc ($self->header('Cache-Control')) { + for my $cc_dir (split(/\s*,\s*/, $cc)) { + return $1 if $cc_dir =~ /^max-age\s*=\s*(\d+)/i; + } + } + + # Next possibility is to look at the "Expires" header + my $date = $self->date || $self->client_date || $opt{time} || time; + if (my $expires = $self->expires) { + return $expires - $date; + } + + # Must apply heuristic expiration + return undef if exists $opt{heuristic_expiry} && !$opt{heuristic_expiry}; + + # Default heuristic expiration parameters + $opt{h_min} ||= 60; + $opt{h_max} ||= 24 * 3600; + $opt{h_lastmod_fraction} ||= 0.10; # 10% since last-mod suggested by RFC2616 + $opt{h_default} ||= 3600; + + # Should give a warning if more than 24 hours according to + # RFC 2616 section 13.2.4. Here we just make this the default + # maximum value. + + if (my $last_modified = $self->last_modified) { + my $h_exp = ($date - $last_modified) * $opt{h_lastmod_fraction}; + return $opt{h_min} if $h_exp < $opt{h_min}; + return $opt{h_max} if $h_exp > $opt{h_max}; + return $h_exp; + } + + # default when all else fails + return $opt{h_min} if $opt{h_min} > $opt{h_default}; + return $opt{h_default}; +} + + +sub is_fresh +{ + my($self, %opt) = @_; + $opt{time} ||= time; + my $f = $self->freshness_lifetime(%opt); + return undef unless defined($f); + return $f > $self->current_age($opt{time}); +} + + +sub fresh_until +{ + my($self, %opt) = @_; + $opt{time} ||= time; + my $f = $self->freshness_lifetime(%opt); + return undef unless defined($f); + return $f - $self->current_age($opt{time}) + $opt{time}; +} + +1; + +=pod + +=encoding UTF-8 + +=head1 NAME + +HTTP::Response - HTTP style response message + +=head1 VERSION + +version 6.18 + +=head1 SYNOPSIS + +Response objects are returned by the request() method of the C: + + # ... + $response = $ua->request($request); + if ($response->is_success) { + print $response->decoded_content; + } + else { + print STDERR $response->status_line, "\n"; + } + +=head1 DESCRIPTION + +The C class encapsulates HTTP style responses. A +response consists of a response line, some headers, and a content +body. Note that the LWP library uses HTTP style responses even for +non-HTTP protocol schemes. Instances of this class are usually +created and returned by the request() method of an C +object. + +C is a subclass of C and therefore +inherits its methods. The following additional methods are available: + +=over 4 + +=item $r = HTTP::Response->new( $code ) + +=item $r = HTTP::Response->new( $code, $msg ) + +=item $r = HTTP::Response->new( $code, $msg, $header ) + +=item $r = HTTP::Response->new( $code, $msg, $header, $content ) + +Constructs a new C object describing a response with +response code $code and optional message $msg. The optional $header +argument should be a reference to an C object or a +plain array reference of key/value pairs. The optional $content +argument should be a string of bytes. The meanings of these arguments are +described below. + +=item $r = HTTP::Response->parse( $str ) + +This constructs a new response object by parsing the given string. + +=item $r->code + +=item $r->code( $code ) + +This is used to get/set the code attribute. The code is a 3 digit +number that encode the overall outcome of an HTTP response. The +C module provide constants that provide mnemonic names +for the code attribute. + +=item $r->message + +=item $r->message( $message ) + +This is used to get/set the message attribute. The message is a short +human readable single line string that explains the response code. + +=item $r->header( $field ) + +=item $r->header( $field => $value ) + +This is used to get/set header values and it is inherited from +C via C. See L for +details and other similar methods that can be used to access the +headers. + +=item $r->content + +=item $r->content( $bytes ) + +This is used to get/set the raw content and it is inherited from the +C base class. See L for details and +other methods that can be used to access the content. + +=item $r->decoded_content( %options ) + +This will return the content after any C and +charsets have been decoded. See L for details. + +=item $r->request + +=item $r->request( $request ) + +This is used to get/set the request attribute. The request attribute +is a reference to the request that caused this response. It does +not have to be the same request passed to the $ua->request() method, +because there might have been redirects and authorization retries in +between. + +=item $r->previous + +=item $r->previous( $response ) + +This is used to get/set the previous attribute. The previous +attribute is used to link together chains of responses. You get +chains of responses if the first response is redirect or unauthorized. +The value is C if this is the first response in a chain. + +Note that the method $r->redirects is provided as a more convenient +way to access the response chain. + +=item $r->status_line + +Returns the string "Ecode> Emessage>". If the message attribute +is not set then the official name of Ecode> (see L) +is substituted. + +=item $r->base + +Returns the base URI for this response. The return value will be a +reference to a URI object. + +The base URI is obtained from one the following sources (in priority +order): + +=over 4 + +=item 1. + +Embedded in the document content, for instance +in HTML documents. + +=item 2. + +A "Content-Base:" or a "Content-Location:" header in the response. + +For backwards compatibility with older HTTP implementations we will +also look for the "Base:" header. + +=item 3. + +The URI used to request this response. This might not be the original +URI that was passed to $ua->request() method, because we might have +received some redirect responses first. + +=back + +If none of these sources provide an absolute URI, undef is returned. + +When the LWP protocol modules produce the HTTP::Response object, then any base +URI embedded in the document (step 1) will already have initialized the +"Content-Base:" header. (See L). This means that +this method only performs the last 2 steps (the content is not always available +either). + +=item $r->filename + +Returns a filename for this response. Note that doing sanity checks +on the returned filename (eg. removing characters that cannot be used +on the target filesystem where the filename would be used, and +laundering it for security purposes) are the caller's responsibility; +the only related thing done by this method is that it makes a simple +attempt to return a plain filename with no preceding path segments. + +The filename is obtained from one the following sources (in priority +order): + +=over 4 + +=item 1. + +A "Content-Disposition:" header in the response. Proper decoding of +RFC 2047 encoded filenames requires the C (for "Q" +encoding), C (for "B" encoding), and C modules. + +=item 2. + +A "Content-Location:" header in the response. + +=item 3. + +The URI used to request this response. This might not be the original +URI that was passed to $ua->request() method, because we might have +received some redirect responses first. + +=back + +If a filename cannot be derived from any of these sources, undef is +returned. + +=item $r->as_string + +=item $r->as_string( $eol ) + +Returns a textual representation of the response. + +=item $r->is_info + +=item $r->is_success + +=item $r->is_redirect + +=item $r->is_error + +=item $r->is_client_error + +=item $r->is_server_error + +These methods indicate if the response was informational, successful, a +redirection, or an error. See L for the meaning of these. + +=item $r->error_as_HTML + +Returns a string containing a complete HTML document indicating what +error occurred. This method should only be called when $r->is_error +is TRUE. + +=item $r->redirects + +Returns the list of redirect responses that lead up to this response +by following the $r->previous chain. The list order is oldest first. + +In scalar context return the number of redirect responses leading up +to this one. + +=item $r->current_age + +Calculates the "current age" of the response as specified by RFC 2616 +section 13.2.3. The age of a response is the time since it was sent +by the origin server. The returned value is a number representing the +age in seconds. + +=item $r->freshness_lifetime( %opt ) + +Calculates the "freshness lifetime" of the response as specified by +RFC 2616 section 13.2.4. The "freshness lifetime" is the length of +time between the generation of a response and its expiration time. +The returned value is the number of seconds until expiry. + +If the response does not contain an "Expires" or a "Cache-Control" +header, then this function will apply some simple heuristic based on +the "Last-Modified" header to determine a suitable lifetime. The +following options might be passed to control the heuristics: + +=over + +=item heuristic_expiry => $bool + +If passed as a FALSE value, don't apply heuristics and just return +C when "Expires" or "Cache-Control" is lacking. + +=item h_lastmod_fraction => $num + +This number represent the fraction of the difference since the +"Last-Modified" timestamp to make the expiry time. The default is +C<0.10>, the suggested typical setting of 10% in RFC 2616. + +=item h_min => $sec + +This is the lower limit of the heuristic expiry age to use. The +default is C<60> (1 minute). + +=item h_max => $sec + +This is the upper limit of the heuristic expiry age to use. The +default is C<86400> (24 hours). + +=item h_default => $sec + +This is the expiry age to use when nothing else applies. The default +is C<3600> (1 hour) or "h_min" if greater. + +=back + +=item $r->is_fresh( %opt ) + +Returns TRUE if the response is fresh, based on the values of +freshness_lifetime() and current_age(). If the response is no longer +fresh, then it has to be re-fetched or re-validated by the origin +server. + +Options might be passed to control expiry heuristics, see the +description of freshness_lifetime(). + +=item $r->fresh_until( %opt ) + +Returns the time (seconds since epoch) when this entity is no longer fresh. + +Options might be passed to control expiry heuristics, see the +description of freshness_lifetime(). + +=back + +=head1 SEE ALSO + +L, L, L, L + +=head1 AUTHOR + +Gisle Aas + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 1994-2017 by Gisle Aas. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut + +__END__ + + +#ABSTRACT: HTTP style response message + diff --git a/lib/HTTP/Status.pm b/lib/HTTP/Status.pm new file mode 100644 index 0000000..8cf9974 --- /dev/null +++ b/lib/HTTP/Status.pm @@ -0,0 +1,348 @@ +package HTTP::Status; + +use strict; +use warnings; + +our $VERSION = '6.18'; + +require 5.002; # because we use prototypes + +use base 'Exporter'; +our @EXPORT = qw(is_info is_success is_redirect is_error status_message); +our @EXPORT_OK = qw(is_client_error is_server_error is_cacheable_by_default); + +# Note also addition of mnemonics to @EXPORT below + +# Unmarked codes are from RFC 7231 (2017-12-20) +# See also: +# https://www.iana.org/assignments/http-status-codes/http-status-codes.xhtml + +my %StatusCode = ( + 100 => 'Continue', + 101 => 'Switching Protocols', + 102 => 'Processing', # RFC 2518: WebDAV + 103 => 'Early Hints', # RFC 8297: Indicating Hints +# 104 .. 199 + 200 => 'OK', + 201 => 'Created', + 202 => 'Accepted', + 203 => 'Non-Authoritative Information', + 204 => 'No Content', + 205 => 'Reset Content', + 206 => 'Partial Content', # RFC 7233: Range Requests + 207 => 'Multi-Status', # RFC 4918: WebDAV + 208 => 'Already Reported', # RFC 5842: WebDAV bindings +# 209 .. 225 + 226 => 'IM used', # RFC 3229: Delta encoding +# 227 .. 299 + 300 => 'Multiple Choices', + 301 => 'Moved Permanently', + 302 => 'Found', + 303 => 'See Other', + 304 => 'Not Modified', # RFC 7232: Conditional Request + 305 => 'Use Proxy', + 307 => 'Temporary Redirect', + 308 => 'Permanent Redirect', # RFC 7528: Permanent Redirect +# 309 .. 399 + 400 => 'Bad Request', + 401 => 'Unauthorized', # RFC 7235: Authentication + 402 => 'Payment Required', + 403 => 'Forbidden', + 404 => 'Not Found', + 405 => 'Method Not Allowed', + 406 => 'Not Acceptable', + 407 => 'Proxy Authentication Required', # RFC 7235: Authentication + 408 => 'Request Timeout', + 409 => 'Conflict', + 410 => 'Gone', + 411 => 'Length Required', + 412 => 'Precondition Failed', # RFC 7232: Conditional Request + 413 => 'Request Entity Too Large', + 414 => 'Request-URI Too Large', + 415 => 'Unsupported Media Type', + 416 => 'Request Range Not Satisfiable', # RFC 7233: Range Requests + 417 => 'Expectation Failed', +# 418 .. 420 + 421 => 'Misdirected Request', # RFC 7540: HTTP/2 + 422 => 'Unprocessable Entity', # RFC 4918: WebDAV + 423 => 'Locked', # RFC 4918: WebDAV + 424 => 'Failed Dependency', # RFC 4918: WebDAV +# 425 + 426 => 'Upgrade Required', +# 427 + 428 => 'Precondition Required', # RFC 6585: Additional Codes + 429 => 'Too Many Requests', # RFC 6585: Additional Codes +# 430 + 431 => 'Request Header Fields Too Large', # RFC 6585: Additional Codes +# 432 .. 450 + 451 => 'Unavailable For Legal Reasons', # RFC 7724: Legal Obstacles +# 452 .. 499 + 500 => 'Internal Server Error', + 501 => 'Not Implemented', + 502 => 'Bad Gateway', + 503 => 'Service Unavailable', + 504 => 'Gateway Timeout', + 505 => 'HTTP Version Not Supported', + 506 => 'Variant Also Negotiates', # RFC 2295: Transparant Ngttn + 507 => 'Insufficient Storage', # RFC 4918: WebDAV + 508 => 'Loop Detected', # RFC 5842: WebDAV bindings +# 509 + 510 => 'Not Extended', # RFC 2774: Extension Framework + 511 => 'Network Authentication Required', # RFC 6585: Additional Codes +); + +# keep some unofficial codes that used to be in this distribution +%StatusCode = ( + %StatusCode, + 418 => 'I\'m a teapot', # RFC 2324: HTCPC/1.0 1-april + 425 => 'Unordered Collection', # WebDAV Draft + 449 => 'Retry with', # microsoft + 509 => 'Bandwidth Limit Exceeded', # Apache / cPanel +); + +my $mnemonicCode = ''; +my ($code, $message); +while (($code, $message) = each %StatusCode) { + # create mnemonic subroutines + $message =~ s/I'm/I am/; + $message =~ tr/a-z \-/A-Z__/; + $mnemonicCode .= "sub HTTP_$message () { $code }\n"; + $mnemonicCode .= "*RC_$message = \\&HTTP_$message;\n"; # legacy + $mnemonicCode .= "push(\@EXPORT_OK, 'HTTP_$message');\n"; + $mnemonicCode .= "push(\@EXPORT, 'RC_$message');\n"; +} +eval $mnemonicCode; # only one eval for speed +die if $@; + +# backwards compatibility +*RC_MOVED_TEMPORARILY = \&RC_FOUND; # 302 was renamed in the standard +push(@EXPORT, "RC_MOVED_TEMPORARILY"); + +*RC_NO_CODE = \&RC_UNORDERED_COLLECTION; +push(@EXPORT, "RC_NO_CODE"); + +our %EXPORT_TAGS = ( + constants => [grep /^HTTP_/, @EXPORT_OK], + is => [grep /^is_/, @EXPORT, @EXPORT_OK], +); + + +sub status_message ($) { $StatusCode{$_[0]}; } + +sub is_info ($) { $_[0] && $_[0] >= 100 && $_[0] < 200; } +sub is_success ($) { $_[0] && $_[0] >= 200 && $_[0] < 300; } +sub is_redirect ($) { $_[0] && $_[0] >= 300 && $_[0] < 400; } +sub is_error ($) { $_[0] && $_[0] >= 400 && $_[0] < 600; } +sub is_client_error ($) { $_[0] && $_[0] >= 400 && $_[0] < 500; } +sub is_server_error ($) { $_[0] && $_[0] >= 500 && $_[0] < 600; } +sub is_cacheable_by_default ($) { $_[0] && ( $_[0] == 200 # OK + || $_[0] == 203 # Non-Authoritative Information + || $_[0] == 204 # No Content + || $_[0] == 206 # Not Acceptable + || $_[0] == 300 # Multiple Choices + || $_[0] == 301 # Moved Permanently + || $_[0] == 404 # Not Found + || $_[0] == 405 # Method Not Allowed + || $_[0] == 410 # Gone + || $_[0] == 414 # Request-URI Too Large + || $_[0] == 451 # Unavailable For Legal Reasons + || $_[0] == 501 # Not Implemented + ); +} + +1; + +=pod + +=encoding UTF-8 + +=head1 NAME + +HTTP::Status - HTTP Status code processing + +=head1 VERSION + +version 6.18 + +=head1 SYNOPSIS + + use HTTP::Status qw(:constants :is status_message); + + if ($rc != HTTP_OK) { + print status_message($rc), "\n"; + } + + if (is_success($rc)) { ... } + if (is_error($rc)) { ... } + if (is_redirect($rc)) { ... } + +=head1 DESCRIPTION + +I is a library of routines for defining and +classifying HTTP status codes for libwww-perl. Status codes are +used to encode the overall outcome of an HTTP response message. Codes +correspond to those defined in RFC 2616 and RFC 2518. + +=head1 CONSTANTS + +The following constant functions can be used as mnemonic status code +names. None of these are exported by default. Use the C<:constants> +tag to import them all. + + HTTP_CONTINUE (100) + HTTP_SWITCHING_PROTOCOLS (101) + HTTP_PROCESSING (102) + HTTP_EARLY_HINTS (103) + + HTTP_OK (200) + HTTP_CREATED (201) + HTTP_ACCEPTED (202) + HTTP_NON_AUTHORITATIVE_INFORMATION (203) + HTTP_NO_CONTENT (204) + HTTP_RESET_CONTENT (205) + HTTP_PARTIAL_CONTENT (206) + HTTP_MULTI_STATUS (207) + HTTP_ALREADY_REPORTED (208) + + HTTP_IM_USED (226) + + HTTP_MULTIPLE_CHOICES (300) + HTTP_MOVED_PERMANENTLY (301) + HTTP_FOUND (302) + HTTP_SEE_OTHER (303) + HTTP_NOT_MODIFIED (304) + HTTP_USE_PROXY (305) + HTTP_TEMPORARY_REDIRECT (307) + HTTP_PERMANENT_REDIRECT (308) + + HTTP_BAD_REQUEST (400) + HTTP_UNAUTHORIZED (401) + HTTP_PAYMENT_REQUIRED (402) + HTTP_FORBIDDEN (403) + HTTP_NOT_FOUND (404) + HTTP_METHOD_NOT_ALLOWED (405) + HTTP_NOT_ACCEPTABLE (406) + HTTP_PROXY_AUTHENTICATION_REQUIRED (407) + HTTP_REQUEST_TIMEOUT (408) + HTTP_CONFLICT (409) + HTTP_GONE (410) + HTTP_LENGTH_REQUIRED (411) + HTTP_PRECONDITION_FAILED (412) + HTTP_REQUEST_ENTITY_TOO_LARGE (413) + HTTP_REQUEST_URI_TOO_LARGE (414) + HTTP_UNSUPPORTED_MEDIA_TYPE (415) + HTTP_REQUEST_RANGE_NOT_SATISFIABLE (416) + HTTP_EXPECTATION_FAILED (417) + HTTP_MISDIRECTED REQUEST (421) + HTTP_UNPROCESSABLE_ENTITY (422) + HTTP_LOCKED (423) + HTTP_FAILED_DEPENDENCY (424) + HTTP_UPGRADE_REQUIRED (426) + HTTP_PRECONDITION_REQUIRED (428) + HTTP_TOO_MANY_REQUESTS (429) + HTTP_REQUEST_HEADER_FIELDS_TOO_LARGE (431) + HTTP_UNAVAILABLE_FOR_LEGAL_REASONS (451) + + HTTP_INTERNAL_SERVER_ERROR (500) + HTTP_NOT_IMPLEMENTED (501) + HTTP_BAD_GATEWAY (502) + HTTP_SERVICE_UNAVAILABLE (503) + HTTP_GATEWAY_TIMEOUT (504) + HTTP_HTTP_VERSION_NOT_SUPPORTED (505) + HTTP_VARIANT_ALSO_NEGOTIATES (506) + HTTP_INSUFFICIENT_STORAGE (507) + HTTP_LOOP_DETECTED (508) + HTTP_NOT_EXTENDED (510) + HTTP_NETWORK_AUTHENTICATION_REQUIRED (511) + +=head1 FUNCTIONS + +The following additional functions are provided. Most of them are +exported by default. The C<:is> import tag can be used to import all +the classification functions. + +=over 4 + +=item status_message( $code ) + +The status_message() function will translate status codes to human +readable strings. The string is the same as found in the constant +names above. If the $code is not registered in the L +then C is returned. + +=item is_info( $code ) + +Return TRUE if C<$code> is an I status code (1xx). This +class of status code indicates a provisional response which can't have +any content. + +=item is_success( $code ) + +Return TRUE if C<$code> is a I status code (2xx). + +=item is_redirect( $code ) + +Return TRUE if C<$code> is a I status code (3xx). This class of +status code indicates that further action needs to be taken by the +user agent in order to fulfill the request. + +=item is_error( $code ) + +Return TRUE if C<$code> is an I status code (4xx or 5xx). The function +returns TRUE for both client and server error status codes. + +=item is_client_error( $code ) + +Return TRUE if C<$code> is a I status code (4xx). This class +of status code is intended for cases in which the client seems to have +erred. + +This function is B exported by default. + +=item is_server_error( $code ) + +Return TRUE if C<$code> is a I status code (5xx). This class +of status codes is intended for cases in which the server is aware +that it has erred or is incapable of performing the request. + +This function is B exported by default. + +=item is_cacheable_by_default( $code ) + +Return TRUE if C<$code> indicates that a response is cacheable by default, and +it can be reused by a cache with heuristic expiration. All other status codes +are not cacheable by default. See L. + +This function is B exported by default. + +=back + +=head1 SEE ALSO + +L + +=head1 BUGS + +For legacy reasons all the C constants are exported by default +with the prefix C. It's recommended to use explicit imports and +the C<:constants> tag instead of relying on this. + +=head1 AUTHOR + +Gisle Aas + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 1994-2017 by Gisle Aas. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut + +__END__ + + +#ABSTRACT: HTTP Status code processing diff --git a/perlcriticrc b/perlcriticrc new file mode 100644 index 0000000..7819a28 --- /dev/null +++ b/perlcriticrc @@ -0,0 +1,86 @@ +severity = 3 +verbose = 11 + +theme = core + pbp + bugs + maintenance + cosmetic + complexity + security + tests + moose + +exclude = Subroutines::ProhibitCallsToUndeclaredSubs + +[BuiltinFunctions::ProhibitStringySplit] +severity = 3 + +[CodeLayout::RequireTrailingCommas] +severity = 3 + +[ControlStructures::ProhibitCStyleForLoops] +severity = 3 + +[InputOutput::RequireCheckedSyscalls] +functions = :builtins +exclude_functions = sleep +severity = 3 + +[Moose::RequireCleanNamespace] +modules = Moose Moose::Role MooseX::Role::Parameterized Moose::Util::TypeConstraints +cleaners = namespace::autoclean + +[NamingConventions::Capitalization] +package_exemptions = [A-Z]\w+|minFraud +file_lexical_variables = [A-Z]\w+|[^A-Z]+ +global_variables = :starts_with_upper +scoped_lexical_variables = [A-Z]\w+|[^A-Z]+ +severity = 3 + +# Given our code base, leaving this at 5 would be a huge pain +[Subroutines::ProhibitManyArgs] +max_arguments = 10 + +[RegularExpressions::ProhibitComplexRegexes] +max_characters = 200 + +[RegularExpressions::ProhibitUnusualDelimiters] +severity = 3 + +[Subroutines::ProhibitUnusedPrivateSubroutines] +private_name_regex = _(?!build)\w+ +skip_when_using = Moo::Role Moose::Role MooseX::Role::Parameterized Role::Tiny Test::Class::Moose::Role + +[TestingAndDebugging::ProhibitNoWarnings] +allow = redefine + +[ValuesAndExpressions::ProhibitEmptyQuotes] +severity = 3 + +[ValuesAndExpressions::ProhibitInterpolationOfLiterals] +severity = 3 + +[ValuesAndExpressions::RequireUpperCaseHeredocTerminator] +severity = 3 + +[Variables::ProhibitPackageVars] +add_packages = Test::Builder + +[TestingAndDebugging::RequireUseStrict] + +[TestingAndDebugging::RequireUseWarnings] + +[-ControlStructures::ProhibitCascadingIfElse] + +[-ErrorHandling::RequireCarping] +[-InputOutput::RequireBriefOpen] + +[-ValuesAndExpressions::ProhibitConstantPragma] + +# No need for /xsm everywhere +[-RegularExpressions::RequireDotMatchAnything] +[-RegularExpressions::RequireExtendedFormatting] +[-RegularExpressions::RequireLineBoundaryMatching] + +[-Subroutines::ProhibitExplicitReturnUndef] + +# http://stackoverflow.com/questions/2275317/why-does-perlcritic-dislike-using-shift-to-populate-subroutine-variables +[-Subroutines::RequireArgUnpacking] + +[-Subroutines::RequireFinalReturn] + +# "use v5.14" is more readable than "use 5.014" +[-ValuesAndExpressions::ProhibitVersionStrings] diff --git a/perltidyrc b/perltidyrc new file mode 100644 index 0000000..b7ed624 --- /dev/null +++ b/perltidyrc @@ -0,0 +1,12 @@ +--blank-lines-before-packages=0 +--iterations=2 +--no-outdent-long-comments +-b +-bar +-boc +-ci=4 +-i=4 +-l=78 +-nolq +-se +-wbb="% + - * / x != == >= <= =~ !~ < > | & >= < = **= += *= &= <<= &&= -= /= |= >>= ||= .= %= ^= x=" diff --git a/t/00-report-prereqs.dd b/t/00-report-prereqs.dd new file mode 100644 index 0000000..daf8639 --- /dev/null +++ b/t/00-report-prereqs.dd @@ -0,0 +1,60 @@ +do { my $x = { + 'configure' => { + 'requires' => { + 'ExtUtils::MakeMaker' => '0', + 'perl' => '5.006' + }, + 'suggests' => { + 'JSON::PP' => '2.27300' + } + }, + 'develop' => { + 'requires' => { + 'Test::CPAN::Changes' => '0.19', + 'Test::More' => '0.96' + } + }, + 'runtime' => { + 'requires' => { + 'Carp' => '0', + 'Compress::Raw::Zlib' => '0', + 'Encode' => '2.21', + 'Encode::Locale' => '1', + 'Exporter' => '5.57', + 'HTTP::Date' => '6', + 'IO::Compress::Bzip2' => '2.021', + 'IO::Compress::Deflate' => '0', + 'IO::Compress::Gzip' => '0', + 'IO::HTML' => '0', + 'IO::Uncompress::Bunzip2' => '2.021', + 'IO::Uncompress::Gunzip' => '0', + 'IO::Uncompress::Inflate' => '0', + 'IO::Uncompress::RawInflate' => '0', + 'LWP::MediaTypes' => '6', + 'MIME::Base64' => '2.1', + 'MIME::QuotedPrint' => '0', + 'Storable' => '0', + 'URI' => '1.10', + 'base' => '0', + 'perl' => '5.008001', + 'strict' => '0', + 'warnings' => '0' + } + }, + 'test' => { + 'recommends' => { + 'CPAN::Meta' => '2.120900' + }, + 'requires' => { + 'ExtUtils::MakeMaker' => '0', + 'File::Spec' => '0', + 'PerlIO::encoding' => '0', + 'Test::More' => '0.88', + 'Time::Local' => '0', + 'Try::Tiny' => '0', + 'perl' => '5.008001' + } + } + }; + $x; + } \ No newline at end of file diff --git a/t/00-report-prereqs.t b/t/00-report-prereqs.t new file mode 100644 index 0000000..c72183a --- /dev/null +++ b/t/00-report-prereqs.t @@ -0,0 +1,193 @@ +#!perl + +use strict; +use warnings; + +# This test was generated by Dist::Zilla::Plugin::Test::ReportPrereqs 0.027 + +use Test::More tests => 1; + +use ExtUtils::MakeMaker; +use File::Spec; + +# from $version::LAX +my $lax_version_re = + qr/(?: undef | (?: (?:[0-9]+) (?: \. | (?:\.[0-9]+) (?:_[0-9]+)? )? + | + (?:\.[0-9]+) (?:_[0-9]+)? + ) | (?: + v (?:[0-9]+) (?: (?:\.[0-9]+)+ (?:_[0-9]+)? )? + | + (?:[0-9]+)? (?:\.[0-9]+){2,} (?:_[0-9]+)? + ) + )/x; + +# hide optional CPAN::Meta modules from prereq scanner +# and check if they are available +my $cpan_meta = "CPAN::Meta"; +my $cpan_meta_pre = "CPAN::Meta::Prereqs"; +my $HAS_CPAN_META = eval "require $cpan_meta; $cpan_meta->VERSION('2.120900')" && eval "require $cpan_meta_pre"; ## no critic + +# Verify requirements? +my $DO_VERIFY_PREREQS = 1; + +sub _max { + my $max = shift; + $max = ( $_ > $max ) ? $_ : $max for @_; + return $max; +} + +sub _merge_prereqs { + my ($collector, $prereqs) = @_; + + # CPAN::Meta::Prereqs object + if (ref $collector eq $cpan_meta_pre) { + return $collector->with_merged_prereqs( + CPAN::Meta::Prereqs->new( $prereqs ) + ); + } + + # Raw hashrefs + for my $phase ( keys %$prereqs ) { + for my $type ( keys %{ $prereqs->{$phase} } ) { + for my $module ( keys %{ $prereqs->{$phase}{$type} } ) { + $collector->{$phase}{$type}{$module} = $prereqs->{$phase}{$type}{$module}; + } + } + } + + return $collector; +} + +my @include = qw( + +); + +my @exclude = qw( + +); + +# Add static prereqs to the included modules list +my $static_prereqs = do './t/00-report-prereqs.dd'; + +# Merge all prereqs (either with ::Prereqs or a hashref) +my $full_prereqs = _merge_prereqs( + ( $HAS_CPAN_META ? $cpan_meta_pre->new : {} ), + $static_prereqs +); + +# Add dynamic prereqs to the included modules list (if we can) +my ($source) = grep { -f } 'MYMETA.json', 'MYMETA.yml'; +my $cpan_meta_error; +if ( $source && $HAS_CPAN_META + && (my $meta = eval { CPAN::Meta->load_file($source) } ) +) { + $full_prereqs = _merge_prereqs($full_prereqs, $meta->prereqs); +} +else { + $cpan_meta_error = $@; # capture error from CPAN::Meta->load_file($source) + $source = 'static metadata'; +} + +my @full_reports; +my @dep_errors; +my $req_hash = $HAS_CPAN_META ? $full_prereqs->as_string_hash : $full_prereqs; + +# Add static includes into a fake section +for my $mod (@include) { + $req_hash->{other}{modules}{$mod} = 0; +} + +for my $phase ( qw(configure build test runtime develop other) ) { + next unless $req_hash->{$phase}; + next if ($phase eq 'develop' and not $ENV{AUTHOR_TESTING}); + + for my $type ( qw(requires recommends suggests conflicts modules) ) { + next unless $req_hash->{$phase}{$type}; + + my $title = ucfirst($phase).' '.ucfirst($type); + my @reports = [qw/Module Want Have/]; + + for my $mod ( sort keys %{ $req_hash->{$phase}{$type} } ) { + next if $mod eq 'perl'; + next if grep { $_ eq $mod } @exclude; + + my $file = $mod; + $file =~ s{::}{/}g; + $file .= ".pm"; + my ($prefix) = grep { -e File::Spec->catfile($_, $file) } @INC; + + my $want = $req_hash->{$phase}{$type}{$mod}; + $want = "undef" unless defined $want; + $want = "any" if !$want && $want == 0; + + my $req_string = $want eq 'any' ? 'any version required' : "version '$want' required"; + + if ($prefix) { + my $have = MM->parse_version( File::Spec->catfile($prefix, $file) ); + $have = "undef" unless defined $have; + push @reports, [$mod, $want, $have]; + + if ( $DO_VERIFY_PREREQS && $HAS_CPAN_META && $type eq 'requires' ) { + if ( $have !~ /\A$lax_version_re\z/ ) { + push @dep_errors, "$mod version '$have' cannot be parsed ($req_string)"; + } + elsif ( ! $full_prereqs->requirements_for( $phase, $type )->accepts_module( $mod => $have ) ) { + push @dep_errors, "$mod version '$have' is not in required range '$want'"; + } + } + } + else { + push @reports, [$mod, $want, "missing"]; + + if ( $DO_VERIFY_PREREQS && $type eq 'requires' ) { + push @dep_errors, "$mod is not installed ($req_string)"; + } + } + } + + if ( @reports ) { + push @full_reports, "=== $title ===\n\n"; + + my $ml = _max( map { length $_->[0] } @reports ); + my $wl = _max( map { length $_->[1] } @reports ); + my $hl = _max( map { length $_->[2] } @reports ); + + if ($type eq 'modules') { + splice @reports, 1, 0, ["-" x $ml, "", "-" x $hl]; + push @full_reports, map { sprintf(" %*s %*s\n", -$ml, $_->[0], $hl, $_->[2]) } @reports; + } + else { + splice @reports, 1, 0, ["-" x $ml, "-" x $wl, "-" x $hl]; + push @full_reports, map { sprintf(" %*s %*s %*s\n", -$ml, $_->[0], $wl, $_->[1], $hl, $_->[2]) } @reports; + } + + push @full_reports, "\n"; + } + } +} + +if ( @full_reports ) { + diag "\nVersions for all modules listed in $source (including optional ones):\n\n", @full_reports; +} + +if ( $cpan_meta_error || @dep_errors ) { + diag "\n*** WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING ***\n"; +} + +if ( $cpan_meta_error ) { + my ($orig_source) = grep { -f } 'MYMETA.json', 'MYMETA.yml'; + diag "\nCPAN::Meta->load_file('$orig_source') failed with: $cpan_meta_error\n"; +} + +if ( @dep_errors ) { + diag join("\n", + "\nThe following REQUIRED prerequisites were not satisfied:\n", + @dep_errors, + "\n" + ); +} + +pass; + +# vim: ts=4 sts=4 sw=4 et: diff --git a/t/common-req.t b/t/common-req.t new file mode 100644 index 0000000..af5229c --- /dev/null +++ b/t/common-req.t @@ -0,0 +1,255 @@ +use strict; +use warnings; + +use Test::More; +plan tests => 64; + +use HTTP::Request::Common; + +my $r = GET 'http://www.sn.no/'; +note $r->as_string; + +is($r->method, "GET"); +is($r->uri, "http://www.sn.no/"); + +$r = HEAD "http://www.sn.no/", + If_Match => 'abc', + From => 'aas@sn.no'; +note $r->as_string; + +is($r->method, "HEAD"); +ok($r->uri->eq("http://www.sn.no")); + +is($r->header('If-Match'), "abc"); +is($r->header("from"), "aas\@sn.no"); + +$r = HEAD "http://www.sn.no/", + Content => 'foo'; +is($r->content, 'foo'); + +$r = HEAD "http://www.sn.no/", + Content => 'foo', + 'Content-Length' => 50; +is($r->content, 'foo'); +is($r->content_length, 50); + +$r = PUT "http://www.sn.no", + Content => 'foo'; +note $r->as_string, "\n"; + +is($r->method, "PUT"); +is($r->uri->host, "www.sn.no"); + +ok(!defined($r->header("Content"))); + +is(${$r->content_ref}, "foo"); +is($r->content, "foo"); +is($r->content_length, 3); + +$r = PUT "http://www.sn.no", + { foo => "bar" }; +is($r->content, "foo=bar"); + +$r = PATCH "http://www.sn.no", + { foo => "bar" }; +is($r->content, "foo=bar"); + +#--- Test POST requests --- + +$r = POST "http://www.sn.no", [foo => 'bar;baz', + baz => [qw(a b c)], + foo => 'zoo=&', + "space " => " + ", + "nl" => "a\nb\r\nc\n", + ], + bar => 'foo'; +note $r->as_string, "\n"; + +is($r->method, "POST"); +is($r->content_type, "application/x-www-form-urlencoded"); +is($r->content_length, 83); +is($r->header("bar"), "foo"); +is($r->content, "foo=bar%3Bbaz&baz=a&baz=b&baz=c&foo=zoo%3D%26&space+=+%2B+&nl=a%0D%0Ab%0D%0Ac%0D%0A"); + +$r = POST "http://example.com"; +is($r->content_length, 0); +is($r->content, ""); + +$r = POST "http://example.com", []; +is($r->content_length, 0); +is($r->content, ""); + +$r = POST "mailto:gisle\@aas.no", + Subject => "Heisan", + Content_Type => "text/plain", + Content => "Howdy\n"; +#note $r->as_string; + +is($r->method, "POST"); +is($r->header("Subject"), "Heisan"); +is($r->content, "Howdy\n"); +is($r->content_type, "text/plain"); + +{ + my @warnings; + local $SIG{__WARN__} = sub { push @warnings, @_ }; + $r = POST 'http://unf.ug/', []; + is( "@warnings", '', 'empty POST' ); +} + +# +# POST for File upload +# +my $file = "test-$$"; +open(FILE, ">$file") or die "Can't create $file: $!"; +print FILE "foo\nbar\nbaz\n"; +close(FILE); + +$r = POST 'http://www.perl.org/survey.cgi', + Content_Type => 'form-data', + Content => [ name => 'Gisle Aas', + email => 'gisle@aas.no', + gender => 'm', + born => '1964', + file => [$file], + ]; +#note $r->as_string; + +unlink($file) or warn "Can't unlink $file: $!"; + +is($r->method, "POST"); +is($r->uri->path, "/survey.cgi"); +is($r->content_type, "multipart/form-data"); +ok($r->header('Content_type') =~ /boundary="?([^"]+)"?/); +my $boundary = $1; + +my $c = $r->content; +$c =~ s/\r//g; +my @c = split(/--\Q$boundary/, $c); +note "$c[5]\n"; + +is(@c, 7); +like($c[6], qr/^--\n/); # 5 parts + header & trailer + +ok($c[2] =~ /^Content-Disposition:\s*form-data;\s*name="email"/m); +ok($c[2] =~ /^gisle\@aas.no$/m); + +ok($c[5] =~ /^Content-Disposition:\s*form-data;\s*name="file";\s*filename="$file"/m); +ok($c[5] =~ /^Content-Type:\s*text\/plain$/m); +ok($c[5] =~ /^foo\nbar\nbaz/m); + +$r = POST 'http://www.perl.org/survey.cgi', + [ file => [ undef, "xxy\"", Content_type => "text/html", Content => "

Hello, world!

" ]], + Content_type => 'multipart/form-data'; +#note $r->as_string; + +ok($r->content =~ /^--\S+\015\012Content-Disposition:\s*form-data;\s*name="file";\s*filename="xxy\\"/m); +ok($r->content =~ /^Content-Type: text\/html/m); +ok($r->content =~ /^

Hello, world/m); + +$r = POST 'http://www.perl.org/survey.cgi', + Content_type => 'multipart/form-data', + Content => [ file => [ undef, undef, Content => "foo"]]; +#note $r->as_string; + +unlike($r->content, qr/filename=/); + + +# The POST routine can now also take a hash reference. +my %hash = (foo => 42, bar => 24); +$r = POST 'http://www.perl.org/survey.cgi', \%hash; +#note $r->as_string, "\n"; +like($r->content, qr/foo=42/); +like($r->content, qr/bar=24/); +is($r->content_type, "application/x-www-form-urlencoded"); +is($r->content_length, 13); + + +# +# POST for File upload +# +use HTTP::Request::Common qw($DYNAMIC_FILE_UPLOAD); + +$file = "test-$$"; +open(FILE, ">$file") or die "Can't create $file: $!"; +for (1..1000) { + print FILE "a" .. "z"; +} +close(FILE); + +$DYNAMIC_FILE_UPLOAD++; +$r = POST 'http://www.perl.org/survey.cgi', + Content_Type => 'form-data', + Content => [ name => 'Gisle Aas', + email => 'gisle@aas.no', + gender => 'm', + born => '1964', + file => [$file], + ]; +#note $r->as_string, "\n"; + +is($r->method, "POST"); +is($r->uri->path, "/survey.cgi"); +is($r->content_type, "multipart/form-data"); +ok($r->header('Content_type') =~ qr/boundary="?([^"]+)"?/); +$boundary = $1; +is(ref($r->content), "CODE"); + +cmp_ok(length($boundary), '>', 10); + +my $code = $r->content; +my $chunk; +my @chunks; +while (defined($chunk = &$code) && length $chunk) { + push(@chunks, $chunk); +} + +unlink($file) or warn "Can't unlink $file: $!"; + +$_ = join("", @chunks); + +#note int(@chunks), " chunks, total size is ", length($_), " bytes\n"; + +# should be close to expected size and number of chunks +cmp_ok(abs(@chunks - 15), '<', 3); +cmp_ok(abs(length($_) - 26589), '<', 20); + +$r = POST 'http://www.example.com'; +is($r->as_string, < 'form-data', Content => []; +is($r->as_string, < 'form-data'; +#note $r->as_string; +is($r->as_string, <method, "DELETE"); + +$r = HTTP::Request::Common::PUT 'http://www.example.com', + 'Content-Type' => 'application/octet-steam', + 'Content' => 'foobarbaz', + 'Content-Length' => 12; # a slight lie +is($r->header('Content-Length'), 9); + +$r = HTTP::Request::Common::PATCH 'http://www.example.com', + 'Content-Type' => 'application/octet-steam', + 'Content' => 'foobarbaz', + 'Content-Length' => 12; # a slight lie +is($r->header('Content-Length'), 9); diff --git a/t/headers-auth.t b/t/headers-auth.t new file mode 100644 index 0000000..19bc32d --- /dev/null +++ b/t/headers-auth.t @@ -0,0 +1,48 @@ +use strict; +use warnings; + +use Test::More; + +plan tests => 9; + +use HTTP::Response; +use HTTP::Headers::Auth; + +my $res = HTTP::Response->new(401); +$res->push_header(WWW_Authenticate => qq(Foo realm="WallyWorld", foo=bar, Bar realm="WallyWorld2")); +$res->push_header(WWW_Authenticate => qq(Basic Realm="WallyWorld", foo=bar, bar=baz)); + +note $res->as_string; + +my %auth = $res->www_authenticate; + +is(keys(%auth), 3); + +is($auth{basic}{realm}, "WallyWorld"); +is($auth{bar}{realm}, "WallyWorld2"); + +$a = $res->www_authenticate; +is($a, 'Foo realm="WallyWorld", foo=bar, Bar realm="WallyWorld2", Basic Realm="WallyWorld", foo=bar, bar=baz'); + +$res->www_authenticate("Basic realm=foo1"); +note $res->as_string; + +$res->www_authenticate(Basic => {realm => "foo2"}); +print $res->as_string; + +$res->www_authenticate(Basic => [realm => "foo3", foo=>33], + Digest => {nonce=>"bar", foo=>'foo'}); +note $res->as_string; + +my $string = $res->as_string; + +like($string, qr/WWW-Authenticate: Basic realm="foo3", foo=33/); +like($string, qr/WWW-Authenticate: Digest (nonce=bar, foo=foo|foo=foo, nonce=bar)/); + +$res = HTTP::Response->new(401); +my @auth = $res->proxy_authenticate('foo'); +is_deeply(\@auth, []); +@auth = $res->proxy_authenticate('foo', 'bar'); +is_deeply(\@auth, ['foo', {}]); +@auth = $res->proxy_authenticate('foo', {'bar' => '_'}); +is_deeply(\@auth, ['foo', {}, 'bar', {}]); diff --git a/t/headers-etag.t b/t/headers-etag.t new file mode 100644 index 0000000..57692d7 --- /dev/null +++ b/t/headers-etag.t @@ -0,0 +1,45 @@ +use strict; +use warnings; + +use Test::More; + +plan tests => 11; + +require HTTP::Headers::ETag; + +my $h = HTTP::Headers->new; + +$h->etag("tag1"); +is($h->etag, qq("tag1")); + +$h->etag("w/tag2"); +is($h->etag, qq(W/"tag2")); + +$h->etag(" w/, weaktag"); +is($h->etag, qq(W/"", "weaktag")); +my @list = $h->etag; +is_deeply(\@list, ['W/""', '"weaktag"']); + +$h->etag(" w/"); +is($h->etag, qq(W/"")); + +$h->etag(" "); +is($h->etag, ""); + +$h->if_match(qq(W/"foo", bar, baz), "bar"); +$h->if_none_match(333); + +$h->if_range("tag3"); +is($h->if_range, qq("tag3")); + +my $t = time; +$h->if_range($t); +is($h->if_range, $t); + +note $h->as_string; + +@list = $h->if_range; +is($#list, 0); +is($list[0], $t); +$h->if_range(undef); +is($h->if_range, ''); diff --git a/t/headers-util.t b/t/headers-util.t new file mode 100644 index 0000000..4555221 --- /dev/null +++ b/t/headers-util.t @@ -0,0 +1,46 @@ +use strict; +use warnings; + +use Test::More; + +use HTTP::Headers::Util qw(split_header_words join_header_words); + +my @s_tests = ( + + ["foo" => "foo"], + ["foo=bar" => "foo=bar"], + [" foo " => "foo"], + ["foo=" => 'foo=""'], + ["foo=bar bar=baz" => "foo=bar; bar=baz"], + ["foo=bar;bar=baz" => "foo=bar; bar=baz"], + ['foo bar baz' => "foo; bar; baz"], + ['foo="\"" bar="\\\\"' => 'foo="\""; bar="\\\\"'], + ['foo,,,bar' => 'foo, bar'], + ['foo=bar,bar=baz' => 'foo=bar, bar=baz'], + + ['TEXT/HTML; CHARSET=ISO-8859-1' => + 'text/html; charset=ISO-8859-1'], + + ['foo="bar"; port="80,81"; discard, bar=baz' => + 'foo=bar; port="80,81"; discard, bar=baz'], + + ['Basic realm="\"foo\\\\bar\""' => + 'basic; realm="\"foo\\\\bar\""'], +); + +plan tests => @s_tests + 3; + +for (@s_tests) { + my($arg, $expect) = @$_; + my @arg = ref($arg) ? @$arg : $arg; + + my $res = join_header_words(split_header_words(@arg)); + is($res, $expect); +} + + +note "# Extra tests\n"; +# some extra tests +is(join_header_words("foo" => undef, "bar" => "baz"), "foo; bar=baz"); +is(join_header_words(), ""); +is(join_header_words([]), ""); diff --git a/t/headers.t b/t/headers.t new file mode 100644 index 0000000..55d42b1 --- /dev/null +++ b/t/headers.t @@ -0,0 +1,517 @@ +use strict; +use warnings; + +use Test::More; + +plan tests => 188; + +my($h, $h2); +sub j { join("|", @_) } + + +require HTTP::Headers; +$h = HTTP::Headers->new; +ok($h); +is(ref($h), "HTTP::Headers"); +is($h->as_string, ""); + +$h = HTTP::Headers->new(foo => "bar", foo => "baaaaz", Foo => "baz"); +is($h->as_string, "Foo: bar\nFoo: baaaaz\nFoo: baz\n"); + +$h = HTTP::Headers->new(foo => ["bar", "baz"]); +is($h->as_string, "Foo: bar\nFoo: baz\n"); + +$h = HTTP::Headers->new(foo => 1, bar => 2, foo_bar => 3); +is($h->as_string, "Bar: 2\nFoo: 1\nFoo-Bar: 3\n"); +is($h->as_string(";"), "Bar: 2;Foo: 1;Foo-Bar: 3;"); + +is($h->header("Foo"), 1); +is($h->header("FOO"), 1); +is(j($h->header("foo")), 1); +is($h->header("foo-bar"), 3); +is($h->header("foo_bar"), 3); +is($h->header("Not-There"), undef); +is(j($h->header("Not-There")), ""); +is(eval { $h->header }, undef); +ok($@); + +is($h->header("Foo", 11), 1); +is($h->header("Foo", [1, 1]), 11); +is($h->header("Foo"), "1, 1"); +is(j($h->header("Foo")), "1|1"); +is($h->header(foo => 11, Foo => 12, bar => 22), 2); +is($h->header("Foo"), "11, 12"); +is($h->header("Bar"), 22); +is($h->header("Bar", undef), 22); +is(j($h->header("bar", 22)), ""); + +$h->push_header(Bar => 22); +is($h->header("Bar"), "22, 22"); +$h->push_header(Bar => [23 .. 25]); +is($h->header("Bar"), "22, 22, 23, 24, 25"); +is(j($h->header("Bar")), "22|22|23|24|25"); + +$h->clear; +$h->header(Foo => 1); +is($h->as_string, "Foo: 1\n"); +$h->init_header(Foo => 2); +$h->init_header(Bar => 2); +is($h->as_string, "Bar: 2\nFoo: 1\n"); +$h->init_header(Foo => [2, 3]); +$h->init_header(Baz => [2, 3]); +is($h->as_string, "Bar: 2\nBaz: 2\nBaz: 3\nFoo: 1\n"); + +eval { $h->init_header(A => 1, B => 2, C => 3) }; +ok($@); +is($h->as_string, "Bar: 2\nBaz: 2\nBaz: 3\nFoo: 1\n"); + +is($h->clone->remove_header("Foo"), 1); +is($h->clone->remove_header("Bar"), 1); +is($h->clone->remove_header("Baz"), 2); +is($h->clone->remove_header(qw(Foo Bar Baz Not-There)), 4); +is($h->clone->remove_header("Not-There"), 0); +is(j($h->clone->remove_header("Foo")), 1); +is(j($h->clone->remove_header("Bar")), 2); +is(j($h->clone->remove_header("Baz")), "2|3"); +is(j($h->clone->remove_header(qw(Foo Bar Baz Not-There))), "1|2|2|3"); +is(j($h->clone->remove_header("Not-There")), ""); + +$h = HTTP::Headers->new( + allow => "GET", + content => "none", + content_type => "text/html", + content_md5 => "dummy", + content_encoding => "gzip", + content_foo => "bar", + last_modified => "yesterday", + expires => "tomorrow", + etag => "abc", + date => "today", + user_agent => "libwww-perl", + zoo => "foo", + ); +is($h->as_string, <clone; +is($h->as_string, $h2->as_string); + +is($h->remove_content_headers->as_string, <as_string, <remove_content_headers; +is($h->as_string, $h2->as_string); + +$h->clear; +is($h->as_string, ""); +undef($h2); + +$h = HTTP::Headers->new; +is($h->header_field_names, 0); +is(j($h->header_field_names), ""); + +$h = HTTP::Headers->new( etag => 1, foo => [2,3], + content_type => "text/plain"); +is($h->header_field_names, 3); +is(j($h->header_field_names), "ETag|Content-Type|Foo"); + +{ + my @tmp; + $h->scan(sub { push(@tmp, @_) }); + is(j(@tmp), "ETag|1|Content-Type|text/plain|Foo|2|Foo|3"); + + @tmp = (); + eval { $h->scan(sub { push(@tmp, @_); die if $_[0] eq "Content-Type" }) }; + ok($@); + is(j(@tmp), "ETag|1|Content-Type|text/plain"); + + @tmp = (); + $h->scan(sub { push(@tmp, @_) }); + is(j(@tmp), "ETag|1|Content-Type|text/plain|Foo|2|Foo|3"); +} + +# CONVENIENCE METHODS + +$h = HTTP::Headers->new; +is($h->date, undef); +is($h->date(time), undef); +is(j($h->header_field_names), "Date"); +like($h->header("Date"), qr/^[A-Z][a-z][a-z], \d\d .* GMT$/); +{ + my $off = time - $h->date; + ok($off == 0 || $off == 1); +} + +if ($] < 5.006) { + Test::skip("Can't call variable method", 1) for 1..13; +} +else { +# other date fields +for my $field (qw(expires if_modified_since if_unmodified_since + last_modified)) +{ + eval <<'EOT'; die $@ if $@; + is($h->$field, undef); + is($h->$field(time), undef); + like((time - $h->$field), qr/^[01]$/); +EOT +} +is(j($h->header_field_names), "Date|If-Modified-Since|If-Unmodified-Since|Expires|Last-Modified"); +} + +$h->clear; +is($h->content_type, ""); +is($h->content_type(""), ""); +is($h->content_type("text/html"), ""); +is($h->content_type, "text/html"); +is($h->content_type(" TEXT / HTML ") , "text/html"); +is($h->content_type, "text/html"); +is(j($h->content_type), "text/html"); +is($h->content_type("text/html;\n charSet = \"ISO-8859-1\"; Foo=1 "), "text/html"); +is($h->content_type, "text/html"); +is(j($h->content_type), "text/html|charSet = \"ISO-8859-1\"; Foo=1 "); +is($h->header("content_type"), "text/html;\n charSet = \"ISO-8859-1\"; Foo=1 "); +ok($h->content_is_html); +ok(!$h->content_is_xhtml); +ok(!$h->content_is_xml); +$h->content_type("application/vnd.wap.xhtml+xml"); +ok($h->content_is_html); +ok($h->content_is_xhtml); +ok($h->content_is_xml); +$h->content_type("text/xml"); +ok(!$h->content_is_html); +ok(!$h->content_is_xhtml); +ok($h->content_is_xml); +$h->content_type("application/xhtml+xml"); +ok($h->content_is_html); +ok($h->content_is_xhtml); +ok($h->content_is_xml); +is($h->content_type("text/html;\n charSet = \"ISO-8859-1\"; Foo=1 "), "application/xhtml+xml"); + +is($h->content_encoding, undef); +is($h->content_encoding("gzip"), undef); +is($h->content_encoding, "gzip"); +is(j($h->header_field_names), "Content-Encoding|Content-Type"); + +is($h->content_language, undef); +is($h->content_language("no"), undef); +is($h->content_language, "no"); + +is($h->title, undef); +is($h->title("This is a test"), undef); +is($h->title, "This is a test"); + +is($h->user_agent, undef); +is($h->user_agent("Mozilla/1.2"), undef); +is($h->user_agent, "Mozilla/1.2"); + +is($h->server, undef); +is($h->server("Apache/2.1"), undef); +is($h->server, "Apache/2.1"); + +is($h->from("Gisle\@ActiveState.com"), undef); +ok($h->header("from", "Gisle\@ActiveState.com")); + +is($h->referer("http://www.example.com"), undef); +is($h->referer, "http://www.example.com"); +is($h->referrer, "http://www.example.com"); +is($h->referer("http://www.example.com/#bar"), "http://www.example.com"); +is($h->referer, "http://www.example.com/"); +{ + require URI; + my $u = URI->new("http://www.example.com#bar"); + $h->referer($u); + is($u->as_string, "http://www.example.com#bar"); + is($h->referer->fragment, undef); + is($h->referrer->as_string, "http://www.example.com"); +} + +is($h->as_string, <clear; +is($h->www_authenticate("foo"), undef); +is($h->www_authenticate("bar"), "foo"); +is($h->www_authenticate, "bar"); +is($h->proxy_authenticate("foo"), undef); +is($h->proxy_authenticate("bar"), "foo"); +is($h->proxy_authenticate, "bar"); + +is($h->authorization_basic, undef); +is($h->authorization_basic("u"), undef); +is($h->authorization_basic("u", "p"), "u:"); +is($h->authorization_basic, "u:p"); +is(j($h->authorization_basic), "u|p"); +is($h->authorization, "Basic dTpw"); + +is(eval { $h->authorization_basic("u2:p") }, undef); +ok($@); +is(j($h->authorization_basic), "u|p"); + +is($h->proxy_authorization_basic("u2", "p2"), undef); +is(j($h->proxy_authorization_basic), "u2|p2"); +is($h->proxy_authorization, "Basic dTI6cDI="); + +is($h->as_string, <new; +eval { + $line = __LINE__; $h->header('foo:', 1); +}; +like($@, qr/^Illegal field name 'foo:' at \Q$file\E line $line/); +eval { + $line = __LINE__; $h->header('', 2); +}; +like($@, qr/^Illegal field name '' at \Q$file\E line $line/); + + + +#---- old tests below ----- + +$h = HTTP::Headers->new( + mime_version => "1.0", + content_type => "text/html" +); +$h->header(URI => "http://www.oslonett.no/"); + +is($h->header("MIME-Version"), "1.0"); +is($h->header('Uri'), "http://www.oslonett.no/"); + +$h->header("MY-header" => "foo", + "Date" => "somedate", + "Accept" => ["text/plain", "image/*"], + ); +$h->push_header("accept" => "audio/basic"); + +is($h->header("date"), "somedate"); + +my @accept = $h->header("accept"); +is(@accept, 3); + +$h->remove_header("uri", "date"); + +my $str = $h->as_string; +my $lines = ($str =~ tr/\n/\n/); +is($lines, 6); + +$h2 = $h->clone; + +$h->header("accept", "*/*"); +$h->remove_header("my-header"); + +@accept = $h2->header("accept"); +is(@accept, 3); + +@accept = $h->header("accept"); +is(@accept, 1); + +# Check order of headers, but first remove this one +$h2->remove_header('mime_version'); + +# and add this general header +$h2->header(Connection => 'close'); + +my @x = (); +$h2->scan(sub {push(@x, shift);}); +is(join(";", @x), "Connection;Accept;Accept;Accept;Content-Type;MY-Header"); + +# Check headers with embedded newlines: +$h = HTTP::Headers->new( + a => "foo\n\n", + b => "foo\nbar", + c => "foo\n\nbar\n\n", + d => "foo\n\tbar", + e => "foo\n bar ", + f => "foo\n bar\n baz\nbaz", + ); +is($h->as_string("<<\n"), <new( + a => "foo\r\n\r\nevil body" , + b => "foo\015\012\015\012evil body" , + c => "foo\x0d\x0a\x0d\x0aevil body" , +); +is ( + $h->as_string(), + "A: foo\r\n evil body\n". + "B: foo\015\012 evil body\n" . + "C: foo\x0d\x0a evil body\n" , + "embedded CRLF are stripped out"); + +# Check with FALSE $HTML::Headers::TRANSLATE_UNDERSCORE +{ + local($HTTP::Headers::TRANSLATE_UNDERSCORE); + $HTTP::Headers::TRANSLATE_UNDERSCORE = undef; # avoid -w warning + + $h = HTTP::Headers->new; + $h->header(abc_abc => "foo"); + $h->header("abc-abc" => "bar"); + + is($h->header("ABC_ABC"), "foo"); + is($h->header("ABC-ABC"),"bar"); + ok($h->remove_header("Abc_Abc")); + ok(!defined($h->header("abc_abc"))); + is($h->header("ABC-ABC"), "bar"); +} + +# Check if objects as header values works +require URI; +$h->header(URI => URI->new("http://www.perl.org")); + +is($h->header("URI")->scheme, "http"); + +$h->clear; +is($h->as_string, ""); + +$h->content_type("text/plain"); +$h->header(content_md5 => "dummy"); +$h->header("Content-Foo" => "foo"); +$h->header(Location => "http:", xyzzy => "plugh!"); + +is($h->as_string, <remove_content_headers; +is($h->as_string, <as_string, <new; +$h->content_type("text/plain"); +$h->header(":foo_bar", 1); +$h->push_header(":content_type", "text/html"); +is(j($h->header_field_names), "Content-Type|:content_type|:foo_bar"); +is($h->header('Content-Type'), "text/plain"); +is($h->header(':Content_Type'), undef); +is($h->header(':content_type'), "text/html"); +is($h->as_string, <new; +ok(!defined $h->warning('foo', 'INIT')); +is($h->warning('bar'), 'foo'); +is($h->warning('baz', 'GET'), 'bar'); +is($h->as_string, <new; +ok(!defined $h->header(':foo', 'bar')); +ok(!defined $h->header(':zap', 'bang')); +$h->push_header(':zap', ['kapow', 'shazam']); +is(j($h->header_field_names), ':foo|:zap'); +is(j($h->header_field_names), ':foo|:zap'); +$h->scan(sub { $_[1] .= '!' }); +is(j($h->header(':zap')), 'bang!|kapow!|shazam!'); +is(j($h->header(':foo')), 'bar'); +is($h->as_string, <remove_header(':zap')), 'bang!|kapow!|shazam!'); +$h->push_header(':zap', 'whomp', ':foo', 'quux'); +is(j($h->header(':foo')), 'bar|quux'); + +# [RT#30579] IE6 appens "; length = NNNN" on If-Modified-Since (can we handle it) +$h = HTTP::Headers->new( + if_modified_since => "Sat, 29 Oct 1994 19:43:31 GMT; length=34343" +); +is(gmtime($h->if_modified_since), "Sat Oct 29 19:43:31 1994"); + +$h = HTTP::Headers->new(); +$h->content_type('text/plain'); +$h->content_length(4); +$h->push_header('x-foo' => 'bar'); +$h->push_header('x-foo' => 'baz'); +is(0+$h->flatten, 8); +is_deeply( + [ $h->flatten ], + [ + 'Content-Length', + 4, + 'Content-Type', + 'text/plain', + 'X-Foo', + 'bar', + 'X-Foo', + 'baz', + ], +); + diff --git a/t/http-config.t b/t/http-config.t new file mode 100644 index 0000000..c0b8825 --- /dev/null +++ b/t/http-config.t @@ -0,0 +1,106 @@ +use strict; +use warnings; + +use Test::More; +plan tests => 28; + +use HTTP::Config; + +sub j { join("|", @_) } + +my $conf = HTTP::Config->new; +ok($conf->empty); +is($conf->entries, 0); +$conf->add_item(42); +ok(!$conf->empty); +is($conf->entries, 1); +is(j($conf->matching_items("http://www.example.com/foo")), 42); +is(j($conf->remove_items), 42); +is(j($conf->remove_items), ''); +is($conf->matching_items("http://www.example.com/foo"), 0); +is($conf->matching_items('foo', 'bar', 'baz'), 0); +$conf->add({item => "http://www.example.com/foo", m_uri__HEAD => undef}); +is($conf->entries, 1); +is($conf->matching_items("http://www.example.com/foo"), 0); +SKIP: { + my $res; + eval { $res = $conf->matching_items(0); }; + skip "can fails on non-object", 2 if $@; + is($res, 0); + eval { $res = $conf->matching(0); }; + ok(!defined $res); +} + +$conf = HTTP::Config->new; + +$conf->add_item("always"); +$conf->add_item("GET", m_method => ["GET", "HEAD"]); +$conf->add_item("POST", m_method => "POST"); +$conf->add_item(".com", m_domain => ".com"); +$conf->add_item("secure", m_secure => 1); +$conf->add_item("not secure", m_secure => 0); +$conf->add_item("slash", m_host_port => "www.example.com:80", m_path_prefix => "/"); +$conf->add_item("u:p", m_host_port => "www.example.com:80", m_path_prefix => "/foo"); +$conf->add_item("success", m_code => "2xx"); +is($conf->find(m_domain => ".com")->{item}, '.com'); +my @found = $conf->find(m_domain => ".com"); +is($#found, 0); +is($found[0]->{item}, '.com'); + +use HTTP::Request; +my $request = HTTP::Request->new(HEAD => "http://www.example.com/foo/bar"); +$request->header("User-Agent" => "Moz/1.0"); + +is(j($conf->matching_items($request)), "u:p|slash|.com|GET|not secure|always"); + +$request->method("HEAD"); +$request->uri->scheme("https"); + +is(j($conf->matching_items($request)), ".com|GET|secure|always"); + +is(j($conf->matching_items("http://activestate.com")), ".com|not secure|always"); + +use HTTP::Response; +my $response = HTTP::Response->new(200 => "OK"); +$response->content_type("text/plain"); +$response->content("Hello, world!\n"); +$response->request($request); + +is(j($conf->matching_items($response)), ".com|success|GET|secure|always"); + +$conf->remove_items(m_secure => 1); +$conf->remove_items(m_domain => ".com"); +is(j($conf->matching_items($response)), "success|GET|always"); + +$conf->remove_items; # start fresh +is(j($conf->matching_items($response)), ""); + +$conf->add_item("any", "m_media_type" => "*/*"); +$conf->add_item("text", m_media_type => "text/*"); +$conf->add_item("html", m_media_type => "html"); +$conf->add_item("HTML", m_media_type => "text/html"); +$conf->add_item("xhtml", m_media_type => "xhtml"); + +is(j($conf->matching_items($response)), "text|any"); + +$response->content_type("application/xhtml+xml"); +is(j($conf->matching_items($response)), "xhtml|html|any"); + +$response->content_type("text/html"); +is(j($conf->matching_items($response)), "HTML|html|text|any"); + +$response->request(undef); +is(j($conf->matching_items($response)), "HTML|html|text|any"); + +{ + my @warnings; + local $SIG{__WARN__} = sub { push @warnings, grep { length } @_ }; + + my $conf = HTTP::Config->new; + $conf->add(owner => undef, callback => sub { 'bleah' }); + $conf->remove(owner => undef); + + ok(($conf->empty), 'found and removed the config entry'); + is(scalar(@warnings), 0, 'no warnings') + or diag('got warnings: ', explain(\@warnings)); +} diff --git a/t/message-charset.t b/t/message-charset.t new file mode 100644 index 0000000..f6ad9f4 --- /dev/null +++ b/t/message-charset.t @@ -0,0 +1,124 @@ +use strict; +use warnings; + +use Test::More; +plan tests => 43; + +use HTTP::Response; +my $r = HTTP::Response->new(200, "OK"); +is($r->content_charset, undef); +is($r->content_type_charset, undef); + +$r->content_type("text/plain"); +is($r->content_charset, undef); + +$r->content("abc"); +is($r->content_charset, "US-ASCII"); + +$r->content("f\xE5rep\xF8lse\n"); +is($r->content_charset, "ISO-8859-1"); + +$r->content("f\xC3\xA5rep\xC3\xB8lse\n"); +is($r->content_charset, "UTF-8"); + +$r->content_type("text/html"); +$r->content(<<'EOT'); + +EOT +is($r->content_charset, "UTF-8"); + +$r->content(<<'EOT'); + + + +EOT +is($r->content_charset, "UTF-8"); + +$r->content(<<'EOT'); +