HTTP-Proxy-0.304/0000755000175000017500000000000012537671053012075 5ustar bookbookHTTP-Proxy-0.304/Changes0000644000175000017500000004634212537671053013401 0ustar bookbookRevision history for Perl extension HTTP::Proxy 0.304 Tue Jun 16 2015 [FIXES] - fix RT #105177 (Slaven Rezic and Gregor Herrmann), regarding Via: header [TEST] - improvement on the fix for t/23connect.t (thanks to e477), but that does not seem to be enough - fix RT #71771 (test using HTML::Parser) 0.303 Wed Apr 29 2015 [FIXES] - closed RT #90414 (Vincenzo Buttazzo), fixing HTTPS data transfer - closed RT #62950 (Slaven Rezic), adding the port to the Via: header [DOCUMENTATION] - added many more contributors in the META file [TEST] - fixed t/23connect.t 0.302 Sat Jan 31 2015 [DOCUMENTATION] - fix RT #85632 (Ashley Pond V) - multiple documentation fixes (Ashley Pond V) - list git contributors in the META file [PACKAGING] - switch to Dist::Zilla for maintaining the distribution 0.301 Sun Aug 3 2014 [TEST] - fix t/02pod-coverage.t to skip HTTP::Proxy::Engine::Threaded when running under an unthreaded Perl (Masahiro Nagano (KAZEBURO)) - fix t/01pod.t and t/02pod-coverage.t to only run under RELEASE_TESTING (thanks to Masahiro Nagano (KAZEBURO)) 0.300 Sun Apr 7 2013 [IMPROVEMENTS] - Downgrade a disconnect message from ERROR to SOCKET debug level in order to reduce the amount of runtime log output. Disconnects are /very/ common in HTTP, and shoudn't be considered errors. (thanks to Salve J. Nilsen) [TEST] - include t/90httpstatus.t in the MANIFEST - fix t/67save.t to not try to create files with a "?" in their name under MSWin32 0.29 Tue Mar 19 2013 [TEST] - fix t/50hopbyhop.t to open the proxy on a random port, and avoid failures when port 8080 is "already in use" 0.28 Thu Mar 14 2013 [FIXES] - the Accept-Encoding header removal code was broken in the previous version. Now the header will be removed as soon as a body filter is configured for the proxy. [TEST] - use File::Spec in the test suite to compute portable file names, to avoid some test failures, like http://www.cpantesters.org/cpan/report/856ca676-6bf5-1014-bfa1-9d8aa3912248 0.27 Fri Mar 8 2013 [IMPROVEMENTS] - in HTTP::Proxy::HeaderFilter::standard, now remove the Accept-Encoding header only when we know we'll actually look at the response body [TESTS] - use httpstat.us to test HTTP statuses 0.26 Wed Feb 6 2013 [IMPROVEMENTS] - remove a "Use of "goto" to jump into a construct is deprecated" warning (Tom Hukins) [DOCUMENTATION] - fix RT #77685 (Tom Hukins) - improved the number of links to other modules from the documentation [TEST] - fix RT #71771 (Tom Hukins) - fix test failures in POD tests (Tom Hukins) 0.25 Sun Jul 3 00:28:10 CEST 2011 [ENHANCEMENTS] - new Engine: HTTP::Proxy::Engine::Threaded, by Angelos Karageorgiou [FIXES] - Correctly call eod() when the response has no body (closed RT ticket #48310) 0.24 Tue Jul 21 21:28:02 CEST 2009 [ENHANCEMENTS] - When a short-circuit response was send, the next response would not be filtered at all. This has been fixed. [FIXES] - yet another fix for t/23connect, proposed by Marek Rouchal (closed RT ticket #38995) [test skipped for now] - HTTP::Headers::Util's split_header_words() returns lower case tokens/keys since October 6, 2008. Fix by Maurice Aubrey. (closed RT tickets #43249, #43622) 0.23 Thu Sep 4 02:29:47 CEST 2008 [ENHANCEMENTS] - HTTP::Proxy::BodyFilter::save had an issue with cygwin because of an incorrect use of File::Spec's catdir(). This is fixed. - CONNECT requests are now forwarded to the upstream proxy, if there is one. Errors from the upstream proxy are relayed to the client. [TESTS] - t/23connect.t does not use sysread() anymore. This time the test should pass about everywhere. 0.22 Thu May 1 00:18:38 CEST 2008 [TESTS] - increased test coverage - t/23connect.t doesn't need an Internet connection any more, thus closing RT ticket #19653. - t/67complete.t tests HTTP::Proxy::BodyFilter::complete [DOCUMENTATION] - closed RT ticket #33465 (Jimbo), by explaining in a little more detail how HTTP::Proxy::BodyFilter::complete works. 0.21 Sun Apr 20 04:34:47 CEST 2008 [ENHANCEMENTS] - HTTP::Proxy::Engine::Legacy and HTTP::Proxy::Engine::ScoreBoard log the number of remaining child processes (in addition to their pids), thanks to Amos Shapira. [FIXES] - HTTP::Proxy::BodyFilter::save had a bug that prevented the 'filename' parameter to be correctly used to compute the filename to save to, and that made the proxy die the second time the filter was called. This fix allowed to close RT tickets #14548 (Max Maischein), #18644 (Mark Tilford) and #33018 (Roland Stigge and Gunnar Wolf). - HTTP::Proxy::BodyFilter::save had many other bugs, which the test suite allowed to spot and fix. [TESTS] - t/67save.t provides 96% coverage of HTTP::Proxy::BodyFilter::save, and helped fix many bugs in it. - fixed t/22http.t and t/22transparent.t not to break when the DNS wrongly resolves an invalid address. [DOCUMENTATION] - closed RT ticket #25295 (Matsuno Tokuhiro) with a doc patch. 0.20 Fri Aug 18 10:25:11 CEST 2006 [ENHANCEMENTS] - Added a will_modify() method to HTTP::Proxy::BodyFilter, that lets the proxy know if a filter may modify the content length, thus closing RT ticket #21051 (Chris Dolan) - If no filter in the current stack will modify the content length, then the header is not removed [FIXES] - closed RT tickets #3184 and #20251 (chunked encoding was enforced while transfering data between a client and server using different versions of HTTP, causing unwanted garbage to appear in the data) - removed useless "ERROR: Getting request failed:" messages when there are simply "No more requests from this connection" [INTERNALS] - Removed the HTTP::Proxy::FilterStack class from inside HTTP::Proxy and put it in its own module file - renamed HTTP::Proxy::FilterStack::active() as will_modify() for consistency reasons [TESTS] - updated t/22http.t and t/23connect.t following Ken Williams' recommandations in RT ticket #19986 [DOCUMENTATION] - patched a small inconsistency in HTTP::Proxy::BodyFilter's documentation (and closed RT ticket #20303) - fully documented HTTP::Proxy::FilterStack 0.19 Fri Apr 28 19:55:41 CEST 2006 [ENHANCEMENTS] - HTTP::Proxy::HeaderFilter::simple now lets one define an end() method as well [FIXES] - HTTP::Proxy::(Body|Header)Filter::simple now provide a default filter() that does nothing if their constructor is not given one (thanks to Merijn Brand) - close RT ticket #14548 by correcting the 'filename' check in HTTP::Proxy::BodyFilter::save (Max Maischein) - ERROR messages are always logged (Mark Tilford) [TESTS] - more tests for log() and logmask() in t/11log.t 0.18 Sun Mar 19 23:49:38 CET 2006 [ENHANCEMENTS] - the new known_methods() method can return all method names know to HTTP::Proxy (can be helpful with the method parameter of push_filter()) [FIXES] - close RT ticket #14898 by using a per-parent lockfile for HTTP::Proxy::Engine::ScoreBoard (Chris Dolan) - close RT ticket #18243 by adding missing DeltaV methods (Stephen Steneker) [EXAMPLES] - eg/perlmonks.pl - redirect perlmonks.com to perlmonks.org 0.17 Wed Sep 28 23:25:17 CEST 2005 [ENHANCEMENTS] - Thanks to Randal Schwartz, a new HTTP::Proxy::Engine::ScoreBoard engine is available. I've benchmarked a twofold speed increase. This engine is still beta, you must enable it by hand. 0.16 Thu Sep 1 19:13:55 CEST 2005 [ENHANCEMENTS] - the new HTTP::Proxy::Engine class and its subclasses now handle the life and death of child processes - the Content-Length header is now removed only if body filters will be applied on the response body - HTTP::Proxy now supports some Apache-like attributes (start_servers, max_clients, max_requests_per_child, min_spare_servers, max_spare_servers, keep_alive, max_keep_alive_requests, keep_alive_timeout) - added support for ALL WebDAV/DeltaV methods - the query argument to push_filter(), added in 0.14, should now work (thanks to Simon Cozens for spotting the problem) - the proxy now has a stash, which is a hash where filters can store data (possibly to share it). (Requested by Mark Fowler) Warning: since the proxy forks for each TCP connection, the data is only shared between filters in the same child process. [DEPRECATION] - the maxchild, maxconn and maxserve accessors are now deprecated. They will disappear in the future: + maxchild has no replacement (should be handled by the engine) + maxconn becomes max_connections + maxserve becomes max_keep_alive_requests - Information regarding the way the engine should behave must passed in the constructor or directly to the engine [NEW METHODS] - $proxy->engine() return the HTTP::Proxy::Engine instance - $proxy->new_connection() increase the TCP connections counter (should only be used by HTTP::Proxy::Engine object) [FIXES] - Makefile.PL was not playing nice with Build.PL in the previous distributions. This has been fixed. Sorry for the inconvenience - no more annoying "getsockname() on closed socket GEN0" warnings (they appeared in 0.14) [Win32 SUPPORT] - Win32 is now supported! badly supported, but supported... - until someone writes a decent engine for Win32, the default Win32 engine will be HTTP::Proxy::Engine::NoFork, which can only handle a single TCP connection at a time [EXAMPLES] - eg/yahoogroups.pl - removes ad interruptions from Yahoo! Groups - eg/https.pl - peek/poke at encrypted web pages - eg/logger.pl - improved the logger script 0.15 Tue Apr 5 21:17:40 CEST 2005 [ENHANCEMENTS] - added support for WebDAV methods (requested by Christian Laursen) - The filter selection is based on the original request and response, as it should - improved kwalitee [DEPRECATION] - the start() method is no longer supported in HTTP::Proxy::BodyFilter subclasses. Use begin() instead. [EXAMPLES] - eg/pdf.pl - save \.pdf files and send a HTML confirmation instead (idea by Emmanuel Di Prétoro) 0.14 Tue Mar 29 11:40:51 CEST 2005 [ANNOUNCE] - It's been more than a year since last release, which is bad. I now plan to release new versions more often, maybe about once a month, or when there are big changes. [DEPRECATION] - the start() method of HTTP::Proxy::Bodyfilter subclasses is renamed begin(), since it now has an end() counterpart. (On a related note, I improve my English. Be sure to check out http://www.landgren.net/perl/lt-2004.html for details) - start() in filters is therefore declared deprecated, an error message is logged. The start() method will not be called any more as from 0.15. - the FILTER constant is now named FILTERS. FILTER will disappear in 0.15 as well. [ENHANCEMENTS] - subclasses of HTTP::Proxy::BodyFilter can now have a finalisation method, named end() - the start^Wbegin() method of HTTP::Proxy::BodyFilter subclasses now receive the message as an argument - new built-in filter: HTTP::Proxy::BodyFilter::save that can save the message body to a file while browsing - new built-in filter: HTTP::Proxy::BodyFilter::complete that stores the message body in memory and passes it on to the next filters only when it's complete - logs have cleaner prefixes and the pid is always shown - should work under 5.005_03 (Thanks to Mathieu Arnold) - transparent proxying support (mostly to please Martin Zdila and Paul Makepeace) - push_filter() should now accept the query parameter [FIXES] - the FILTER constant is now named FILTERS [BUGS] - the proxy does not work under Win32, except if you force maxchild to 0 (no forking at all). - t/20dummy.t (and a few others) hanged under Win32 + Ken Hirsch proposed a patch for HTTP::Daemon (and a workaround for HTTP::Proxy's daemon object) + Bruno De Fraine tracked down the problem to the fork() emulation by Windows threads under Win32 that lead to a deadlock. => both explanations cover the same problem, which I haven't been able to correct yet - all the tests that fork a proxy and a server are therefore skipped under Win32. This is ugly, and will change in the future. [EXAMPLES] - eg/rfc.pl - save rfc\d+\.txt files as we browse them - eg/js.pl - save \.js files as we browse them - eg/dragon.pl - enhance the Dragon Go Server web site - eg/fudd.pl - make the web tawk wike Ewmer J. Fudd - eg/switch.pl - switch proxies as you browse - Changed all the examples so that they can take HTTP::Proxy::new() parameters on the command-line (so, call them with logmask 3, for example) [DOCUMENTATION] - documentation for the filter initialisation methods - removed all references to the so-called "store-and-forward" mechanism (see HTTP::Proxy::BodyFilter::complete) 0.13 Wed Mar 3 17:36:31 CET 2004 [ENHANCEMENTS] - CONNECT support (but only transparently...) - the client_headers() method (similar to hop_headers()) give the filters access to the proxy's LWP::UA Client-* headers - filters are applied on all supported methods by default [FIXES] - removed everything regarding control() and control_regex(), which were not used and confusing [TESTS] - tests for CONNECT support - tests for SSL support (not working yet) [EXAMPLES] - eg/adblock.pl - a very simple adblocker - eg/trim.pl - trims whitespace from HTML pages - eg/javascript.pl - add any text right after [DOCUMENTATION] - separate COPYRIGHT and LICENSE sections in all man pages 0.12 Thu Jan 22 23:54:03 CET 2004 [ENHANCEMENTS] - send the error message to the client when the Proxy agent dies (usually because of a filter error) - the proxy now sends a X-Forwarded-For header by default (and the proxy method x_forwarded_for can toggle this) - the proxy method client_socket() gives access to the socket connected to the current client (the example in Changes for 0.10 was wrong: one can get the IP address of the connected agent from inside a filter with $self->proxy->client_socket->peerhost) [FIXES] - do not block simultaneous connections when not forking - clean up the filter chain after the body-request filters - ensure the filter stack is reinitialised between requests [TESTS] - tests for X-Forwarded-For - test the proxy against http://diveintomark.org/tests/client/http/ [EXAMPLES] - eg/post.pl - outputs the URI and parameters of all POST requests - eg/logger.pl - outputs details of GET and POST requests 0.11 Fri Jan 2 17:02:08 CET 2004 [ENHANCEMENTS] - setting maxchild to 0 prevents forking (Jim Cromie) - filters can now match on the query string - hop-by-hop headers and Max-Forwards headers are correctly supported - new mutators added to HTTP::Proxy: via, hop_headers, request, response - filters can now answer in place of the server, which allows for authorisation filters, cache (?) filters, etc. - new examples scripts: proxy-auth.pl [FIXES] - push_filter() now correctly supports several match criteria [TESTS] - all the Via: header tests are now in t/50via.t - t/50standard.t now checks headers for several request types - new tests: + t/51simple2.t - check response header filters with an actual proxy + t/61simple2.t - check response body filters with an actual proxy [INTERNALS] - new method _send_response_headers 0.10 Wed Nov 19 01:36:59 CET 2003 *** MAJOR INTERFACE CHANGES *** - new base classes HTTP::Proxy::HeaderFilter and HTTP::Proxy::BodyFilter - some useful built-in filter classes: HTTP::Proxy::BodyFilter::htmlparser HTTP::Proxy::BodyFilter::htmltext HTTP::Proxy::BodyFilter::lines HTTP::Proxy::BodyFilter::simple HTTP::Proxy::BodyFilter::tags HTTP::Proxy::HeaderFilter::simple HTTP::Proxy::HeaderFilter::standard - tests for the internal class HTTP::Proxy::FilterStack - tests for the built-in filters - the examples are up-to-date with the new interface - new/enhanced accessors: + the proxy host() attribute becomes actually useful: by default, the proxy is only usable by local user-agents (the socket is bound to localhost) + the filters proxy() accessor gives access to the proxy itself. For example, one can get the IP address of the agent connected to the proxy from inside a filter ($self->proxy->daemon->peerhost) - many documentation changes This version is NOT compatible with the previous ones regarding the way filters work. *** MAJOR INTERFACE CHANGES *** 0.09 Fri Aug 15 21:12:17 CEST 2003 - maxserve is now correctly handled - corrected a bug in the t/20keepalive.t test file that made the tests fail on some machines 0.08 Thu Mar 13 01:41:42 CET 2003 - cleaned up support for filters - added support for "buffering" filters and a new HTTP::Proxy::FilterStack class - added an anonymiser script (eg/anonymiser.pl) - the tests won't break if a local proxy is configured - the interfaces are very likely to change soon 0.07 Tue Feb 18 22:30:43 CET 2003 - the proxy now supports persistent connexions (Yay!) - and tests to check for it - and a new timeout accessor 0.06 Mon Feb 17 00:21:37 CET 2003 - better forking system and better reaping of zombies (thanks to David Landgren and Stéphane Payrard) Still won't work under Windows, though :-( - replaced verbose() by logmask(), so as to fine-tune the logging system - put some of the test functions in a test module (t::Utils) 0.05 Tue Feb 4 00:47:23 CET 2003 - explicitly refuse CONNECT - better support for TRACE method - support the Via: Header (a MUST in RFC 2616) - filters, but this needs more work 0.04 Sat Nov 30 12:19:22 CET 2002 - accept connection from other hosts - better ftp support (no test yet) - basic gopher support (no test yet) - better HTTP error handling - use CRLF in HTTP headers 0.03 Fri Nov 29 11:17:36 CET 2002 - url() method gives a url to reach the proxy - new 'control' attribute defines the control URL - better subprocess management by preforking child processes (thanks to Eric Cholet) - a children handles only one request at a time, for better performance (this means we only do HTTP/1.0 for now) - correctly handle the Proxy-Connection and Connection headers 0.02 Thu Oct 24 23:45:08 CEST 2002 - the system now forks to handle several connections - but needs better test suites 0.01 Tue Oct 1 11:54:07 CEST 2002 - original version HTTP-Proxy-0.304/LICENSE0000644000175000017500000004371312537671053013112 0ustar bookbookThis software is copyright (c) 2015 by Philippe Bruhat (BooK). This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. Terms of the Perl programming language system itself a) the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version, or b) the "Artistic License" --- The GNU General Public License, Version 1, February 1989 --- This software is Copyright (c) 2015 by Philippe Bruhat (BooK). This is free software, licensed under: The GNU General Public License, Version 1, February 1989 GNU GENERAL PUBLIC LICENSE Version 1, February 1989 Copyright (C) 1989 Free Software Foundation, Inc. 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The license agreements of most software companies try to keep users at the mercy of those companies. By contrast, our General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. The General Public License applies to the Free Software Foundation's software and to any other program whose authors commit to using it. You can use it for your programs, too. When we speak of free software, we are referring to freedom, not price. Specifically, the General Public License is designed to make sure that you have the freedom to give away or sell copies of free software, that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of a such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must tell them their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any work containing the Program or a portion of it, either verbatim or with modifications. Each licensee is addressed as "you". 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this General Public License and to the absence of any warranty; and give any other recipients of the Program a copy of this General Public License along with the Program. You may charge a fee for the physical act of transferring a copy. 2. You may modify your copy or copies of the Program or any portion of it, and copy and distribute such modifications under the terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains the Program or any part thereof, either with or without modifications, to be licensed at no charge to all third parties under the terms of this General Public License (except that you may choose to grant warranty protection to some or all third parties, at your option). c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the simplest and most usual way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this General Public License. d) You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. Mere aggregation of another independent work with the Program (or its derivative) on a volume of a storage or distribution medium does not bring the other work under the scope of these terms. 3. You may copy and distribute the Program (or a portion or derivative of it, under Paragraph 2) in object code or executable form under the terms of Paragraphs 1 and 2 above provided that you also do one of the following: a) accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) accompany it with a written offer, valid for at least three years, to give any third party free (except for a nominal charge for the cost of distribution) a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) accompany it with the information you received as to where the corresponding source code may be obtained. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form alone.) Source code for a work means the preferred form of the work for making modifications to it. For an executable file, complete source code means all the source code for all modules it contains; but, as a special exception, it need not include source code for modules which are standard libraries that accompany the operating system on which the executable file runs, or for standard header files or definitions files that accompany that operating system. 4. You may not copy, modify, sublicense, distribute or transfer the Program except as expressly provided under this General Public License. Any attempt otherwise to copy, modify, sublicense, distribute or transfer the Program is void, and will automatically terminate your rights to use the Program under this License. However, parties who have received copies, or rights to use copies, from you under this General Public License will not have their licenses terminated so long as such parties remain in full compliance. 5. By copying, distributing or modifying the Program (or any work based on the Program) you indicate your acceptance of this license to do so, and all its terms and conditions. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. 7. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of the license which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the license, you may choose any version ever published by the Free Software Foundation. 8. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS Appendix: How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to humanity, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) 19yy This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston MA 02110-1301 USA Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) 19xx name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (a program to direct compilers to make passes at assemblers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice That's all there is to it! --- The Artistic License 1.0 --- This software is Copyright (c) 2015 by Philippe Bruhat (BooK). This is free software, licensed under: The Artistic License 1.0 The Artistic License Preamble The intent of this document is to state the conditions under which a Package may be copied, such that the Copyright Holder maintains some semblance of artistic control over the development of the package, while giving the users of the package the right to use and distribute the Package in a more-or-less customary fashion, plus the right to make reasonable modifications. Definitions: - "Package" refers to the collection of files distributed by the Copyright Holder, and derivatives of that collection of files created through textual modification. - "Standard Version" refers to such a Package if it has not been modified, or has been modified in accordance with the wishes of the Copyright Holder. - "Copyright Holder" is whoever is named in the copyright or copyrights for the package. - "You" is you, if you're thinking about copying or distributing this Package. - "Reasonable copying fee" is whatever you can justify on the basis of media cost, duplication charges, time of people involved, and so on. (You will not be required to justify it to the Copyright Holder, but only to the computing community at large as a market that must bear the fee.) - "Freely Available" means that no fee is charged for the item itself, though there may be fees involved in handling the item. It also means that recipients of the item may redistribute it under the same conditions they received it. 1. You may make and give away verbatim copies of the source form of the Standard Version of this Package without restriction, provided that you duplicate all of the original copyright notices and associated disclaimers. 2. You may apply bug fixes, portability fixes and other modifications derived from the Public Domain or from the Copyright Holder. A Package modified in such a way shall still be considered the Standard Version. 3. You may otherwise modify your copy of this Package in any way, provided that you insert a prominent notice in each changed file stating how and when you changed that file, and provided that you do at least ONE of the following: a) place your modifications in the Public Domain or otherwise make them Freely Available, such as by posting said modifications to Usenet or an equivalent medium, or placing the modifications on a major archive site such as ftp.uu.net, or by allowing the Copyright Holder to include your modifications in the Standard Version of the Package. b) use the modified Package only within your corporation or organization. c) rename any non-standard executables so the names do not conflict with standard executables, which must also be provided, and provide a separate manual page for each non-standard executable that clearly documents how it differs from the Standard Version. d) make other distribution arrangements with the Copyright Holder. 4. You may distribute the programs of this Package in object code or executable form, provided that you do at least ONE of the following: a) distribute a Standard Version of the executables and library files, together with instructions (in the manual page or equivalent) on where to get the Standard Version. b) accompany the distribution with the machine-readable source of the Package with your modifications. c) accompany any non-standard executables with their corresponding Standard Version executables, giving the non-standard executables non-standard names, and clearly documenting the differences in manual pages (or equivalent), together with instructions on where to get the Standard Version. d) make other distribution arrangements with the Copyright Holder. 5. You may charge a reasonable copying fee for any distribution of this Package. You may charge any fee you choose for support of this Package. You may not charge a fee for this Package itself. However, you may distribute this Package in aggregate with other (possibly commercial) programs as part of a larger (possibly commercial) software distribution provided that you do not advertise this Package as a product of your own. 6. The scripts and library files supplied as input to or produced as output from the programs of this Package do not automatically fall under the copyright of this Package, but belong to whomever generated them, and may be sold commercially, and may be aggregated with this Package. 7. C or perl subroutines supplied by you and linked into this Package shall not be considered part of this Package. 8. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. 9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. The End HTTP-Proxy-0.304/eg/0000755000175000017500000000000012537671053012470 5ustar bookbookHTTP-Proxy-0.304/eg/dragon.pl0000755000175000017500000000410212537671053014277 0ustar bookbook#!/usr/bin/perl -w use HTTP::Proxy; use HTTP::Proxy::HeaderFilter::simple; use HTTP::Proxy::BodyFilter::simple; use HTTP::Proxy::BodyFilter::complete; use MIME::Base64; use Fcntl ':flock'; use strict; # the proxy my $proxy = HTTP::Proxy->new( @ARGV ); # the status page: # - auto-refresh (quickly at first, then more slowly) # - count the number of games and modify the title my $seen_title; $proxy->push_filter( host => 'www.dragongoserver.net', path => '^/status.php', # auto-refresh response => HTTP::Proxy::HeaderFilter::simple->new( sub { my ( $self, $headers, $response ) = @_; ($response->request->uri->query || '') =~ /reload=(\d+)/; my $n = ($1 || 0) + 1; my $delay = $n < 5 ? 30 : $n < 15 ? 60 : $n < 25 ? 300 : 3600; $headers->push_header( Refresh => "$delay;url=" . $response->request->uri->path . "?reload=$n" ); } ), # count games response => HTTP::Proxy::BodyFilter::complete->new(), response => HTTP::Proxy::BodyFilter::simple->new( filter => sub { my ( $self, $dataref, $message, $protocol, $buffer ) = @_; next if ! $$dataref; # count the games and change the title my $n = 0; $n++ while $$dataref =~ /game\.php\?gid=\d+/g; my $s = $n > 1 ? "s" : ""; $n ||= "No"; $$dataref =~ s!.*?!$n go game$s pending!s; }, ), ); # the game page: # - remove the Message: textarea # - add a link to make it appear when needed $proxy->push_filter( host => 'www.dragongoserver.net', path => '^/game.php', response => HTTP::Proxy::BodyFilter::complete->new(), response => HTTP::Proxy::BodyFilter::simple->new( sub { my $msg = '&msg=yes'; my $uri = $_[2]->request->uri; if( $uri =~ s/$msg//o ) { $msg = ''; } else { ${$_[1]} =~ s|()||; } ${$_[1]} =~ s|(Message:)|$1|; } ) ); $proxy->start; HTTP-Proxy-0.304/eg/proxy.pl0000755000175000017500000000020612537671053014207 0ustar bookbook#!/usr/bin/perl -w use HTTP::Proxy qw( :log ); use strict; # a very simple proxy my $proxy = HTTP::Proxy->new(@ARGV); $proxy->start; HTTP-Proxy-0.304/eg/outline.pl0000755000175000017500000000214512537671053014511 0ustar bookbook#!/usr/bin/perl -w use HTTP::Proxy qw( :log ); use HTTP::Proxy::BodyFilter::htmlparser; use HTML::Parser; use strict; my $parser = HTML::Parser->new( api_version => 3 ); $parser->handler( start_document => sub { my $self = shift; $self->{print} = 1 }, "self" ); $parser->handler( start => sub { my ( $self, $tag, $text ) = @_; $self->{print} = 1 if $tag =~ /^h\d/; $self->{output} .= $text if $self->{print}; $self->{print} = 0 if $tag eq 'body'; }, "self,tagname,text" ); $parser->handler( end => sub { my ( $self, $tag, $text ) = @_; $self->{print} = 1 if $tag eq 'body'; $self->{output} .= $text if $self->{print}; $self->{print} = 0 if $tag =~ /^h\d/; }, "self,tagname,text" ); $parser->handler( default => sub { my ( $self, $text ) = @_; $self->{output} .= $text if $self->{print}; }, "self,text" ); my $filter = HTTP::Proxy::BodyFilter::htmlparser->new( $parser, rw => 1 ); my $proxy = HTTP::Proxy->new(@ARGV); $proxy->push_filter( mime => 'text/html', response => $filter ); $proxy->start; HTTP-Proxy-0.304/eg/rot13.pl0000755000175000017500000000337712537671053014012 0ustar bookbook#!/usr/bin/perl -w use HTTP::Proxy qw( :log ); use HTTP::Proxy::BodyFilter::tags; use HTTP::Proxy::BodyFilter::simple; use HTTP::Proxy::BodyFilter::htmltext; use strict; my $proxy = HTTP::Proxy->new(@ARGV); my %noaccent = ( Agrave => 'A', Aacute => 'A', Acirc => 'A', Atilde => 'A', Auml => 'A', Aring => 'A', AElig => 'AE', Ccedil => 'C', Egrave => 'E', Eacute => 'E', Ecirc => 'E', Euml => 'E', Igrave => 'I', Iacute => 'I', Icirc => 'I', Iuml => 'I', Ntilde => 'N', Ograve => 'O', Oacute => 'O', Ocirc => 'O', Otile => 'O', Ouml => 'O', Oslash => 'O', Ugrave => 'U', Uacute => 'U', Ucirc => 'U', Uuml => 'U', Yacute => 'Y', agrave => 'a', aacute => 'a', acirc => 'a', atilde => 'a', auml => 'a', aring => 'a', aelig => 'ae', ccedil => 'c', egrave => 'e', eacute => 'e', ecirc => 'e', euml => 'e', igrave => 'i', iacute => 'i', icirc => 'i', iuml => 'i', ntilde => 'n', ograve => 'o', oacute => 'o', ocirc => 'o', otile => 'o', ouml => 'o', oslash => 'o', ugrave => 'u', uacute => 'u', ucirc => 'u', uuml => 'u', yacute => 'y', 'yuml' => 'y', 'Æ' => 'AE', 'æ' => 'ae', ); my $re = join '|', sort keys %noaccent; $proxy->push_filter( mime => 'text/html', response => HTTP::Proxy::BodyFilter::tags->new, # protect tags response => HTTP::Proxy::BodyFilter::simple->new( # remove accents sub { ${ $_[1] } =~ s/&($re);/$noaccent{$1}/go; } ), response => HTTP::Proxy::BodyFilter::htmltext->new( # rot13 sub { tr{ÀÁÂÃÄÅÇÈÉÊËÌÍÎÏÑÒÓÔÕÖØÙÚÛÜÝàáâãäåçèéêëìíîïñòóôõöøùúûüýÿ} {AAAAAACEEEEIIIINOOOOOOUUUUYaaaaaaceeeeiiiinoooooouuuuyy}; tr/a-zA-z/n-za-mN-ZA-M/; } ) ); $proxy->start; HTTP-Proxy-0.304/eg/js.pl0000755000175000017500000000055112537671053013445 0ustar bookbookuse HTTP::Proxy; use HTTP::Proxy::BodyFilter::save; my $proxy = HTTP::Proxy->new(@ARGV); # save javascript files as we browse them $proxy->push_filter( path => qr!/.js$!, response => HTTP::Proxy::BodyFilter::save->new( template => '%f', prefix => 'javascript', multiple => 0, keep_old => 1, ) ); $proxy->start; HTTP-Proxy-0.304/eg/proxy-auth.pl0000755000175000017500000000201412537671053015145 0ustar bookbook#!/usr/bin/perl -w use HTTP::Proxy qw( :log ); use HTTP::Proxy::HeaderFilter::simple; use MIME::Base64 qw( encode_base64 ); use strict; # the encoded user:password pair # login: http # passwd: proxy my $token = "Basic " . encode_base64( "http:proxy", '' ); # a very simple proxy that requires authentication my $proxy = HTTP::Proxy->new(@ARGV); # the authentication filter $proxy->push_filter( request => HTTP::Proxy::HeaderFilter::simple->new( sub { my ( $self, $headers, $request ) = @_; # check the token against all credentials my $ok = 0; $_ eq $token && $ok++ for $self->proxy->hop_headers->header('Proxy-Authorization'); # no valid credential if ( !$ok ) { my $response = HTTP::Response->new(407); $response->header( Proxy_Authenticate => 'Basic realm="HTTP::Proxy"' ); $self->proxy->response($response); } } ) ); $proxy->start; HTTP-Proxy-0.304/eg/leet.pl0000755000175000017500000000175612537671053013772 0ustar bookbook#!/usr/bin/perl -w use HTTP::Proxy qw( :log ); use HTTP::Proxy::BodyFilter::tags; use HTTP::Proxy::BodyFilter::htmltext; use strict; # a very simple proxy my $proxy = HTTP::Proxy->new( @ARGV ); my %leet = ( a => [qw( 4 /-\ @ )], b => ['|3'], c => [qw! c ( < [ !], e => [qw( e 3 )], g => [qw( g 6 )], h => [qw! h |-| )-( !], k => [qw( k |< ]{ )], i => ['i', '!'], l => [ 'l', "1", "|" ], m => [ 'm', "|V|", "|\\/|" ], n => ["|\\|"], o => ['o', "0"], s => [ "5", "Z" ], t => [ "7", "+" ], u => [qw( u \_/ )], v => [qw( v \/ )], w => [qw( vv `// )], 'y' => ['j', '`/'], z => ["2"], ); # but a complicated filter $proxy->push_filter( mime => 'text/html', response => HTTP::Proxy::BodyFilter::tags->new, response => HTTP::Proxy::BodyFilter::htmltext->new( sub { s/([a-zA-Z])/$leet{lc $1}[rand @{$leet{lc $1}}]||$1/ge; } ) ); $proxy->start; HTTP-Proxy-0.304/eg/adblock.pl0000755000175000017500000000201412537671053014424 0ustar bookbook#!/usr/bin/perl -w use strict; use HTTP::Proxy qw( :log ); use HTTP::Proxy::HeaderFilter::simple; use vars qw( $re ); # this is a very simple ad blocker # a full-fledged ad blocker should be a module # this dot is *not* a web bug ;-) my $no = HTTP::Response->new( 200 ); $no->content_type('text/plain'); $no->content('.'); my $filter = HTTP::Proxy::HeaderFilter::simple->new( sub { my ( $self, $headers, $message ) = @_; $self->proxy->response( $no ) if $message->uri->host =~ /$re/o; } ); my $proxy = HTTP::Proxy->new( @ARGV ); $proxy->push_filter( request => $filter ); $proxy->start; # a short and basic list BEGIN { $re = join '|', map { quotemeta } qw( ads.wanadooregie.com cybermonitor.com doubleclick.com adfu.blockstackers.com bannerswap.com click2net.com clickxchange.com dimeclicks.com fastclick.net mediacharger.com mediaplex.com myaffiliateprogram.com netads.hotwired.com valueclick.com ); } HTTP-Proxy-0.304/eg/tracker.pl0000755000175000017500000000162712537671053014471 0ustar bookbook#!/usr/bin/perl -w use HTTP::Proxy; use HTTP::Proxy::HeaderFilter::simple; use Fcntl ':flock'; use strict; # this is a tracker proxy that stores Referer, URL, CODE # and output them to STDOUT or the given file # # Example output: # # NULL http://www.perl.org/ 200 # http://www.perl.org/ http://learn.perl.org/ 200 # my $file = shift || '-'; open OUT, ">> $file" or die "Can't open $file: $!"; my $proxy = HTTP::Proxy->new( @ARGV ); # pass the args you want $proxy->push_filter( response => HTTP::Proxy::HeaderFilter::simple->new( sub { my ( $self, $headers, $message ) = @_; flock( OUT, LOCK_EX ); print OUT join( " ", $message->request->headers->header( 'Referer' ) || 'NULL', $message->request->uri, $message->code ), $/; flock( OUT, LOCK_UN ); } ) ); $proxy->start; END { close OUT; } HTTP-Proxy-0.304/eg/logger.pl0000755000175000017500000000600612537671053014311 0ustar bookbook#!/usr/bin/perl -w use strict; use HTTP::Proxy; use HTTP::Proxy::HeaderFilter::simple; use HTTP::Proxy::BodyFilter::simple; use CGI::Util qw( unescape ); # get the command-line parameters my %args = ( peek => [], header => [], mime => 'text/*', ); { my $args = '(' . join( '|', keys %args ) . ')'; for ( my $i = 0 ; $i < @ARGV ; $i += 2 ) { if ( $ARGV[$i] =~ /$args/o ) { if ( ref $args{$1} ) { push @{ $args{$1} }, $ARGV[ $i + 1 ]; } else { $args{$1} = $ARGV[ $i + 1 ]; } splice( @ARGV, $i, 2 ); redo if $i < @ARGV; } } } # the headers we want to see my @srv_hdr = ( qw( Content-Type Set-Cookie Set-Cookie2 WWW-Authenticate Location ), @{ $args{header} } ); my @clt_hdr = ( qw( Cookie Cookie2 Referer Referrer Authorization ), @{ $args{header} } ); # NOTE: Body request filters always receive the request body in one pass my $post_filter = HTTP::Proxy::BodyFilter::simple->new( begin => sub { $_[0]->{binary} = 0; }, filter => sub { my ( $self, $dataref, $message, $protocol, $buffer ) = @_; print STDOUT "\n", $message->method, " ", $message->uri, "\n"; print_headers( $message, @clt_hdr ); if ( $self->{binary} || $$dataref =~ /\0/ ) { $self->{binary} = 1; print STDOUT " (not printing binary data)\n"; return; } # this is from CGI.pm, method parse_params() my (@pairs) = split( /[&;]/, $$dataref ); for (@pairs) { my ( $param, $value ) = split( '=', $_, 2 ); $param = unescape($param); $value = unescape($value); printf STDOUT " %-20s => %s\n", $param, $value; } } ); my $get_filter = HTTP::Proxy::HeaderFilter::simple->new( sub { my ( $self, $headers, $message ) = @_; my $req = $message->request; if ( $req->method ne 'POST' ) { print STDOUT "\n", $req->method, " ", $req->uri, "\n"; print_headers( $req, @clt_hdr ); } print STDOUT $message->status_line, "\n"; print_headers( $message, @srv_hdr ); } ); sub print_headers { my $message = shift; for my $h (@_) { if ( $message->header($h) ) { print STDOUT " $h: $_\n" for ( $message->header($h) ); } } } # create and start the proxy my $proxy = HTTP::Proxy->new(@ARGV); # if we want to look at SOME sites if (@{$args{peek}}) { for (@{$args{peek}}) { $proxy->push_filter( host => $_, method => 'POST', request => $post_filter ); $proxy->push_filter( host => $_, response => $get_filter, mime => $args{mime}, ); } } # otherwise, peek at all sites else { $proxy->push_filter( method => 'POST', request => $post_filter ); $proxy->push_filter( response => $get_filter, mime => $args{mime} ); } $proxy->start; HTTP-Proxy-0.304/eg/rainbow.pl0000755000175000017500000000415512537671053014476 0ustar bookbook#!/usr/bin/perl -w use HTTP::Proxy qw( :log ); use HTTP::Proxy::BodyFilter::tags; use HTTP::Proxy::BodyFilter::simple; use HTTP::Proxy::BodyFilter::htmltext; use strict; my $proxy = HTTP::Proxy->new(@ARGV); $proxy->push_filter( mime => 'text/html', response => HTTP::Proxy::BodyFilter::tags->new, # protect tags response => HTTP::Proxy::BodyFilter::simple->new( # rainbow entities sub { ${ $_[1] } =~ s/(&[#\w]+;)/rainbow($1)/eg; } ), response => HTTP::Proxy::BodyFilter::htmltext->new( # rainbow text sub { s/(\S)/rainbow($1)/eg; } ) ); sub rainbow { return sprintf qq{%s}, next_color(), shift; } # the following code courtesy David 'grinder' Landgren # but adapted for our needs use constant PI_2 => 3.14159265359 * 2; my @PRIMES = qw/11 13 17 19 23 29 31 37 41 43 47 53 59/; my $red = rand() * PI_2; my $green = rand() * PI_2; my $blue = rand() * PI_2; my $rdelta = PI_2 / $PRIMES[ rand scalar @PRIMES ]; my $gdelta = PI_2 / $PRIMES[ rand scalar @PRIMES ]; my $bdelta = PI_2 / $PRIMES[ rand scalar @PRIMES ]; my ( $rp, $gp, $bp ) = ( sin $red, sin $green, sin $blue ); my ( $rq, $gq, $bq ) = qw/ 0 0 0/; my ( $rr, $gr, $br ) = qw/ 0 0 0/; $proxy->start; sub next_color { my $rs = sin( $red += $rdelta ); my $rc = $rs * 120 + 120; my $gs = sin( $green += $gdelta ); my $gc = $gs * 120 + 120; my $bs = sin( $blue += $bdelta ); my $bc = $bs * 120 + 120; $rq = $rp <=> $rs; $gq = $gp <=> $gs; $bq = $bp <=> $bs; $rp = $rs; $gp = $gs; $bp = $bs; $rdelta = PI_2 / $PRIMES[ rand scalar @PRIMES ] if ( $rr == 1 and $rq < 1 and $rs < 1 ); $gdelta = PI_2 / $PRIMES[ rand scalar @PRIMES ] if ( $gr == 1 and $gq < 1 and $gs < 1 ); $bdelta = PI_2 / $PRIMES[ rand scalar @PRIMES ] if ( $br == 1 and $bq < 1 and $bs < 1 ); $rr = $rq; $gr = $gq; $br = $bq; $rc = ( $rc < 0 ) ? 0 : ( $rc > 255 ) ? 255 : $rc; $gc = ( $gc < 0 ) ? 0 : ( $gc > 255 ) ? 255 : $gc; $bc = ( $bc < 0 ) ? 0 : ( $bc > 255 ) ? 255 : $bc; return sprintf( "#%02x%02x%02x", $rc, $gc, $bc ); } HTTP-Proxy-0.304/eg/flv.pl0000755000175000017500000000211212537671053013613 0ustar bookbook#!/usr/bin/env perl use strict; use warnings; use HTTP::Proxy; use HTTP::Proxy::BodyFilter::save; use Digest::MD5 qw( md5_hex); use POSIX qw( strftime ); my $proxy = HTTP::Proxy->new(@ARGV); # a filter to save FLV files somewhere my $flv_filter = HTTP::Proxy::BodyFilter::save->new( filename => sub { my ($message) = @_; my $uri = $message->request->uri; # get the id, or fallback to some md5 hash my ($id) = ( $uri->query || '' ) =~ /id=([^&;]+)/i; $id = md5_hex($uri) unless $id; # compute the filename (including the base site name) my ($host) = $uri->host =~ /([^.]+\.[^.]+)$/; my $file = strftime "flv/%Y-%m-%d/${host}_$id.flv", localtime; # ignore it if we already have it return if -e $file && -s $file == $message->content_length; # otherwise, save return $file; }, ); # push the filter for all MIME types we want to catch for my $mime (qw( video/flv video/x-flv )) { $proxy->push_filter( mime => $mime, response => $flv_filter, ); } $proxy->start; HTTP-Proxy-0.304/eg/https.pl0000511000175000017500000000502312537671053014160 0ustar bookbook#!/usr/bin/perl -w use HTTP::Proxy; use HTTP::Proxy::HeaderFilter::simple; use HTTP::Proxy::BodyFilter::htmlparser; use HTTP::Proxy::BodyFilter::htmltext; use HTML::Parser; use strict; # where to find URI in tag attributes # (it actually a little more complicated, since some tags can have # several attributes that require an URI) my %links = ( a => 'href', area => 'href', base => 'href', link => 'href', frame => 'src', iframe => 'src', img => 'src', input => 'src', script => 'src', form => 'action', body => 'background', ); my $re_tags = join '|', sort keys %links; my $hrefparser = HTML::Parser->new( api_version => 3 ); # turn all https:// links to http://this_is_ssl links $hrefparser->handler( start => sub { my ( $self, $tag, $attr, $attrseq, $text ) = @_; if ( $tag =~ /^($re_tags)$/o && exists $attr->{$links{$1}} && substr( $attr->{$links{$1}}, 0, 8 ) eq "https://" ) { $attr->{$links{$1}} =~ s!^https://!http://this_is_ssl.!; $text = "<$tag " . join( ' ', map { qq($_="$attr->{$_}") } @$attrseq ) . ">"; } $self->{output} .= $text; }, "self,tagname,attr,attrseq,text" ); # by default copy everything $hrefparser->handler( default => sub { my ( $self, $text ) = @_; $self->{output} .= $text; }, "self,text" ); # the proxy itself my $proxy = HTTP::Proxy->new(@ARGV); $proxy->push_filter( mime => 'text/html', response => HTTP::Proxy::BodyFilter::htmlparser->new( $hrefparser, rw => 1 ), ); # detect https requests $proxy->push_filter( request => HTTP::Proxy::HeaderFilter::simple->new( sub { my ( $self, $headers, $message ) = @_; # find out the actual https site my $uri = $message->uri; if ( $uri =~ m!^http://this_is_ssl\.! ) { $uri->scheme("https"); my $host = $uri->host; $host =~ s!^this_is_ssl\.!!; $uri->host($host); } } ), response => HTTP::Proxy::HeaderFilter::simple->new( sub { my ( $self, $headers, $message ) = @_; # modify Location: headers in the response my $location = $headers->header( 'Location' ); if( $location =~ m!^https://! ) { $location =~ s!^https://!http://this_is_ssl.!; $headers->header( Location => $location ); } } ), ); $proxy->start; HTTP-Proxy-0.304/eg/perlmonks.pl0000755000175000017500000000174512537671053015051 0ustar bookbook#!/usr/bin/perl -w use HTTP::Proxy qw( :log ); use HTTP::Proxy::HeaderFilter::simple; use strict; # a very simple proxy my $proxy = HTTP::Proxy->new(@ARGV); # this filter redirects all requests to perlmonks.org my $filter = HTTP::Proxy::HeaderFilter::simple->new( sub { my ( $self, $headers, $message ) = @_; # modify the host part of the request $self->proxy()->log( ERROR, "FOO", $message->uri() ); $message->uri()->host('perlmonks.org'); # create a new redirect response my $res = HTTP::Response->new( 301, 'Moved to perlmonks.org', [ Location => $message->uri() ] ); # and make the proxy send it back to the client $self->proxy()->response($res); } ); # put this filter on perlmonks.com and www.perlmonks.org $proxy->push_filter( host => 'perlmonks.com', request => $filter ); $proxy->push_filter( host => 'www.perlmonks.org', request => $filter ); $proxy->start(); HTTP-Proxy-0.304/eg/switch.pl0000755000175000017500000000070012537671053014326 0ustar bookbook#!/usr/bin/perl -w use HTTP::Proxy; use HTTP::Proxy::HeaderFilter::simple; # call this proxy as # eg/switch.pl proxy http://proxy1:port/,http://proxy2:port/ my %args = @ARGV; my @proxy = split/,/, $args{proxy}; my $proxy = HTTP::Proxy->new(@ARGV); $proxy->push_filter( request => HTTP::Proxy::HeaderFilter::simple->new( sub { shift->proxy->agent->proxy( http => $proxy[ rand @proxy ] ); } ) ); $proxy->start; HTTP-Proxy-0.304/eg/anonymiser.pl0000755000175000017500000000106112537671053015212 0ustar bookbook#!/usr/bin/perl -w # yeah, I know, I write UK English ;-) use HTTP::Proxy qw( :log ); use HTTP::Proxy::HeaderFilter::simple; use strict; # a very simple proxy my $proxy = HTTP::Proxy->new( @ARGV ); # the anonymising filter $proxy->push_filter( mime => undef, request => HTTP::Proxy::HeaderFilter::simple->new( sub { $_[1]->remove_header(qw( User-Agent From Referer Cookie Cookie2 )) } ), response => HTTP::Proxy::HeaderFilter::simple->new( sub { $_[1]->remove_header(qw( Set-Cookie Set-Cookie2 )) } ) ); $proxy->start; HTTP-Proxy-0.304/eg/yahoogroups.pl0000755000175000017500000000304512537671053015411 0ustar bookbook#!/usr/bin/perl -w use strict; use HTTP::Proxy qw( :log ); use HTTP::Proxy::HeaderFilter::simple; use CGI::Util qw( unescape ); my $proxy = HTTP::Proxy->new(@ARGV); $proxy->push_filter( host => 'groups.yahoo.com', response => HTTP::Proxy::HeaderFilter::simple->new( sub { my ( $self, $headers, $message ) = @_; my $location; # ads start by redirecting to 'interrupt' return unless ( $location = $headers->header('Location') ) && $location =~ m!/interrupt\?!; # fetch the ad page (we need the cookie) # use a new request to avoid modifying the original one $self->proxy->log( FILTERS, "YAHOOGROUPS", "Ad interrupt detected: fetching $location" ); my $r = $self->proxy->agent->simple_request( HTTP::Request->new( GET => $location, $message->request->headers # headers are cloned ) ); # redirect to our original destination # which was stored in the 'done' parameter # and pass the cookie along $location = unescape($location); $location =~ s|^(http://[^/]*).*done=([^&]*).*$|$1$2|; $headers->header( Location => $location ); $headers->header( Set_Cookie => $r->header('Set_Cookie') ); $self->proxy->log( FILTERS, "YAHOOGROUPS", "Set-Cookie: " . $r->header('Set_Cookie') ); } ) ); $proxy->start; HTTP-Proxy-0.304/eg/pdf.pl0000755000175000017500000000266012537671053013605 0ustar bookbook#!/usr/bin/perl # # Saves all PDF files, and just confirm saving to the client # (the PDF file never arrives to the client, but is replaced by # a simple HTML file) # # Based on a request by Emmanuel Di Prétoro # use strict; use warnings; use HTTP::Proxy qw ( :log ); use HTTP::Proxy::BodyFilter::save; use HTTP::Proxy::BodyFilter::simple; use HTTP::Proxy::HeaderFilter::simple; my $proxy = HTTP::Proxy->new( @ARGV ); my $saved; $proxy->push_filter( # you should probably restrict this to certain hosts as well path => qr/\.pdf$/, mime => 'application/pdf', # save the PDF response => HTTP::Proxy::BodyFilter::save->new( template => "%f", prefix => 'pdf' ), # send a HTML message instead response => HTTP::Proxy::BodyFilter::simple->new( begin => sub { my ( $self, $message ) = @_; # for information, saorge $saved = 0; }, filter => sub { my ( $self, $dataref, $message, $protocol, $buffer ) = @_; $$dataref = $saved++ ? "" : sprintf '

Saving PDF file. Go back

', $message->request->header('referer'); } ), # change the response Content-Type response => HTTP::Proxy::HeaderFilter::simple->new( sub { my ( $self, $headers, $response ) = @_; $headers->content_type('text/html'); } ), ); $proxy->start; HTTP-Proxy-0.304/eg/trim.pl0000755000175000017500000000105012537671053013777 0ustar bookbook#!/usr/bin/perl -w use HTTP::Proxy qw( :log ); use HTTP::Proxy::BodyFilter::lines; use HTTP::Proxy::BodyFilter::simple; use strict; my $proxy = HTTP::Proxy->new(@ARGV); # a simple proxy that trims whitespace in HTML $proxy->push_filter( mime => 'text/html', response => HTTP::Proxy::BodyFilter::lines->new(), response => HTTP::Proxy::BodyFilter::simple->new( sub { my ($self, $dataref ) = @_; $$dataref =~ s/^\s+//m; # multi-line data $$dataref =~ s/\s+$//m; } ) ); $proxy->start; HTTP-Proxy-0.304/eg/javascript.pl0000755000175000017500000000164512537671053015204 0ustar bookbook#!/usr/bin/perl -w use HTTP::Proxy; use HTML::Parser; use HTTP::Proxy::BodyFilter::htmlparser; # define the filter (the most difficult part) # filters not using HTML::Parser are much simpler :-) my $parser = HTML::Parser->new( api_version => 3 ); $parser->handler( start => sub { my ( $self, $tag, $text ) = @_; $self->{output} .= $text; $self->{output} .= "YOUR JAVASCRIPT HERE" if $tag eq 'body'; }, "self,tagname,text" ); $parser->handler( default => sub { my ($self, $text) = @_; $self->{output} .= $text; }, "self,text" ); # this is a read-write filter (rw => 1) # that is the reason why we had to copy everything into $self->{output} my $filter = HTTP::Proxy::BodyFilter::htmlparser->new( $parser, rw => 1 ); # create and launch the proxy my $proxy = HTTP::Proxy->new(@ARGV); $proxy->push_filter( response => $filter, mime => 'text/html' ); $proxy->start(); HTTP-Proxy-0.304/eg/fudd.pl0000755000175000017500000000066312537671053013757 0ustar bookbook#!/usr/bin/perl -w # based on Google's Elmer Fudd preference setting use HTTP::Proxy; use HTTP::Proxy::BodyFilter::tags; use HTTP::Proxy::BodyFilter::htmltext; use strict; my $proxy = HTTP::Proxy->new(@ARGV); $proxy->push_filter( mime => 'text/html', response => HTTP::Proxy::BodyFilter::tags->new, response => HTTP::Proxy::BodyFilter::htmltext->new( sub { y/r/w/; s/l(?=\w)/w/g } ) ); $proxy->start; HTTP-Proxy-0.304/eg/README0000644000175000017500000001001512537671053013345 0ustar bookbookThe eg/ directory holds a few example proxies. All scripts accept HTTP::Proxy constructor key/value pairs on the command-line. Example: ./proxy.pl port 3128 host 0.0.0.0 * proxy.pl A very simple proxy. Filter: none * anonymiser.pl A simple anonymizing proxy, similar in functionnality to the one shown by Randal L. Schwartz in his WebTechniques #11 column. http://www.stonehenge.com/merlyn/WebTechniques/col11.html Filter: HTTP::Proxy::HeaderFilter::simple * proxy-auth.pl A very simple proxy, with Basic authentication. Filter: HTTP::Proxy::HeaderFilter::simple * leet.pl * rot13.pl * rainbow.pl * fudd.pl These filters do simple modifications of all HTML pages. Filters: HTTP::Proxy::BodyFilter::tags HTTP::Proxy::BodyFilter::simple HTTP::Proxy::BodyFilter::htmltext * bork.pl This ffiltir elsu duis simpli mudiffixeshuns uff ell HTML pegis. Bork bork bork ! * outline.pl * ayb.pl These proxy do more complicated modifications of HTML pages, and require a HTML::Parser object to do so. All you tag are belong to us. Filter: HTTP::Proxy::BodyFilter::htmlparser * post.pl This filter outputs the request URI and the form parameters of all POST requests. Filter: HTTP::Proxy::HeaderFilter::simple * logger.pl This filter outputs the important information out of GET and POST requests: method, URI, cookies, content-type (text/*) and POST request parameters. Filter: HTTP::Proxy::HeaderFilter::simple * adblock.pl This is a very simple proxy that block ad sites. Filters: HTTP::Proxy::HeaderFilter::simple HTTP::Proxy::BodyFilter::simple * trim.pl A simple proxy that trims lines of HTML text. Filters: HTTP::Proxy::BodyFilter::lines HTTP::Proxy::BodyFilter::simple * javascript.pl A proxy that adds anything/javascript at the beginning of a HTML page. (right after the tag) Filter: HTTP::Proxy::BodyFilter::htmlparser * rfc.pl A proxy that automatically saves the files named rfc\d+\.txt to a file of the same name in the rfc/ directory. Filter: HTTP::Proxy::BodyFilter::save * dragon.pl A proxy that removes some of the shortcomings of the Dragon Go Server website (http://www.dragongoserver.net/) Filters: HTTP::Proxy::HeaderFilter::simple HTTP::Proxy::BodyFilter::simple HTTP::Proxy::BodyFilter::tags * pdf.pl Save all PDF files in the pdf/ directory, and replace it with a HTML message saying "PDF file saved." Filters: HTTP::Proxy::HeaderFilter::simple HTTP::Proxy::Body::simple HTTP::Proxy::Body::save * yahoogroups.pl Removes the advertisment interruptions from Yahoo! Groups Filter: HTTP::Proxy::HeaderFilter::simple * https.pl Modify https:// links to http:// links that the proxy will recognise. The proxy will download the pages using SSL and will then be able to modify them with its filter stacks. Filters: HTTP::Proxy::HeaderFilter::simple HTTP::Proxy::BodyFilter::htmlparser * perlmonks.pl Redirect all requests to perlmonks.com and perlmonks.org to perlmonks.org, thus keeping connection information intact (all cookies will point to a single web site). This code was used as a starting point for the "Rewrite the web" hack in Perl Hacks (O'Reilly 2006). Filter: HTTP::Proxy::HeaderFilter::simple * switch.pl Randomly switch proxies from a list given on the command line. Filter: HTTP::Proxy::HeaderFilter::simple * tracker.pl This tracker proxy stores Referer, URL, CODE and output them to STDOUT or the given file Example output: NULL http://www.perl.org/ 200 http://www.perl.org/ http://learn.perl.org/ 200 Filter: HTTP::Proxy::HeaderFilter::simple * js.pl Save JavaScript files as we browse them. Filter: HTTP::Proxy::Body::save * flv.pl Saves all FLV files in the flv/ directory, with a computed name (id taken from the URI, or MD5 hash of the URI). Filter: HTTP::Proxy::Body::save HTTP-Proxy-0.304/eg/bork.pl0000755000175000017500000000425612537671053013774 0ustar bookbook#!/usr/bin/perl -w # script kindly offered by glb (Eric Cassagnard) use HTTP::Proxy qw( :log ); use HTTP::Proxy::BodyFilter::tags; use HTTP::Proxy::BodyFilter::simple; use HTTP::Proxy::BodyFilter::htmltext; use strict; my $proxy = HTTP::Proxy->new(@ARGV); my %noaccent = ( Agrave => 'A', Aacute => 'A', Acirc => 'A', Atilde => 'A', Auml => 'A', Aring => 'A', AElig => 'AE', Ccedil => 'C', Egrave => 'E', Eacute => 'E', Ecirc => 'E', Euml => 'E', Igrave => 'I', Iacute => 'I', Icirc => 'I', Iuml => 'I', Ntilde => 'N', Ograve => 'O', Oacute => 'O', Ocirc => 'O', Otile => 'O', Ouml => 'O', Oslash => 'O', Ugrave => 'U', Uacute => 'U', Ucirc => 'U', Uuml => 'U', Yacute => 'Y', agrave => 'a', aacute => 'a', acirc => 'a', atilde => 'a', auml => 'a', aring => 'a', aelig => 'ae', ccedil => 'c', egrave => 'e', eacute => 'e', ecirc => 'e', euml => 'e', igrave => 'i', iacute => 'i', icirc => 'i', iuml => 'i', ntilde => 'n', ograve => 'o', oacute => 'o', ocirc => 'o', otile => 'o', ouml => 'o', oslash => 'o', ugrave => 'u', uacute => 'u', ucirc => 'u', uuml => 'u', yacute => 'y', 'yuml' => 'y', 'Æ' => 'AE', 'æ' => 'ae', ); my $re = join '|', sort keys %noaccent; my %sounds = ( an => 'un', An => 'Un', au => 'oo', Au => 'Oo', a => 'e', A => 'E', ew => 'oo', e => 'e-a', e => 'i', E => 'I', f => 'ff', ir => 'ur', ow => 'oo', o => 'oo', O => 'Oo', o => 'u', the => 'zee', The => 'Zee', th => 't', tion => 'shun', u => 'oo', U => 'Oo', v => 'f', V => 'F', w => 'v', W => 'V' ); my $sc = join '|', sort keys %sounds; $proxy->push_filter( mime => 'text/html', response => HTTP::Proxy::BodyFilter::tags->new, response => HTTP::Proxy::BodyFilter::simple->new( sub { ${ $_[ 1 ] } =~ s/&($re);/$noaccent{$1}/go; } ), response => HTTP::Proxy::BodyFilter::htmltext->new( sub { tr{ÀÁÂÃÄÅÇÈÉÊËÌÍÎÏÑÒÓÔÕÖØÙÚÛÜÝàáâãäåçèéêëìíîïñòóôõöøùúûüýÿ} {AAAAAACEEEEIIIINOOOOOOUUUUYaaaaaaceeeeiiiinoooooouuuuyy}; s/($sc)/$sounds{$1}/go; s/([?!]+)/$1 Bork bork bork !/go ; s/(\.+)(\s|$)/$1 Bork bork bork ! /go ; } ) ); $proxy->start; HTTP-Proxy-0.304/eg/post.pl0000755000175000017500000000152412537671053014017 0ustar bookbook#!/usr/bin/perl -w use strict; use HTTP::Proxy qw( :log ); use HTTP::Proxy::BodyFilter::simple; use CGI::Util qw( unescape ); # NOTE: Body request filters always receive the request body in one pass my $filter = HTTP::Proxy::BodyFilter::simple->new( sub { my ( $self, $dataref, $message, $protocol, $buffer ) = @_; print STDOUT $message->method, " ", $message->uri, "\n"; # this is from CGI.pm, method parse_params my (@pairs) = split ( /[&;]/, $$dataref ); for (@pairs) { my ( $param, $value ) = split ( '=', $_, 2 ); $param = unescape($param); $value = unescape($value); printf STDOUT " %-30s => %s\n", $param, $value; } } ); my $proxy = HTTP::Proxy->new(@ARGV); $proxy->push_filter( method => 'POST', request => $filter ); $proxy->start; HTTP-Proxy-0.304/eg/rfc.pl0000755000175000017500000000057312537671053013607 0ustar bookbookuse HTTP::Proxy; use HTTP::Proxy::BodyFilter::save; my $proxy = HTTP::Proxy->new(@ARGV); # save RFC files as we browse them $proxy->push_filter( path => qr!/rfc\d+.txt!, mime => 'text/plain', response => HTTP::Proxy::BodyFilter::save->new( template => '%f', prefix => 'rfc', multiple => 0, keep_old => 1, ) ); $proxy->start; HTTP-Proxy-0.304/eg/ayb.pl0000755000175000017500000000353112537671053013605 0ustar bookbook#!/usr/bin/perl -w use HTTP::Proxy qw( :log ); use HTTP::Proxy::BodyFilter::htmlparser; use HTML::Parser; use strict; # the proxy my $proxy = HTTP::Proxy->new( @ARGV ); # all your base... my @ayb = grep { !/^$/ } split/$/m, << 'AYB'; In A.D. 2101 War was beginning. What happen ? Somebody set up us the bomb. We get signal. What ! Main screen turn on. It's You !! How are you gentlemen !! All your base are belong to us. You are on the way to destruction. What you say !! You have no chance to survive make your time. HA HA HA HA .... Take off every 'zig' !! You know what you doing. Move 'zig'. For great justice. AYB # the AYB parser # replaces heading content with the AYB text my $parser = HTML::Parser->new( api_version => 3 ); $parser->handler( start_document => sub { my $self = shift; $self->{ayb} = 0; $self->{i} = int rand @ayb; }, "self" ); $parser->handler( start => sub { my ( $self, $tag, $attr, $text ) = @_; $self->{ayb} = 1 if $tag =~ /^h\d/; if( $tag eq 'img' ) { $attr->{src} = 'http://home.uchicago.edu/~obmontoy/cats.jpg'; $text = "<$tag " . join(' ', map { qq($_="$attr->{$_}") } keys %$attr ) . ">"; } $self->{output} .= $text; }, "self,tagname,attr,text" ); $parser->handler( end => sub { my ( $self, $tag, $text ) = @_; if( $tag =~ /^h\d/ ) { $self->{ayb} = 0; } $self->{output} .= $text; }, "self,tagname,text" ); $parser->handler( default => sub { my ( $self, $text ) = @_; $self->{output} .= $self->{ayb} ? $ayb[($self->{i} += 1 ) %= @ayb] : $text; }, "self,text" ); $proxy->push_filter( mime => 'text/html', response => HTTP::Proxy::BodyFilter::htmlparser->new( $parser, rw => 1 ), ); $proxy->start; HTTP-Proxy-0.304/t/0000755000175000017500000000000012537671053012340 5ustar bookbookHTTP-Proxy-0.304/t/61simple2.t0000644000175000017500000000363212537671053014253 0ustar bookbookuse Test::More tests => 4; use strict; use HTTP::Proxy; use HTTP::Proxy::BodyFilter::simple; use t::Utils; # test configuration my $test = Test::Builder->new; $test->use_numbers(0); $test->no_ending(1); # create the filter my $sub = sub { my ( $self, $dataref, $message, $protocol, $buffer ) = @_; $$dataref =~ s/test/foo/g; }; my $filter = HTTP::Proxy::BodyFilter::simple->new($sub); # create the proxy my $proxy = HTTP::Proxy->new( port => 0, max_clients => 0, max_keep_alive_requests => 1, max_connections => 1, ); $proxy->init; $proxy->agent->protocols_allowed(undef); $proxy->push_filter( response => $filter, scheme => 'file', mime => 'text/*' ); my $url = $proxy->url; # fork the proxy my @pids; { $^W = 0; # warning due to the absence of a host in the file URL push @pids, fork_proxy($proxy); } # check that the correct transformation is applied my $ua = LWP::UserAgent->new(); $ua->proxy( file => $url ); my $response = $ua->request( HTTP::Request->new( GET => 'file:t/test.html' ) ); my $file; { local $/ = undef; open F, "t/test.html" or diag "Unable to open t/test.html"; $file = ; close F; } $file =~ s/test/foo/g; is( $response->content, $file, "The proxy applied the transformation" ); # push another filter $sub = sub { my ( $self, $dataref, $message, $protocol, $buffer ) = @_; $$dataref =~ s/Test/Bar/g; }; $filter = HTTP::Proxy::BodyFilter::simple->new( filter => $sub, begin => sub { ok( 1, "begin() called" ) }, end => sub { ok( 1, "end() called" ) }, ); $proxy->push_filter( response => $filter, scheme => 'file', mime => 'text/*' ); # fork the modified proxy push @pids, fork_proxy($proxy); $response = $ua->request( HTTP::Request->new( GET => 'file:t/test.html' ) ); $file =~ s/Test/Bar/g; is( $response->content, $file, "The proxy applied two transformations" ); # wait for kids wait for @pids; HTTP-Proxy-0.304/t/90httpstatus.t0000644000175000017500000000262712537671053015130 0ustar bookbook# good place for web client tests: # http://diveintomark.org/tests/client/http/ use strict; my @url; my $tests; BEGIN { @url = ( map ( [ "$_" => 0 + $_ ], 200 .. 206, 300, 304, 306 ), map ( [ "$_" => 0 + $_, 200 ], 301 .. 303, 305, 307 ), map ( [ "$_" => 0 + $_ ], 400 .. 418, 500 .. 505 ), ); $tests += @$_ - 1 for @url; } use Test::More; use HTTP::Proxy; use HTTP::Request::Common; use t::Utils; my $base = 'http://httpstat.us'; plan tests => $tests; SKIP: { skip "$base is not available", $tests unless web_ok($base); # $tests + 2, because of the duplicate 401 my $proxy = HTTP::Proxy->new( port => 0, max_keep_alive_requests => $tests, max_connections => 1, ); $proxy->init; my $ua = LWP::UserAgent->new( keep_alive => 1 ); $ua->proxy( http => $proxy->url ); # fork the proxy my $pid = fork_proxy($proxy); # check all those pages for (@url) { my ( $doc, $status, $status2 ) = @$_; my $res = $ua->simple_request( GET "$base/$doc" ); is( $res->code, $status, "$doc => $status " . $res->message ); # redirection if ( $res->is_redirect && $status2 ) { $res = $ua->simple_request( GET $res->header('Location') ); is( $res->code, $status2, "$doc => $status2 (redirect)" ); } } # wait for the proxy wait; } HTTP-Proxy-0.304/t/67save.t0000644000175000017500000001473012537671053013645 0ustar bookbookuse strict; use warnings; use Test::More; use HTTP::Proxy::BodyFilter::save; use File::Temp qw( tempdir ); use File::Spec::Functions; # a sandbox to play in my $dir = tempdir( CLEANUP => 1 ); my @errors = ( [ [ keep_old => 1, timestamp => 1 ] => qr/^Can't timestamp and keep older files at the same time/ ], [ [ status => 200 ] => qr/^status must be an array reference/ ], [ [ status => [qw(200 007 )] ] => qr/status must contain only HTTP codes/ ], [ [ filename => 'zlonk' ] => qr/^filename must be a code reference/ ], ); my @data = ( 'recusandae veritatis illum quos tempor aut quidem', 'necessitatibus lorem aperiam facere consequuntur incididunt similique' ); my @d = ( prefix => $dir ); # defaults my @templates = ( # args, URL => filename [ [@d], 'http://bam.fr/zok/awk.html' => catfile( $dir, qw(bam.fr zok awk.html) ) ], [ [ @d, multiple => 0 ], 'http://bam.fr/zok/awk.html' => catfile( $dir, qw(bam.fr zok awk.html) ) ], [ [@d], 'http://bam.fr/zok/awk.html' => catfile( $dir, qw(bam.fr zok awk.html.1) ) ], [ [ @d, no_host => 1 ], 'http://bam.fr/zok/awk.html' => catfile( $dir, qw(zok awk.html ) ) ], [ [ @d, no_dirs => 1 ], 'http://bam.fr/zok/awk.html' => catfile( $dir, qw(bam.fr awk.html) ) ], [ [ @d, no_host => 1, no_dirs => 1 ], 'http://bam.fr/zok/awk.html' => catfile( $dir, 'awk.html' ) ], [ [ @d, no_dirs => 1 ], 'http://bam.fr/zok/' => catfile( $dir, qw(bam.fr index.html) ) ], #[ [@d], 'http://bam.fr/zok/' => "$dir/bam.fr/index.html" ], [ [ template => "$dir/%p" ], 'http://bam.fr/pow/zok.html' => catfile( $dir, qw(pow zok.html) ) ], [ [ template => "$dir/%f" ], 'http://bam.fr/pow/zok.html' => catfile( $dir, 'zok.html' ) ], [ [ template => "$dir/%p" ], 'http://bam.fr/zam.html?q=pow' => catfile( $dir, 'zam.html' ) ], # Win32 does not accept '?' in file names ( [ [ template => "$dir/%P" ], 'http://bam.fr/zam.html?q=pow' => catfile( $dir, 'zam.html?q=pow' ) ] ) x ( $^O ne 'MSWin32' ), [ [ @d, cut_dirs => 2 ], 'http://bam.fr/a/b/c/d/e.html' => catfile( $dir, qw(bam.fr c d e.html) ) ], [ [ @d, cut_dirs => 2, no_host => 1 ], 'http://bam.fr/a/b/c/d/e.html' => catfile( $dir, qw(c d e.html) ) ], [ [ @d, cut_dirs => 5, no_host => 1 ], 'http://bam.fr/a/b/c/d/e.html' => catfile( $dir, 'e.html' ) ], # won't save [ [ @d, keep_old => 1 ], 'http://bam.fr/zok/awk.html' => undef ], ); my @responses = ( [ [@d], 'http://bam.fr/a.html' => 200, catfile( $dir, qw(bam.fr a.html) ) ], [ [@d], 'http://bam.fr/b.html' => 404, undef ], [ [ @d, status => [ 200, 404 ] ], 'http://bam.fr/c.html' => 404, catfile( $dir, qw(bam.fr c.html) ) ], ); plan tests => 2 * @errors # error checking + 1 # simple test + 7 * 2 # filename tests: 2 that save + 5 * 2 # filename tests: 2 that don't + 2 * @templates # all template tests + 2 * @responses # all responses tests ; # some variables my $proxy = HTTP::Proxy->new( port => 0 ); my ( $filter, $data, $file, $buffer ); # test the save filter # 1) errors in new for my $t (@errors) { my ( $args, $regex ) = @$t; ok( !eval { HTTP::Proxy::BodyFilter::save->new(@$args); 1; }, "new( @$args ) fails" ); like( $@, $regex, "Error matches $regex" ); } # 2) code for filenames $filter = HTTP::Proxy::BodyFilter::save->new( filename => sub {$file} ); $filter->proxy($proxy); # simple check ok( !$filter->will_modify, 'Filter does not modify content' ); # loop on four requests # two that save, and two that won't for my $name ( qw( zlonk.pod kayo.html ), undef, '' ) { $file = $name ? catfile( $dir, $name ) : $name; my $req = HTTP::Request->new( GET => 'http://www.example.com/' ); ok( my $ok = eval { $filter->begin($req); 1; }, 'Initialized filter without error' ); diag $@ if !$ok; if ($file) { is( $filter->{_hpbf_save_filename}, $file, "Got filename ($file)" ); } else { ok( !$filter->{_hpbf_save_filename}, 'No filename' ); } my $filter_fh; if ($name) { ok( $filter->{_hpbf_save_fh}->opened, 'Filehandle opened' ); $filter_fh = $filter->{_hpbf_save_fh}; } else { ok( !exists $filter->{_hpbf_save_fh}, 'No filehandle' ); } # add some data $buffer = ''; ok( eval { $filter->filter( \$data[0], $req, '', \$buffer ); $filter->filter( \$data[1], $req, '', undef ); $filter->end(); 1; }, 'Filtered data without error' ); diag $@ if $@; # file closed now ok( !defined $filter->{_hpbf_save_fh}, 'No filehandle' ); if ($filter_fh) { ok( !$filter_fh->opened, 'Filehandle closed' ); # check the data open my $fh, $file or diag "Can't open $file: $!"; is( join( '', <$fh> ), join( '', @data ), 'All data saved' ); close $fh; } } # 3) the multiple templating cases for my $t (@templates) { my ( $args, $url, $filename ) = @$t; my $filter = HTTP::Proxy::BodyFilter::save->new(@$args); $filter->proxy($proxy); my $req = HTTP::Request->new( GET => $url ); # filter initialisation ok( my $ok = eval { $filter->begin($req); 1; }, 'Initialized filter without error' ); diag $@ if !$ok; my $mesg = defined $filename ? "$url => $filename" : "Won't save $url"; is( $filter->{_hpbf_save_filename}, $filename, $mesg ); } # 4) some cases that depend on the response for my $t (@responses) { my ( $args, $url, $status, $filename ) = @$t; my $filter = HTTP::Proxy::BodyFilter::save->new(@$args); $filter->proxy($proxy); my $res = HTTP::Response->new($status); $res->request( HTTP::Request->new( GET => $url ) ); ok( my $ok = eval { $filter->begin($res); 1; }, 'Initialized filter without error' ); diag $@ if !$ok; if ($filename) { is( $filter->{_hpbf_save_filename}, $filename, "$url ($status) => $filename" ); } else { ok( !$filter->{_hpbf_save_filename}, "$url ($status) => No filename" ); } } HTTP-Proxy-0.304/t/test.html0000644000175000017500000000050212537671053014202 0ustar bookbook This is an HTML test file

Test title

Test sub-title

This is a test paragraph, with bold and emphasised text.


Another test

   # some source code
   $a++
  

HTTP-Proxy-0.304/t/51simple.t0000644000175000017500000000155012537671053014165 0ustar bookbookuse Test::More tests => 3; use strict; use HTTP::Proxy::HeaderFilter::simple; use HTTP::Headers; my ( $filter, $sub, $h ); # error checking eval { $filter = HTTP::Proxy::HeaderFilter::simple->new() }; like( $@, qr/^Constructor called without argument/, "Need at least one arg" ); eval { $filter = HTTP::Proxy::HeaderFilter::simple->new('foo') }; like( $@, qr/^Single parameter must be a CODE /, "Must pass a coderef" ); $sub = sub { my ( $self, $headers, $message ) = @_; $headers->header( User_Agent => 'Foo/1.0' ); }; $filter = HTTP::Proxy::HeaderFilter::simple->new($sub); # test the filter $h = HTTP::Headers->new( Date => 'Thu, 03 Feb 1994 00:00:00 GMT', Content_Type => 'text/html; version=3.2', Content_Base => 'http://www.perl.org/' ); $filter->filter( $h, undef ); is( $h->header('User-Agent'), 'Foo/1.0', "Header modified" ); HTTP-Proxy-0.304/t/11log.t0000644000175000017500000000215112537671053013447 0ustar bookbookuse Test::More; use HTTP::Proxy qw(:log); use strict; my %mask = ( CONNECT => CONNECT, DATA => DATA, ENGINE => ENGINE, ERROR => ERROR, FILTERS => FILTERS, HEADERS => HEADERS, PROCESS => PROCESS, PROXY => PROXY, SOCKET => SOCKET, STATUS => STATUS, ); # try all combinations my @tests = ( [ NONE, qw( ERROR ) ], [ PROXY, qw( ERROR PROXY ) ], [ STATUS | SOCKET, qw( ERROR SOCKET STATUS ) ], [ DATA | STATUS | SOCKET, qw( DATA ERROR SOCKET STATUS ) ], [ ALL, qw( CONNECT DATA ENGINE ERROR FILTERS HEADERS PROCESS PROXY SOCKET STATUS ) ], ); my $t; $t += @$_ - 1 for @tests; plan tests => $t; # communicate with a pipe pipe my ( $rh, $wh ); select( ( select($wh), $| = 1 )[0] ); # the proxy logs error to the pipe my $proxy = HTTP::Proxy->new( logfh => $wh ); for (@tests) { my ( $mask, @msgs ) = @$_; $proxy->logmask($mask); $proxy->log( $mask{$_}, 'TEST', $_ ) for sort keys %mask; like( <$rh>, qr/TEST: $_$/, "mask $mask: $_ message" ) for @msgs; } close $wh; print for <$rh>; HTTP-Proxy-0.304/t/22http.t0000644000175000017500000000374012537671053013654 0ustar bookbookuse strict; use vars qw( @requests ); use Socket; # here are all the requests the client will try BEGIN { @requests = ( # host, expected code, shouldn't resolve [ 'http://www.mongueurs.net/', 200 ], [ 'http://httpd.apache.org/docs', 301 ], [ 'http://www.google.com/testing/', 404 ], [ 'http://www.error.zzz/', '5..', 1 ], ); } use Test::More tests => @requests + 1; use t::Utils; use LWP::UserAgent; use HTTP::Proxy; # we skip the tests if the network is not available SKIP: { skip "Web does not seem to work", @requests + 1 unless web_ok(); my $test = Test::Builder->new; # this is to work around tests in forked processes $test->use_numbers(0); $test->no_ending(1); my $proxy = HTTP::Proxy->new( port => 0, max_connections => scalar @requests, ); $proxy->init; # required to access the url later # fork a HTTP proxy my $pid = fork_proxy( $proxy, sub { ok( $proxy->conn == @requests, "Served the correct number of requests" ); } ); # run a client my $ua = LWP::UserAgent->new; $ua->proxy( http => $proxy->url ); for (@requests) { my ( $uri, $code, $dns_fail ) = @$_; $uri = URI->new($uri); $dns_fail &&= defined +( gethostbyname $uri->host )[4]; SKIP: { if ($dns_fail) { # contact the proxy anyway $ua->simple_request( HTTP::Request->new( GET => 'http://localhost/' ) ); skip "Our DNS shouldn't resolve " . $uri->host, 1; } else { # the real test my $req = HTTP::Request->new( GET => $uri ); my $rep = $ua->simple_request($req); like( $rep->code, qr/^$code$/, "Got an answer (@{[$rep->code]})" ); } } } # make sure the kid is dead wait; } HTTP-Proxy-0.304/t/40push_filters.t0000644000175000017500000000363312537671053015405 0ustar bookbookuse strict; use Test::More tests => 11; use HTTP::Proxy; use HTTP::Proxy::BodyFilter; use HTTP::Proxy::HeaderFilter; # test the basic filter methods my $proxy = HTTP::Proxy->new( port => 0 ); # test the errors eval { $proxy->push_filter( 1 ); }; like( $@, qr/^Odd number of arguments/, "Bad number of parameter" ); eval { $proxy->push_filter( response => 1 ); }; like( $@, qr/^Not a Filter reference for filter queue/, "Bad parameter" ); eval { $proxy->push_filter( typo => sub { } ); }; like( $@, qr/^'typo' is not a filter stack/, "Unknown filter stack" ); eval { $proxy->push_filter( mime => 'text', response => sub { } ); }; like( $@, qr/^Invalid MIME/, "Bad MIME type" ); eval { $proxy->push_filter( method => 'FOO', response => sub { } ); }; like( $@, qr/^Invalid method: FOO/, "Invalid method: " ); eval { $proxy->push_filter( scheme => 'rstp', response => sub { } ); }; like( $@, qr/^Unsupported scheme/, "Unsupported scheme" ); # test correct working my $filter = HTTP::Proxy::HeaderFilter->new; eval { $proxy->push_filter( response => $filter ); }; is( $@, '', "Accept a HeaderFilter"); { package Foo; use base qw( HTTP::Proxy::HeaderFilter ); } $filter = Foo->new; eval { $proxy->push_filter( response => $filter ); }; is( $@, '', "Accept an object derived from HeaderFilter"); # test multiple match criteria eval { $proxy->push_filter( response => $filter, mime => 'text/*', scheme => 'http', method => 'GET' ); }; is( $@, "", "Support several match criteria" ); # test pushing multiple filters at once # this test breaks encapsulation $proxy = HTTP::Proxy->new( port => 0 ); $filter = HTTP::Proxy::BodyFilter->new; my $filter2 = HTTP::Proxy::BodyFilter->new; $proxy->push_filter( response => $filter, response => $filter2 ); is( $proxy->{body}{response}{filters}[0][1], $filter, "First filter"); is( $proxy->{body}{response}{filters}[1][1], $filter2, "Second filter"); HTTP-Proxy-0.304/t/Utils.pm0000644000175000017500000000645212537671053014005 0ustar bookbookpackage t::Utils; use strict; use Exporter (); use IO::Socket::INET; use vars qw( @ISA @EXPORT @EXPORT_OK ); @ISA = qw( Exporter ); @EXPORT = qw( &server_start &server_next &fork_proxy &web_ok &bare_request ); @EXPORT_OK = @EXPORT; use HTTP::Daemon; use LWP::UserAgent; # start a simple server sub server_start { # create a HTTP::Daemon (on an available port) my $daemon = HTTP::Daemon->new( LocalHost => 'localhost', ReuseAddr => 1, ) or die "Unable to start web server"; return $daemon; } # This must NOT be called in an OO fashion but this way: # server_next( $server, $coderef, ... ); # # The optional coderef takes a HTTP::Request as its first argument # and returns a HTTP::Response. The rest of server_next() arguments # are passed to &$anwser; sub server_next { my $daemon = shift; my $answer = shift; # get connection data my $conn = $daemon->accept; my $req = $conn->get_request; # compute some answer my $rep; if ( ref $answer eq 'CODE' ) { $rep = $answer->( $req, @_ ); } else { $rep = HTTP::Response->new( 200, 'OK', HTTP::Headers->new( 'Content-Type' => 'text/plain' ), sprintf( "You asked for %s", ( $req->uri ) x 2 ) ); } $conn->send_response($rep); $conn->close; } # run a stand-alone proxy # the proxy accepts an optional coderef to run after serving all requests sub fork_proxy { my $proxy = shift; my $sub = shift; my $pid = fork; die "Unable to fork proxy" if not defined $pid; if ( $pid == 0 ) { $0 .= " (proxy)"; # this is the http proxy $proxy->start; $sub->() if ( defined $sub and ref $sub eq 'CODE' ); exit 0; } # back to the parent return $pid; } # check that the web connection is working sub web_ok { my $ua = LWP::UserAgent->new( env_proxy => 1, timeout => 30 ); my $res = $ua->request( HTTP::Request->new( GET => shift||'http://www.google.com/intl/en/' ) ); return $res->is_success; } # send a simple request without LWP::UA # bare_request($url, $headers, $proxy) sub bare_request { my ($url, $headers, $proxy) = @_; # connect directly to the proxy $proxy->url() =~ /:(\d+)/; my $sock = IO::Socket::INET->new( PeerAddr => 'localhost', PeerPort => $1, Proto => 'tcp' ) or do { warn "Can't connect to the proxy"; return ""; }; # send the request print $sock "GET $url HTTP/1.0\015\012", $headers->as_string( "\015\012" ), "\015\012"; my $content = join "", <$sock>; # close the connection to the proxy close $sock or warn "close: $!"; return $content; } package HTTP::Proxy; # return the requested internal filter stack # _filter_stack( body|header, request|response, HTTP::Message ) sub _filter_stack { my ( $self, $part, $mesg ) = splice( @_, 0, 3 ); die "No <$part><$mesg> filter stack" unless $part =~ /^(?:header|body)$/ and $mesg =~ /^(?:request|response)$/; for (@_) { die "$_ is not a HTTP::Request or HTTP::Response" unless ( ref $_ ) =~ /^HTTP::(Request|Response)$/; $self->{ lc $1 } = $_; } $self->{response}->request( $self->{request} ); return $self->{$part}{$mesg}; } HTTP-Proxy-0.304/t/23https.t0000644000175000017500000000457312537671053014045 0ustar bookbookuse Test::More skip_all => "Can't make this work with Crypt::SSLeay"; use strict; use t::Utils; use HTTP::Proxy; use LWP::UserAgent; # test CONNECT my $test = Test::Builder->new; # this is to work around tests in forked processes $test->use_numbers(0); $test->no_ending(1); SKIP: { eval "require Crypt::SSLeay;" skip "Crypt::SSLeay not installed", 1 if $@; my $proxy = HTTP::Proxy->new( port => 0, maxconn => 1, logmask => 63 ); # Excerpts from the Crypt::SSLeay documentation # --------------------------------------------- # LWP::UserAgent and Crypt::SSLeay have their own versions of proxy support. # # At the time of this writing, libwww v5.6 seems to proxy https requests # fine with an Apache mod_proxy server. It sends a line like: # # GET https://www.nodeworks.com HTTP/1.1 # # to the proxy server, which is not the CONNECT request that some # proxies would expect, so this may not work with other proxy servers # than mod_proxy. The CONNECT method is used by Crypt::SSLeay's internal # proxy support. # # For native Crypt::SSLeay proxy support of https requests, you need to # set an environment variable HTTPS_PROXY to your proxy server & port, as in: # # # PROXY SUPPORT # $ENV{HTTPS_PROXY} = 'http://proxy_hostname_or_ip:port'; # $ENV{HTTPS_PROXY} = '127.0.0.1:8080'; # # Use of the HTTPS_PROXY environment variable in this way is similar to # LWP::UserAgent->env_proxy() usage, but calling that method will likely # override or break the Crypt::SSLeay support, so do not mix the two. #$proxy->agent( LWP::UserAgent->new ); # no env_proxy $proxy->init; # required to access the url later # fork a HTTP proxy my $pid = fork_proxy( $proxy, sub { ok( $proxy->conn == 1, "Served the correct number of requests" ); } ); # run a client my $ua = LWP::UserAgent->new; # no env_proxy $ENV{HTTPS_PROXY} = $proxy->url; # to be used by Crypt::SSLeay #$ENV{HTTPS_DEBUG} = 1; my $req = HTTP::Request->new( GET => "https://www.gandi.net/"); my $res = $ua->request($req); #print $res->status_line,$/,$res->headers->as_string; #500 ?? # make sure the kid is dead wait; } # tests with lwp-request: # HTTPS_PROXY=http://localhost:8080/ \ # HTTPS_DEBUG=1 \ # lwp-request -P -des https://www.nodeworks.com/ # # -P prevents lwp-request to call env_proxy() on its agent, # so that Crypt::SSLeay can use the HTTPS_PROXY environment variable HTTP-Proxy-0.304/t/64tags.t0000644000175000017500000000203412537671053013634 0ustar bookbookuse Test::More tests => 14; use strict; use HTTP::Proxy::BodyFilter::tags; my $filter = HTTP::Proxy::BodyFilter::tags->new(); # test the filter for ( [ 'foo bar', '', 'foo bar', '' ], [ 'foofoo', '', '', '>', '' ], [ '>foo', '', '>foo', '' ], [ '>foofoo', 'foofoo --> > <>><', '', ' > <>>', '<'], # the following fails because of the implementation of the tags.pm # a stronger implementation requires parsing # [ 'xfilter( \$data, undef, undef, ( defined $buffer ? \$buffer : undef ) ); is( $data, $_->[2], "Correct data" ); is( $buffer, $_->[3], "Correct buffer" ); } HTTP-Proxy-0.304/t/22transparent.t0000644000175000017500000000407712537671053015242 0ustar bookbookuse strict; use Test::More; use t::Utils; use LWP::UserAgent; use HTTP::Proxy; # here are all the requests the client will try my @requests = ( # host, path, expected code, dns should fail [ 'www.mongueurs.net', '/', 200 ], [ 'httpd.apache.org', '/docs', 301 ], [ 'www.google.com', '/testing/', 404 ], [ 'www.error.zzz', '/', '5..', 1 ], ); if ( $^O eq 'MSWin32' ) { plan skip_all => "This test fails on MSWin32. HTTP::Proxy is usable on Win32 with maxchild => 0"; exit; } # we skip the tests if the network is not available my $web_ok = web_ok(); plan tests => @requests + 2; # this is to work around tests in forked processes my $test = Test::Builder->new; $test->use_numbers(0); $test->no_ending(1); my $proxy = HTTP::Proxy->new( port => 0, max_connections => @requests * $web_ok + 1, ); $proxy->init; # required to access the url later # fork a HTTP proxy my $pid = fork_proxy( $proxy, sub { is( $proxy->conn, @requests * $web_ok + 1, "Served the correct number of requests" ); } ); # no Host: header my $content = bare_request( '/', HTTP::Headers->new(), $proxy ); my ($code) = $content =~ m!^HTTP/\d+\.\d+ (\d\d\d) !g; is( $code, 400, "Relative URL and no Host: Bad Request" ); SKIP: { skip "Web does not seem to work", scalar @requests unless $web_ok; for (@requests) { my ( $host, $path, $status, $dns_fail ) = @$_; $dns_fail &&= defined +( gethostbyname $host )[4]; SKIP: { if ($dns_fail) { $content = bare_request( '/', HTTP::Headers->new( Host => 'localhost' ), $proxy ); skip "Our DNS shouldn't resolve $host", 1; } else { $content = bare_request( $path, HTTP::Headers->new( Host => $host ), $proxy ); ($code) = $content =~ m!^HTTP/\d+\.\d+ (\d\d\d) !g; like( $code, qr/^$status$/, "Got an answer ($code)" ); } } } } # make sure the kid is dead wait; HTTP-Proxy-0.304/t/16stash.t0000644000175000017500000000147412537671053014024 0ustar bookbookuse strict; use Test::More tests => 7; use HTTP::Proxy; my $proxy; $proxy = HTTP::Proxy->new; is_deeply( $proxy->stash, {}, "Empty stash by default" ); $proxy = HTTP::Proxy->new( stash => { clunk => 'slosh', plop => 'biff' } ); is( $proxy->stash('clunk'), 'slosh', "get clunk from stash" ); is( $proxy->stash('plop'), 'biff', "get plop from stash" ); is_deeply( $proxy->stash, { clunk => 'slosh', plop => 'biff' }, "the whole hash" ); is( $proxy->stash( clunk => 'sock' ), 'sock', "set returns the new value" ); is( $proxy->stash('clunk'), 'sock', "the new value is set" ); my $h = $proxy->stash; %$h = ( thwack => 'spla_a_t', rip => 'uggh', zowie => 'thwape' ); is_deeply( $proxy->stash, { thwack => 'spla_a_t', rip => 'uggh', zowie => 'thwape' }, "stash() is a reference to the stash itself" ); HTTP-Proxy-0.304/t/00-report-prereqs.t0000644000175000017500000001273112537671053015740 0ustar bookbook#!perl use strict; use warnings; # This test was generated by Dist::Zilla::Plugin::Test::ReportPrereqs 0.021 use Test::More tests => 1; use ExtUtils::MakeMaker; use File::Spec; # from $version::LAX my $lax_version_re = qr/(?: undef | (?: (?:[0-9]+) (?: \. | (?:\.[0-9]+) (?:_[0-9]+)? )? | (?:\.[0-9]+) (?:_[0-9]+)? ) | (?: v (?:[0-9]+) (?: (?:\.[0-9]+)+ (?:_[0-9]+)? )? | (?:[0-9]+)? (?:\.[0-9]+){2,} (?:_[0-9]+)? ) )/x; # hide optional CPAN::Meta modules from prereq scanner # and check if they are available my $cpan_meta = "CPAN::Meta"; my $cpan_meta_pre = "CPAN::Meta::Prereqs"; my $HAS_CPAN_META = eval "require $cpan_meta; $cpan_meta->VERSION('2.120900')" && eval "require $cpan_meta_pre"; ## no critic # Verify requirements? my $DO_VERIFY_PREREQS = 1; sub _max { my $max = shift; $max = ( $_ > $max ) ? $_ : $max for @_; return $max; } sub _merge_prereqs { my ($collector, $prereqs) = @_; # CPAN::Meta::Prereqs object if (ref $collector eq $cpan_meta_pre) { return $collector->with_merged_prereqs( CPAN::Meta::Prereqs->new( $prereqs ) ); } # Raw hashrefs for my $phase ( keys %$prereqs ) { for my $type ( keys %{ $prereqs->{$phase} } ) { for my $module ( keys %{ $prereqs->{$phase}{$type} } ) { $collector->{$phase}{$type}{$module} = $prereqs->{$phase}{$type}{$module}; } } } return $collector; } my @include = qw( ); my @exclude = qw( ); # Add static prereqs to the included modules list my $static_prereqs = do 't/00-report-prereqs.dd'; # Merge all prereqs (either with ::Prereqs or a hashref) my $full_prereqs = _merge_prereqs( ( $HAS_CPAN_META ? $cpan_meta_pre->new : {} ), $static_prereqs ); # Add dynamic prereqs to the included modules list (if we can) my ($source) = grep { -f } 'MYMETA.json', 'MYMETA.yml'; if ( $source && $HAS_CPAN_META ) { if ( my $meta = eval { CPAN::Meta->load_file($source) } ) { $full_prereqs = _merge_prereqs($full_prereqs, $meta->prereqs); } } else { $source = 'static metadata'; } my @full_reports; my @dep_errors; my $req_hash = $HAS_CPAN_META ? $full_prereqs->as_string_hash : $full_prereqs; # Add static includes into a fake section for my $mod (@include) { $req_hash->{other}{modules}{$mod} = 0; } for my $phase ( qw(configure build test runtime develop other) ) { next unless $req_hash->{$phase}; next if ($phase eq 'develop' and not $ENV{AUTHOR_TESTING}); for my $type ( qw(requires recommends suggests conflicts modules) ) { next unless $req_hash->{$phase}{$type}; my $title = ucfirst($phase).' '.ucfirst($type); my @reports = [qw/Module Want Have/]; for my $mod ( sort keys %{ $req_hash->{$phase}{$type} } ) { next if $mod eq 'perl'; next if grep { $_ eq $mod } @exclude; my $file = $mod; $file =~ s{::}{/}g; $file .= ".pm"; my ($prefix) = grep { -e File::Spec->catfile($_, $file) } @INC; my $want = $req_hash->{$phase}{$type}{$mod}; $want = "undef" unless defined $want; $want = "any" if !$want && $want == 0; my $req_string = $want eq 'any' ? 'any version required' : "version '$want' required"; if ($prefix) { my $have = MM->parse_version( File::Spec->catfile($prefix, $file) ); $have = "undef" unless defined $have; push @reports, [$mod, $want, $have]; if ( $DO_VERIFY_PREREQS && $HAS_CPAN_META && $type eq 'requires' ) { if ( $have !~ /\A$lax_version_re\z/ ) { push @dep_errors, "$mod version '$have' cannot be parsed ($req_string)"; } elsif ( ! $full_prereqs->requirements_for( $phase, $type )->accepts_module( $mod => $have ) ) { push @dep_errors, "$mod version '$have' is not in required range '$want'"; } } } else { push @reports, [$mod, $want, "missing"]; if ( $DO_VERIFY_PREREQS && $type eq 'requires' ) { push @dep_errors, "$mod is not installed ($req_string)"; } } } if ( @reports ) { push @full_reports, "=== $title ===\n\n"; my $ml = _max( map { length $_->[0] } @reports ); my $wl = _max( map { length $_->[1] } @reports ); my $hl = _max( map { length $_->[2] } @reports ); if ($type eq 'modules') { splice @reports, 1, 0, ["-" x $ml, "", "-" x $hl]; push @full_reports, map { sprintf(" %*s %*s\n", -$ml, $_->[0], $hl, $_->[2]) } @reports; } else { splice @reports, 1, 0, ["-" x $ml, "-" x $wl, "-" x $hl]; push @full_reports, map { sprintf(" %*s %*s %*s\n", -$ml, $_->[0], $wl, $_->[1], $hl, $_->[2]) } @reports; } push @full_reports, "\n"; } } } if ( @full_reports ) { diag "\nVersions for all modules listed in $source (including optional ones):\n\n", @full_reports; } if ( @dep_errors ) { diag join("\n", "\n*** WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING ***\n", "The following REQUIRED prerequisites were not satisfied:\n", @dep_errors, "\n" ); } pass; # vim: ts=4 sts=4 sw=4 et: HTTP-Proxy-0.304/t/50via.t0000644000175000017500000000443412537671053013456 0ustar bookbookuse strict; use Test::More; use LWP::UserAgent; use HTTP::Proxy; use t::Utils; # some helper functions for the server if( $^O eq 'MSWin32' ) { plan skip_all => "This test fails on MSWin32. HTTP::Proxy is usable on Win32 with maxchild => 0"; exit; } plan tests => 4; my $test = Test::Builder->new; my @pids; # this is a rather long test suite just to test that # $proxy->via() works ok # this is to work around tests in forked processes $test->use_numbers(0); $test->no_ending(1); # create a HTTP::Daemon (on an available port) my $server = server_start(); # create and fork the proxy # the proxy itself will not fork my $proxy = HTTP::Proxy->new( port => 0, max_connections => 1, max_clients => 0 ); $proxy->init; # required to access the url later $proxy->agent->no_proxy( URI->new( $server->url )->host ); push @pids, fork_proxy($proxy); # fork the HTTP server my $pid = fork; die "Unable to fork web server" if not defined $pid; if ( $pid == 0 ) { # the answer method my $answer1 = sub { my ( $req, $data ) = @_; isnt( $req->headers->header('Via'), undef, "Server says Via: header added" ); return HTTP::Response->new( 200, 'OK', HTTP::Headers->new( 'Content-Type' => 'text/plain' ), "Headers checked." ); }; my $answer2 = sub { my ( $req, $data ) = @_; is( $req->headers->header('Via'), undef, "Server says no Via: header added" ); return HTTP::Response->new( 200, 'OK', HTTP::Headers->new( 'Content-Type' => 'text/plain' ), "Headers checked." ); }; # let's return some files when asked for them server_next( $server, $answer1 ); server_next( $server, $answer2 ); exit 0; } push @pids, $pid; # run a client my ( $req, $res ); my $ua = LWP::UserAgent->new; $ua->proxy( http => $proxy->url ); # send a Proxy-Connection header $req = HTTP::Request->new( GET => $server->url ); $res = $ua->simple_request($req); isnt( $res->headers->header('Via'), undef, "Client says Via: header added" ); # create and fork the proxy $proxy->via(''); push @pids, fork_proxy($proxy); $res = $ua->simple_request($req); is( $res->headers->header('Via'), undef, "Client says no Via: header added" ); # make sure both kids are dead wait for @pids; HTTP-Proxy-0.304/t/51simple2.t0000644000175000017500000000260312537671053014247 0ustar bookbookuse Test::More tests => 2; use strict; use HTTP::Proxy; use HTTP::Proxy::HeaderFilter::simple; use t::Utils; # create the filter my $sub = sub { my ( $self, $headers, $message) = @_; $headers->header( X_Foo => 'Bar' ); }; my $filter = HTTP::Proxy::HeaderFilter::simple->new($sub); # create the proxy my $proxy = HTTP::Proxy->new( port => 0, max_clients => 0, max_connections => 2, ); # prepare the proxy and server $proxy->init; $proxy->agent->proxy( http => "" ); $proxy->push_filter( response => $filter ); my $url = $proxy->url; my $server = server_start(); my $serverurl = $server->url; # fork the proxy my @pids; push @pids, fork_proxy($proxy); # fork the HTTP server my $pid = fork; die "Unable to fork web server" if not defined $pid; if ( $pid == 0 ) { server_next($server) for 1 .. 2; exit 0; } push @pids, $pid; # # check that the correct transformation is applied # # for GET requests my $ua = LWP::UserAgent->new(); $ua->proxy( http => $url ); my $response = $ua->request( HTTP::Request->new( GET => $serverurl ) ); is( $response->header( "X-Foo" ), "Bar", "Proxy applied the transformation" ); # for HEAD requests $ua = LWP::UserAgent->new(); $ua->proxy( http => $url ); $response = $ua->request( HTTP::Request->new( HEAD => $serverurl ) ); is( $response->header( "X-Foo" ), "Bar", "Proxy applied the transformation" ); # wait for kids wait for @pids; HTTP-Proxy-0.304/t/20keepalive.t0000644000175000017500000000523712537671053014643 0ustar bookbookuse strict; use Test::More; # here are all the requests the client will try my @requests = ( 'single.txt', ( 'file1.txt', 'directory/file2.txt', 'ooh.cgi?q=query' ) x 2 ); if( $^O eq 'MSWin32' ) { plan skip_all => "This test fails on MSWin32. HTTP::Proxy is usable on Win32 with maxchild => 0"; exit; } plan tests => 3 * @requests + 1; use LWP::UserAgent; use HTTP::Proxy; use t::Utils; # some helper functions for the server my $test = Test::Builder->new; # this is to work around tests in forked processes $test->use_numbers(0); $test->no_ending(1); # create a HTTP::Daemon (on an available port) my $server = server_start(); # create a HTTP::Proxy my $proxy = HTTP::Proxy->new( port => 0, max_keep_alive_requests => 3, # no more than 3 requests per connection max_connections => 3, # no more than 3 connections ); $proxy->init; # required to access the url later $proxy->agent->no_proxy( URI->new( $server->url )->host ); # fork the HTTP server my @pids; my $pid = fork; die "Unable to fork web server" if not defined $pid; if ( $pid == 0 ) { # the answer method my $answer = sub { my $req = shift; my $data = shift; my $re = quotemeta $data; like( $req->uri, qr/$re/, "The daemon got what it expected" ); return HTTP::Response->new( 200, 'OK', HTTP::Headers->new( 'Content-Type' => 'text/plain' ), "Here is $data." ); }; # let's return some files when asked for them server_next( $server, $answer, $_ ) for @requests; exit 0; } # back in the parent push @pids, $pid; # remember the kid # fork a HTTP proxy fork_proxy( $proxy, sub { is( $proxy->conn, 3, "The proxy served the correct number of connections" ); } ); # back in the parent push @pids, $pid; # remember the kid # some variables my ( $ua, $res, $re ); # the first connection will be closed by the client $ua = LWP::UserAgent->new; $ua->proxy( http => $proxy->url ); my $req = shift @requests; $res = $ua->simple_request( HTTP::Request->new( GET => $server->url . $req ) ); ok( $res->is_success, "Got an answer (@{[$res->status_line]})" ); $re = quotemeta $req; like( $res->content, qr/$re/, "The client got what it expected" ); # the other connections (keep-alive) $ua = LWP::UserAgent->new( keep_alive => 1 ); $ua->proxy( http => $proxy->url ); for (@requests) { $res = $ua->simple_request( HTTP::Request->new( GET => $server->url . $_ ) ); ok( $res->is_success, "Got an answer (@{[$res->status_line]})" ); $re = quotemeta; like( $res->content, qr/$re/, "The client got what it expected" ); } # make sure both kids are dead wait for @pids; HTTP-Proxy-0.304/t/50standard.t0000644000175000017500000001131012537671053014466 0ustar bookbookuse strict; use Test::More; use LWP::UserAgent; use HTTP::Proxy; use HTTP::Proxy::HeaderFilter::simple; use t::Utils; # some helper functions for the server if( $^O eq 'MSWin32' ) { plan skip_all => "This test fails on MSWin32. HTTP::Proxy is usable on Win32 with maxchild => 0"; exit; } plan tests => 13; my $test = Test::Builder->new; my @pids; # this is to work around tests in forked processes $test->use_numbers(0); $test->no_ending(1); # create a HTTP::Daemon (on an available port) my $server = server_start(); # create and fork the proxy my $proxy = HTTP::Proxy->new( port => 0, max_connections => 5 ); $proxy->init; # required to access the url later $proxy->agent->no_proxy( URI->new( $server->url )->host ); push @pids, fork_proxy($proxy); # fork the HTTP server my $pid = fork; die "Unable to fork web server" if not defined $pid; if ( $pid == 0 ) { my $res = HTTP::Response->new( 200, 'OK', HTTP::Headers->new( 'Content-Type' => 'text/plain' ), "Here is some data." ); # let's return some files when asked for them server_next($server) for 1 .. 3; server_next($server, sub { my $req = shift; SKIP: { skip 'FreeBSD jail does not treat localhost as 127.0.0.1', 1 if ($^O eq 'freebsd' && `sysctl -n security.jail.jailed` == 1); is( $req->header("X-Forwarded-For"), '127.0.0.1', "The daemon got X-Forwarded-For" ); } return $res; } ); server_next( $server, sub { my $req = shift; is( $req->header("X-Forwarded-For"), undef, "The daemon didn't get X-Forwarded-For" ); return $res; } ); exit 0; } push @pids, $pid; # run a client my ( $req, $res ); my $ua = LWP::UserAgent->new; $ua->proxy( http => $proxy->url ); # # check that we have single Date and Server headers # # for GET requests $req = HTTP::Request->new( GET => $server->url . "headers" ); $res = $ua->simple_request($req); my @date = $res->headers->header('Date'); is( scalar @date, 1, "A single Date: header for GET request" ); my @server = $res->headers->header('Server'); is( scalar @server, 1, "A single Server: header for GET request" ); # for HEAD requests $req = HTTP::Request->new( HEAD => $server->url . "headers-head" ); $res = $ua->simple_request($req); @date = $res->headers->header('Date'); is( scalar @date, 1, "A single Date: header for HEAD request" ); @server = $res->headers->header('Server'); is( scalar @server, 1, "A single Server: header for HEAD request" ); # for direct proxy responses $ua->proxy( file => $proxy->url ); $req = HTTP::Request->new( GET => "file:///etc/passwd" ); $res = $ua->simple_request($req); @date = $res->headers->header('Date'); is( scalar @date, 1, "A single Date: header for direct proxy response" ); @server = $res->headers->header('Server'); is( scalar @server, 1, "A single Server: header for direct proxy response" ); # check the Server: header like( $server[0], qr!HTTP::Proxy/\d+\.\d+!, "Correct server name for direct proxy response" ); # we cannot use a LWP user-agent to check # that the LWP Client-* headers are removed use IO::Socket::INET; # connect directly to the proxy $proxy->url() =~ /:(\d+)/; my $sock = IO::Socket::INET->new( PeerAddr => 'localhost', PeerPort => $1, Proto => 'tcp' ) or diag "Can't connect to the proxy"; # send the request my $url = $server->url; $url =~ m!http://([^:]*)!; print $sock "GET $url HTTP/1.0\015\012Host: $1\015\012\015\012"; # fetch and count the Client-* response headers my @client = grep { /^Client-/ } <$sock>; is( scalar @client, 0, "No Client-* headers sent by the proxy" ); # close the connection to the proxy close $sock or diag "close: $!"; # X-Forwarded-For (test in the server) $req = HTTP::Request->new( HEAD => $server->url . "x-forwarded-for" ); $res = $ua->simple_request($req); is( $res->header( 'X-Forwarded-For' ), undef, "No X-Forwarded-For sent back" ); # yet another proxy $proxy = HTTP::Proxy->new( port => 0, max_connections => 1, x_forwarded_for => 0 ); $proxy->init; # required to access the url later $proxy->agent->no_proxy( URI->new( $server->url )->host ); $proxy->push_filter( response => HTTP::Proxy::HeaderFilter::simple->new( sub { is( $_[0]->proxy->client_headers->header("Client-Response-Num"), 1, "Client headers" ); } ) ); push @pids, fork_proxy($proxy); # X-Forwarded-For (test in the server) $ua->proxy( http => $proxy->url ); $req = HTTP::Request->new( HEAD => $server->url . "x-forwarded-for" ); $res = $ua->simple_request($req); is( $res->header( 'X-Forwarded-For' ), undef, "No X-Forwarded-For sent back" ); # make sure both kids are dead wait for @pids; HTTP-Proxy-0.304/t/18engine.t0000644000175000017500000000406612537671053014151 0ustar bookbookuse Test::More; use HTTP::Proxy::Engine; plan tests => 18; my $e; my $p = bless {}, "HTTP::Proxy"; $e = HTTP::Proxy::Engine->new( proxy => $p, engine => Legacy ); isa_ok( $e, 'HTTP::Proxy::Engine::Legacy' ); # use the default engine for $^O eval { HTTP::Proxy::Engine->new() }; isa_ok( $e, 'HTTP::Proxy::Engine' ); eval { HTTP::Proxy::Engine->new( engine => Legacy ) }; like( $@, qr/^No proxy defined/, "proxy required" ); eval { HTTP::Proxy::Engine->new( proxy => "P", engine => Legacy ) }; like( $@, qr/^P is not a HTTP::Proxy object/, "REAL proxy required" ); # direct engine creation # HTTP::Proxy::Engine::Legacy was required before $e = HTTP::Proxy::Engine::Legacy->new( proxy => $p ); isa_ok( $e, 'HTTP::Proxy::Engine::Legacy' ); eval { HTTP::Proxy::Engine::Legacy->new() }; like( $@, qr/^No proxy defined/, "proxy required" ); eval { HTTP::Proxy::Engine::Legacy->new( proxy => "P" ) }; like( $@, qr/^P is not a HTTP::Proxy object/, "REAL proxy required" ); # non-existent engine eval { HTTP::Proxy::Engine->new( proxy => $p, engine => Bonk ) }; like( $@, qr/^Can't locate HTTP.+?Proxy.+?Engine.+?Bonk\.pm in \@INC/, "Engine Bonk does not exist" ); # check the base accessor $e = HTTP::Proxy::Engine->new( proxy => $p, engine => Legacy ); is( $e->proxy, $p, "proxy() get" ); # check subclasses accessors $e = HTTP::Proxy::Engine->new( proxy => $p, engine => Legacy, select => 2 ); is( $e->select, 2, "subclass get()" ); is( $e->select(4), 4, "subclass set()" ); is( $e->select, 4, "subclass get()" ); $e = HTTP::Proxy::Engine::Legacy->new( proxy => $p, select => 3 ); is( $e->select, 3, "subclass get()" ); is( $e->select(4), 4, "subclass set()" ); is( $e->select, 4, "subclass get()" ); # but where is the code? is( *{HTTP::Proxy::Engine::select}{CODE}, undef, "code not in the base class" ); is( ref *{HTTP::Proxy::Engine::select}{CODE}, '', "code not in the base class" ); my $c = \&HTTP::Proxy::Engine::Legacy::select; # remove "used only once" warning is( ref *{HTTP::Proxy::Engine::Legacy::select}{CODE}, 'CODE', "code in the subclass" ); HTTP-Proxy-0.304/t/release-distmeta.t0000644000175000017500000000043012537671053015752 0ustar bookbook#!perl BEGIN { unless ($ENV{RELEASE_TESTING}) { require Test::More; Test::More::plan(skip_all => 'these tests are for release candidate testing'); } } # This file was automatically generated by Dist::Zilla::Plugin::MetaTests. use Test::CPAN::Meta; meta_yaml_ok(); HTTP-Proxy-0.304/t/00basic.t0000644000175000017500000000065712537671053013756 0ustar bookbookuse vars qw( @modules ); BEGIN { use Config; use File::Find; use vars qw( @modules ); find( sub { push @modules, $File::Find::name if /\.pm$/ }, 'blib/lib' ); } use Test::More tests => scalar @modules; for ( sort map { s!/!::!g; s/\.pm$//; s/^blib::lib:://; $_ } @modules ) { SKIP: { skip "$^X is not a threaded Perl", 1 if /Thread/ && !$Config{usethreads}; use_ok($_); } } HTTP-Proxy-0.304/t/66htmlparser.t0000644000175000017500000000336112537671053015065 0ustar bookbookuse strict; use Test::More; BEGIN { if ( eval "use HTML::Parser; 1;" ) { plan tests => 5; } else { plan skip_all => 'HTML::Parser not installed'; } } use HTTP::Proxy; use HTTP::Proxy::BodyFilter::htmlparser; my @results = ( [ '

Test

\n

foo
bar

', '

Test

\n

foo
bar

', { start => 4, end => 3 } ], [ '

Test

\n

foo
bar

', '


', { start => 4, end => 3 } ], ); my $filter; my $count; # bad initialisation eval { $filter = HTTP::Proxy::BodyFilter::htmlparser->new("foo"); }; like( $@, qr/^First parameter must be a HTML::Parser/, "Test constructor" ); my $p = HTML::Parser->new; $p->handler( start => \&start, "self,text" ); $p->handler( end => \&end, "self,text" ); $p->handler( start_document => \&start_document, "" ); # the handlers sub start_document { $count = {} } sub start { $count->{start}++; $_[0]->{output} .= $_[1] } sub end { $count->{end}++; $_[0]->{output} .= $_[1] } # read-only filter my $data = shift @results; $filter = HTTP::Proxy::BodyFilter::htmlparser->new($p); $filter->filter( \$data->[0], undef, undef, undef ); is_deeply( $data->[0], $data->[1], "Data not modified" ); is_deeply( $data->[2], $count, "Correct number of start and end events" ); # read-write filter (yeah, it's the same) $data = shift @results; $filter = HTTP::Proxy::BodyFilter::htmlparser->new( $p, rw => 1 ); $filter->filter( \$data->[0], undef, undef, undef ); is_deeply( $data->[0], $data->[1], "Data modified" ); is_deeply( $data->[2], $count, "Correct number of start and end events" ); HTTP-Proxy-0.304/t/17fstack.t0000644000175000017500000000322512537671053014152 0ustar bookbookuse Test::More tests => 11; use HTTP::Proxy; use HTTP::Proxy::HeaderFilter; use HTTP::Proxy::BodyFilter; my $stack; my $hf = [ sub { 1 }, HTTP::Proxy::HeaderFilter->new() ]; my $hf2 = [ sub { 1 }, HTTP::Proxy::HeaderFilter->new() ]; my $bf = [ sub { 1 }, HTTP::Proxy::BodyFilter->new() ]; # test general stack workings $stack = HTTP::Proxy::FilterStack->new(); # all, push is_deeply( [ $stack->all ], [], "FilterStack is empty" ); $stack->push($hf); is_deeply( [ $stack->all ], [ $hf ], "FilterStack has one element" ); $stack->push($hf2, $hf); is_deeply( [ $stack->all ], [ $hf, $hf2, $hf ], "FilterStack has three elements" ); # insert $stack->insert(1, $hf2); is_deeply( [ $stack->all ], [ $hf, $hf2, $hf2, $hf ], "FilterStack is correct"); is( scalar $stack->all, 4, "Correct in scalar context too"); # remove my $elem = $stack->remove(1); is( $elem, $hf2, "Got back what was in the stack"); # check insertion in header FilterStack eval { $stack->push( $bf ); }; like( $@, qr/is not a HTTP::Proxy::HeaderFilter/, "Incorrect Filter class" ); eval { $stack->insert( 0, $bf ); }; like( $@, qr/is not a HTTP::Proxy::HeaderFilter/, "Incorrect Filter class" ); { package Foo; use base qw( HTTP::Proxy::HeaderFilter ); } my $foo = [ sub { 1 }, Foo->new() ]; eval { $stack->push( $foo ); }; is( $@, '', "Can push derived Filters" ); # same test for body FilterStack my $bstack = HTTP::Proxy::FilterStack->new(1); eval { $bstack->push( $hf ); }; like( $@, qr/is not a HTTP::Proxy::BodyFilter/, "Incorrect Filter class" ); eval { $bstack->insert( 0, $hf ); }; like( $@, qr/is not a HTTP::Proxy::BodyFilter/, "Incorrect Filter class" ); # current # filter # filter_last HTTP-Proxy-0.304/t/release-pod-syntax.t0000644000175000017500000000045612537671053016256 0ustar bookbook#!perl BEGIN { unless ($ENV{RELEASE_TESTING}) { require Test::More; Test::More::plan(skip_all => 'these tests are for release candidate testing'); } } # This file was automatically generated by Dist::Zilla::Plugin::PodSyntaxTests. use Test::More; use Test::Pod 1.41; all_pod_files_ok(); HTTP-Proxy-0.304/t/00-report-prereqs.dd0000644000175000017500000000536212537671053016066 0ustar bookbookdo { my $x = { 'configure' => { 'requires' => { 'ExtUtils::MakeMaker' => '0' } }, 'develop' => { 'requires' => { 'Pod::Coverage::TrustPod' => '0', 'Test::CPAN::Meta' => '0', 'Test::Pod' => '1.41', 'Test::Pod::Coverage' => '1.08' } }, 'runtime' => { 'requires' => { 'Carp' => '0', 'Exporter' => '0', 'Fcntl' => '0', 'File::Path' => '0', 'File::Spec' => '0', 'File::Temp' => '0', 'HTTP::Daemon' => '0', 'HTTP::Date' => '0', 'HTTP::Headers::Util' => '0', 'IO::Handle' => '0', 'IO::Select' => '0', 'LWP::ConnCache' => '0', 'LWP::UserAgent' => '0', 'POSIX' => '0', 'Socket' => '0', 'Sys::Hostname' => '0', 'constant' => '0', 'strict' => '0', 'vars' => '0' } }, 'test' => { 'recommends' => { 'CPAN::Meta' => '2.120900' }, 'requires' => { 'ExtUtils::MakeMaker' => '0', 'File::Find' => '0', 'File::Spec' => '0', 'File::Spec::Functions' => '0', 'HTML::Parser' => '3', 'HTTP::Headers' => '0', 'HTTP::Request' => '0', 'HTTP::Request::Common' => '0', 'IO::Socket::INET' => '0', 'Test::More' => '0', 'base' => '0', 'warnings' => '0' } } }; $x; }HTTP-Proxy-0.304/t/71rot13.t0000644000175000017500000000263412537671053013652 0ustar bookbookuse Test::More tests => 4; use HTTP::Proxy; use HTTP::Proxy::BodyFilter::tags; use HTTP::Proxy::BodyFilter::htmltext; use t::Utils; use strict; # a very simple proxy my $proxy = HTTP::Proxy->new( port => 0 ); $proxy->push_filter( mime => 'text/html', response => HTTP::Proxy::BodyFilter::tags->new, response => HTTP::Proxy::BodyFilter::htmltext->new( sub { tr/a-zA-z/n-za-mN-ZA-M/ } ) ); # get and test the filter stack my $stack = $proxy->_filter_stack( body => 'response', HTTP::Request->new( GET => 'http://foo.com/bar.html' ), HTTP::Response->new( 200, "OK", HTTP::Headers->new( 'Content-Type' => 'text/html' ) ) ); for ( [ "abc", "nop" ], [ "100 € is expensive", "100 € vf rkcrafvir" ], [ "
<-- here
", " <-- urer " ], [ qq'\n foo', qq'\n sbb', ], ) { my $data = "$_->[0]"; $stack->select_filters( $proxy->{response} ); $stack->filter( \$data, $proxy->{response}, undef ); is( $data, $_->[1], "Correct data transformation" ); } HTTP-Proxy-0.304/t/64lines.t0000644000175000017500000000350712537671053014016 0ustar bookbookuse Test::More tests => 33; use strict; use HTTP::Proxy::BodyFilter::lines; my $filter; # error checking eval { $filter = HTTP::Proxy::BodyFilter::lines->new( undef ) }; like( $@, qr/slurp mode is not supported/, "No slurp mode" ); eval { $filter = HTTP::Proxy::BodyFilter::lines->new( \'foo' ) }; like( $@, qr/"foo" is not numeric/, "Records must be numeric" ); eval { $filter = HTTP::Proxy::BodyFilter::lines->new( \0 ) }; like( $@, qr/Records of size 0/, "Records must be != 0" ); # test the filter for ( HTTP::Proxy::BodyFilter::lines->new(), [ "\n\n\nfoo\n", "", "\n\n\nfoo\n", "" ], [ "foo\nbar", "", "foo\n", "bar" ], [ "foo\nbar\nbaz", "", "foo\nbar\n", "baz" ], [ "", "", "", "" ], [ "foo\nbar\nbaz", undef, "foo\nbar\nbaz", undef ], HTTP::Proxy::BodyFilter::lines->new('%'), [ "\n\n%\nfoo\n", "", "\n\n%", "\nfoo\n" ], [ "foo\%bar", "", 'foo%', "bar" ], [ "foo\n\%bar\nbaz", "", "foo\n\%", "bar\nbaz" ], [ "foo\nbar\%baz", undef, "foo\nbar\%baz", undef ], HTTP::Proxy::BodyFilter::lines->new(""), [ "foo\nbar\n\nbaz", "", "foo\nbar\n\n", "baz" ], [ "foo\nbar\n\n", "", "", "foo\nbar\n\n" ], [ "foo\nbar\n\n", undef, "foo\nbar\n\n", undef ], HTTP::Proxy::BodyFilter::lines->new( \10 ), [ '01234567890123', "", "0123456789", "0123" ], [ '0123456789' x 2, "", "0123456789" x 2, "" ], [ '01234567890123', undef, "01234567890123", undef ], ) { $filter = $_, next if ref eq 'HTTP::Proxy::BodyFilter::lines'; my ( $data, $buffer ) = @$_[ 0, 1 ]; $filter->filter( \$data, undef, undef, ( defined $buffer ? \$buffer : undef ) ); is( $data, $_->[2], "Correct data" ); is( $buffer, $_->[3], "Correct buffer" ); } HTTP-Proxy-0.304/t/50hopbyhop.t0000644000175000017500000000767512537671053014541 0ustar bookbookuse strict; use Test::More tests => 28; use HTTP::Proxy; # objects my $proxy = HTTP::Proxy->new( port => 0 ); $proxy->init; # needed to setup the filter stacks my $filter = HTTP::Proxy::HeaderFilter::standard->new; # a few hacks because we aren't actually connected $filter->proxy($proxy); { package MockSocket; use vars qw( @ISA ); @ISA = qw( IO::Socket::INET ); # needed by HTTP::Proxy::HeaderFilter::standard sub peerhost { "1.2.3.4"; } } $proxy->{client_socket} = MockSocket->new(); # the dummy request my $req = HTTP::Request->new( GET => 'http://www.example.com/' ); $req->header( Proxy_Connection => 'Keep-Alive', Connection => 'Foo, Bar', Foo => 'foofoo', Bar => 'barbar', User_Agent => 'Foo/1.0' ); $filter->filter( $req->headers, $req ); # hop-by-hop is( $proxy->hop_headers->header('proxy-connection'), 'Keep-Alive', "Hop-by-hop Proxy-Connection" ); is( $proxy->hop_headers->header('connection'), 'Foo, Bar', "Hop-by-hop Connection" ); is( $proxy->hop_headers->header('Foo'), 'foofoo', "Hop-by-hop Foo" ); is( $proxy->hop_headers->header('Bar'), 'barbar', "Hop-by-hop Bar" ); # end-to-end is( $req->header('user-agent'), 'Foo/1.0', "End-to-end User-Agent" ); is( $req->header('proxy-connection'), undef, "Connection header removed" ); is( $req->header('connection'), undef, "Connection header removed" ); is( $req->header('Foo'), undef, "Connection header removed" ); is( $req->header('Bar'), undef, "Connection header removed" ); # yet another test $req = HTTP::Request->new( GET => 'http://www.example.com/' ); $req->push_header( Proxy_Connection => 'Keep-Alive' ); $req->push_header( Connection => 'Foo' ); $req->push_header( Connection => 'Bar' ); $req->push_header( Foo => 'foofoo' ); $req->push_header( Bar => 'barbar' ); $req->push_header( User_Agent => 'Foo/1.0' ); $filter->filter( $req->headers, $req ); # hop-by-hop is( $proxy->hop_headers->header('proxy-connection'), 'Keep-Alive', "Hop-by-hop Proxy-Connection" ); is( $proxy->hop_headers->header('connection'), 'Foo, Bar', "Hop-by-hop Connection" ); is( $proxy->hop_headers->header('Foo'), 'foofoo', "Hop-by-hop Foo" ); is( $proxy->hop_headers->header('Bar'), 'barbar', "Hop-by-hop Bar" ); # end-to-end is( $req->header('user-agent'), 'Foo/1.0', "End-to-end User-Agent" ); is( $req->header('proxy-connection'), undef, "Connection header removed" ); is( $req->header('connection'), undef, "Connection header removed" ); is( $req->header('Foo'), undef, "Connection header removed" ); is( $req->header('Bar'), undef, "Connection header removed" ); # a final test $req = HTTP::Request->new( GET => 'http://www.example.com/' ); $req->push_header( Proxy_Connection => 'Keep-Alive' ); $req->push_header( Connection => 'Foo, Bar' ); $req->push_header( Connection => 'Baz' ); $req->push_header( Foo => 'foofoo' ); $req->push_header( Bar => 'barbar' ); $req->push_header( Baz => 'bazbaz' ); $req->push_header( User_Agent => 'Foo/1.0' ); $filter->filter( $req->headers, $req ); # hop-by-hop is( $proxy->hop_headers->header('proxy-connection'), 'Keep-Alive', "Hop-by-hop Proxy-Connection" ); is( $proxy->hop_headers->header('connection'), 'Foo, Bar, Baz', "Hop-by-hop Connection" ); is( $proxy->hop_headers->header('Foo'), 'foofoo', "Hop-by-hop Foo" ); is( $proxy->hop_headers->header('Bar'), 'barbar', "Hop-by-hop Bar" ); is( $proxy->hop_headers->header('Baz'), 'bazbaz', "Hop-by-hop Baz" ); # end-to-end is( $req->header('user-agent'), 'Foo/1.0', "End-to-end User-Agent" ); is( $req->header('proxy-connection'), undef, "Connection header removed" ); is( $req->header('connection'), undef, "Connection header removed" ); is( $req->header('Foo'), undef, "Connection header removed" ); is( $req->header('Bar'), undef, "Connection header removed" ); HTTP-Proxy-0.304/t/67complete.t0000644000175000017500000000304412537671053014513 0ustar bookbookuse strict; use warnings; use Test::More; use HTTP::Proxy; use HTTP::Proxy::BodyFilter::complete; use HTTP::Proxy::BodyFilter::simple; my @data = ( 'miny hollers the let tiger catch meeny a he him', 'joy beamish flame gyre o blade came callay jaws vorpal', 'xvi vigor nvi Bvi trived Elvis levee viper e3 PVIC', 'Wizzle Hunny_Bee Alexander_Beetle Owl Woozle Eeyore Backson', 'necessitatibus lorem aperiam facere consequuntur incididunt similique' ); my $full = join '', @data; plan tests => 1 + @data; # some variables my $proxy = HTTP::Proxy->new( port => 0 ); $proxy->push_filter( response => HTTP::Proxy::BodyFilter::complete->new(), response => HTTP::Proxy::BodyFilter::simple->new( sub { my ( $self, $dataref, $message, $protocol, $buffer ) = @_; if ( defined $buffer ) { is( $$dataref, '', 'Empty chunk of data' ); } else { is( $$dataref, $full, 'Full data in one big chunk' ); } } ), ); # set up a fake request/response set my $res = HTTP::Response->new( 200, 'OK', HTTP::Headers->new( 'Content-Type' => 'text/html' ), 'dummy' ); $res->request( HTTP::Request->new( GET => 'http://www.example.com/' ) ); $proxy->request( $res->request ); $proxy->response($res); # run the data through the filters $proxy->{body}{response}->select_filters($res); for my $data (@data) { $proxy->{body}{response}->filter( \$data, $res, '' ); } # finalize my $data = ''; $proxy->{body}{response}->filter_last( \$data, $res, '' ); HTTP-Proxy-0.304/t/10init.t0000644000175000017500000000157212537671053013636 0ustar bookbookuse Test::More tests => 8; use HTTP::Proxy; my ( $proxy, $agent, $daemon ); # individual methods $proxy = HTTP::Proxy->new( port => 0 ); is( $proxy->agent, undef, 'agent undefined at startup' ); is( $proxy->daemon, undef, 'daemon undefined at startup' ); # private methods (should we test them?) $agent = $proxy->_init_agent; $daemon = $proxy->_init_daemon; isa_ok( $agent, 'LWP::UserAgent', 'init_agent' ); isa_ok( $daemon, 'HTTP::Daemon', 'init_daemon' ); # this is ugly $daemon = undef; # combined init method $proxy = HTTP::Proxy->new( port => 0 ); $proxy->init; isa_ok( $proxy->agent, 'LWP::UserAgent', 'init agent' ); isa_ok( $proxy->daemon, 'HTTP::Daemon', 'init daemon' ); # basic checks on the agent $agent = $proxy->agent; ok( ! $agent->is_protocol_supported('mailto'), "Can't mailto" ); ok( ! $agent->is_protocol_supported('file'), "Can't access local files" ); HTTP-Proxy-0.304/t/15deprecated.t0000644000175000017500000000333212537671053014774 0ustar bookbookuse strict; use Test::More; use File::Spec; use HTTP::Proxy; my $errfile = File::Spec->catfile( 't', 'stderr.out' ); my @deprecated = ( [ maxchild => qr/^maxchild is deprecated, please use max_clients/ ], [ maxconn => qr/^maxconn is deprecated, please use max_connections/ ], [ maxserve => qr/^maxserve is deprecated, please use max_keep_alive_requests/ ], ); plan tests => 4 * @deprecated; # check the warnings open my $olderr, ">&STDERR" or die "Can't dup STDERR: $!"; open STDERR, '>', $errfile or die "Can't redirect STDERR: $!"; select STDERR; $| = 1; # make unbuffered # call the deprecated methods my $p1 = HTTP::Proxy->new( maxchild => 1, maxconn => 3, maxserve => 5, ); my $p2 = HTTP::Proxy->new(); $p2->maxchild(9); $p2->maxconn(8); $p2->maxserve(7); # get the old STDERR back open STDERR, ">&", $olderr or die "Can't dup \$olderr: $!"; # read the stderr log open my $fh, $errfile or die "Can't open $errfile: $!"; my @err = sort <$fh>; close $fh or diag "Can't close $errfile: $!"; # run the tests for (@deprecated) { like( shift @err, $_->[1], "$_->[0] is deprecated" ); like( shift @err, $_->[1], "$_->[0] is deprecated" ); } diag $_ for @err; unlink $errfile or diag "Can't unlink $errfile: $!"; # check that the real method was called is( $p1->max_clients, 1, "max_clients called for maxchild" ); is( $p1->max_connections, 3, "max_connections called for maxconn" ); is( $p1->max_keep_alive_requests, 5, "max_keep_alive_requests called for maxserve" ); is( $p2->max_clients, 9, "max_clients called for maxchild" ); is( $p2->max_connections, 8, "max_connections called for maxconn" ); is( $p2->max_keep_alive_requests, 7, "max_keep_alive_requests called for maxserve" ); HTTP-Proxy-0.304/t/42will_modify.t0000644000175000017500000000342212537671053015212 0ustar bookbookuse strict; use Test::More; use HTTP::Proxy; use HTTP::Proxy::BodyFilter::tags; use HTTP::Proxy::BodyFilter::simple; use HTTP::Proxy::BodyFilter::complete; use HTTP::Proxy::BodyFilter::htmltext; use HTTP::Proxy::BodyFilter::lines; use HTTP::Proxy::BodyFilter::save; use HTTP::Request; my @idem_filters = qw( complete lines save tags ); plan tests => 2 + @idem_filters; my $proxy = HTTP::Proxy->new( port => 0 ); my $req = HTTP::Request->new( GET => 'http://www.vronk.com/' ); my $res = HTTP::Response->new( 200 ); $res->request( $req ); $res->content_type( 'text/html' ); $proxy->request( $req ); $proxy->response( $res ); # basic values for my $filter (@idem_filters) { $req->uri("http://www.$filter.com/"); $proxy->push_filter( response => "HTTP::Proxy::BodyFilter::$filter"->new ); $proxy->{body}{response}->select_filters($res); is( $proxy->{body}{response}->will_modify($res), 0, qq{Filter $filter won't change a thing} ); } # change the request info $req->uri( 'http://www.zlonk.com/' ); # filters that don't modify anything $proxy->push_filter( host => 'zlonk.com', response => HTTP::Proxy::BodyFilter::tags->new(), response => HTTP::Proxy::BodyFilter::complete->new(), ); $proxy->{body}{response}->select_filters( $res ); ok( !$proxy->{body}{response}->will_modify(), q{Filters won't change a thing} ); # simulate end of connection $proxy->{body}{response}->eod(); # add a filter that will change stuff $proxy->push_filter( host => 'zlonk.com', response => HTTP::Proxy::BodyFilter::simple->new( sub {} ), ); $proxy->{body}{response}->select_filters( $res ); ok( $proxy->{body}{response}->will_modify( $res ), q{Filters admit they will change something} ); unlink( 'www.zlonk.com' ); # cleanup file created by HPBF::save HTTP-Proxy-0.304/t/20dummy.t0000644000175000017500000000425612537671053014031 0ustar bookbookuse Test::More; use strict; # here are all the requests the client will try my @requests = qw( file1.txt directory/file2.txt ooh.cgi?q=query ); if( $^O eq 'MSWin32' ) { plan skip_all => "This test fails on MSWin32. HTTP::Proxy is usable on Win32 with maxchild => 0"; exit; } plan tests => 3 * @requests + 1; use LWP::UserAgent; use HTTP::Proxy; use t::Utils; # some helper functions for the server my $test = Test::Builder->new; # this is to work around tests in forked processes $test->use_numbers(0); $test->no_ending(1); # create a HTTP::Daemon (on an available port) my $server = server_start(); my $serverurl = $server->url; my $proxy = HTTP::Proxy->new( port => 0, max_connections => scalar @requests ); $proxy->init; # required to access the url later $proxy->agent->no_proxy( URI->new( $server->url )->host ); my $proxyurl = $proxy->url; # fork the HTTP server my @pids; my $pid = fork; die "Unable to fork web server" if not defined $pid; if ( $pid == 0 ) { # the answer method my $answer = sub { my $req = shift; my $data = shift; my $re = quotemeta $data; like( $req->uri, qr/$re/, "The daemon got what it expected" ); return HTTP::Response->new( 200, 'OK', HTTP::Headers->new( 'Content-Type' => 'text/plain' ), "Here is $data." ); }; # let's return some files when asked for them server_next( $server, $answer, $_ ) for @requests; exit 0; } # back in the parent push @pids, $pid; # remember the kid # fork a HTTP proxy $pid = fork_proxy( $proxy, sub { is( $proxy->conn, scalar @requests, "The proxy served the correct number of connections" ); } ); # back in the parent push @pids, $pid; # remember the kid # run a client my $ua = LWP::UserAgent->new; $ua->proxy( http => $proxyurl ); for (@requests) { my $req = HTTP::Request->new( GET => $serverurl . $_ ); my $rep = $ua->simple_request($req); ok( $rep->is_success, "Got an answer (@{[$rep->status_line]})" ); my $re = quotemeta; like( $rep->content, qr/$re/, "The client got what it expected" ); } # make sure both kids are dead wait for @pids; HTTP-Proxy-0.304/t/61simple.t0000644000175000017500000000340412537671053014166 0ustar bookbookuse Test::More tests => 14; use strict; use HTTP::Proxy::BodyFilter::simple; my ( $filter, $sub ); # error checking eval { $filter = HTTP::Proxy::BodyFilter::simple->new() }; like( $@, qr/^Constructor called without argument/, "Need at least one arg" ); eval { $filter = HTTP::Proxy::BodyFilter::simple->new("foo") }; like( $@, qr/^Single parameter must be a CODE reference/, "Single coderef" ); eval { $filter = HTTP::Proxy::BodyFilter::simple->new( filter => "foo" ) }; like( $@, qr/^Parameter to filter must be a CODE reference/, "Need coderef" ); eval { $filter = HTTP::Proxy::BodyFilter::simple->new( typo => sub { } ); }; like( $@, qr/Unkown method typo/, "Incorrect method name" ); for (qw( filter begin end )) { eval { $filter = HTTP::Proxy::BodyFilter::simple->new( $_ => sub { } ); }; is( $@, '', "Accept $_" ); } $sub = sub { my ( $self, $dataref, $message, $protocol, $buffer ) = @_; $$dataref =~ s/foo/bar/g; }; $filter = HTTP::Proxy::BodyFilter::simple->new($sub); is( $filter->can('filter'), $sub, "filter() runs the correct filter" ); ok( $filter->will_modify(), 'will_modify() defaults to true' ); # will_modify() $filter = HTTP::Proxy::BodyFilter::simple->new( filter => $sub, will_modify => 42 ); is( $filter->will_modify(), 42, 'will_modify() returns the given data' ); # test the filter for ( [ "\nfoo\n", "", "\nbar\n", "" ], HTTP::Proxy::BodyFilter::simple->new( end => sub {} ), [ "\nfoo\n", "", "\nfoo\n", "" ], ) { $filter = $_, next if ref $_ eq 'HTTP::Proxy::BodyFilter::simple'; my ( $data, $buffer ) = @$_[ 0, 1 ]; $filter->filter( \$data, undef, undef, ( defined $buffer ? \$buffer : undef ) ); is( $data, $_->[2], "Correct data" ); is( $buffer, $_->[3], "Correct buffer" ); } HTTP-Proxy-0.304/t/15accessors.t0000644000175000017500000000566012537671053014667 0ustar bookbookuse Test::More; use HTTP::Proxy qw( :log ); my $proxy; $proxy = HTTP::Proxy->new; # # default values # my %meth = ( agent => undef, chunk => 4096, daemon => undef, host => 'localhost', logfh => *main::STDERR, max_connections => 0, max_keep_alive_requests => 10, port => 8080, request => undef, response => undef, hop_headers => undef, logmask => 0, x_forwarded_for => 1, conn => 0, client_socket => undef, # loop is not used/internal for now ); plan tests => 16 + keys %meth; for my $key ( sort keys %meth ) { no strict 'refs'; is( $proxy->$key(), $meth{$key}, "$key has the correct default" ); } like( $proxy->via(), qr!\(HTTP::Proxy/$HTTP::Proxy::VERSION\)$!, "via has the correct default"); { my $my_via_proxy = HTTP::Proxy->new( via => 'VIA!VIA!VIA!' ); is( $my_via_proxy->via(), 'VIA!VIA!VIA!', 'custom via' ); } # test deprecated accessors $proxy = HTTP::Proxy->new( maxserve => 127, maxconn => 255 ); is( $proxy->max_keep_alive_requests, 127, "deprecated maxserve"); is( $proxy->max_connections, 255, "deprecated maxconn"); # # test generated accessors (they're all the same) # is( $proxy->port(8888), $meth{port}, "Set return the previous value" ); is( $proxy->port, 8888, "Set works" ); # # other accessors # $proxy->max_clients( 666 ); is( $proxy->engine->max_clients, 666, "max_clients correctly delegated" ); # check the url() method $proxy->port(0); # this spits a (normal) warning, but we clean it away { local *OLDERR; # swap errputs open OLDERR, ">&STDERR" or die "Could not duplicate STDERR: $!"; close STDERR; # the actual test is( $proxy->url, undef, "We do not have a url yet" ); # put things back to normal close STDERR; open STDERR, ">&OLDERR" or die "Could not duplicate OLDERR: $!"; close OLDERR; } $proxy->_init_daemon; ok( $proxy->url =~ '^$http://' . $proxy->host . ':\d+/$', "url looks good" ); # check the timeout $proxy->_init_agent; is( $proxy->agent->timeout, 60, "Default agent timeout of 60 secs" ); is( $proxy->timeout(120), 60, "timeout() returns the old value" ); is( $proxy->agent->timeout, 120, "New agent timeout value of 120 secs" ); # # the known_methods() method # my @all = $proxy->known_methods(); my @http = $proxy->known_methods('HTTP'); is_deeply( \@http, [ $proxy->known_methods('http') ], 'known_methods() is case insensitive' ); my %dav = map { $_ => 1 } $proxy->known_methods('webdav'); my %delta = map { $_ => 1 } $proxy->known_methods('DelTaV'); is( scalar grep( { $dav{$_} } @http ), scalar @http, 'WebDAV contains HTTP' ); is( scalar grep( { $delta{$_} } keys %dav ), scalar keys %dav, 'DeltaV contains WebDAV' ); my %all = ( %dav, %delta, map { $_ => 1 } @http ); is_deeply( [ sort keys %all ], [ sort @all ], 'know_methods() returns all methods' ); HTTP-Proxy-0.304/t/23connect.t0000644000175000017500000000413612537671053014327 0ustar bookbookuse Test::More; use strict; use t::Utils; use HTTP::Proxy; use LWP::UserAgent; use IO::Socket::INET; plan skip_all => "This test fails on MSWin32. HTTP::Proxy is usable on Win32 with maxchild => 0" if $^O eq 'MSWin32'; # make sure we inherit no upstream proxy delete $ENV{$_} for qw( http_proxy HTTP_PROXY https_proxy HTTPS_PROXY ); # test CONNECT my $test = Test::Builder->new; # this is to work around tests in forked processes $test->use_numbers(0); $test->no_ending(1); # fork a local server that'll print a banner on connection my $host; my $banner = "President_of_Earth Barbarella Professor_Ping Stomoxys Dildano\n"; { my $server = IO::Socket::INET->new( Listen => 1 ); plan 'skip_all', "Couldn't create local server" if !defined $server; $host = 'localhost:' . $server->sockport; my $pid = fork; plan 'skip_all', "Couldn't fork" if !defined $pid; if ( !$pid ) { my $sock = $server->accept; $sock->print($banner); $sock->close; exit; } } plan tests => 4; { my $proxy = HTTP::Proxy->new( port => 0, max_connections => 1 ); $proxy->init; # required to access the url later # fork a HTTP proxy my $pid = fork_proxy( $proxy, sub { ok( $proxy->conn == 1, "Served the correct number of requests" ); } ); # run a client my $ua = LWP::UserAgent->new; $ua->proxy( http => $proxy->url ); my $req = HTTP::Request->new( CONNECT => "http://$host/" ); my $res = $ua->request($req); my $sock = $res->{client_socket}; if ( !$sock->blocking ) { diag("socket is non blocking, switching to blocking mode"); $sock->blocking(1); } # what does the proxy say? is( $res->code, 200, "The proxy accepts CONNECT requests" ); # read a line my $read; eval { local $SIG{ALRM} = sub { die 'timeout' }; alarm 30; $read = <$sock>; }; ok( $read, "Read some data from the socket" ); is( $read, $banner, "CONNECTed to the TCP server and got the banner" ); close $sock; # make sure the kids are dead wait for 1 .. 2; } HTTP-Proxy-0.304/t/README0000644000175000017500000000576412537671053013234 0ustar bookbookREADME file for the HTTP::Proxy tests * Helper modules HTTP::Proxy can test itself without using the network, thanks to the HTTP::Daemon module. But since I want to test the proxy against "real" servers, I also need to test it with an internet connection. localhost tests work as follows: - a HTTP::Daemon is created and forked, that will serve a certain number of simple requests - a HTTP::Proxy is created and forked - a LWP::UserAgent is created and connects to the proxy - each of those process can run its own tests independantly, thanks to Test::More The t/Utils.pm files (use t::Utils in some test files) exports several functions: - server_start() starts a new HTTP::Daemon - server_next( [ \&answer ] ) returns the next response from the server (accepts a coderef) - fork_proxy( $proxy, [ \&end ] ) fork a proxy server passed as an argument, with an optionnel subroutine to run at the end - web_ok() test if the actual WWW is available for testing - bare_request( $url, $headers, $proxy ) send a simple request through the proxy without LWP::UA return a string containing the full response * Test categories The tests are prefixed with a number, which indicates several categories: 0x - Basic tests t/00basic.t - use HTTP::Proxy works t/01pod.t - the POD is correct t/05new.t - the HTTP::Proxy constructor 1x - Minimal functionnality tests t/10init.t - the proxy initialisation t/11log.t - the log() and logmask() methods t/15accessors.t - the proxy accessors t/17fstack.t - the internal HTTP::Proxy::FilterStack object 2x - Network protocols test t/20dummy.t - tests against a dummy web server t/20keepalive.t - test the keep-alive connections t/22http.t - test actual HTTP servers t/22transparent.t - test transparent proxying t/23connect.t - test CONNECT to a ssh server t/23https.t - test CONNECT for SSL 3x - (Reserved for future use) 4x - Filter-related functions t/40push_filters.t - the push_filter method 5x - Internal header filters t/50hopbyhop.t - check hop-by-hop headers removal t/50standard.t - check other headers removal t/50via.t - check the Via: headers t/51simple.t - HTTP::Proxy::HeaderFilter::simple t/51simple2.t - HTTP::Proxy::HeaderFilter::simple with a real proxy 6x - Internal body filters t/61simple.t - HTTP::Proxy::BodyFilter::simple t/61simple2.t - HTTP::Proxy::BodyFilter::simple with a real proxy t/64htmltext.t - HTTP::Proxy::BodyFilter::htmltext t/64lines.t - HTTP::Proxy::BodyFilter::lines t/64tags.t - HTTP::Proxy::BodyFilter::tags t/66htmlparser.t - HTTP::Proxy::BodyFilter::htmlparser 7x - Complex filter chains t/71rot13.t - a simple ROT13 filter set 8x - (Reserved for future use) 9x - miscellaneous tests t/90diveintomark.t - test the proxy against a lot of status codes HTTP-Proxy-0.304/t/05new.t0000644000175000017500000000152312537671053013464 0ustar bookbookuse Test::More tests => 10; use HTTP::Proxy qw( :log ); my $proxy; $proxy = HTTP::Proxy->new; # check for defaults is( $proxy->logmask, NONE, 'Default log mask' ); is( $proxy->port, 8080, 'Default port' ); is( $proxy->host, 'localhost', 'Default host' ); is( $proxy->agent, undef, 'Default agent' ); # new with arguments $proxy = HTTP::Proxy->new( port => 3128, host => 'foo', logmask => STATUS, ); is( $proxy->port, 3128, 'port set by new' ); is( $proxy->logmask, STATUS, 'verbosity set by new' ); is( $proxy->host, 'foo', 'host set by new' ); # check the accessors is( $proxy->logmask(NONE), STATUS, 'logmask accessor' ); is( $proxy->logmask, NONE, 'logmask changed by accessor' ); # check a read-only accessor my $conn = $proxy->conn; $proxy->conn( $conn + 100 ); is( $proxy->conn, $conn, 'read-only attribute' ); HTTP-Proxy-0.304/t/41filters.t0000644000175000017500000000070512537671053014344 0ustar bookbookuse Test::More tests => 2; use HTTP::Proxy; use HTTP::Proxy::HeaderFilter; use HTTP::Proxy::BodyFilter; my $proxy = HTTP::Proxy->new( port => 0 ); my $filter = HTTP::Proxy::HeaderFilter->new; $proxy->push_filter( request => $filter ); is( $filter->proxy, $proxy, "The HeaderFilter knows its proxy" ); $filter = HTTP::Proxy::BodyFilter->new; $proxy->push_filter( response => $filter ); is( $filter->proxy, $proxy, "The BodyFilter knows its proxy" ); HTTP-Proxy-0.304/t/64htmltext.t0000644000175000017500000000272312537671053014554 0ustar bookbookuse strict; use vars qw( @tokens ); BEGIN { @tokens = ( "\n", "\n", "\nVous Etes Perdu ?\n", "\n", "\n", "\n", "Perdu sur l'Internet ?", "\n", "Pas de panique, on va vous aider", "\n", " * ", "<-", "---- vous ", "tes ici", "\n", "\n", "\n\n" ); } use Test::More tests => 2 + scalar @tokens; use HTTP::Proxy::BodyFilter::htmltext; # the tests are in the HTTP::Proxy::BodyFilter::htmltext callback my $sub = sub { is( $_, shift (@tokens), "Correct text token matched" ); }; my $data = qq{\n\n\nVous Etes Perdu ?\n\n\n\n

Perdu sur l'Internet ?

\n

Pas de panique, on va vous aider

\n
    * <----- vous êtes ici
\n\n\n\n}; my $result = $data; # test the filter's parser my $filter = HTTP::Proxy::BodyFilter::htmltext->new($sub); $filter->filter( \$data, undef, undef, undef ); is( $data, $result, "Text data not modified" ); # test the result data when modified $result = $data = "

This is a test.

\n

Yes, a test

\n"; $result =~ s/test/foobar/g; $filter = HTTP::Proxy::BodyFilter::htmltext->new( sub { s/test/foobar/g } ); $filter->filter( \$data, undef, undef, undef ); is( $data, $result, "Text data correctly transformed" ); HTTP-Proxy-0.304/t/release-pod-coverage.t0000644000175000017500000000057212537671053016522 0ustar bookbook#!perl BEGIN { unless ($ENV{RELEASE_TESTING}) { require Test::More; Test::More::plan(skip_all => 'these tests are for release candidate testing'); } } # This file was automatically generated by Dist::Zilla::Plugin::PodCoverageTests. use Test::Pod::Coverage 1.08; use Pod::Coverage::TrustPod; all_pod_coverage_ok({ coverage_class => 'Pod::Coverage::TrustPod' }); HTTP-Proxy-0.304/META.yml0000644000175000017500000000417312537671053013353 0ustar bookbook--- abstract: 'A pure Perl HTTP proxy' author: - 'Philippe Bruhat (BooK) ' build_requires: ExtUtils::MakeMaker: '0' File::Find: '0' File::Spec: '0' File::Spec::Functions: '0' HTML::Parser: '3' HTTP::Headers: '0' HTTP::Request: '0' HTTP::Request::Common: '0' IO::Socket::INET: '0' Test::More: '0' base: '0' warnings: '0' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 0 generated_by: 'Dist::Zilla version 5.034, CPAN::Meta::Converter version 2.150001' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: HTTP-Proxy requires: Carp: '0' Exporter: '0' Fcntl: '0' File::Path: '0' File::Spec: '0' File::Temp: '0' HTTP::Daemon: '0' HTTP::Date: '0' HTTP::Headers::Util: '0' IO::Handle: '0' IO::Select: '0' LWP::ConnCache: '0' LWP::UserAgent: '0' POSIX: '0' Socket: '0' Sys::Hostname: '0' constant: '0' strict: '0' vars: '0' resources: bugtracker: http://rt.cpan.org/NoAuth/Bugs.html?Dist=HTTP-Proxy repository: http://github.com/book/HTTP-Proxy.git version: '0.304' x_contributors: - e477 - 'Vincenzo Buttazzo ' - 'Slaven Rezic ' - 'Tom Hukins ' - 'Salve J. Nilsen ' - 'Masahiro Nagano ' - 'Ashley Pond V ' - 'Angelos Karageorgiou ' - 'Gregor Herrmann ' - 'Maurice Aubrey' - 'Marek Rouchal ' - Jimbo - 'Roland Stigge' - 'Gunnar Wolf ' - 'Matsuno Tokuhiro ' - 'Ken Williams ' - 'Max Maischein ' - 'Mark Tilford' - 'Chris Dolan ' - 'Randal L. Schwartz ' - 'Simon Cozens ' - 'Christian Laursen' - 'Emmanuel Di Prétoro ' - 'Mathieu Arnold ' - 'Paul Makepeace ' - 'Martin Zdila' - 'Jim Cromie ' - 'Stéphane Payrard ' - 'David Landgren ' - 'Éric Cholet ' HTTP-Proxy-0.304/META.json0000644000175000017500000000672012537671053013523 0ustar bookbook{ "abstract" : "A pure Perl HTTP proxy", "author" : [ "Philippe Bruhat (BooK) " ], "dynamic_config" : 0, "generated_by" : "Dist::Zilla version 5.034, CPAN::Meta::Converter version 2.150001", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "HTTP-Proxy", "prereqs" : { "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "develop" : { "requires" : { "Pod::Coverage::TrustPod" : "0", "Test::CPAN::Meta" : "0", "Test::Pod" : "1.41", "Test::Pod::Coverage" : "1.08" } }, "runtime" : { "requires" : { "Carp" : "0", "Exporter" : "0", "Fcntl" : "0", "File::Path" : "0", "File::Spec" : "0", "File::Temp" : "0", "HTTP::Daemon" : "0", "HTTP::Date" : "0", "HTTP::Headers::Util" : "0", "IO::Handle" : "0", "IO::Select" : "0", "LWP::ConnCache" : "0", "LWP::UserAgent" : "0", "POSIX" : "0", "Socket" : "0", "Sys::Hostname" : "0", "constant" : "0", "strict" : "0", "vars" : "0" } }, "test" : { "recommends" : { "CPAN::Meta" : "2.120900" }, "requires" : { "ExtUtils::MakeMaker" : "0", "File::Find" : "0", "File::Spec" : "0", "File::Spec::Functions" : "0", "HTML::Parser" : "3", "HTTP::Headers" : "0", "HTTP::Request" : "0", "HTTP::Request::Common" : "0", "IO::Socket::INET" : "0", "Test::More" : "0", "base" : "0", "warnings" : "0" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "mailto" : "bug-http-proxy@rt.cpan.org", "web" : "http://rt.cpan.org/NoAuth/Bugs.html?Dist=HTTP-Proxy" }, "repository" : { "type" : "git", "url" : "http://github.com/book/HTTP-Proxy.git", "web" : "http://github.com/book/HTTP-Proxy" } }, "version" : "0.304", "x_contributors" : [ "e477", "Vincenzo Buttazzo ", "Slaven Rezic ", "Tom Hukins ", "Salve J. Nilsen ", "Masahiro Nagano ", "Ashley Pond V ", "Angelos Karageorgiou ", "Gregor Herrmann ", "Maurice Aubrey", "Marek Rouchal ", "Jimbo", "Roland Stigge", "Gunnar Wolf ", "Matsuno Tokuhiro ", "Ken Williams ", "Max Maischein ", "Mark Tilford", "Chris Dolan ", "Randal L. Schwartz ", "Simon Cozens ", "Christian Laursen", "Emmanuel Di Prétoro ", "Mathieu Arnold ", "Paul Makepeace ", "Martin Zdila", "Jim Cromie ", "Stéphane Payrard ", "David Landgren ", "Éric Cholet " ] } HTTP-Proxy-0.304/dist.ini0000644000175000017500000000434312537671053013545 0ustar bookbookname = HTTP-Proxy author = Philippe Bruhat (BooK) license = Perl_5 copyright_holder = Philippe Bruhat (BooK) ; copyright_year = 2002-2015 [PkgVersion] [@Filter] -bundle = @Basic -remove = Readme [PruneFiles] filename = setup filename = TODO match = \.patch$ match = mess/.* match = cover_db match = html/.* [AutoPrereqs] [Prereqs / TestRequires] HTML::Parser = 3 [Test::ReportPrereqs] [MetaResources] repository.web = http://github.com/book/HTTP-Proxy repository.url = http://github.com/book/HTTP-Proxy.git repository.type = git bugtracker.web = http://rt.cpan.org/NoAuth/Bugs.html?Dist=HTTP-Proxy bugtracker.mailto = bug-http-proxy@rt.cpan.org [MetaJSON] [MetaTests] [PodSyntaxTests] [PodCoverageTests] [NextRelease] format = %v %{EEE MMM d yyyy}d [@Git] changelog = Changes commit_msg = Changes for version %v tag_format = v%v tag_message = %N v%v push_to = origin push_to = github [Git::NextVersion] [Meta::Contributors] contributor = e477 contributor = Vincenzo Buttazzo contributor = Slaven Rezic contributor = Tom Hukins contributor = Salve J. Nilsen contributor = Masahiro Nagano contributor = Ashley Pond V contributor = Angelos Karageorgiou contributor = Gregor Herrmann contributor = Maurice Aubrey contributor = Marek Rouchal contributor = Jimbo contributor = Roland Stigge contributor = Gunnar Wolf contributor = Matsuno Tokuhiro contributor = Ken Williams contributor = Max Maischein contributor = Mark Tilford contributor = Chris Dolan contributor = Randal L. Schwartz contributor = Simon Cozens contributor = Christian Laursen contributor = Emmanuel Di Prétoro contributor = Mathieu Arnold contributor = Paul Makepeace contributor = Martin Zdila contributor = Jim Cromie contributor = Stéphane Payrard contributor = David Landgren contributor = Éric Cholet HTTP-Proxy-0.304/MANIFEST0000644000175000017500000000322112537671053013224 0ustar bookbook# This file was automatically generated by Dist::Zilla::Plugin::Manifest v5.034. Changes LICENSE MANIFEST META.json META.yml Makefile.PL README dist.ini eg/README eg/adblock.pl eg/anonymiser.pl eg/ayb.pl eg/bork.pl eg/dragon.pl eg/flv.pl eg/fudd.pl eg/https.pl eg/javascript.pl eg/js.pl eg/leet.pl eg/logger.pl eg/outline.pl eg/pdf.pl eg/perlmonks.pl eg/post.pl eg/proxy-auth.pl eg/proxy.pl eg/rainbow.pl eg/rfc.pl eg/rot13.pl eg/switch.pl eg/tracker.pl eg/trim.pl eg/yahoogroups.pl lib/HTTP/Proxy.pm lib/HTTP/Proxy/BodyFilter.pm lib/HTTP/Proxy/BodyFilter/complete.pm lib/HTTP/Proxy/BodyFilter/htmlparser.pm lib/HTTP/Proxy/BodyFilter/htmltext.pm lib/HTTP/Proxy/BodyFilter/lines.pm lib/HTTP/Proxy/BodyFilter/save.pm lib/HTTP/Proxy/BodyFilter/simple.pm lib/HTTP/Proxy/BodyFilter/tags.pm lib/HTTP/Proxy/Engine.pm lib/HTTP/Proxy/Engine/Legacy.pm lib/HTTP/Proxy/Engine/NoFork.pm lib/HTTP/Proxy/Engine/ScoreBoard.pm lib/HTTP/Proxy/Engine/Threaded.pm lib/HTTP/Proxy/FilterStack.pm lib/HTTP/Proxy/HeaderFilter.pm lib/HTTP/Proxy/HeaderFilter/simple.pm lib/HTTP/Proxy/HeaderFilter/standard.pm t/00-report-prereqs.dd t/00-report-prereqs.t t/00basic.t t/05new.t t/10init.t t/11log.t t/15accessors.t t/15deprecated.t t/16stash.t t/17fstack.t t/18engine.t t/20dummy.t t/20keepalive.t t/22http.t t/22transparent.t t/23connect.t t/23https.t t/40push_filters.t t/41filters.t t/42will_modify.t t/50hopbyhop.t t/50standard.t t/50via.t t/51simple.t t/51simple2.t t/61simple.t t/61simple2.t t/64htmltext.t t/64lines.t t/64tags.t t/66htmlparser.t t/67complete.t t/67save.t t/71rot13.t t/90httpstatus.t t/README t/Utils.pm t/release-distmeta.t t/release-pod-coverage.t t/release-pod-syntax.t t/test.html HTTP-Proxy-0.304/Makefile.PL0000644000175000017500000000440512537671053014052 0ustar bookbook# This file was automatically generated by Dist::Zilla::Plugin::MakeMaker v5.034. use strict; use warnings; use ExtUtils::MakeMaker; my %WriteMakefileArgs = ( "ABSTRACT" => "A pure Perl HTTP proxy", "AUTHOR" => "Philippe Bruhat (BooK) ", "CONFIGURE_REQUIRES" => { "ExtUtils::MakeMaker" => 0 }, "DISTNAME" => "HTTP-Proxy", "EXE_FILES" => [], "LICENSE" => "perl", "NAME" => "HTTP::Proxy", "PREREQ_PM" => { "Carp" => 0, "Exporter" => 0, "Fcntl" => 0, "File::Path" => 0, "File::Spec" => 0, "File::Temp" => 0, "HTTP::Daemon" => 0, "HTTP::Date" => 0, "HTTP::Headers::Util" => 0, "IO::Handle" => 0, "IO::Select" => 0, "LWP::ConnCache" => 0, "LWP::UserAgent" => 0, "POSIX" => 0, "Socket" => 0, "Sys::Hostname" => 0, "constant" => 0, "strict" => 0, "vars" => 0 }, "TEST_REQUIRES" => { "ExtUtils::MakeMaker" => 0, "File::Find" => 0, "File::Spec" => 0, "File::Spec::Functions" => 0, "HTML::Parser" => 3, "HTTP::Headers" => 0, "HTTP::Request" => 0, "HTTP::Request::Common" => 0, "IO::Socket::INET" => 0, "Test::More" => 0, "base" => 0, "warnings" => 0 }, "VERSION" => "0.304", "test" => { "TESTS" => "t/*.t" } ); my %FallbackPrereqs = ( "Carp" => 0, "Exporter" => 0, "ExtUtils::MakeMaker" => 0, "Fcntl" => 0, "File::Find" => 0, "File::Path" => 0, "File::Spec" => 0, "File::Spec::Functions" => 0, "File::Temp" => 0, "HTML::Parser" => 3, "HTTP::Daemon" => 0, "HTTP::Date" => 0, "HTTP::Headers" => 0, "HTTP::Headers::Util" => 0, "HTTP::Request" => 0, "HTTP::Request::Common" => 0, "IO::Handle" => 0, "IO::Select" => 0, "IO::Socket::INET" => 0, "LWP::ConnCache" => 0, "LWP::UserAgent" => 0, "POSIX" => 0, "Socket" => 0, "Sys::Hostname" => 0, "Test::More" => 0, "base" => 0, "constant" => 0, "strict" => 0, "vars" => 0, "warnings" => 0 ); unless ( eval { ExtUtils::MakeMaker->VERSION(6.63_03) } ) { delete $WriteMakefileArgs{TEST_REQUIRES}; delete $WriteMakefileArgs{BUILD_REQUIRES}; $WriteMakefileArgs{PREREQ_PM} = \%FallbackPrereqs; } delete $WriteMakefileArgs{CONFIGURE_REQUIRES} unless eval { ExtUtils::MakeMaker->VERSION(6.52) }; WriteMakefile(%WriteMakefileArgs); HTTP-Proxy-0.304/lib/0000755000175000017500000000000012537671053012643 5ustar bookbookHTTP-Proxy-0.304/lib/HTTP/0000755000175000017500000000000012537671053013422 5ustar bookbookHTTP-Proxy-0.304/lib/HTTP/Proxy/0000755000175000017500000000000012537671053014543 5ustar bookbookHTTP-Proxy-0.304/lib/HTTP/Proxy/Engine/0000755000175000017500000000000012537671053015750 5ustar bookbookHTTP-Proxy-0.304/lib/HTTP/Proxy/Engine/ScoreBoard.pm0000644000175000017500000002021012537671053020324 0ustar bookbookpackage HTTP::Proxy::Engine::ScoreBoard; $HTTP::Proxy::Engine::ScoreBoard::VERSION = '0.304'; use strict; use POSIX ":sys_wait_h"; # WNOHANG use Fcntl qw(LOCK_UN LOCK_EX); use IO::Handle; use File::Temp; use HTTP::Proxy; our @ISA = qw( HTTP::Proxy::Engine ); our %defaults = ( start_servers => 4, # start this many, and don't go below max_clients => 12, # don't go above max_requests_per_child => 250, # just in case there's a leak min_spare_servers => 1, # minimum idle (if 0, never start new) max_spare_servers => 12, # maximum idle (should be "single browser max") verify_delay => 60, # minimum time between kids verification ); __PACKAGE__->make_accessors( qw( kids select status_read status_write scoreboard tempfile verify_live_kids_time last_active_time last_fork_time ), keys %defaults ); sub start { my $self = shift; $self->kids( {} ); # set up the communication pipe $self->status_read( IO::Handle->new() ); $self->status_write( IO::Handle->new() ); pipe( $self->status_read(), $self->status_write() ) or die "Can't create pipe: $!"; $self->status_write()->autoflush(1); $self->select( IO::Select->new( $self->status_read() ) ); setpgrp; # set as group leader # scoreboard information $self->verify_live_kids_time( time ); $self->last_active_time( time ); $self->last_fork_time( time ); $self->scoreboard( '' ); # lockfile information $self->tempfile( File::Temp->new( UNLINK => 0, TEMPLATE => 'http-proxy-XXXX' ) ); $self->proxy()->log( HTTP::Proxy::ENGINE, "ENGINE", "Using " . $self->tempfile()->filename() . " as lockfile" ); } my %status = ( A => 'Acccept', B => 'Busy', I => 'Idle' ); sub run { my $self = shift; my $proxy = $self->proxy(); my $kids = $self->kids(); ## first phase: update scoreboard if ( $self->select()->can_read(1) ) { $self->status_read()->sysread( my $buf, 50 ) > 0 # read first 10 changes or die "bad read"; # FIXME while ( length $buf ) { my ( $pid, $status ) = unpack "NA", substr( $buf, 0, 5, "" ); $proxy->log( HTTP::Proxy::ENGINE, 'ENGINE', "Child process $pid updated to $status ($status{$status})" ); $kids->{$pid} = $status; } $self->last_active_time(time); } { my $new = join "", values %$kids; if ( $new ne $self->scoreboard() ) { $proxy->log( HTTP::Proxy::ENGINE, 'ENGINE', "ScoreBoard = $new" ); $self->scoreboard($new); } } ## second phase: delete dead kids while ( ( my $kid = waitpid( -1, WNOHANG ) ) > 0 ) { $proxy->{conn}++; # Cannot use the interface for RO attributes $proxy->log( HTTP::Proxy::PROCESS, 'PROCESS', "Reaped child process $kid" ); $proxy->log( HTTP::Proxy::PROCESS, "PROCESS", keys(%$kids) . " remaining kids: @{[ keys %$kids ]}" ); delete $kids->{$kid}; } ## third phase: verify live kids if ( time > $self->verify_live_kids_time() + $self->verify_delay() ) { for my $kid ( keys %$kids ) { next if kill 0, $kid; # shouldn't happen normally $proxy->log( HTTP::Proxy::ERROR, "ENGINE", "Child process $kid found missing" ); delete $kids->{$kid}; } $self->verify_live_kids_time(time); } ## fourth phase: launch kids my @idlers = grep $kids->{$_} eq "I", keys %$kids; if ( ( @idlers < $self->min_spare_servers() # not enough idlers or keys %$kids < $self->start_servers() # not enough overall ) and keys %$kids < $self->max_clients() # not too many please and time > $self->last_fork_time() # not too fast please ) { my $child = fork(); if ( !defined $child ) { $proxy->log( HTTP::Proxy::ERROR, "PROCESS", "Cannot fork" ); } else { if ($child) { $proxy->log( HTTP::Proxy::PROCESS, "PROCESS", "Forked child process $child" ); $kids->{$child} = "I"; $self->last_fork_time(time); } else { # child process $self->_run_child(); exit; # we're done } } } elsif ( ( @idlers > $self->max_spare_servers() # too many idlers or @idlers > $self->min_spare_servers() # too many lazy idlers and time > $self->last_active_time + $self->verify_delay() ) and keys %$kids > $self->start_servers() # not too few please ) { my $victim = $idlers[ rand @idlers ]; $proxy->log( HTTP::Proxy::ENGINE, "ENGINE", "Killing idle child process $victim" ); kill INT => $victim; # pick one at random $self->last_active_time(time); } } sub stop { my $self = shift; my $kids = $self->kids(); my $proxy = $self->proxy(); kill 'INT' => keys %$kids; # wait for remaining children while (%$kids) { my $pid = waitpid( -1, WNOHANG ); next unless $pid; $proxy->{conn}++; # WRONG for this engine! delete $kids->{$pid}; $proxy->log( HTTP::Proxy::PROCESS, "PROCESS", "Reaped child process $pid" ); $proxy->log( HTTP::Proxy::PROCESS, "PROCESS", keys(%$kids) . " remaining kids: @{[ keys %$kids ]}" ); } # remove the temporary file unlink $self->tempfile()->filename() or do { $proxy->log( HTTP::Proxy::ERROR, "ERROR", "Can't unlink @{[ $self->tempfile()->filename() ]}: $!" ); }; } sub _run_child { my $self = shift; my $proxy = $self->proxy(); my $daemon = $proxy->daemon(); my $status_write = $self->status_write(); open my $lockfh, $self->tempfile()->filename() or do { $proxy->log( HTTP::Proxy::ERROR, "ERROR", "Cannot open lock file: $!" ); exit; }; my $did = 0; # processed count while ( ++$did <= $self->max_requests_per_child() ) { flock $lockfh, LOCK_EX or do { $proxy->log( HTTP::Proxy::ERROR, "ERROR", "Cannot get flock: $!" ); exit; }; last unless $proxy->loop(); 5 == syswrite $status_write, pack "NA", $$, "A" # go accept or $proxy->log( HTTP::Proxy::ERROR, "ERROR", "status A: short write"); my $slave = $daemon->accept() or do { $proxy->log( HTTP::Proxy::ERROR, "ERROR", "Cannot accept: $!"); exit; }; flock $lockfh, LOCK_UN or do { $proxy->log( HTTP::Proxy::ERROR, "ERROR", "Cannot unflock: $!" ); exit; }; 5 == syswrite $status_write, pack "NA", $$, "B" # go busy or $proxy->log( HTTP::Proxy::ERROR, "ERROR", "status B: short write"); $slave->autoflush(1); $proxy->serve_connections($slave); # the real work is done here close $slave; 5 == syswrite $status_write, pack "NA", $$, "I" # go idle or $proxy->log( HTTP::Proxy::ERROR, "ERROR", "status I: short write"); } } 1; __END__ =head1 NAME HTTP::Proxy::Engine::ScoreBoard - A scoreboard-based HTTP::Proxy engine =head1 SYNOPSIS my $proxy = HTTP::Proxy->new( engine => 'ScoreBoard' ); =head1 DESCRIPTION This module provides a scoreboard-based engine to L. =head1 METHODS The module defines the following methods, used by L main loop: =over 4 =item start() Initialise the engine. =item run() Implements the forking logic: a new process is forked for each new incoming TCP connection. =item stop() Reap remaining child processes. =back =head1 SEE ALSO L, L. =head1 AUTHOR Philippe "BooK" Bruhat, C<< >>. Many thanks to Randal L. Schwartz for his help in implementing this module. =head1 COPYRIGHT Copyright 2005-2015, Philippe Bruhat. =head1 LICENSE This module is free software; you can redistribute it or modify it under the same terms as Perl itself. =cut HTTP-Proxy-0.304/lib/HTTP/Proxy/Engine/Legacy.pm0000644000175000017500000001026212537671053017513 0ustar bookbookpackage HTTP::Proxy::Engine::Legacy; $HTTP::Proxy::Engine::Legacy::VERSION = '0.304'; use strict; use POSIX 'WNOHANG'; use HTTP::Proxy; our @ISA = qw( HTTP::Proxy::Engine ); our %defaults = ( max_clients => 12, ); __PACKAGE__->make_accessors( qw( kids select ), keys %defaults ); sub start { my $self = shift; $self->kids( [] ); $self->select( IO::Select->new( $self->proxy->daemon ) ); } sub run { my $self = shift; my $proxy = $self->proxy; my $kids = $self->kids; # check for new connections my @ready = $self->select->can_read(1); for my $fh (@ready) { # there's only one, anyway # single-process proxy (useful for debugging) if ( $self->max_clients == 0 ) { $proxy->max_keep_alive_requests(1); # do not block simultaneous connections $proxy->log( HTTP::Proxy::PROCESS, "PROCESS", "No fork allowed, serving the connection" ); $proxy->serve_connections($fh->accept); $proxy->new_connection; next; } if ( @$kids >= $self->max_clients ) { $proxy->log( HTTP::Proxy::ERROR, "PROCESS", "Too many child process, serving the connection" ); $proxy->serve_connections($fh->accept); $proxy->new_connection; next; } # accept the new connection my $conn = $fh->accept; my $child = fork; if ( !defined $child ) { $conn->close; $proxy->log( HTTP::Proxy::ERROR, "PROCESS", "Cannot fork" ); $self->max_clients( $self->max_clients - 1 ) if $self->max_clients > @$kids; next; } # the parent process if ($child) { $conn->close; $proxy->log( HTTP::Proxy::PROCESS, "PROCESS", "Forked child process $child" ); push @$kids, $child; } # the child process handles the whole connection else { $SIG{INT} = 'DEFAULT'; $proxy->serve_connections($conn); exit; # let's die! } } $self->reap_zombies if @$kids; } sub stop { my $self = shift; my $kids = $self->kids; # wait for remaining children # EOLOOP kill INT => @$kids; $self->reap_zombies while @$kids; } # private reaper sub sub reap_zombies { my $self = shift; my $kids = $self->kids; my $proxy = $self->proxy; while (1) { my $pid = waitpid( -1, WNOHANG ); last if $pid == 0 || $pid == -1; # AS/Win32 returns negative PIDs @$kids = grep { $_ != $pid } @$kids; $proxy->{conn}++; # Cannot use the interface for RO attributes $proxy->log( HTTP::Proxy::PROCESS, "PROCESS", "Reaped child process $pid" ); $proxy->log( HTTP::Proxy::PROCESS, "PROCESS", @$kids . " remaining kids: @$kids" ); } } 1; __END__ =head1 NAME HTTP::Proxy::Engine::Legacy - The "older" HTTP::Proxy engine =head1 SYNOPSIS my $proxy = HTTP::Proxy->new( engine => 'Legacy' ); =head1 DESCRIPTION This engine reproduces the older child creation algorithm of L. Angelos Karageorgiou C<< >> reports: I with the following trick:> max_keep_alive_requests(1); max_clients(120); $HTTP::VERSION(1.0); # just in case I Id requests!> =head1 METHODS The module defines the following methods, used by L main loop: =over 4 =item start() Initialise the engine. =item run() Implements the forking logic: a new process is forked for each new incoming TCP connection. =item stop() Reap remaining child processes. =back The following method is used by the engine internally: =over 4 =item reap_zombies() Process the dead child processes. =back =head1 SEE ALSO L, L. =head1 AUTHOR Philippe "BooK" Bruhat, C<< >>. =head1 COPYRIGHT Copyright 2005-2015, Philippe Bruhat. =head1 LICENSE This module is free software; you can redistribute it or modify it under the same terms as Perl itself. =cut HTTP-Proxy-0.304/lib/HTTP/Proxy/Engine/NoFork.pm0000644000175000017500000000270512537671053017510 0ustar bookbookpackage HTTP::Proxy::Engine::NoFork; $HTTP::Proxy::Engine::NoFork::VERSION = '0.304'; use strict; our @ISA = qw( HTTP::Proxy::Engine ); __PACKAGE__->make_accessors( 'select' ); sub start { my $self = shift; my $proxy = $self->proxy; $self->select( IO::Select->new( $proxy->daemon ) ); # clients will not block the proxy by keeping the connection open $proxy->max_keep_alive_requests( 1 ); } sub run { my $self = shift; my $proxy = $self->proxy; # check for new connections for my $fh ( $self->select->can_read() ) { # there's only one, anyway # single-process proxy $proxy->serve_connections( $fh->accept ); $proxy->new_connection; } } 1; __END__ =head1 NAME HTTP::Proxy::Engine::NoFork - A basic, non forking HTTP::Proxy engine =head1 SYNOPSIS use HTTP::Proxy; my $proxy = HTTP::Proxy->new( engine => 'NoFork' ); =head1 DESCRIPTION The L engine runs the proxy without forking. =head1 METHODS =over 4 =item start() Initialise the engine. =item run() Implements the non-forking logic by calling C<< $proxy->serve_requests() >> directly. =back =head1 SEE ALSO L, L. =head1 AUTHOR Philippe "BooK" Bruhat, C<< >>. =head1 COPYRIGHT Copyright 2005-2015, Philippe Bruhat. =head1 LICENSE This module is free software; you can redistribute it or modify it under the same terms as Perl itself. =cut HTTP-Proxy-0.304/lib/HTTP/Proxy/Engine/Threaded.pm0000644000175000017500000000474612537671053020041 0ustar bookbookpackage HTTP::Proxy::Engine::Threaded; $HTTP::Proxy::Engine::Threaded::VERSION = '0.304'; use strict; use HTTP::Proxy; my $can_use_threads; BEGIN { $can_use_threads = eval 'use threads; 1'; } # A massive hack of Engine::Fork to use the threads stuff # Basically created to work under win32 so that the filters # can share global caches among themselves # Angelos Karageorgiou angelos@unix.gr our @ISA = qw( HTTP::Proxy::Engine ); our %defaults = ( max_clients => 60, ); __PACKAGE__->make_accessors( qw( kids select ), keys %defaults ); sub new { die "This Perl not built to support threads" if !$can_use_threads; shift->SUPER::new(@_); } sub start { my $self = shift; $self->kids( [] ); $self->select( IO::Select->new( $self->proxy->daemon ) ); } sub run { my $self = shift; my $proxy = $self->proxy; my $kids = $self->kids; # check for new connections my @ready = $self->select->can_read(1); for my $fh (@ready) { # there's only one, anyway # single-process proxy (useful for debugging) # accept the new connection my $conn = $fh->accept; my $child=threads->new(\&_worker,$proxy,$conn); if ( !defined $child ) { $conn->close; $proxy->log( HTTP::Proxy::ERROR, "PROCESS", "Cannot spawn thread" ); next; } $child->detach(); } } sub stop { my $self = shift; my $kids = $self->kids; # not needed } sub _worker { my $proxy=shift; my $conn=shift; $proxy->serve_connections($conn); $conn->close(); return; } 1; __END__ =head1 NAME HTTP::Proxy::Engine::Threaded - A scoreboard-based HTTP::Proxy engine =head1 SYNOPSIS my $proxy = HTTP::Proxy->new( engine => 'Threaded' ); =head1 DESCRIPTION This module provides a threaded engine to L. =head1 METHODS The module defines the following methods, used by L main loop: =over 4 =item start() Initialize the engine. =item run() Implements the forking logic: a new process is forked for each new incoming TCP connection. =item stop() Reap remaining child processes. =back =head1 SEE ALSO L, L. =head1 AUTHORS Angelos Karageorgiou C<< >>. (Actual code) Philippe "BooK" Bruhat, C<< >>. (Documentation) =head1 COPYRIGHT Copyright 2010-2015, Philippe Bruhat. =head1 LICENSE This module is free software; you can redistribute it or modify it under the same terms as Perl itself. =cut HTTP-Proxy-0.304/lib/HTTP/Proxy/BodyFilter.pm0000644000175000017500000001702012537671053017144 0ustar bookbookpackage HTTP::Proxy::BodyFilter; $HTTP::Proxy::BodyFilter::VERSION = '0.304'; use strict; use Carp; sub new { my $class = shift; my $self = bless {}, $class; $self->init(@_) if $self->can('init'); return $self; } sub proxy { my ( $self, $new ) = @_; return $new ? $self->{_hpbf_proxy} = $new : $self->{_hpbf_proxy}; } sub filter { croak "HTTP::Proxy::HeaderFilter cannot be used as a filter"; } sub will_modify { 1 } # by default, we expect the filter to modify data 1; __END__ =head1 NAME HTTP::Proxy::BodyFilter - A base class for HTTP messages body filters =head1 SYNOPSIS package MyFilter; use base qw( HTTP::Proxy::BodyFilter ); # a simple modification, that may break things sub filter { my ( $self, $dataref, $message, $protocol, $buffer ) = @_; $$dataref =~ s/PERL/Perl/g; } 1; =head1 DESCRIPTION The L class is used to create filters for HTTP request/response body data. =head2 Creating a BodyFilter A BodyFilter is just a derived class that implements some methods called by the proxy. Of all the methods presented below, only C B be defined in the derived class. =over 4 =item filter() The signature of the filter() method is the following: sub filter { my ( $self, $dataref, $message, $protocol, $buffer ) = @_; ... } where C<$self> is the filter object, C<$dataref> is a reference to the chunk of body data received, C<$message> is a reference to either a L or a L object, and C<$protocol> is a reference to the L protocol object. Note that this subroutine signature looks a lot like that of the call- backs of L (except that C<$message> is either a L or a L object). C<$buffer> is a reference to a buffer where some of the unprocessed data can be stored for the next time the filter will be called (see L for details). Thanks to the built-in HTTP::Proxy::BodyFilter::* filters, this is rarely needed. It is possible to access the headers of the message with C<< $message->headers() >>. This L object is the one that was sent to the client (if the filter is on the response stack) or origin server (if the filter is on the request stack). Modifying it in the C method is useless, since the headers have already been sent. Since C<$dataref> is a I to the data string, the referent can be modified and the changes will be transmitted through the filters that follows, until the data reaches its recipient. A L object is a blessed hash, and the base class reserves only hash keys that start with C<_hpbf>. =item new() The constructor is defined for all subclasses. Initialisation tasks (if any) for subclasses should be done in the C method (see below). =item init() This method is called by the C constructeur to perform all initisalisation tasks. It's called once in the filter lifetime. It receives all the parameters passed to C. =item begin() Some filters might require initialisation before they are able to handle the data. If a C method is defined in your subclass, the proxy will call it before sending data to the C method. It's called once per HTTP message handled by the filter, before data processing begins. The method signature is as follows: sub begin { my ( $self, $message ) = @_ ... } =item end() Some filters might require finalisation after they are finished handling the data. If a C method is defined in your subclass, the proxy will call it after it has finished sending data to the C method. It's called once per HTTP message handled by the filter, after all data processing is done. This method does not expect any parameters. =item will_modify() This method return a boolean value that indicate if the filter will modify the body data on the fly. The default implementation returns a I value. =back =head2 Using a buffer to store data for a later use Some filters cannot handle arbitrary data: for example a filter that basically lowercases tag name will apply a simple regex such as C\s*(\w+)([^E]*)E/E\L$1\E$2E/g>. But the filter will fail is the chunk of data contains a tag that is cut before the final C>. It would be extremely complicated and error-prone to let each filter (and its author) do its own buffering, so the L architecture handles this too. The proxy passes to each filter, each time it is called, a reference to an empty string (C<$buffer> in the above signature) that the filter can use to store some data for next run. When the reference is C, it means that the filter cannot store any data, because this is the very last run, needed to gather all the data left in all buffers. It is recommended to store as little data as possible in the buffer, so as to avoid (badly) reproducing what L does. In particular, you have to remember that all the data that remains in the buffer after the last piece of data is received from the origin server will be sent back to your filter in one big piece. =head2 The store and forward approach L implements a I mechanism, for those filters which need to have the whole message body to work. It's enabled simply by pushing the L filter on the filter stack. The data is stored in memory by the "complete" filter, which passes it on to the following filter once the full message body has been received. =head2 Standard BodyFilters Standard L classes are lowercase. The following BodyFilters are included in the L distribution: =over 4 =item lines This filter makes sure that the next filter in the filter chain will only receive complete lines. The "chunks" of data received by the following filters with either end with C<\n> or will be the last piece of data for the current HTTP message body. =item htmltext This class lets you create a filter that runs a given code reference against text included in a HTML document (outside CscriptE> and CstyleE> tags). HTML entities are not included in the text. =item htmlparser Creates a filter from a HTML::Parser object. =item simple This class lets you create a simple body filter from a code reference. =item save Store the message body to a file. =item complete This filter stores the whole message body in memory, thus allowing some actions to be taken only when the full page has been received by the proxy. =item tags The L filter makes sure that the next filter in the filter chain will only receive complete tags. The current implementation is not 100% perfect, though. =back Please read each filter's documentation for more details about their use. =head1 USEFUL METHODS FOR SUBCLASSES Some methods are available to filters, so that they can eventually use the little knowledge they might have of HTTP::Proxy's internals. They mostly are accessors. =over 4 =item proxy() Gets a reference to the L objects that owns the filter. This gives access to some of the proxy methods. =back =head1 AUTHOR Philippe "BooK" Bruhat, Ebook@cpan.orgE. =head1 SEE ALSO L, L. =head1 COPYRIGHT Copyright 2003-2015, Philippe Bruhat. =head1 LICENSE This module is free software; you can redistribute it or modify it under the same terms as Perl itself. =cut HTTP-Proxy-0.304/lib/HTTP/Proxy/HeaderFilter/0000755000175000017500000000000012537671053017101 5ustar bookbookHTTP-Proxy-0.304/lib/HTTP/Proxy/HeaderFilter/simple.pm0000644000175000017500000000621112537671053020730 0ustar bookbookpackage HTTP::Proxy::HeaderFilter::simple; $HTTP::Proxy::HeaderFilter::simple::VERSION = '0.304'; use strict; use Carp; use HTTP::Proxy::HeaderFilter; use vars qw( @ISA ); @ISA = qw( HTTP::Proxy::HeaderFilter ); my $methods = join '|', qw( begin filter end ); $methods = qr/^(?:$methods)$/; sub init { my $self = shift; croak "Constructor called without argument" unless @_; if ( @_ == 1 ) { croak "Single parameter must be a CODE reference" unless ref $_[0] eq 'CODE'; $self->{_filter} = $_[0]; } else { $self->{_filter} = sub { }; # default while (@_) { my ( $name, $code ) = splice @_, 0, 2; # basic error checking croak "Parameter to $name must be a CODE reference" unless ref $code eq 'CODE'; croak "Unkown method $name" unless $name =~ $methods; $self->{"_$name"} = $code; } } } # transparently call the actual methods sub begin { goto &{ $_[0]{_begin} }; } sub filter { goto &{ $_[0]{_filter} }; } sub end { goto &{ $_[0]{_end} }; } sub can { my ( $self, $method ) = @_; return $method =~ $methods ? $self->{"_$method"} : UNIVERSAL::can( $self, $method ); } 1; __END__ =head1 NAME HTTP::Proxy::HeaderFilter::simple - A class for creating simple filters =head1 SYNOPSIS use HTTP::Proxy::HeaderFilter::simple; # a simple User-Agent filter my $filter = HTTP::Proxy::HeaderFilter::simple->new( sub { $_[1]->header( User_Agent => 'foobar/1.0' ); } ); $proxy->push_filter( request => $filter ); =head1 DESCRIPTION L can create BodyFilter without going through the hassle of creating a full-fledged class. Simply pass a code reference to the C method of your filter to the constructor, and you'll get the adequate filter. =head2 Constructor calling convention The constructor is called with a single code reference. The code reference must conform to the standard C signature for header filters: sub filter { my ( $self, $headers, $message) = @_; ... } This code reference is used for the C method. =head1 METHODS This filter "factory" defines the standard L methods, but those are only, erm, "proxies" to the actual CODE references passed to the constructor. These "proxy" methods are: =over 4 =item filter() =item begin() =item end() =back Two other methods are actually L methods, and are called automatically: =over 4 =item init() Initalise the filter instance with the code references passed to the constructor. =item can() Return the actual code reference that will be run, and not the "proxy" methods. If called with any other name than C and C, it calls C instead. =back =head1 SEE ALSO L, L. =head1 AUTHOR Philippe "BooK" Bruhat, Ebook@cpan.orgE. =head1 COPYRIGHT Copyright 2003-2015, Philippe Bruhat. =head1 LICENSE This module is free software; you can redistribute it or modify it under the same terms as Perl itself. =cut HTTP-Proxy-0.304/lib/HTTP/Proxy/HeaderFilter/standard.pm0000644000175000017500000001066612537671053021250 0ustar bookbookpackage HTTP::Proxy::HeaderFilter::standard; $HTTP::Proxy::HeaderFilter::standard::VERSION = '0.304'; use strict; use HTTP::Proxy; use HTTP::Headers::Util qw( split_header_words ); use HTTP::Proxy::HeaderFilter; use vars qw( @ISA ); @ISA = qw( HTTP::Proxy::HeaderFilter ); # known hop-by-hop headers my @hopbyhop = qw( Connection Keep-Alive Proxy-Authenticate Proxy-Authorization TE Trailers Transfer-Encoding Upgrade Proxy-Connection Public ); # standard proxy header filter (RFC 2616) sub filter { my ( $self, $headers, $message ) = @_; # the Via: header my $via = $message->protocol() || ''; if ( $self->proxy->via and $via =~ s!HTTP/!! ) { $via .= " " . $self->proxy->via; $headers->header( Via => join ', ', $message->headers->header('Via') || (), $via ); } # the X-Forwarded-For header $headers->push_header( X_Forwarded_For => $self->proxy->client_socket->peerhost ) if $message->isa( 'HTTP::Request' ) && $self->proxy->x_forwarded_for; # make a list of hop-by-hop headers my %h2h = map { (lc) => 1 } @hopbyhop; my $hop = HTTP::Headers->new(); my $client = HTTP::Headers->new(); $h2h{ lc $_->[0] } = 1 for map { split_header_words($_) } $headers->header('Connection'); # hop-by-hop headers are set aside # as well as LWP::UserAgent Client-* headers $headers->scan( sub { my ( $k, $v ) = @_; if ( $h2h{lc $k} ) { $hop->push_header( $k => $v ); $headers->remove_header($k); } if( $k =~ /^Client-/ ) { $client->push_header( $k => $v ); $headers->remove_header($k); } } ); # set the hop-by-hop and client headers in the proxy # only the end-to-end headers are left in the message $self->proxy->hop_headers($hop); $self->proxy->client_headers($client); # handle Max-Forwards if ( $message->isa('HTTP::Request') and defined $headers->header('Max-Forwards') ) { my ( $max, $method ) = ( $headers->header('Max-Forwards'), $message->method ); if ( $max == 0 ) { # answer directly TRACE ou OPTIONS if ( $method eq 'TRACE' ) { my $response = HTTP::Response->new( 200, 'OK', HTTP::Headers->new( Content_Type => 'message/http' , Content_Length => 0), $message->as_string ); $self->proxy->response($response); } elsif ( $method eq 'OPTIONS' ) { my $response = HTTP::Response->new(200); $response->header( Allow => join ', ', @HTTP::Proxy::METHODS ); $self->proxy->response($response); } } # The Max-Forwards header field MAY be ignored for all # other methods defined by this specification (RFC 2616) elsif ( $method =~ /^(?:TRACE|OPTIONS)/ ) { $headers->header( 'Max-Forwards' => --$max ); } } # no encoding accepted (gzip, compress, deflate) # if we plan to do anything with the response body $headers->remove_header( 'Accept-Encoding' ) if @{ $self->proxy->{body}{response}{filters} }; } 1; __END__ =head1 NAME HTTP::Proxy::HeaderFilter::standard - An internal filter to respect RFC2616 =head1 DESCRIPTION This is an internal filter used by HTTP::Proxy to enforce behaviour compliant with RFC 2616. =head1 METHOD This filter implements a single method that is called automatically: =over 4 =item filter() Enforce RFC 2616-compliant behaviour, by adding the C and C headers (except when the proxy was instructed not to add them), decrementing the C header and removing the hop-by-hop and L headers. Note that the filter will automatically remove the C headers if the proxy has at least one L filter. (This is to ensure that the filters will receive uncompressed data.) =back =head1 SEE ALSO L, L, RFC 2616. =head1 AUTHOR Philippe "BooK" Bruhat, Ebook@cpan.orgE. Thanks to Gisle Aas, for directions regarding the handling of the hop-by-hop headers. =head1 COPYRIGHT Copyright 2003-2015, Philippe Bruhat. =head1 LICENSE This module is free software; you can redistribute it or modify it under the same terms as Perl itself. =cut HTTP-Proxy-0.304/lib/HTTP/Proxy/Engine.pm0000644000175000017500000001006512537671053016310 0ustar bookbookpackage HTTP::Proxy::Engine; $HTTP::Proxy::Engine::VERSION = '0.304'; use strict; use Carp; my %engines = ( MSWin32 => 'NoFork', default => 'Legacy', ); # required accessors __PACKAGE__->make_accessors( qw( max_clients )); sub new { my $class = shift; my %params = @_; # the front-end if ( $class eq 'HTTP::Proxy::Engine' ) { my $engine = delete $params{engine}; $engine = $engines{$^O} || $engines{default} unless defined $engine; $class = "HTTP::Proxy::Engine::$engine"; eval "require $class"; croak $@ if $@; } # some error checking croak "No proxy defined" unless exists $params{proxy}; croak "$params{proxy} is not a HTTP::Proxy object" unless UNIVERSAL::isa( $params{proxy}, 'HTTP::Proxy' ); # so we are an actual engine no strict 'refs'; return bless { %{"$class\::defaults"}, %params }, $class; } # run() should be defined in subclasses sub run { my $self = shift; my $class = ref $self; croak "$class doesn't define a run() method"; } sub proxy { $_[0]{proxy} } # class method sub make_accessors { my $class = shift; for my $attr (@_) { no strict 'refs'; *{"$class\::$attr"} = sub { $_[0]{$attr} = $_[1] if defined $_[1]; $_[0]{$attr}; }; } } 1; __END__ =head1 NAME HTTP::Proxy::Engine - Generic child process manager engine for HTTP::Proxy =head1 SYNOPSIS use HTTP::Proxy; # use the default engine for your system my $proxy = HTTP::Proxy->new(); # choose one my $proxy = HTTP::Proxy->new( engine => 'Old' ); =head1 DESCRIPTION The L class is a front-end to actual proxy engine classes. The role of an engine is to implement the main fork+serve loop with all the required bookkeeping. This is also a good way to test various implementation and/or try out new algorithms without too much difficulties. =head1 METHODS =over 4 =item new() Create a new engine. The parameter C is used to decide which kind of engine will be created. Other parameters are passed to the underlying engine. This method also implement the subclasses constructor (they obviously do not need the C parameter). =back =head1 CREATING YOUR OWN ENGINE It is possible to create one's own engine, by creating a simple subclass of L with the following methods: =over 4 =item start() This method should handle any initialisation required when the engine starts. =item run() This method is the main loop of the master process. It defines how child processes are forked, checked and killed. The engine MUST have a run() method, and it will be called again and again until the proxy exits. C<< $self->proxy->daemon >> returns the listening socket that can C connections. The child must call C<< $self->proxy->serve_connections() >> on the returned socket to handle actual TCP connections. =item stop() This optional method should handle any cleanup procedures when the engine stops (typically when the main proxy process is killed). =back A subclass may also define a C<%defaults> hash (with C) that contains the default values for the fields used internaly. =head1 METHODS PROVIDED TO SUBCLASSES L provides the following methods to its subclasses: =over 4 =item proxy() Return the L object that runs the engine. =item max_clients() Get or set the maximum number of TCP clients, that is to say the maximum number of forked child process. Some engines may understand a value of C<0> as I. This is what L does. =item make_accessors( @names ) Create accessors named after C<@names> in the subclass package. All accessors are read/write. This is a utility method. B =back =head1 AUTHOR Philippe "BooK" Bruhat, C<< >>. =head1 COPYRIGHT Copyright 2005-2015, Philippe Bruhat. =head1 LICENSE This module is free software; you can redistribute it or modify it under the same terms as Perl itself. =cut HTTP-Proxy-0.304/lib/HTTP/Proxy/BodyFilter/0000755000175000017500000000000012537671053016606 5ustar bookbookHTTP-Proxy-0.304/lib/HTTP/Proxy/BodyFilter/htmlparser.pm0000644000175000017500000000762412537671053021336 0ustar bookbookpackage HTTP::Proxy::BodyFilter::htmlparser; $HTTP::Proxy::BodyFilter::htmlparser::VERSION = '0.304'; use strict; use Carp; use HTTP::Proxy::BodyFilter; use vars qw( @ISA ); @ISA = qw( HTTP::Proxy::BodyFilter ); sub init { croak "First parameter must be a HTML::Parser object" unless $_[1]->isa('HTML::Parser'); my $self = shift; $self->{_parser} = shift; my %args = (@_); $self->{rw} = delete $args{rw}; } sub filter { my ( $self, $dataref, $message, $protocol, $buffer ) = @_; @{ $self->{_parser} }{qw( output message protocol )} = ( "", $message, $protocol ); $self->{_parser}->parse($$dataref); $self->{_parser}->eof if not defined $buffer; # last chunk $$dataref = $self->{_parser}{output} if $self->{rw}; } sub will_modify { $_[0]->{rw} } 1; __END__ =head1 NAME HTTP::Proxy::BodyFilter::htmlparser - Filter using HTML::Parser =head1 SYNOPSIS use HTTP::Proxy::BodyFilter::htmlparser; # $parser is a HTML::Parser object $proxy->push_filter( mime => 'text/html', response => HTTP::Proxy::BodyFilter::htmlparser->new( $parser ); ); =head1 DESCRIPTION The L lets you create a filter based on the L object of your choice. This filter takes a L object as an argument to its constructor. The filter is either read-only or read-write. A read-only filter will not allow you to change the data on the fly. If you request a read-write filter, you'll have to rewrite the response-body completely. With a read-write filter, you B recreate the whole body data. This is mainly due to the fact that the L has its own buffering system, and that there is no easy way to correlate the data that triggered the L event and its original position in the chunk sent by the origin server. See below for details. Note that a simple filter that modify the HTML text (not the tags) can be created more easily with L. =head2 Creating a HTML::Parser that rewrites pages A read-write filter is declared by passing C 1> to the constructor: HTTP::Proxy::BodyFilter::htmlparser->new( $parser, rw => 1 ); To be able to modify the body of a message, a filter created with L must rewrite it completely. The L object can update a special attribute named C. To do so, the L handler will have to request the C attribute (that is to say, require access to the parser itself) and update its C key. The following attributes are added to the L object by this filter: =over 4 =item output A string that will hold the data sent back by the proxy. This string will be used as a replacement for the body data only if the filter is read-write, that is to say, if it was initialised with C 1>. Data should always be B to C<$parser-E{output}>. =item message A reference to the L that triggered the filter. =item protocol A reference to the L object. =back =head1 METHODS This filter defines three methods, called automatically: =over 4 =item filter() The C method handles all the interactions with the L object. =item init() Initialise the filter with the HTML::Parser object passed to the constructor. =item will_modify() This method returns a boolean value that indicates to the system if it will modify the data passing through. The value is actually the value of the C parameter passed to the constructor. =back =head1 SEE ALSO L, L, L. =head1 AUTHOR Philippe "BooK" Bruhat, Ebook@cpan.orgE. =head1 COPYRIGHT Copyright 2003-2015, Philippe Bruhat. =head1 LICENSE This module is free software; you can redistribute it or modify it under the same terms as Perl itself. =cut HTTP-Proxy-0.304/lib/HTTP/Proxy/BodyFilter/simple.pm0000644000175000017500000001024012537671053020432 0ustar bookbookpackage HTTP::Proxy::BodyFilter::simple; $HTTP::Proxy::BodyFilter::simple::VERSION = '0.304'; use strict; use Carp; use HTTP::Proxy::BodyFilter; use vars qw( @ISA ); @ISA = qw( HTTP::Proxy::BodyFilter ); my $methods = join '|', qw( begin filter end will_modify ); $methods = qr/^(?:$methods)$/; sub init { my $self = shift; croak "Constructor called without argument" unless @_; $self->{_will_modify} = 1; if ( @_ == 1 ) { croak "Single parameter must be a CODE reference" unless ref $_[0] eq 'CODE'; $self->{_filter} = $_[0]; } else { $self->{_filter} = sub { }; # default while (@_) { my ( $name, $code ) = splice @_, 0, 2; # basic error checking croak "Parameter to $name must be a CODE reference" if $name ne 'will_modify' && ref $code ne 'CODE'; croak "Unkown method $name" unless $name =~ $methods; $self->{"_$name"} = $code; } } } # transparently call the actual methods sub begin { goto &{ $_[0]{_begin} }; } sub filter { goto &{ $_[0]{_filter} }; } sub end { goto &{ $_[0]{_end} }; } sub will_modify { return $_[0]{_will_modify} } sub can { my ( $self, $method ) = @_; return $method =~ $methods ? $self->{"_$method"} : UNIVERSAL::can( $self, $method ); } 1; __END__ =head1 NAME HTTP::Proxy::BodyFilter::simple - A class for creating simple filters =head1 SYNOPSIS use HTTP::Proxy::BodyFilter::simple; # a simple s/// filter my $filter = HTTP::Proxy::BodyFilter::simple->new( sub { ${ $_[1] } =~ s/foo/bar/g; } ); $proxy->push_filter( response => $filter ); =head1 DESCRIPTION L can create BodyFilter without going through the hassle of creating a full-fledged class. Simply pass a code reference to the C method of your filter to the constructor, and you'll get the adequate filter. =head2 Constructor calling convention The constructor can be called in several ways, which are shown in the synopsis: =over 4 =item single code reference The code reference must conform to the standard filter() signature: sub filter { my ( $self, $dataref, $message, $protocol, $buffer ) = @_; ... } It is assumed to be the code for the C method. See L for more details about the C method. =item name/coderef pairs The name is the name of the method (C, C, C) and the coderef is the method itself. See L for the methods signatures. =back =head1 METHODS This filter "factory" defines the standard L methods, but those are only, erm, "proxies" to the actual CODE references passed to the constructor. These "proxy" methods are: =over 4 =item filter() =item begin() =item end() =back Two other methods are actually L methods, and are called automatically: =over 4 =item init() Initalise the filter instance with the code references passed to the constructor. =item can() Return the actual code reference that will be run, and not the "proxy" methods. If called with any other name than C, C and C, calls C instead. =back There is also a method that returns a boolean value: =over 4 =item will_modify() The C method returns a scalar value (boolean) indicating if the filter may modify the body data. The default method returns a true value, so you only need to set this value when you are I that the filter will not modify data (or at least not modify its final length). Here's a simple example: $filter = HTTP::Proxy::BodyFilter::simple->new( filter => sub { ${ $_[1] } =~ s/foo/bar/g; }, will_modify => 0, # "foo" is the same length as "bar" ); =back =head1 SEE ALSO L, L. =head1 AUTHOR Philippe "BooK" Bruhat, Ebook@cpan.orgE. =head1 COPYRIGHT Copyright 2003-2015, Philippe Bruhat. =head1 LICENSE This module is free software; you can redistribute it or modify it under the same terms as Perl itself. =cut HTTP-Proxy-0.304/lib/HTTP/Proxy/BodyFilter/htmltext.pm0000644000175000017500000000625012537671053021020 0ustar bookbookpackage HTTP::Proxy::BodyFilter::htmltext; $HTTP::Proxy::BodyFilter::htmltext::VERSION = '0.304'; use strict; use Carp; use HTTP::Proxy::BodyFilter; use vars qw( @ISA ); @ISA = qw( HTTP::Proxy::BodyFilter ); sub init { croak "Parameter must be a CODE reference" unless ref $_[1] eq 'CODE'; $_[0]->{_filter} = $_[1]; } sub begin { $_[0]->{js} = 0; } # per message initialisation sub filter { my ( $self, $dataref, $message, $protocol, $buffer ) = @_; my $pos = pos($$dataref) = 0; SCAN: { $pos = pos($$dataref); $$dataref =~ /\G<\s*(?:script|style)[^>]*>/cgi # protect && do { $self->{js} = 1; redo SCAN; }; $$dataref =~ /\G<\s*\/\s*(?:script|style)[^>]*>/cgi # unprotect && do { $self->{js} = 0; redo SCAN; }; # comments are considered as text # if you want comments as comments, # use HTTP::Proxy::BodyFilter::htmlparser $$dataref =~ /\G