├── .github ├── dependabot.yml └── workflows │ └── build-and-test.yml ├── .gitignore ├── .mailmap ├── CONTRIBUTING.md ├── Changes ├── Install ├── LICENSE ├── META.json ├── Makefile.PL ├── README.md ├── cpanfile ├── dist.ini ├── lib └── HTTP │ ├── Config.pm │ ├── Headers.pm │ ├── Headers │ ├── Auth.pm │ ├── ETag.pm │ └── Util.pm │ ├── Message.pm │ ├── Request.pm │ ├── Request │ └── Common.pm │ ├── Response.pm │ └── Status.pm ├── perlcriticrc ├── perltidyrc ├── t ├── common-req.t ├── headers-auth.t ├── headers-etag.t ├── headers-util.t ├── headers.t ├── http-config.t ├── lib │ └── Secret.pm ├── message-brotli.t ├── message-charset.t ├── message-decode-brotlibomb.t ├── message-decode-bzipbomb.t ├── message-decode-xml.t ├── message-decode-zipbomb.t ├── message-old.t ├── message-parts.t ├── message.t ├── request.t ├── request_type_with_data.t ├── response.t ├── status-old.t └── status.t └── tidyall.ini /.github/dependabot.yml: -------------------------------------------------------------------------------- 1 | --- 2 | version: 2 3 | updates: 4 | 5 | - package-ecosystem: "github-actions" 6 | directory: "/" 7 | schedule: 8 | # Check for updates to GitHub Actions every week 9 | interval: "weekly" 10 | -------------------------------------------------------------------------------- /.github/workflows/build-and-test.yml: -------------------------------------------------------------------------------- 1 | --- 2 | name: dzil build and test 3 | 4 | on: 5 | push: 6 | branches: 7 | - "master" 8 | pull_request: 9 | branches: 10 | - "*" 11 | workflow_dispatch: 12 | 13 | jobs: 14 | build: 15 | name: Build distribution 16 | runs-on: ubuntu-latest 17 | strategy: 18 | max-parallel: 1 19 | container: 20 | image: perldocker/perl-tester:5.38 21 | steps: 22 | - uses: actions/checkout@v4 23 | - name: Allow for file ownership conflicts with Docker and GitHub Actions 24 | run: git config --global --add safe.directory '*' 25 | - name: Run Tests with coverage 26 | env: 27 | AUTHOR_TESTING: 1 28 | CODECOV_TOKEN: ${{secrets.CODECOV_TOKEN}} 29 | RELEASE_TESTING: 1 30 | run: auto-build-and-test-dist 31 | - uses: actions/upload-artifact@v4 32 | with: 33 | name: build_dir 34 | path: build_dir 35 | test_linux: 36 | runs-on: ubuntu-latest 37 | name: Perl ${{ matrix.perl-version }} on ubuntu-latest 38 | needs: build 39 | strategy: 40 | matrix: 41 | perl-version: 42 | - "5.10" 43 | - "5.12" 44 | - "5.14" 45 | - "5.16" 46 | - "5.18" 47 | - "5.20" 48 | - "5.22" 49 | - "5.24" 50 | - "5.26" 51 | - "5.28" 52 | - "5.30" 53 | - "5.32" 54 | - "5.34" 55 | - "5.36" 56 | - "5.38" 57 | container: 58 | image: perldocker/perl-tester:${{ matrix.perl-version }} 59 | env: 60 | AUTHOR_TESTING: 1 61 | steps: 62 | - name: Decide if we need to install recommended modules 63 | id: with-recommends 64 | if: matrix.perl-version >= 5.14 65 | run: echo '::set-output name=flag::--with-recommends' 66 | - uses: actions/download-artifact@v4 67 | with: 68 | name: build_dir 69 | path: . 70 | - name: Install deps 71 | if: success() 72 | run: > 73 | cpm install -g 74 | --cpanfile cpanfile 75 | --with-develop 76 | ${{ steps.with-recommends.outputs.flag }} 77 | --with-suggests 78 | --show-build-log-on-failure 79 | - name: Run Tests 80 | if: success() 81 | run: prove -lr --jobs 2 t 82 | test_macos: 83 | runs-on: ${{ matrix.os }} 84 | strategy: 85 | fail-fast: true 86 | matrix: 87 | os: ["macos-latest"] 88 | perl-version: 89 | - "5.10" 90 | - "5.12" 91 | - "5.14" 92 | - "5.16" 93 | - "5.18" 94 | - "5.20" 95 | - "5.22" 96 | - "5.24" 97 | - "5.26" 98 | - "5.28" 99 | - "5.30" 100 | - "5.32" 101 | - "5.34" 102 | - "5.36" 103 | - "5.38" 104 | name: Perl ${{ matrix.perl-version }} on ${{ matrix.os }} 105 | needs: build 106 | steps: 107 | - uses: actions/checkout@v4 108 | - name: Set Up Perl 109 | uses: shogo82148/actions-setup-perl@v1 110 | with: 111 | perl-version: ${{ matrix.perl-version }} 112 | - name: Decide if we need to install recommended modules 113 | id: with-recommends 114 | if: matrix.perl-version >= 5.14 115 | run: echo '::set-output name=flag::--with-recommends' 116 | - uses: actions/download-artifact@v4 117 | with: 118 | name: build_dir 119 | path: . 120 | - run: perl -V 121 | - name: install deps using cpanm 122 | uses: perl-actions/install-with-cpm@v1 123 | with: 124 | cpanfile: "cpanfile" 125 | args: > 126 | --with-develop 127 | ${{ steps.with-recommends.outputs.flag }} 128 | --with-suggests 129 | --with-test 130 | --mirror https://cpan.metacpan.org 131 | --mirror http://cpan.cpantesters.org 132 | - run: prove -lr t 133 | env: 134 | AUTHOR_TESTING: 1 135 | test_windows: 136 | runs-on: ${{ matrix.os }} 137 | strategy: 138 | fail-fast: false 139 | matrix: 140 | os: ["windows-latest"] 141 | perl-version: 142 | # https://github.com/shogo82148/actions-setup-perl/issues/223 143 | # - "5.10" 144 | # - "5.12" 145 | - "5.14" 146 | - "5.16" 147 | - "5.18" 148 | - "5.20" 149 | - "5.22" 150 | - "5.24" 151 | - "5.26" 152 | - "5.28" 153 | - "5.30" 154 | - "5.32" 155 | # As of 2022-06-06 5.32 is the latest Strawberry Perl 156 | # - "5.34" 157 | # - "5.36" 158 | name: Perl ${{ matrix.perl-version }} on ${{ matrix.os }} 159 | needs: build 160 | steps: 161 | - uses: actions/checkout@v4 162 | - name: Set Up Perl 163 | uses: shogo82148/actions-setup-perl@v1 164 | with: 165 | perl-version: ${{ matrix.perl-version }} 166 | distribution: strawberry 167 | - uses: actions/download-artifact@v4 168 | with: 169 | name: build_dir 170 | path: . 171 | - name: install deps using cpanm 172 | uses: perl-actions/install-with-cpanm@v1 173 | with: 174 | cpanfile: "cpanfile" 175 | args: "--mirror https://cpan.metacpan.org --mirror http://cpan.cpantesters.org" 176 | - run: perl -V 177 | - run: prove -lr t 178 | env: 179 | AUTHOR_TESTING: 1 180 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | /.ackrc 3 | /blib/ 4 | .build 5 | /_eumm/ 6 | !/.gitignore 7 | /HTTP-Message-*/ 8 | /HTTP-Message-*.tar.gz 9 | /Makefile 10 | /Makefile.old 11 | /MANIFEST.bak 12 | /MANIFEST.SKIP.bak 13 | /MYMETA.* 14 | .perl-version 15 | /pm_to_blib 16 | *.sw* 17 | .tidyall.d 18 | .vscode/ 19 | -------------------------------------------------------------------------------- /.mailmap: -------------------------------------------------------------------------------- 1 | # https://www.kernel.org/pub/software/scm/git/docs/git-shortlog.html#_mapping_authors 2 | Chase Whitener 3 | Chase Whitener 4 | Christopher J. Madsen 5 | Gisle Aas 6 | Gisle Aas 7 | Gisle Aas 8 | Gisle Aas 9 | Jason A Fesler Jason Fesler 10 | Jason A Fesler 11 | Jason A Fesler 12 | Karen Etheridge 13 | Mark Stosberg 14 | Mark Stosberg 15 | Mike Schilli mschilli 16 | Mike Schilli Mike Schilli 17 | Slaven Rezic 18 | Ville Skyttä Ville Skytta 19 | Mickey Nasriachi mickey 20 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | # HOW TO CONTRIBUTE 2 | 3 | Thank you for considering contributing to this distribution. This file 4 | contains instructions that will help you work with the source code. 5 | 6 | The distribution is managed with [Dist::Zilla](https://metacpan.org/pod/Dist::Zilla). 7 | This means that many of the usual files you might expect are not in the 8 | repository, but are generated at release time. Some generated files are kept 9 | in the repository as a convenience (Makefile.PL, META.json, and cpanfile). 10 | 11 | Generally, **you do not need Dist::Zilla to contribute patches**. You may need 12 | Dist::Zilla to create a tarball. See below for guidance. 13 | 14 | ## Getting dependencies 15 | 16 | If you have App::cpanminus 1.6 or later installed, you can use 17 | [cpanm](https://metacpan.org/pod/cpanm) to satisfy dependencies like this: 18 | 19 | $ cpanm --installdeps --with-develop . 20 | 21 | You can also run this command (or any other cpanm command) without installing 22 | App::cpanminus first, using the fatpacked `cpanm` script via curl or wget: 23 | 24 | $ curl -L https://cpanmin.us | perl - --installdeps --with-develop . 25 | $ wget -qO - https://cpanmin.us | perl - --installdeps --with-develop . 26 | 27 | Otherwise, look for either a `cpanfile` or `META.json` file for a list of 28 | dependencies to satisfy. 29 | 30 | ## Running tests 31 | 32 | You can run tests directly using the `prove` tool: 33 | 34 | $ prove -l 35 | $ prove -lv t/some_test_file.t 36 | 37 | 38 | ## Code style and tidying 39 | 40 | This distribution contains a `.perltidyrc` file in the root of the repository. 41 | Please install Perl::Tidy and use `perltidy` before submitting patches. However, 42 | as this is an old distribution and styling has changed somewhat over the years, 43 | please keep your tidying constrained to the portion of code or function in which 44 | you're patching. 45 | 46 | $ perltidy -pro=perltidyrc lib/HTTP/Status.pm -o my_tidy_copy.pm 47 | ... 48 | $ rm my_tidy_copy.pm 49 | 50 | The above command, for example, would provide you with a copy of `Status.pm` 51 | that has been cleaned according to our `.perltidyrc` settings. You'd then look 52 | at the newly created `my_tidy_copy.pm` in the dist root and replace your work 53 | with the cleaned up copy if there are differences. 54 | 55 | This may seem like an arbitrary thing, but it is immensely helpful if all code 56 | is written in a singular style. If everything were tidy, it'd look like one 57 | single person wrote the code rather than a mish-mash. 58 | 59 | ## Installing and using Dist::Zilla 60 | 61 | [Dist::Zilla](https://metacpan.org/pod/Dist::Zilla) is a very powerful 62 | authoring tool, optimized for maintaining a large number of distributions with 63 | a high degree of automation, but it has a large dependency chain, a bit of a 64 | learning curve and requires a number of author-specific plugins. 65 | 66 | To install it from CPAN, I recommend one of the following approaches for the 67 | quickest installation: 68 | 69 | # using CPAN.pm, but bypassing non-functional pod tests 70 | $ cpan TAP::Harness::Restricted 71 | $ PERL_MM_USE_DEFAULT=1 HARNESS_CLASS=TAP::Harness::Restricted cpan Dist::Zilla 72 | 73 | # using cpanm, bypassing *all* tests 74 | $ cpanm -n Dist::Zilla 75 | 76 | In either case, it's probably going to take about 10 minutes. Go for a walk, 77 | go get a cup of your favorite beverage, take a bathroom break, or whatever. 78 | When you get back, Dist::Zilla should be ready for you. 79 | 80 | Then you need to install any plugins specific to this distribution: 81 | 82 | $ dzil authordeps --missing | cpanm 83 | 84 | You can use Dist::Zilla to install the distribution's dependencies if you 85 | haven't already installed them with cpanm: 86 | 87 | $ dzil listdeps --missing --develop | cpanm 88 | 89 | Once everything is installed, here are some dzil commands you might try: 90 | 91 | $ dzil build 92 | $ dzil test 93 | $ dzil regenerate 94 | 95 | You can learn more about Dist::Zilla at http://dzil.org/ 96 | 97 | ## Other notes 98 | 99 | This distribution maintains the generated `META.json` and `Makefile.PL` 100 | in the repository. This allows two things: 101 | [Travis CI](https://travis-ci.org/) can build and test the distribution without 102 | requiring Dist::Zilla, and the distribution can be installed directly from 103 | Github or a local git repository using `cpanm` for testing (again, not 104 | requiring Dist::Zilla). 105 | 106 | $ cpanm git://github.com/Author/Distribution-Name.git 107 | $ cd Distribution-Name; cpanm . 108 | 109 | Contributions are preferred in the form of a Github pull request. See 110 | [Using pull requests](https://help.github.com/articles/using-pull-requests/) 111 | for further information. You can use the Github issue tracker to report issues 112 | without an accompanying patch. 113 | 114 | # CREDITS 115 | 116 | This file was adapted from an initial `CONTRIBUTING.mkdn` file from David 117 | Golden under the terms of the [CC0](https://creativecommons.org/share-your-work/public-domain/cc0/), with inspiration from the 118 | contributing documents from [Dist::Zilla::Plugin::Author::KENTNL::CONTRIBUTING](https://metacpan.org/pod/Dist::Zilla::Plugin::Author::KENTNL::CONTRIBUTING) 119 | and [Dist::Zilla::PluginBundle::Author::ETHER](https://metacpan.org/pod/Dist::Zilla::PluginBundle::Author::ETHER). 120 | -------------------------------------------------------------------------------- /Changes: -------------------------------------------------------------------------------- 1 | Revision history for HTTP-Message 2 | 3 | {{$NEXT}} 4 | 5 | 7.00 2024-10-07 15:31:56Z 6 | - Stop transforming LF into CRLF. Fixes #69 (GH#196) (Olaf Alders) 7 | 8 | 6.46 2024-05-27 18:58:16Z 9 | - Update several status codes to RFC 9110 (GH#197) (Wesley Schwengle) 10 | 11 | 6.45 2023-09-27 14:27:31Z 12 | - Allow for file ownership conflicts with Docker and GitHub Actions 13 | (GH#193) (Olaf Alders) 14 | - Add the 'status_code' function for getting all status codes as hash 15 | (GH#194) (Dai Okabayashi) 16 | 17 | 6.44 2022-10-26 20:49:00Z 18 | - Made the Clone module a hard requirement, so we don't have to 19 | provide a fallback function for HTTP::Headers::clone(). 20 | We require at least Clone 0.46, as that release now supports 21 | Perl back to 5.8.1, just like us. (GH#184) (Neil Bowers) 22 | - Import clone from Clone rather than inheriting (GH#189) (Graham Knop) 23 | - Made the Compress::Raw::Zlib 2.062 module minimal required 24 | version. (GH#190) (Jakub 'q84fh' Skory) 25 | 26 | 6.43 2022-10-22 14:50:35Z 27 | - Remove dependency to IO::Uncompress::Bunzip2. (Michal Josef Spacek) 28 | - Remove dependency to IO::Uncompress::Gunzip. (Michal Josef Spacek) 29 | 30 | 6.42 2022-10-18 13:53:22Z 31 | - We now don't consider the Content-Location header when asked 32 | for the base URI. RFC 7231 says we shouldn't. (GH#51) (Neil Bowers) 33 | - Increased the (max) buffer size for read() when processing form data, 34 | from 2048 to 8192. This was suggested in RT#105184, as it improved 35 | performance for them. (GH#59) (Neil Bowers) 36 | 37 | 6.41 2022-10-12 15:57:40Z 38 | - Add maximum size for HTTP::Message->decoded_content 39 | This can be used to limit the size of a decompressed HTTP response, 40 | especially when making requests to untrusted or user-specified servers. 41 | The $HTTP::Message::MAXIMUM_BODY_SIZE variable and the ->max_body_size 42 | accessor can set this limit. (GH#181) (Max Maischein) 43 | 44 | 6.40 2022-10-12 15:45:52Z 45 | - Fixed two typos in the doc, originally reported by FatherC 46 | in RT#90716, ported over as GH#57. (GH#57) (Neil Bowers) 47 | 48 | 6.39 2022-10-08 13:48:26Z 49 | - Remove Travis config (GH#180) (Olaf Alders) 50 | - Added status_constant_name() which maps status code 51 | to the name of the corresponding constant. (GH#160) (Neil Bowers) 52 | - Updated the doc for status_message() to clarify that it 53 | returns "Not Found" and not "HTTP_NOT_FOUND". (GH#160) (Neil Bowers) 54 | 55 | 6.38 2022-10-06 21:48:18Z 56 | - Replace "base" with "parent" (GH#176) (James Raspass) 57 | - Replace "print" with "note" in tests (GH#178) (James Raspass) 58 | - Noted that OPTIONS supported was added in 6.1, to the doc 59 | for HTTP::Request::Common. Addresses GH#177. (GH#179) (Neil Bowers) 60 | 61 | 6.37 2022-06-14 14:08:55Z 62 | - Support for Brotli "br" encoding (GH#163) (trizen and Julien Fiegehenn) 63 | - Don't test Perl > 5.32 on Windows in GH Actions (GH#174) (Olaf Alders) 64 | 65 | 6.36 2022-01-05 14:39:42Z 66 | - Fix examples in HTTP::Request::Common synopsis: HTTP::Request::Common 67 | does not put headers in an arrayref, unlike HTTP::Request (GH#170) (Karen 68 | Etheridge) 69 | - Update to contributing information (GH#171) (Håkon Hægland) 70 | 71 | 6.35 2021-11-11 22:10:31Z 72 | - Clarify documentation for decoded_content (GH#166) (Eric Wastl) 73 | 74 | 6.34 2021-11-08 14:27:36Z 75 | - Catch case of empty name/value in header words split. (GH#168) (Galen Huntington) 76 | 77 | 6.33 2021-06-28 16:51:58Z 78 | - Allow `can` method to respond to delegated methods (GH#159) (nanto_vi, 79 | TOYAMA Nao) 80 | 81 | 6.32 2021-05-18 18:54:27Z 82 | - Use File::Spec for MSWin32 on Content-Disposition filename (GH#157) 83 | (tzccinct) 84 | 85 | 6.31 2021-05-11 18:07:37Z 86 | - Fix test writing to files (GH#156) (Michal Josef Špaček) 87 | 88 | 6.30 2021-05-10 14:55:55Z 89 | - Don't inherit from Exporter anymore (GH#155) (Max Maischein) 90 | - Remove superfluous Perl version requirement. This module requires Perl 91 | 5.6 or newer. (GH#155) (Max Maischein) 92 | 93 | 6.29 2021-03-06 04:50:34Z 94 | - fix issue with HTTP::Request internal cache for canonical url when using 95 | URI::URL (GH#146) (andrew-grechkin) 96 | 97 | 6.28 2021-02-19 16:22:13Z 98 | - fix warnings during HTTP::Config->match #62 (GH#152) (Viťas Strádal) 99 | 100 | 6.27 2021-01-05 03:02:01Z 101 | - Clean up backcompat code (GH#148) (Dan Book) 102 | - Add "308 Permanent Redirect" to is_cacheable_by_default (GH#150) (simbabque) 103 | 104 | 6.26 2020-09-10 02:34:25Z 105 | - Update comment which explains in which RFC 451 is defined (GH#143) (Olaf 106 | Alders). Reported by Toby Inkster. 107 | - Fix HTTP status descriptions and add 425 Too Early (GH#145) (Dan Book) 108 | 109 | 6.25 2020-06-28 17:52:12Z 110 | - Don't run Changes test on master in GH actions 111 | - move Clone from required to suggests prerequisite, to re-enable 112 | fatpacking 113 | 114 | 6.24 2020-05-11 13:15:25Z 115 | - Full release. No changes since TRIAL release 6.23 116 | 117 | 6.23 2020-05-07 17:57:18Z (TRIAL RELEASE) 118 | - Enable static install (GH#134) (Olaf Alders) 119 | - Support non-string header values that stringify (GH#137) (Will Storey) 120 | 121 | 6.22 2020-02-24 18:58:07Z 122 | - Full release. No changes since TRIAL release 6.21 123 | 124 | 6.21 2020-02-19 14:35:09Z (TRIAL RELEASE) 125 | - Bump Encode to latest version (3.01) (GH#129) (Olaf Alders) 126 | - Revert #115 (GH#131) (Olaf Alders) 127 | - Revert (GH#125) "try hard to make a usable file name" (GH#130) (Olaf 128 | Alders) 129 | - Fix JSON request encoding examples in POD (GH#126) (Michael Schout) 130 | - Added support for OPTIONS requests. 131 | 132 | 6.20 2019-02-05 01:46:39Z (TRIAL RELEASE) 133 | - Fix encoded file names when LC_ALL=C (GH#125) (Lars Dɪᴇᴄᴋᴏᴡ 迪拉斯) 134 | 135 | 6.19 2019-01-16 15:17:35Z (TRIAL RELEASE) 136 | - Add support for RFC 8187 encoded filenames (GH#115) (Zaki Mughal) 137 | - Fix memoized _uri_canonical #121 (GH#123) (Dorian Taylor) 138 | - Don't overwrite $@ in decodable (gh #80) (GH#118) (mschae94) 139 | - Add support for RFC 8187 encoded filenames (GH#115) (Zaki Mughal) 140 | 141 | 6.18 2018-06-05 16:29:15Z 142 | - Revert status_message to original code (GH#111) (Theo van Hoesel) 143 | 144 | 6.17 2018-06-05 01:55:34Z 145 | - Documented status code 451 in the list of constants (GH #104) (Robert Rothenberg) 146 | - Status code 451 is cachable by default, as per RFC 7725 (GH #104) (Robert Rothenberg) 147 | - Add default status_message for unknown status codes (GH#105) (Robert Rothenberg) 148 | - Corrections to the documentation (GH#102) (Jonas B. Nielsen) 149 | 150 | 6.16 2018-03-28 14:09:17Z 151 | - Update status codes to official IANA list (GH#100) (Theo van Hoesel) 152 | 153 | 6.15 2018-03-13 13:02:56Z 154 | - Whenever possible, use an absolute four digit year for Time::Local (GH#97) 155 | - Add is_cacheable_by_default() (GH#98) (Theo van Hoesel) 156 | 157 | 6.14 2017-12-20 22:28:48Z 158 | - Add some useful examples in HTTP::Request (GH #92) (Chase Whitener). 159 | Batch requests are now explained. 160 | - PUT and PATCH docs updated (GH #84) (saturdaywalkers) 161 | - Trim trailing \r from status line so message() doesn't return it (GH #87) (Felipe Gasper) 162 | - Bring test coverage of HTTP::Config to 100% (GH #85) (Pete Houston) 163 | - Add 103 Early Hints to HTTP::Status (GH #94) (Tatsuhiko Miyagawa) 164 | 165 | 6.13 2017-06-20 01:07:03Z 166 | - Non-TRIAL release of changes found in 6.12 167 | 168 | 6.12 2017-06-15 18:03:50Z (TRIAL RELEASE) 169 | - If an object is passed to HTTP::Request, it must provide a canonical() 170 | method (Olaf Alders) 171 | - Make sure status messages don't die by checking the status exists before 172 | checking the value range (Kent Fredric, GH #39) 173 | - Add a .mailmap file to clean up the contributors list 174 | - Avoid inconsistent setting of content to undef (Jerome Eteve) 175 | - Simplify the way some methods are created (Tom Hukins) 176 | - Remove some indirect object notation (Chase Whitener) 177 | - Fix example in Pod (Tobias Leich) 178 | - Add support for HTTP PATCH method (Mickey Nasriachi) 179 | 180 | 6.11 2015-09-09 181 | - fix an undefined value warning in HTTP::Headers::as_string 182 | 183 | 6.10 2015-07-19 184 | - fix uses of qr/.../m in tests that do not work in 5.8.x 185 | 186 | 6.09 2015-07-19 187 | - converted all uses of Test.pm to Test::More 188 | - fix uninitialized warning in HTTP::Config (RT#105929) 189 | 190 | 6.08 2015-07-10 191 | - Resolve new uninitialized warning from 192 | HTTP::Request::Common::request_type_with_data (RT#105787) 193 | 194 | 6.07 2015-07-09 195 | - Allow subclasses to override the class of parts - it used to be hardcoded 196 | to HTTP::Message. (Gisle Aas, RT#79239) 197 | - Added support for is_client_error, is_server_error to HTTP::Response 198 | (Karen Etheridge) 199 | - Added flatten interface to HTTP::Headers (Tokuhiro Matsuno, GH#5) 200 | - Allow PUT to pass content data via hashrefs just like with POST (Michael 201 | Schilli, GH#9) 202 | - Fix for "Content-Encoding: none" header (Gisle Aas, RT#94882) 203 | - Add support for HTTP status 308, defined in RFC 7238 (Olivier Mengué, 204 | RT#104102) 205 | - drop the use of "use vars" (Karen Etheridge) 206 | 207 | 6.06 2012-10-21 208 | - More forgiving test on croak message [RT#80302] (Gisle Aas) 209 | - Added test for multipart parsing (Gisle Aas) 210 | - Multipart end boundary doesn't need match a complete line [RT#79239] 211 | (Mark Overmeer) 212 | 213 | 6.05 2012-10-20 214 | - Updated ignores (Gisle Aas) 215 | - No need to prevent visiting field values starting with '_' (Gisle Aas) 216 | - Report the correct croak caller for delegated methods (Gisle Aas) 217 | - Disallow empty field names or field names containing ':' (Gisle Aas) 218 | - Make the extra std_case entries local to each header (Gisle Aas) 219 | 220 | 6.04 2012-09-30 221 | - Updated repository URL (Gisle Aas) 222 | - Avoid undef warning for empty content (Gisle Aas) 223 | - Teach $m->content_charset about JSON (Gisle Aas) 224 | - Use the canonical charset name for UTF-16LE (and frieds) (Gisle Aas) 225 | - Add option to override the "(no content)" marker of $m->dump (Gisle Aas) 226 | - Use IO::HTML for encoding sniffing (Christopher J. Madsen) 227 | - mime_name was introduced in Encode 2.21 (Christopher J. Madsen) 228 | - Remove an unneeded "require" (Tom Hukins) 229 | - Spelling fixes. (Ville Skyttä) 230 | - Sanitized PERL_HTTP_URI_CLASS environment variable. (chromatic) 231 | - Add test from RT#77466 (Martin H. Sluka) 232 | - Fix doc grammo [RT#75831] (Father Chrysostomos) 233 | 234 | 6.03 2012-02-16 235 | - Support 'bzip2' as alternative to Content-Encoding: x-bzip2. Some 236 | servers seem to return it. 237 | - Make newlines in forms be "\r\n" terminated. 238 | - Added some more status codes. 239 | - Restore perl-5.8.1 compatibility. 240 | 241 | 6.02 2011-03-20 242 | - Declare dependency on Bunzip2 v2.021 [RT#66593] 243 | 244 | 6.01 2011-03-07 245 | - Avoid loading XML::Simple to avoid test failures. 246 | - Eliminate the HTML::Entities dependency. 247 | 248 | 6.00 2011-02-27 249 | - Initial release of HTTP-Message as a separate distribution. There are no 250 | code changes besides incrementing the version number since 251 | libwww-perl-5.837. 252 | - The HTTP::Message module with friends used to be bundled with the 253 | libwww-perl distribution. 254 | -------------------------------------------------------------------------------- /Install: -------------------------------------------------------------------------------- 1 | This is the Perl distribution HTTP-Message. 2 | 3 | Installing HTTP-Message is straightforward. 4 | 5 | ## Installation with cpanm 6 | 7 | If you have cpanm, you only need one line: 8 | 9 | % cpanm HTTP::Message 10 | 11 | If it does not have permission to install modules to the current perl, cpanm 12 | will automatically set up and install to a local::lib in your home directory. 13 | See the local::lib documentation (https://metacpan.org/pod/local::lib) for 14 | details on enabling it in your environment. 15 | 16 | ## Installing with the CPAN shell 17 | 18 | Alternatively, if your CPAN shell is set up, you should just be able to do: 19 | 20 | % cpan HTTP::Message 21 | 22 | ## Manual installation 23 | 24 | As a last resort, you can manually install it. Download the tarball, untar it, 25 | then build it: 26 | 27 | % perl Makefile.PL 28 | % make && make test 29 | 30 | Then install it: 31 | 32 | % make install 33 | 34 | If your perl is system-managed, you can create a local::lib in your home 35 | directory to install modules to. For details, see the local::lib documentation: 36 | https://metacpan.org/pod/local::lib 37 | 38 | ## Documentation 39 | 40 | HTTP-Message documentation is available as POD. 41 | You can run perldoc from a shell to read the documentation: 42 | 43 | % perldoc HTTP::Message 44 | -------------------------------------------------------------------------------- /Makefile.PL: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by Dist::Zilla::Plugin::MakeMaker v6.032. 2 | use strict; 3 | use warnings; 4 | 5 | use 5.008001; 6 | 7 | use ExtUtils::MakeMaker; 8 | 9 | my %WriteMakefileArgs = ( 10 | "ABSTRACT" => "HTTP style message (base class)", 11 | "AUTHOR" => "Gisle Aas ", 12 | "CONFIGURE_REQUIRES" => { 13 | "ExtUtils::MakeMaker" => 0 14 | }, 15 | "DISTNAME" => "HTTP-Message", 16 | "LICENSE" => "perl", 17 | "MIN_PERL_VERSION" => "5.008001", 18 | "NAME" => "HTTP::Message", 19 | "PREREQ_PM" => { 20 | "Carp" => 0, 21 | "Clone" => "0.46", 22 | "Compress::Raw::Bzip2" => 0, 23 | "Compress::Raw::Zlib" => "2.062", 24 | "Encode" => "3.01", 25 | "Encode::Locale" => 1, 26 | "Exporter" => "5.57", 27 | "File::Spec" => 0, 28 | "HTTP::Date" => 6, 29 | "IO::Compress::Bzip2" => "2.021", 30 | "IO::Compress::Deflate" => 0, 31 | "IO::Compress::Gzip" => 0, 32 | "IO::HTML" => 0, 33 | "IO::Uncompress::Inflate" => 0, 34 | "IO::Uncompress::RawInflate" => 0, 35 | "LWP::MediaTypes" => 6, 36 | "MIME::Base64" => "2.1", 37 | "MIME::QuotedPrint" => 0, 38 | "URI" => "1.10", 39 | "parent" => 0, 40 | "strict" => 0, 41 | "warnings" => 0 42 | }, 43 | "TEST_REQUIRES" => { 44 | "ExtUtils::MakeMaker" => 0, 45 | "File::Spec" => 0, 46 | "File::Temp" => 0, 47 | "PerlIO::encoding" => 0, 48 | "Test::More" => "0.88", 49 | "Test::Needs" => 0, 50 | "Time::Local" => 0, 51 | "Try::Tiny" => 0, 52 | "URI::URL" => 0, 53 | "lib" => 0, 54 | "overload" => 0 55 | }, 56 | "VERSION" => "7.01", 57 | "test" => { 58 | "TESTS" => "t/*.t" 59 | } 60 | ); 61 | 62 | 63 | my %FallbackPrereqs = ( 64 | "Carp" => 0, 65 | "Clone" => "0.46", 66 | "Compress::Raw::Bzip2" => 0, 67 | "Compress::Raw::Zlib" => "2.062", 68 | "Encode" => "3.01", 69 | "Encode::Locale" => 1, 70 | "Exporter" => "5.57", 71 | "ExtUtils::MakeMaker" => 0, 72 | "File::Spec" => 0, 73 | "File::Temp" => 0, 74 | "HTTP::Date" => 6, 75 | "IO::Compress::Bzip2" => "2.021", 76 | "IO::Compress::Deflate" => 0, 77 | "IO::Compress::Gzip" => 0, 78 | "IO::HTML" => 0, 79 | "IO::Uncompress::Inflate" => 0, 80 | "IO::Uncompress::RawInflate" => 0, 81 | "LWP::MediaTypes" => 6, 82 | "MIME::Base64" => "2.1", 83 | "MIME::QuotedPrint" => 0, 84 | "PerlIO::encoding" => 0, 85 | "Test::More" => "0.88", 86 | "Test::Needs" => 0, 87 | "Time::Local" => 0, 88 | "Try::Tiny" => 0, 89 | "URI" => "1.10", 90 | "URI::URL" => 0, 91 | "lib" => 0, 92 | "overload" => 0, 93 | "parent" => 0, 94 | "strict" => 0, 95 | "warnings" => 0 96 | ); 97 | 98 | 99 | unless ( eval { ExtUtils::MakeMaker->VERSION(6.63_03) } ) { 100 | delete $WriteMakefileArgs{TEST_REQUIRES}; 101 | delete $WriteMakefileArgs{BUILD_REQUIRES}; 102 | $WriteMakefileArgs{PREREQ_PM} = \%FallbackPrereqs; 103 | } 104 | 105 | delete $WriteMakefileArgs{CONFIGURE_REQUIRES} 106 | unless eval { ExtUtils::MakeMaker->VERSION(6.52) }; 107 | 108 | WriteMakefile(%WriteMakefileArgs); 109 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # NAME 2 | 3 | HTTP::Message - HTTP style message (base class) 4 | 5 | # VERSION 6 | 7 | version 7.00 8 | 9 | # SYNOPSIS 10 | 11 | use parent 'HTTP::Message'; 12 | 13 | # DESCRIPTION 14 | 15 | An `HTTP::Message` object contains some headers and a content body. 16 | The following methods are available: 17 | 18 | - $mess = HTTP::Message->new 19 | - $mess = HTTP::Message->new( $headers ) 20 | - $mess = HTTP::Message->new( $headers, $content ) 21 | 22 | This constructs a new message object. Normally you would want 23 | construct `HTTP::Request` or `HTTP::Response` objects instead. 24 | 25 | The optional $header argument should be a reference to an 26 | `HTTP::Headers` object or a plain array reference of key/value pairs. 27 | If an `HTTP::Headers` object is provided then a copy of it will be 28 | embedded into the constructed message, i.e. it will not be owned and 29 | can be modified afterwards without affecting the message. 30 | 31 | The optional $content argument should be a string of bytes. 32 | 33 | - $mess = HTTP::Message->parse( $str ) 34 | 35 | This constructs a new message object by parsing the given string. 36 | 37 | - $mess->headers 38 | 39 | Returns the embedded `HTTP::Headers` object. 40 | 41 | - $mess->headers\_as\_string 42 | - $mess->headers\_as\_string( $eol ) 43 | 44 | Call the as\_string() method for the headers in the 45 | message. This will be the same as 46 | 47 | $mess->headers->as_string 48 | 49 | but it will make your program a whole character shorter :-) 50 | 51 | - $mess->content 52 | - $mess->content( $bytes ) 53 | 54 | The content() method sets the raw content if an argument is given. If no 55 | argument is given the content is not touched. In either case the 56 | original raw content is returned. 57 | 58 | If the `undef` argument is given, the content is reset to its default value, 59 | which is an empty string. 60 | 61 | Note that the content should be a string of bytes. Strings in perl 62 | can contain characters outside the range of a byte. The `Encode` 63 | module can be used to turn such strings into a string of bytes. 64 | 65 | - $mess->add\_content( $bytes ) 66 | 67 | The add\_content() methods appends more data bytes to the end of the 68 | current content buffer. 69 | 70 | - $mess->add\_content\_utf8( $string ) 71 | 72 | The add\_content\_utf8() method appends the UTF-8 bytes representing the 73 | string to the end of the current content buffer. 74 | 75 | - $mess->content\_ref 76 | - $mess->content\_ref( \\$bytes ) 77 | 78 | The content\_ref() method will return a reference to content buffer string. 79 | It can be more efficient to access the content this way if the content 80 | is huge, and it can even be used for direct manipulation of the content, 81 | for instance: 82 | 83 | ${$res->content_ref} =~ s/\bfoo\b/bar/g; 84 | 85 | This example would modify the content buffer in-place. 86 | 87 | If an argument is passed it will setup the content to reference some 88 | external source. The content() and add\_content() methods 89 | will automatically dereference scalar references passed this way. For 90 | other references content() will return the reference itself and 91 | add\_content() will refuse to do anything. 92 | 93 | - $mess->content\_charset 94 | 95 | This returns the charset used by the content in the message. The 96 | charset is either found as the charset attribute of the 97 | `Content-Type` header or by guessing. 98 | 99 | 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) 100 | for details about how charset is determined. 101 | 102 | - $mess->decoded\_content( %options ) 103 | 104 | Returns the content with any `Content-Encoding` undone and, for textual content 105 | (`Content-Type` values starting with `text/`, exactly matching 106 | `application/xml`, or ending with `+xml`), the raw content's character set 107 | decoded into Perl's Unicode string format. Note that this 108 | [does not currently](https://github.com/libwww-perl/HTTP-Message/pull/99) 109 | attempt to decode declared character sets for any other content types like 110 | `application/json` or `application/javascript`. If the `Content-Encoding` 111 | or `charset` of the message is unknown, this method will fail by returning 112 | `undef`. 113 | 114 | The following options can be specified. 115 | 116 | - `charset` 117 | 118 | This overrides the charset parameter for text content. The value 119 | `none` can used to suppress decoding of the charset. 120 | 121 | - `default_charset` 122 | 123 | This overrides the default charset guessed by content\_charset() or 124 | if that fails "ISO-8859-1". 125 | 126 | - `alt_charset` 127 | 128 | If decoding fails because the charset specified in the Content-Type header 129 | isn't recognized by Perl's Encode module, then try decoding using this charset 130 | instead of failing. The `alt_charset` might be specified as `none` to simply 131 | return the string without any decoding of charset as alternative. 132 | 133 | - `charset_strict` 134 | 135 | Abort decoding if malformed characters is found in the content. By 136 | default you get the substitution character ("\\x{FFFD}") in place of 137 | malformed characters. 138 | 139 | - `raise_error` 140 | 141 | If TRUE then raise an exception if not able to decode content. Reason 142 | might be that the specified `Content-Encoding` or `charset` is not 143 | supported. If this option is FALSE, then decoded\_content() will return 144 | `undef` on errors, but will still set $@. 145 | 146 | - `ref` 147 | 148 | If TRUE then a reference to decoded content is returned. This might 149 | be more efficient in cases where the decoded content is identical to 150 | the raw content as no data copying is required in this case. 151 | 152 | - $mess->decodable 153 | - HTTP::Message::decodable() 154 | 155 | This returns the encoding identifiers that decoded\_content() can 156 | process. In scalar context returns a comma separated string of 157 | identifiers. 158 | 159 | This value is suitable for initializing the `Accept-Encoding` request 160 | header field. 161 | 162 | - $mess->decode 163 | 164 | This method tries to replace the content of the message with the 165 | decoded version and removes the `Content-Encoding` header. Returns 166 | TRUE if successful and FALSE if not. 167 | 168 | If the message does not have a `Content-Encoding` header this method 169 | does nothing and returns TRUE. 170 | 171 | Note that the content of the message is still bytes after this method 172 | has been called and you still need to call decoded\_content() if you 173 | want to process its content as a string. 174 | 175 | - $mess->encode( $encoding, ... ) 176 | 177 | Apply the given encodings to the content of the message. Returns TRUE 178 | if successful. The "identity" (non-)encoding is always supported; other 179 | currently supported encodings, subject to availability of required 180 | additional modules, are "gzip", "deflate", "x-bzip2", "base64" and "br". 181 | 182 | A successful call to this function will set the `Content-Encoding` 183 | header. 184 | 185 | Note that `multipart/*` or `message/*` messages can't be encoded and 186 | this method will croak if you try. 187 | 188 | - $mess->parts 189 | - $mess->parts( @parts ) 190 | - $mess->parts( \\@parts ) 191 | 192 | Messages can be composite, i.e. contain other messages. The composite 193 | messages have a content type of `multipart/*` or `message/*`. This 194 | method give access to the contained messages. 195 | 196 | The argumentless form will return a list of `HTTP::Message` objects. 197 | If the content type of $msg is not `multipart/*` or `message/*` then 198 | this will return the empty list. In scalar context only the first 199 | object is returned. The returned message parts should be regarded as 200 | read-only (future versions of this library might make it possible 201 | to modify the parent by modifying the parts). 202 | 203 | If the content type of $msg is `message/*` then there will only be 204 | one part returned. 205 | 206 | If the content type is `message/http`, then the return value will be 207 | either an `HTTP::Request` or an `HTTP::Response` object. 208 | 209 | If a @parts argument is given, then the content of the message will be 210 | modified. The array reference form is provided so that an empty list 211 | can be provided. The @parts array should contain `HTTP::Message` 212 | objects. The @parts objects are owned by $mess after this call and 213 | should not be modified or made part of other messages. 214 | 215 | When updating the message with this method and the old content type of 216 | $mess is not `multipart/*` or `message/*`, then the content type is 217 | set to `multipart/mixed` and all other content headers are cleared. 218 | 219 | This method will croak if the content type is `message/*` and more 220 | than one part is provided. 221 | 222 | - $mess->add\_part( $part ) 223 | 224 | This will add a part to a message. The $part argument should be 225 | another `HTTP::Message` object. If the previous content type of 226 | $mess is not `multipart/*` then the old content (together with all 227 | content headers) will be made part #1 and the content type made 228 | `multipart/mixed` before the new part is added. The $part object is 229 | owned by $mess after this call and should not be modified or made part 230 | of other messages. 231 | 232 | There is no return value. 233 | 234 | - $mess->clear 235 | 236 | Will clear the headers and set the content to the empty string. There 237 | is no return value 238 | 239 | - $mess->protocol 240 | - $mess->protocol( $proto ) 241 | 242 | Sets the HTTP protocol used for the message. The protocol() is a string 243 | like `HTTP/1.0` or `HTTP/1.1`. 244 | 245 | - $mess->clone 246 | 247 | Returns a copy of the message object. 248 | 249 | - $mess->as\_string 250 | - $mess->as\_string( $eol ) 251 | 252 | Returns the message formatted as a single string. 253 | 254 | The optional $eol parameter specifies the line ending sequence to use. 255 | The default is "\\n". If no $eol is given then as\_string will ensure 256 | that the returned string is newline terminated (even when the message 257 | content is not). No extra newline is appended if an explicit $eol is 258 | passed. 259 | 260 | - $mess->dump( %opt ) 261 | 262 | Returns the message formatted as a string. In void context print the string. 263 | 264 | This differs from `$mess->as_string` in that it escapes the bytes 265 | of the content so that it's safe to print them and it limits how much 266 | content to print. The escapes syntax used is the same as for Perl's 267 | double quoted strings. If there is no content the string "(no 268 | content)" is shown in its place. 269 | 270 | Options to influence the output can be passed as key/value pairs. The 271 | following options are recognized: 272 | 273 | - maxlength => $num 274 | 275 | How much of the content to show. The default is 512. Set this to 0 276 | for unlimited. 277 | 278 | If the content is longer then the string is chopped at the limit and 279 | the string "...\\n(### more bytes not shown)" appended. 280 | 281 | - no\_content => $str 282 | 283 | Replaces the "(no content)" marker. 284 | 285 | - prefix => $str 286 | 287 | A string that will be prefixed to each line of the dump. 288 | 289 | All methods unknown to `HTTP::Message` itself are delegated to the 290 | `HTTP::Headers` object that is part of every message. This allows 291 | convenient access to these methods. Refer to [HTTP::Headers](https://metacpan.org/pod/HTTP%3A%3AHeaders) for 292 | details of these methods: 293 | 294 | $mess->header( $field => $val ) 295 | $mess->push_header( $field => $val ) 296 | $mess->init_header( $field => $val ) 297 | $mess->remove_header( $field ) 298 | $mess->remove_content_headers 299 | $mess->header_field_names 300 | $mess->scan( \&doit ) 301 | 302 | $mess->date 303 | $mess->expires 304 | $mess->if_modified_since 305 | $mess->if_unmodified_since 306 | $mess->last_modified 307 | $mess->content_type 308 | $mess->content_encoding 309 | $mess->content_length 310 | $mess->content_language 311 | $mess->title 312 | $mess->user_agent 313 | $mess->server 314 | $mess->from 315 | $mess->referer 316 | $mess->www_authenticate 317 | $mess->authorization 318 | $mess->proxy_authorization 319 | $mess->authorization_basic 320 | $mess->proxy_authorization_basic 321 | 322 | # AUTHOR 323 | 324 | Gisle Aas 325 | 326 | # COPYRIGHT AND LICENSE 327 | 328 | This software is copyright (c) 1994 by Gisle Aas. 329 | 330 | This is free software; you can redistribute it and/or modify it under 331 | the same terms as the Perl 5 programming language system itself. 332 | -------------------------------------------------------------------------------- /cpanfile: -------------------------------------------------------------------------------- 1 | # This file is generated by Dist::Zilla::Plugin::CPANFile v6.032 2 | # Do not edit this file directly. To change prereqs, edit the `dist.ini` file. 3 | 4 | requires "Carp" => "0"; 5 | requires "Clone" => "0.46"; 6 | requires "Compress::Raw::Bzip2" => "0"; 7 | requires "Compress::Raw::Zlib" => "2.062"; 8 | requires "Encode" => "3.01"; 9 | requires "Encode::Locale" => "1"; 10 | requires "Exporter" => "5.57"; 11 | requires "File::Spec" => "0"; 12 | requires "HTTP::Date" => "6"; 13 | requires "IO::Compress::Bzip2" => "2.021"; 14 | requires "IO::Compress::Deflate" => "0"; 15 | requires "IO::Compress::Gzip" => "0"; 16 | requires "IO::HTML" => "0"; 17 | requires "IO::Uncompress::Inflate" => "0"; 18 | requires "IO::Uncompress::RawInflate" => "0"; 19 | requires "LWP::MediaTypes" => "6"; 20 | requires "MIME::Base64" => "2.1"; 21 | requires "MIME::QuotedPrint" => "0"; 22 | requires "URI" => "1.10"; 23 | requires "parent" => "0"; 24 | requires "perl" => "5.008001"; 25 | requires "strict" => "0"; 26 | requires "warnings" => "0"; 27 | recommends "IO::Compress::Brotli" => "0.004001"; 28 | recommends "IO::Uncompress::Brotli" => "0.004001"; 29 | 30 | on 'test' => sub { 31 | requires "ExtUtils::MakeMaker" => "0"; 32 | requires "File::Spec" => "0"; 33 | requires "File::Temp" => "0"; 34 | requires "PerlIO::encoding" => "0"; 35 | requires "Test::More" => "0.88"; 36 | requires "Test::Needs" => "0"; 37 | requires "Time::Local" => "0"; 38 | requires "Try::Tiny" => "0"; 39 | requires "URI::URL" => "0"; 40 | requires "lib" => "0"; 41 | requires "overload" => "0"; 42 | requires "perl" => "5.008001"; 43 | }; 44 | 45 | on 'test' => sub { 46 | recommends "CPAN::Meta" => "2.120900"; 47 | recommends "IO::Compress::Brotli" => "0.004001"; 48 | recommends "IO::Uncompress::Brotli" => "0.004001"; 49 | }; 50 | 51 | on 'configure' => sub { 52 | requires "ExtUtils::MakeMaker" => "0"; 53 | requires "perl" => "5.006"; 54 | }; 55 | 56 | on 'configure' => sub { 57 | suggests "JSON::PP" => "2.27300"; 58 | }; 59 | 60 | on 'develop' => sub { 61 | requires "File::Spec" => "0"; 62 | requires "IO::Handle" => "0"; 63 | requires "IPC::Open3" => "0"; 64 | requires "Test::CPAN::Changes" => "0.19"; 65 | requires "Test::Mojibake" => "0"; 66 | requires "Test::More" => "0.96"; 67 | requires "Test::Pod" => "1.41"; 68 | requires "Test::Portability::Files" => "0"; 69 | requires "Test::Version" => "1"; 70 | requires "perl" => "5.006"; 71 | }; 72 | -------------------------------------------------------------------------------- /dist.ini: -------------------------------------------------------------------------------- 1 | name = HTTP-Message 2 | author = Gisle Aas 3 | license = Perl_5 4 | main_module = lib/HTTP/Message.pm 5 | copyright_holder = Gisle Aas 6 | copyright_year = 1994 7 | 8 | [MetaResources] 9 | x_IRC = irc://irc.perl.org/#lwp 10 | x_MailingList = mailto:libwww@perl.org 11 | 12 | [Prereqs] 13 | Compress::Raw::Zlib = 2.062 14 | Encode = 3.01 15 | Encode::Locale = 1 16 | Exporter = 5.57 17 | HTTP::Date = 6 18 | IO::Compress::Brotli = 0.004001 19 | IO::Compress::Bzip2 = 2.021 20 | IO::Uncompress::Brotli = 0.004001 21 | LWP::MediaTypes = 6 22 | MIME::Base64 = 2.1 23 | perl = 5.008001 24 | URI = 1.10 25 | Clone = 0.46 26 | 27 | [@Author::OALDERS] 28 | ; all these tests are TODO 29 | -remove = Prereqs 30 | -remove = Test::EOL 31 | -remove = Test::Perl::Critic 32 | -remove = Test::Pod::Coverage::Configurable 33 | -remove = Test::PodSpelling 34 | -remove = Test::Synopsis 35 | -remove = Test::TidyAll 36 | StaticInstall.mode = on 37 | StaticInstall.dry_run = 0 38 | 39 | [Prereqs::Soften / Brotli] 40 | to_relationship = recommends 41 | copy_to = test.recommends 42 | module = IO::Compress::Brotli 43 | module = IO::Uncompress::Brotli 44 | 45 | [Test::Compile] 46 | bail_out_on_fail = 1 47 | xt_mode = 1 48 | -------------------------------------------------------------------------------- /lib/HTTP/Config.pm: -------------------------------------------------------------------------------- 1 | package HTTP::Config; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | our $VERSION = '7.01'; 7 | 8 | use URI; 9 | 10 | sub new { 11 | my $class = shift; 12 | return bless [], $class; 13 | } 14 | 15 | sub entries { 16 | my $self = shift; 17 | @$self; 18 | } 19 | 20 | sub empty { 21 | my $self = shift; 22 | not @$self; 23 | } 24 | 25 | sub add { 26 | if (@_ == 2) { 27 | my $self = shift; 28 | push(@$self, shift); 29 | return; 30 | } 31 | my($self, %spec) = @_; 32 | push(@$self, \%spec); 33 | return; 34 | } 35 | 36 | sub find2 { 37 | my($self, %spec) = @_; 38 | my @found; 39 | my @rest; 40 | ITEM: 41 | for my $item (@$self) { 42 | for my $k (keys %spec) { 43 | no warnings 'uninitialized'; 44 | if (!exists $item->{$k} || $spec{$k} ne $item->{$k}) { 45 | push(@rest, $item); 46 | next ITEM; 47 | } 48 | } 49 | push(@found, $item); 50 | } 51 | return \@found unless wantarray; 52 | return \@found, \@rest; 53 | } 54 | 55 | sub find { 56 | my $self = shift; 57 | my $f = $self->find2(@_); 58 | return @$f if wantarray; 59 | return $f->[0]; 60 | } 61 | 62 | sub remove { 63 | my($self, %spec) = @_; 64 | my($removed, $rest) = $self->find2(%spec); 65 | @$self = @$rest if @$removed; 66 | return @$removed; 67 | } 68 | 69 | my %MATCH = ( 70 | m_scheme => sub { 71 | my($v, $uri) = @_; 72 | return $uri->_scheme eq $v; # URI known to be canonical 73 | }, 74 | m_secure => sub { 75 | my($v, $uri) = @_; 76 | my $secure = $uri->can("secure") ? $uri->secure : $uri->_scheme eq "https"; 77 | return $secure == !!$v; 78 | }, 79 | m_host_port => sub { 80 | my($v, $uri) = @_; 81 | return unless $uri->can("host_port"); 82 | return $uri->host_port eq $v, 7; 83 | }, 84 | m_host => sub { 85 | my($v, $uri) = @_; 86 | return unless $uri->can("host"); 87 | return $uri->host eq $v, 6; 88 | }, 89 | m_port => sub { 90 | my($v, $uri) = @_; 91 | return unless $uri->can("port"); 92 | return $uri->port eq $v; 93 | }, 94 | m_domain => sub { 95 | my($v, $uri) = @_; 96 | return unless $uri->can("host"); 97 | my $h = $uri->host; 98 | $h = "$h.local" unless $h =~ /\./; 99 | $v = ".$v" unless $v =~ /^\./; 100 | return length($v), 5 if substr($h, -length($v)) eq $v; 101 | return 0; 102 | }, 103 | m_path => sub { 104 | my($v, $uri) = @_; 105 | return unless $uri->can("path"); 106 | return $uri->path eq $v, 4; 107 | }, 108 | m_path_prefix => sub { 109 | my($v, $uri) = @_; 110 | return unless $uri->can("path"); 111 | my $path = $uri->path; 112 | my $len = length($v); 113 | return $len, 3 if $path eq $v; 114 | return 0 if length($path) <= $len; 115 | $v .= "/" unless $v =~ m,/\z,,; 116 | return $len, 3 if substr($path, 0, length($v)) eq $v; 117 | return 0; 118 | }, 119 | m_path_match => sub { 120 | my($v, $uri) = @_; 121 | return unless $uri->can("path"); 122 | return $uri->path =~ $v; 123 | }, 124 | m_uri__ => sub { 125 | my($v, $k, $uri) = @_; 126 | return unless $uri->can($k); 127 | return 1 unless defined $v; 128 | return $uri->$k eq $v; 129 | }, 130 | m_method => sub { 131 | my($v, $uri, $request) = @_; 132 | return $request && $request->method eq $v; 133 | }, 134 | m_proxy => sub { 135 | my($v, $uri, $request) = @_; 136 | return $request && ($request->{proxy} || "") eq $v; 137 | }, 138 | m_code => sub { 139 | my($v, $uri, $request, $response) = @_; 140 | $v =~ s/xx\z//; 141 | return unless $response; 142 | return length($v), 2 if substr($response->code, 0, length($v)) eq $v; 143 | }, 144 | m_media_type => sub { # for request too?? 145 | my($v, $uri, $request, $response) = @_; 146 | return unless $response; 147 | return 1, 1 if $v eq "*/*"; 148 | my $ct = $response->content_type; 149 | return 2, 1 if $v =~ s,/\*\z,, && $ct =~ m,^\Q$v\E/,; 150 | return 3, 1 if $v eq "html" && $response->content_is_html; 151 | return 4, 1 if $v eq "xhtml" && $response->content_is_xhtml; 152 | return 10, 1 if $v eq $ct; 153 | return 0; 154 | }, 155 | m_header__ => sub { 156 | my($v, $k, $uri, $request, $response) = @_; 157 | return unless $request; 158 | my $req_header = $request->header($k); 159 | return 1 if defined($req_header) && $req_header eq $v; 160 | if ($response) { 161 | my $res_header = $response->header($k); 162 | return 1 if defined($res_header) && $res_header eq $v; 163 | } 164 | return 0; 165 | }, 166 | m_response_attr__ => sub { 167 | my($v, $k, $uri, $request, $response) = @_; 168 | return unless $response; 169 | return 1 if !defined($v) && exists $response->{$k}; 170 | return 0 unless exists $response->{$k}; 171 | return 1 if $response->{$k} eq $v; 172 | return 0; 173 | }, 174 | ); 175 | 176 | sub matching { 177 | my $self = shift; 178 | if (@_ == 1) { 179 | if ($_[0]->can("request")) { 180 | unshift(@_, $_[0]->request); 181 | unshift(@_, undef) unless defined $_[0]; 182 | } 183 | unshift(@_, $_[0]->uri_canonical) if $_[0] && $_[0]->can("uri_canonical"); 184 | } 185 | my($uri, $request, $response) = @_; 186 | $uri = URI->new($uri) unless ref($uri); 187 | 188 | my @m; 189 | ITEM: 190 | for my $item (@$self) { 191 | my $order; 192 | for my $ikey (keys %$item) { 193 | my $mkey = $ikey; 194 | my $k; 195 | $k = $1 if $mkey =~ s/__(.*)/__/; 196 | if (my $m = $MATCH{$mkey}) { 197 | #print "$ikey $mkey\n"; 198 | my($c, $o); 199 | my @arg = ( 200 | defined($k) ? $k : (), 201 | $uri, $request, $response 202 | ); 203 | my $v = $item->{$ikey}; 204 | $v = [$v] unless ref($v) eq "ARRAY"; 205 | for (@$v) { 206 | ($c, $o) = $m->($_, @arg); 207 | #print " - $_ ==> $c $o\n"; 208 | last if $c; 209 | } 210 | next ITEM unless $c; 211 | $order->[$o || 0] += $c; 212 | } 213 | } 214 | $order->[7] ||= 0; 215 | $item->{_order} = join(".", reverse map sprintf("%03d", $_ || 0), @$order); 216 | push(@m, $item); 217 | } 218 | @m = sort { $b->{_order} cmp $a->{_order} } @m; 219 | delete $_->{_order} for @m; 220 | return @m if wantarray; 221 | return $m[0]; 222 | } 223 | 224 | sub add_item { 225 | my $self = shift; 226 | my $item = shift; 227 | return $self->add(item => $item, @_); 228 | } 229 | 230 | sub remove_items { 231 | my $self = shift; 232 | return map $_->{item}, $self->remove(@_); 233 | } 234 | 235 | sub matching_items { 236 | my $self = shift; 237 | return map $_->{item}, $self->matching(@_); 238 | } 239 | 240 | 1; 241 | 242 | __END__ 243 | 244 | =pod 245 | 246 | =head1 SYNOPSIS 247 | 248 | use HTTP::Config; 249 | my $c = HTTP::Config->new; 250 | $c->add(m_domain => ".example.com", m_scheme => "http", verbose => 1); 251 | 252 | use HTTP::Request; 253 | my $request = HTTP::Request->new(GET => "http://www.example.com"); 254 | 255 | if (my @m = $c->matching($request)) { 256 | print "Yadayada\n" if $m[0]->{verbose}; 257 | } 258 | 259 | =head1 DESCRIPTION 260 | 261 | An C object is a list of entries that 262 | can be matched against request or request/response pairs. Its 263 | purpose is to hold configuration data that can be looked up given a 264 | request or response object. 265 | 266 | Each configuration entry is a hash. Some keys specify matching to 267 | occur against attributes of request/response objects. Other keys can 268 | be used to hold user data. 269 | 270 | The following methods are provided: 271 | 272 | =over 4 273 | 274 | =item $conf = HTTP::Config->new 275 | 276 | Constructs a new empty C object and returns it. 277 | 278 | =item $conf->entries 279 | 280 | Returns the list of entries in the configuration object. 281 | In scalar context returns the number of entries. 282 | 283 | =item $conf->empty 284 | 285 | Return true if there are no entries in the configuration object. 286 | This is just a shorthand for C<< not $conf->entries >>. 287 | 288 | =item $conf->add( %matchspec, %other ) 289 | 290 | =item $conf->add( \%entry ) 291 | 292 | Adds a new entry to the configuration. 293 | You can either pass separate key/value pairs or a hash reference. 294 | 295 | =item $conf->remove( %spec ) 296 | 297 | Removes (and returns) the entries that have matches for all the key/value pairs in %spec. 298 | If %spec is empty this will match all entries; so it will empty the configuration object. 299 | 300 | =item $conf->matching( $uri, $request, $response ) 301 | 302 | =item $conf->matching( $uri ) 303 | 304 | =item $conf->matching( $request ) 305 | 306 | =item $conf->matching( $response ) 307 | 308 | Returns the entries that match the given $uri, $request and $response triplet. 309 | 310 | If called with a single $request object then the $uri is obtained by calling its 'uri_canonical' method. 311 | If called with a single $response object, then the request object is obtained by calling its 'request' method; 312 | and then the $uri is obtained as if a single $request was provided. 313 | 314 | The entries are returned with the most specific matches first. 315 | In scalar context returns the most specific match or C in none match. 316 | 317 | =item $conf->add_item( $item, %matchspec ) 318 | 319 | =item $conf->remove_items( %spec ) 320 | 321 | =item $conf->matching_items( $uri, $request, $response ) 322 | 323 | Wrappers that hides the entries themselves. 324 | 325 | =back 326 | 327 | =head2 Matching 328 | 329 | The following keys on a configuration entry specify matching. For all 330 | of these you can provide an array of values instead of a single value. 331 | The entry matches if at least one of the values in the array matches. 332 | 333 | Entries that require match against a response object attribute will never match 334 | unless a response object was provided. 335 | 336 | =over 337 | 338 | =item m_scheme => $scheme 339 | 340 | Matches if the URI uses the specified scheme; e.g. "http". 341 | 342 | =item m_secure => $bool 343 | 344 | If $bool is TRUE; matches if the URI uses a secure scheme. If $bool 345 | is FALSE; matches if the URI does not use a secure scheme. An example 346 | of a secure scheme is "https". 347 | 348 | =item m_host_port => "$hostname:$port" 349 | 350 | Matches if the URI's host_port method return the specified value. 351 | 352 | =item m_host => $hostname 353 | 354 | Matches if the URI's host method returns the specified value. 355 | 356 | =item m_port => $port 357 | 358 | Matches if the URI's port method returns the specified value. 359 | 360 | =item m_domain => ".$domain" 361 | 362 | Matches if the URI's host method return a value that within the given 363 | domain. The hostname "www.example.com" will for instance match the 364 | domain ".com". 365 | 366 | =item m_path => $path 367 | 368 | Matches if the URI's path method returns the specified value. 369 | 370 | =item m_path_prefix => $path 371 | 372 | Matches if the URI's path is the specified path or has the specified 373 | path as prefix. 374 | 375 | =item m_path_match => $Regexp 376 | 377 | Matches if the regular expression matches the URI's path. Eg. qr/\.html$/. 378 | 379 | =item m_method => $method 380 | 381 | Matches if the request method matches the specified value. Eg. "GET" or "POST". 382 | 383 | =item m_code => $digit 384 | 385 | =item m_code => $status_code 386 | 387 | Matches if the response status code matches. If a single digit is 388 | specified; matches for all response status codes beginning with that digit. 389 | 390 | =item m_proxy => $url 391 | 392 | Matches if the request is to be sent to the given Proxy server. 393 | 394 | =item m_media_type => "*/*" 395 | 396 | =item m_media_type => "text/*" 397 | 398 | =item m_media_type => "html" 399 | 400 | =item m_media_type => "xhtml" 401 | 402 | =item m_media_type => "text/html" 403 | 404 | Matches if the response media type matches. 405 | 406 | With a value of "html" matches if $response->content_is_html returns TRUE. 407 | With a value of "xhtml" matches if $response->content_is_xhtml returns TRUE. 408 | 409 | =item m_uri__I<$method> => undef 410 | 411 | Matches if the URI object provides the method. 412 | 413 | =item m_uri__I<$method> => $string 414 | 415 | Matches if the URI's $method method returns the given value. 416 | 417 | =item m_header__I<$field> => $string 418 | 419 | Matches if either the request or the response have a header $field with the given value. 420 | 421 | =item m_response_attr__I<$key> => undef 422 | 423 | =item m_response_attr__I<$key> => $string 424 | 425 | Matches if the response object has that key, or the entry has the given value. 426 | 427 | =back 428 | 429 | =head1 SEE ALSO 430 | 431 | L, L, L 432 | 433 | =cut 434 | 435 | #ABSTRACT: Configuration for request and response objects 436 | 437 | -------------------------------------------------------------------------------- /lib/HTTP/Headers/Auth.pm: -------------------------------------------------------------------------------- 1 | package HTTP::Headers::Auth; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | our $VERSION = '7.01'; 7 | 8 | use HTTP::Headers; 9 | 10 | package 11 | HTTP::Headers; 12 | 13 | BEGIN { 14 | # we provide a new (and better) implementations below 15 | undef(&www_authenticate); 16 | undef(&proxy_authenticate); 17 | } 18 | 19 | require HTTP::Headers::Util; 20 | 21 | sub _parse_authenticate 22 | { 23 | my @ret; 24 | for (HTTP::Headers::Util::split_header_words(@_)) { 25 | if (!defined($_->[1])) { 26 | # this is a new auth scheme 27 | push(@ret, shift(@$_) => {}); 28 | shift @$_; 29 | } 30 | if (@ret) { 31 | # this a new parameter pair for the last auth scheme 32 | while (@$_) { 33 | my $k = shift @$_; 34 | my $v = shift @$_; 35 | $ret[-1]{$k} = $v; 36 | } 37 | } 38 | else { 39 | # something wrong, parameter pair without any scheme seen 40 | # IGNORE 41 | } 42 | } 43 | @ret; 44 | } 45 | 46 | sub _authenticate 47 | { 48 | my $self = shift; 49 | my $header = shift; 50 | my @old = $self->_header($header); 51 | if (@_) { 52 | $self->remove_header($header); 53 | my @new = @_; 54 | while (@new) { 55 | my $a_scheme = shift(@new); 56 | if ($a_scheme =~ /\s/) { 57 | # assume complete valid value, pass it through 58 | $self->push_header($header, $a_scheme); 59 | } 60 | else { 61 | my @param; 62 | if (@new) { 63 | my $p = $new[0]; 64 | if (ref($p) eq "ARRAY") { 65 | @param = @$p; 66 | shift(@new); 67 | } 68 | elsif (ref($p) eq "HASH") { 69 | @param = %$p; 70 | shift(@new); 71 | } 72 | } 73 | my $val = ucfirst(lc($a_scheme)); 74 | if (@param) { 75 | my $sep = " "; 76 | while (@param) { 77 | my $k = shift @param; 78 | my $v = shift @param; 79 | if ($v =~ /[^0-9a-zA-Z]/ || lc($k) eq "realm") { 80 | # must quote the value 81 | $v =~ s,([\\\"]),\\$1,g; 82 | $v = qq("$v"); 83 | } 84 | $val .= "$sep$k=$v"; 85 | $sep = ", "; 86 | } 87 | } 88 | $self->push_header($header, $val); 89 | } 90 | } 91 | } 92 | return unless defined wantarray; 93 | wantarray ? _parse_authenticate(@old) : join(", ", @old); 94 | } 95 | 96 | 97 | sub www_authenticate { shift->_authenticate("WWW-Authenticate", @_) } 98 | sub proxy_authenticate { shift->_authenticate("Proxy-Authenticate", @_) } 99 | 100 | 1; 101 | -------------------------------------------------------------------------------- /lib/HTTP/Headers/ETag.pm: -------------------------------------------------------------------------------- 1 | package HTTP::Headers::ETag; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | our $VERSION = '7.01'; 7 | 8 | require HTTP::Date; 9 | 10 | require HTTP::Headers; 11 | package 12 | HTTP::Headers; 13 | 14 | sub _etags 15 | { 16 | my $self = shift; 17 | my $header = shift; 18 | my @old = _split_etag_list($self->_header($header)); 19 | if (@_) { 20 | $self->_header($header => join(", ", _split_etag_list(@_))); 21 | } 22 | wantarray ? @old : join(", ", @old); 23 | } 24 | 25 | sub etag { shift->_etags("ETag", @_); } 26 | sub if_match { shift->_etags("If-Match", @_); } 27 | sub if_none_match { shift->_etags("If-None-Match", @_); } 28 | 29 | sub if_range { 30 | # Either a date or an entity-tag 31 | my $self = shift; 32 | my @old = $self->_header("If-Range"); 33 | if (@_) { 34 | my $new = shift; 35 | if (!defined $new) { 36 | $self->remove_header("If-Range"); 37 | } 38 | elsif ($new =~ /^\d+$/) { 39 | $self->_date_header("If-Range", $new); 40 | } 41 | else { 42 | $self->_etags("If-Range", $new); 43 | } 44 | } 45 | return unless defined(wantarray); 46 | for (@old) { 47 | my $t = HTTP::Date::str2time($_); 48 | $_ = $t if $t; 49 | } 50 | wantarray ? @old : join(", ", @old); 51 | } 52 | 53 | 54 | # Split a list of entity tag values. The return value is a list 55 | # consisting of one element per entity tag. Suitable for parsing 56 | # headers like C, C. You might even want to 57 | # use it on C and C entity tag values, because it will 58 | # normalize them to the common form. 59 | # 60 | # entity-tag = [ weak ] opaque-tag 61 | # weak = "W/" 62 | # opaque-tag = quoted-string 63 | 64 | 65 | sub _split_etag_list 66 | { 67 | my(@val) = @_; 68 | my @res; 69 | for (@val) { 70 | while (length) { 71 | my $weak = ""; 72 | $weak = "W/" if s,^\s*[wW]/,,; 73 | my $etag = ""; 74 | if (s/^\s*(\"[^\"\\]*(?:\\.[^\"\\]*)*\")//) { 75 | push(@res, "$weak$1"); 76 | } 77 | elsif (s/^\s*,//) { 78 | push(@res, qq(W/"")) if $weak; 79 | } 80 | elsif (s/^\s*([^,\s]+)//) { 81 | $etag = $1; 82 | $etag =~ s/([\"\\])/\\$1/g; 83 | push(@res, qq($weak"$etag")); 84 | } 85 | elsif (s/^\s+// || !length) { 86 | push(@res, qq(W/"")) if $weak; 87 | } 88 | else { 89 | die "This should not happen: '$_'"; 90 | } 91 | } 92 | } 93 | @res; 94 | } 95 | 96 | 1; 97 | -------------------------------------------------------------------------------- /lib/HTTP/Headers/Util.pm: -------------------------------------------------------------------------------- 1 | package HTTP::Headers::Util; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | our $VERSION = '7.01'; 7 | 8 | use Exporter 5.57 'import'; 9 | 10 | our @EXPORT_OK=qw(split_header_words _split_header_words join_header_words); 11 | 12 | 13 | sub split_header_words { 14 | my @res = &_split_header_words; 15 | for my $arr (@res) { 16 | for (my $i = @$arr - 2; $i >= 0; $i -= 2) { 17 | $arr->[$i] = lc($arr->[$i]); 18 | } 19 | } 20 | return @res; 21 | } 22 | 23 | sub _split_header_words 24 | { 25 | my(@val) = @_; 26 | my @res; 27 | for (@val) { 28 | my @cur; 29 | while (length) { 30 | if (s/^\s*(=*[^\s=;,]+)//) { # 'token' or parameter 'attribute' 31 | push(@cur, $1); 32 | # a quoted value 33 | if (s/^\s*=\s*\"([^\"\\]*(?:\\.[^\"\\]*)*)\"//) { 34 | my $val = $1; 35 | $val =~ s/\\(.)/$1/g; 36 | push(@cur, $val); 37 | # some unquoted value 38 | } 39 | elsif (s/^\s*=\s*([^;,\s]*)//) { 40 | my $val = $1; 41 | $val =~ s/\s+$//; 42 | push(@cur, $val); 43 | # no value, a lone token 44 | } 45 | else { 46 | push(@cur, undef); 47 | } 48 | } 49 | elsif (s/^\s*,//) { 50 | push(@res, [@cur]) if @cur; 51 | @cur = (); 52 | } 53 | elsif (s/^\s*;// || s/^\s+// || s/^=//) { 54 | # continue 55 | } 56 | else { 57 | die "This should not happen: '$_'"; 58 | } 59 | } 60 | push(@res, \@cur) if @cur; 61 | } 62 | @res; 63 | } 64 | 65 | 66 | sub join_header_words 67 | { 68 | @_ = ([@_]) if @_ && !ref($_[0]); 69 | my @res; 70 | for (@_) { 71 | my @cur = @$_; 72 | my @attr; 73 | while (@cur) { 74 | my $k = shift @cur; 75 | my $v = shift @cur; 76 | if (defined $v) { 77 | if ($v =~ /[\x00-\x20()<>@,;:\\\"\/\[\]?={}\x7F-\xFF]/ || !length($v)) { 78 | $v =~ s/([\"\\])/\\$1/g; # escape " and \ 79 | $k .= qq(="$v"); 80 | } 81 | else { 82 | # token 83 | $k .= "=$v"; 84 | } 85 | } 86 | push(@attr, $k); 87 | } 88 | push(@res, join("; ", @attr)) if @attr; 89 | } 90 | join(", ", @res); 91 | } 92 | 93 | 94 | 1; 95 | 96 | __END__ 97 | 98 | =pod 99 | 100 | =head1 SYNOPSIS 101 | 102 | use HTTP::Headers::Util qw(split_header_words); 103 | @values = split_header_words($h->header("Content-Type")); 104 | 105 | =head1 DESCRIPTION 106 | 107 | This module provides a few functions that helps parsing and 108 | construction of valid HTTP header values. None of the functions are 109 | exported by default. 110 | 111 | The following functions are available: 112 | 113 | =over 4 114 | 115 | 116 | =item split_header_words( @header_values ) 117 | 118 | This function will parse the header values given as argument into a 119 | list of anonymous arrays containing key/value pairs. The function 120 | knows how to deal with ",", ";" and "=" as well as quoted values after 121 | "=". A list of space separated tokens are parsed as if they were 122 | separated by ";". 123 | 124 | If the @header_values passed as argument contains multiple values, 125 | then they are treated as if they were a single value separated by 126 | comma ",". 127 | 128 | This means that this function is useful for parsing header fields that 129 | follow this syntax (BNF as from the HTTP/1.1 specification, but we relax 130 | the requirement for tokens). 131 | 132 | headers = #header 133 | header = (token | parameter) *( [";"] (token | parameter)) 134 | 135 | token = 1* 136 | separators = "(" | ")" | "<" | ">" | "@" 137 | | "," | ";" | ":" | "\" | <"> 138 | | "/" | "[" | "]" | "?" | "=" 139 | | "{" | "}" | SP | HT 140 | 141 | quoted-string = ( <"> *(qdtext | quoted-pair ) <"> ) 142 | qdtext = > 143 | quoted-pair = "\" CHAR 144 | 145 | parameter = attribute "=" value 146 | attribute = token 147 | value = token | quoted-string 148 | 149 | Each I
is represented by an anonymous array of key/value 150 | pairs. The keys will be all be forced to lower case. 151 | The value for a simple token (not part of a parameter) is C. 152 | Syntactically incorrect headers will not necessarily be parsed as you 153 | would want. 154 | 155 | This is easier to describe with some examples: 156 | 157 | split_header_words('foo="bar"; port="80,81"; DISCARD, BAR=baz'); 158 | split_header_words('text/html; charset="iso-8859-1"'); 159 | split_header_words('Basic realm="\\"foo\\\\bar\\""'); 160 | 161 | will return 162 | 163 | [foo=>'bar', port=>'80,81', discard=> undef], [bar=>'baz' ] 164 | ['text/html' => undef, charset => 'iso-8859-1'] 165 | [basic => undef, realm => "\"foo\\bar\""] 166 | 167 | If you don't want the function to convert tokens and attribute keys to 168 | lower case you can call it as C<_split_header_words> instead (with a 169 | leading underscore). 170 | 171 | =item join_header_words( @arrays ) 172 | 173 | This will do the opposite of the conversion done by split_header_words(). 174 | It takes a list of anonymous arrays as arguments (or a list of 175 | key/value pairs) and produces a single header value. Attribute values 176 | are quoted if needed. 177 | 178 | Example: 179 | 180 | join_header_words(["text/plain" => undef, charset => "iso-8859/1"]); 181 | join_header_words("text/plain" => undef, charset => "iso-8859/1"); 182 | 183 | will both return the string: 184 | 185 | text/plain; charset="iso-8859/1" 186 | 187 | =back 188 | 189 | =cut 190 | 191 | #ABSTRACT: Header value parsing utility functions 192 | 193 | -------------------------------------------------------------------------------- /lib/HTTP/Request.pm: -------------------------------------------------------------------------------- 1 | package HTTP::Request; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | our $VERSION = '7.01'; 7 | 8 | use parent 'HTTP::Message'; 9 | 10 | sub new 11 | { 12 | my($class, $method, $uri, $header, $content) = @_; 13 | my $self = $class->SUPER::new($header, $content); 14 | $self->method($method); 15 | $self->uri($uri); 16 | $self; 17 | } 18 | 19 | 20 | sub parse 21 | { 22 | my($class, $str) = @_; 23 | Carp::carp('Undefined argument to parse()') if $^W && ! defined $str; 24 | my $request_line; 25 | if (defined $str && $str =~ s/^(.*)\n//) { 26 | $request_line = $1; 27 | } 28 | else { 29 | $request_line = $str; 30 | $str = ""; 31 | } 32 | 33 | my $self = $class->SUPER::parse($str); 34 | if (defined $request_line) { 35 | my($method, $uri, $protocol) = split(' ', $request_line); 36 | $self->method($method); 37 | $self->uri($uri) if defined($uri); 38 | $self->protocol($protocol) if $protocol; 39 | } 40 | $self; 41 | } 42 | 43 | 44 | sub clone 45 | { 46 | my $self = shift; 47 | my $clone = bless $self->SUPER::clone, ref($self); 48 | $clone->method($self->method); 49 | $clone->uri($self->uri); 50 | $clone; 51 | } 52 | 53 | 54 | sub method 55 | { 56 | shift->_elem('_method', @_); 57 | } 58 | 59 | 60 | sub uri 61 | { 62 | my $self = shift; 63 | my $old = $self->{'_uri'}; 64 | if (@_) { 65 | my $uri = shift; 66 | if (!defined $uri) { 67 | # that's ok 68 | } 69 | elsif (ref $uri) { 70 | Carp::croak("A URI can't be a " . ref($uri) . " reference") 71 | if ref($uri) eq 'HASH' or ref($uri) eq 'ARRAY'; 72 | Carp::croak("Can't use a " . ref($uri) . " object as a URI") 73 | unless $uri->can('scheme') && $uri->can('canonical'); 74 | $uri = $uri->clone; 75 | unless ($HTTP::URI_CLASS eq "URI") { 76 | # Argh!! Hate this... old LWP legacy! 77 | eval { local $SIG{__DIE__}; $uri = $uri->abs; }; 78 | die $@ if $@ && $@ !~ /Missing base argument/; 79 | } 80 | } 81 | else { 82 | $uri = $HTTP::URI_CLASS->new($uri); 83 | } 84 | $self->{'_uri'} = $uri; 85 | delete $self->{'_uri_canonical'}; 86 | } 87 | $old; 88 | } 89 | 90 | *url = \&uri; # legacy 91 | 92 | sub uri_canonical 93 | { 94 | my $self = shift; 95 | 96 | my $uri = $self->{_uri}; 97 | 98 | if (defined (my $canon = $self->{_uri_canonical})) { 99 | # early bailout if these are the exact same string; 100 | # rely on stringification of the URI objects 101 | return $canon if $canon eq $uri; 102 | } 103 | 104 | # otherwise we need to refresh the memoized value 105 | $self->{_uri_canonical} = $uri->canonical; 106 | } 107 | 108 | 109 | sub accept_decodable 110 | { 111 | my $self = shift; 112 | $self->header("Accept-Encoding", scalar($self->decodable)); 113 | } 114 | 115 | sub as_string 116 | { 117 | my $self = shift; 118 | my($eol) = @_; 119 | $eol = "\n" unless defined $eol; 120 | 121 | my $req_line = $self->method || "-"; 122 | my $uri = $self->uri; 123 | $uri = (defined $uri) ? $uri->as_string : "-"; 124 | $req_line .= " $uri"; 125 | my $proto = $self->protocol; 126 | $req_line .= " $proto" if $proto; 127 | 128 | return join($eol, $req_line, $self->SUPER::as_string(@_)); 129 | } 130 | 131 | sub dump 132 | { 133 | my $self = shift; 134 | my @pre = ($self->method || "-", $self->uri || "-"); 135 | if (my $prot = $self->protocol) { 136 | push(@pre, $prot); 137 | } 138 | 139 | return $self->SUPER::dump( 140 | preheader => join(" ", @pre), 141 | @_, 142 | ); 143 | } 144 | 145 | 146 | 1; 147 | 148 | __END__ 149 | 150 | =pod 151 | 152 | =head1 SYNOPSIS 153 | 154 | require HTTP::Request; 155 | $request = HTTP::Request->new(GET => 'http://www.example.com/'); 156 | 157 | and usually used like this: 158 | 159 | $ua = LWP::UserAgent->new; 160 | $response = $ua->request($request); 161 | 162 | =head1 DESCRIPTION 163 | 164 | C is a class encapsulating HTTP style requests, 165 | consisting of a request line, some headers, and a content body. Note 166 | that the LWP library uses HTTP style requests even for non-HTTP 167 | protocols. Instances of this class are usually passed to the 168 | request() method of an C object. 169 | 170 | C is a subclass of C and therefore 171 | inherits its methods. The following additional methods are available: 172 | 173 | =over 4 174 | 175 | =item $r = HTTP::Request->new( $method, $uri ) 176 | 177 | =item $r = HTTP::Request->new( $method, $uri, $header ) 178 | 179 | =item $r = HTTP::Request->new( $method, $uri, $header, $content ) 180 | 181 | Constructs a new C object describing a request on the 182 | object $uri using method $method. The $method argument must be a 183 | string. The $uri argument can be either a string, or a reference to a 184 | C object. The optional $header argument should be a reference to 185 | an C object or a plain array reference of key/value 186 | pairs. The optional $content argument should be a string of bytes. 187 | 188 | =item $r = HTTP::Request->parse( $str ) 189 | 190 | This constructs a new request object by parsing the given string. 191 | 192 | =item $r->method 193 | 194 | =item $r->method( $val ) 195 | 196 | This is used to get/set the method attribute. The method should be a 197 | short string like "GET", "HEAD", "PUT", "PATCH" or "POST". 198 | 199 | =item $r->uri 200 | 201 | =item $r->uri( $val ) 202 | 203 | This is used to get/set the uri attribute. The $val can be a 204 | reference to a URI object or a plain string. If a string is given, 205 | then it should be parsable as an absolute URI. 206 | 207 | =item $r->header( $field ) 208 | 209 | =item $r->header( $field => $value ) 210 | 211 | This is used to get/set header values and it is inherited from 212 | C via C. See L for 213 | details and other similar methods that can be used to access the 214 | headers. 215 | 216 | =item $r->accept_decodable 217 | 218 | This will set the C header to the list of encodings 219 | that decoded_content() can decode. 220 | 221 | =item $r->content 222 | 223 | =item $r->content( $bytes ) 224 | 225 | This is used to get/set the content and it is inherited from the 226 | C base class. See L for details and 227 | other methods that can be used to access the content. 228 | 229 | Note that the content should be a string of bytes. Strings in perl 230 | can contain characters outside the range of a byte. The C 231 | module can be used to turn such strings into a string of bytes. 232 | 233 | =item $r->as_string 234 | 235 | =item $r->as_string( $eol ) 236 | 237 | Method returning a textual representation of the request. 238 | 239 | =back 240 | 241 | =head1 EXAMPLES 242 | 243 | Creating requests to be sent with L or others can be easy. Here 244 | are a few examples. 245 | 246 | =head2 Simple POST 247 | 248 | Here, we'll create a simple POST request that could be used to send JSON data 249 | to an endpoint. 250 | 251 | #!/usr/bin/env perl 252 | 253 | use strict; 254 | use warnings; 255 | 256 | use HTTP::Request (); 257 | use JSON::MaybeXS qw(encode_json); 258 | 259 | my $url = 'https://www.example.com/api/user/123'; 260 | my $header = ['Content-Type' => 'application/json; charset=UTF-8']; 261 | my $data = {foo => 'bar', baz => 'quux'}; 262 | my $encoded_data = encode_json($data); 263 | 264 | my $r = HTTP::Request->new('POST', $url, $header, $encoded_data); 265 | # at this point, we could send it via LWP::UserAgent 266 | # my $ua = LWP::UserAgent->new(); 267 | # my $res = $ua->request($r); 268 | 269 | =head2 Batch POST Request 270 | 271 | Some services, like Google, allow multiple requests to be sent in one batch. 272 | L for example. Using the 273 | C method from L makes this simple. 274 | 275 | #!/usr/bin/env perl 276 | 277 | use strict; 278 | use warnings; 279 | 280 | use HTTP::Request (); 281 | use JSON::MaybeXS qw(encode_json); 282 | 283 | my $auth_token = 'auth_token'; 284 | my $batch_url = 'https://www.googleapis.com/batch'; 285 | my $url = 'https://www.googleapis.com/drive/v3/files/fileId/permissions?fields=id'; 286 | my $url_no_email = 'https://www.googleapis.com/drive/v3/files/fileId/permissions?fields=id&sendNotificationEmail=false'; 287 | 288 | # generate a JSON post request for one of the batch entries 289 | my $req1 = build_json_request($url, { 290 | emailAddress => 'example@appsrocks.com', 291 | role => "writer", 292 | type => "user", 293 | }); 294 | 295 | # generate a JSON post request for one of the batch entries 296 | my $req2 = build_json_request($url_no_email, { 297 | domain => "appsrocks.com", 298 | role => "reader", 299 | type => "domain", 300 | }); 301 | 302 | # generate a multipart request to send all of the other requests 303 | my $r = HTTP::Request->new('POST', $batch_url, [ 304 | 'Accept-Encoding' => 'gzip', 305 | # if we don't provide a boundary here, HTTP::Message will generate 306 | # one for us. We could use UUID::uuid() here if we wanted. 307 | 'Content-Type' => 'multipart/mixed; boundary=END_OF_PART' 308 | ]); 309 | 310 | # add the two POST requests to the main request 311 | $r->add_part($req1, $req2); 312 | # at this point, we could send it via LWP::UserAgent 313 | # my $ua = LWP::UserAgent->new(); 314 | # my $res = $ua->request($r); 315 | exit(); 316 | 317 | sub build_json_request { 318 | my ($url, $href) = @_; 319 | my $header = ['Authorization' => "Bearer $auth_token", 'Content-Type' => 'application/json; charset=UTF-8']; 320 | return HTTP::Request->new('POST', $url, $header, encode_json($href)); 321 | } 322 | 323 | 324 | =head1 SEE ALSO 325 | 326 | L, L, L, 327 | L 328 | 329 | =cut 330 | 331 | #ABSTRACT: HTTP style request message 332 | -------------------------------------------------------------------------------- /lib/HTTP/Request/Common.pm: -------------------------------------------------------------------------------- 1 | package HTTP::Request::Common; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | our $VERSION = '7.01'; 7 | 8 | our $DYNAMIC_FILE_UPLOAD ||= 0; # make it defined (don't know why) 9 | our $READ_BUFFER_SIZE = 8192; 10 | 11 | use Exporter 5.57 'import'; 12 | 13 | our @EXPORT =qw(GET HEAD PUT PATCH POST OPTIONS); 14 | our @EXPORT_OK = qw($DYNAMIC_FILE_UPLOAD DELETE); 15 | 16 | require HTTP::Request; 17 | use Carp(); 18 | use File::Spec; 19 | 20 | my $CRLF = "\015\012"; # "\r\n" is not portable 21 | 22 | sub GET { _simple_req('GET', @_); } 23 | sub HEAD { _simple_req('HEAD', @_); } 24 | sub DELETE { _simple_req('DELETE', @_); } 25 | sub PATCH { request_type_with_data('PATCH', @_); } 26 | sub POST { request_type_with_data('POST', @_); } 27 | sub PUT { request_type_with_data('PUT', @_); } 28 | sub OPTIONS { request_type_with_data('OPTIONS', @_); } 29 | 30 | sub request_type_with_data 31 | { 32 | my $type = shift; 33 | my $url = shift; 34 | my $req = HTTP::Request->new($type => $url); 35 | my $content; 36 | $content = shift if @_ and ref $_[0]; 37 | my($k, $v); 38 | while (($k,$v) = splice(@_, 0, 2)) { 39 | if (lc($k) eq 'content') { 40 | $content = $v; 41 | } 42 | else { 43 | $req->push_header($k, $v); 44 | } 45 | } 46 | my $ct = $req->header('Content-Type'); 47 | unless ($ct) { 48 | $ct = 'application/x-www-form-urlencoded'; 49 | } 50 | elsif ($ct eq 'form-data') { 51 | $ct = 'multipart/form-data'; 52 | } 53 | 54 | if (ref $content) { 55 | if ($ct =~ m,^multipart/form-data\s*(;|$),i) { 56 | require HTTP::Headers::Util; 57 | my @v = HTTP::Headers::Util::split_header_words($ct); 58 | Carp::carp("Multiple Content-Type headers") if @v > 1; 59 | @v = @{$v[0]}; 60 | 61 | my $boundary; 62 | my $boundary_index; 63 | for (my @tmp = @v; @tmp;) { 64 | my($k, $v) = splice(@tmp, 0, 2); 65 | if ($k eq "boundary") { 66 | $boundary = $v; 67 | $boundary_index = @v - @tmp - 1; 68 | last; 69 | } 70 | } 71 | 72 | ($content, $boundary) = form_data($content, $boundary, $req); 73 | 74 | if ($boundary_index) { 75 | $v[$boundary_index] = $boundary; 76 | } 77 | else { 78 | push(@v, boundary => $boundary); 79 | } 80 | 81 | $ct = HTTP::Headers::Util::join_header_words(@v); 82 | } 83 | else { 84 | # We use a temporary URI object to format 85 | # the application/x-www-form-urlencoded content. 86 | require URI; 87 | my $url = URI->new('http:'); 88 | $url->query_form(ref($content) eq "HASH" ? %$content : @$content); 89 | $content = $url->query; 90 | } 91 | } 92 | 93 | $req->header('Content-Type' => $ct); # might be redundant 94 | if (defined($content)) { 95 | $req->header('Content-Length' => 96 | length($content)) unless ref($content); 97 | $req->content($content); 98 | } 99 | else { 100 | $req->header('Content-Length' => 0); 101 | } 102 | $req; 103 | } 104 | 105 | 106 | sub _simple_req 107 | { 108 | my($method, $url) = splice(@_, 0, 2); 109 | my $req = HTTP::Request->new($method => $url); 110 | my($k, $v); 111 | my $content; 112 | while (($k,$v) = splice(@_, 0, 2)) { 113 | if (lc($k) eq 'content') { 114 | $req->add_content($v); 115 | $content++; 116 | } 117 | else { 118 | $req->push_header($k, $v); 119 | } 120 | } 121 | if ($content && !defined($req->header("Content-Length"))) { 122 | $req->header("Content-Length", length(${$req->content_ref})); 123 | } 124 | $req; 125 | } 126 | 127 | 128 | sub form_data # RFC1867 129 | { 130 | my($data, $boundary, $req) = @_; 131 | my @data = ref($data) eq "HASH" ? %$data : @$data; # copy 132 | my $fhparts; 133 | my @parts; 134 | while (my ($k,$v) = splice(@data, 0, 2)) { 135 | if (!ref($v)) { 136 | $k =~ s/([\\\"])/\\$1/g; # escape quotes and backslashes 137 | no warnings 'uninitialized'; 138 | push(@parts, 139 | qq(Content-Disposition: form-data; name="$k"$CRLF$CRLF$v)); 140 | } 141 | else { 142 | my($file, $usename, @headers) = @$v; 143 | unless (defined $usename) { 144 | $usename = $file; 145 | $usename = (File::Spec->splitpath($usename))[-1] if defined($usename); 146 | } 147 | $k =~ s/([\\\"])/\\$1/g; 148 | my $disp = qq(form-data; name="$k"); 149 | if (defined($usename) and length($usename)) { 150 | $usename =~ s/([\\\"])/\\$1/g; 151 | $disp .= qq(; filename="$usename"); 152 | } 153 | my $content = ""; 154 | my $h = HTTP::Headers->new(@headers); 155 | if ($file) { 156 | open(my $fh, "<", $file) or Carp::croak("Can't open file $file: $!"); 157 | binmode($fh); 158 | if ($DYNAMIC_FILE_UPLOAD) { 159 | # will read file later, close it now in order to 160 | # not accumulate to many open file handles 161 | close($fh); 162 | $content = \$file; 163 | } 164 | else { 165 | local($/) = undef; # slurp files 166 | $content = <$fh>; 167 | close($fh); 168 | } 169 | unless ($h->header("Content-Type")) { 170 | require LWP::MediaTypes; 171 | LWP::MediaTypes::guess_media_type($file, $h); 172 | } 173 | } 174 | if ($h->header("Content-Disposition")) { 175 | # just to get it sorted first 176 | $disp = $h->header("Content-Disposition"); 177 | $h->remove_header("Content-Disposition"); 178 | } 179 | if ($h->header("Content")) { 180 | $content = $h->header("Content"); 181 | $h->remove_header("Content"); 182 | } 183 | my $head = join($CRLF, "Content-Disposition: $disp", 184 | $h->as_string($CRLF), 185 | ""); 186 | if (ref $content) { 187 | push(@parts, [$head, $$content]); 188 | $fhparts++; 189 | } 190 | else { 191 | push(@parts, $head . $content); 192 | } 193 | } 194 | } 195 | return ("", "none") unless @parts; 196 | 197 | my $content; 198 | if ($fhparts) { 199 | $boundary = boundary(10) # hopefully enough randomness 200 | unless $boundary; 201 | 202 | # add the boundaries to the @parts array 203 | for (1..@parts-1) { 204 | splice(@parts, $_*2-1, 0, "$CRLF--$boundary$CRLF"); 205 | } 206 | unshift(@parts, "--$boundary$CRLF"); 207 | push(@parts, "$CRLF--$boundary--$CRLF"); 208 | 209 | # See if we can generate Content-Length header 210 | my $length = 0; 211 | for (@parts) { 212 | if (ref $_) { 213 | my ($head, $f) = @$_; 214 | my $file_size; 215 | unless ( -f $f && ($file_size = -s _) ) { 216 | # The file is either a dynamic file like /dev/audio 217 | # or perhaps a file in the /proc file system where 218 | # stat may return a 0 size even though reading it 219 | # will produce data. So we cannot make 220 | # a Content-Length header. 221 | undef $length; 222 | last; 223 | } 224 | $length += $file_size + length $head; 225 | } 226 | else { 227 | $length += length; 228 | } 229 | } 230 | $length && $req->header('Content-Length' => $length); 231 | 232 | # set up a closure that will return content piecemeal 233 | $content = sub { 234 | for (;;) { 235 | unless (@parts) { 236 | defined $length && $length != 0 && 237 | Carp::croak "length of data sent did not match calculated Content-Length header. Probably because uploaded file changed in size during transfer."; 238 | return; 239 | } 240 | my $p = shift @parts; 241 | unless (ref $p) { 242 | $p .= shift @parts while @parts && !ref($parts[0]); 243 | defined $length && ($length -= length $p); 244 | return $p; 245 | } 246 | my($buf, $fh) = @$p; 247 | unless (ref($fh)) { 248 | my $file = $fh; 249 | undef($fh); 250 | open($fh, "<", $file) || Carp::croak("Can't open file $file: $!"); 251 | binmode($fh); 252 | } 253 | my $buflength = length $buf; 254 | my $n = read($fh, $buf, $READ_BUFFER_SIZE, $buflength); 255 | if ($n) { 256 | $buflength += $n; 257 | unshift(@parts, ["", $fh]); 258 | } 259 | else { 260 | close($fh); 261 | } 262 | if ($buflength) { 263 | defined $length && ($length -= $buflength); 264 | return $buf 265 | } 266 | } 267 | }; 268 | 269 | } 270 | else { 271 | $boundary = boundary() unless $boundary; 272 | 273 | my $bno = 0; 274 | CHECK_BOUNDARY: 275 | { 276 | for (@parts) { 277 | if (index($_, $boundary) >= 0) { 278 | # must have a better boundary 279 | $boundary = boundary(++$bno); 280 | redo CHECK_BOUNDARY; 281 | } 282 | } 283 | last; 284 | } 285 | $content = "--$boundary$CRLF" . 286 | join("$CRLF--$boundary$CRLF", @parts) . 287 | "$CRLF--$boundary--$CRLF"; 288 | } 289 | 290 | wantarray ? ($content, $boundary) : $content; 291 | } 292 | 293 | 294 | sub boundary 295 | { 296 | my $size = shift || return "xYzZY"; 297 | require MIME::Base64; 298 | my $b = MIME::Base64::encode(join("", map chr(rand(256)), 1..$size*3), ""); 299 | $b =~ s/[\W]/X/g; # ensure alnum only 300 | $b; 301 | } 302 | 303 | 1; 304 | 305 | __END__ 306 | 307 | =pod 308 | 309 | =head1 SYNOPSIS 310 | 311 | use HTTP::Request::Common; 312 | $ua = LWP::UserAgent->new; 313 | $ua->request(GET 'http://www.sn.no/'); 314 | $ua->request(POST 'http://somewhere/foo', foo => bar, bar => foo); 315 | $ua->request(PATCH 'http://somewhere/foo', foo => bar, bar => foo); 316 | $ua->request(PUT 'http://somewhere/foo', foo => bar, bar => foo); 317 | $ua->request(OPTIONS 'http://somewhere/foo', foo => bar, bar => foo); 318 | 319 | =head1 DESCRIPTION 320 | 321 | This module provides functions that return newly created C 322 | objects. These functions are usually more convenient to use than the 323 | standard C constructor for the most common requests. 324 | 325 | Note that L has several convenience methods, including 326 | C, C, C, C and C. 327 | 328 | The following functions are provided: 329 | 330 | =over 4 331 | 332 | =item GET $url 333 | 334 | =item GET $url, Header => Value,... 335 | 336 | The C function returns an L object initialized with 337 | the "GET" method and the specified URL. It is roughly equivalent to the 338 | following call 339 | 340 | HTTP::Request->new( 341 | GET => $url, 342 | HTTP::Headers->new(Header => Value,...), 343 | ) 344 | 345 | but is less cluttered. What is different is that a header named 346 | C will initialize the content part of the request instead of 347 | setting a header field. Note that GET requests should normally not 348 | have a content, so this hack makes more sense for the C, C 349 | and C functions described below. 350 | 351 | The C method of L exists as a shortcut for 352 | C<< $ua->request(GET ...) >>. 353 | 354 | =item HEAD $url 355 | 356 | =item HEAD $url, Header => Value,... 357 | 358 | Like GET() but the method in the request is "HEAD". 359 | 360 | The C method of L exists as a shortcut for 361 | C<< $ua->request(HEAD ...) >>. 362 | 363 | =item DELETE $url 364 | 365 | =item DELETE $url, Header => Value,... 366 | 367 | Like C but the method in the request is C. This function 368 | is not exported by default. 369 | 370 | =item PATCH $url 371 | 372 | =item PATCH $url, Header => Value,... 373 | 374 | =item PATCH $url, $form_ref, Header => Value,... 375 | 376 | =item PATCH $url, Header => Value,..., Content => $form_ref 377 | 378 | =item PATCH $url, Header => Value,..., Content => $content 379 | 380 | The same as C below, but the method in the request is C. 381 | 382 | =item PUT $url 383 | 384 | =item PUT $url, Header => Value,... 385 | 386 | =item PUT $url, $form_ref, Header => Value,... 387 | 388 | =item PUT $url, Header => Value,..., Content => $form_ref 389 | 390 | =item PUT $url, Header => Value,..., Content => $content 391 | 392 | The same as C below, but the method in the request is C 393 | 394 | =item OPTIONS $url 395 | 396 | =item OPTIONS $url, Header => Value,... 397 | 398 | =item OPTIONS $url, $form_ref, Header => Value,... 399 | 400 | =item OPTIONS $url, Header => Value,..., Content => $form_ref 401 | 402 | =item OPTIONS $url, Header => Value,..., Content => $content 403 | 404 | The same as C below, but the method in the request is C 405 | 406 | This was added in version 6.21, so you should require that in your code: 407 | 408 | use HTTP::Request::Common 6.21; 409 | 410 | =item POST $url 411 | 412 | =item POST $url, Header => Value,... 413 | 414 | =item POST $url, $form_ref, Header => Value,... 415 | 416 | =item POST $url, Header => Value,..., Content => $form_ref 417 | 418 | =item POST $url, Header => Value,..., Content => $content 419 | 420 | C, C and C all work with the same parameters. 421 | 422 | %data = ( title => 'something', body => something else' ); 423 | $ua = LWP::UserAgent->new(); 424 | $request = HTTP::Request::Common::POST( $url, [ %data ] ); 425 | $response = $ua->request($request); 426 | 427 | They take a second optional array or hash reference 428 | parameter C<$form_ref>. The content can also be specified 429 | directly using the C pseudo-header, and you may also provide 430 | the C<$form_ref> this way. 431 | 432 | The C pseudo-header steals a bit of the header field namespace as 433 | there is no way to directly specify a header that is actually called 434 | "Content". If you really need this you must update the request 435 | returned in a separate statement. 436 | 437 | The C<$form_ref> argument can be used to pass key/value pairs for the 438 | form content. By default we will initialize a request using the 439 | C content type. This means that 440 | you can emulate an HTML Eform> POSTing like this: 441 | 442 | POST 'http://www.perl.org/survey.cgi', 443 | [ name => 'Gisle Aas', 444 | email => 'gisle@aas.no', 445 | gender => 'M', 446 | born => '1964', 447 | perc => '3%', 448 | ]; 449 | 450 | This will create an L object that looks like this: 451 | 452 | POST http://www.perl.org/survey.cgi 453 | Content-Length: 66 454 | Content-Type: application/x-www-form-urlencoded 455 | 456 | name=Gisle%20Aas&email=gisle%40aas.no&gender=M&born=1964&perc=3%25 457 | 458 | Multivalued form fields can be specified by either repeating the field 459 | name or by passing the value as an array reference. 460 | 461 | The POST method also supports the C content used 462 | for I as specified in RFC 1867. You trigger 463 | this content format by specifying a content type of C<'form-data'> as 464 | one of the request headers. If one of the values in the C<$form_ref> is 465 | an array reference, then it is treated as a file part specification 466 | with the following interpretation: 467 | 468 | [ $file, $filename, Header => Value... ] 469 | [ undef, $filename, Header => Value,..., Content => $content ] 470 | 471 | The first value in the array ($file) is the name of a file to open. 472 | This file will be read and its content placed in the request. The 473 | routine will croak if the file can't be opened. Use an C as 474 | $file value if you want to specify the content directly with a 475 | C header. The $filename is the filename to report in the 476 | request. If this value is undefined, then the basename of the $file 477 | will be used. You can specify an empty string as $filename if you 478 | want to suppress sending the filename when you provide a $file value. 479 | 480 | If a $file is provided by no C header, then C 481 | and C will be filled in automatically with the values 482 | returned by C 483 | 484 | Sending my F<~/.profile> to the survey used as example above can be 485 | achieved by this: 486 | 487 | POST 'http://www.perl.org/survey.cgi', 488 | Content_Type => 'form-data', 489 | Content => [ name => 'Gisle Aas', 490 | email => 'gisle@aas.no', 491 | gender => 'M', 492 | born => '1964', 493 | init => ["$ENV{HOME}/.profile"], 494 | ] 495 | 496 | This will create an L object that almost looks this (the 497 | boundary and the content of your F<~/.profile> is likely to be 498 | different): 499 | 500 | POST http://www.perl.org/survey.cgi 501 | Content-Length: 388 502 | Content-Type: multipart/form-data; boundary="6G+f" 503 | 504 | --6G+f 505 | Content-Disposition: form-data; name="name" 506 | 507 | Gisle Aas 508 | --6G+f 509 | Content-Disposition: form-data; name="email" 510 | 511 | gisle@aas.no 512 | --6G+f 513 | Content-Disposition: form-data; name="gender" 514 | 515 | M 516 | --6G+f 517 | Content-Disposition: form-data; name="born" 518 | 519 | 1964 520 | --6G+f 521 | Content-Disposition: form-data; name="init"; filename=".profile" 522 | Content-Type: text/plain 523 | 524 | PATH=/local/perl/bin:$PATH 525 | export PATH 526 | 527 | --6G+f-- 528 | 529 | If you set the C<$DYNAMIC_FILE_UPLOAD> variable (exportable) to some TRUE 530 | value, then you get back a request object with a subroutine closure as 531 | the content attribute. This subroutine will read the content of any 532 | files on demand and return it in suitable chunks. This allow you to 533 | upload arbitrary big files without using lots of memory. You can even 534 | upload infinite files like F if you wish; however, if 535 | the file is not a plain file, there will be no C header 536 | defined for the request. Not all servers (or server 537 | applications) like this. Also, if the file(s) change in size between 538 | the time the C is calculated and the time that the last 539 | chunk is delivered, the subroutine will C. 540 | 541 | The C method of L exists as a shortcut for 542 | C<< $ua->request(POST ...) >>. 543 | 544 | =back 545 | 546 | =head1 SEE ALSO 547 | 548 | L, L 549 | 550 | Also, there are some examples in L that you might 551 | find useful. For example, batch requests are explained there. 552 | 553 | =cut 554 | 555 | #ABSTRACT: Construct common HTTP::Request objects 556 | -------------------------------------------------------------------------------- /lib/HTTP/Response.pm: -------------------------------------------------------------------------------- 1 | package HTTP::Response; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | our $VERSION = '7.01'; 7 | 8 | use parent 'HTTP::Message'; 9 | 10 | use HTTP::Status (); 11 | 12 | 13 | sub new 14 | { 15 | my($class, $rc, $msg, $header, $content) = @_; 16 | my $self = $class->SUPER::new($header, $content); 17 | $self->code($rc); 18 | $self->message($msg); 19 | $self; 20 | } 21 | 22 | 23 | sub parse 24 | { 25 | my($class, $str) = @_; 26 | Carp::carp('Undefined argument to parse()') if $^W && ! defined $str; 27 | my $status_line; 28 | if (defined $str && $str =~ s/^(.*)\n//) { 29 | $status_line = $1; 30 | } 31 | else { 32 | $status_line = $str; 33 | $str = ""; 34 | } 35 | 36 | $status_line =~ s/\r\z// if defined $status_line; 37 | 38 | my $self = $class->SUPER::parse($str); 39 | if (defined $status_line) { 40 | my($protocol, $code, $message); 41 | if ($status_line =~ /^\d{3} /) { 42 | # Looks like a response created by HTTP::Response->new 43 | ($code, $message) = split(' ', $status_line, 2); 44 | } else { 45 | ($protocol, $code, $message) = split(' ', $status_line, 3); 46 | } 47 | $self->protocol($protocol) if $protocol; 48 | $self->code($code) if defined($code); 49 | $self->message($message) if defined($message); 50 | } 51 | $self; 52 | } 53 | 54 | 55 | sub clone 56 | { 57 | my $self = shift; 58 | my $clone = bless $self->SUPER::clone, ref($self); 59 | $clone->code($self->code); 60 | $clone->message($self->message); 61 | $clone->request($self->request->clone) if $self->request; 62 | # we don't clone previous 63 | $clone; 64 | } 65 | 66 | 67 | sub code { shift->_elem('_rc', @_); } 68 | sub message { shift->_elem('_msg', @_); } 69 | sub previous { shift->_elem('_previous',@_); } 70 | sub request { shift->_elem('_request', @_); } 71 | 72 | 73 | sub status_line 74 | { 75 | my $self = shift; 76 | my $code = $self->{'_rc'} || "000"; 77 | my $mess = $self->{'_msg'} || HTTP::Status::status_message($code) || "Unknown code"; 78 | return "$code $mess"; 79 | } 80 | 81 | 82 | sub base 83 | { 84 | my $self = shift; 85 | my $base = ( 86 | $self->header('Content-Base'), # used to be HTTP/1.1 87 | $self->header('Base'), # HTTP/1.0 88 | )[0]; 89 | if ($base && $base =~ /^$URI::scheme_re:/o) { 90 | # already absolute 91 | return $HTTP::URI_CLASS->new($base); 92 | } 93 | 94 | my $req = $self->request; 95 | if ($req) { 96 | # if $base is undef here, the return value is effectively 97 | # just a copy of $self->request->uri. 98 | return $HTTP::URI_CLASS->new_abs($base, $req->uri); 99 | } 100 | 101 | # can't find an absolute base 102 | return undef; 103 | } 104 | 105 | 106 | sub redirects { 107 | my $self = shift; 108 | my @r; 109 | my $r = $self; 110 | while (my $p = $r->previous) { 111 | push(@r, $p); 112 | $r = $p; 113 | } 114 | return @r unless wantarray; 115 | return reverse @r; 116 | } 117 | 118 | 119 | sub filename 120 | { 121 | my $self = shift; 122 | my $file; 123 | 124 | my $cd = $self->header('Content-Disposition'); 125 | if ($cd) { 126 | require HTTP::Headers::Util; 127 | if (my @cd = HTTP::Headers::Util::split_header_words($cd)) { 128 | my ($disposition, undef, %cd_param) = @{$cd[-1]}; 129 | $file = $cd_param{filename}; 130 | 131 | # RFC 2047 encoded? 132 | if ($file && $file =~ /^=\?(.+?)\?(.+?)\?(.+)\?=$/) { 133 | my $charset = $1; 134 | my $encoding = uc($2); 135 | my $encfile = $3; 136 | 137 | if ($encoding eq 'Q' || $encoding eq 'B') { 138 | local($SIG{__DIE__}); 139 | eval { 140 | if ($encoding eq 'Q') { 141 | $encfile =~ s/_/ /g; 142 | require MIME::QuotedPrint; 143 | $encfile = MIME::QuotedPrint::decode($encfile); 144 | } 145 | else { # $encoding eq 'B' 146 | require MIME::Base64; 147 | $encfile = MIME::Base64::decode($encfile); 148 | } 149 | 150 | require Encode; 151 | require Encode::Locale; 152 | Encode::from_to($encfile, $charset, "locale_fs"); 153 | }; 154 | 155 | $file = $encfile unless $@; 156 | } 157 | } 158 | } 159 | } 160 | 161 | unless (defined($file) && length($file)) { 162 | my $uri; 163 | if (my $cl = $self->header('Content-Location')) { 164 | $uri = URI->new($cl); 165 | } 166 | elsif (my $request = $self->request) { 167 | $uri = $request->uri; 168 | } 169 | 170 | if ($uri) { 171 | $file = ($uri->path_segments)[-1]; 172 | } 173 | } 174 | 175 | if ($file) { 176 | $file =~ s,.*[\\/],,; # basename 177 | } 178 | 179 | if ($file && !length($file)) { 180 | $file = undef; 181 | } 182 | 183 | $file; 184 | } 185 | 186 | 187 | sub as_string 188 | { 189 | my $self = shift; 190 | my($eol) = @_; 191 | $eol = "\n" unless defined $eol; 192 | 193 | my $status_line = $self->status_line; 194 | my $proto = $self->protocol; 195 | $status_line = "$proto $status_line" if $proto; 196 | 197 | return join($eol, $status_line, $self->SUPER::as_string(@_)); 198 | } 199 | 200 | 201 | sub dump 202 | { 203 | my $self = shift; 204 | 205 | my $status_line = $self->status_line; 206 | my $proto = $self->protocol; 207 | $status_line = "$proto $status_line" if $proto; 208 | 209 | return $self->SUPER::dump( 210 | preheader => $status_line, 211 | @_, 212 | ); 213 | } 214 | 215 | 216 | sub is_info { HTTP::Status::is_info (shift->{'_rc'}); } 217 | sub is_success { HTTP::Status::is_success (shift->{'_rc'}); } 218 | sub is_redirect { HTTP::Status::is_redirect (shift->{'_rc'}); } 219 | sub is_error { HTTP::Status::is_error (shift->{'_rc'}); } 220 | sub is_client_error { HTTP::Status::is_client_error (shift->{'_rc'}); } 221 | sub is_server_error { HTTP::Status::is_server_error (shift->{'_rc'}); } 222 | 223 | 224 | sub error_as_HTML 225 | { 226 | my $self = shift; 227 | my $title = 'An Error Occurred'; 228 | my $body = $self->status_line; 229 | $body =~ s/&/&/g; 230 | $body =~ s/ 233 | $title 234 | 235 |

$title

236 |

$body

237 | 238 | 239 | EOM 240 | } 241 | 242 | 243 | sub current_age 244 | { 245 | my $self = shift; 246 | my $time = shift; 247 | 248 | # Implementation of RFC 2616 section 13.2.3 249 | # (age calculations) 250 | my $response_time = $self->client_date; 251 | my $date = $self->date; 252 | 253 | my $age = 0; 254 | if ($response_time && $date) { 255 | $age = $response_time - $date; # apparent_age 256 | $age = 0 if $age < 0; 257 | } 258 | 259 | my $age_v = $self->header('Age'); 260 | if ($age_v && $age_v > $age) { 261 | $age = $age_v; # corrected_received_age 262 | } 263 | 264 | if ($response_time) { 265 | my $request = $self->request; 266 | if ($request) { 267 | my $request_time = $request->date; 268 | if ($request_time && $request_time < $response_time) { 269 | # Add response_delay to age to get 'corrected_initial_age' 270 | $age += $response_time - $request_time; 271 | } 272 | } 273 | $age += ($time || time) - $response_time; 274 | } 275 | return $age; 276 | } 277 | 278 | 279 | sub freshness_lifetime 280 | { 281 | my($self, %opt) = @_; 282 | 283 | # First look for the Cache-Control: max-age=n header 284 | for my $cc ($self->header('Cache-Control')) { 285 | for my $cc_dir (split(/\s*,\s*/, $cc)) { 286 | return $1 if $cc_dir =~ /^max-age\s*=\s*(\d+)/i; 287 | } 288 | } 289 | 290 | # Next possibility is to look at the "Expires" header 291 | my $date = $self->date || $self->client_date || $opt{time} || time; 292 | if (my $expires = $self->expires) { 293 | return $expires - $date; 294 | } 295 | 296 | # Must apply heuristic expiration 297 | return undef if exists $opt{heuristic_expiry} && !$opt{heuristic_expiry}; 298 | 299 | # Default heuristic expiration parameters 300 | $opt{h_min} ||= 60; 301 | $opt{h_max} ||= 24 * 3600; 302 | $opt{h_lastmod_fraction} ||= 0.10; # 10% since last-mod suggested by RFC2616 303 | $opt{h_default} ||= 3600; 304 | 305 | # Should give a warning if more than 24 hours according to 306 | # RFC 2616 section 13.2.4. Here we just make this the default 307 | # maximum value. 308 | 309 | if (my $last_modified = $self->last_modified) { 310 | my $h_exp = ($date - $last_modified) * $opt{h_lastmod_fraction}; 311 | return $opt{h_min} if $h_exp < $opt{h_min}; 312 | return $opt{h_max} if $h_exp > $opt{h_max}; 313 | return $h_exp; 314 | } 315 | 316 | # default when all else fails 317 | return $opt{h_min} if $opt{h_min} > $opt{h_default}; 318 | return $opt{h_default}; 319 | } 320 | 321 | 322 | sub is_fresh 323 | { 324 | my($self, %opt) = @_; 325 | $opt{time} ||= time; 326 | my $f = $self->freshness_lifetime(%opt); 327 | return undef unless defined($f); 328 | return $f > $self->current_age($opt{time}); 329 | } 330 | 331 | 332 | sub fresh_until 333 | { 334 | my($self, %opt) = @_; 335 | $opt{time} ||= time; 336 | my $f = $self->freshness_lifetime(%opt); 337 | return undef unless defined($f); 338 | return $f - $self->current_age($opt{time}) + $opt{time}; 339 | } 340 | 341 | 1; 342 | 343 | 344 | __END__ 345 | 346 | =pod 347 | 348 | =head1 SYNOPSIS 349 | 350 | Response objects are returned by the request() method of the C: 351 | 352 | # ... 353 | $response = $ua->request($request); 354 | if ($response->is_success) { 355 | print $response->decoded_content; 356 | } 357 | else { 358 | print STDERR $response->status_line, "\n"; 359 | } 360 | 361 | =head1 DESCRIPTION 362 | 363 | The C class encapsulates HTTP style responses. A 364 | response consists of a response line, some headers, and a content 365 | body. Note that the LWP library uses HTTP style responses even for 366 | non-HTTP protocol schemes. Instances of this class are usually 367 | created and returned by the request() method of an C 368 | object. 369 | 370 | C is a subclass of C and therefore 371 | inherits its methods. The following additional methods are available: 372 | 373 | =over 4 374 | 375 | =item $r = HTTP::Response->new( $code ) 376 | 377 | =item $r = HTTP::Response->new( $code, $msg ) 378 | 379 | =item $r = HTTP::Response->new( $code, $msg, $header ) 380 | 381 | =item $r = HTTP::Response->new( $code, $msg, $header, $content ) 382 | 383 | Constructs a new C object describing a response with 384 | response code $code and optional message $msg. The optional $header 385 | argument should be a reference to an C object or a 386 | plain array reference of key/value pairs. The optional $content 387 | argument should be a string of bytes. The meanings of these arguments are 388 | described below. 389 | 390 | =item $r = HTTP::Response->parse( $str ) 391 | 392 | This constructs a new response object by parsing the given string. 393 | 394 | =item $r->code 395 | 396 | =item $r->code( $code ) 397 | 398 | This is used to get/set the code attribute. The code is a 3 digit 399 | number that encode the overall outcome of an HTTP response. The 400 | C module provide constants that provide mnemonic names 401 | for the code attribute. 402 | 403 | =item $r->message 404 | 405 | =item $r->message( $message ) 406 | 407 | This is used to get/set the message attribute. The message is a short 408 | human readable single line string that explains the response code. 409 | 410 | =item $r->header( $field ) 411 | 412 | =item $r->header( $field => $value ) 413 | 414 | This is used to get/set header values and it is inherited from 415 | C via C. See L for 416 | details and other similar methods that can be used to access the 417 | headers. 418 | 419 | =item $r->content 420 | 421 | =item $r->content( $bytes ) 422 | 423 | This is used to get/set the raw content and it is inherited from the 424 | C base class. See L for details and 425 | other methods that can be used to access the content. 426 | 427 | =item $r->decoded_content( %options ) 428 | 429 | This will return the content after any C and 430 | charsets have been decoded. See L for details. 431 | 432 | =item $r->request 433 | 434 | =item $r->request( $request ) 435 | 436 | This is used to get/set the request attribute. The request attribute 437 | is a reference to the request that caused this response. It does 438 | not have to be the same request passed to the $ua->request() method, 439 | because there might have been redirects and authorization retries in 440 | between. 441 | 442 | =item $r->previous 443 | 444 | =item $r->previous( $response ) 445 | 446 | This is used to get/set the previous attribute. The previous 447 | attribute is used to link together chains of responses. You get 448 | chains of responses if the first response is redirect or unauthorized. 449 | The value is C if this is the first response in a chain. 450 | 451 | Note that the method $r->redirects is provided as a more convenient 452 | way to access the response chain. 453 | 454 | =item $r->status_line 455 | 456 | Returns the string "Ecode> Emessage>". If the message attribute 457 | is not set then the official name of Ecode> (see L) 458 | is substituted. 459 | 460 | =item $r->base 461 | 462 | Returns the base URI for this response. The return value will be a 463 | reference to a URI object. 464 | 465 | The base URI is obtained from one the following sources (in priority 466 | order): 467 | 468 | =over 4 469 | 470 | =item 1. 471 | 472 | Embedded in the document content, for instance 473 | in HTML documents. 474 | 475 | =item 2. 476 | 477 | A "Content-Base:" header in the response. 478 | 479 | For backwards compatibility with older HTTP implementations we will 480 | also look for the "Base:" header. 481 | 482 | =item 3. 483 | 484 | The URI used to request this response. This might not be the original 485 | URI that was passed to $ua->request() method, because we might have 486 | received some redirect responses first. 487 | 488 | =back 489 | 490 | If none of these sources provide an absolute URI, undef is returned. 491 | 492 | B: previous versions of HTTP::Response would also consider 493 | a "Content-Location:" header, 494 | as L said it should be. 495 | But this was never widely implemented by browsers, 496 | and now L 497 | says it should no longer be considered. 498 | 499 | When the LWP protocol modules produce the HTTP::Response object, then any base 500 | URI embedded in the document (step 1) will already have initialized the 501 | "Content-Base:" header. (See L). This means that 502 | this method only performs the last 2 steps (the content is not always available 503 | either). 504 | 505 | =item $r->filename 506 | 507 | Returns a filename for this response. Note that doing sanity checks 508 | on the returned filename (eg. removing characters that cannot be used 509 | on the target filesystem where the filename would be used, and 510 | laundering it for security purposes) are the caller's responsibility; 511 | the only related thing done by this method is that it makes a simple 512 | attempt to return a plain filename with no preceding path segments. 513 | 514 | The filename is obtained from one the following sources (in priority 515 | order): 516 | 517 | =over 4 518 | 519 | =item 1. 520 | 521 | A "Content-Disposition:" header in the response. Proper decoding of 522 | RFC 2047 encoded filenames requires the C (for "Q" 523 | encoding), C (for "B" encoding), and C modules. 524 | 525 | =item 2. 526 | 527 | A "Content-Location:" header in the response. 528 | 529 | =item 3. 530 | 531 | The URI used to request this response. This might not be the original 532 | URI that was passed to $ua->request() method, because we might have 533 | received some redirect responses first. 534 | 535 | =back 536 | 537 | If a filename cannot be derived from any of these sources, undef is 538 | returned. 539 | 540 | =item $r->as_string 541 | 542 | =item $r->as_string( $eol ) 543 | 544 | Returns a textual representation of the response. 545 | 546 | =item $r->is_info 547 | 548 | =item $r->is_success 549 | 550 | =item $r->is_redirect 551 | 552 | =item $r->is_error 553 | 554 | =item $r->is_client_error 555 | 556 | =item $r->is_server_error 557 | 558 | These methods indicate if the response was informational, successful, a 559 | redirection, or an error. See L for the meaning of these. 560 | 561 | =item $r->error_as_HTML 562 | 563 | Returns a string containing a complete HTML document indicating what 564 | error occurred. This method should only be called when $r->is_error 565 | is TRUE. 566 | 567 | =item $r->redirects 568 | 569 | Returns the list of redirect responses that lead up to this response 570 | by following the $r->previous chain. The list order is oldest first. 571 | 572 | In scalar context return the number of redirect responses leading up 573 | to this one. 574 | 575 | =item $r->current_age 576 | 577 | Calculates the "current age" of the response as specified by RFC 2616 578 | section 13.2.3. The age of a response is the time since it was sent 579 | by the origin server. The returned value is a number representing the 580 | age in seconds. 581 | 582 | =item $r->freshness_lifetime( %opt ) 583 | 584 | Calculates the "freshness lifetime" of the response as specified by 585 | RFC 2616 section 13.2.4. The "freshness lifetime" is the length of 586 | time between the generation of a response and its expiration time. 587 | The returned value is the number of seconds until expiry. 588 | 589 | If the response does not contain an "Expires" or a "Cache-Control" 590 | header, then this function will apply some simple heuristic based on 591 | the "Last-Modified" header to determine a suitable lifetime. The 592 | following options might be passed to control the heuristics: 593 | 594 | =over 595 | 596 | =item heuristic_expiry => $bool 597 | 598 | If passed as a FALSE value, don't apply heuristics and just return 599 | C when "Expires" or "Cache-Control" is lacking. 600 | 601 | =item h_lastmod_fraction => $num 602 | 603 | This number represent the fraction of the difference since the 604 | "Last-Modified" timestamp to make the expiry time. The default is 605 | C<0.10>, the suggested typical setting of 10% in RFC 2616. 606 | 607 | =item h_min => $sec 608 | 609 | This is the lower limit of the heuristic expiry age to use. The 610 | default is C<60> (1 minute). 611 | 612 | =item h_max => $sec 613 | 614 | This is the upper limit of the heuristic expiry age to use. The 615 | default is C<86400> (24 hours). 616 | 617 | =item h_default => $sec 618 | 619 | This is the expiry age to use when nothing else applies. The default 620 | is C<3600> (1 hour) or "h_min" if greater. 621 | 622 | =back 623 | 624 | =item $r->is_fresh( %opt ) 625 | 626 | Returns TRUE if the response is fresh, based on the values of 627 | freshness_lifetime() and current_age(). If the response is no longer 628 | fresh, then it has to be re-fetched or re-validated by the origin 629 | server. 630 | 631 | Options might be passed to control expiry heuristics, see the 632 | description of freshness_lifetime(). 633 | 634 | =item $r->fresh_until( %opt ) 635 | 636 | Returns the time (seconds since epoch) when this entity is no longer fresh. 637 | 638 | Options might be passed to control expiry heuristics, see the 639 | description of freshness_lifetime(). 640 | 641 | =back 642 | 643 | =head1 SEE ALSO 644 | 645 | L, L, L, L 646 | 647 | =cut 648 | 649 | #ABSTRACT: HTTP style response message 650 | 651 | -------------------------------------------------------------------------------- /lib/HTTP/Status.pm: -------------------------------------------------------------------------------- 1 | package HTTP::Status; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | our $VERSION = '7.01'; 7 | 8 | use Exporter 5.57 'import'; 9 | 10 | our @EXPORT = qw(is_info is_success is_redirect is_error status_message); 11 | our @EXPORT_OK = qw(is_client_error is_server_error is_cacheable_by_default status_constant_name status_codes); 12 | 13 | # Note also addition of mnemonics to @EXPORT below 14 | 15 | # Unmarked codes are from RFC 7231 (2017-12-20) 16 | # See also: 17 | # https://www.iana.org/assignments/http-status-codes/http-status-codes.xhtml 18 | 19 | my %StatusCode = ( 20 | 100 => 'Continue', 21 | 101 => 'Switching Protocols', 22 | 102 => 'Processing', # RFC 2518: WebDAV 23 | 103 => 'Early Hints', # RFC 8297: Indicating Hints 24 | # 104 .. 199 25 | 200 => 'OK', 26 | 201 => 'Created', 27 | 202 => 'Accepted', 28 | 203 => 'Non-Authoritative Information', 29 | 204 => 'No Content', 30 | 205 => 'Reset Content', 31 | 206 => 'Partial Content', # RFC 7233: Range Requests 32 | 207 => 'Multi-Status', # RFC 4918: WebDAV 33 | 208 => 'Already Reported', # RFC 5842: WebDAV bindings 34 | # 209 .. 225 35 | 226 => 'IM Used', # RFC 3229: Delta encoding 36 | # 227 .. 299 37 | 300 => 'Multiple Choices', 38 | 301 => 'Moved Permanently', 39 | 302 => 'Found', 40 | 303 => 'See Other', 41 | 304 => 'Not Modified', # RFC 7232: Conditional Request 42 | 305 => 'Use Proxy', 43 | 306 => '(Unused)', # RFC 9110: Previously used and reserved 44 | 307 => 'Temporary Redirect', 45 | 308 => 'Permanent Redirect', # RFC 7528: Permanent Redirect 46 | # 309 .. 399 47 | 400 => 'Bad Request', 48 | 401 => 'Unauthorized', # RFC 7235: Authentication 49 | 402 => 'Payment Required', 50 | 403 => 'Forbidden', 51 | 404 => 'Not Found', 52 | 405 => 'Method Not Allowed', 53 | 406 => 'Not Acceptable', 54 | 407 => 'Proxy Authentication Required', # RFC 7235: Authentication 55 | 408 => 'Request Timeout', 56 | 409 => 'Conflict', 57 | 410 => 'Gone', 58 | 411 => 'Length Required', 59 | 412 => 'Precondition Failed', # RFC 7232: Conditional Request 60 | 413 => 'Content Too Large', 61 | 414 => 'URI Too Long', 62 | 415 => 'Unsupported Media Type', 63 | 416 => 'Range Not Satisfiable', # RFC 7233: Range Requests 64 | 417 => 'Expectation Failed', 65 | 418 => "I'm a teapot", # RFC 2324: RFC9110 reserved it 66 | # 419 .. 420 67 | 421 => 'Misdirected Request', # RFC 7540: HTTP/2 68 | 422 => 'Unprocessable Content', # RFC 9110: WebDAV 69 | 423 => 'Locked', # RFC 4918: WebDAV 70 | 424 => 'Failed Dependency', # RFC 4918: WebDAV 71 | 425 => 'Too Early', # RFC 8470: Using Early Data in HTTP 72 | 426 => 'Upgrade Required', 73 | # 427 74 | 428 => 'Precondition Required', # RFC 6585: Additional Codes 75 | 429 => 'Too Many Requests', # RFC 6585: Additional Codes 76 | # 430 77 | 431 => 'Request Header Fields Too Large', # RFC 6585: Additional Codes 78 | # 432 .. 450 79 | 451 => 'Unavailable For Legal Reasons', # RFC 7725: Legal Obstacles 80 | # 452 .. 499 81 | 500 => 'Internal Server Error', 82 | 501 => 'Not Implemented', 83 | 502 => 'Bad Gateway', 84 | 503 => 'Service Unavailable', 85 | 504 => 'Gateway Timeout', 86 | 505 => 'HTTP Version Not Supported', 87 | 506 => 'Variant Also Negotiates', # RFC 2295: Transparent Ngttn 88 | 507 => 'Insufficient Storage', # RFC 4918: WebDAV 89 | 508 => 'Loop Detected', # RFC 5842: WebDAV bindings 90 | # 509 91 | 510 => 'Not Extended', # RFC 2774: Extension Framework 92 | 511 => 'Network Authentication Required', # RFC 6585: Additional Codes 93 | 94 | # Keep some unofficial codes that used to be in this distribution 95 | 449 => 'Retry with', # microsoft 96 | 509 => 'Bandwidth Limit Exceeded', # Apache / cPanel 97 | ); 98 | 99 | my %StatusCodeName; 100 | my $mnemonicCode = ''; 101 | my ($code, $message); 102 | while (($code, $message) = each %StatusCode) { 103 | next if $message eq '(Unused)'; 104 | # create mnemonic subroutines 105 | $message =~ s/I'm/I am/; 106 | $message =~ tr/a-z \-/A-Z__/; 107 | my $constant_name = "HTTP_".$message; 108 | $mnemonicCode .= "sub $constant_name () { $code }\n"; 109 | $mnemonicCode .= "*RC_$message = \\&HTTP_$message;\n"; # legacy 110 | $mnemonicCode .= "push(\@EXPORT_OK, 'HTTP_$message');\n"; 111 | $mnemonicCode .= "push(\@EXPORT, 'RC_$message');\n"; 112 | $StatusCodeName{$code} = $constant_name 113 | } 114 | eval $mnemonicCode; # only one eval for speed 115 | die if $@; 116 | 117 | # backwards compatibility 118 | *RC_MOVED_TEMPORARILY = \&RC_FOUND; # 302 was renamed in the standard 119 | push(@EXPORT, "RC_MOVED_TEMPORARILY"); 120 | 121 | my %compat = ( 122 | UNPROCESSABLE_ENTITY => \&HTTP_UNPROCESSABLE_CONTENT, 123 | PAYLOAD_TOO_LARGE => \&HTTP_CONTENT_TOO_LARGE, 124 | REQUEST_ENTITY_TOO_LARGE => \&HTTP_CONTENT_TOO_LARGE, 125 | REQUEST_URI_TOO_LARGE => \&HTTP_URI_TOO_LONG, 126 | REQUEST_RANGE_NOT_SATISFIABLE => \&HTTP_RANGE_NOT_SATISFIABLE, 127 | NO_CODE => \&HTTP_TOO_EARLY, 128 | UNORDERED_COLLECTION => \&HTTP_TOO_EARLY, 129 | ); 130 | 131 | foreach my $name (keys %compat) { 132 | push(@EXPORT, "RC_$name"); 133 | push(@EXPORT_OK, "HTTP_$name"); 134 | no strict 'refs'; 135 | *{"RC_$name"} = $compat{$name}; 136 | *{"HTTP_$name"} = $compat{$name}; 137 | } 138 | 139 | our %EXPORT_TAGS = ( 140 | constants => [grep /^HTTP_/, @EXPORT_OK], 141 | is => [grep /^is_/, @EXPORT, @EXPORT_OK], 142 | ); 143 | 144 | 145 | sub status_message ($) { $StatusCode{$_[0]}; } 146 | sub status_constant_name ($) { 147 | exists($StatusCodeName{$_[0]}) ? $StatusCodeName{$_[0]} : undef; 148 | } 149 | 150 | sub is_info ($) { $_[0] && $_[0] >= 100 && $_[0] < 200; } 151 | sub is_success ($) { $_[0] && $_[0] >= 200 && $_[0] < 300; } 152 | sub is_redirect ($) { $_[0] && $_[0] >= 300 && $_[0] < 400; } 153 | sub is_error ($) { $_[0] && $_[0] >= 400 && $_[0] < 600; } 154 | sub is_client_error ($) { $_[0] && $_[0] >= 400 && $_[0] < 500; } 155 | sub is_server_error ($) { $_[0] && $_[0] >= 500 && $_[0] < 600; } 156 | sub is_cacheable_by_default ($) { $_[0] && ( $_[0] == 200 # OK 157 | || $_[0] == 203 # Non-Authoritative Information 158 | || $_[0] == 204 # No Content 159 | || $_[0] == 206 # Not Acceptable 160 | || $_[0] == 300 # Multiple Choices 161 | || $_[0] == 301 # Moved Permanently 162 | || $_[0] == 308 # Permanent Redirect 163 | || $_[0] == 404 # Not Found 164 | || $_[0] == 405 # Method Not Allowed 165 | || $_[0] == 410 # Gone 166 | || $_[0] == 414 # Request-URI Too Large 167 | || $_[0] == 451 # Unavailable For Legal Reasons 168 | || $_[0] == 501 # Not Implemented 169 | ); 170 | } 171 | 172 | sub status_codes { %StatusCode; } 173 | 174 | 1; 175 | 176 | 177 | __END__ 178 | 179 | =pod 180 | 181 | =head1 SYNOPSIS 182 | 183 | use HTTP::Status qw(:constants :is status_message); 184 | 185 | if ($rc != HTTP_OK) { 186 | print status_message($rc), "\n"; 187 | } 188 | 189 | if (is_success($rc)) { ... } 190 | if (is_error($rc)) { ... } 191 | if (is_redirect($rc)) { ... } 192 | 193 | =head1 DESCRIPTION 194 | 195 | I is a library of routines for defining and 196 | classifying HTTP status codes for libwww-perl. Status codes are 197 | used to encode the overall outcome of an HTTP response message. Codes 198 | correspond to those defined in RFC 2616 and RFC 2518. 199 | 200 | =head1 CONSTANTS 201 | 202 | The following constant functions can be used as mnemonic status code 203 | names. None of these are exported by default. Use the C<:constants> 204 | tag to import them all. 205 | 206 | HTTP_CONTINUE (100) 207 | HTTP_SWITCHING_PROTOCOLS (101) 208 | HTTP_PROCESSING (102) 209 | HTTP_EARLY_HINTS (103) 210 | 211 | HTTP_OK (200) 212 | HTTP_CREATED (201) 213 | HTTP_ACCEPTED (202) 214 | HTTP_NON_AUTHORITATIVE_INFORMATION (203) 215 | HTTP_NO_CONTENT (204) 216 | HTTP_RESET_CONTENT (205) 217 | HTTP_PARTIAL_CONTENT (206) 218 | HTTP_MULTI_STATUS (207) 219 | HTTP_ALREADY_REPORTED (208) 220 | 221 | HTTP_IM_USED (226) 222 | 223 | HTTP_MULTIPLE_CHOICES (300) 224 | HTTP_MOVED_PERMANENTLY (301) 225 | HTTP_FOUND (302) 226 | HTTP_SEE_OTHER (303) 227 | HTTP_NOT_MODIFIED (304) 228 | HTTP_USE_PROXY (305) 229 | HTTP_TEMPORARY_REDIRECT (307) 230 | HTTP_PERMANENT_REDIRECT (308) 231 | 232 | HTTP_BAD_REQUEST (400) 233 | HTTP_UNAUTHORIZED (401) 234 | HTTP_PAYMENT_REQUIRED (402) 235 | HTTP_FORBIDDEN (403) 236 | HTTP_NOT_FOUND (404) 237 | HTTP_METHOD_NOT_ALLOWED (405) 238 | HTTP_NOT_ACCEPTABLE (406) 239 | HTTP_PROXY_AUTHENTICATION_REQUIRED (407) 240 | HTTP_REQUEST_TIMEOUT (408) 241 | HTTP_CONFLICT (409) 242 | HTTP_GONE (410) 243 | HTTP_LENGTH_REQUIRED (411) 244 | HTTP_PRECONDITION_FAILED (412) 245 | HTTP_CONTENT_TOO_LARGE (413) 246 | HTTP_URI_TOO_LONG (414) 247 | HTTP_UNSUPPORTED_MEDIA_TYPE (415) 248 | HTTP_RANGE_NOT_SATISFIABLE (416) 249 | HTTP_EXPECTATION_FAILED (417) 250 | HTTP_MISDIRECTED REQUEST (421) 251 | HTTP_UNPROCESSABLE_CONTENT (422) 252 | HTTP_LOCKED (423) 253 | HTTP_FAILED_DEPENDENCY (424) 254 | HTTP_TOO_EARLY (425) 255 | HTTP_UPGRADE_REQUIRED (426) 256 | HTTP_PRECONDITION_REQUIRED (428) 257 | HTTP_TOO_MANY_REQUESTS (429) 258 | HTTP_REQUEST_HEADER_FIELDS_TOO_LARGE (431) 259 | HTTP_UNAVAILABLE_FOR_LEGAL_REASONS (451) 260 | 261 | HTTP_INTERNAL_SERVER_ERROR (500) 262 | HTTP_NOT_IMPLEMENTED (501) 263 | HTTP_BAD_GATEWAY (502) 264 | HTTP_SERVICE_UNAVAILABLE (503) 265 | HTTP_GATEWAY_TIMEOUT (504) 266 | HTTP_HTTP_VERSION_NOT_SUPPORTED (505) 267 | HTTP_VARIANT_ALSO_NEGOTIATES (506) 268 | HTTP_INSUFFICIENT_STORAGE (507) 269 | HTTP_LOOP_DETECTED (508) 270 | HTTP_NOT_EXTENDED (510) 271 | HTTP_NETWORK_AUTHENTICATION_REQUIRED (511) 272 | 273 | =head1 FUNCTIONS 274 | 275 | The following additional functions are provided. Most of them are 276 | exported by default. The C<:is> import tag can be used to import all 277 | the classification functions. 278 | 279 | =over 4 280 | 281 | =item status_message( $code ) 282 | 283 | The status_message() function will translate status codes to human 284 | readable strings. The string is the same as found in the constant 285 | names above. 286 | For example, C will return C<"Not Found">. 287 | 288 | If the $code is not registered in the L 290 | then C is returned. 291 | 292 | =item status_constant_name( $code ) 293 | 294 | The status_constant_name() function will translate a status code 295 | to a string which has the name of the constant for that status code. 296 | For example, C will return C<"HTTP_NOT_FOUND">. 297 | 298 | If the C<$code> is not registered in the L 300 | then C is returned. 301 | 302 | =item is_info( $code ) 303 | 304 | Return TRUE if C<$code> is an I status code (1xx). This 305 | class of status code indicates a provisional response which can't have 306 | any content. 307 | 308 | =item is_success( $code ) 309 | 310 | Return TRUE if C<$code> is a I status code (2xx). 311 | 312 | =item is_redirect( $code ) 313 | 314 | Return TRUE if C<$code> is a I status code (3xx). This class of 315 | status code indicates that further action needs to be taken by the 316 | user agent in order to fulfill the request. 317 | 318 | =item is_error( $code ) 319 | 320 | Return TRUE if C<$code> is an I status code (4xx or 5xx). The function 321 | returns TRUE for both client and server error status codes. 322 | 323 | =item is_client_error( $code ) 324 | 325 | Return TRUE if C<$code> is a I status code (4xx). This class 326 | of status code is intended for cases in which the client seems to have 327 | erred. 328 | 329 | This function is B exported by default. 330 | 331 | =item is_server_error( $code ) 332 | 333 | Return TRUE if C<$code> is a I status code (5xx). This class 334 | of status codes is intended for cases in which the server is aware 335 | that it has erred or is incapable of performing the request. 336 | 337 | This function is B exported by default. 338 | 339 | =item is_cacheable_by_default( $code ) 340 | 341 | Return TRUE if C<$code> indicates that a response is cacheable by default, and 342 | it can be reused by a cache with heuristic expiration. All other status codes 343 | are not cacheable by default. See L. 345 | 346 | This function is B exported by default. 347 | 348 | =item status_codes 349 | 350 | Returns a hash mapping numerical HTTP status code (e.g. 200) to text status messages (e.g. "OK") 351 | 352 | This function is B exported by default. 353 | 354 | =back 355 | 356 | =head1 SEE ALSO 357 | 358 | L 359 | 360 | =head1 BUGS 361 | 362 | For legacy reasons all the C constants are exported by default 363 | with the prefix C. It's recommended to use explicit imports and 364 | the C<:constants> tag instead of relying on this. 365 | 366 | =cut 367 | 368 | #ABSTRACT: HTTP Status code processing 369 | -------------------------------------------------------------------------------- /perlcriticrc: -------------------------------------------------------------------------------- 1 | severity = 3 2 | verbose = 11 3 | 4 | theme = core + pbp + bugs + maintenance + cosmetic + complexity + security + tests + moose 5 | 6 | exclude = Subroutines::ProhibitCallsToUndeclaredSubs 7 | 8 | [BuiltinFunctions::ProhibitStringySplit] 9 | severity = 3 10 | 11 | [CodeLayout::RequireTrailingCommas] 12 | severity = 3 13 | 14 | [ControlStructures::ProhibitCStyleForLoops] 15 | severity = 3 16 | 17 | [InputOutput::RequireCheckedSyscalls] 18 | functions = :builtins 19 | exclude_functions = sleep 20 | severity = 3 21 | 22 | [Moose::RequireCleanNamespace] 23 | modules = Moose Moose::Role MooseX::Role::Parameterized Moose::Util::TypeConstraints 24 | cleaners = namespace::autoclean 25 | 26 | [NamingConventions::Capitalization] 27 | package_exemptions = [A-Z]\w+|minFraud 28 | file_lexical_variables = [A-Z]\w+|[^A-Z]+ 29 | global_variables = :starts_with_upper 30 | scoped_lexical_variables = [A-Z]\w+|[^A-Z]+ 31 | severity = 3 32 | 33 | # Given our code base, leaving this at 5 would be a huge pain 34 | [Subroutines::ProhibitManyArgs] 35 | max_arguments = 10 36 | 37 | [RegularExpressions::ProhibitComplexRegexes] 38 | max_characters = 200 39 | 40 | [RegularExpressions::ProhibitUnusualDelimiters] 41 | severity = 3 42 | 43 | [Subroutines::ProhibitUnusedPrivateSubroutines] 44 | private_name_regex = _(?!build)\w+ 45 | skip_when_using = Moo::Role Moose::Role MooseX::Role::Parameterized Role::Tiny Test::Class::Moose::Role 46 | 47 | [TestingAndDebugging::ProhibitNoWarnings] 48 | allow = redefine 49 | 50 | [ValuesAndExpressions::ProhibitEmptyQuotes] 51 | severity = 3 52 | 53 | [ValuesAndExpressions::ProhibitInterpolationOfLiterals] 54 | severity = 3 55 | 56 | [ValuesAndExpressions::RequireUpperCaseHeredocTerminator] 57 | severity = 3 58 | 59 | [Variables::ProhibitPackageVars] 60 | add_packages = Test::Builder 61 | 62 | [TestingAndDebugging::RequireUseStrict] 63 | 64 | [TestingAndDebugging::RequireUseWarnings] 65 | 66 | [-ControlStructures::ProhibitCascadingIfElse] 67 | 68 | [-ErrorHandling::RequireCarping] 69 | [-InputOutput::RequireBriefOpen] 70 | 71 | [-ValuesAndExpressions::ProhibitConstantPragma] 72 | 73 | # No need for /xsm everywhere 74 | [-RegularExpressions::RequireDotMatchAnything] 75 | [-RegularExpressions::RequireExtendedFormatting] 76 | [-RegularExpressions::RequireLineBoundaryMatching] 77 | 78 | [-Subroutines::ProhibitExplicitReturnUndef] 79 | 80 | # http://stackoverflow.com/questions/2275317/why-does-perlcritic-dislike-using-shift-to-populate-subroutine-variables 81 | [-Subroutines::RequireArgUnpacking] 82 | 83 | [-Subroutines::RequireFinalReturn] 84 | 85 | # "use v5.14" is more readable than "use 5.014" 86 | [-ValuesAndExpressions::ProhibitVersionStrings] 87 | -------------------------------------------------------------------------------- /perltidyrc: -------------------------------------------------------------------------------- 1 | --blank-lines-before-packages=0 2 | --iterations=2 3 | --no-outdent-long-comments 4 | -b 5 | -bar 6 | -boc 7 | -ci=4 8 | -i=4 9 | -l=78 10 | -nolq 11 | -se 12 | -wbb="% + - * / x != == >= <= =~ !~ < > | & >= < = **= += *= &= <<= &&= -= /= |= >>= ||= .= %= ^= x=" 13 | -------------------------------------------------------------------------------- /t/common-req.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | 6 | use File::Spec; 7 | use File::Temp qw(tempfile); 8 | use HTTP::Request::Common; 9 | 10 | my $r = GET 'http://www.sn.no/'; 11 | note $r->as_string; 12 | 13 | is($r->method, "GET"); 14 | is($r->uri, "http://www.sn.no/"); 15 | 16 | $r = HEAD "http://www.sn.no/", 17 | If_Match => 'abc', 18 | From => 'aas@sn.no'; 19 | note $r->as_string; 20 | 21 | is($r->method, "HEAD"); 22 | ok($r->uri->eq("http://www.sn.no")); 23 | 24 | is($r->header('If-Match'), "abc"); 25 | is($r->header("from"), "aas\@sn.no"); 26 | 27 | $r = HEAD "http://www.sn.no/", 28 | Content => 'foo'; 29 | is($r->content, 'foo'); 30 | 31 | $r = HEAD "http://www.sn.no/", 32 | Content => 'foo', 33 | 'Content-Length' => 50; 34 | is($r->content, 'foo'); 35 | is($r->content_length, 50); 36 | 37 | $r = PUT "http://www.sn.no", 38 | Content => 'foo'; 39 | note $r->as_string, "\n"; 40 | 41 | is($r->method, "PUT"); 42 | is($r->uri->host, "www.sn.no"); 43 | 44 | ok(!defined($r->header("Content"))); 45 | 46 | is(${$r->content_ref}, "foo"); 47 | is($r->content, "foo"); 48 | is($r->content_length, 3); 49 | 50 | $r = PUT "http://www.sn.no", 51 | { foo => "bar" }; 52 | is($r->content, "foo=bar"); 53 | 54 | $r = OPTIONS "http://www.sn.no", 55 | Content => 'foo'; 56 | note $r->as_string, "\n"; 57 | 58 | is($r->method, "OPTIONS"); 59 | is($r->uri->host, "www.sn.no"); 60 | 61 | ok(!defined($r->header("Content"))); 62 | 63 | is(${$r->content_ref}, "foo"); 64 | is($r->content, "foo"); 65 | is($r->content_length, 3); 66 | 67 | $r = OPTIONS "http://www.sn.no", 68 | { foo => "bar" }; 69 | is($r->content, "foo=bar"); 70 | 71 | $r = PATCH "http://www.sn.no", 72 | { foo => "bar" }; 73 | is($r->content, "foo=bar"); 74 | 75 | #--- Test POST requests --- 76 | 77 | $r = POST "http://www.sn.no", [foo => 'bar;baz', 78 | baz => [qw(a b c)], 79 | foo => 'zoo=&', 80 | "space " => " + ", 81 | "nl" => "a\nb\r\nc\n", 82 | ], 83 | bar => 'foo'; 84 | note $r->as_string, "\n"; 85 | 86 | is($r->method, "POST"); 87 | is($r->content_type, "application/x-www-form-urlencoded"); 88 | is($r->content_length, 77, 'content_length'); 89 | is($r->header("bar"), "foo", 'bar is foo'); 90 | is($r->content, 'foo=bar%3Bbaz&baz=a&baz=b&baz=c&foo=zoo%3D%26&space+=+%2B+&nl=a%0Ab%0D%0Ac%0A'); 91 | 92 | $r = POST "http://example.com"; 93 | is($r->content_length, 0); 94 | is($r->content, ""); 95 | 96 | $r = POST "http://example.com", []; 97 | is($r->content_length, 0); 98 | is($r->content, ""); 99 | 100 | $r = POST "mailto:gisle\@aas.no", 101 | Subject => "Heisan", 102 | Content_Type => "text/plain", 103 | Content => "Howdy\n"; 104 | #note $r->as_string; 105 | 106 | is($r->method, "POST"); 107 | is($r->header("Subject"), "Heisan"); 108 | is($r->content, "Howdy\n"); 109 | is($r->content_type, "text/plain"); 110 | 111 | { 112 | my @warnings; 113 | local $SIG{__WARN__} = sub { push @warnings, @_ }; 114 | $r = POST 'http://unf.ug/', []; 115 | is( "@warnings", '', 'empty POST' ); 116 | } 117 | 118 | # 119 | # POST for File upload 120 | # 121 | my (undef, $file) = tempfile(); 122 | my $form_file = (File::Spec->splitpath($file))[-1]; 123 | open(FILE, ">$file") or die "Can't create $file: $!"; 124 | print FILE "foo\nbar\nbaz\n"; 125 | close(FILE); 126 | 127 | $r = POST 'http://www.perl.org/survey.cgi', 128 | Content_Type => 'form-data', 129 | Content => [ name => 'Gisle Aas', 130 | email => 'gisle@aas.no', 131 | gender => 'm', 132 | born => '1964', 133 | file => [$file], 134 | ]; 135 | #note $r->as_string; 136 | 137 | unlink($file) or warn "Can't unlink $file: $!"; 138 | 139 | is($r->method, "POST"); 140 | is($r->uri->path, "/survey.cgi"); 141 | is($r->content_type, "multipart/form-data"); 142 | ok($r->header('Content_type') =~ /boundary="?([^"]+)"?/); 143 | my $boundary = $1; 144 | 145 | my $c = $r->content; 146 | $c =~ s/\r//g; 147 | my @c = split(/--\Q$boundary/, $c); 148 | note "$c[5]\n"; 149 | 150 | is(@c, 7); 151 | like($c[6], qr/^--\n/); # 5 parts + header & trailer 152 | 153 | ok($c[2] =~ /^Content-Disposition:\s*form-data;\s*name="email"/m); 154 | ok($c[2] =~ /^gisle\@aas.no$/m); 155 | 156 | ok($c[5] =~ /^Content-Disposition:\s*form-data;\s*name="file";\s*filename="$form_file"/m); 157 | ok($c[5] =~ /^Content-Type:\s*text\/plain$/m); 158 | ok($c[5] =~ /^foo\nbar\nbaz/m); 159 | 160 | $r = POST 'http://www.perl.org/survey.cgi', 161 | [ file => [ undef, "xxy\"", Content_type => "text/html", Content => "

Hello, world!

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

Hello, world/m); 168 | 169 | $r = POST 'http://www.perl.org/survey.cgi', 170 | Content_type => 'multipart/form-data', 171 | Content => [ file => [ undef, undef, Content => "foo"]]; 172 | #note $r->as_string; 173 | 174 | unlike($r->content, qr/filename=/); 175 | 176 | 177 | # The POST routine can now also take a hash reference. 178 | my %hash = (foo => 42, bar => 24); 179 | $r = POST 'http://www.perl.org/survey.cgi', \%hash; 180 | #note $r->as_string, "\n"; 181 | like($r->content, qr/foo=42/); 182 | like($r->content, qr/bar=24/); 183 | is($r->content_type, "application/x-www-form-urlencoded"); 184 | is($r->content_length, 13); 185 | 186 | 187 | # 188 | # POST for File upload 189 | # 190 | use HTTP::Request::Common qw($DYNAMIC_FILE_UPLOAD); 191 | 192 | (undef, $file) = tempfile(); 193 | open(FILE, ">$file") or die "Can't create $file: $!"; 194 | for (1..1000) { 195 | print FILE "a" .. "z"; 196 | } 197 | close(FILE); 198 | 199 | $DYNAMIC_FILE_UPLOAD++; 200 | $r = POST 'http://www.perl.org/survey.cgi', 201 | Content_Type => 'form-data', 202 | Content => [ name => 'Gisle Aas', 203 | email => 'gisle@aas.no', 204 | gender => 'm', 205 | born => '1964', 206 | file => [$file], 207 | ]; 208 | #note $r->as_string, "\n"; 209 | 210 | is($r->method, "POST"); 211 | is($r->uri->path, "/survey.cgi"); 212 | is($r->content_type, "multipart/form-data"); 213 | ok($r->header('Content_type') =~ qr/boundary="?([^"]+)"?/); 214 | $boundary = $1; 215 | is(ref($r->content), "CODE"); 216 | 217 | cmp_ok(length($boundary), '>', 10); 218 | 219 | my $code = $r->content; 220 | my $chunk; 221 | my @chunks; 222 | while (defined($chunk = &$code) && length $chunk) { 223 | push(@chunks, $chunk); 224 | } 225 | 226 | unlink($file) or warn "Can't unlink $file: $!"; 227 | 228 | $_ = join("", @chunks); 229 | 230 | #note int(@chunks), " chunks, total size is ", length($_), " bytes\n"; 231 | 232 | # should be close to expected size and number of chunks 233 | cmp_ok(abs(@chunks - 6), '<', 3); 234 | cmp_ok(abs(length($_) - 26589), '<', 20); 235 | 236 | $r = POST 'http://www.example.com'; 237 | is($r->as_string, < 'form-data', Content => []; 245 | is($r->as_string, < 'form-data'; 253 | #note $r->as_string; 254 | is($r->as_string, <method, "DELETE"); 263 | 264 | $r = HTTP::Request::Common::PUT 'http://www.example.com', 265 | 'Content-Type' => 'application/octet-steam', 266 | 'Content' => 'foobarbaz', 267 | 'Content-Length' => 12; # a slight lie 268 | is($r->header('Content-Length'), 9); 269 | 270 | $r = HTTP::Request::Common::PATCH 'http://www.example.com', 271 | 'Content-Type' => 'application/octet-steam', 272 | 'Content' => 'foobarbaz', 273 | 'Content-Length' => 12; # a slight lie 274 | is($r->header('Content-Length'), 9); 275 | 276 | done_testing(); 277 | -------------------------------------------------------------------------------- /t/headers-auth.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | 6 | plan tests => 9; 7 | 8 | use HTTP::Response; 9 | use HTTP::Headers::Auth; 10 | 11 | my $res = HTTP::Response->new(401); 12 | $res->push_header(WWW_Authenticate => qq(Foo realm="WallyWorld", foo=bar, Bar realm="WallyWorld2")); 13 | $res->push_header(WWW_Authenticate => qq(Basic Realm="WallyWorld", foo=bar, bar=baz)); 14 | 15 | note $res->as_string; 16 | 17 | my %auth = $res->www_authenticate; 18 | 19 | is(keys(%auth), 3); 20 | 21 | is($auth{basic}{realm}, "WallyWorld"); 22 | is($auth{bar}{realm}, "WallyWorld2"); 23 | 24 | $a = $res->www_authenticate; 25 | is($a, 'Foo realm="WallyWorld", foo=bar, Bar realm="WallyWorld2", Basic Realm="WallyWorld", foo=bar, bar=baz'); 26 | 27 | $res->www_authenticate("Basic realm=foo1"); 28 | note $res->as_string; 29 | 30 | $res->www_authenticate(Basic => {realm => "foo2"}); 31 | note $res->as_string; 32 | 33 | $res->www_authenticate(Basic => [realm => "foo3", foo=>33], 34 | Digest => {nonce=>"bar", foo=>'foo'}); 35 | note $res->as_string; 36 | 37 | my $string = $res->as_string; 38 | 39 | like($string, qr/WWW-Authenticate: Basic realm="foo3", foo=33/); 40 | like($string, qr/WWW-Authenticate: Digest (nonce=bar, foo=foo|foo=foo, nonce=bar)/); 41 | 42 | $res = HTTP::Response->new(401); 43 | my @auth = $res->proxy_authenticate('foo'); 44 | is_deeply(\@auth, []); 45 | @auth = $res->proxy_authenticate('foo', 'bar'); 46 | is_deeply(\@auth, ['foo', {}]); 47 | @auth = $res->proxy_authenticate('foo', {'bar' => '_'}); 48 | is_deeply(\@auth, ['foo', {}, 'bar', {}]); 49 | -------------------------------------------------------------------------------- /t/headers-etag.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | 6 | plan tests => 11; 7 | 8 | require HTTP::Headers::ETag; 9 | 10 | my $h = HTTP::Headers->new; 11 | 12 | $h->etag("tag1"); 13 | is($h->etag, qq("tag1")); 14 | 15 | $h->etag("w/tag2"); 16 | is($h->etag, qq(W/"tag2")); 17 | 18 | $h->etag(" w/, weaktag"); 19 | is($h->etag, qq(W/"", "weaktag")); 20 | my @list = $h->etag; 21 | is_deeply(\@list, ['W/""', '"weaktag"']); 22 | 23 | $h->etag(" w/"); 24 | is($h->etag, qq(W/"")); 25 | 26 | $h->etag(" "); 27 | is($h->etag, ""); 28 | 29 | $h->if_match(qq(W/"foo", bar, baz), "bar"); 30 | $h->if_none_match(333); 31 | 32 | $h->if_range("tag3"); 33 | is($h->if_range, qq("tag3")); 34 | 35 | my $t = time; 36 | $h->if_range($t); 37 | is($h->if_range, $t); 38 | 39 | note $h->as_string; 40 | 41 | @list = $h->if_range; 42 | is($#list, 0); 43 | is($list[0], $t); 44 | $h->if_range(undef); 45 | is($h->if_range, ''); 46 | -------------------------------------------------------------------------------- /t/headers-util.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | 6 | use HTTP::Headers::Util qw(split_header_words join_header_words); 7 | 8 | my @s_tests = ( 9 | 10 | ["foo" => "foo"], 11 | ["foo=bar" => "foo=bar"], 12 | [" foo " => "foo"], 13 | ["foo=" => 'foo=""'], 14 | ["foo=bar bar=baz" => "foo=bar; bar=baz"], 15 | ["foo=bar;bar=baz" => "foo=bar; bar=baz"], 16 | ['foo bar baz' => "foo; bar; baz"], 17 | ['foo="\"" bar="\\\\"' => 'foo="\""; bar="\\\\"'], 18 | ['foo,,,bar' => 'foo, bar'], 19 | ['foo=bar,bar=baz' => 'foo=bar, bar=baz'], 20 | 21 | ['TEXT/HTML; CHARSET=ISO-8859-1' => 22 | 'text/html; charset=ISO-8859-1'], 23 | 24 | ['foo="bar"; port="80,81"; discard, bar=baz' => 25 | 'foo=bar; port="80,81"; discard, bar=baz'], 26 | 27 | ['Basic realm="\"foo\\\\bar\""' => 28 | 'basic; realm="\"foo\\\\bar\""'], 29 | ); 30 | 31 | plan tests => @s_tests + 4; 32 | 33 | for (@s_tests) { 34 | my($arg, $expect) = @$_; 35 | my @arg = ref($arg) ? @$arg : $arg; 36 | 37 | my $res = join_header_words(split_header_words(@arg)); 38 | is($res, $expect); 39 | } 40 | 41 | 42 | note "# Extra tests\n"; 43 | # some extra tests 44 | is(join_header_words("foo" => undef, "bar" => "baz"), "foo; bar=baz"); 45 | is(join_header_words(), ""); 46 | is(join_header_words([]), ""); 47 | # ignore bare = 48 | is_deeply(split_header_words("foo; =;bar=baz"), ["foo" => undef, "bar" => "baz"]); 49 | -------------------------------------------------------------------------------- /t/headers.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use lib 't/lib'; 5 | 6 | use Secret (); 7 | use Test::More; 8 | 9 | plan tests => 189; 10 | 11 | my($h, $h2); 12 | sub j { join("|", @_) } 13 | 14 | 15 | require HTTP::Headers; 16 | $h = HTTP::Headers->new; 17 | ok($h); 18 | is(ref($h), "HTTP::Headers"); 19 | is($h->as_string, ""); 20 | 21 | $h = HTTP::Headers->new(foo => "bar", foo => "baaaaz", Foo => "baz"); 22 | is($h->as_string, "Foo: bar\nFoo: baaaaz\nFoo: baz\n"); 23 | 24 | $h = HTTP::Headers->new(foo => ["bar", "baz"]); 25 | is($h->as_string, "Foo: bar\nFoo: baz\n"); 26 | 27 | $h = HTTP::Headers->new(foo => 1, bar => 2, foo_bar => 3); 28 | is($h->as_string, "Bar: 2\nFoo: 1\nFoo-Bar: 3\n"); 29 | is($h->as_string(";"), "Bar: 2;Foo: 1;Foo-Bar: 3;"); 30 | 31 | is($h->header("Foo"), 1); 32 | is($h->header("FOO"), 1); 33 | is(j($h->header("foo")), 1); 34 | is($h->header("foo-bar"), 3); 35 | is($h->header("foo_bar"), 3); 36 | is($h->header("Not-There"), undef); 37 | is(j($h->header("Not-There")), ""); 38 | is(eval { $h->header }, undef); 39 | ok($@); 40 | 41 | is($h->header("Foo", 11), 1); 42 | is($h->header("Foo", [1, 1]), 11); 43 | is($h->header("Foo"), "1, 1"); 44 | is(j($h->header("Foo")), "1|1"); 45 | is($h->header(foo => 11, Foo => 12, bar => 22), 2); 46 | is($h->header("Foo"), "11, 12"); 47 | is($h->header("Bar"), 22); 48 | is($h->header("Bar", undef), 22); 49 | is(j($h->header("bar", 22)), ""); 50 | 51 | $h->push_header(Bar => 22); 52 | is($h->header("Bar"), "22, 22"); 53 | $h->push_header(Bar => [23 .. 25]); 54 | is($h->header("Bar"), "22, 22, 23, 24, 25"); 55 | is(j($h->header("Bar")), "22|22|23|24|25"); 56 | 57 | $h->clear; 58 | $h->header(Foo => 1); 59 | is($h->as_string, "Foo: 1\n"); 60 | $h->init_header(Foo => 2); 61 | $h->init_header(Bar => 2); 62 | is($h->as_string, "Bar: 2\nFoo: 1\n"); 63 | $h->init_header(Foo => [2, 3]); 64 | $h->init_header(Baz => [2, 3]); 65 | is($h->as_string, "Bar: 2\nBaz: 2\nBaz: 3\nFoo: 1\n"); 66 | 67 | eval { $h->init_header(A => 1, B => 2, C => 3) }; 68 | ok($@); 69 | is($h->as_string, "Bar: 2\nBaz: 2\nBaz: 3\nFoo: 1\n"); 70 | 71 | is($h->clone->remove_header("Foo"), 1); 72 | is($h->clone->remove_header("Bar"), 1); 73 | is($h->clone->remove_header("Baz"), 2); 74 | is($h->clone->remove_header(qw(Foo Bar Baz Not-There)), 4); 75 | is($h->clone->remove_header("Not-There"), 0); 76 | is(j($h->clone->remove_header("Foo")), 1); 77 | is(j($h->clone->remove_header("Bar")), 2); 78 | is(j($h->clone->remove_header("Baz")), "2|3"); 79 | is(j($h->clone->remove_header(qw(Foo Bar Baz Not-There))), "1|2|2|3"); 80 | is(j($h->clone->remove_header("Not-There")), ""); 81 | 82 | $h = HTTP::Headers->new( 83 | allow => "GET", 84 | content => "none", 85 | content_type => "text/html", 86 | content_md5 => "dummy", 87 | content_encoding => "gzip", 88 | content_foo => "bar", 89 | last_modified => "yesterday", 90 | expires => "tomorrow", 91 | etag => "abc", 92 | date => "today", 93 | user_agent => "libwww-perl", 94 | zoo => "foo", 95 | ); 96 | is($h->as_string, <clone; 112 | is($h->as_string, $h2->as_string); 113 | 114 | is($h->remove_content_headers->as_string, <as_string, <remove_content_headers; 134 | is($h->as_string, $h2->as_string); 135 | 136 | $h->clear; 137 | is($h->as_string, ""); 138 | undef($h2); 139 | 140 | $h = HTTP::Headers->new; 141 | is($h->header_field_names, 0); 142 | is(j($h->header_field_names), ""); 143 | 144 | $h = HTTP::Headers->new( etag => 1, foo => [2,3], 145 | content_type => "text/plain"); 146 | is($h->header_field_names, 3); 147 | is(j($h->header_field_names), "ETag|Content-Type|Foo"); 148 | 149 | { 150 | my @tmp; 151 | $h->scan(sub { push(@tmp, @_) }); 152 | is(j(@tmp), "ETag|1|Content-Type|text/plain|Foo|2|Foo|3"); 153 | 154 | @tmp = (); 155 | eval { $h->scan(sub { push(@tmp, @_); die if $_[0] eq "Content-Type" }) }; 156 | ok($@); 157 | is(j(@tmp), "ETag|1|Content-Type|text/plain"); 158 | 159 | @tmp = (); 160 | $h->scan(sub { push(@tmp, @_) }); 161 | is(j(@tmp), "ETag|1|Content-Type|text/plain|Foo|2|Foo|3"); 162 | } 163 | 164 | # CONVENIENCE METHODS 165 | 166 | $h = HTTP::Headers->new; 167 | is($h->date, undef); 168 | is($h->date(time), undef); 169 | is(j($h->header_field_names), "Date"); 170 | like($h->header("Date"), qr/^[A-Z][a-z][a-z], \d\d .* GMT$/); 171 | { 172 | my $off = time - $h->date; 173 | ok($off == 0 || $off == 1); 174 | } 175 | 176 | if ($] < 5.006) { 177 | Test::skip("Can't call variable method", 1) for 1..13; 178 | } 179 | else { 180 | # other date fields 181 | for my $field (qw(expires if_modified_since if_unmodified_since 182 | last_modified)) 183 | { 184 | eval <<'EOT'; die $@ if $@; 185 | is($h->$field, undef); 186 | is($h->$field(time), undef); 187 | like((time - $h->$field), qr/^[01]$/); 188 | EOT 189 | } 190 | is(j($h->header_field_names), "Date|If-Modified-Since|If-Unmodified-Since|Expires|Last-Modified"); 191 | } 192 | 193 | $h->clear; 194 | is($h->content_type, ""); 195 | is($h->content_type(""), ""); 196 | is($h->content_type("text/html"), ""); 197 | is($h->content_type, "text/html"); 198 | is($h->content_type(" TEXT / HTML ") , "text/html"); 199 | is($h->content_type, "text/html"); 200 | is(j($h->content_type), "text/html"); 201 | is($h->content_type("text/html;\n charSet = \"ISO-8859-1\"; Foo=1 "), "text/html"); 202 | is($h->content_type, "text/html"); 203 | is(j($h->content_type), "text/html|charSet = \"ISO-8859-1\"; Foo=1 "); 204 | is($h->header("content_type"), "text/html;\n charSet = \"ISO-8859-1\"; Foo=1 "); 205 | ok($h->content_is_html); 206 | ok(!$h->content_is_xhtml); 207 | ok(!$h->content_is_xml); 208 | $h->content_type("application/vnd.wap.xhtml+xml"); 209 | ok($h->content_is_html); 210 | ok($h->content_is_xhtml); 211 | ok($h->content_is_xml); 212 | $h->content_type("text/xml"); 213 | ok(!$h->content_is_html); 214 | ok(!$h->content_is_xhtml); 215 | ok($h->content_is_xml); 216 | $h->content_type("application/xhtml+xml"); 217 | ok($h->content_is_html); 218 | ok($h->content_is_xhtml); 219 | ok($h->content_is_xml); 220 | is($h->content_type("text/html;\n charSet = \"ISO-8859-1\"; Foo=1 "), "application/xhtml+xml"); 221 | 222 | is($h->content_encoding, undef); 223 | is($h->content_encoding("gzip"), undef); 224 | is($h->content_encoding, "gzip"); 225 | is(j($h->header_field_names), "Content-Encoding|Content-Type"); 226 | 227 | is($h->content_language, undef); 228 | is($h->content_language("no"), undef); 229 | is($h->content_language, "no"); 230 | 231 | is($h->title, undef); 232 | is($h->title("This is a test"), undef); 233 | is($h->title, "This is a test"); 234 | 235 | is($h->user_agent, undef); 236 | is($h->user_agent("Mozilla/1.2"), undef); 237 | is($h->user_agent, "Mozilla/1.2"); 238 | 239 | is($h->server, undef); 240 | is($h->server("Apache/2.1"), undef); 241 | is($h->server, "Apache/2.1"); 242 | 243 | is($h->from("Gisle\@ActiveState.com"), undef); 244 | ok($h->header("from", "Gisle\@ActiveState.com")); 245 | 246 | is($h->referer("http://www.example.com"), undef); 247 | is($h->referer, "http://www.example.com"); 248 | is($h->referrer, "http://www.example.com"); 249 | is($h->referer("http://www.example.com/#bar"), "http://www.example.com"); 250 | is($h->referer, "http://www.example.com/"); 251 | { 252 | require URI; 253 | my $u = URI->new("http://www.example.com#bar"); 254 | $h->referer($u); 255 | is($u->as_string, "http://www.example.com#bar"); 256 | is($h->referer->fragment, undef); 257 | is($h->referrer->as_string, "http://www.example.com"); 258 | } 259 | 260 | is($h->as_string, <clear; 273 | is($h->www_authenticate("foo"), undef); 274 | is($h->www_authenticate("bar"), "foo"); 275 | is($h->www_authenticate, "bar"); 276 | is($h->proxy_authenticate("foo"), undef); 277 | is($h->proxy_authenticate("bar"), "foo"); 278 | is($h->proxy_authenticate, "bar"); 279 | 280 | is($h->authorization_basic, undef); 281 | is($h->authorization_basic("u"), undef); 282 | is($h->authorization_basic("u", "p"), "u:"); 283 | is($h->authorization_basic, "u:p"); 284 | is(j($h->authorization_basic), "u|p"); 285 | is($h->authorization, "Basic dTpw"); 286 | 287 | is(eval { $h->authorization_basic("u2:p") }, undef); 288 | ok($@); 289 | is(j($h->authorization_basic), "u|p"); 290 | 291 | is($h->proxy_authorization_basic("u2", "p2"), undef); 292 | is(j($h->proxy_authorization_basic), "u2|p2"); 293 | is($h->proxy_authorization, "Basic dTI6cDI="); 294 | 295 | is($h->as_string, <new; 306 | eval { 307 | $line = __LINE__; $h->header('foo:', 1); 308 | }; 309 | like($@, qr/^Illegal field name 'foo:' at \Q$file\E line $line/); 310 | eval { 311 | $line = __LINE__; $h->header('', 2); 312 | }; 313 | like($@, qr/^Illegal field name '' at \Q$file\E line $line/); 314 | 315 | 316 | 317 | #---- old tests below ----- 318 | 319 | $h = HTTP::Headers->new( 320 | mime_version => "1.0", 321 | content_type => "text/html" 322 | ); 323 | $h->header(URI => "http://www.oslonett.no/"); 324 | 325 | is($h->header("MIME-Version"), "1.0"); 326 | is($h->header('Uri'), "http://www.oslonett.no/"); 327 | 328 | $h->header("MY-header" => "foo", 329 | "Date" => "somedate", 330 | "Accept" => ["text/plain", "image/*"], 331 | ); 332 | $h->push_header("accept" => "audio/basic"); 333 | 334 | is($h->header("date"), "somedate"); 335 | 336 | my @accept = $h->header("accept"); 337 | is(@accept, 3); 338 | 339 | $h->remove_header("uri", "date"); 340 | 341 | my $str = $h->as_string; 342 | my $lines = ($str =~ tr/\n/\n/); 343 | is($lines, 6); 344 | 345 | $h2 = $h->clone; 346 | 347 | $h->header("accept", "*/*"); 348 | $h->remove_header("my-header"); 349 | 350 | @accept = $h2->header("accept"); 351 | is(@accept, 3); 352 | 353 | @accept = $h->header("accept"); 354 | is(@accept, 1); 355 | 356 | # Check order of headers, but first remove this one 357 | $h2->remove_header('mime_version'); 358 | 359 | # and add this general header 360 | $h2->header(Connection => 'close'); 361 | 362 | my @x = (); 363 | $h2->scan(sub {push(@x, shift);}); 364 | is(join(";", @x), "Connection;Accept;Accept;Accept;Content-Type;MY-Header"); 365 | 366 | # Check headers with embedded newlines: 367 | $h = HTTP::Headers->new( 368 | a => "foo\n\n", 369 | b => "foo\nbar", 370 | c => "foo\n\nbar\n\n", 371 | d => "foo\n\tbar", 372 | e => "foo\n bar ", 373 | f => "foo\n bar\n baz\nbaz", 374 | ); 375 | is($h->as_string("<<\n"), <new( 393 | a => "foo\r\n\r\nevil body" , 394 | b => "foo\015\012\015\012evil body" , 395 | c => "foo\x0d\x0a\x0d\x0aevil body" , 396 | ); 397 | is ( 398 | $h->as_string(), 399 | "A: foo\r\n evil body\n". 400 | "B: foo\015\012 evil body\n" . 401 | "C: foo\x0d\x0a evil body\n" , 402 | "embedded CRLF are stripped out"); 403 | 404 | # Check with FALSE $HTML::Headers::TRANSLATE_UNDERSCORE 405 | { 406 | local($HTTP::Headers::TRANSLATE_UNDERSCORE); 407 | $HTTP::Headers::TRANSLATE_UNDERSCORE = undef; # avoid -w warning 408 | 409 | $h = HTTP::Headers->new; 410 | $h->header(abc_abc => "foo"); 411 | $h->header("abc-abc" => "bar"); 412 | 413 | is($h->header("ABC_ABC"), "foo"); 414 | is($h->header("ABC-ABC"),"bar"); 415 | ok($h->remove_header("Abc_Abc")); 416 | ok(!defined($h->header("abc_abc"))); 417 | is($h->header("ABC-ABC"), "bar"); 418 | } 419 | 420 | # Check if objects as header values works 421 | require URI; 422 | $h->header(URI => URI->new("http://www.perl.org")); 423 | 424 | is($h->header("URI")->scheme, "http"); 425 | 426 | $h->clear; 427 | is($h->as_string, ""); 428 | 429 | $h->content_type("text/plain"); 430 | $h->header(content_md5 => "dummy"); 431 | $h->header("Content-Foo" => "foo"); 432 | $h->header(Location => "http:", xyzzy => "plugh!"); 433 | 434 | is($h->as_string, <remove_content_headers; 443 | is($h->as_string, <as_string, <new; 455 | $h->content_type("text/plain"); 456 | $h->header(":foo_bar", 1); 457 | $h->push_header(":content_type", "text/html"); 458 | is(j($h->header_field_names), "Content-Type|:content_type|:foo_bar"); 459 | is($h->header('Content-Type'), "text/plain"); 460 | is($h->header(':Content_Type'), undef); 461 | is($h->header(':content_type'), "text/html"); 462 | is($h->as_string, <new; 469 | ok(!defined $h->warning('foo', 'INIT')); 470 | is($h->warning('bar'), 'foo'); 471 | is($h->warning('baz', 'GET'), 'bar'); 472 | is($h->as_string, <new; 477 | ok(!defined $h->header(':foo', 'bar')); 478 | ok(!defined $h->header(':zap', 'bang')); 479 | $h->push_header(':zap', ['kapow', 'shazam']); 480 | is(j($h->header_field_names), ':foo|:zap'); 481 | is(j($h->header_field_names), ':foo|:zap'); 482 | $h->scan(sub { $_[1] .= '!' }); 483 | is(j($h->header(':zap')), 'bang!|kapow!|shazam!'); 484 | is(j($h->header(':foo')), 'bar'); 485 | is($h->as_string, <remove_header(':zap')), 'bang!|kapow!|shazam!'); 492 | $h->push_header(':zap', 'whomp', ':foo', 'quux'); 493 | is(j($h->header(':foo')), 'bar|quux'); 494 | 495 | # [RT#30579] IE6 appends "; length = NNNN" on If-Modified-Since (can we handle it) 496 | $h = HTTP::Headers->new( 497 | if_modified_since => "Sat, 29 Oct 1994 19:43:31 GMT; length=34343" 498 | ); 499 | is(gmtime($h->if_modified_since), "Sat Oct 29 19:43:31 1994"); 500 | 501 | $h = HTTP::Headers->new(); 502 | $h->content_type('text/plain'); 503 | $h->content_length(4); 504 | $h->push_header('x-foo' => 'bar'); 505 | $h->push_header('x-foo' => 'baz'); 506 | is(0+$h->flatten, 8); 507 | is_deeply( 508 | [ $h->flatten ], 509 | [ 510 | 'Content-Length', 511 | 4, 512 | 'Content-Type', 513 | 'text/plain', 514 | 'X-Foo', 515 | 'bar', 516 | 'X-Foo', 517 | 'baz', 518 | ], 519 | ); 520 | 521 | subtest 'object that stringifies is a valid value' => sub { 522 | my $h = HTTP::Headers->new; 523 | $h->header('X-Password' => Secret->new('hunter2')); 524 | my $h2 = $h->clone; 525 | is($h2->as_string, "X-Password: hunter2\n", 'correct headers'); 526 | }; 527 | -------------------------------------------------------------------------------- /t/http-config.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | plan tests => 30; 6 | 7 | use HTTP::Config; 8 | 9 | sub j { join("|", @_) } 10 | 11 | my $conf = HTTP::Config->new; 12 | ok($conf->empty); 13 | is($conf->entries, 0); 14 | $conf->add_item(42); 15 | ok(!$conf->empty); 16 | is($conf->entries, 1); 17 | is(j($conf->matching_items("http://www.example.com/foo")), 42); 18 | is(j($conf->remove_items), 42); 19 | is(j($conf->remove_items), ''); 20 | is($conf->matching_items("http://www.example.com/foo"), 0); 21 | is($conf->matching_items('foo', 'bar', 'baz'), 0); 22 | $conf->add({item => "http://www.example.com/foo", m_uri__HEAD => undef}); 23 | is($conf->entries, 1); 24 | is($conf->matching_items("http://www.example.com/foo"), 0); 25 | SKIP: { 26 | my $res; 27 | eval { $res = $conf->matching_items(0); }; 28 | skip "can fails on non-object", 2 if $@; 29 | is($res, 0); 30 | eval { $res = $conf->matching(0); }; 31 | ok(!defined $res); 32 | } 33 | 34 | $conf = HTTP::Config->new; 35 | 36 | $conf->add_item("always"); 37 | $conf->add_item("GET", m_method => ["GET", "HEAD"]); 38 | $conf->add_item("POST", m_method => "POST"); 39 | $conf->add_item(".com", m_domain => ".com"); 40 | $conf->add_item("secure", m_secure => 1); 41 | $conf->add_item("not secure", m_secure => 0); 42 | $conf->add_item("slash", m_host_port => "www.example.com:80", m_path_prefix => "/"); 43 | $conf->add_item("u:p", m_host_port => "www.example.com:80", m_path_prefix => "/foo"); 44 | $conf->add_item("success", m_code => "2xx"); 45 | is($conf->find(m_domain => ".com")->{item}, '.com'); 46 | my @found = $conf->find(m_domain => ".com"); 47 | is($#found, 0); 48 | is($found[0]->{item}, '.com'); 49 | 50 | use HTTP::Request; 51 | my $request = HTTP::Request->new(HEAD => "http://www.example.com/foo/bar"); 52 | $request->header("User-Agent" => "Moz/1.0"); 53 | 54 | is(j($conf->matching_items($request)), "u:p|slash|.com|GET|not secure|always"); 55 | 56 | $request->method("HEAD"); 57 | $request->uri->scheme("https"); 58 | 59 | is(j($conf->matching_items($request)), ".com|GET|secure|always"); 60 | 61 | is(j($conf->matching_items("http://activestate.com")), ".com|not secure|always"); 62 | 63 | use HTTP::Response; 64 | my $response = HTTP::Response->new(200 => "OK"); 65 | $response->content_type("text/plain"); 66 | $response->content("Hello, world!\n"); 67 | $response->request($request); 68 | 69 | is(j($conf->matching_items($response)), ".com|success|GET|secure|always"); 70 | 71 | $conf->remove_items(m_secure => 1); 72 | $conf->remove_items(m_domain => ".com"); 73 | is(j($conf->matching_items($response)), "success|GET|always"); 74 | 75 | $conf->remove_items; # start fresh 76 | is(j($conf->matching_items($response)), ""); 77 | 78 | $conf->add_item("any", "m_media_type" => "*/*"); 79 | $conf->add_item("text", m_media_type => "text/*"); 80 | $conf->add_item("html", m_media_type => "html"); 81 | $conf->add_item("HTML", m_media_type => "text/html"); 82 | $conf->add_item("xhtml", m_media_type => "xhtml"); 83 | 84 | is(j($conf->matching_items($response)), "text|any"); 85 | 86 | $response->content_type("application/xhtml+xml"); 87 | is(j($conf->matching_items($response)), "xhtml|html|any"); 88 | 89 | $response->content_type("text/html"); 90 | is(j($conf->matching_items($response)), "HTML|html|text|any"); 91 | 92 | $response->request(undef); 93 | is(j($conf->matching_items($response)), "HTML|html|text|any"); 94 | 95 | { 96 | my @warnings; 97 | local $SIG{__WARN__} = sub { push @warnings, grep { length } @_ }; 98 | 99 | my $conf = HTTP::Config->new; 100 | $conf->add(owner => undef, callback => sub { 'bleah' }); 101 | $conf->remove(owner => undef); 102 | 103 | ok(($conf->empty), 'found and removed the config entry'); 104 | is(scalar(@warnings), 0, 'no warnings') 105 | or diag('got warnings: ', explain(\@warnings)); 106 | 107 | @warnings = (); 108 | $conf->add_item("bond", m_header__user_agent => 'james/0.0.7'); 109 | my $request2 = HTTP::Request->new(HEAD => "http://www.example.com/foo/bar"); 110 | is(j($conf->matching_items($request2)), ''); 111 | 112 | is(scalar(@warnings), 0, 'no warnings') 113 | or diag('got warnings: ', explain(\@warnings)); 114 | 115 | } 116 | -------------------------------------------------------------------------------- /t/lib/Secret.pm: -------------------------------------------------------------------------------- 1 | package Secret; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use overload ( 7 | q{""} => 'to_string', 8 | fallback => 1, 9 | ); 10 | 11 | sub new { 12 | my ( $class, $s ) = @_; 13 | return bless sub {$s}, $class; 14 | } 15 | 16 | sub to_string { shift->(); } 17 | 18 | 1; 19 | -------------------------------------------------------------------------------- /t/message-brotli.t: -------------------------------------------------------------------------------- 1 | #! perl -w 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | use Test::Needs 'IO::Compress::Brotli', 'IO::Uncompress::Brotli'; 8 | 9 | require HTTP::Message; 10 | 11 | subtest "decoding" => sub { 12 | 13 | my $m = HTTP::Message->new( 14 | [ 15 | "Content-Type" => "text/plain", 16 | "Content-Encoding" => "br, base64", 17 | ], 18 | "CwaASGVsbG8gd29ybGQhCgM=\n" 19 | ); 20 | is( $m->decoded_content, "Hello world!\n", "decoded_content() works" ); 21 | ok( $m->decode, "decode() works" ); 22 | is( $m->content, "Hello world!\n", "... and content() is correct" ); 23 | }; 24 | 25 | subtest "encoding" => sub { 26 | my $m = HTTP::Message->new( 27 | [ 28 | "Content-Type" => "text/plain", 29 | ], 30 | "Hello world!" 31 | ); 32 | ok( $m->encode("br"), "set encoding to 'br" ); 33 | is( $m->header("Content-Encoding"), 34 | "br", "... and Content-Encoding is set" ); 35 | isnt( $m->content, "Hello world!", "... and the content has changed" ); 36 | is( $m->decoded_content, "Hello world!", "decoded_content() works" ); 37 | ok( $m->decode, "decode() works" ); 38 | is( $m->content, "Hello world!", "... and content() is correct" ); 39 | }; 40 | 41 | done_testing; 42 | -------------------------------------------------------------------------------- /t/message-charset.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | plan tests => 43; 6 | 7 | use HTTP::Response; 8 | my $r = HTTP::Response->new(200, "OK"); 9 | is($r->content_charset, undef); 10 | is($r->content_type_charset, undef); 11 | 12 | $r->content_type("text/plain"); 13 | is($r->content_charset, undef); 14 | 15 | $r->content("abc"); 16 | is($r->content_charset, "US-ASCII"); 17 | 18 | $r->content("f\xE5rep\xF8lse\n"); 19 | is($r->content_charset, "ISO-8859-1"); 20 | 21 | $r->content("f\xC3\xA5rep\xC3\xB8lse\n"); 22 | is($r->content_charset, "UTF-8"); 23 | 24 | $r->content_type("text/html"); 25 | $r->content(<<'EOT'); 26 | 27 | EOT 28 | is($r->content_charset, "UTF-8"); 29 | 30 | $r->content(<<'EOT'); 31 | 32 | 33 | 34 | EOT 35 | is($r->content_charset, "UTF-8"); 36 | 37 | $r->content(<<'EOT'); 38 |