Web-Simple-0.035/000750 000000 000000 00000000000 15266735051 011640 5ustar00000000 000000 Web-Simple-0.035/README000660 000000 000000 00000067025 15266735051 012535 0ustar00000000 000000 NAME Web::Simple - A quick and easy way to build simple web applications SYNOPSIS #!/usr/bin/env perl package HelloWorld; use Web::Simple; sub dispatch_request { GET => sub { [ 200, [ 'Content-type', 'text/plain' ], [ 'Hello world!' ] ] }, '' => sub { [ 405, [ 'Content-type', 'text/plain' ], [ 'Method not allowed' ] ] } } HelloWorld->run_if_script; If you save this file into your cgi-bin as "hello-world.cgi" and then visit: http://my.server.name/cgi-bin/hello-world.cgi/ you'll get the "Hello world!" string output to your browser. At the same time this file will also act as a class module, so you can save it as HelloWorld.pm and use it as-is in test scripts or other deployment mechanisms. Note that you should retain the ->run_if_script even if your app is a module, since this additionally makes it valid as a .psgi file, which can be extremely useful during development. For more complex examples and non-CGI deployment, see Web::Simple::Deployment. To get help with Web::Simple, please connect to the irc.perl.org IRC network and join #web-simple. DESCRIPTION The philosophy of Web::Simple is to keep to an absolute bare minimum for everything. It is not designed to be used for large scale applications; the Catalyst web framework already works very nicely for that and is a far more mature, well supported piece of software. However, if you have an application that only does a couple of things, and want to not have to think about complexities of deployment, then Web::Simple might be just the thing for you. The only public interface the Web::Simple module itself provides is an "import" based one: use Web::Simple 'NameOfApplication'; This sets up your package (in this case "NameOfApplication" is your package) so that it inherits from Web::Simple::Application and imports strictures, as well as installs a "PSGI_ENV" constant for convenience, as well as some other subroutines. Importing strictures will automatically make your code use the "strict" and "warnings" pragma, so you can skip the usual: use strict; use warnings FATAL => 'all'; provided you 'use Web::Simple' at the top of the file. Note that we turn on *fatal* warnings so if you have any warnings at any point from the file that you did 'use Web::Simple' in, then your application will die. This is, so far, considered a feature. When we inherit from Web::Simple::Application we also use Moo, which is the the equivalent of: { package NameOfApplication; use Moo; extends 'Web::Simple::Application'; } So you can use Moo features in your application, such as creating attributes using the "has" subroutine, etc. Please see the documentation for Moo for more information. It also exports the following subroutines for use in dispatchers: response_filter { ... }; redispatch_to '/somewhere'; Finally, import sets $INC{"NameOfApplication.pm"} = 'Set by "use Web::Simple;" invocation'; so that perl will not attempt to load the application again even if require NameOfApplication; is encountered in other code. One important thing to remember when using NameOfApplication->run_if_script; At the end of your app is that this call will create an instance of your app for you automatically, regardless of context. An easier way to think of this would be if the method were more verbosely named NameOfApplication->run_request_if_script_else_turn_coderef_for_psgi; DISPATCH STRATEGY Web::Simple despite being straightforward to use, has a powerful system for matching all sorts of incoming URLs to one or more subroutines. These subroutines can be simple actions to take for a given URL, or something more complicated, including entire Plack applications, Plack::Middleware and nested subdispatchers. Examples sub dispatch_request { ( # matches: GET /user/1.htm?show_details=1 # GET /user/1.htm 'GET + /user/* + ?show_details~ + .htm|.html|.xhtml' => sub { my ($self, $user_id, $show_details) = @_; ... }, # matches: POST /user?username=frew # POST /user?username=mst&first_name=matt&last_name=trout 'POST + /user + ?username=&*' => sub { my ($self, $username, $misc_params) = @_; ... }, # matches: DELETE /user/1/friend/2 'DELETE + /user/*/friend/*' => sub { my ($self, $user_id, $friend_id) = @_; ... }, # matches: PUT /user/1?first_name=Matt&last_name=Trout 'PUT + /user/* + ?first_name~&last_name~' => sub { my ($self, $user_id, $first_name, $last_name) = @_; ... }, '/user/*/...' => sub { my $user_id = $_[1]; ( # matches: PUT /user/1/role/1 'PUT + /role/*' => sub { my $role_id = $_[1]; ... }, # matches: DELETE /user/1/role/1 'DELETE + /role/*' => sub { my $role_id = $_[1]; ... }, ); }, ); } The dispatch cycle At the beginning of a request, your app's dispatch_request method is called with the PSGI $env as an argument. You can handle the request entirely in here and return a PSGI response arrayref if you want: sub dispatch_request { my ($self, $env) = @_; [ 404, [ 'Content-type' => 'text/plain' ], [ 'Amnesia == fail' ] ] } However, generally, instead of that, you return a set of route/target pairs: sub dispatch_request { my $self = shift; ( '/' => sub { redispatch_to '/index.html' }, '/user/*' => sub { $self->show_user($_[1]) }, 'POST + %*' => 'handle_post', ... ); } Well, a sub is a valid PSGI response too (for ultimate streaming and async cleverness). If you want to return a PSGI sub you have to wrap it into an array ref. sub dispatch_request { [ sub { my $respond = shift; # This is pure PSGI here, so read perldoc PSGI } ] } If you return a string followed by a subroutine or method name, the string is treated as a match specification - and if the test is passed, the subroutine is called as a method and passed any matched arguments (see below for more details). You can also return a plain subroutine which will be called with just $env - remember that in this case if you need $self you must close over it. If you return a normal object, Web::Simple will simply return it upwards on the assumption that a response_filter (or some arbitrary Plack::Middleware) somewhere will convert it to something useful. This allows: sub dispatch_request { my $self = shift; ( '.html' => sub { response_filter { $self->render_zoom($_[0]) } }, '/user/*' => sub { $self->users->get($_[1]) }, ); } An alternative to using string + suborutine to declare a route is to use the sub prototype - sub dispatch_request { my $self = shift; ( sub (.html) { response_filter { $self->render_zoom($_[0]) } }, sub (/user/) { $self->users->get($_[1]) }, $self->can('handle_post'), # if declared as 'sub handle_post (...) {' ) } This can be useful sugar, especially if you want to keep method-based dispatchers' route specifications on the methods. to render a user object to HTML, if there is an incoming URL such as: http://myweb.org/user/111.html This works because as we descend down the dispachers, we first match "sub (.html)", which adds a "response_filter" (basically a specialized routine that follows the Plack::Middleware specification), and then later we also match "sub (/user/*)" which gets a user and returns that as the response. This user object 'bubbles up' through all the wrapping middleware until it hits the "response_filter" we defined, after which the return is converted to a true html response. However, two types of objects are treated specially - a "Plack::Component" object will have its "to_app" method called and be used as a dispatcher: sub dispatch_request { my $self = shift; ( '/static/...' => sub { Plack::App::File->new(...) }, ... ); } A Plack::Middleware object will be used as a filter for the rest of the dispatch being returned into: ## responds to /admin/track_usage AND /admin/delete_accounts sub dispatch_request { my $self = shift; ( '/admin/**' => sub { Plack::Middleware::Session->new(%opts); }, '/admin/track_usage' => sub { ## something that needs a session }, '/admin/delete_accounts' => sub { ## something else that needs a session }, ); } Note that this is for the dispatch being returned to, so if you want to provide it inline you need to do: ## ALSO responds to /admin/track_usage AND /admin/delete_accounts sub dispatch_request { my $self = shift; ( '/admin/...' => sub { ( sub { Plack::Middleware::Session->new(%opts); }, '/track_usage' => sub { ## something that needs a session }, '/delete_accounts' => sub { ## something else that needs a session }, ); } ); } And that's it - but remember that all this happens recursively - it's dispatchers all the way down. A URL incoming pattern will run all matching dispatchers and then hit all added filters or Plack::Middleware. Web::Simple match specifications Method matches 'GET' => sub { A match specification beginning with a capital letter matches HTTP requests with that request method. Path matches '/login' => sub { A match specification beginning with a / is a path match. In the simplest case it matches a specific path. To match a path with a wildcard part, you can do: '/user/*' => sub { $self->handle_user($_[1]) This will match /user/ where does not include a literal / character. The matched part becomes part of the match arguments. You can also match more than one part: '/user/*/*' => sub { my ($self, $user_1, $user_2) = @_; '/domain/*/user/*' => sub { my ($self, $domain, $user) = @_; and so on. To match an arbitrary number of parts, use "**": '/page/**' => sub { my ($self, $match) = @_; This will result in a single element for the entire match. Note that you can do '/page/**/edit' => sub { to match an arbitrary number of parts up to but not including some final part. Note: Since Web::Simple handles a concept of file extensions, "*" and "**" matchers will not by default match things after a final dot, and this can be modified by using "*.*" and "**.*" in the final position, e.g.: /one/* matches /one/two.three and captures "two" /one/*.* matches /one/two.three and captures "two.three" /** matches /one/two.three and captures "one/two" /**.* matches /one/two.three and captures "one/two.three" Finally, '/foo/...' => sub { Will match "/foo/" on the beginning of the path and strip it. This is designed to be used to construct nested dispatch structures, but can also prove useful for having e.g. an optional language specification at the start of a path. Note that the '...' is a "maybe something here, maybe not" so the above specification will match like this: /foo # no match /foo/ # match and strip path to '/' /foo/bar/baz # match and strip path to '/bar/baz' Almost the same, '/foo...' => sub { Will match on "/foo/bar/baz", but also include "/foo". Otherwise it operates the same way as "/foo/...". /foo # match and strip path to '' /foo/ # match and strip path to '/' /foo/bar/baz # match and strip path to '/bar/baz' Please note the difference between sub(/foo/...) and sub(/foo...). In the first case, this is expecting to find something after "/foo" (and fails to match if nothing is found), while in the second case we can match both "/foo" and "/foo/more/to/come". The following are roughly the same: '/foo' => sub { 'I match /foo' }, '/foo/...' => sub { ( '/bar' => sub { 'I match /foo/bar' }, '/*' => sub { 'I match /foo/{id}' }, ); } Versus '/foo...' => sub { ( '~' => sub { 'I match /foo' }, '/bar' => sub { 'I match /foo/bar' }, '/*' => sub { 'I match /foo/{id}' }, ); } You may prefer the latter example should you wish to take advantage of subdispatchers to scope common activities. For example: '/user...' => sub { my $user_rs = $schema->resultset('User'); ( '~' => sub { $user_rs }, '/*' => sub { $user_rs->find($_[1]) }, ); } You should note the special case path match "sub (~)" which is only meaningful when it is contained in this type of path match. It matches to an empty path. Naming your patch matches Any "*", "**", "*.*", or "**.*" match can be followed with ":name" to make it into a named match, so: '/*:one/*:two/*:three/*:four' => sub { "I match /1/2/3/4 capturing { one => 1, two => 2, three => 3, four => 4 }" } '/**.*:allofit' => sub { "I match anything capturing { allofit => \$whole_path }" } In the specific case of a simple single-* match, the * may be omitted, to allow you to write: '/:one/:two/:three/:four' => sub { "I match /1/2/3/4 capturing { one => 1, two => 2, three => 3, four => 4 }" } "/foo" and "/foo/" are different specs As you may have noticed with the difference between '/foo/...' and '/foo...', trailing slashes in path specs are significant. This is intentional and necessary to retain the ability to use relative links on websites. Let's demonstrate on this link: bar If the user loads the url "/foo/" and clicks on this link, they will be sent to "/foo/bar". However when they are on the url "/foo" and click this link, then they will be sent to "/bar". This makes it necessary to be explicit about the trailing slash. Extension matches '.html' => sub { will match .html from the path (assuming the subroutine itself returns something, of course). This is normally used for rendering - e.g.: '.html' => sub { response_filter { $self->render_html($_[1]) } } Additionally, '.*' => sub { will match any extension and supplies the extension as a match argument. Query and body parameter matches Query and body parameters can be match via '?' => sub { # match URI query '%' => sub { # match body params The body spec will match if the request content is either application/x-www-form-urlencoded or multipart/form-data - the latter of which is required for uploads - see below. The param spec is elements of one of the following forms: param~ # optional parameter param= # required parameter @param~ # optional multiple parameter @param= # required multiple parameter :param~ # optional parameter in hashref :param= # required parameter in hashref :@param~ # optional multiple in hashref :@param= # required multiple in hashref * # include all other parameters in hashref @* # include all other parameters as multiple in hashref separated by the "&" character. The arguments added to the request are one per non-":"/"*" parameter (scalar for normal, arrayref for multiple), plus if any ":"/"*" specs exist a hashref containing those values. If a parameter has no value, i.e. appears as '?foo&', a value of 1 will be captured. Please note that if you specify a multiple type parameter match, you are ensured of getting an arrayref for the value, EVEN if the current incoming request has only one value. However if a parameter is specified as single and multiple values are found, the last one will be used. For example to match a "page" parameter with an optional "order_by" parameter one would write: '?page=&order_by~' => sub { my ($self, $page, $order_by) = @_; return unless $page =~ /^\d+$/; $order_by ||= 'id'; response_filter { $_[1]->search_rs({}, { page => $page, order_by => $order_by }); } } to implement paging and ordering against a DBIx::Class::ResultSet object. Another Example: To get all parameters as a hashref of arrayrefs, write: '?@*' => sub { my ($self, $params) = @_; ... To get two parameters as a hashref, write: '?:user~&:domain~' => sub { my ($self, $params) = @_; # params contains only 'user' and 'domain' keys You can also mix these, so: '?foo=&@bar~&:coffee=&@*' => sub { my ($self, $foo, $bar, $params) = @_; where $bar is an arrayref (possibly an empty one), and $params contains arrayref values for all parameters not mentioned and a scalar value for the 'coffee' parameter. Note, in the case where you combine arrayref, single parameter and named hashref style, the arrayref and single parameters will appear in @_ in the order you defined them in the prototype, but all hashrefs will merge into a single $params, as in the example above. Upload matches '*foo=' => sub { # param specifier can be anything valid for query or body The upload match system functions exactly like a query/body match, except that the values returned (if any) are "Web::Dispatch::Upload" objects. Note that this match type will succeed in two circumstances where you might not expect it to - first, when the field exists but is not an upload field and second, when the field exists but the form is not an upload form (i.e. content type "application/x-www-form-urlencoded" rather than "multipart/form-data"). In either of these cases, what you'll get back is a "Web::Dispatch::NotAnUpload" object, which will "die" with an error pointing out the problem if you try and use it. To be sure you have a real upload object, call $upload->is_upload # returns 1 on a valid upload, 0 on a non-upload field and to get the reason why such an object is not an upload, call $upload->reason # returns a reason or '' on a valid upload. Other than these two methods, the upload object provides the same interface as Plack::Request::Upload with the addition of a stringify to the temporary filename to make copying it somewhere else easier to handle. Combining matches Matches may be combined with the + character - e.g. 'GET + /user/*' => sub { to create an AND match. They may also be combined with the | character - e.g. 'GET|POST' => sub { to create an OR match. Matches can be nested with () - e.g. '(GET|POST + /user/*)' => sub { and negated with ! - e.g. '!/user/foo + /user/*' => sub { ! binds to the immediate rightmost match specification, so if you want to negate a combination you will need to use '!(POST|PUT|DELETE)' => sub { and | binds tighter than +, so '(GET|POST) + /user/*' => sub { and 'GET|POST + /user/*' => sub { are equivalent, but '(GET + /admin/...) | (POST + /admin/...)' => sub { and 'GET + /admin/... | POST + /admin/...' => sub { are not - the latter is equivalent to 'GET + (/admin/...|POST) + /admin/...' => sub { which will never match! Whitespace Note that for legibility you are permitted to use whitespace: 'GET + /user/*' => sub { but it will be ignored. This is because the perl parser strips whitespace from subroutine prototypes, so this is equivalent to 'GET+/user/*' => sub { Accessing parameters via %_ If your dispatch specification causes your dispatch subroutine to receive a hash reference as its first argument, the contained named parameters will be accessible via %_. This can be used to access your path matches, if they are named: 'GET + /foo/:path_part' => sub { [ 200, ['Content-type' => 'text/plain'], ["We are in $_{path_part}"], ]; } Or, if your first argument would be a hash reference containing named query parameters: 'GET + /foo + ?:some_param=' => sub { [ 200, ['Content-type' => 'text/plain'], ["We received $_{some_param} as parameter"], ]; } Of course this also works when all you are doing is slurping the whole set of parameters by their name: 'GET + /foo + ?*' => sub { [ 200, ['Content-type' => 'text/plain'], [exists($_{foo}) ? "Received a foo: $_{foo}" : "No foo!"], ], } Note that only the first hash reference will be available via %_. If you receive additional hash references, you will need to access them as usual. Accessing the PSGI env hash In some cases you may wish to get the raw PSGI env hash - to do this, you can either use a plain sub: sub { my ($env) = @_; ... } or use the "PSGI_ENV" constant exported to retrieve it from @_: 'GET + /foo + ?some_param=' => sub { my $param = $_[1]; my $env = $_[PSGI_ENV]; } but note that if you're trying to add a middleware, you should simply use Web::Simple's direct support for doing so. EXPORTED SUBROUTINES response_filter response_filter { # Hide errors from the user because we hates them, preciousss if (ref($_[0]) eq 'ARRAY' && $_[0]->[0] == 500) { $_[0] = [ 200, @{$_[0]}[1..$#{$_[0]}] ]; } return $_[0]; }; The response_filter subroutine is designed for use inside dispatch subroutines. It creates and returns a special dispatcher that always matches, and calls the block passed to it as a filter on the result of running the rest of the current dispatch chain. Thus the filter above runs further dispatch as normal, but if the result of dispatch is a 500 (Internal Server Error) response, changes this to a 200 (OK) response without altering the headers or body. redispatch_to redispatch_to '/other/url'; The redispatch_to subroutine is designed for use inside dispatch subroutines. It creates and returns a special dispatcher that always matches, and instead of continuing dispatch re-delegates it to the start of the dispatch process, but with the path of the request altered to the supplied URL. Thus if you receive a POST to "/some/url" and return a redispatch to "/other/url", the dispatch behaviour will be exactly as if the same POST request had been made to "/other/url" instead. Note, this is not the same as returning an HTTP 3xx redirect as a response; rather it is a much more efficient internal process. SECURITY CONSIDERATIONS Request bodies now have a maximum size, which defaults to 8 MiB. If you want to adjust the size, you need to change $Web::Dispatch::ParamParser::MAX_BODY_SIZE, for example, $Web::Dispatch::ParamParser::MAX_BODY_SIZE = 33554432; # 32MiB Requests with larger bodies will croak. You will need to validate the Content-Length header before dispatching it, if you want a user-friendly response. CHANGES BETWEEN RELEASES Changes between 0.004 and 0.005 * dispatch {} replaced by declaring a dispatch_request method dispatch {} has gone away - instead, you write: sub dispatch_request { my $self = shift; ( 'GET /foo/' => sub { ... }, ... ); } Note that this method is still returning the dispatch code - just like "dispatch" did. Also note that you need the "my $self = shift" since the magic $self variable went away. * the magic $self variable went away. Just add "my $self = shift;" while writing your "sub dispatch_request {" like a normal perl method. * subdispatch deleted - all dispatchers can now subdispatch In earlier releases you needed to write: subdispatch sub (/foo/...) { ... [ sub (GET /bar/) { ... }, ... ] } As of 0.005, you can instead write simply: sub (/foo/...) { ... ( sub (GET /bar/) { ... }, ... ) } Changes since Antiquated Perl * filter_response renamed to response_filter This is a pure rename; a global search and replace should fix it. * dispatch [] changed to dispatch {} Simply changing dispatch [ sub(...) { ... }, ... ]; to dispatch { sub(...) { ... }, ... }; should work fine. DEVELOPMENT HISTORY Web::Simple was originally written to form part of my Antiquated Perl talk for Italian Perl Workshop 2009, but in writing the bloggery example I realised that having a bare minimum system for writing web applications that doesn't drive me insane was rather nice and decided to spend my attempt at nanowrimo for 2009 improving and documenting it to the point where others could use it. The Antiquated Perl talk can be found at and the slides are reproduced in this distribution under Web::Simple::AntiquatedPerl. COMMUNITY AND SUPPORT IRC channel irc.perl.org #web-simple No mailing list yet Because mst's non-work email is a bombsite so he'd never read it anyway. Git repository Gitweb is on http://git.shadowcat.co.uk/ and the clone URL is: git clone git://git.shadowcat.co.uk/catagits/Web-Simple.git AUTHOR Matt S. Trout (mst) CONTRIBUTORS Devin Austin (dhoss) Arthur Axel 'fREW' Schmidt gregor herrmann (gregoa) John Napiorkowski (jnap) Josh McMichael Justin Hunter (arcanez) Kjetil Kjernsmo markie Christian Walde (Mithaldu) nperez Robin Edwards Andrew Rodland (hobbs) Robert Sedlacek (phaylon) Hakim Cassimally (osfameron) Karen Etheridge (ether) Robert Rothenberg COPYRIGHT Copyright (c) 2011 the Web::Simple "AUTHOR" and "CONTRIBUTORS" as listed above. LICENSE This library is free software and may be distributed under the same terms as perl itself. Web-Simple-0.035/Changes000644 000000 000000 00000011002 15266735021 013127 0ustar00000000 000000 Revision history for Web-Simple 0.035 - 2026-10-23 [Security] - A urlencoded body is read in chunks (CVE-2026-114629) - The request body now has a configurable MAX_BODY_SIZE (defaults to 8 MiB) 0.034 - 2026-10-21 - migrate repository to github 0.033 - 2017-03-20 - reinstate the right glob in XML::Tags 0.032 - 2016-11-15 - add HTTP::Body dep - fix Test::More dep - documention fixes 0.031 - 2015-08-14 - rewrite docs to use string form first - handle empty query parameters - produce a sensible error for (GET => undef) on 5.8 0.030 - 2014-08-07 - make dispatch_misc.t handle Plack's MockHTTP's on error behaviour changing 0.029 - 2014-07-27 - fix repository metadata (Thomas Sibley) 0.028 - 2014-07-11 - remove use of 'use base' - lower minimum required version of perl properly down to 5.6 0.027 - 2014-07-11 - stable release of 0.026_001 0.026_001 - 2014-07-09 - fix prerequisite declarations on older toolchain 0.026 - 2014-07-09 - remove erroneous XML::Tags prereq 0.025 - 2014-07-07 - fixes a memory leak that occurs when calling Web::Simple::Application::to_psgi_app (Christian Walde) - more complete prerequisite declarations 0.024 - 2014-07-03 - small documentation fixes 0.023 - 2014-05-23 - Re-dist to fix MANIFEST 0.022 - 2014-05-23 - Remove erroneous require of deleted Web::Dispatch::Node 0.021 - 2014-05-20 - Handle ) as last character of composite spec - Allow passing method names to dispatcher - Added Web::Simple::Role - Assorted doc updates 0.020 - 2012-08-03 - re-dist for botched release 0.019 - 2012-07-30 - Add %_ alias if first argument is a hashref - Un-mark upload matches as experimental since they work 0.018 - 2012-07-15 - Allow dots in parameter names - Support for basic authentication in test requests 0.017 - 2012-07-05 - Don't falsely recognize mod_cgid as FCGI 0.016 - 2012-05-11 - Actually import weaken so the 0.015 fix doesn't implode 0.015 - 2012-05-10 - Fix a per-application-instance memory leak 0.014 - 2012-04-27 - Add named path matching - Allow headers on CLI calls 0.013 - 2012-04-03 - Fix a weird interaction between match-spec parsing and module loading that was causing brokenness and test failures with perl 5.8.8 0.012 - 2012-01-30 - Added match predicates match_true and match_false - Added '~' to match an empty path - Sub-dispatch via '...' is now permissible without a trailing slash - Only word char sequences with singular periods are parsed as path parts now - Various doc fixes - All query body parameters are now decoded from UTF8 - Allow dots in path matches, so you can have sub (/foo.html) 0.011 - 2011-12-23 - Add Web::Dispatch::HTTPMethods - Fix [ sub {} ] for async code - Support match_foo(...) => sub {} as a dispatcher return 0.010 - 2011-10-06 - Provide $app->run_test_request for use in test scripts - Preserve original env in Web::Dispatch so ParamParser can cache in there (stops HTTP::Body object getting destroyed early thereby losing uploads) 0.009 - 2011-10-03 - Complete port from HTTP::Request::AsCGI to Plack::Test - Add experimental upload support - Update Plack usage to call ::Handler:: classes not ::Server:: - Assume FastCGI mode if STDIN is a socket (works some places env vars fail) - Change CLI mode to print status line and headers to STDERR and content to STDOUT so that './myapp /foo.html >foo.html' works sanely - Add *.* and **.* dispatch types to keep extension - Add Antiquated Perl slides in a POD document. 0.008 - 2011-02-16 - Once more. 0.007 - 2011-02-16 - Re-release due to indexing failure 0.006 - 2011-02-15 - Fix Content-type issue (ie, Content-type: blah works, but Content-type: blah; charset: blah shits flames) - Make Web::Dispatch return [\$cv] as \$cv to allow subref responses - Stop undef errors killing XML::Tags conversion to string - Fixup dispatcher logic so dispatchers within a /foo/... work correctly 0.005 - Tue Jan 11 2011 22:09 UTC - Redocument to cover changes - Factor dispatcher code out into Web::Dispatch - Support 'use Web::Simple;' to default to current package 0.004 - Thu Jul 08 2010 22:08 UTC - Hide Plack Modules from PAUSE 0.003 - Thu Jul 08 2010 14:48 UTC - Experimentally use $_[ENV] for the PSGI env - Add CSS::Declare - Add more tags to HTML::Tags 0.002 - Tue Dec 01 2009 00:30 UTC - fix dispatcher construction to recognise '' as no proto (we expected undef) - plackup support, as_psgi_app method - Fix SYNOPSIS 0.001 - Tue Nov 24 2009 21:54 UTC - Initial release Web-Simple-0.035/MANIFEST000644 000000 000000 00000002757 15266735051 013011 0ustar00000000 000000 Changes examples/bloggery/bloggery.cgi examples/bloggery/posts/Another-Post.html examples/bloggery/posts/One-Post.html examples/bloggery/posts/One-Post.summary.html examples/dispatchex/dispatchex.cgi examples/golf/golf.cgi examples/hello-world/hello-world.cgi lib/CSS/Declare.pm lib/HTML/Tags.pm lib/Plack/Middleware/Dispatch.pm lib/Web/Dispatch.pm lib/Web/Dispatch/HTTPMethods.pm lib/Web/Dispatch/Node.pm lib/Web/Dispatch/ParamParser.pm lib/Web/Dispatch/Parser.pm lib/Web/Dispatch/Predicates.pm lib/Web/Dispatch/ToApp.pm lib/Web/Dispatch/Upload.pm lib/Web/Dispatch/Wrapper.pm lib/Web/Simple.pm lib/Web/Simple/AntiquatedPerl.pod lib/Web/Simple/Application.pm lib/Web/Simple/Deployment.pod lib/Web/Simple/HackedPlack.pm lib/Web/Simple/Role.pm lib/XML/Tags.pm maint/Makefile.PL.include Makefile.PL MANIFEST This list of files t/bloggery.t t/css_declare.t t/dispatch_misc.t t/dispatch_parser.t t/env.t t/globbery/one t/globbery/three t/globbery/two t/leak.t t/match-home.t t/param_parser.t t/post.t t/predicate_objects.t t/request_mode_heuristics.t t/response-filter.t t/role.t t/stream_test.t t/sub-dispatch-args.t t/sub-dispatch-env.t t/tags.t t/test-request-basic-auth.t t/underscore.t t/wd-http-methods.t META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) README README file (added by Distar) LICENSE LICENSE file (added by Distar) Web-Simple-0.035/LICENSE000660 000000 000000 00000046133 15266735051 012657 0ustar00000000 000000 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) 2026 by mst - Matt S. Trout (cpan:MSTROUT) . 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. 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, see . 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 Moe Ghoul, President of Vice That's all there is to it! --- The Perl Artistic License 1.0 --- This software is Copyright (c) 2026 by mst - Matt S. Trout (cpan:MSTROUT) . This is free software, licensed under: The Perl 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 as specified below. "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 uunet.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) give non-standard executables non-standard names, and clearly document 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. You may embed this Package's interpreter within an executable of yours (by linking); this shall be construed as a mere form of aggregation, provided that the complete Standard Version of the interpreter is so embedded. 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 whoever generated them, and may be sold commercially, and may be aggregated with this Package. If such scripts or library files are aggregated with this Package via the so-called "undump" or "unexec" methods of producing a binary executable image, then distribution of such an image shall neither be construed as a distribution of this Package nor shall it fall under the restrictions of Paragraphs 3 and 4, provided that you do not represent such an executable image as a Standard Version of this Package. 7. C subroutines (or comparably compiled subroutines in other languages) supplied by you and linked into this Package in order to emulate subroutines and variables of the language defined by this Package shall not be considered part of this Package, but are the equivalent of input as in Paragraph 6, provided these subroutines do not change the language in any way that would cause it to fail the regression tests for the language. 8. Aggregation of this Package with a commercial distribution is always permitted provided that the use of this Package is embedded; that is, when no overt attempt is made to make this Package's interfaces visible to the end user of the commercial distribution. Such use shall not be construed as a distribution of this Package. 9. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. 10. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. The End Web-Simple-0.035/t/000750 000000 000000 00000000000 15266735050 012102 5ustar00000000 000000 Web-Simple-0.035/META.yml000660 000000 000000 00000001726 15266735050 013121 0ustar00000000 000000 --- abstract: 'A quick and easy way to build simple web applications' author: - 'mst - Matt S. Trout (cpan:MSTROUT) ' build_requires: Data::Dumper::Concise: '2.020' IO::Scalar: '0' Test::More: '0.88' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 0 generated_by: 'ExtUtils::MakeMaker version 7.78, CPAN::Meta::Converter version 2.150015' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Web-Simple no_index: directory: - t - inc requires: Encode: '0' Exporter: '5.57' HTTP::Body: '1.22' Moo: '0.009014' Plack: '0.9968' Scalar::Util: '0' Syntax::Keyword::Gather: '1.001' perl: '5.006' strictures: '1' warnings::illegalproto: '0' resources: bugtracker: https://rt.cpan.org/Public/Dist/Display.html?Name=Web-Simple repository: https://github.com/p5sagit/Web-Simple.git version: '0.035' x_serialization_backend: 'CPAN::Meta::YAML version 0.020' Web-Simple-0.035/META.json000660 000000 000000 00000003473 15266735050 013272 0ustar00000000 000000 { "abstract" : "A quick and easy way to build simple web applications", "author" : [ "mst - Matt S. Trout (cpan:MSTROUT) " ], "dynamic_config" : 0, "generated_by" : "ExtUtils::MakeMaker version 7.78, CPAN::Meta::Converter version 2.150015", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "Web-Simple", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "Encode" : "0", "Exporter" : "5.57", "HTTP::Body" : "1.22", "Moo" : "0.009014", "Plack" : "0.9968", "Scalar::Util" : "0", "Syntax::Keyword::Gather" : "1.001", "perl" : "5.006", "strictures" : "1", "warnings::illegalproto" : "0" } }, "test" : { "recommends" : { "Devel::Cycle" : "0", "HTTP::Request::AsCGI" : "0" }, "requires" : { "Data::Dumper::Concise" : "2.020", "IO::Scalar" : "0", "Test::More" : "0.88" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "mailto" : "bug-Web-Simple@rt.cpan.org", "web" : "https://rt.cpan.org/Public/Dist/Display.html?Name=Web-Simple" }, "repository" : { "type" : "git", "url" : "https://github.com/p5sagit/Web-Simple.git", "web" : "https://github.com/p5sagit/Web-Simple" } }, "version" : "0.035", "x_serialization_backend" : "JSON::MaybeXS version 1.004008" } Web-Simple-0.035/examples/000750 000000 000000 00000000000 15266735050 013455 5ustar00000000 000000 Web-Simple-0.035/lib/000750 000000 000000 00000000000 15266735050 012405 5ustar00000000 000000 Web-Simple-0.035/maint/000750 000000 000000 00000000000 15266735050 012747 5ustar00000000 000000 Web-Simple-0.035/Makefile.PL000644 000000 000000 00000006000 15266733471 013617 0ustar00000000 000000 use strict; use warnings FATAL => 'all'; use 5.006; use ExtUtils::MakeMaker; (do './maint/Makefile.PL.include' or die $@) unless -f 'META.yml'; my %WriteMakefileArgs = ( NAME => 'Web::Simple', VERSION_FROM => 'lib/Web/Simple.pm', META_MERGE => { 'meta-spec' => { version => 2 }, dynamic_config => 0, resources => { # r/w, old repository: catagits@git.shadowcat.co.uk:Web-Simple.git repository => { url => 'https://github.com/p5sagit/Web-Simple.git', web => 'https://github.com/p5sagit/Web-Simple', type => 'git', }, bugtracker => { mailto => 'bug-Web-Simple@rt.cpan.org', web => 'https://rt.cpan.org/Public/Dist/Display.html?Name=Web-Simple', }, }, }, META_ADD => { 'meta-spec' => { version => 2 }, prereqs => { configure => { requires => { 'ExtUtils::MakeMaker' => 0, }, }, runtime => { requires => { 'Encode' => '0', # not core in 5.6 'Exporter' => '5.57', # use Exporter 'import' 'Moo' => '0.009014', 'Plack' => '0.9968', 'HTTP::Body' => '1.22', 'Scalar::Util' => '0', # not core in 5.6 'Syntax::Keyword::Gather' => '1.001', 'strictures' => '1', 'warnings::illegalproto' => '0', 'perl' => '5.006', }, }, test => { requires => { 'Data::Dumper::Concise' => '2.020', 'IO::Scalar' => 0, 'Test::More' => '0.88', }, recommends => { 'Devel::Cycle' => '0', 'HTTP::Request::AsCGI' => '0', }, }, }, }, ); my $eumm_version = eval $ExtUtils::MakeMaker::VERSION; for (qw(configure build test runtime)) { my $key = $_ eq 'runtime' ? 'PREREQ_PM' : uc $_.'_REQUIRES'; next unless exists $WriteMakefileArgs{META_ADD}{prereqs}{$_} or exists $WriteMakefileArgs{$key}; my $r = $WriteMakefileArgs{$key} = { %{$WriteMakefileArgs{META_ADD}{prereqs}{$_}{requires} || {}}, %{delete $WriteMakefileArgs{$key} || {}}, }; defined $r->{$_} or delete $r->{$_} for keys %$r; } # dynamic prereqs get added here. $WriteMakefileArgs{MIN_PERL_VERSION} = delete $WriteMakefileArgs{PREREQ_PM}{perl} || 0; die 'attention developer: you need to do a sane meta merge here!' if keys %{$WriteMakefileArgs{BUILD_REQUIRES}}; $WriteMakefileArgs{BUILD_REQUIRES} = { %{$WriteMakefileArgs{BUILD_REQUIRES} || {}}, %{delete $WriteMakefileArgs{TEST_REQUIRES}} } if $eumm_version < 6.63_03; $WriteMakefileArgs{PREREQ_PM} = { %{$WriteMakefileArgs{PREREQ_PM}}, %{delete $WriteMakefileArgs{BUILD_REQUIRES}} } if $eumm_version < 6.55_01; delete $WriteMakefileArgs{CONFIGURE_REQUIRES} if $eumm_version < 6.51_03; delete $WriteMakefileArgs{MIN_PERL_VERSION} if $eumm_version < 6.48; delete @WriteMakefileArgs{qw(META_ADD META_MERGE)} if $eumm_version < 6.46; delete $WriteMakefileArgs{LICENSE} if $eumm_version < 6.31; WriteMakefile(%WriteMakefileArgs); Web-Simple-0.035/maint/Makefile.PL.include000644 000000 000000 00000000534 12500156524 016341 0ustar00000000 000000 BEGIN { -e 'Distar' or system("git clone git://git.shadowcat.co.uk/p5sagit/Distar.git") } use lib "Distar/lib"; use Distar; author 'mst - Matt S. Trout (cpan:MSTROUT) '; manifest_include 't/globbery' => qr/.*/; manifest_include 'docs' => qr/.*/; manifest_include 'examples' => qr/.*/; manifest_include 'lib' => qr/.*\.pod$/; Web-Simple-0.035/lib/Web/000750 000000 000000 00000000000 15266735050 013122 5ustar00000000 000000 Web-Simple-0.035/lib/HTML/000750 000000 000000 00000000000 15266735050 013151 5ustar00000000 000000 Web-Simple-0.035/lib/Plack/000750 000000 000000 00000000000 15266735050 013437 5ustar00000000 000000 Web-Simple-0.035/lib/XML/000750 000000 000000 00000000000 15266735050 013045 5ustar00000000 000000 Web-Simple-0.035/lib/CSS/000750 000000 000000 00000000000 15266735050 013035 5ustar00000000 000000 Web-Simple-0.035/lib/CSS/Declare.pm000644 000000 000000 00000007527 12500156524 014741 0ustar00000000 000000 package CSS::Declare; use strict; use warnings; use Syntax::Keyword::Gather; my $IN_SCOPE = 0; sub import { die "Can't import CSS::Declare into a scope when already compiling one that uses it" if $IN_SCOPE; my ($class, @args) = @_; my $opts = shift(@args) if ref($args[0]) eq 'HASH'; my $target = $class->_find_target(0, $opts); my $unex = $class->_export_tags_into($target); $class->_install_unexporter($unex); $IN_SCOPE = 1; } sub _find_target { my ($class, $extra_levels, $opts) = @_; return $opts->{into} if defined($opts->{into}); my $level = ($opts->{into_level} || 1) + $extra_levels; return (caller($level))[0]; } my @properties = qw{ accelerator azimuth background background_attachment background_color background_image background_position background_position_x background_position_y background_repeat behavior border border_bottom border_bottom_color border_bottom_style border_bottom_width border_collapse border_color border_left border_left_color border_left_style border_left_width border_right border_right_color border_right_style border_right_width border_spacing border_style border_top border_top_color border_top_style border_top_width border_width bottom caption_side clear clip color content counter_increment counter_reset cue cue_after cue_before cursor direction display elevation empty_cells filter float font font_family font_size font_size_adjust font_stretch font_style font_variant font_weight height ime_mode include_source layer_background_color layer_background_image layout_flow layout_grid layout_grid_char layout_grid_char_spacing layout_grid_line layout_grid_mode layout_grid_type left letter_spacing line_break line_height list_style list_style_image list_style_position list_style_type margin margin_bottom margin_left margin_right margin_top marker_offset marks max_height max_width min_height min_width orphans outline outline_color outline_style outline_width overflow overflow_X overflow_Y padding padding_bottom padding_left padding_right padding_top page page_break_after page_break_before page_break_inside pause pause_after pause_before pitch pitch_range play_during position quotes _replace richness right ruby_align ruby_overhang ruby_position size speak speak_header speak_numeral speak_punctuation speech_rate stress scrollbar_arrow_color scrollbar_base_color scrollbar_dark_shadow_color scrollbar_face_color scrollbar_highlight_color scrollbar_shadow_color scrollbar_3d_light_color scrollbar_track_color table_layout text_align text_align_last text_decoration text_indent text_justify text_overflow text_shadow text_transform text_autospace text_kashida_space text_underline_position top unicode_bidi vertical_align visibility voice_family volume white_space widows width word_break word_spacing word_wrap writing_mode z_index zoom }; sub _export_tags_into { my ($class, $into) = @_; for my $property (@properties) { my $property_name = $property; $property_name =~ tr/_/-/; no strict 'refs'; *{"$into\::$property"} = sub ($) { return ($property_name => $_[0]) }; } return sub { foreach my $property (@properties) { no strict 'refs'; delete ${"${into}::"}{$property} } $IN_SCOPE = 0; }; } sub _install_unexporter { my ($class, $unex) = @_; $^H |= 0x20000; # localize %^H $^H{'CSS::Declare::Unex'} = bless($unex, 'CSS::Declare::Unex'); } sub to_css_string { my @css = @_; return join q{ }, gather { while (my ($selector, $declarations) = splice(@css, 0, 2)) { take "$selector "._generate_declarations($declarations) } }; } sub _generate_declarations { my $declarations = shift; return '{'.join(q{;}, gather { while (my ($property, $value) = splice(@{$declarations}, 0, 2)) { take "$property:$value" } }).'}'; } package CSS::Declare::Unex; sub DESTROY { local $@; eval { $_[0]->(); 1 } || warn "ARGH: $@" } 1; Web-Simple-0.035/lib/XML/Tags.pm000644 000000 000000 00000006471 14401201364 014300 0ustar00000000 000000 package XML::Tags; use strict; use warnings FATAL => 'all'; use File::Glob (); require overload; my $IN_SCOPE = 0; sub import { die "Can't import XML::Tags into a scope when already compiling one that uses it" if $IN_SCOPE; my ($class, @args) = @_; my $opts = shift(@args) if ref($args[0]) eq 'HASH'; my $target = $class->_find_target(0, $opts); my @tags = $class->_find_tags(@args); my $unex = $class->_export_tags_into($target => @tags); if ($INC{"bareword/filehandles.pm"}) { bareword::filehandles->import } $class->_install_unexporter($unex); $IN_SCOPE = 1; } sub to_xml_string { map { # string == text -> HTML, scalarref == raw HTML, other == passthrough ref($_) ? (ref $_ eq 'SCALAR' ? $$_ : $_) : do { local $_ = $_; # copy if (defined) { s/&/&/g; s/"/"/g; s//>/g; $_; } else { '' } } } @_ } sub _find_tags { shift; @_ } sub _find_target { my ($class, $extra_levels, $opts) = @_; return $opts->{into} if defined($opts->{into}); my $level = ($opts->{into_level} || 1) + $extra_levels; return (caller($level))[0]; } sub _set_glob { # stupid insanity. delete anything already there so we disassociated # the *CORE::GLOBAL::glob typeglob. Then the string reference call # revivifies it - i.e. creates us a new glob, which we get a reference # to, which we can then assign to. # doing it without the quotes doesn't - it binds to the version in scope # at compile time, which means after a delete you get a nice warm segv. delete ${CORE::GLOBAL::}{glob}; no strict 'refs'; *{'CORE::GLOBAL::glob'} = $_[0]; } sub _export_tags_into { my ($class, $into, @tags) = @_; foreach my $tag (@tags) { no strict 'refs'; tie *{"${into}::${tag}"}, 'XML::Tags::TIEHANDLE', \"<${tag}>"; } _set_glob(sub { local $XML::Tags::StringThing::IN_GLOBBERY = 1; \('<'."$_[0]".'>'); }); overload::constant(q => sub { XML::Tags::StringThing->from_constant(@_) }); return sub { foreach my $tag (@tags) { no strict 'refs'; delete ${"${into}::"}{$tag} } _set_glob(\&File::Glob::csh_glob); overload::remove_constant('q'); $IN_SCOPE = 0; }; } sub _install_unexporter { my ($class, $unex) = @_; $^H |= 0x20000; # localize %^H $^H{'XML::Tags::Unex'} = bless($unex, 'XML::Tags::Unex'); } package XML::Tags::TIEHANDLE; sub TIEHANDLE { my $str = $_[1]; bless \$str, $_[0] } sub READLINE { ${$_[0]} } package XML::Tags::Unex; sub DESTROY { local $@; eval { $_[0]->(); 1 } || warn "ARGH: $@" } package XML::Tags::StringThing; use overload ( '.' => 'concat', '""' => 'stringify', fallback => 1 ); sub stringify { join( '', ((our $IN_GLOBBERY) ? XML::Tags::to_xml_string(@{$_[0]}) : (map +(ref $_ ? $$_ : $_), @{$_[0]}) ) ); } sub from_constant { my ($class, $initial, $parsed, $type) = @_; return $parsed unless $type eq 'qq'; return $class->new($parsed); } sub new { my ($class, $string) = @_; bless([ \$string ], $class); } sub concat { my ($self, $other, $rev) = @_; my @extra = do { if (ref($other) && ($other =~ /[a-z]=[A-Z]/) && $other->isa(__PACKAGE__)) { @{$other} } else { $other; } }; my @new = @{$self}; $rev ? unshift(@new, @extra) : push(@new, @extra); bless(\@new, ref($self)); } 1; Web-Simple-0.035/lib/Plack/Middleware/000750 000000 000000 00000000000 15266735050 015514 5ustar00000000 000000 Web-Simple-0.035/lib/Plack/Middleware/Dispatch.pm000644 000000 000000 00000000460 13012661354 017606 0ustar00000000 000000 package Plack::Middleware::Dispatch; use Moo; extends 'Web::Dispatch'; has app => (is => 'ro', writer => '_set_app'); sub wrap { my ($self, $app, @args) = @_; if (ref $self) { $self->_set_app($app); } else { $self = $self->new({ app => $app, @args }); } return $self->to_app; } 1; Web-Simple-0.035/lib/HTML/Tags.pm000644 000000 000000 00000001574 12500156524 014410 0ustar00000000 000000 package HTML::Tags; use strict; use warnings FATAL => 'all'; use XML::Tags (); my @HTML_TAGS = qw( a abbr address area article aside audio b base bb bdo blockquote body br button canvas caption cite code col colgroup command datagrid datalist dd del details dialog dfn div dl dt em embed eventsource fieldset figure footer form h1 h2 h3 h4 h5 h6 head header hr html i iframe img input ins kbd label legend li link mark map menu meta meter nav noscript object ol optgroup option output p param pre progress q ruby rp rt samp script section select small source span strong style sub sup table tbody td textarea tfoot th thead time title tr ul var video ); sub import { my ($class, @rest) = @_; my $opts = ref($rest[0]) eq 'HASH' ? shift(@rest) : {}; ($opts->{into_level}||=1)++; XML::Tags->import($opts, @HTML_TAGS, @rest); } sub to_html_string { XML::Tags::to_xml_string(@_) } 1; Web-Simple-0.035/lib/Web/Dispatch/000750 000000 000000 00000000000 15266735050 014661 5ustar00000000 000000 Web-Simple-0.035/lib/Web/Simple.pm000644 000000 000000 00000064414 15266735004 014726 0ustar00000000 000000 package Web::Simple; use strictures 1; use warnings::illegalproto (); use Moo (); use Web::Dispatch::Wrapper (); our $VERSION = '0.035'; sub import { my ($class, $app_package) = @_; $app_package ||= caller; $class->_export_into($app_package); eval "package $app_package; use Web::Dispatch::Wrapper; use Moo; 1" or die "Failed to setup app package: $@"; strictures->import; warnings::illegalproto->unimport; } sub _export_into { my ($class, $app_package) = @_; { no strict 'refs'; *{"${app_package}::PSGI_ENV"} = sub () { -1 }; require Web::Simple::Application; unshift(@{"${app_package}::ISA"}, 'Web::Simple::Application'); } (my $name = $app_package) =~ s/::/\//g; $INC{"${name}.pm"} = 'Set by "use Web::Simple;" invocation'; } 1; =head1 NAME Web::Simple - A quick and easy way to build simple web applications =head1 SYNOPSIS #!/usr/bin/env perl package HelloWorld; use Web::Simple; sub dispatch_request { GET => sub { [ 200, [ 'Content-type', 'text/plain' ], [ 'Hello world!' ] ] }, '' => sub { [ 405, [ 'Content-type', 'text/plain' ], [ 'Method not allowed' ] ] } } HelloWorld->run_if_script; If you save this file into your cgi-bin as C and then visit: http://my.server.name/cgi-bin/hello-world.cgi/ you'll get the "Hello world!" string output to your browser. At the same time this file will also act as a class module, so you can save it as HelloWorld.pm and use it as-is in test scripts or other deployment mechanisms. Note that you should retain the ->run_if_script even if your app is a module, since this additionally makes it valid as a .psgi file, which can be extremely useful during development. For more complex examples and non-CGI deployment, see L. To get help with L, please connect to the irc.perl.org IRC network and join #web-simple. =head1 DESCRIPTION The philosophy of L is to keep to an absolute bare minimum for everything. It is not designed to be used for large scale applications; the L web framework already works very nicely for that and is a far more mature, well supported piece of software. However, if you have an application that only does a couple of things, and want to not have to think about complexities of deployment, then L might be just the thing for you. The only public interface the L module itself provides is an C based one: use Web::Simple 'NameOfApplication'; This sets up your package (in this case "NameOfApplication" is your package) so that it inherits from L and imports L, as well as installs a C constant for convenience, as well as some other subroutines. Importing L will automatically make your code use the C and C pragma, so you can skip the usual: use strict; use warnings FATAL => 'all'; provided you 'use Web::Simple' at the top of the file. Note that we turn on *fatal* warnings so if you have any warnings at any point from the file that you did 'use Web::Simple' in, then your application will die. This is, so far, considered a feature. When we inherit from L we also use L, which is the the equivalent of: { package NameOfApplication; use Moo; extends 'Web::Simple::Application'; } So you can use L features in your application, such as creating attributes using the C subroutine, etc. Please see the documentation for L for more information. It also exports the following subroutines for use in dispatchers: response_filter { ... }; redispatch_to '/somewhere'; Finally, import sets $INC{"NameOfApplication.pm"} = 'Set by "use Web::Simple;" invocation'; so that perl will not attempt to load the application again even if require NameOfApplication; is encountered in other code. One important thing to remember when using NameOfApplication->run_if_script; At the end of your app is that this call will create an instance of your app for you automatically, regardless of context. An easier way to think of this would be if the method were more verbosely named NameOfApplication->run_request_if_script_else_turn_coderef_for_psgi; =head1 DISPATCH STRATEGY L despite being straightforward to use, has a powerful system for matching all sorts of incoming URLs to one or more subroutines. These subroutines can be simple actions to take for a given URL, or something more complicated, including entire L applications, L and nested subdispatchers. =head2 Examples sub dispatch_request { ( # matches: GET /user/1.htm?show_details=1 # GET /user/1.htm 'GET + /user/* + ?show_details~ + .htm|.html|.xhtml' => sub { my ($self, $user_id, $show_details) = @_; ... }, # matches: POST /user?username=frew # POST /user?username=mst&first_name=matt&last_name=trout 'POST + /user + ?username=&*' => sub { my ($self, $username, $misc_params) = @_; ... }, # matches: DELETE /user/1/friend/2 'DELETE + /user/*/friend/*' => sub { my ($self, $user_id, $friend_id) = @_; ... }, # matches: PUT /user/1?first_name=Matt&last_name=Trout 'PUT + /user/* + ?first_name~&last_name~' => sub { my ($self, $user_id, $first_name, $last_name) = @_; ... }, '/user/*/...' => sub { my $user_id = $_[1]; ( # matches: PUT /user/1/role/1 'PUT + /role/*' => sub { my $role_id = $_[1]; ... }, # matches: DELETE /user/1/role/1 'DELETE + /role/*' => sub { my $role_id = $_[1]; ... }, ); }, ); } =head2 The dispatch cycle At the beginning of a request, your app's dispatch_request method is called with the PSGI $env as an argument. You can handle the request entirely in here and return a PSGI response arrayref if you want: sub dispatch_request { my ($self, $env) = @_; [ 404, [ 'Content-type' => 'text/plain' ], [ 'Amnesia == fail' ] ] } However, generally, instead of that, you return a set of route/target pairs: sub dispatch_request { my $self = shift; ( '/' => sub { redispatch_to '/index.html' }, '/user/*' => sub { $self->show_user($_[1]) }, 'POST + %*' => 'handle_post', ... ); } Well, a sub is a valid PSGI response too (for ultimate streaming and async cleverness). If you want to return a PSGI sub you have to wrap it into an array ref. sub dispatch_request { [ sub { my $respond = shift; # This is pure PSGI here, so read perldoc PSGI } ] } If you return a string followed by a subroutine or method name, the string is treated as a match specification - and if the test is passed, the subroutine is called as a method and passed any matched arguments (see below for more details). You can also return a plain subroutine which will be called with just C<$env> - remember that in this case if you need C<$self> you B close over it. If you return a normal object, L will simply return it upwards on the assumption that a response_filter (or some arbitrary L) somewhere will convert it to something useful. This allows: sub dispatch_request { my $self = shift; ( '.html' => sub { response_filter { $self->render_zoom($_[0]) } }, '/user/*' => sub { $self->users->get($_[1]) }, ); } An alternative to using string + suborutine to declare a route is to use the sub prototype - sub dispatch_request { my $self = shift; ( sub (.html) { response_filter { $self->render_zoom($_[0]) } }, sub (/user/) { $self->users->get($_[1]) }, $self->can('handle_post'), # if declared as 'sub handle_post (...) {' ) } This can be useful sugar, especially if you want to keep method-based dispatchers' route specifications on the methods. to render a user object to HTML, if there is an incoming URL such as: http://myweb.org/user/111.html This works because as we descend down the dispachers, we first match C, which adds a C (basically a specialized routine that follows the L specification), and then later we also match C which gets a user and returns that as the response. This user object 'bubbles up' through all the wrapping middleware until it hits the C we defined, after which the return is converted to a true html response. However, two types of objects are treated specially - a C object will have its C method called and be used as a dispatcher: sub dispatch_request { my $self = shift; ( '/static/...' => sub { Plack::App::File->new(...) }, ... ); } A L object will be used as a filter for the rest of the dispatch being returned into: ## responds to /admin/track_usage AND /admin/delete_accounts sub dispatch_request { my $self = shift; ( '/admin/**' => sub { Plack::Middleware::Session->new(%opts); }, '/admin/track_usage' => sub { ## something that needs a session }, '/admin/delete_accounts' => sub { ## something else that needs a session }, ); } Note that this is for the dispatch being B to, so if you want to provide it inline you need to do: ## ALSO responds to /admin/track_usage AND /admin/delete_accounts sub dispatch_request { my $self = shift; ( '/admin/...' => sub { ( sub { Plack::Middleware::Session->new(%opts); }, '/track_usage' => sub { ## something that needs a session }, '/delete_accounts' => sub { ## something else that needs a session }, ); } ); } And that's it - but remember that all this happens recursively - it's dispatchers all the way down. A URL incoming pattern will run all matching dispatchers and then hit all added filters or L. =head2 Web::Simple match specifications =head3 Method matches 'GET' => sub { A match specification beginning with a capital letter matches HTTP requests with that request method. =head3 Path matches '/login' => sub { A match specification beginning with a / is a path match. In the simplest case it matches a specific path. To match a path with a wildcard part, you can do: '/user/*' => sub { $self->handle_user($_[1]) This will match /user/ where does not include a literal / character. The matched part becomes part of the match arguments. You can also match more than one part: '/user/*/*' => sub { my ($self, $user_1, $user_2) = @_; '/domain/*/user/*' => sub { my ($self, $domain, $user) = @_; and so on. To match an arbitrary number of parts, use C<**>: '/page/**' => sub { my ($self, $match) = @_; This will result in a single element for the entire match. Note that you can do '/page/**/edit' => sub { to match an arbitrary number of parts up to but not including some final part. Note: Since Web::Simple handles a concept of file extensions, C<*> and C<**> matchers will not by default match things after a final dot, and this can be modified by using C<*.*> and C<**.*> in the final position, e.g.: /one/* matches /one/two.three and captures "two" /one/*.* matches /one/two.three and captures "two.three" /** matches /one/two.three and captures "one/two" /**.* matches /one/two.three and captures "one/two.three" Finally, '/foo/...' => sub { Will match C on the beginning of the path B strip it. This is designed to be used to construct nested dispatch structures, but can also prove useful for having e.g. an optional language specification at the start of a path. Note that the '...' is a "maybe something here, maybe not" so the above specification will match like this: /foo # no match /foo/ # match and strip path to '/' /foo/bar/baz # match and strip path to '/bar/baz' Almost the same, '/foo...' => sub { Will match on C, but also include C. Otherwise it operates the same way as C. /foo # match and strip path to '' /foo/ # match and strip path to '/' /foo/bar/baz # match and strip path to '/bar/baz' Please note the difference between C and C. In the first case, this is expecting to find something after C (and fails to match if nothing is found), while in the second case we can match both C and C. The following are roughly the same: '/foo' => sub { 'I match /foo' }, '/foo/...' => sub { ( '/bar' => sub { 'I match /foo/bar' }, '/*' => sub { 'I match /foo/{id}' }, ); } Versus '/foo...' => sub { ( '~' => sub { 'I match /foo' }, '/bar' => sub { 'I match /foo/bar' }, '/*' => sub { 'I match /foo/{id}' }, ); } You may prefer the latter example should you wish to take advantage of subdispatchers to scope common activities. For example: '/user...' => sub { my $user_rs = $schema->resultset('User'); ( '~' => sub { $user_rs }, '/*' => sub { $user_rs->find($_[1]) }, ); } You should note the special case path match C which is only meaningful when it is contained in this type of path match. It matches to an empty path. =head4 Naming your patch matches Any C<*>, C<**>, C<*.*>, or C<**.*> match can be followed with C<:name> to make it into a named match, so: '/*:one/*:two/*:three/*:four' => sub { "I match /1/2/3/4 capturing { one => 1, two => 2, three => 3, four => 4 }" } '/**.*:allofit' => sub { "I match anything capturing { allofit => \$whole_path }" } In the specific case of a simple single-* match, the * may be omitted, to allow you to write: '/:one/:two/:three/:four' => sub { "I match /1/2/3/4 capturing { one => 1, two => 2, three => 3, four => 4 }" } =head4 C and C are different specs As you may have noticed with the difference between C<'/foo/...'> and C<'/foo...'>, trailing slashes in path specs are significant. This is intentional and necessary to retain the ability to use relative links on websites. Let's demonstrate on this link: bar If the user loads the url C and clicks on this link, they will be sent to C. However when they are on the url C and click this link, then they will be sent to C. This makes it necessary to be explicit about the trailing slash. =head3 Extension matches '.html' => sub { will match .html from the path (assuming the subroutine itself returns something, of course). This is normally used for rendering - e.g.: '.html' => sub { response_filter { $self->render_html($_[1]) } } Additionally, '.*' => sub { will match any extension and supplies the extension as a match argument. =head3 Query and body parameter matches Query and body parameters can be match via '?' => sub { # match URI query '%' => sub { # match body params The body spec will match if the request content is either application/x-www-form-urlencoded or multipart/form-data - the latter of which is required for uploads - see below. The param spec is elements of one of the following forms: param~ # optional parameter param= # required parameter @param~ # optional multiple parameter @param= # required multiple parameter :param~ # optional parameter in hashref :param= # required parameter in hashref :@param~ # optional multiple in hashref :@param= # required multiple in hashref * # include all other parameters in hashref @* # include all other parameters as multiple in hashref separated by the C<&> character. The arguments added to the request are one per non-C<:>/C<*> parameter (scalar for normal, arrayref for multiple), plus if any C<:>/C<*> specs exist a hashref containing those values. If a parameter has no value, i.e. appears as '?foo&', a value of 1 will be captured. Please note that if you specify a multiple type parameter match, you are ensured of getting an arrayref for the value, EVEN if the current incoming request has only one value. However if a parameter is specified as single and multiple values are found, the last one will be used. For example to match a C parameter with an optional C parameter one would write: '?page=&order_by~' => sub { my ($self, $page, $order_by) = @_; return unless $page =~ /^\d+$/; $order_by ||= 'id'; response_filter { $_[1]->search_rs({}, { page => $page, order_by => $order_by }); } } to implement paging and ordering against a L object. Another Example: To get all parameters as a hashref of arrayrefs, write: '?@*' => sub { my ($self, $params) = @_; ... To get two parameters as a hashref, write: '?:user~&:domain~' => sub { my ($self, $params) = @_; # params contains only 'user' and 'domain' keys You can also mix these, so: '?foo=&@bar~&:coffee=&@*' => sub { my ($self, $foo, $bar, $params) = @_; where $bar is an arrayref (possibly an empty one), and $params contains arrayref values for all parameters B mentioned and a scalar value for the 'coffee' parameter. Note, in the case where you combine arrayref, single parameter and named hashref style, the arrayref and single parameters will appear in C<@_> in the order you defined them in the prototype, but all hashrefs will merge into a single C<$params>, as in the example above. =head3 Upload matches '*foo=' => sub { # param specifier can be anything valid for query or body The upload match system functions exactly like a query/body match, except that the values returned (if any) are C objects. Note that this match type will succeed in two circumstances where you might not expect it to - first, when the field exists but is not an upload field and second, when the field exists but the form is not an upload form (i.e. content type "application/x-www-form-urlencoded" rather than "multipart/form-data"). In either of these cases, what you'll get back is a C object, which will C with an error pointing out the problem if you try and use it. To be sure you have a real upload object, call $upload->is_upload # returns 1 on a valid upload, 0 on a non-upload field and to get the reason why such an object is not an upload, call $upload->reason # returns a reason or '' on a valid upload. Other than these two methods, the upload object provides the same interface as L with the addition of a stringify to the temporary filename to make copying it somewhere else easier to handle. =head3 Combining matches Matches may be combined with the + character - e.g. 'GET + /user/*' => sub { to create an AND match. They may also be combined with the | character - e.g. 'GET|POST' => sub { to create an OR match. Matches can be nested with () - e.g. '(GET|POST + /user/*)' => sub { and negated with ! - e.g. '!/user/foo + /user/*' => sub { ! binds to the immediate rightmost match specification, so if you want to negate a combination you will need to use '!(POST|PUT|DELETE)' => sub { and | binds tighter than +, so '(GET|POST) + /user/*' => sub { and 'GET|POST + /user/*' => sub { are equivalent, but '(GET + /admin/...) | (POST + /admin/...)' => sub { and 'GET + /admin/... | POST + /admin/...' => sub { are not - the latter is equivalent to 'GET + (/admin/...|POST) + /admin/...' => sub { which will never match! =head3 Whitespace Note that for legibility you are permitted to use whitespace: 'GET + /user/*' => sub { but it will be ignored. This is because the perl parser strips whitespace from subroutine prototypes, so this is equivalent to 'GET+/user/*' => sub { =head3 Accessing parameters via C<%_> If your dispatch specification causes your dispatch subroutine to receive a hash reference as its first argument, the contained named parameters will be accessible via C<%_>. This can be used to access your path matches, if they are named: 'GET + /foo/:path_part' => sub { [ 200, ['Content-type' => 'text/plain'], ["We are in $_{path_part}"], ]; } Or, if your first argument would be a hash reference containing named query parameters: 'GET + /foo + ?:some_param=' => sub { [ 200, ['Content-type' => 'text/plain'], ["We received $_{some_param} as parameter"], ]; } Of course this also works when all you are doing is slurping the whole set of parameters by their name: 'GET + /foo + ?*' => sub { [ 200, ['Content-type' => 'text/plain'], [exists($_{foo}) ? "Received a foo: $_{foo}" : "No foo!"], ], } Note that only the first hash reference will be available via C<%_>. If you receive additional hash references, you will need to access them as usual. =head3 Accessing the PSGI env hash In some cases you may wish to get the raw PSGI env hash - to do this, you can either use a plain sub: sub { my ($env) = @_; ... } or use the C constant exported to retrieve it from C<@_>: 'GET + /foo + ?some_param=' => sub { my $param = $_[1]; my $env = $_[PSGI_ENV]; } but note that if you're trying to add a middleware, you should simply use Web::Simple's direct support for doing so. =head1 EXPORTED SUBROUTINES =head2 response_filter response_filter { # Hide errors from the user because we hates them, preciousss if (ref($_[0]) eq 'ARRAY' && $_[0]->[0] == 500) { $_[0] = [ 200, @{$_[0]}[1..$#{$_[0]}] ]; } return $_[0]; }; The response_filter subroutine is designed for use inside dispatch subroutines. It creates and returns a special dispatcher that always matches, and calls the block passed to it as a filter on the result of running the rest of the current dispatch chain. Thus the filter above runs further dispatch as normal, but if the result of dispatch is a 500 (Internal Server Error) response, changes this to a 200 (OK) response without altering the headers or body. =head2 redispatch_to redispatch_to '/other/url'; The redispatch_to subroutine is designed for use inside dispatch subroutines. It creates and returns a special dispatcher that always matches, and instead of continuing dispatch re-delegates it to the start of the dispatch process, but with the path of the request altered to the supplied URL. Thus if you receive a POST to C and return a redispatch to C, the dispatch behaviour will be exactly as if the same POST request had been made to C instead. Note, this is not the same as returning an HTTP 3xx redirect as a response; rather it is a much more efficient internal process. =head1 SECURITY CONSIDERATIONS Request bodies now have a maximum size, which defaults to 8 MiB. If you want to adjust the size, you need to change C<$Web::Dispatch::ParamParser::MAX_BODY_SIZE>, for example, $Web::Dispatch::ParamParser::MAX_BODY_SIZE = 33554432; # 32MiB Requests with larger bodies will croak. You will need to validate the Content-Length header before dispatching it, if you want a user-friendly response. =head1 CHANGES BETWEEN RELEASES =head2 Changes between 0.004 and 0.005 =over 4 =item * dispatch {} replaced by declaring a dispatch_request method dispatch {} has gone away - instead, you write: sub dispatch_request { my $self = shift; ( 'GET /foo/' => sub { ... }, ... ); } Note that this method is still B the dispatch code - just like C did. Also note that you need the C<< my $self = shift >> since the magic $self variable went away. =item * the magic $self variable went away. Just add C<< my $self = shift; >> while writing your C<< sub dispatch_request { >> like a normal perl method. =item * subdispatch deleted - all dispatchers can now subdispatch In earlier releases you needed to write: subdispatch sub (/foo/...) { ... [ sub (GET /bar/) { ... }, ... ] } As of 0.005, you can instead write simply: sub (/foo/...) { ... ( sub (GET /bar/) { ... }, ... ) } =back =head2 Changes since Antiquated Perl =over 4 =item * filter_response renamed to response_filter This is a pure rename; a global search and replace should fix it. =item * dispatch [] changed to dispatch {} Simply changing dispatch [ sub(...) { ... }, ... ]; to dispatch { sub(...) { ... }, ... }; should work fine. =back =head1 DEVELOPMENT HISTORY Web::Simple was originally written to form part of my Antiquated Perl talk for Italian Perl Workshop 2009, but in writing the bloggery example I realised that having a bare minimum system for writing web applications that doesn't drive me insane was rather nice and decided to spend my attempt at nanowrimo for 2009 improving and documenting it to the point where others could use it. The Antiquated Perl talk can be found at L and the slides are reproduced in this distribution under L. =head1 COMMUNITY AND SUPPORT =head2 IRC channel irc.perl.org #web-simple =head2 No mailing list yet Because mst's non-work email is a bombsite so he'd never read it anyway. =head2 Git repository Gitweb is on http://git.shadowcat.co.uk/ and the clone URL is: git clone git://git.shadowcat.co.uk/catagits/Web-Simple.git =head1 AUTHOR Matt S. Trout (mst) =head1 CONTRIBUTORS Devin Austin (dhoss) Arthur Axel 'fREW' Schmidt gregor herrmann (gregoa) John Napiorkowski (jnap) Josh McMichael Justin Hunter (arcanez) Kjetil Kjernsmo markie Christian Walde (Mithaldu) nperez Robin Edwards Andrew Rodland (hobbs) Robert Sedlacek (phaylon) Hakim Cassimally (osfameron) Karen Etheridge (ether) Robert Rothenberg =head1 COPYRIGHT Copyright (c) 2011 the Web::Simple L and L as listed above. =head1 LICENSE This library is free software and may be distributed under the same terms as perl itself. =cut Web-Simple-0.035/lib/Web/Dispatch.pm000644 000000 000000 00000010213 12500156524 015210 0ustar00000000 000000 package Web::Dispatch; use Sub::Quote; use Scalar::Util qw(blessed); sub MAGIC_MIDDLEWARE_KEY { __PACKAGE__.'.middleware' } use Moo; use Web::Dispatch::Parser; use Web::Dispatch::Node; with 'Web::Dispatch::ToApp'; has dispatch_app => ( is => 'lazy', builder => sub { shift->dispatch_object->to_app } ); has dispatch_object => (is => 'ro', required => 0, weak_ref => 1); has parser_class => ( is => 'ro', default => quote_sub q{ 'Web::Dispatch::Parser' } ); has node_class => ( is => 'ro', default => quote_sub q{ 'Web::Dispatch::Node' } ); has _parser => (is => 'lazy'); after BUILDARGS => sub { my ( $self, %args ) = @_; die "Either dispatch_app or dispatch_object need to be supplied." if !$args{dispatch_app} and !$args{dispatch_object} }; sub _build__parser { my ($self) = @_; $self->parser_class->new; } sub call { my ($self, $env) = @_; my $res = $self->_dispatch($env, $self->dispatch_app); return $res->[0] if ref($res) eq 'ARRAY' and @{$res} == 1 and ref($res->[0]) eq 'CODE'; return $res; } sub _dispatch { my ($self, $env, @match) = @_; while (defined(my $try = shift @match)) { return $try if ref($try) eq 'ARRAY'; if (ref($try) eq 'HASH') { $env = { 'Web::Dispatch.original_env' => $env, %$env, %$try }; next; } my @result = $self->_to_try($try, \@match)->($env, @match); next unless @result and defined($result[0]); my $first = $result[0]; if (my $res = $self->_have_result($first, \@result, \@match, $env)) { return $res; } # make a copy so we don't screw with it assigning further up my $env = $env; unshift @match, sub { $self->_dispatch($env, @result) }; } return; } sub _have_result { my ($self, $first, $result, $match, $env) = @_; if (ref($first) eq 'ARRAY') { return $first; } elsif (blessed($first) && $first->isa('Plack::Middleware')) { return $self->_uplevel_middleware($first, $result); } elsif (ref($first) eq 'HASH' and $first->{+MAGIC_MIDDLEWARE_KEY}) { return $self->_redispatch_with_middleware($first, $match, $env); } elsif ( blessed($first) && not($first->can('to_app')) && not($first->isa('Web::Dispatch::Matcher')) ) { return $first; } return; } sub _uplevel_middleware { my ($self, $match, $results) = @_; die "Multiple results but first one is a middleware ($match)" if @{$results} > 1; # middleware needs to uplevel exactly once to wrap the rest of the # level it was created for - next elsif unwraps it return { MAGIC_MIDDLEWARE_KEY, $match }; } sub _redispatch_with_middleware { my ($self, $first, $match, $env) = @_; my $mw = $first->{+MAGIC_MIDDLEWARE_KEY}; $mw->app(sub { $self->_dispatch($_[0], @{$match}) }); return $mw->to_app->($env); } sub _to_try { my ($self, $try, $more) = @_; # sub () {} becomes a dispatcher # sub {} is a PSGI app and can be returned as is # '' => sub {} becomes a dispatcher # $obj isa WD:Predicates::Matcher => sub { ... } - become a dispatcher # $obj w/to_app method is a Plack::App-like thing - call it to get a PSGI app # if (ref($try) eq 'CODE') { if (defined(my $proto = prototype($try))) { $self->_construct_node(match => $proto, run => $try); } else { $try } } elsif (!ref($try) and (ref($more->[0]) eq 'CODE' or ($more->[0] and !ref($more->[0]) and $self->dispatch_object and $self->dispatch_object->can($more->[0]))) ) { $self->_construct_node(match => $try, run => shift(@$more)); } elsif ( (blessed($try) && $try->isa('Web::Dispatch::Matcher')) and (ref($more->[0]) eq 'CODE') ) { $self->_construct_node(match => $try, run => shift(@$more)); } elsif (blessed($try) && $try->can('to_app')) { $try->to_app; } else { die "No idea how we got here with $try"; } } sub _construct_node { my ($self, %args) = @_; $args{match} = $self->_parser->parse($args{match}) if !ref $args{match}; if ( my $obj = $self->dispatch_object) { # if possible, call dispatchers as methods of the app object my $dispatch_sub = $args{run}; $args{run} = sub { $obj->$dispatch_sub(@_) }; } $self->node_class->new(\%args)->to_app; } 1; Web-Simple-0.035/lib/Web/Simple/000750 000000 000000 00000000000 15266735050 014353 5ustar00000000 000000 Web-Simple-0.035/lib/Web/Simple/AntiquatedPerl.pod000644 000000 000000 00000014234 12500156524 020001 0ustar00000000 000000 =head1 NAME Web::Simple::AntiquatedPerl - the slides from the talk =head1 WHAT? Web::Simple was originally introduced in a talk at the Italian Perl Workshop, entitled Antiquated Perl. The video is available on the Shadowcat site: If you don't particularly want to watch me confusing a bunch of Italian perl mongers, the slides are reproduced below. =head1 SLIDES Antiquated Perl ---- Modern Perl? ---- Post Modern Perl ---- Enlightened Perl ---- everybody knows ---- Catalyst Moose DBIx::Class ---- Modern Perl? ---- perl5 v10 ---- given ($x) { when (3) { ... ---- ~~ ---- what's the opposite? ---- Old Perl? ---- if it works ---- Legacy Perl? ---- not interesting ---- Stupid Perl ---- *$&^*(^ FormMail.PL ---- Antiquated Perl ---- Antique ---- Old *and* beautiful ---- Simple Elegant ---- $|++ ---- use IO::Handle; STDOUT->autoflush(1); ---- it's core. it's fine. ---- but why think? ---- select((select(FOO),$|++)[0]) ---- (select(FOO),$|++) -> ($old_selected_fh,$|) ---- (select(FOO),$|++)[0] -> $old_select_fh ---- select((select(FOO),$|++)[0]) -> use IO::Handle; FOO->autoflush(1) ---- ~~ ---- ~~@x ---- ~(~(@x)) ---- bitwise negation ---- so ... ---- ~@x -> ~(scalar @x) ---- ~~$number -> $number ---- ~~@x -> scalar @x ---- perl -MMoose -e'print ~~keys %INC' 84 ---- overload::constant ---- lets you affect parsing ---- numbers strings ---- q qq qr t s qw ---- i18n.pm ---- ~~"$foo bar" loc("_[0] bar", $foo) ---- for ---- for ($foo) { /bar/ and ... ---- for ($foo) { /bar/ and return do { } ---- /foo/gc ---- /\Gbar/gc ---- sub parse { my ($self, $str) = @_; for ($str) { /match1/gc and return $self->_subparse_1($_) ---- sub _subparse_1 { my ($self) = @_; for ($_[1]) { /\Gsubmatch1/gc ... ---- prototypes ---- sub foo (&) { ---- foo { ... }; ---- prototype \&foo ---- typeglobs ---- *{"${package}::${name}"} = sub { ... } ---- local ---- local $_ ---- local *Carp::croak = \&Carp::confess; ---- do { local (@ARGV, $/) = $file; <> } ---- strict and warnings ---- strict->import ---- affects compilation scope ---- sub strict_and_warnings::import { strict->import; warnings->import; } ---- use strict_and_warnings; ---- $^H %^H ---- $^H |= 0x20000; $^H{'foo'} = bless($foo, 'My::Foo'); ---- sub My::Foo::DESTROY { ---- delete ${$package}{myimport} ---- B::Hooks::EndOfScope ---- tie ---- tie $var, 'Foo'; ---- sub FETCH sub STORE ---- Scalar Array Hash Handle ---- now ... ---- mst: destruction testing technology since March 1983 ---- 3 days old ---- 2 weeks early ---- incubator ---- glass box plastic tray heater ---- design flaw ---- BANG ---- so ... ---- interesting fact ---- prototypes only warn when parsed ---- error when compiled ---- so ... ---- dispatch [ sub (GET + /) { ... }, sub (GET + /user/*) { ... } ]; ---- foreach my $sub (@$dispatch) { my $proto = prototype $sub; $parser->parse($proto); ... ---- PARSE: { do { push @match, $self->_parse_spec_section($spec) or $self->_blam("Unable to work out what the next section is"); last PARSE if (pos == length); /\G\+/gc or $self->_blam('Spec sections must be separated by +'); } until (pos == length) }; ---- sub _blam { my ($self, $error) = @_; my $hat = (' ' x pos).'^'; die "Error parsing dispatch specification: ${error}\n ${_} ${hat} here\n"; } ---- Error parsing ... GET+/foo ^ here ---- sub (GET + /user/*) { my ($self, $user) = @_; ---- I hate fetching $self ---- *{"${app}::self"} = \${"${app}::self"}; ---- use vars ---- sub _run_with_self { my ($self, $run, @args) = @_; my $class = ref($self); no strict 'refs'; local *{"${class}::self"} = \$self; $self->$run(@args); } ---- HTML output ---- templates ---- HTML is NOT TEXT ----
, $text,
; ----
---- <$fh> ---- tie *{"${app}::${name}"}, 'XML::Tags::TIEHANDLE', "<${name}>"; ---- sub TIEHANDLE { my $str = $_[1]; bless \$str, $_[0] } sub READLINE { ${$_[0]} } ---- sub DESTROY { my ($into, @names) = @$_[0]; no strict 'refs'; delete ${$into}{$_} for @names; } ----
---- glob('/div'); ---- *CORE::GLOBAL::glob = sub { ... }; ---- delete ${CORE::GLOBAL::}{glob}; ---- sub foo { use XML::Tags qw(div);
, "foo!",
; } ---- what about interpolation ---- my $stuff = 'foo"bar'; ---- hmm ... ---- overload::constant! ---- glob('a href="'.$stuff.'"'); ---- glob( bless(\'a href="', 'MagicTag') .$stuff .bless(\'"', 'MagicTag') ) ---- use overload '.' => 'concat'; sub concat { ---- hooking it up ---- sub (.html) { filter_response { $self->render_html($_[1]) } } ---- bless( $_[1], 'Web::Simple::ResponseFilter' ); ---- if ($self->_is_response_filter($result)) { return $self->_run_with_self( $result, $self->_run_dispatch_for($new_env, \@disp) ); } ---- and the result? ---- goto &demo; ---- questions? ---- thank you =head1 AUTHOR Matt S. Trout =head1 COPYRIGHT Copyright (c) 2011 Matt S. Trout =head1 LICENSE This text is free documentation under the same license as perl itself. =cut Web-Simple-0.035/lib/Web/Simple/Deployment.pod000644 000000 000000 00000003365 12500156524 017202 0ustar00000000 000000 =head1 NAME Web::Simple::Deployment - various deployment options =head1 DESCRIPTION This file documents common deployment methods for Web::Simple. If you feel one is missing, please ask in the IRC channel and we'll work with you to add it. =head1 CGI The most basic deployment option is as a CGI script loading and running your Web::Simple-module: #!/usr/bin/env perl use Your::Web::Simple::App; Your::Web::Simple::App->run_if_script; Save that as script.cgi and your web server will handle it correctly. =head1 Plack-Server This works in with exactly the same code as CGI deployment. However instead of letting your web server load script.cgi, you run this on the command line: plackup script.cgi =head2 Self-contained CGI Sometimes your app is so small that you have only one or two tiny classes that you want to run as a CGI script. Web::Simple offers a helpful mechanism to achieve that. #!/usr/bin/env perl use Web::Simple 'HelloWorld'; # enables strictures and warnings for the file # additionally, HelloWorld is upgraded to a # Web::Simple application { package HelloWorld; sub dispatch_request { sub (GET) { [ 200, [ 'Content-type', 'text/plain' ], [ 'Hello world! It is a fine ' . HelloWorld::Helper->day ] ] }, sub () { [ 405, [ 'Content-type', 'text/plain' ], [ 'Method not allowed' ] ] } } } { package HelloWorld::Helper; use DateTime; sub day { return DateTime->now->day_name; } } HelloWorld->run_if_script; =head1 AUTHORS See L for authors. =head1 COPYRIGHT AND LICENSE See L for the copyright and license. =cut Web-Simple-0.035/lib/Web/Simple/Application.pm000644 000000 000000 00000024511 12761653370 017165 0ustar00000000 000000 package Web::Simple::Application; use Scalar::Util 'weaken'; use Moo; has 'config' => ( is => 'ro', default => sub { my ($self) = @_; +{ $self->default_config } }, trigger => sub { my ($self, $value) = @_; my %default = $self->default_config; my @not = grep !exists $value->{$_}, keys %default; @{$value}{@not} = @default{@not}; } ); sub default_config { () } has '_dispatcher' => (is => 'lazy'); sub _build__dispatcher { my $self = shift; require Web::Dispatch; my $final = $self->_build_final_dispatcher; # We need to weaken both the copy of $self that the # app parameter will close over and the copy that'll # be passed through as a node argument. # # To ensure that this doesn't then result in us being # DESTROYed unexpectedly early, our to_psgi_app method # closes back over $self weaken($self); my %dispatch_args = ( dispatch_app => sub { $self->dispatch_request(@_), $final }, dispatch_object => $self ); weaken($dispatch_args{dispatch_object}); Web::Dispatch->new(%dispatch_args); } sub _build_final_dispatcher { [ 404, [ 'Content-type', 'text/plain' ], [ 'Not found' ] ] } sub run_if_script { # ->to_psgi_app is true for require() but also works for plackup return $_[0]->to_psgi_app if caller(1); my $self = ref($_[0]) ? $_[0] : $_[0]->new; $self->run(@_); } sub _run_cgi { my $self = shift; require Plack::Handler::CGI; Plack::Handler::CGI->new->run($self->to_psgi_app); } sub _run_fcgi { my $self = shift; require Plack::Handler::FCGI; Plack::Handler::FCGI->new->run($self->to_psgi_app); } sub to_psgi_app { my $self = ref($_[0]) ? $_[0] : $_[0]->new; my $app = $self->_dispatcher->to_app; # Close over $self to keep $self alive even though # we weakened the copies the dispatcher has; the # if 0 causes the ops to be optimised away to # minimise the performance impact and avoid void # context warnings while still doing the closing # over part. As Mithaldu said: "Gnarly." ... return sub { $self if 0; goto &$app; }; } sub run { my $self = shift; if ( $ENV{PHP_FCGI_CHILDREN} || $ENV{FCGI_ROLE} || $ENV{FCGI_SOCKET_PATH} || ( -S STDIN && !$ENV{GATEWAY_INTERFACE} ) # If STDIN is a socket, almost certainly FastCGI, except for mod_cgid ) { return $self->_run_fcgi; } elsif ($ENV{GATEWAY_INTERFACE}) { return $self->_run_cgi; } unless (@ARGV && $ARGV[0] =~ m{(^[A-Z/])|\@}) { return $self->_run_cli(@ARGV); } my @args = @ARGV; unshift(@args, 'GET') if $args[0] !~ /^[A-Z]/; $self->_run_cli_test_request(@args); } sub _test_request_spec_to_http_request { my ($self, $method, $path, @rest) = @_; # if it's a reference, assume a request object return $method if ref($method); if ($path =~ s/^(.*?)\@//) { my $basic = $1; require MIME::Base64; unshift @rest, 'Authorization:', 'Basic '.MIME::Base64::encode($basic); } my $request = HTTP::Request->new($method => $path); my @params; while (my ($header, $value) = splice(@rest, 0, 2)) { unless ($header =~ s/:$//) { push @params, $header, $value; } $header =~ s/_/-/g; if ($header eq 'Content') { $request->content($value); } else { $request->headers->push_header($header, $value); } } if (($method eq 'POST' or $method eq 'PUT') and @params) { my $content = do { require URI; my $url = URI->new('http:'); $url->query_form(@params); $url->query; }; $request->header('Content-Type' => 'application/x-www-form-urlencoded'); $request->header('Content-Length' => length($content)); $request->content($content); } return $request; } sub run_test_request { my ($self, @req) = @_; require HTTP::Request; require Plack::Test; my $request = $self->_test_request_spec_to_http_request(@req); Plack::Test::test_psgi( $self->to_psgi_app, sub { shift->($request) } ); } sub _run_cli_test_request { my ($self, @req) = @_; my $response = $self->run_test_request(@req); binmode(STDOUT); binmode(STDERR); # for win32 print STDERR $response->status_line."\n"; print STDERR $response->headers_as_string("\n")."\n"; my $content = $response->content; $content .= "\n" if length($content) and $content !~ /\n\z/; print STDOUT $content if $content; } sub _run_cli { my $self = shift; die $self->_cli_usage; } sub _cli_usage { "To run this script in CGI test mode, pass a URL path beginning with /:\n". "\n". " $0 /some/path\n". " $0 /\n" } 1; =head1 NAME Web::Simple::Application - A base class for your Web-Simple application =head1 DESCRIPTION This is a base class for your L application. You probably don't need to construct this class yourself, since L does the 'heavy lifting' for you in that regards. =head1 METHODS This class exposes the following public methods. =head2 default_config Merges with the C initializer to provide configuration information for your application. For example: sub default_config { ( title => 'Bloggery', posts_dir => $FindBin::Bin.'/posts', ); } Now, the C attribute of C<$self> will be set to a HashRef containing keys 'title' and 'posts_dir'. The keys from default_config are merged into any config supplied, so if you construct your application like: MyWebSimpleApp::Web->new( config => { title => 'Spoon', environment => 'dev' } ) then C will contain: { title => 'Spoon', posts_dir => '/path/to/myapp/posts', environment => 'dev' } =head2 run_if_script The run_if_script method is designed to be used at the end of the script or .pm file where your application class is defined - for example: ## my_web_simple_app.pl #!/usr/bin/env perl use Web::Simple 'HelloWorld'; { package HelloWorld; sub dispatch_request { sub (GET) { [ 200, [ 'Content-type', 'text/plain' ], [ 'Hello world!' ] ] }, sub () { [ 405, [ 'Content-type', 'text/plain' ], [ 'Method not allowed' ] ] } } } HelloWorld->run_if_script; This returns a true value, so your file is now valid as a module - so require 'my_web_simple_app.pl'; my $hw = HelloWorld->new; will work fine (and you can rename it to lib/HelloWorld.pm later to make it a real use-able module). However, it detects if it's being run as a script (via testing $0) and if so attempts to do the right thing. If run under a CGI environment, your application will execute as a CGI. If run under a FastCGI environment, your application will execute as a FastCGI process (this works both for dynamic shared-hosting-style FastCGI and for apache FastCgiServer style setups). If run from the commandline with a URL path, it runs a GET request against that path - $ perl -Ilib examples/hello-world/hello-world.cgi / 200 OK Content-Type: text/plain Hello world! You can also provide a method name - $ perl -Ilib examples/hello-world/hello-world.cgi POST / 405 Method Not Allowed Content-Type: text/plain Method not allowed For a POST or PUT request, pairs on the command line will be treated as form variables. For any request, pairs on the command line ending in : are treated as headers, and 'Content:' will set the request body - $ ./myapp POST / Accept: text/html form_field_name form_field_value $ ./myapp POST / Content-Type: text/json Content: '{ "json": "here" }' The body of the response is sent to STDOUT and the headers to STDERR, so $ ./myapp GET / >index.html will generally do the right thing. To send basic authentication credentials, use user:pass@ syntax - $ ./myapp GET bob:secret@/protected/path Additionally, you can treat the file as though it were a standard PSGI application file (*.psgi). For example you can start up up with C plackup my_web_simple_app.pl or C starman my_web_simple_app.pl =head2 to_psgi_app This method is called by L to create the L app coderef for use via L and L. If you want to globally add middleware, you can override this method: use Web::Simple 'HelloWorld'; { package HelloWorld; use Plack::Builder; around 'to_psgi_app', sub { my ($orig, $self) = (shift, shift); my $app = $self->$orig(@_); builder { enable ...; ## whatever middleware you want $app; }; }; } This method can also be used to mount a Web::Simple application within a separate C<*.psgi> file - use strictures 1; use Plack::Builder; use WSApp; use AnotherWSApp; builder { mount '/' => WSApp->to_psgi_app; mount '/another' => AnotherWSApp->to_psgi_app; }; This method can be called as a class method, in which case it implicitly calls ->new, or as an object method ... in which case it doesn't. =head2 run Used for running your application under stand-alone CGI and FCGI modes. I should document this more extensively but run_if_script will call it when you need it, so don't worry about it too much. =head2 run_test_request my $res = $app->run_test_request(GET => '/' => %headers); my $res = $app->run_test_request(POST => '/' => %headers_or_form); my $res = $app->run_test_request($http_request); Accepts either an L object or ($method, $path) and runs that request against the application, returning an L object. If the HTTP method is POST or PUT, then a series of pairs can be passed after this to create a form style message body. If you need to test an upload, then create an L object by hand or use the C subroutine provided by L. If you prefix the URL with 'user:pass@' this will be converted into an Authorization header for HTTP basic auth: my $res = $app->run_test_request( GET => 'bob:secret@/protected/resource' ); If pairs are passed where the key ends in :, it is instead treated as a headers, so: my $res = $app->run_test_request( POST => '/', 'Accept:' => 'text/html', some_form_key => 'value' ); will do what you expect. You can also pass a special key of Content: to set the request body: my $res = $app->run_test_request( POST => '/', 'Content-Type:' => 'text/json', 'Content:' => '{ "json": "here" }', ); =head1 AUTHORS See L for authors. =head1 COPYRIGHT AND LICENSE See L for the copyright and license. =cut Web-Simple-0.035/lib/Web/Simple/HackedPlack.pm000644 000000 000000 00000004663 12500156524 017050 0ustar00000000 000000 # This is Plack::Server::CGI, copied almost verbatim. # Except I inlined the bits of Plack::Util it needed. # Because it loads a number of modules that I didn't. # miyagawa, I'm sorry to butcher your code like this. # The apology would have been in the form of a haiku. # But I needed more syllables than that would permit. # So I thought perhaps I'd make it bricktext instead. # -- love, mst # Hide from PAUSE package Plack::Server::CGI; use strict; use warnings; use IO::Handle; BEGIN { # Hide from PAUSE package Plack::Util; sub foreach { my($body, $cb) = @_; if (ref $body eq 'ARRAY') { for my $line (@$body) { $cb->($line) if length $line; } } else { local $/ = \4096 unless ref $/; while (defined(my $line = $body->getline)) { $cb->($line) if length $line; } $body->close; } } sub TRUE() { 1==1 } sub FALSE() { !TRUE } } sub new { bless {}, shift } sub run { my ($self, $app) = @_; my %env; while (my ($k, $v) = each %ENV) { next unless $k =~ qr/^(?:REQUEST_METHOD|SCRIPT_NAME|PATH_INFO|QUERY_STRING|SERVER_NAME|SERVER_PORT|SERVER_PROTOCOL|CONTENT_LENGTH|CONTENT_TYPE|REMOTE_ADDR|REQUEST_URI)$|^HTTP_/; $env{$k} = $v; } $env{'HTTP_COOKIE'} ||= $ENV{COOKIE}; $env{'psgi.version'} = [ 1, 0 ]; $env{'psgi.url_scheme'} = ($ENV{HTTPS}||'off') =~ /^(?:on|1)$/i ? 'https' : 'http'; $env{'psgi.input'} = *STDIN; $env{'psgi.errors'} = *STDERR; $env{'psgi.multithread'} = Plack::Util::FALSE; $env{'psgi.multiprocess'} = Plack::Util::TRUE; $env{'psgi.run_once'} = Plack::Util::TRUE; my $res = $app->(\%env); print "Status: $res->[0]\n"; my $headers = $res->[1]; while (my ($k, $v) = splice(@$headers, 0, 2)) { print "$k: $v\n"; } print "\n"; my $body = $res->[2]; my $cb = sub { print STDOUT $_[0] }; Plack::Util::foreach($body, $cb); } 1; __END__ =head1 SYNOPSIS ## in your .cgi #!/usr/bin/perl use Plack::Server::CGI; # or Plack::Util::load_psgi("/path/to/app.psgi"); my $app = sub { my $env = shift; return [ 200, [ 'Content-Type' => 'text/plain', 'Content-Length' => 13 ], 'Hello, world!', ]; }; Plack::Server::CGI->new->run($app); =head1 SEE ALSO L =cut Web-Simple-0.035/lib/Web/Simple/Role.pm000644 000000 000000 00000001671 15266735004 015623 0ustar00000000 000000 package Web::Simple::Role; use strictures 1; use warnings::illegalproto (); use Moo::Role (); our $VERSION = '0.035'; sub import { my ($class, $app_package) = @_; $app_package ||= caller; eval "package $app_package; use Web::Dispatch::Wrapper; use Moo::Role; 1" or die "Failed to setup app package: $@"; strictures->import; warnings::illegalproto->unimport; } 1; __END__ =head1 NAME Web::Simple::Role - Define roles for Web::Simple applications =head1 SYNOPSIS package MyApp; use Web::Simple; with MyApp::Role; sub dispatch_request { ... } and in the role: package MyApp::Role; use Web::Simple::Role; around dispatch_request => sub { my ($orig, $self) = @_; return ( $self->$orig, sub (GET + /baz) { ... } ); }; Now C can also dispatch C =head1 AUTHORS See L for authors. =head1 COPYRIGHT AND LICENSE See L for the copyright and license. =cut Web-Simple-0.035/lib/Web/Dispatch/ToApp.pm000644 000000 000000 00000000201 12500156524 016227 0ustar00000000 000000 package Web::Dispatch::ToApp; use Moo::Role; requires 'call'; sub to_app { my ($self) = @_; sub { $self->call(@_) } } 1; Web-Simple-0.035/lib/Web/Dispatch/Wrapper.pm000644 000000 000000 00000001457 12500156524 016642 0ustar00000000 000000 package Web::Dispatch::Wrapper; use strictures 1; use Moo; use Exporter 'import'; our @EXPORT = qw(dispatch_wrapper redispatch_to response_filter); extends 'Plack::Middleware'; has 'wrapper' => (is => 'ro', required => 1); sub dispatch_wrapper (&) { my ($code) = @_; __PACKAGE__->from_code($code); } sub from_code { my ($class, $code) = @_; $class->new(wrapper => $code); } sub redispatch_to { my ($new_path) = @_; __PACKAGE__->from_code(sub { $_[1]->({ %{$_[0]}, PATH_INFO => $new_path }); }); } sub response_filter (&) { my ($code) = @_; __PACKAGE__->from_code(sub { my @result = $_[1]->($_[0]); if (@result) { $code->(@result); } else { () } }); } sub to_app { my $code = $_[0]->wrapper; my $app = $_[0]->app; sub { $code->($_[0], $app) } } 1; Web-Simple-0.035/lib/Web/Dispatch/Parser.pm000644 000000 000000 00000014634 12500156524 016457 0ustar00000000 000000 package Web::Dispatch::Parser; sub DEBUG () { 0 } BEGIN { if ($ENV{WEB_DISPATCH_PARSER_DEBUG}) { no warnings 'redefine'; *DEBUG = sub () { 1 } } } use Sub::Quote; use Web::Dispatch::Predicates; use Moo; has _cache => ( is => 'lazy', default => quote_sub q{ {} } ); sub diag { if (DEBUG) { warn $_[0] } } sub _wtf { my ($self, $error) = @_; my $hat = (' ' x (pos||0)).'^'; warn "Warning parsing dispatch specification: ${error}\n ${_} ${hat} here\n"; } sub _blam { my ($self, $error) = @_; my $hat = (' ' x (pos||0)).'^'; die "Error parsing dispatch specification: ${error}\n ${_} ${hat} here\n"; } sub parse { my ($self, $spec) = @_; $spec =~ s/\s+//g; # whitespace is not valid return $self->_cache->{$spec} ||= $self->_parse_spec($spec); } sub _parse_spec { my ($self, $spec, $nested) = @_; return match_true() unless length($spec); for ($_[1]) { my @match; my $close; PARSE: { do { push @match, $self->_parse_spec_section($_) or $self->_blam("Unable to work out what the next section is"); if (/\G\)/gc) { $self->_blam("Found closing ) with no opening (") unless $nested; $close = 1; last PARSE; } last PARSE if (pos == length); $match[-1] = $self->_parse_spec_combinator($_, $match[-1]) or $self->_blam('No valid combinator - expected + or |'); } until (pos == length) }; # accept trailing whitespace if (!$close and $nested and pos == length) { pos = $nested - 1; $self->_blam("No closing ) found for opening ("); } return $match[0] if (@match == 1); return match_and(@match); } } sub _parse_spec_combinator { my ($self, $spec, $match) = @_; for ($_[1]) { /\G\+/gc and return $match; /\G\|/gc and return do { my @match = $match; PARSE: { do { push @match, $self->_parse_spec_section($_) or $self->_blam("Unable to work out what the next section is"); last PARSE if (pos == length); last PARSE unless /\G\|/gc; # give up when next thing isn't | } until (pos == length) }; # accept trailing whitespace return match_or(@match); }; } return; } sub _parse_spec_section { my ($self) = @_; for ($_[1]) { # ~ /\G~/gc and return match_path('^$'); # GET POST PUT HEAD ... /\G([A-Z]+)/gc and return match_method($1); # /... /\G(?=\/)/gc and return $self->_url_path_match($_); # .* and .html /\G\.(\*|\w+)/gc and return match_extension($1); # (...) /\G\(/gc and return $self->_parse_spec($_, pos); # !something /\G!/gc and return match_not($self->_parse_spec_section($_)); # ? /\G\?/gc and return $self->_parse_param_handler($_, 'query'); # % /\G\%/gc and return $self->_parse_param_handler($_, 'body'); # * /\G\*/gc and return $self->_parse_param_handler($_, 'uploads'); } return; # () will trigger the blam in our caller } sub _url_path_match { my ($self) = @_; for ($_[1]) { my (@path, @names, $seen_nameless); my $end = ''; my $keep_dot; PATH: while (/\G\//gc) { /\G\.\.\./gc and do { $end = '(/.*)'; last PATH; }; my ($segment) = $self->_url_path_segment_match($_) or $self->_blam("Couldn't parse path match segment"); if (ref($segment)) { ($segment, $keep_dot, my $name) = @$segment; if (defined($name)) { $self->_blam("Can't mix positional and named captures in path match") if $seen_nameless; push @names, $name; } else { $self->_blam("Can't mix positional and named captures in path match") if @names; $seen_nameless = 1; } } push @path, $segment; /\G\.\.\./gc and do { $end = '(|/.*)'; last PATH; }; /\G\.\*/gc and $keep_dot = 1; last PATH if $keep_dot; } if (@path && !$end && !$keep_dot) { length and $_ .= '(?:\.\w+)?' for $path[-1]; } my $re = '^('.join('/','',@path).')'.$end.'$'; $re = qr/$re/; if ($end) { return match_path_strip($re, @names ? \@names : ()); } else { return match_path($re, @names ? \@names : ()); } } return; } sub _url_path_segment_match { my ($self) = @_; for ($_[1]) { # trailing / -> require / on end of URL /\G(?:(?=[+|\)])|$)/gc and return ''; # word chars only -> exact path part match / \G( (?: # start matching at a space followed by: [\w\-] # word chars or dashes | # OR \. # a period (?!\.) # not followed by another period ) + # then grab as far as possible ) /gcx and return "\Q$1"; # ** -> capture unlimited path parts /\G\*\*(?:(\.\*)?\:(\w+))?/gc and return [ '(.*?[^/])', $1, $2 ]; # * -> capture path part # *:name -> capture named path part /\G\*(?:(\.\*)?\:(\w+))?/gc and return [ '([^/]+?)', $1, $2 ]; # :name -> capture named path part /\G\:(\w+)/gc and return [ '([^/]+?)', 0, $1 ]; } return (); } sub _parse_param_handler { my ($self, $spec, $type) = @_; for ($_[1]) { my (@required, @single, %multi, $star, $multistar, %positional, $have_kw); my %spec; my $pos_idx = 0; PARAM: { do { # ?:foo or ?@:foo my $is_kw = /\G\:/gc; # ?@foo or ?@* my $multi = /\G\@/gc; # @* or * if (/\G\*/gc) { $self->_blam("* is always named; no need to supply :") if $is_kw; if ($star) { $self->_blam("Can only use one * or \@* in a parameter match"); } $spec{star} = { multi => $multi }; } else { # @foo= or foo= or @foo~ or foo~ /\G([\w.]*)/gc or $self->_blam('Expected parameter name'); my $name = $1; # check for = or ~ on the end /\G\=/gc ? push(@{$spec{required}||=[]}, $name) : (/\G\~/gc or $self->_blam('Expected = or ~ after parameter name')); # record positional or keyword push @{$spec{$is_kw ? 'named' : 'positional'}||=[]}, { name => $name, multi => $multi }; } } while (/\G\&/gc) } return Web::Dispatch::Predicates->can("match_${type}")->(\%spec); } } 1; Web-Simple-0.035/lib/Web/Dispatch/HTTPMethods.pm000644 000000 000000 00000011432 15266213772 017332 0ustar00000000 000000 package Web::Dispatch::HTTPMethods; use strictures 1; use Web::Dispatch::Predicates qw(match_method); use Scalar::Util qw(blessed); use Exporter 'import'; our @EXPORT = qw(GET HEAD POST PUT DELETE OPTIONS); sub HEAD(&;@) { method_helper(HEAD => @_) } sub GET(&;@) { method_helper(GET => @_) } sub POST(&;@) { method_helper(POST => @_) } sub PUT(&;@) { method_helper(PUT => @_) } sub DELETE(&;@) { method_helper(DELETE => @_) } sub OPTIONS(&;@) { method_helper(OPTIONS => @_) } { package Web::Dispatch::HTTPMethods::Endpoint; sub new { bless { map { $_=>0 } @EXPORT }, shift } sub hdrs { 'Content-Type' => 'text/plain' } sub create_implicit_HEAD { my $self = shift; if($self->{GET} && not $self->{HEAD}) { $self->{HEAD} = sub { [ @{$self->{GET}->(@_)}[0,1], []] }; } } sub create_implicit_OPTIONS { my $self = shift; $self->{OPTIONS} = sub { [200, [$self->hdrs, Allow=>$self->allowed] , [] ]; }; } sub allowed { join ',', grep { $_[0]->{$_} } @EXPORT } sub to_app { my $self = shift; my $implicit_HEAD = $self->create_implicit_HEAD; my $implicit_OPTIONS = $self->create_implicit_OPTIONS; return sub { my $env = shift; if($env->{REQUEST_METHOD} eq 'HEAD') { $implicit_HEAD->($env); } elsif($env->{REQUEST_METHOD} eq 'OPTIONS') { $implicit_OPTIONS->($env); } else { [405, [$self->hdrs, Allow=>$self->allowed] , ['Method Not Allowed'] ]; } }; } } sub isa_endpoint { blessed($_[0]) && $_[0]->isa('Web::Dispatch::HTTPMethods::Endpoint') } sub endpoint_from { return $_[-1] } sub new_endpoint { Web::Dispatch::HTTPMethods::Endpoint->new(@_) } sub method_helper { my $predicate = match_method(my $method = shift); my ($code, @following ) = @_; endpoint_from( my @dispatchers = scalar(@following) ? ($predicate, @_) : ($predicate, @_, new_endpoint) )->{$method} = $code; die "Non HTTP Method dispatcher detected in HTTP Method scope" unless(isa_endpoint($dispatchers[-1])); return @dispatchers; } 1; =head1 NAME Web::Dispatch::HTTPMethods - Helpers to make RESTFul Dispatchers Easier =head1 SYNOPSIS package MyApp:WithHTTPMethods; use Web::Simple; use Web::Dispatch::HTTPMethods; sub as_text { [200, ['Content-Type' => 'text/plain'], [$_[0]->{REQUEST_METHOD}, $_[0]->{REQUEST_URI}] ] } sub dispatch_request { sub (/get) { GET { as_text(pop) } }, sub (/get-head) { GET { as_text(pop) } HEAD { [204,[],[]] }, }, sub (/get-post-put) { GET { as_text(pop) } ## NOTE: no commas separating http methods POST { as_text(pop) } PUT { as_text(pop) } }, } =head1 DESCRIPTION Exports the most commonly used HTTP methods as subroutine helpers into your L based application. Use of these methods additionally adds an automatic HTTP code 405 C response if none of the HTTP methods match for a given dispatch and also adds a dispatch rule for C if no C exists but a C does (in which case the C returns the C dispatch with an empty body.) We also add support at the end of the chain for the OPTIONS method. This defaults to HTTP 200 OK + Allows http headers. We also try to set correct HTTP headers such as C as makes sense based on your dispatch chain. The following dispatch chains are basically the same: sub dispatch_request { sub (/get-http-methods) { GET { [200, ['Content-Type' => 'text/plain'], ['Hello World']] } }, sub(/get-classic) { sub (GET) { [200, ['Content-Type' => 'text/plain'], ['Hello World']] }, sub (HEAD) { [200, ['Content-Type' => 'text/plain'], []] }, sub (OPTIONS) { [200, ['Content-Type' => 'text/plain', Allows=>'GET,HEAD,OPTIONS'], []]; }, sub () { [405, ['Content-Type' => 'text/plain', Allows=>'GET,HEAD,OPTIONS'], ['Method Not Allowed']] }, } } The idea here is less boilerplate to distract the reader from the main point of the code and also to encapsulate some best practices. B You currently cannot mix http method style and prototype sub style in the same scope, as in the following example: sub dispatch_request { sub (/get-head) { GET { ... } sub (HEAD) { ... } }, } If you try this our code will notice and issue a C. If you have a good use case please bring it to the authors. =head2 EXPORTS This automatically exports the following subroutines: GET PUT POST HEAD DELETE OPTIONS =head1 AUTHOR See L for AUTHOR =head1 CONTRIBUTORS See L for CONTRIBUTORS =head1 COPYRIGHT See L for COPYRIGHT =head1 LICENSE See L for LICENSE =cut Web-Simple-0.035/lib/Web/Dispatch/Predicates.pm000644 000000 000000 00000007416 12500156524 017306 0ustar00000000 000000 package Web::Dispatch::Predicates; use strictures 1; use Exporter 'import'; our @EXPORT = qw( match_and match_or match_not match_method match_path match_path_strip match_extension match_query match_body match_uploads match_true match_false ); sub _matcher { bless shift, 'Web::Dispatch::Matcher' } sub match_true { _matcher(sub { {} }); } sub match_false { _matcher(sub {}); } sub match_and { my @match = @_; _matcher(sub { my ($env) = @_; my $my_env = { 'Web::Dispatch.original_env' => $env, %$env }; my $new_env; my @got; foreach my $match (@match) { if (my @this_got = $match->($my_env)) { my %change_env = %{shift(@this_got)}; @{$my_env}{keys %change_env} = values %change_env; @{$new_env}{keys %change_env} = values %change_env; push @got, @this_got; } else { return; } } return ($new_env, @got); }) } sub match_or { my @match = @_; _matcher(sub { foreach my $try (@match) { if (my @ret = $try->(@_)) { return @ret; } } return; }) } sub match_not { my ($match) = @_; _matcher(sub { if (my @discard = $match->($_[0])) { (); } else { ({}); } }) } sub match_method { my ($method) = @_; _matcher(sub { my ($env) = @_; $env->{REQUEST_METHOD} eq $method ? {} : () }) } sub match_path { my ($re, $names) = @_; _matcher(sub { my ($env) = @_; if (my @cap = ($env->{PATH_INFO} =~ /$re/)) { $cap[0] = {}; $cap[1] = do { my %c; @c{@$names} = splice @cap, 1; \%c } if $names; return @cap; } return; }) } sub match_path_strip { my ($re, $names) = @_; _matcher(sub { my ($env) = @_; if (my @cap = ($env->{PATH_INFO} =~ /$re/)) { $cap[0] = { SCRIPT_NAME => ($env->{SCRIPT_NAME}||'').$cap[0], PATH_INFO => pop(@cap), }; $cap[1] = do { my %c; @c{@$names} = splice @cap, 1; \%c } if $names; return @cap; } return; }) } sub match_extension { my ($extension) = @_; my $wild = (!$extension or $extension eq '*'); my $re = $wild ? qr/\.(\w+)$/ : qr/\.(\Q${extension}\E)$/; _matcher(sub { if ($_[0]->{PATH_INFO} =~ $re) { ($wild ? ({}, $1) : {}); } else { (); } }); } sub match_query { _matcher(_param_matcher(query => $_[0])); } sub match_body { _matcher(_param_matcher(body => $_[0])); } sub match_uploads { _matcher(_param_matcher(uploads => $_[0])); } sub _param_matcher { my ($type, $spec) = @_; # We're probably parsing a match spec while building the parser, and # on 5.8.8, loading ParamParser loads Encode which blows away $_ and pos. # Furthermore, localizing $_ doesn't restore pos afterwards. So do this # stupid thing instead to work on 5.8.8 my $saved_pos = pos; { local $_; require Web::Dispatch::ParamParser; } pos = $saved_pos; my $unpack = Web::Dispatch::ParamParser->can("get_unpacked_${type}_from"); sub { _extract_params($unpack->($_[0]), $spec) }; } sub _extract_params { my ($raw, $spec) = @_; foreach my $name (@{$spec->{required}||[]}) { return unless exists $raw->{$name}; } my @ret = ( {}, map { $_->{multi} ? $raw->{$_->{name}}||[] : $raw->{$_->{name}}->[-1] } @{$spec->{positional}||[]} ); # separated since 'or' is short circuit my ($named, $star) = ($spec->{named}, $spec->{star}); if ($named or $star) { my %kw; if ($star) { @kw{keys %$raw} = ( $star->{multi} ? values %$raw : map $_->[-1], values %$raw ); } foreach my $n (@{$named||[]}) { next if !$n->{multi} and !exists $raw->{$n->{name}}; $kw{$n->{name}} = $n->{multi} ? $raw->{$n->{name}}||[] : $raw->{$n->{name}}->[-1]; } push @ret, \%kw; } @ret; } 1; Web-Simple-0.035/lib/Web/Dispatch/ParamParser.pm000644 000000 000000 00000011153 15266733706 017450 0ustar00000000 000000 package Web::Dispatch::ParamParser; use strict; use warnings FATAL => 'all'; use Encode 'decode_utf8'; our $MAX_BODY_SIZE = 8388608; # 8MiB sub UNPACKED_QUERY () { __PACKAGE__.'.unpacked_query' } sub UNPACKED_BODY () { __PACKAGE__.'.unpacked_body' } sub UNPACKED_BODY_OBJECT () { __PACKAGE__.'.unpacked_body_object' } sub UNPACKED_UPLOADS () { __PACKAGE__.'.unpacked_uploads' } sub ORIG_ENV () { 'Web::Dispatch.original_env' } sub get_unpacked_query_from { return ($_[0]->{+ORIG_ENV}||$_[0])->{+UNPACKED_QUERY} ||= do { _unpack_params($_[0]->{QUERY_STRING}) }; } sub get_unpacked_body_from { return ($_[0]->{+ORIG_ENV}||$_[0])->{+UNPACKED_BODY} ||= do { my $ct = lc($_[0]->{CONTENT_TYPE}||''); if (!$_[0]->{CONTENT_LENGTH}) { {} } elsif (index($ct, 'application/x-www-form-urlencoded') >= 0) { my $buf = ""; _chunk_reader( $_[0], sub { $buf .= $_[0] } ); _unpack_params($buf); } elsif (index($ct, 'multipart/form-data') >= 0) { my $p = get_unpacked_body_object_from($_[0])->param; # forcible arrayification (functional, $p does not belong to us, # do NOT replace this with a side-effect ridden "simpler" version) +{ map +(ref($p->{$_}) eq 'ARRAY' ? ($_ => $p->{$_}) : ($_ => [ $p->{$_} ]) ), keys %$p }; } else { {} } }; } sub get_unpacked_body_object_from { # we may have no object at all - so use a single element arrayref for ||= return (($_[0]->{+ORIG_ENV}||$_[0])->{+UNPACKED_BODY_OBJECT} ||= do { if (!$_[0]->{CONTENT_LENGTH}) { [ undef ] } elsif (index(lc($_[0]->{CONTENT_TYPE}||''),'multipart/form-data')==-1) { [ undef ] } else { [ _make_http_body($_[0]) ] } })->[0]; } sub get_unpacked_uploads_from { $_[0]->{+UNPACKED_UPLOADS} ||= do { require Web::Dispatch::Upload; require HTTP::Headers; my ($final, $reason) = ( {}, "field %s exists with value %s but body was not multipart/form-data" ); if (my $body = get_unpacked_body_object_from($_[0])) { my $u = $body->upload; $reason = "field %s exists with value %s but was not an upload"; foreach my $k (keys %$u) { foreach my $v (ref($u->{$k}) eq 'ARRAY' ? @{$u->{$k}} : $u->{$k}) { push(@{$final->{$k}||=[]}, Web::Dispatch::Upload->new( %{$v}, headers => HTTP::Headers->new($v->{headers}) )); } } } my $b = get_unpacked_body_from($_[0]); foreach my $k (keys %$b) { next if $final->{$k}; foreach my $v (@{$b->{$k}}) { next unless $v; push(@{$final->{$k}||=[]}, Web::Dispatch::NotAnUpload->new( filename => $v, reason => sprintf($reason, $k, $v) )); } } $final; }; } { # shamelessly stolen from HTTP::Body::UrlEncoded by Christian Hansen my $DECODE = qr/%([0-9a-fA-F]{2})/; my %hex_chr; foreach my $num ( 0 .. 255 ) { my $h = sprintf "%02X", $num; $hex_chr{ lc $h } = $hex_chr{ uc $h } = chr $num; } sub _unpack_params { my %unpack; (my $params = $_[0]) =~ s/\+/ /g; my ($name, $value); foreach my $pair (split(/[&;](?:\s+)?/, $params)) { $value = 1 unless (($name, $value) = split(/=/, $pair, 2)) == 2; s/$DECODE/$hex_chr{$1}/gs for ($name, $value); $_ = decode_utf8 $_ for ($name, $value); push(@{$unpack{$name}||=[]}, $value); } \%unpack; } } { # shamelessly stolen from Plack::Request by miyagawa sub _make_http_body { # Can't actually do this yet, since Plack::Request deletes the # header structure out of the uploads in its copy of the body. # I suspect I need to supply miyagawa with a failing test. #if (my $plack_body = $_[0]->{'plack.request.http.body'}) { # # Plack already constructed one; probably wasteful to do it again # return $plack_body; #} require HTTP::Body; my $body = HTTP::Body->new(@{$_[0]}{qw(CONTENT_TYPE CONTENT_LENGTH)}); $body->cleanup(1); _chunk_reader( $_[0], sub { $body->add( $_[0] ) } ); return $body; } sub _chunk_reader { my ( $env, $callback ) = @_; my $spin = 0; my $input = $_[0]->{'psgi.input'}; my $cl = $_[0]->{CONTENT_LENGTH}; if ($cl > $MAX_BODY_SIZE) { Carp::croak("Bad Content-Length: $cl > ${MAX_BODY_SIZE}"); } while ($cl) { $input->read( my $chunk, $cl < 8192 ? $cl : 8192 ); my $read = length $chunk; $cl -= $read; $callback->($chunk); if ( $read == 0 && $spin++ > 2000 ) { require Carp; Carp::croak("Bad Content-Length: maybe client disconnect? ($cl bytes remaining)"); } } } } 1; Web-Simple-0.035/lib/Web/Dispatch/Node.pm000644 000000 000000 00000001200 12500156524 016071 0ustar00000000 000000 package Web::Dispatch::Node; use Moo; with 'Web::Dispatch::ToApp'; for (qw(match run)) { has "_${_}" => (is => 'ro', required => 1, init_arg => $_); } sub call { my ($self, $env) = @_; if (my ($env_delta, @match) = $self->_match->($env)) { ($env_delta, $self->_curry(@match)); } else { () } } sub _curry { my ($self, @args) = @_; my $run = $self->_run; my $code = sub { $run->(@args, $_[0]) }; # if the first argument is a hashref, localize %_ to it to permit # use of $_{name} inside the dispatch sub ref($args[0]) eq 'HASH' ? do { my $v = $args[0]; sub { local *_ = $v; &$code } } : $code } 1; Web-Simple-0.035/lib/Web/Dispatch/Upload.pm000644 000000 000000 00000001537 12500156524 016445 0ustar00000000 000000 use strictures 1; { package Web::Dispatch::Upload; require Plack::Request::Upload; our @ISA = qw(Plack::Request::Upload); use overload '""' => 'tempname', fallback => 1; sub is_upload { 1 } sub reason { '' } } { package Web::Dispatch::NotAnUpload; use overload '""' => '_explode', fallback => 1; sub new { my ($class, %args) = @_; bless { filename => $args{filename}, reason => $args{reason} }, $class; } sub is_upload { 0 } sub reason { $_[0]->{reason} } sub _explode { die "Not actually an upload: ".$_[0]->{reason} } sub filename { $_[0]->_explode } sub headers { $_[0]->_explode } sub size { $_[0]->_explode } sub tempname { $_[0]->_explode } sub path { $_[0]->_explode } sub content_type { $_[0]->_explode } sub type { $_[0]->_explode } sub basename { $_[0]->_explode } } 1; Web-Simple-0.035/examples/golf/000750 000000 000000 00000000000 15266735050 014404 5ustar00000000 000000 Web-Simple-0.035/examples/hello-world/000750 000000 000000 00000000000 15266735050 015705 5ustar00000000 000000 Web-Simple-0.035/examples/bloggery/000750 000000 000000 00000000000 15266735050 015267 5ustar00000000 000000 Web-Simple-0.035/examples/dispatchex/000750 000000 000000 00000000000 15266735050 015611 5ustar00000000 000000 Web-Simple-0.035/examples/dispatchex/dispatchex.cgi000644 000000 000000 00000001133 12500156524 020423 0ustar00000000 000000 use Web::Simple 'DispatchEx'; package DispatchEx; dispatch { response_filter { [ 200, [ 'Content-type' => 'text/plain' ], $_[1] ]; }, subdispatch sub (.html) { [ response_filter { [ @{$_[1]}, '.html' ] }, sub (/foo) { [ '/foo' ] }, ] }, subdispatch sub (/domain/*/...) { return unless (my $domain_id = $_[1]) =~ /^\d+$/; [ sub (/) { [ "Domain ${domain_id}" ] }, sub (/user/*) { return unless (my $user_id = $_[1]) =~ /^\d+$/; [ "Domain ${domain_id} user ${user_id}" ] } ] } }; DispatchEx->run_if_script; Web-Simple-0.035/examples/bloggery/bloggery.cgi000755 000000 000000 00000006022 12500156524 017564 0ustar00000000 000000 #!/usr/bin/perl use FindBin; use lib $FindBin::Bin.'/code'; use Web::Simple 'Bloggery'; package Bloggery::PostList; use File::stat; sub from_dir { my ($class, $dir) = @_; bless ({ dir => $dir }, $class); } sub all { my ($self) = @_; map { Bloggery::Post->from_file($_) } sort { stat($a)->mtime <=> stat($b)->mtime } grep { !/\.summary\.html$/ } glob($self->{dir}.'/*.html'); } sub post { my ($self, $name) = @_; my $file = $self->{dir}."/${name}.html"; return unless $file && -f $file; return Bloggery::Post->from_file($file); } sub map { my ($self, $code) = @_; map $code->($_), $self->all; } package Bloggery::Post; sub from_file { my ($class, $file) = @_; bless({ file => $file }, $class); } sub name { my $name = shift->{file}; $name =~ s/.*\///; $name =~ s/\.html$//; $name; } sub title { my $title = shift->name; $title =~ s/-/ /g; $title; } sub html { \do { local (@ARGV, $/) = shift->{file}; <> }; } sub summary_html { my $file = shift->{file}; $file =~ s/\.html$/.summary.html/; return \'

No summary

' unless -f $file; \do { local (@ARGV, $/) = $file; <> }; } package Bloggery; has post_list => (is => 'lazy'); sub default_config { ( title => 'Bloggery', posts_dir => $FindBin::Bin.'/posts', ); } sub _build_post_list { my ($self) = @_; Bloggery::PostList->from_dir( $self->config->{posts_dir} ); } sub post { my ($self, $post) = @_; $self->post_list->post($post); } sub dispatch_request { my $self = shift; sub (GET + /) { redispatch_to '/index.html' }, sub (.html) { response_filter { $self->render_html(@_) } }, sub (GET + /index) { $self->post_list }, sub (GET + /*) { $self->post($_[1]) }, sub (GET) { [ 404, [ 'Content-type', 'text/plain' ], [ 'Not found' ] ] }, sub { [ 405, [ 'Content-type', 'text/plain' ], [ 'Method not allowed' ] ] }, }; sub render_html { my ($self, $data) = @_; use HTML::Tags; return $data if ref($data) eq 'ARRAY'; return [ 200, [ 'Content-type', 'text/html' ], [ HTML::Tags::to_html_string( , , , $self->title_for($data), , , ,

, $self->title_for($data),

,
, $self->main_html_for($data),
, , ) ] ]; } sub title_for { my ($self, $data) = @_; if ($data->isa('Bloggery::Post')) { return $data->title; } return $self->config->{title}; } sub main_html_for { my ($self, $data) = @_; use HTML::Tags; if ($data->isa('Bloggery::Post')) { $data->html } elsif ($data->isa('Bloggery::PostList')) { ; } else {

, "Don't know how to render $data",

; } } Bloggery->run_if_script; Web-Simple-0.035/examples/bloggery/posts/000750 000000 000000 00000000000 15266735050 016437 5ustar00000000 000000 Web-Simple-0.035/examples/bloggery/posts/One-Post.html000644 000000 000000 00000000027 12500156524 020764 0ustar00000000 000000

This is a post!

Web-Simple-0.035/examples/bloggery/posts/One-Post.summary.html000644 000000 000000 00000000023 12500156524 022454 0ustar00000000 000000

Excitement!

Web-Simple-0.035/examples/bloggery/posts/Another-Post.html000644 000000 000000 00000000034 12500156524 021641 0ustar00000000 000000

This is also a post!

Web-Simple-0.035/examples/hello-world/hello-world.cgi000644 000000 000000 00000000475 12500156524 020623 0ustar00000000 000000 #!/usr/bin/perl use Web::Simple 'HelloWorld'; { package HelloWorld; sub dispatch_request { sub (GET) { [ 200, [ 'Content-type', 'text/plain' ], [ 'Hello world!' ] ] }, sub () { [ 405, [ 'Content-type', 'text/plain' ], [ 'Method not allowed' ] ] } }; } HelloWorld->run_if_script; Web-Simple-0.035/examples/golf/golf.cgi000755 000000 000000 00000000224 12500156524 016014 0ustar00000000 000000 #!/usr/bin/perl use Web::Simple; sub dispatch_request { [ 200, [ 'Content-type', 'text/plain' ], [ 'Hello world!' ] ] } __PACKAGE__->run_if_script; Web-Simple-0.035/t/env.t000644 000000 000000 00000000615 12500156524 013055 0ustar00000000 000000 use strict; use warnings FATAL => 'all'; use Test::More 'no_plan'; use Plack::Test; { use Web::Simple 'EnvTest'; package EnvTest; sub dispatch_request { sub (GET) { my $env = $_[PSGI_ENV]; [ 200, [ "Content-type" => "text/plain" ], [ 'foo' ] ] }, } } my $app = EnvTest->new; ok $app->run_test_request(GET => 'http://localhost/')->is_success; Web-Simple-0.035/t/request_mode_heuristics.t000644 000000 000000 00000003165 12761653350 017236 0ustar00000000 000000 use strictures; use Test::More 0.88; use Web::Simple::Application; use Socket; run(); done_testing; sub run { my $a = Web::Simple::Application->new; my ( $cli, $cgi, $fcgi, $test ) = qw( cli cgi fcgi test ); my $res; no warnings 'redefine'; local *Web::Simple::Application::_run_fcgi = sub { $res = "fcgi" }; local *Web::Simple::Application::_run_cgi = sub { $res = "cgi" }; local *Web::Simple::Application::_run_cli = sub { $res = "cli" }; local *Web::Simple::Application::_run_cli_test_request = sub { $res = "test" }; use strictures; { $a->run; is $res, "cli", "empty invocation goes to CLI mode"; } SKIP: { skip "windows does not support the needed socket manipulation", 2 if $^O eq 'MSWin32' or $^O eq 'cygwin'; { socket my $socket, AF_INET, SOCK_STREAM, 0 or die "socket: $!"; open my $old_in, '<&STDIN' or die "open: $!"; open STDIN, '<&', $socket or die "open: $!"; $a->run; is $res, "fcgi", "STDIN being a socket means FCGI"; open STDIN, '<&', $old_in or die "open: $!"; } { local $ENV{GATEWAY_INTERFACE} = "CGI 1.1"; socket my $socket, AF_INET, SOCK_STREAM, 0 or die "socket: $!"; open my $old_in, '<&STDIN' or die "open: $!"; open STDIN, '<&', $socket or die "open: $!"; $a->run; isnt $res, "fcgi", "STDIN being a socket doesn't mean FCGI if GATEWAY_INTERFACE is set"; open STDIN, '<&', $old_in or die "open: $!"; } } return; } Web-Simple-0.035/t/bloggery.t000644 000000 000000 00000001676 15266213772 014122 0ustar00000000 000000 use strict; use warnings FATAL => 'all'; use Test::More qw(no_plan); require_ok './examples/bloggery/bloggery.cgi'; __END__ #use Test::More ( # eval { require HTTP::Request::AsCGI } # ? 'no_plan' ## : (skip_all => 'No HTTP::Request::AsCGI') #); use HTTP::Request::AsCGI; use HTTP::Request::Common qw(GET POST); require 'examples/bloggery/bloggery.cgi'; my $app = Bloggery->new( { config => { posts_dir => 'examples/bloggery/posts' } } ); sub run_request { my $request = shift; my $c = HTTP::Request::AsCGI->new($request, SCRIPT_NAME=> $0)->setup; $app->run; $c->restore; return $c->response; } my $res; warn run_request(GET 'http://localhost/index.html')->as_string; warn run_request(GET 'http://localhost/')->as_string; warn run_request(GET 'http://localhost/One-Post.html')->as_string; warn run_request(GET 'http://localhost/Not-There.html')->as_string; warn run_request(POST 'http://localhost/One-Post.html')->as_string; Web-Simple-0.035/t/dispatch_parser.t000644 000000 000000 00000033356 12500156524 015450 0ustar00000000 000000 use strict; use warnings FATAL => 'all'; use Test::More qw(no_plan); use Web::Dispatch::Parser; my $dp = Web::Dispatch::Parser->new; { my $all = $dp->parse(''); is_deeply( [ $all->({ REQUEST_METHOD => 'GET' }) ], [ {} ], 'GET matches' ); is_deeply( [ $all->({ REQUEST_METHOD => 'POST' }) ], [ {} ], 'POST matches' ); }; { my $get = $dp->parse('GET'); is_deeply( [ $get->({ REQUEST_METHOD => 'GET' }) ], [ {} ], 'GET matches' ); is_deeply( [ $get->({ REQUEST_METHOD => 'POST' }) ], [], 'POST does not match' ); } { my $html = $dp->parse('.html'); is_deeply( [ $html->({ PATH_INFO => '/foo/bar.html' }) ], [ { } ], '.html matches' ); is_deeply( [ $html->({ PATH_INFO => '/foo/bar.xml' }) ], [], '.xml does not match .html' ); } { my $any_ext = $dp->parse('.*'); is_deeply( [ $any_ext->({ PATH_INFO => '/foo/bar.html' }) ], [ { }, 'html' ], '.html matches .* and extension returned' ); is_deeply( [ $any_ext->({ PATH_INFO => '/foo/bar' }) ], [], 'no extension does not match .*' ); } { my $slash = $dp->parse('/'); is_deeply( [ $slash->({ PATH_INFO => '/' }) ], [ {} ], '/ matches /' ); is_deeply( [ $slash->({ PATH_INFO => '/foo' }) ], [ ], '/foo does not match /' ); } { my $post = $dp->parse('/post/*'); is_deeply( [ $post->({ PATH_INFO => '/post/one' }) ], [ {}, 'one' ], '/post/one parses out one' ); is_deeply( [ $post->({ PATH_INFO => '/post/one/' }) ], [], '/post/one/ does not match' ); is_deeply( [ $post->({ PATH_INFO => '/post/one.html' }) ], [ {}, 'one' ], '/post/one.html still parses out one' ); } { my $post = $dp->parse('/foo-bar/*'); is_deeply( [ $post->({ PATH_INFO => '/foo-bar/one' }) ], [ {}, 'one' ], '/foo-bar/one parses out one' ); is_deeply( [ $post->({ PATH_INFO => '/foo-bar/one/' }) ], [], '/foo-bar/one/ does not match' ); } { my $combi = $dp->parse('GET+/post/*'); is_deeply( [ $combi->({ PATH_INFO => '/post/one', REQUEST_METHOD => 'GET' }) ], [ {}, 'one' ], '/post/one parses out one' ); is_deeply( [ $combi->({ PATH_INFO => '/post/one/', REQUEST_METHOD => 'GET' }) ], [], '/post/one/ does not match' ); is_deeply( [ $combi->({ PATH_INFO => '/post/one', REQUEST_METHOD => 'POST' }) ], [], 'POST /post/one does not match' ); } { my $or = $dp->parse('GET|POST'); foreach my $meth (qw(GET POST)) { is_deeply( [ $or->({ REQUEST_METHOD => $meth }) ], [ {} ], 'GET|POST matches method '.$meth ); } is_deeply( [ $or->({ REQUEST_METHOD => 'PUT' }) ], [], 'GET|POST does not match PUT' ); } { my $or = $dp->parse('GET|POST|DELETE'); foreach my $meth (qw(GET POST DELETE)) { is_deeply( [ $or->({ REQUEST_METHOD => $meth }) ], [ {} ], 'GET|POST|DELETE matches method '.$meth ); } is_deeply( [ $or->({ REQUEST_METHOD => 'PUT' }) ], [], 'GET|POST|DELETE does not match PUT' ); } { my $nest = $dp->parse('(GET+/foo)|POST'); is_deeply( [ $nest->({ PATH_INFO => '/foo', REQUEST_METHOD => 'GET' }) ], [ {} ], '(GET+/foo)|POST matches GET /foo' ); is_deeply( [ $nest->({ PATH_INFO => '/bar', REQUEST_METHOD => 'GET' }) ], [], '(GET+/foo)|POST does not match GET /bar' ); is_deeply( [ $nest->({ PATH_INFO => '/bar', REQUEST_METHOD => 'POST' }) ], [ {} ], '(GET+/foo)|POST matches POST /bar' ); is_deeply( [ $nest->({ PATH_INFO => '/foo', REQUEST_METHOD => 'PUT' }) ], [], '(GET+/foo)|POST does not match PUT /foo' ); } { my $spec = '(GET+/foo)|(POST+/foo)'; my $nest = $dp->parse($spec); for my $method (qw( GET POST )) { is_deeply( [ $nest->({ PATH_INFO => '/foo', REQUEST_METHOD => $method }) ], [ {} ], "$spec matches $method /foo" ); is_deeply( [ $nest->({ PATH_INFO => '/bar', REQUEST_METHOD => $method }) ], [], "$spec does not match $method /bar" ); } is_deeply( [ $nest->({ PATH_INFO => '/foo', REQUEST_METHOD => 'PUT' }) ], [], "$spec does not match PUT /foo" ); } { local $@; ok( !eval { $dp->parse('/foo+(GET'); 1 }, 'Death with missing closing )' ); my $err = q{ /foo+(GET ^ }; (s/^\n//s,s/\n $//s,s/^ //mg) for $err; like( $@, qr{\Q$err\E}, "Error $@ matches\n${err}\n" ); } { my $not = $dp->parse('!.html+.*'); is_deeply( [ $not->({ PATH_INFO => '/foo.xml' }) ], [ {}, 'xml' ], '!.html+.* matches /foo.xml' ); is_deeply( [ $not->({ PATH_INFO => '/foo.html' }) ], [], '!.html+.* does not match /foo.html' ); is_deeply( [ $not->({ PATH_INFO => '/foo' }) ], [], '!.html+.* does not match /foo' ); } { my $ext = $dp->parse('/foo.bar'); is_deeply( [ $ext->({ PATH_INFO => '/foo.bar' }) ], [ {} ], '/foo.bar matches /foo.bar' ); is_deeply( [ $ext->({ PATH_INFO => '/foo.bar.ext' }) ], [ {} ], '/foo.bar matches /foo.bar.ext' ); is_deeply( [ $ext->({ PATH_INFO => '/foo.notbar' }) ], [], '/foo.bar does not match /foo.notbar' ); } { my $sub = $dp->parse('/foo/*/...'); is_deeply( [ $sub->({ PATH_INFO => '/foo/1/bar' }) ], [ { PATH_INFO => '/bar', SCRIPT_NAME => '/foo/1' }, 1 ], '/foo/*/... matches /foo/1/bar and strips to /bar' ); is_deeply( [ $sub->({ PATH_INFO => '/foo/1/' }) ], [ { PATH_INFO => '/', SCRIPT_NAME => '/foo/1' }, 1 ], '/foo/*/... matches /foo/1/bar and strips to /' ); is_deeply( [ $sub->({ PATH_INFO => '/foo/1' }) ], [], '/foo/*/... does not match /foo/1 (no trailing /)' ); } { my $sub = $dp->parse('/foo/**/belief'); my $match = 'barred/beyond'; is_deeply( [ $sub->({ PATH_INFO => "/foo/${match}/belief" }) ], [ {}, $match ], "/foo/**/belief matches /foo/${match}/belief" ); } { my $match = '~'; my $sub = $dp->parse($match); is_deeply( [ $sub->({ PATH_INFO => '/foo' }) ], [], "$match does not match /foo" ); is_deeply( [ $sub->({ PATH_INFO => '' }) ], [ {} ], "$match matches empty path with empty env" ); } { my $match = '/foo...'; my $sub = $dp->parse($match); is_deeply( [ $sub->({ PATH_INFO => '/foobar' }) ], [], "$match does not match /foobar" ); is_deeply( [ $sub->({ PATH_INFO => '/foo/bar' }) ], [ { PATH_INFO => '/bar', SCRIPT_NAME => '/foo' } ], "$match matches /foo/bar and strips to /bar" ); is_deeply( [ $sub->({ PATH_INFO => '/foo/' }) ], [ { PATH_INFO => '/', SCRIPT_NAME => '/foo' } ], "$match matches /foo/ and strips to /" ); is_deeply( [ $sub->({ PATH_INFO => '/foo' }) ], [ { PATH_INFO => '', SCRIPT_NAME => '/foo' } ], "$match matches /foo and strips to empty path" ); } { my @dot_pairs = ( [ '/one/*' => 'two' ], [ '/one/*.*' => 'two.three' ], [ '/**' => 'one/two' ], [ '/**.*' => 'one/two.three' ], ); foreach my $p (@dot_pairs) { is_deeply( [ $dp->parse($p->[0])->({ PATH_INFO => '/one/two.three' }) ], [ {}, $p->[1] ], "${\$p->[0]} matches /one/two.three and returns ${\$p->[1]}" ); } } { my @named = ( [ '/foo/*:foo_id' => '/foo/1' => { foo_id => 1 } ], [ '/foo/:foo_id' => '/foo/1' => { foo_id => 1 } ], [ '/foo/:id/**:rest' => '/foo/id/rest/of/the/path.ext' => { id => 'id', rest => 'rest/of/the/path' } ], [ '/foo/:id/**.*:rest' => '/foo/id/rest/of/the/path.ext' => { id => 'id', rest => 'rest/of/the/path.ext' } ], ); foreach my $n (@named) { is_deeply( [ $dp->parse($n->[0])->({ PATH_INFO => $n->[1] }) ], [ {}, $n->[2] ], "${\$n->[0]} matches ${\$n->[1]} with correct captures" ); } } # # query string # my $q = 'foo=FOO&bar=BAR1&baz=one+two&quux=QUUX1&quux=QUUX2' .'&foo.bar=FOOBAR1&foo.bar=FOOBAR2&foo.baz=FOOBAZ' .'&bar=BAR2&quux=QUUX3&evil=%2F'; my %all_single = ( foo => 'FOO', bar => 'BAR2', baz => 'one two', quux => 'QUUX3', evil => '/', 'foo.baz' => 'FOOBAZ', 'foo.bar' => 'FOOBAR2', ); my %all_multi = ( foo => [ 'FOO' ], bar => [ qw(BAR1 BAR2) ], baz => [ 'one two' ], quux => [ qw(QUUX1 QUUX2 QUUX3) ], evil => [ '/' ], 'foo.baz' => [ 'FOOBAZ' ], 'foo.bar' => [ qw(FOOBAR1 FOOBAR2) ], ); foreach my $lose ('?foo=','?:foo=','?@foo=','?:@foo=') { my $foo = $dp->parse($lose); is_deeply( [ $foo->({ QUERY_STRING => '' }) ], [], "${lose} fails with no query" ); is_deeply( [ $foo->({ QUERY_STRING => 'bar=baz' }) ], [], "${lose} fails with query missing foo key" ); } foreach my $win ( [ '?foo=' => 'FOO' ], [ '?:foo=' => { foo => 'FOO' } ], [ '?spoo~' => undef ], [ '?:spoo~' => {} ], [ '?@spoo~' => [] ], [ '?:@spoo~' => { spoo => [] } ], [ '?bar=' => 'BAR2' ], [ '?:bar=' => { bar => 'BAR2' } ], [ '?@bar=' => [ qw(BAR1 BAR2) ] ], [ '?:@bar=' => { bar => [ qw(BAR1 BAR2) ] } ], [ '?foo=&@bar=' => 'FOO', [ qw(BAR1 BAR2) ] ], [ '?foo=&:@bar=' => 'FOO', { bar => [ qw(BAR1 BAR2) ] } ], [ '?:foo=&:@bar=' => { foo => 'FOO', bar => [ qw(BAR1 BAR2) ] } ], [ '?:baz=&:evil=' => { baz => 'one two', evil => '/' } ], [ '?*' => \%all_single ], [ '?@*' => \%all_multi ], [ '?foo=&@*' => 'FOO', \%all_multi ], [ '?:foo=&@*' => { %all_multi, foo => 'FOO' } ], [ '?:@bar=&*' => { %all_single, bar => [ qw(BAR1 BAR2) ] } ], [ '?foo.baz=' => 'FOOBAZ' ], [ '?:foo.baz=' => { 'foo.baz' => 'FOOBAZ' } ], [ '?foo.bar=' => 'FOOBAR2' ], [ '?:foo.bar=' => { 'foo.bar' => 'FOOBAR2' } ], [ '?@foo.bar=' => [ qw(FOOBAR1 FOOBAR2) ] ], [ '?:@foo.bar=' => { 'foo.bar' => [ qw(FOOBAR1 FOOBAR2) ] } ], ) { my ($spec, @res) = @$win; my $match = $dp->parse($spec); #use Data::Dump::Streamer; warn Dump($match); is_deeply( [ $match->({ QUERY_STRING => $q }) ], [ {}, @res ], "${spec} matches correctly" ); } # # /path/info/ + query string # foreach my $lose2 ('/foo/bar/+?foo=','/foo/bar/+?:foo=','/foo/bar/+?@foo=','/foo/bar/+?:@foo=') { my $foo = $dp->parse($lose2); is_deeply( [ $foo->({ PATH_INFO => '/foo/bar/', QUERY_STRING => '' }) ], [ ], "${lose2} fails with no query" ); is_deeply( [ $foo->({ PATH_INFO => '/foo/bar/', QUERY_STRING => 'bar=baz' }) ], [ ], "${lose2} fails with query missing foo key" ); } foreach my $win2 ( [ '/foo/bar/+?foo=' => 'FOO' ], [ '/foo/bar/+?:foo=' => { foo => 'FOO' } ], [ '/foo/bar/+?spoo~' => undef ], [ '/foo/bar/+?:spoo~' => {} ], [ '/foo/bar/+?@spoo~' => [] ], [ '/foo/bar/+?:@spoo~' => { spoo => [] } ], [ '/foo/bar/+?bar=' => 'BAR2' ], [ '/foo/bar/+?:bar=' => { bar => 'BAR2' } ], [ '/foo/bar/+?@bar=' => [ qw(BAR1 BAR2) ] ], [ '/foo/bar/+?:@bar=' => { bar => [ qw(BAR1 BAR2) ] } ], [ '/foo/bar/+?foo=&@bar=' => 'FOO', [ qw(BAR1 BAR2) ] ], [ '/foo/bar/+?foo=&:@bar=' => 'FOO', { bar => [ qw(BAR1 BAR2) ] } ], [ '/foo/bar/+?:foo=&:@bar=' => { foo => 'FOO', bar => [ qw(BAR1 BAR2) ] } ], [ '/foo/bar/+?:baz=&:evil=' => { baz => 'one two', evil => '/' } ], [ '/foo/bar/+?*' => \%all_single ], [ '/foo/bar/+?@*' => \%all_multi ], [ '/foo/bar/+?foo=&@*' => 'FOO', \%all_multi ], [ '/foo/bar/+?:foo=&@*' => { %all_multi, foo => 'FOO' } ], [ '/foo/bar/+?:@bar=&*' => { %all_single, bar => [ qw(BAR1 BAR2) ] } ], [ '/foo/bar/+?foo.baz=' => 'FOOBAZ' ], [ '/foo/bar/+?:foo.baz=' => { 'foo.baz' => 'FOOBAZ' } ], [ '/foo/bar/+?foo.bar=' => 'FOOBAR2' ], [ '/foo/bar/+?:foo.bar=' => { 'foo.bar' => 'FOOBAR2' } ], [ '/foo/bar/+?@foo.bar=' => [ qw(FOOBAR1 FOOBAR2) ] ], [ '/foo/bar/+?:@foo.bar=' => { 'foo.bar' => [ qw(FOOBAR1 FOOBAR2) ] } ], ) { my ($spec, @res) = @$win2; my $match = $dp->parse($spec); # use Data::Dump::Streamer; warn Dump($match); is_deeply( [ $match->({ PATH_INFO => '/foo/bar/', QUERY_STRING => $q }) ], [ {}, @res ], "${spec} matches correctly" ); } # # /path/info + query string # foreach my $lose3 ('/foo/bar+?foo=','/foo/bar+?:foo=','/foo/bar+?@foo=','/foo/bar+?:@foo=') { my $foo = $dp->parse($lose3); is_deeply( [ $foo->({ PATH_INFO => '/foo/bar', QUERY_STRING => '' }) ], [ ], "${lose3} fails with no query" ); is_deeply( [ $foo->({ PATH_INFO => '/foo/bar', QUERY_STRING => 'bar=baz' }) ], [ ], "${lose3} fails with query missing foo key" ); } foreach my $win3 ( [ '/foo/bar+?foo=' => 'FOO' ], [ '/foo/bar+?:foo=' => { foo => 'FOO' } ], [ '/foo/bar+?spoo~' => undef ], [ '/foo/bar+?:spoo~' => {} ], [ '/foo/bar+?@spoo~' => [] ], [ '/foo/bar+?:@spoo~' => { spoo => [] } ], [ '/foo/bar+?bar=' => 'BAR2' ], [ '/foo/bar+?:bar=' => { bar => 'BAR2' } ], [ '/foo/bar+?@bar=' => [ qw(BAR1 BAR2) ] ], [ '/foo/bar+?:@bar=' => { bar => [ qw(BAR1 BAR2) ] } ], [ '/foo/bar+?foo=&@bar=' => 'FOO', [ qw(BAR1 BAR2) ] ], [ '/foo/bar+?foo=&:@bar=' => 'FOO', { bar => [ qw(BAR1 BAR2) ] } ], [ '/foo/bar+?:foo=&:@bar=' => { foo => 'FOO', bar => [ qw(BAR1 BAR2) ] } ], [ '/foo/bar+?:baz=&:evil=' => { baz => 'one two', evil => '/' } ], [ '/foo/bar+?*' => \%all_single ], [ '/foo/bar+?@*' => \%all_multi ], [ '/foo/bar+?foo=&@*' => 'FOO', \%all_multi ], [ '/foo/bar+?:foo=&@*' => { %all_multi, foo => 'FOO' } ], [ '/foo/bar+?:@bar=&*' => { %all_single, bar => [ qw(BAR1 BAR2) ] } ], [ '/foo/bar+?foo.baz=' => 'FOOBAZ' ], [ '/foo/bar+?:foo.baz=' => { 'foo.baz' => 'FOOBAZ' } ], [ '/foo/bar+?foo.bar=' => 'FOOBAR2' ], [ '/foo/bar+?:foo.bar=' => { 'foo.bar' => 'FOOBAR2' } ], [ '/foo/bar+?@foo.bar=' => [ qw(FOOBAR1 FOOBAR2) ] ], [ '/foo/bar+?:@foo.bar=' => { 'foo.bar' => [ qw(FOOBAR1 FOOBAR2) ] } ], ) { my ($spec, @res) = @$win3; my $match = $dp->parse($spec); # use Data::Dump::Streamer; warn Dump($match); is_deeply( [ $match->({ PATH_INFO => '/foo/bar', QUERY_STRING => $q }) ], [ {}, @res ], "${spec} matches correctly" ); } Web-Simple-0.035/t/post.t000644 000000 000000 00000005537 12500156524 013262 0ustar00000000 000000 use strict; use warnings FATAL => 'all'; use Test::More qw(no_plan); { use Web::Simple 'PostTest'; package PostTest; sub dispatch_request { sub (%:foo=&:bar~) { $_[1]->{bar} ||= 'EMPTY'; [ 200, [ "Content-type" => "text/plain" ], [ join(' ',@{$_[1]}{qw(foo bar)}) ] ] }, sub (*baz=) { [ 200, [ "Content-type" => "text/plain" ], [ $_[1]->reason || $_[1]->filename ], ] }, sub (POST + %* + %biff=) { $_[1]->{bar} ||= 'EMPTY'; [ 200, [ "Content-type" => "text/plain" ], [ join(' ',@{$_[1]}{qw(biff bong)}) ] ] }, } } use HTTP::Request::Common qw(GET POST); my $app = PostTest->new; sub run_request { $app->run_test_request(@_); } my $get = run_request(GET 'http://localhost/'); cmp_ok($get->code, '==', 404, '404 on GET'); my $no_body = run_request(POST 'http://localhost/'); cmp_ok($no_body->code, '==', 404, '404 with empty body'); my $no_foo = run_request(POST 'http://localhost/' => [ bar => 'BAR' ]); cmp_ok($no_foo->code, '==', 404, '404 with no foo param'); my $no_bar = run_request(POST 'http://localhost/' => [ foo => 'FOO' ]); cmp_ok($no_bar->code, '==', 200, '200 with only foo param'); is($no_bar->content, 'FOO EMPTY', 'bar defaulted'); my $both = run_request( POST 'http://localhost/' => [ foo => 'FOO', bar => 'BAR' ] ); cmp_ok($both->code, '==', 200, '200 with both params'); is($both->content, 'FOO BAR', 'both params returned'); my $upload = run_request( POST 'http://localhost' => Content_Type => 'form-data' => Content => [ foo => 'FOO', bar => 'BAR' ] ); cmp_ok($upload->code, '==', 200, '200 with multipart'); is($upload->content, 'FOO BAR', 'both params returned'); my $upload_splat = run_request( POST 'http://localhost' => Content_Type => 'form-data' => Content => [ biff => 'frew', bong => 'fru' ] ); cmp_ok($upload_splat->code, '==', 200, '200 with multipart'); is($upload_splat->content, 'frew fru', 'both params returned'); my $upload_wrongtype = run_request( POST 'http://localhost' => [ baz => 'fleem' ] ); is( $upload_wrongtype->content, 'field baz exists with value fleem but body was not multipart/form-data', 'error points out wrong body type' ); my $upload_notupload = run_request( POST 'http://localhost' => Content_Type => 'form-data' => Content => [ baz => 'fleem' ] ); is( $upload_notupload->content, 'field baz exists with value fleem but was not an upload', 'error points out field was not an upload' ); my $upload_isupload = run_request( POST 'http://localhost' => Content_Type => 'form-data' => Content => [ baz => [ undef, 'TESTFILE', Content => 'test content', 'Content-Type' => 'text/plain' ], ] ); is( $upload_isupload->content, 'TESTFILE', 'Actual upload returns filename ok' ); Web-Simple-0.035/t/underscore.t000644 000000 000000 00000000435 12761653350 014446 0ustar00000000 000000 use Web::Simple 'TestApp'; use Test::More 0.88; sub TestApp::dispatch_request { sub (GET + ?*) { [ 200, [ 'Content-type' => 'text/plain' ], [ $_{foo} ] ] } } my $res = TestApp->new->run_test_request(GET => '/?foo=bar'); is($res->content, 'bar', '%_ set ok'); done_testing; Web-Simple-0.035/t/sub-dispatch-args.t000644 000000 000000 00000006711 12500156524 015610 0ustar00000000 000000 use strict; use warnings FATAL => 'all'; use Data::Dumper::Concise; use Test::More 'no_plan'; use Plack::Test; { use Web::Simple 't::Web::Simple::SubDispatchArgs'; package t::Web::Simple::SubDispatchArgs; has 'attr' => (is=>'ro'); sub dispatch_request { my $self = shift; sub (/) { $self->show_landing(@_); }, sub(/...) { q(GET + /user) => sub { $self->show_users(@_); }, sub (/user/*) { sub (GET) { $self->show_user(@_); }, sub (POST + %:id=&:@roles~) { $self->process_post(@_); } }, } }; sub show_landing { my ($self, @args) = @_; local $self->{_dispatcher}; local $args[-1]->{'Web::Dispatch.original_env'}; return [ 200, ['Content-Type' => 'application/perl' ], [::Dumper \@args], ]; } sub show_users { my ($self, @args) = @_; local $self->{_dispatcher}; local $args[-1]->{'Web::Dispatch.original_env'}; return [ 200, ['Content-Type' => 'application/perl' ], [::Dumper \@args], ]; } sub show_user { my ($self, @args) = @_; local $self->{_dispatcher}; local $args[-1]->{'Web::Dispatch.original_env'}; return [ 200, ['Content-Type' => 'application/perl' ], [::Dumper \@args], ]; } sub process_post { my ($self, @args) = @_; local $self->{_dispatcher}; local $args[-1]->{'Web::Dispatch.original_env'}; return [ 200, ['Content-Type' => 'application/perl' ], [::Dumper \@args], ]; } } ok my $app = t::Web::Simple::SubDispatchArgs->new, 'made app'; sub run_request { $app->run_test_request(@_); } ok my $get_landing = run_request(GET => 'http://localhost/' ), 'got landing'; cmp_ok $get_landing->code, '==', 200, '200 on GET'; no strict 'refs'; { my ($self, $env, @noextra) = @{eval($get_landing->content)||[]}; die $@ if $@; is scalar(@noextra), 0, 'No extra stuff'; is ref($self), 't::Web::Simple::SubDispatchArgs', 'got object'; is ref($env), 'HASH', 'Got hashref'; } ok my $get_users = run_request(GET => 'http://localhost/user'), 'got user'; cmp_ok $get_users->code, '==', 200, '200 on GET'; { my ($self, $env, @noextra) = @{eval $get_users->content}; is scalar(@noextra), 0, 'No extra stuff'; is ref($self), 't::Web::Simple::SubDispatchArgs', 'got object'; is ref($env), 'HASH', 'Got hashref'; } ok my $get_user = run_request(GET => 'http://localhost/user/42'), 'got user'; cmp_ok $get_user->code, '==', 200, '200 on GET'; { my ($self, $env, @noextra) = @{eval $get_user->content}; is scalar(@noextra), 0, 'No extra stuff'; is ref($self), 't::Web::Simple::SubDispatchArgs', 'got object'; is ref($env), 'HASH', 'Got hashref'; } ok my $post_user = run_request(POST => 'http://localhost/user/42', [id => '99'] ), 'post user'; cmp_ok $post_user->code, '==', 200, '200 on POST'; { my ($self, $params, $env, @noextra) = @{eval $post_user->content}; is scalar(@noextra), 0, 'No extra stuff'; is ref($self), 't::Web::Simple::SubDispatchArgs', 'got object'; is ref($params), 'HASH', 'Got POST hashref'; is $params->{id}, 99, 'got expected value for id'; is ref($env), 'HASH', 'Got hashref'; } Web-Simple-0.035/t/globbery/000750 000000 000000 00000000000 15266735050 013707 5ustar00000000 000000 Web-Simple-0.035/t/response-filter.t000644 000000 000000 00000001316 12761653472 015422 0ustar00000000 000000 use strictures 1; use Test::More 0.88; use Plack::Test; use HTTP::Request::Common qw(GET POST); { package t::Web::Simple::ResponseFilter; use Web::Simple; sub dispatch_request { my $self = shift; sub (.html) { response_filter { return [ 200, [ 'Content-Type' => 'text/html' ], [ shift->{name} ], ]; } }, sub (GET + /index) { bless {name=>'john'}, 'CrazyHotWildWet'; }, } } ok my $app = t::Web::Simple::ResponseFilter->new->to_psgi_app, 'Got a plack app'; test_psgi $app, sub { my $cb = shift; my $res = $cb->(GET "/index.html"); like $res->content, qr/john/, 'Got Expected Content'; }; done_testing; Web-Simple-0.035/t/css_declare.t000644 000000 000000 00000000614 12500156524 014533 0ustar00000000 000000 use strict; use warnings FATAL => 'all'; use Test::More qw(no_plan); { package Foo; sub foo { use CSS::Declare; return ( '*' => [ color 'red' ], 'tr, td' => [ margin '1px' ], ); } } is( CSS::Declare::to_css_string(Foo::foo()), '* {color:red} tr, td {margin:1px}', 'Basic CSS::Declare usage' ); ok(!Foo->can('color'), 'Death on use of unimported tag'); Web-Simple-0.035/t/test-request-basic-auth.t000644 000000 000000 00000002352 12761653350 016760 0ustar00000000 000000 use strictures 1; use Test::More 0.88; my $auth_result; my @auth_args; { package TestApp; use Web::Simple; use Plack::Middleware::Auth::Basic; sub dispatch_request { sub () { Plack::Middleware::Auth::Basic->new( authenticator => sub { @auth_args = @_; return $auth_result } ) }, sub () { [ 200, [ 'Content-type' => 'text/plain' ], [ 'Woo' ] ] } } } my $ta = TestApp->new; my $res = $ta->run_test_request(GET => '/'); is($res->code, '401', 'Auth failed with no user/pass'); ok(!@auth_args, 'Auth callback never called with no user/pass'); $res = $ta->run_test_request(GET => 'bob:secret@/'); is($res->code, '401', 'Auth failed with bad user/pass'); is($auth_args[0], 'bob', 'Username passed ok'); is($auth_args[1], 'secret', 'Password passed ok'); $auth_result = 1; @auth_args = (); $res = $ta->run_test_request(GET => '/'); is($res->code, '401', 'Auth failed with no user/pass'); ok(!@auth_args, 'Auth callback never called with no user/pass'); $res = $ta->run_test_request(GET => 'bob:secret@/'); is($res->code, '200', 'Auth succeeded with good user/pass'); is($auth_args[0], 'bob', 'Username passed ok'); is($auth_args[1], 'secret', 'Password passed ok'); done_testing; Web-Simple-0.035/t/sub-dispatch-env.t000644 000000 000000 00000001051 12761653350 015444 0ustar00000000 000000 use strictures 1; use Test::More 0.88; { package TestApp; use Web::Simple; sub dispatch_request { sub (/foo/...) { sub (GET) { [ 200, [], [ $_[PSGI_ENV]->{PATH_INFO} ] ] } }, sub (POST) { [ 200, [], [ $_[PSGI_ENV]->{PATH_INFO} ] ] } } } my $app = TestApp->new->to_psgi_app; my $call = sub { $app->({ SCRIPT_NAME => '/base', PATH_INFO => '/foo/bar', REQUEST_METHOD => shift })->[2]->[0] }; is($call->('GET'), '/bar', 'recursive strip ok'); is($call->('POST'), '/foo/bar', 'later dispatchers unaffected'); done_testing; Web-Simple-0.035/t/leak.t000644 000000 000000 00000000563 15266213772 013216 0ustar00000000 000000 use strictures; use Test::More 0.88; plan skip_all => 'No Devel::Cycle' unless eval { require Devel::Cycle; 1 }; use Web::Simple; my $counter; my $on_cycle = sub { Devel::Cycle::_do_report( ++$counter, shift ) }; { local *STDOUT = *STDERR; Devel::Cycle::find_cycle( main->new->to_psgi_app, $on_cycle ); } ok !$counter, "no leak in to_psgi_app"; done_testing; Web-Simple-0.035/t/param_parser.t000644 000000 000000 00000004712 15266733471 014761 0ustar00000000 000000 use strict; use warnings FATAL => 'all'; use Test::More qw(no_plan); use IO::Scalar; use Web::Dispatch::ParamParser; my $param_sample = 'foo=bar&baz=quux&foo=%2F&xyzzy'; my $unpacked = { baz => [ "quux" ], foo => [ "bar", "/" ], xyzzy => [ 1 ] }; is_deeply( Web::Dispatch::ParamParser::_unpack_params('foo=bar&baz=quux&foo=%2F&xyzzy'), $unpacked, 'Simple unpack ok' ); my $env = { 'QUERY_STRING' => $param_sample }; is_deeply( Web::Dispatch::ParamParser::get_unpacked_query_from($env), $unpacked, 'Dynamic unpack ok' ); is_deeply( $env->{+Web::Dispatch::ParamParser::UNPACKED_QUERY}, $unpacked, 'Unpack cached ok' ); sub FakeBody::param { { baz => "quux", foo => [ "bar", "/" ], xyzzy => [ 1 ] } } my $body_env = { CONTENT_TYPE => "multipart/form-data", CONTENT_LENGTH => 1, +Web::Dispatch::ParamParser::UNPACKED_BODY_OBJECT => [ bless {}, "FakeBody" ] }; is_deeply( Web::Dispatch::ParamParser::get_unpacked_body_from($body_env), $unpacked, 'Body cached multipart ok' ); eval { open( my $in, '<', \ "x=1" ); local $Web::Dispatch::ParamParser::MAX_BODY_SIZE = 2**41; Web::Dispatch::ParamParser::get_unpacked_body_from( { CONTENT_LENGTH => 2**40, CONTENT_TYPE => "application/x-www-form-urlencoded", "psgi.input" => $in, REQUEST_METHOD => "POST", } ); }; like $@, qr/^Bad Content-Length: maybe client disconnect/, "Bad Content-Length (body smaller than Content-Length)"; eval { open( my $in, '<', \ "x=1" ); Web::Dispatch::ParamParser::get_unpacked_body_from( { CONTENT_LENGTH => 2**40, CONTENT_TYPE => "application/x-www-form-urlencoded", "psgi.input" => $in, REQUEST_METHOD => "POST", } ); }; like $@, qr/^Bad Content-Length: [0-9]+ > ${Web::Dispatch::ParamParser::MAX_BODY_SIZE}/, "Bad Content-Length (MAX_BODY_SIZE)"; { local $Web::Dispatch::ParamParser::MAX_BODY_SIZE = 2; eval { open( my $in, '<', \ "x=1" ); Web::Dispatch::ParamParser::get_unpacked_body_from( { CONTENT_LENGTH => 3, CONTENT_TYPE => "application/x-www-form-urlencoded", "psgi.input" => $in, REQUEST_METHOD => "POST", } ); }; like $@, qr/^Bad Content-Length: [0-9]+ > ${Web::Dispatch::ParamParser::MAX_BODY_SIZE}/, "Bad Content-Length (MAX_BODY_SIZE)"; } 1; Web-Simple-0.035/t/role.t000644 000000 000000 00000001643 12761653350 013240 0ustar00000000 000000 use strict; use warnings FATAL => 'all'; use Test::More 0.88; { package BazRole; use Web::Simple::Role; around dispatch_request => sub { my ($orig, $self) = @_; return ( $self->$orig, sub (GET + /baz) { [ 200, [ "Content-type" => "text/plain" ], [ 'baz' ], ] } ); }; } { package FooBar; use Web::Simple; with 'BazRole'; sub dispatch_request { sub (GET + /foo) { [ 200, [ "Content-type" => "text/plain" ], [ 'foo' ], ] }, sub (GET + /bar) { [ 200, [ "Content-type" => "text/plain" ], [ 'bar' ], ] }, } } use HTTP::Request::Common qw(GET POST); my $app = FooBar->new; sub run_request { $app->run_test_request(@_); } for my $word (qw/ foo bar baz /) { my $get = run_request(GET "http://localhost/${word}"); is($get->content, $word, "Dispatch $word"); } done_testing; Web-Simple-0.035/t/stream_test.t000644 000000 000000 00000001637 14401201606 014616 0ustar00000000 000000 use strict; use warnings FATAL => 'all'; use Test::More; use Test::Needs 'HTTP::Request::AsCGI'; use HTTP::Request::Common qw(GET POST); my $app = StreamTest->new; ok run_request( $app, GET 'http://localhost/' )->is_success; is run_request( $app, GET 'http://localhost/' )->content, "foo"; sub run_request { my ( $app, $request ) = @_; my $c = HTTP::Request::AsCGI->new( $request )->setup; $app->run; $c->restore; return $c->response; } { package StreamTest; use Web::Simple; sub dispatch_request { sub (GET) { [ sub { my $respond = shift; my $writer = $respond->( [ 200, [ "Content-type" => "text/plain" ] ] ); $writer->write( 'f' ); $writer->write( 'o' ); $writer->write( 'o' ); } ]; },; } } done_testing; Web-Simple-0.035/t/predicate_objects.t000644 000000 000000 00000010371 12500156524 015736 0ustar00000000 000000 use strict; use warnings FATAL => 'all'; use Data::Dumper::Concise; use Test::More 'no_plan'; use Plack::Test; { use Web::Simple 't::Web::Simple::SubDispatchArgs'; package t::Web::Simple::SubDispatchArgs; use Web::Dispatch::Predicates; has 'attr' => (is=>'ro'); sub dispatch_request { my $self = shift; ## sub(/) { match_path(qr/(?-xism:^(\/)$)/), sub { $self->show_landing(@_); }, ## sub(/...) { match_path_strip(qr/(?-xism:^()(\/.*)$)/) => sub { match_and ( match_method('GET'), match_path(qr/(?-xism:^(\/user(?:\.\w+)?)$)/) ) => sub { $self->show_users(@_); }, match_path(qr/(?-xism:^(\/user\/([^\/]+?)(?:\.\w+)?)$)/), sub { match_method('GET') => sub { $self->show_user(@_); }, match_and ( match_method('POST'), match_body ({ named => [ { multi => "", name => "id" }, { multi => 1, name => "roles" } ], required => ["id"] }) ) => sub { $self->process_post(@_); } }, } }; sub show_landing { my ($self, @args) = @_; local $self->{_dispatcher}; local $args[-1]->{'Web::Dispatch.original_env'}; return [ 200, ['Content-Type' => 'application/perl' ], [::Dumper \@args], ]; } sub show_users { my ($self, @args) = @_; local $self->{_dispatcher}; local $args[-1]->{'Web::Dispatch.original_env'}; return [ 200, ['Content-Type' => 'application/perl' ], [::Dumper \@args], ]; } sub show_user { my ($self, @args) = @_; local $self->{_dispatcher}; local $args[-1]->{'Web::Dispatch.original_env'}; return [ 200, ['Content-Type' => 'application/perl' ], [::Dumper \@args], ]; } sub process_post { my ($self, @args) = @_; local $self->{_dispatcher}; local $args[-1]->{'Web::Dispatch.original_env'}; return [ 200, ['Content-Type' => 'application/perl' ], [::Dumper \@args], ]; } } ok my $app = t::Web::Simple::SubDispatchArgs->new, 'made app'; sub run_request { $app->run_test_request(@_); } ok my $get_landing = run_request(GET => 'http://localhost/' ), 'got landing'; cmp_ok $get_landing->code, '==', 200, '200 on GET'; no strict 'refs'; { my ($self, $env, @noextra) = @{eval($get_landing->content)||[]}; die $@ if $@; is scalar(@noextra), 0, 'No extra stuff'; is ref($self), 't::Web::Simple::SubDispatchArgs', 'got object'; is ref($env), 'HASH', 'Got hashref'; } ok my $get_users = run_request(GET => 'http://localhost/user'), 'got user'; cmp_ok $get_users->code, '==', 200, '200 on GET'; { my ($self, $env, @noextra) = @{eval $get_users->content}; is scalar(@noextra), 0, 'No extra stuff'; is ref($self), 't::Web::Simple::SubDispatchArgs', 'got object'; is ref($env), 'HASH', 'Got hashref'; } ok my $get_user = run_request(GET => 'http://localhost/user/42'), 'got user'; cmp_ok $get_user->code, '==', 200, '200 on GET'; { my ($self, $env, @noextra) = @{eval $get_user->content}; is scalar(@noextra), 0, 'No extra stuff'; is ref($self), 't::Web::Simple::SubDispatchArgs', 'got object'; is ref($env), 'HASH', 'Got hashref'; } ok my $post_user = run_request(POST => 'http://localhost/user/42', id => '99' ), 'post user'; cmp_ok $post_user->code, '==', 200, '200 on POST'; { my ($self, $params, $env, @noextra) = @{eval $post_user->content or die $@}; is scalar(@noextra), 0, 'No extra stuff'; is ref($self), 't::Web::Simple::SubDispatchArgs', 'got object'; is ref($params), 'HASH', 'Got POST hashref'; is $params->{id}, 99, 'got expected value for id'; is ref($env), 'HASH', 'Got hashref'; } Web-Simple-0.035/t/dispatch_misc.t000644 000000 000000 00000013623 12761653350 015112 0ustar00000000 000000 use strict; use warnings FATAL => 'all'; no warnings::illegalproto; use Test::More 0.88; use HTTP::Request::Common qw(GET POST); use Web::Dispatch; use HTTP::Response; use Web::Dispatch::Predicates 'match_true'; my @dispatch; { use Web::Simple 'MiscTest'; package MiscTest; sub dispatch_request { @dispatch } sub string_method { [ 999, [], [""] ]; } sub can { die "Passed undef to can, this blows up on 5.8" unless defined($_[1]); shift->SUPER::can(@_) } } my $app = MiscTest->new; sub run_request { $app->run_test_request( @_ ); } string_method_name(); app_is_non_plack(); app_is_object(); app_is_just_sub(); plack_app_return(); broken_route_def(); invalid_psgi_responses(); middleware_as_only_route(); route_returns_middleware_plus_extra(); route_returns_undef(); matcher_nonsub_pair(); matcher_undef_method(); done_testing(); sub string_method_name { @dispatch = ( '/' => "string_method" ); my $get = run_request( GET => 'http://localhost/' ); cmp_ok $get->code, '==', 999, "a dispatcher that's a string matching a method on the dispatch object gets executed"; } sub app_is_non_plack { my $r = HTTP::Response->new( 999 ); my $d = Web::Dispatch->new( dispatch_app => $r ); eval { $d->call }; like $@, qr/No idea how we got here with HTTP::Response/, "Web::Dispatch dies when run with an app() that is a non-PSGI object"; undef $@; } sub app_is_object { { package ObjectApp; use Moo; sub to_app { [ 999, [], ["ok"] ] } } my $o = ObjectApp->new; my $d = Web::Dispatch->new( dispatch_object => $o ); my $res = $d->call; cmp_ok $res->[0], '==', 999, "Web::Dispatch can dispatch properly, given only an object with to_app method"; } sub app_is_just_sub { my $d = Web::Dispatch->new( dispatch_app => sub () { [ 999, [], ["ok"] ] } ); my $res = $d->call( {} ); cmp_ok $res->[0], '==', 999, "Web::Dispatch can dispatch properly, given only an app that's just a sub, with no object involved"; } sub plack_app_return { { package FauxPlackApp; sub new { bless {}, $_[0] } sub to_app { return sub { [ 999, [], [""] ]; }; } } @dispatch = ( sub (/) { FauxPlackApp->new; } ); my $get = run_request( GET => 'http://localhost/' ); cmp_ok $get->code, '==', 999, "when a route returns a thing that look like a Plack app, the web app redispatches to that thing"; } sub broken_route_def { @dispatch = ( '/' => "" ); my $get = run_request( GET => 'http://localhost/' ); cmp_ok $get->code, '==', 500, "a route definition by hash that doesn't pair a sub with a route dies"; like $get->content, qr[No idea how we got here with /], "the error message points out the broken definition"; } sub invalid_psgi_responses { undef $@; my @responses = ( [ [ sub { } ], "an arrayref with a single sub in it" ], [ ["moo"], "an arrayref with a scalar that is not a sub" ], [ bless( {}, "FauxObject" ), "an object without to_app method" ], ); for my $response ( @responses ) { @dispatch = ( sub (/) { $response->[0] } ); my $message = sprintf( "if a route returns %s, then that is returned as a response by WD, causing HTTP::Message::PSGI to choke", $response->[1] ); # Somewhere between 1.0028 and 1.0031 Plack changed so that the # FauxObject case became a 500 rather than a die; in case it later does # the same thing for other stuff, just accept either sort of error my $res = eval { run_request( GET => 'http://localhost/' ) }; if ($res) { ok $res->is_error, $message; } else { like $@, qr/Can't call method "request" on an undefined value .*MockHTTP/, $message; } undef $@; } } sub middleware_as_only_route { @dispatch = ( bless {}, "Plack::Middleware" ); my $get = run_request( GET => 'http://localhost/' ); cmp_ok $get->code, '==', 500, "a route definition consisting of only a middleware causes a bail"; like $get->content, qr[Multiple results but first one is a middleware \(Plack::Middleware=], "the error message mentions the middleware class"; } sub route_returns_middleware_plus_extra { @dispatch = ( sub (/) { return ( bless( {}, "Plack::Middleware" ), "" ); } ); my $get = run_request( GET => 'http://localhost/' ); cmp_ok $get->code, '==', 500, "a route returning a middleware and at least one other variable causes a bail"; like $get->content, qr[Multiple results but first one is a middleware \(Plack::Middleware=], "the error message mentions the middleware class"; } sub route_returns_undef { @dispatch = ( sub (/) { ( sub(/) { undef; }, sub(/) { [ 900, [], [""] ]; } ); }, sub () { [ 400, [], [""] ]; } ); my $get = run_request( GET => 'http://localhost/' ); cmp_ok $get->code, '==', 900, "a route that returns undef causes WD to ignore it and resume dispatching"; } sub matcher_nonsub_pair { @dispatch = ( match_true() => 5 ); my $get = run_request( GET => 'http://localhost/' ); cmp_ok $get->code, '==', 500, "a route definition that pairs a WD::Matcher a non-sub dies"; like $get->content, qr[No idea how we got here with Web::Dispatch::M], "the error message points out the broken definition"; } sub matcher_undef_method { @dispatch = ( 'GET', undef ); my $get = run_request( GET => 'http://localhost/' ); cmp_ok $get->code, '==', 500, "a route definition that pairs a WD::Matcher a non-sub dies"; like $get->content, qr[No idea how we got here with GET], "the error message points out the broken definition"; } Web-Simple-0.035/t/wd-http-methods.t000644 000000 000000 00000005734 12761653350 015334 0ustar00000000 000000 use strictures 1; use Test::More 0.88; { package t::Web::Simple::HTTPMethods; use Web::Simple; use Web::Dispatch::HTTPMethods; sub as_text { [200, ['Content-Type' => 'text/plain'], [$_[0]->{REQUEST_METHOD}, $_[0]->{REQUEST_URI}] ] } sub dispatch_request { sub (/get) { GET { as_text(pop) } }, sub (/get-head-options) { GET { as_text(pop) } HEAD { [204,[],[]] } OPTIONS { [204,[],[]] }, }, sub (/get-post-put) { GET { as_text(pop) } POST { as_text(pop) } PUT { as_text(pop) } }, } } ok my $app = t::Web::Simple::HTTPMethods->new, 'made app'; for my $uri ('http://localhost/get-post-put') { ## Check allowed methods and responses for(ok my $res = $app->run_test_request(GET => $uri)) { is $res->content, 'GET/get-post-put'; } for(ok my $res = $app->run_test_request(POST => $uri)) { is $res->content, 'POST/get-post-put'; } for(ok my $res = $app->run_test_request(PUT => $uri)) { is $res->content, 'PUT/get-post-put'; } ## Since GET is allowed, check for implict HEAD for(ok my $head = $app->run_test_request(HEAD => $uri)) { is $head->code, 200; is $head->content, ''; } ## Check the implicit support for OPTIONS for(ok my $options = $app->run_test_request(OPTIONS => $uri)) { is $options->code, 200; is $options->content, ''; is $options->header('Allow'), 'GET,HEAD,POST,PUT,OPTIONS'; } ## Check implicitly added not allowed for(ok my $not_allowed = $app->run_test_request(DELETE => $uri)) { is $not_allowed->code, 405; is $not_allowed->content, 'Method Not Allowed'; is $not_allowed->header('Allow'), 'GET,HEAD,POST,PUT,OPTIONS'; } } for my $uri ('http://localhost/get-head-options') { ## Check allowed methods and responses for(ok my $res = $app->run_test_request(GET => $uri)) { is $res->content, 'GET/get-head-options'; } for(ok my $head = $app->run_test_request(HEAD => $uri)) { is $head->code, 204; is $head->content, ''; } for(ok my $options = $app->run_test_request(OPTIONS => $uri)) { is $options->code, 204; is $options->content, ''; } ## Check implicitly added not allowed for(ok my $not_allowed = $app->run_test_request(PUT => $uri)) { is $not_allowed->code, 405; is $not_allowed->content, 'Method Not Allowed'; is $not_allowed->header('Allow'), 'GET,HEAD,OPTIONS'; } } for my $uri ('http://localhost/get') { ## Check allowed methods and responses for(ok my $res = $app->run_test_request(GET => $uri)) { is $res->content, 'GET/get'; } ## Check implicitly added not allowed for(ok my $not_allowed = $app->run_test_request(PUT => $uri)) { is $not_allowed->code, 405; is $not_allowed->content, 'Method Not Allowed'; is $not_allowed->header('Allow'), 'GET,HEAD,OPTIONS'; } ## Since GET is allowed, check for implict HEAD for(ok my $head = $app->run_test_request(HEAD => $uri)) { is $head->code, 200; is $head->content, ''; } } done_testing; Web-Simple-0.035/t/tags.t000644 000000 000000 00000004754 14401201364 013226 0ustar00000000 000000 use strict; use warnings FATAL => 'all'; use Test::More qw(no_plan); my $globbery; BEGIN { $globbery = join(', ', ) } { package Foo; sub foo { use XML::Tags qw(one two three); , , ; } sub bar { no warnings 'once'; # this is supposed to warn, it's broken } sub baz { use XML::Tags qw(bar); ; } sub quux { use HTML::Tags; , , "YAY", , ; } sub xquux { use HTML::Tags; , ,,,,
,'x',,1,,
; } sub fleem { use XML::Tags qw(woo); my $ent = 'one&two"four'; ; } sub flaax { use XML::Tags qw(woo); my $data = "one&twofour"; , $data, , , \$data, ; } sub HTML_comment { use HTML::Tags; ; } sub PI { use XML::Tags; ; } sub DTD { use HTML::Tags; } sub globbery { ; } } is( join(', ', XML::Tags::to_xml_string Foo::foo()), ', , ', 'open tags ok' ); ok(!eval { Foo::bar(); 1 }, 'Death on use of unimported tag'); is( join(', ', XML::Tags::to_xml_string Foo::baz()), '', 'close tag ok' ); is( join('', HTML::Tags::to_html_string Foo::quux), 'YAY', 'HTML tags ok' ); is( join('', HTML::Tags::to_html_string Foo::xquux), '' . '
x1
', 'Conflicting HTML tags ok' ); is( join('', XML::Tags::to_xml_string Foo::HTML_comment), '', 'HTML comment ok' ); is( join('', XML::Tags::to_xml_string Foo::fleem), '', 'Escaping ok' ); is( join('', XML::Tags::to_xml_string Foo::flaax), 'one&two<three>fourone&twofour', 'Escaping user data ok' ); is( join('', XML::Tags::to_xml_string Foo::PI), '', 'XML processing instruction' ); is( join('', HTML::Tags::to_html_string Foo::DTD), '', 'DTD ok' ); is( join(', ', Foo::globbery), $globbery, 'real glob re-installed ok' ); Web-Simple-0.035/t/match-home.t000644 000000 000000 00000003152 12761653350 014316 0ustar00000000 000000 use strictures 1; use Test::More 0.88; { package t::Web::Simple::MatchHome; use Web::Simple; sub as_text { [200, ['Content-Type' => 'text/plain'], [$_[0]->{REQUEST_METHOD}, $_[0]->{REQUEST_URI}] ] } sub dispatch_request { sub (/foo...) { sub (~) { as_text(pop) }, sub (/bar) { as_text(pop) }, sub (/baz) { as_text(pop) }, sub (/*) { as_text(pop) }, sub (/bork...) { sub (~) { as_text(pop) }, sub (/bar) { as_text(pop) }, } }, sub (/...) { sub (/baz) { as_text(pop) }, sub (/fob...) { sub (~) { as_text(pop) }, sub (/bar) { as_text(pop) }, } } } } ok my $app = t::Web::Simple::MatchHome->new, 'made app'; for(ok my $res = $app->run_test_request(GET => '/foo')) { is $res->content, 'GET/foo'; } for(ok my $res = $app->run_test_request(GET => '/foo/bar')) { is $res->content, 'GET/foo/bar'; } for(ok my $res = $app->run_test_request(GET => '/foo/baz')) { is $res->content, 'GET/foo/baz'; } for(ok my $res = $app->run_test_request(GET => '/foo/id')) { is $res->content, 'GET/foo/id'; } for(ok my $res = $app->run_test_request(GET => '/foo/bork')) { is $res->content, 'GET/foo/bork'; } for(ok my $res = $app->run_test_request(GET => '/foo/bork/bar')) { is $res->content, 'GET/foo/bork/bar'; } for(ok my $res = $app->run_test_request(GET => '/fob')) { is $res->content, 'GET/fob'; } for(ok my $res = $app->run_test_request(GET => '/baz')) { is $res->content, 'GET/baz'; } for(ok my $res = $app->run_test_request(GET => '/fob/bar')) { is $res->content, 'GET/fob/bar'; } done_testing; Web-Simple-0.035/t/globbery/three000644 000000 000000 00000000000 14401201364 014716 0ustar00000000 000000 Web-Simple-0.035/t/globbery/one000644 000000 000000 00000000000 12500156524 014375 0ustar00000000 000000 Web-Simple-0.035/t/globbery/two000644 000000 000000 00000000000 12500156524 014425 0ustar00000000 000000