├── .gitignore ├── .travis.yml ├── t ├── 001-load.t ├── 002-base.t ├── 050-routes.t ├── 011-core-list.t ├── 100-blog.t ├── 010-core-add.t ├── 013-core-find-array.t └── 012-core-find-scalar.t ├── bin └── prancer ├── META.info ├── lib └── App │ ├── Prancer │ ├── Sessions.pm6 │ ├── Core.pm6 │ ├── Routes.pm6 │ └── StateMachine.pm6 │ └── Prancer.pm6 ├── README.md └── LICENSE /.gitignore: -------------------------------------------------------------------------------- 1 | *.swp 2 | *.swo 3 | lib/.precomp 4 | static 5 | Makefile 6 | Makefile.old 7 | MANIFEST.bak 8 | META.yml 9 | MYMETA.yml 10 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: perl6 2 | sudo: true 3 | perl6: 4 | - latest 5 | install: 6 | - rakudobrew build-panda 7 | - panda installdeps . 8 | - panda installdeps . 9 | -------------------------------------------------------------------------------- /t/001-load.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use Test; 4 | 5 | plan 3; 6 | 7 | use-ok 'App::Prancer::Core'; 8 | use-ok 'App::Prancer::Routes'; 9 | use-ok 'App::Prancer::StateMachine'; 10 | -------------------------------------------------------------------------------- /bin/prancer: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | 3 | use v6; 4 | use App::Prancer::Handler; 5 | 6 | multi MAIN( 'run-blog', Str:D $app-name, 7 | Str:D $admin-username, 8 | Str:D $admin-password ) 9 | { 10 | say "Building blog..."; 11 | say "Launching blog..."; 12 | prance; 13 | } 14 | 15 | # vim: ft=perl6 16 | -------------------------------------------------------------------------------- /META.info: -------------------------------------------------------------------------------- 1 | { 2 | "name" : "App-prancer", 3 | "tags" : [ 4 | "web", 5 | "framework", 6 | "PSGI", 7 | "P6SGI" 8 | ], 9 | "authors" : [ 10 | "Jeffrey Goff " 11 | ], 12 | "author" : "Jeffrey Goff ", 13 | "auth" : "github:drforr", 14 | "support" : { 15 | "source" : "git://github.com/drforr/perl6-App-prancer.git" 16 | }, 17 | "source-url" : "git://github.com/drforr/perl6-App-prancer.git", 18 | "perl" : "6", 19 | "build-depends" : [ 20 | "panda" 21 | ], 22 | "provides" : { 23 | "App::Prancer::Core" : "lib/App/Prancer/Core.pm6" 24 | "App::Prancer::Routes" : "lib/App/Prancer/Routes.pm6" 25 | "App::Prancer::Sessions" : "lib/App/Prancer/Sessions.pm6" 26 | }, 27 | "depends" : [ 28 | # "Cookie::Baker", 29 | # "Crust", 30 | "Digest::HMAC", 31 | # "Digest::SHA" 32 | ], 33 | "test-depends" : [ 34 | "Test" 35 | ], 36 | "description" : "Minimalist web framework", 37 | 38 | "version" : "0.0.2" 39 | } 40 | -------------------------------------------------------------------------------- /lib/App/Prancer/Sessions.pm6: -------------------------------------------------------------------------------- 1 | =begin pod 2 | 3 | =head1 App::Prancer::Sessions 4 | 5 | Insert, display and search for user sessions. 6 | 7 | =head1 Synopsis 8 | 9 | use App::Prancer::Sessions; 10 | 11 | my $sessions = App::Prancer::Sessions.new; 12 | $id = $sessions.add( $scalar ); 13 | $sessions.set( $id, $scalar ); 14 | $scalar = $sessions.find( $id ); 15 | $list = $sessions.list; 16 | 17 | =head1 Documentation 18 | 19 | Add, find and display Prancer session objects. 20 | 21 | =over 22 | 23 | =item add( $scalar ) 24 | 25 | Add a scalar (serialized Perl 6 object) to a session cache, and return that 26 | newly-created session's ID. 27 | 28 | =item set( $id, $scalar ) 29 | 30 | Set session ID C<$id> to C<$scalar>. The method returns the ID it was passed 31 | as a convenience. 32 | 33 | =item find( $id ) 34 | 35 | Find a session with ID C<$id>, and return its serialized form. 36 | 37 | =item list() 38 | 39 | Return a list of all sessions in the cache. 40 | 41 | =back 42 | 43 | =end pod 44 | 45 | use Digest::HMAC; 46 | use Digest; 47 | use Digest::SHA; 48 | 49 | class App::Prancer::Sessions 50 | { 51 | has $.sessions = { }; 52 | 53 | sub session-ID( ) 54 | { 55 | my $rand = ~1.rand; 56 | return hmac-hex("key", $rand, &md5) 57 | } 58 | 59 | method add( $scalar ) 60 | { 61 | my $id = session-ID; 62 | $.sessions.{$id} = $scalar; 63 | return $id 64 | } 65 | 66 | method set( $id, $scalar ) 67 | { 68 | $.sessions.{$id} = $scalar; 69 | return $id; 70 | } 71 | 72 | method find( $id ) 73 | { 74 | return $.sessions.{$id} 75 | } 76 | 77 | method list( ) 78 | { 79 | return $.sessions.perl 80 | } 81 | } 82 | -------------------------------------------------------------------------------- /lib/App/Prancer.pm6: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | =begin pod 4 | 5 | =begin NAME 6 | 7 | App::Prancer - Minimalist web framework along the lines of Dancer 8 | 9 | =end NAME 10 | 11 | =begin SYNOPSIS 12 | 13 | use App::Prancer; 14 | 15 | multi GET( '/' ) is route 16 | { 'Post' } 17 | 18 | multi GET( '/post', Str:D $username ) is route 19 | { 'Post for $username!' } 20 | 21 | multi POST( '/login', %QUERY ) is route 22 | { 'Login $QUERY' } 23 | 24 | prance; 25 | 26 | =end SYNOPSIS 27 | 28 | =begin DESCRIPTION 29 | 30 | Sitting on top of the L web layer, this provides a minimalist web 31 | framework. In order to use it, you simply use the L route module, 32 | define some subroutines to create your L web application, and call the 33 | C main loop in order to start processing. 34 | 35 | Any function that you add the C trait to automatically becomes a 36 | web route. The C web application calls your route when it finds 37 | a matching route. 38 | 39 | =end DESCRIPTION 40 | 41 | =begin METHODS 42 | 43 | Any of the standard HTTP/1.1 methods may be turned into a route, simply by 44 | putting C after the signature. Likely you will need more than one 45 | route for a given HTTP method, so be sure to declare your functions with 46 | C rather than the more common C or C calls. Don't worry, 47 | Perl will remind you if you forget to do so. 48 | 49 | =item DELETE 50 | 51 | =item GET 52 | 53 | =item HEAD 54 | 55 | =item OPTIONS 56 | 57 | =tem POST 58 | 59 | =item PUT 60 | 61 | =item PATCH 62 | 63 | =end METHODS 64 | 65 | =end pod 66 | 67 | class App::Prancer 68 | { 69 | } 70 | -------------------------------------------------------------------------------- /t/002-base.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use Test; 4 | use Crust::Test; 5 | use App::Prancer::StateMachine; 6 | 7 | my regex Valid-Name { <[ A .. P ]> \d ** 2 }; 8 | my regex Valid-Code { \d ** 3 }; 9 | 10 | my regex Valid-Vertex { ^ [ | ] $ }; 11 | 12 | my $s = App::Prancer::StateMachine.new; 13 | 14 | is $s.graph.keys.elems, 54, 15 | q{Correct number of vertices in the graph}; 16 | 17 | ok so True == ( map { ?/ / }, 18 | $s.graph.keys).all, 19 | q{Vertex labels have the correct name}; 20 | 21 | subtest sub { 22 | plan 4; 23 | 24 | ok so True == ( map { ?$_. }, $s.graph.values).all, 25 | q{Vertices all have 'node' keys}; 26 | ok so True == ( map { ?$_. }, $s.graph.values).all, 27 | q{Vertices all have 'true' keys}; 28 | ok so True == ( map { ?/ / }, 29 | map { $_. }, $s.graph.values).all, 30 | q{'true' values have the correct format}; 31 | ok so True == ( map { ?$s.graph.{$_} }, 32 | grep { ?$_ ~~ / ^ / }, 33 | map { $_. }, $s.graph.values ).all, 34 | q{'true' edges that go to a decision are in the graph}; 35 | }, q{'true' edges}; 36 | 37 | subtest sub { 38 | plan 4; 39 | 40 | ok so True == ( map { ?$_. }, $s.graph.values).all, 41 | q{Vertices all have 'node' keys}; 42 | ok so True == ( map { ?$_. }, $s.graph.values).all, 43 | q{Vertices all have 'false' keys}; 44 | ok so True == ( map { ?/ / }, 45 | map { $_. }, $s.graph.values).all, 46 | q{'false' values have the correct format}; 47 | ok so True == ( map { ?$s.graph.{$_} }, 48 | grep { ?$_ ~~ / ^ / }, 49 | map { $_. }, $s.graph.values ).all, 50 | q{'false' edges that go to a decision are in the graph}; 51 | }, q{'false' edges}; 52 | 53 | done-testing; 54 | -------------------------------------------------------------------------------- /t/050-routes.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use Test; 4 | use Crust::Test; 5 | use App::Prancer::Routes :testing; 6 | 7 | multi GET( '/' ) is route { 'GET / HTTP/1.1 OK' } 8 | 9 | multi GET( '/regression-1', '/', Int $profile-ID ) is route 10 | { 11 | "GET /regression-1/$profile-ID HTTP/1.1 OK" 12 | } 13 | 14 | multi GET( '/regression-1a', Int $profile-ID ) is route 15 | { 16 | "GET /regression-1a/$profile-ID HTTP/1.1 OK" 17 | } 18 | 19 | multi GET( Int $x, '/', Int $y, '/', 'regression-2.html' ) is route 20 | { 21 | sprintf "GET /%04d/%02d/regression-2.html HTTP/1.1 OK", $x, $y 22 | } 23 | 24 | multi GET( '/regression-3', 25 | Str :$updated-min, Str :$updated-max, Int :$max-results ) is route 26 | { 27 | my $rest = "?updated-min=$updated-min" ~ 28 | "\&updated-max=$updated-max" ~ 29 | "\&max-results=$max-results"; 30 | return "GET /regression-3$rest HTTP/1.1 OK"; 31 | } 32 | 33 | $Crust::Test::Impl = "MockHTTP"; 34 | 35 | sub content-from( $cb, $method, $URL ) 36 | { 37 | my $req = HTTP::Request.new( GET => $URL ); 38 | my $res = $cb($req); 39 | return $res.content.decode; 40 | } 41 | 42 | test-psgi 43 | client => -> $cb 44 | { 45 | is content-from( $cb, 'GET', '/' ), 46 | q{GET / HTTP/1.1 OK}, 47 | q{GET /}; 48 | is content-from( $cb, 'GET', 49 | '/regression-1/18252182597447689159' ), 50 | q{GET /regression-1/18252182597447689159 HTTP/1.1 OK}, 51 | q{GET /regression-1/18252182597447689159}; 52 | is content-from( $cb, 'GET', 53 | '/regression-1a/18252182597447689159' ), 54 | q{GET /regression-1a/18252182597447689159 HTTP/1.1 OK}, 55 | q{GET /regression-1a/18252182597447689159}; 56 | is content-from( $cb, 'GET', 57 | '/2016/02/regression-2.html' ), 58 | q{GET /2016/02/regression-2.html HTTP/1.1 OK}, 59 | q{GET /2016/02/regression-2.html}; 60 | is content-from( $cb, 'GET', 61 | '/regression-3?updated-min=2016-01-01T00:00:00%2B02:00&updated-max=2017-01-01T00:00:00%2B02:00&max-results=6' ), 62 | q{GET /regression-3?updated-min=2016-01-01T00:00:00+02:00&updated-max=2017-01-01T00:00:00+02:00&max-results=6 HTTP/1.1 OK}, 63 | q{GET /regression-3?updated-min=2016-01-01T00:00:00+02:00&updated-max=2017-01-01T00:00:00+02:00&max-results=6 HTTP/1.1 OK}; 64 | }, 65 | app => &app; 66 | 67 | done-testing; 68 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Prancer 2 | ======= 3 | 4 | Prancer is a minimalist web framework. 5 | 6 | You have to know how to do 4 things in order to write a Prancer web app: 7 | 8 | * Load a module 9 | * Write a function 10 | * Call a function 11 | * There is no 4th thing. 12 | 13 | ``` 14 | use Prancer::Handler; 15 | 16 | multi GET( '/post' ) is route { 17 | return 'Post content here'; 18 | } 19 | 20 | prance; 21 | ``` 22 | 23 | Static files are served from the static/ directory. Dynamic routes are why 24 | you have a web framework, so read on to learn how to listen for GET, POST 25 | and PUT requests. There will be helpers later on for REST-style URLs, 26 | pagination of data and other common web tasks. I'm trying to write things in 27 | such a way that those can simply be Roles mixed in to the Handler class. 28 | 29 | Declare your routes as Perl 6 functions. The function's name corresponds to 30 | the HTTP method you want to respond to, and the function's parameters are 31 | just the parts of the URL you want to respond to. 32 | 33 | For instance, you could listen for a 'GET /post/2016/02/my-great-post HTTP/1.1' 34 | request by creating a function like this: 35 | 36 | ``` 37 | multi GET( '/post/2016/02/my-great-post' ) is route { } 38 | ``` 39 | 40 | But that only listens for that particular post in that particular year. If you 41 | want to listen for that post during any year, just replace 2016 and 02 with 42 | regular Perl arguments like so: 43 | 44 | ``` 45 | multi GET( '/post', Int:D $year, Int:D $month, '/my-great-post' ) is route { } 46 | ``` 47 | 48 | You can listen for any post name by replacing '/my-great-post' with a string 49 | argument thusly. 50 | 51 | ``` 52 | multi GET( '/post', Int:D $year, Int:D $month, Str:D $name ) { 53 | my $content = 'Static content here, this would be gotten from a DB.'; 54 | return "$year/$month - $name$content"; 55 | } 56 | ``` 57 | 58 | Add %QUERY to find out what arguments got passed along with the URL, or 59 | %BODY if you want to find out what the body of a form had in it, or $ENV if you 60 | just want the original Crust request. 61 | 62 | Installation 63 | ============ 64 | 65 | * Using panda (a module management tool bundled with Rakudo Star): 66 | 67 | ``` 68 | panda update && panda install Prancer 69 | ``` 70 | 71 | * Using ufo (a project Makefile creation script bundled with Rakudo Star) and make: 72 | 73 | ``` 74 | ufo 75 | make 76 | make test 77 | make install 78 | ``` 79 | 80 | ## Testing 81 | 82 | To run tests: 83 | 84 | ``` 85 | prove -e perl6 86 | ``` 87 | 88 | ## Author 89 | 90 | Jeffrey Goff, DrForr on #perl6, https://github.com/drforr/ 91 | 92 | ## License 93 | 94 | Artistic License 2.0 95 | -------------------------------------------------------------------------------- /t/011-core-list.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Test; 3 | use App::Prancer::Core; 4 | 5 | plan 27; 6 | 7 | my $r = App::Prancer::Core.new; 8 | 9 | is-deeply 10 | [ $r.list('GET') ], 11 | [ ], 12 | q{Empty core has no routes}; 13 | 14 | ok $r.add( 'GET', 1, '/' ), q{Add '/'}; 15 | is-deeply 16 | [ $r.list('GET') ], 17 | [ '/' ], 18 | q{Default route is listed}; 19 | 20 | ok $r.add( 'GET', 1, '/', 'a' ), q{Add '/a'}; 21 | is-deeply 22 | [ $r.list('GET') ], 23 | [ '/', '/a' ], 24 | q{'/a' was added}; 25 | 26 | ok $r.add( 'GET', 1, '/', Int ), q{Add '/#(Int)'}; 27 | is-deeply 28 | [ $r.list('GET') ], 29 | [ '/', '/#(Int)', '/a' ], 30 | q{'/#(Int)' was added}; 31 | 32 | ok $r.add( 'GET', 1, '/', Str ), q{Add '/#(Str)'}; 33 | is-deeply 34 | [ $r.list('GET') ], 35 | [ '/', '/#(Int)', '/#(Str)', '/a' ], 36 | q{'/#(Str)' was added}; 37 | 38 | ok $r.add( 'GET', 1, '/', Array ), q{Add '/#(Array)'}; 39 | is-deeply 40 | [ $r.list('GET') ], 41 | [ '/', '/#(Array)', '/#(Int)', '/#(Str)', '/a' ], 42 | q{'/#(Array)' was added}; 43 | 44 | ok $r.add( 'GET', 1, '/', 'a', '/' ), q{Add '/a/'}; 45 | is-deeply 46 | [ $r.list('GET') ], 47 | [ '/', '/#(Array)', '/#(Int)', '/#(Str)', '/a', '/a/' ], 48 | q{'/a/' was added}; 49 | 50 | ok $r.add( 'GET', 1, '/', Int, '/' ), q{Add '/#(Int)/'}; 51 | is-deeply 52 | [ $r.list('GET') ], 53 | [ '/', '/#(Array)', '/#(Int)', '/#(Int)/', '/#(Str)', '/a', '/a/' ], 54 | q{'/#(Int)/' was added}; 55 | 56 | ok $r.add( 'GET', 1, '/', Str, '/' ), q{Add '/#(Str)/'}; 57 | is-deeply 58 | [ $r.list('GET') ], 59 | [ '/', 60 | '/#(Array)', 61 | '/#(Int)', 62 | '/#(Int)/', 63 | '/#(Str)', 64 | '/#(Str)/', 65 | '/a', 66 | '/a/' 67 | ], 68 | q{'/#(Str)/' was added}; 69 | 70 | ok $r.add( 'GET', 1, '/', Array, '/' ), q{Add '/#(Array)/'}; 71 | is-deeply 72 | [ $r.list('GET') ], 73 | [ '/', 74 | '/#(Array)', 75 | '/#(Array)/', 76 | '/#(Int)', 77 | '/#(Int)/', 78 | '/#(Str)', 79 | '/#(Str)/', 80 | '/a', 81 | '/a/' 82 | ], 83 | q{'/#(Array)/' was added}; 84 | 85 | ok $r.add( 'GET', 1, '/', 'a', '/', 'b' ), q{Add '/a/b'}; 86 | is-deeply 87 | [ $r.list('GET') ], 88 | [ '/', 89 | '/#(Array)', 90 | '/#(Array)/', 91 | '/#(Int)', 92 | '/#(Int)/', 93 | '/#(Str)', 94 | '/#(Str)/', 95 | '/a', 96 | '/a/', 97 | '/a/b' 98 | ], 99 | q{'/a/b' was added}; 100 | 101 | ok $r.add( 'GET', 1, '/', 'a', '/', '#(Int)' ), q{Add '/a/#(Int)'}; 102 | is-deeply 103 | [ $r.list('GET') ], 104 | [ '/', 105 | '/#(Array)', 106 | '/#(Array)/', 107 | '/#(Int)', 108 | '/#(Int)/', 109 | '/#(Str)', 110 | '/#(Str)/', 111 | '/a', 112 | '/a/', 113 | '/a/#(Int)', 114 | '/a/b' 115 | ], 116 | q{'/a/#(Int)' was added}; 117 | 118 | ok $r.add( 'GET', 1, '/', 'a', '/', '#(Str)' ), q{Add '/a/#(Str)'}; 119 | is-deeply 120 | [ $r.list('GET') ], 121 | [ '/', 122 | '/#(Array)', 123 | '/#(Array)/', 124 | '/#(Int)', 125 | '/#(Int)/', 126 | '/#(Str)', 127 | '/#(Str)/', 128 | '/a', 129 | '/a/', 130 | '/a/#(Int)', 131 | '/a/#(Str)', 132 | '/a/b' 133 | ], 134 | q{'/a/#(Str)' was added}; 135 | 136 | ok $r.add( 'GET', 1, '/', 'a', '/', '#(Array)' ), q{Add '/a/#(Array)'}; 137 | is-deeply 138 | [ $r.list('GET') ], 139 | [ '/', 140 | '/#(Array)', 141 | '/#(Array)/', 142 | '/#(Int)', 143 | '/#(Int)/', 144 | '/#(Str)', 145 | '/#(Str)/', 146 | '/a', 147 | '/a/', 148 | '/a/#(Array)', 149 | '/a/#(Int)', 150 | '/a/#(Str)', 151 | '/a/b' 152 | ], 153 | q{'/a/#(Str)' was added}; 154 | 155 | done-testing; 156 | -------------------------------------------------------------------------------- /t/100-blog.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use Test; 4 | use Crust::Test; 5 | use App::Prancer::Routes; 6 | #my $p = App::Prancer::Handler.new; 7 | 8 | $Crust::Test::Impl = "MockHTTP"; 9 | 10 | #`( 11 | sub content-from( $cb, $method, $URL ) 12 | { 13 | my $req = HTTP::Request.new( GET => $URL ); 14 | my $res = $cb($req); 15 | return $res.content.decode; 16 | } 17 | 18 | # Root of the site. 19 | # 20 | multi GET( '' ) is route { '/' } 21 | 22 | # Check single-element URL 23 | # 24 | multi GET( '/foo' ) is route { '/foo' } 25 | multi GET( '/post', Str :$format ) is route { "/post?format=%QUERY" } 26 | multi GET( 'bare' ) is route { '/bare' } 27 | multi GET( Int $x ) is route { "/#{$x}" } 28 | multi GET( Str $x ) is route { "/\${$x}" } 29 | 30 | # Check that a single argument can be broken in twain. 31 | # 32 | multi GET( '/join/join' ) is route { "/join/join" } 33 | 34 | # Check the permutations of two arguments 35 | # 36 | multi GET( '/foo', '/foo' ) is route { "/foo/foo" } 37 | multi GET( '/foo', 'bare' ) is route { "/foo/bare" } 38 | multi GET( '/foo', Str $x ) is route { "/foo/{$x}" } 39 | multi GET( 'bare', '/foo' ) is route { "/bare/foo" } 40 | multi GET( 'bare', 'bare' ) is route { "/bare/bare" } 41 | multi GET( 'bare', Str $x ) is route { "/bare/{$x}" } 42 | multi GET( Str $x, '/foo' ) is route { "/{$x}/foo" } 43 | multi GET( Str $x, 'bare' ) is route { "/{$x}/bare" } 44 | multi GET( Str $x, Str $y ) is route { "/{$x}/{$y}" } 45 | 46 | # And permutations of three, but simpler this time, otherwise m**n explosion 47 | # 48 | multi GET( '/foo', '/foo', '/foo' ) is route { "/foo/foo/foo" } 49 | multi GET( '/foo', '/foo', Str $x ) is route { "/foo/foo/{$x}" } 50 | multi GET( '/foo', Str $x, '/foo' ) is route { "/foo/{$x}/foo" } 51 | multi GET( '/foo', Str $x, Str $y ) is route { "/foo/{$x}/{$y}" } 52 | multi GET( Str $x, '/foo', '/foo' ) is route { "/{$x}/foo/foo" } 53 | multi GET( Str $x, '/foo', Str $y ) is route { "/{$x}/foo/{$y}" } 54 | multi GET( Str $x, Str $y, '/foo' ) is route { "/{$x}/{$y}/foo" } 55 | multi GET( Str $x, Str $y, Str $z ) is route { "/{$x}/{$y}/{$z}" } 56 | 57 | test-psgi 58 | client => -> $cb 59 | { 60 | is content-from( $cb, 'GET', '/' ), '/'; 61 | 62 | subtest sub 63 | { 64 | plan 7; 65 | 66 | is content-from( $cb, 'GET', '/foo' ), 67 | '/foo'; 68 | is content-from( $cb, 'GET', '/post?format=JSON' ), 69 | '/post?format=JSON'; 70 | is content-from( $cb, 'GET', '/user?format=JSON' ), 71 | '/user?format=JSON'; 72 | is content-from( $cb, 'GET', '/bare' ), 73 | '/bare'; 74 | is content-from( $cb, 'GET', '/2016' ), 75 | '/#2016'; 76 | is content-from( $cb, 'GET', '/bar' ), 77 | '/$bar'; 78 | 79 | is content-from( $cb, 'GET', '/join/join' ), 80 | '/join/join'; 81 | }, q{Single-element route}; 82 | 83 | subtest sub 84 | { 85 | plan 9; 86 | 87 | is content-from( $cb, 'GET', '/foo/foo' ), 88 | '/foo/foo'; 89 | is content-from( $cb, 'GET', '/foo/bare' ), 90 | '/foo/bare'; 91 | is content-from( $cb, 'GET', '/foo/bar' ), 92 | '/foo/bar'; 93 | is content-from( $cb, 'GET', '/bare/foo' ), 94 | '/bare/foo'; 95 | is content-from( $cb, 'GET', '/bare/bare' ), 96 | '/bare/bare'; 97 | is content-from( $cb, 'GET', '/bare/bar' ), 98 | '/bare/bar'; 99 | is content-from( $cb, 'GET', '/bar/foo' ), 100 | '/bar/foo'; 101 | is content-from( $cb, 'GET', '/bar/bare' ), 102 | '/bar/bare'; 103 | is content-from( $cb, 'GET', '/bar/bar' ), 104 | '/bar/bar'; 105 | }, q{Two-element route}; 106 | 107 | subtest sub 108 | { 109 | plan 8; 110 | 111 | is content-from( $cb, 'GET', '/foo/foo/foo' ), 112 | '/foo/foo/foo'; 113 | is content-from( $cb, 'GET', '/foo/foo/bar' ), 114 | '/foo/foo/bar'; 115 | is content-from( $cb, 'GET', '/foo/bar/foo' ), 116 | '/foo/bar/foo'; 117 | is content-from( $cb, 'GET', '/foo/bar/bar' ), 118 | '/foo/bar/bar'; 119 | is content-from( $cb, 'GET', '/bar/foo/foo' ), 120 | '/bar/foo/foo'; 121 | is content-from( $cb, 'GET', '/bar/foo/bar' ), 122 | '/bar/foo/bar'; 123 | is content-from( $cb, 'GET', '/bar/bar/foo' ), 124 | '/bar/bar/foo'; 125 | is content-from( $cb, 'GET', '/bar/bar/bar' ), 126 | '/bar/bar/bar'; 127 | }, q{Three-element route}; 128 | }, 129 | app => $p.make-app; 130 | ) 131 | 132 | done-testing; 133 | -------------------------------------------------------------------------------- /lib/App/Prancer/Core.pm6: -------------------------------------------------------------------------------- 1 | =begin pod 2 | 3 | =head1 App::Prancer::Core 4 | 5 | Insert, display and search for application routes. 6 | 7 | =head1 Synopsis 8 | 9 | use App::Prancer::Core; 10 | 11 | my $routes = App::Prancer::Core.new; 12 | $routes.add( 'GET', 1, '/', 'a' ); 13 | $routes.add( 'GET', 2, '/', Str ); 14 | say $routes.find( 'GET', '/a' ); # 1 15 | say $routes.available; # GET 16 | say $routes.list( 'GET' ); 17 | 18 | =head1 Documentation 19 | 20 | Add, find and display Prancer routes. 21 | 22 | =over 23 | 24 | =item add( $info, '/', 'a' ) 25 | 26 | Add a route '/a' to the internal trie. C<$info> can be anything you like, and 27 | is untyped. In real-world usage this would contain a Routine object and likely 28 | more information about calling semantics and whatnot. It's untyped for testing 29 | so that we can pass simple integers in to prove that the object going in is 30 | what comes out. 31 | 32 | =item find( '/a' ) 33 | 34 | Find a route '/a' in the internal trie, and return its associated info. 35 | 36 | =item list() 37 | 38 | Return a list of all routes in the trie, compressed from the internal structure 39 | into a list of strings. 40 | 41 | =back 42 | 43 | =end pod 44 | 45 | class App::Prancer::Core 46 | { 47 | my class Route-Info { }; 48 | has $.routes = 49 | { 50 | DELETE => { }, 51 | GET => { }, 52 | HEAD => { }, 53 | OPTIONS => { }, 54 | PATCH => { }, 55 | POST => { }, 56 | PUT => { }, 57 | }; 58 | 59 | sub add-route( $routes, $node, *@terms ) 60 | { 61 | my ( $head, @tail ) = @terms; 62 | 63 | # Perl 6 allows objects as keys, and by all rights $head here 64 | # should be allowed to remain unmodified. 65 | # 66 | # This causes problems downstream, specifically when trying to 67 | # debug the internals because I'm always forgetting to add 68 | # .perl or .gist to my debug commands. And I think that it's 69 | # important that this core data structure should be able to 70 | # be printed out without modifications. 71 | # 72 | # So I'm going to transform bare 'Str' and 'Int' and whatever 73 | # values into '#(Str)', '#(Int)' and '#(whatever)' values 74 | # for ease of reading. Besides, AFAIK '#' is illegal inside 75 | # the path portion of URLs because it's an URL anchor. 76 | # 77 | if @tail 78 | { 79 | if $routes.{$head} 80 | { 81 | if $routes.{$head} ~~ Int:D or 82 | $routes.{$head} ~~ Route-Info 83 | { 84 | $routes.{$head} = 85 | { '' => $routes.{$head} }; 86 | } 87 | } 88 | else 89 | { 90 | $routes.{$head} = { }; 91 | } 92 | return add-route( $routes.{$head}, $node, @tail ); 93 | } 94 | elsif $routes.{$head} 95 | { 96 | if $routes.{$head} ~~ Int:D or 97 | $routes.{$head} ~~ Route-Info 98 | { 99 | $routes.{$head} = { '' => $routes.{$head} }; 100 | } 101 | else 102 | { 103 | return False if $routes.{$head}{''}; 104 | $routes.{$head}{''} = $node 105 | } 106 | } 107 | else 108 | { 109 | $routes.{$head} = { '' => $node } 110 | } 111 | return True; 112 | } 113 | 114 | method add( Str $method, $node, *@terms ) 115 | { 116 | fail "Cannot add empty route!" unless @terms; 117 | fail "Cannot add route with two Arrays!" 118 | if (grep { $_ ~~ Array }, @terms ).elems > 1; 119 | 120 | my @x; 121 | for @terms -> $x 122 | { 123 | my $v; 124 | if $x ~~ Str:D { $v = $x } 125 | elsif $x ~~ Int { $v = '#(Int)' } 126 | elsif $x ~~ Str { $v = '#(Str)' } 127 | elsif $x ~~ Array { $v = '#(Array)' } 128 | @x.append( $v ) 129 | } 130 | 131 | my @final-terms; 132 | for @x -> $term 133 | { 134 | my @terms = 135 | grep { $_ ne '' }, 136 | map { ~$_ }, 137 | $term.split( /\/+/, :v ); 138 | @final-terms.push( '/' ) if 139 | @final-terms and 140 | @final-terms[*-1] ne '/' and 141 | @terms[0] ne '/'; 142 | @final-terms.append( @terms ); 143 | } 144 | @final-terms.unshift( '/' ) if @final-terms[0] ne '/'; 145 | 146 | add-route( $.routes.{$method}, $node, @final-terms ) or 147 | fail "Path " ~ join( '', 148 | grep { $_ ne '' }, 149 | map { $_.perl }, 150 | @final-terms 151 | ) ~ " already exists!"; 152 | } 153 | 154 | # Int is a subset of Str, so match on that type first. 155 | # 156 | sub find-element( $trie, $element ) 157 | { 158 | return $trie.{$element} if $trie.{$element}; 159 | return $trie.{'#(Int)'} if $trie.{'#(Int)'} and +$element; 160 | return $trie.{'#(Str)'} if $trie.{'#(Str)'}; 161 | 162 | return False; 163 | } 164 | 165 | sub find-exact( $trie, Str:D $URL ) 166 | { 167 | my @path = grep { $_ ne '' }, $URL.split( /\// ); 168 | my $rv = $trie; 169 | 170 | for @path -> $element 171 | { 172 | $rv = find-element( $rv.{'/'}, $element ); 173 | last unless $rv; 174 | } 175 | 176 | if $URL ~~ m{\/$} 177 | { 178 | return $rv.{'/'}.{''} if $rv.{'/'}.{''} 179 | } 180 | else 181 | { 182 | return $rv.{''} if $rv.{''} 183 | } 184 | } 185 | 186 | method find( Str $method, Str:D $URL ) 187 | { 188 | my $trie = $.routes.{$method}; 189 | return False unless $trie and $URL and $URL ~~ /^\//; 190 | 191 | my $exact = find-exact( $trie, $URL ); 192 | return $exact if $exact; 193 | } 194 | 195 | sub list-routes( $trie ) 196 | { 197 | my @routes; 198 | @routes.append( '/' ) 199 | if $trie.{'/'}.{''}; 200 | 201 | for $trie.{'/'}.keys.sort -> $e 202 | { 203 | my $temp = $trie.{'/'}{$e}; 204 | @routes.append( "/$e" ) 205 | if $temp.{''}; 206 | @routes.append( 207 | map { "/$e$_" }, list-routes( $temp ) ) 208 | if $temp.{'/'}; 209 | } 210 | return @routes; 211 | } 212 | 213 | method list( Str $method ) 214 | { 215 | return list-routes( $.routes.{$method} ); 216 | } 217 | 218 | method available( ) 219 | { 220 | return $.routes.keys.sort; 221 | } 222 | } 223 | -------------------------------------------------------------------------------- /t/010-core-add.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Test; 3 | use App::Prancer::Core; 4 | 5 | plan 35; 6 | 7 | my $r = App::Prancer::Core.new; 8 | 9 | # 10 | # Start with 1 argument, go up to 4. 11 | # 12 | ok $r.add( 'GET', 1, '/' ), q{Add '/'}; 13 | throws-like { $r.add( 'GET', 1, '/' ) }, 14 | Exception, 15 | message => /exists/, 16 | q{Adding '/' a second time throws an Exception}; 17 | 18 | ok $r.add( 'GET', 10, '/', 'a' ), q{Add '/a'}; 19 | ok $r.add( 'GET', 11, '/', Int ), q{Add '/#(Int)'}; 20 | ok $r.add( 'GET', 12, '/', Str ), q{Add '/#(Str)'}; 21 | ok $r.add( 'GET', 13, '/', Array ), q{Add '/#(Array)'}; 22 | 23 | subtest sub 24 | { 25 | plan 4; 26 | 27 | throws-like { $r.add( 'GET', 1, '/', 'a' ) }, 28 | Exception, 29 | message => /exists/, 30 | q{Adding '/a' a second time throws an Exception}; 31 | throws-like { $r.add( 'GET', 1, '/', Int ) }, 32 | Exception, 33 | message => /exists/, 34 | q{Adding '/#(Int)' a second time throws an Exception}; 35 | throws-like { $r.add( 'GET', 1, '/', Str ) }, 36 | Exception, 37 | message => /exists/, 38 | q{Adding '/#(Str)' a second time throws an Exception}; 39 | throws-like { $r.add( 'GET', 1, '/', Array ) }, 40 | Exception, 41 | message => /exists/, 42 | q{Adding '/#(Array)' a second time throws an Exception}; 43 | }, 44 | q{Throw exceptions for 2 terms}; 45 | 46 | ok $r.add( 'GET', 100, '/', 'a', '/' ), q{Add '/a/'}; 47 | ok $r.add( 'GET', 101, '/', Int, '/' ), q{Add '/#(Int)/'}; 48 | ok $r.add( 'GET', 102, '/', Str, '/' ), q{Add '/#(Str)/'}; 49 | ok $r.add( 'GET', 103, '/', Array, '/' ), q{Add '/#(Array)'}; 50 | 51 | subtest sub 52 | { 53 | plan 4; 54 | 55 | throws-like { $r.add( 'GET', 1, '/', 'a', '/' ) }, 56 | Exception, 57 | message => /exists/, 58 | q{Adding '/a/' a second time throws an Exception}; 59 | throws-like { $r.add( 'GET', 1, '/', Int, '/' ) }, 60 | Exception, 61 | message => /exists/, 62 | q{Adding '/#(Int)/' a second time throws an Exception}; 63 | throws-like { $r.add( 'GET', 1, '/', Str, '/' ) }, 64 | Exception, 65 | message => /exists/, 66 | q{Adding '/#(Str)/' a second time throws an Exception}; 67 | throws-like { $r.add( 'GET', 1, '/', Array, '/' ) }, 68 | Exception, 69 | message => /exists/, 70 | q{Adding '/#(Array)/' a second time throws an Exception}; 71 | }, 72 | q{Throw exceptions for 3 terms}; 73 | 74 | # Only one level of combinatorics, though. 75 | # 76 | ok $r.add( 'GET', 1000, '/', 'a', '/', 'b' ), q{Add '/a/b'}; 77 | ok $r.add( 'GET', 1001, '/', 'a', '/', Int ), q{Add '/a/#(Int)'}; 78 | ok $r.add( 'GET', 1002, '/', 'a', '/', Str ), q{Add '/a/#(Str)'}; 79 | ok $r.add( 'GET', 1003, '/', 'a', '/', Array ), q{Add '/a/#(Array)'}; 80 | 81 | subtest sub 82 | { 83 | plan 4; 84 | 85 | throws-like { $r.add( 'GET', 1, '/', 'a', '/', 'b' ) }, 86 | Exception, 87 | message => /exists/, 88 | q{Adding '/a/b' a second time throws an Exception}; 89 | throws-like { $r.add( 'GET', 1, '/', 'a', '/', Int ) }, 90 | Exception, 91 | message => /exists/, 92 | q{Adding '/a/#(Int)' a second time throws an Exception}; 93 | throws-like { $r.add( 'GET', 1, '/', 'a', '/', Str ) }, 94 | Exception, 95 | message => /exists/, 96 | q{Adding '/a/#(Str)' a second time throws an Exception}; 97 | throws-like { $r.add( 'GET', 1, '/', 'a', '/', Array ) }, 98 | Exception, 99 | message => /exists/, 100 | q{Adding '/a/#(Array)' a second time throws an Exception}; 101 | }, 102 | q{Throw exceptions for 4 terms starting with '/a'}; 103 | 104 | ok $r.add( 'GET', 1010, '/', Int, '/', 'b' ), q{Add '/#(Int)/b'}; 105 | ok $r.add( 'GET', 1011, '/', Int, '/', Int ), q{Add '/#(Int)/#(Int)'}; 106 | ok $r.add( 'GET', 1012, '/', Int, '/', Str ), q{Add '/#(Int)/#(Str)'}; 107 | ok $r.add( 'GET', 1013, '/', Int, '/', Array ), q{Add '/#(Int)/#(Array)'}; 108 | 109 | subtest sub 110 | { 111 | plan 4; 112 | 113 | throws-like { $r.add( 'GET', 1, '/', Int, '/', 'b' ) }, 114 | Exception, 115 | message => /exists/, 116 | q{Adding '/#(Int)/b' a second time}; 117 | throws-like { $r.add( 'GET', 1, '/', Int, '/', Int ) }, 118 | Exception, 119 | message => /exists/, 120 | q{Adding '/#(Int)/#(Int)' a second time}; 121 | throws-like { $r.add( 'GET', 1, '/', Int, '/', Str ) }, 122 | Exception, 123 | message => /exists/, 124 | q{Adding '/#(Int)/#(Str)' a second time}; 125 | throws-like { $r.add( 'GET', 1, '/', Int, '/', Array ) }, 126 | Exception, 127 | message => /exists/, 128 | q{Adding '/#(Int)/#(Array)' a second time}; 129 | }, 130 | q{Throw exceptions for 4 terms starting with '/#(Int)'}; 131 | 132 | ok $r.add( 'GET', 1020, '/', Str, '/', 'b' ), q{Add '/#(Str)/b'}; 133 | ok $r.add( 'GET', 1021, '/', Str, '/', Int ), q{Add '/#(Str)/#(Int)'}; 134 | ok $r.add( 'GET', 1022, '/', Str, '/', Str ), q{Add '/#(Str)/#(Str)'}; 135 | ok $r.add( 'GET', 1023, '/', Str, '/', Array ), q{Add '/#(Str)/#(Array)'}; 136 | 137 | subtest sub 138 | { 139 | plan 4; 140 | 141 | throws-like { $r.add( 'GET', 1, '/', Str, '/', 'b' ) }, 142 | Exception, 143 | message => /exists/, 144 | q{Adding '/#(Str)/b' a second time}; 145 | throws-like { $r.add( 'GET', 1, '/', Str, '/', Int ) }, 146 | Exception, 147 | message => /exists/, 148 | q{Adding '/#(Str)/#(Int)' a second time}; 149 | throws-like { $r.add( 'GET', 1, '/', Str, '/', Str ) }, 150 | Exception, 151 | message => /exists/, 152 | q{Adding '/#(Str)/#(Str)' a second time}; 153 | throws-like { $r.add( 'GET', 1, '/', Str, '/', Array ) }, 154 | Exception, 155 | message => /exists/, 156 | q{Adding '/#(Str)/#(Array)' a second time}; 157 | }, 158 | q{Throw exceptions for 4 terms starting with '/#(Str)'}; 159 | 160 | ok $r.add( 'GET', 1030, '/', Array, '/', 'b' ), q{Add '/#(Array)/b'}; 161 | ok $r.add( 'GET', 1031, '/', Array, '/', Int ), q{Add '/#(Array)/#(Int)'}; 162 | ok $r.add( 'GET', 1032, '/', Array, '/', Str ), q{Add '/#(Array)/#(Str)'}; 163 | throws-like { $r.add( 'GET', 1, '/', Array, '/', Array ) }, 164 | Exception, 165 | message => /two/, 166 | q{Can't add a route with two Arrays}; 167 | 168 | subtest sub 169 | { 170 | plan 4; 171 | 172 | throws-like { $r.add( 'GET', 1, '/', Array, '/', 'b' ) }, 173 | Exception, 174 | message => /exists/, 175 | q{Adding '/#(Array)/b' a second time}; 176 | throws-like { $r.add( 'GET', 1, '/', Array, '/', Int ) }, 177 | Exception, 178 | message => /exists/, 179 | q{Adding '/#(Array)/#(Int)' a second time}; 180 | throws-like { $r.add( 'GET', 1, '/', Array, '/', Str ) }, 181 | Exception, 182 | message => /exists/, 183 | q{Adding '/#(Array)/#(Str)' a second time}; 184 | throws-like { $r.add( 'GET', 1, '/', Array, '/', Array ) }, 185 | Exception, 186 | message => /two/, 187 | q{Still can't add a route with two Arrays}; 188 | }, 189 | q{Throw exceptions for 4 terms starting with '/#(Array)'}; 190 | 191 | subtest sub 192 | { 193 | plan 4; 194 | 195 | my $r = App::Prancer::Core.new; 196 | 197 | ok $r.add( 'GET', 1, '/a' ), 198 | q{Add '/a'}; 199 | ok $r.add( 'GET', 1, '/a/' ), 200 | q{Add '/a/'}; 201 | ok $r.add( 'GET', 1, '/', 'b/' ), 202 | q{Add '/b/'}; 203 | ok $r.add( 'GET', 1, '/a', '/b' ), 204 | q{Add '/a/b'}; 205 | }, 206 | q{Slashes allowed as part of literals}; 207 | 208 | subtest sub 209 | { 210 | plan 4; 211 | 212 | my $r = App::Prancer::Core.new; 213 | 214 | ok $r.add( 'GET', 1, 'a' ), 215 | q{Add '/a'}; 216 | ok $r.add( 'GET', 1, Int ), 217 | q{Add '/#(Int)'}; 218 | ok $r.add( 'GET', 1, Str ), 219 | q{Add '/#(Str)'}; 220 | ok $r.add( 'GET', 1, Array ), 221 | q{Add '/#(Array)'}; 222 | }, 223 | q{Can add single-element routes without slashes}; 224 | 225 | subtest sub 226 | { 227 | plan 16; 228 | 229 | my $r = App::Prancer::Core.new; 230 | 231 | ok $r.add( 'GET', 1, 'a', 'a' ), 232 | q{Add '/a/a'}; 233 | ok $r.add( 'GET', 1, 'a', Int ), 234 | q{Add '/a/#(Int)'}; 235 | ok $r.add( 'GET', 1, 'a', Str ), 236 | q{Add '/a/#(Str)'}; 237 | ok $r.add( 'GET', 1, 'a', Array ), 238 | q{Add '/a/#(Array)'}; 239 | 240 | ok $r.add( 'GET', 1, Int, 'a' ), 241 | q{Add '/#(Int)/a'}; 242 | ok $r.add( 'GET', 1, Int, Int ), 243 | q{Add '/#(Int)/#(Int)'}; 244 | ok $r.add( 'GET', 1, Int, Str ), 245 | q{Add '/#(Int)/#(Str)'}; 246 | ok $r.add( 'GET', 1, Int, Array ), 247 | q{Add '/#(Int)/#(Array)'}; 248 | 249 | ok $r.add( 'GET', 1, Str, 'a' ), 250 | q{Add '/#(Str)/a'}; 251 | ok $r.add( 'GET', 1, Str, Int ), 252 | q{Add '/#(Str)/#(Int)'}; 253 | ok $r.add( 'GET', 1, Str, Str ), 254 | q{Add '/#(Str)/#(Str)'}; 255 | ok $r.add( 'GET', 1, Str, Array ), 256 | q{Add '/#(Str)/#(Array)'}; 257 | 258 | ok $r.add( 'GET', 1, Array, 'a' ), 259 | q{Add '/#(Array)/a'}; 260 | ok $r.add( 'GET', 1, Array, Int ), 261 | q{Add '/#(Array)/#(Int)'}; 262 | ok $r.add( 'GET', 1, Array, Str ), 263 | q{Add '/#(Array)/#(Str)'}; 264 | throws-like { $r.add( 'GET', 1, Array, Array ) }, 265 | Exception, 266 | message => /two/, 267 | q{Still can't add a route with two Arrays}; 268 | }, 269 | q{Can add two-element routes without slashes}; 270 | 271 | done-testing; 272 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The Artistic License 2.0 2 | 3 | Copyright (c) 2000-2006, The Perl Foundation. 4 | 5 | Everyone is permitted to copy and distribute verbatim copies 6 | of this license document, but changing it is not allowed. 7 | 8 | Preamble 9 | 10 | This license establishes the terms under which a given free software 11 | Package may be copied, modified, distributed, and/or redistributed. 12 | The intent is that the Copyright Holder maintains some artistic 13 | control over the development of that Package while still keeping the 14 | Package available as open source and free software. 15 | 16 | You are always permitted to make arrangements wholly outside of this 17 | license directly with the Copyright Holder of a given Package. If the 18 | terms of this license do not permit the full use that you propose to 19 | make of the Package, you should contact the Copyright Holder and seek 20 | a different licensing arrangement. 21 | 22 | Definitions 23 | 24 | "Copyright Holder" means the individual(s) or organization(s) 25 | named in the copyright notice for the entire Package. 26 | 27 | "Contributor" means any party that has contributed code or other 28 | material to the Package, in accordance with the Copyright Holder's 29 | procedures. 30 | 31 | "You" and "your" means any person who would like to copy, 32 | distribute, or modify the Package. 33 | 34 | "Package" means the collection of files distributed by the 35 | Copyright Holder, and derivatives of that collection and/or of 36 | those files. A given Package may consist of either the Standard 37 | Version, or a Modified Version. 38 | 39 | "Distribute" means providing a copy of the Package or making it 40 | accessible to anyone else, or in the case of a company or 41 | organization, to others outside of your company or organization. 42 | 43 | "Distributor Fee" means any fee that you charge for Distributing 44 | this Package or providing support for this Package to another 45 | party. It does not mean licensing fees. 46 | 47 | "Standard Version" refers to the Package if it has not been 48 | modified, or has been modified only in ways explicitly requested 49 | by the Copyright Holder. 50 | 51 | "Modified Version" means the Package, if it has been changed, and 52 | such changes were not explicitly requested by the Copyright 53 | Holder. 54 | 55 | "Original License" means this Artistic License as Distributed with 56 | the Standard Version of the Package, in its current version or as 57 | it may be modified by The Perl Foundation in the future. 58 | 59 | "Source" form means the source code, documentation source, and 60 | configuration files for the Package. 61 | 62 | "Compiled" form means the compiled bytecode, object code, binary, 63 | or any other form resulting from mechanical transformation or 64 | translation of the Source form. 65 | 66 | 67 | Permission for Use and Modification Without Distribution 68 | 69 | (1) You are permitted to use the Standard Version and create and use 70 | Modified Versions for any purpose without restriction, provided that 71 | you do not Distribute the Modified Version. 72 | 73 | 74 | Permissions for Redistribution of the Standard Version 75 | 76 | (2) You may Distribute verbatim copies of the Source form of the 77 | Standard Version of this Package in any medium without restriction, 78 | either gratis or for a Distributor Fee, provided that you duplicate 79 | all of the original copyright notices and associated disclaimers. At 80 | your discretion, such verbatim copies may or may not include a 81 | Compiled form of the Package. 82 | 83 | (3) You may apply any bug fixes, portability changes, and other 84 | modifications made available from the Copyright Holder. The resulting 85 | Package will still be considered the Standard Version, and as such 86 | will be subject to the Original License. 87 | 88 | 89 | Distribution of Modified Versions of the Package as Source 90 | 91 | (4) You may Distribute your Modified Version as Source (either gratis 92 | or for a Distributor Fee, and with or without a Compiled form of the 93 | Modified Version) provided that you clearly document how it differs 94 | from the Standard Version, including, but not limited to, documenting 95 | any non-standard features, executables, or modules, and provided that 96 | you do at least ONE of the following: 97 | 98 | (a) make the Modified Version available to the Copyright Holder 99 | of the Standard Version, under the Original License, so that the 100 | Copyright Holder may include your modifications in the Standard 101 | Version. 102 | 103 | (b) ensure that installation of your Modified Version does not 104 | prevent the user installing or running the Standard Version. In 105 | addition, the Modified Version must bear a name that is different 106 | from the name of the Standard Version. 107 | 108 | (c) allow anyone who receives a copy of the Modified Version to 109 | make the Source form of the Modified Version available to others 110 | under 111 | 112 | (i) the Original License or 113 | 114 | (ii) a license that permits the licensee to freely copy, 115 | modify and redistribute the Modified Version using the same 116 | licensing terms that apply to the copy that the licensee 117 | received, and requires that the Source form of the Modified 118 | Version, and of any works derived from it, be made freely 119 | available in that license fees are prohibited but Distributor 120 | Fees are allowed. 121 | 122 | 123 | Distribution of Compiled Forms of the Standard Version 124 | or Modified Versions without the Source 125 | 126 | (5) You may Distribute Compiled forms of the Standard Version without 127 | the Source, provided that you include complete instructions on how to 128 | get the Source of the Standard Version. Such instructions must be 129 | valid at the time of your distribution. If these instructions, at any 130 | time while you are carrying out such distribution, become invalid, you 131 | must provide new instructions on demand or cease further distribution. 132 | If you provide valid instructions or cease distribution within thirty 133 | days after you become aware that the instructions are invalid, then 134 | you do not forfeit any of your rights under this license. 135 | 136 | (6) You may Distribute a Modified Version in Compiled form without 137 | the Source, provided that you comply with Section 4 with respect to 138 | the Source of the Modified Version. 139 | 140 | 141 | Aggregating or Linking the Package 142 | 143 | (7) You may aggregate the Package (either the Standard Version or 144 | Modified Version) with other packages and Distribute the resulting 145 | aggregation provided that you do not charge a licensing fee for the 146 | Package. Distributor Fees are permitted, and licensing fees for other 147 | components in the aggregation are permitted. The terms of this license 148 | apply to the use and Distribution of the Standard or Modified Versions 149 | as included in the aggregation. 150 | 151 | (8) You are permitted to link Modified and Standard Versions with 152 | other works, to embed the Package in a larger work of your own, or to 153 | build stand-alone binary or bytecode versions of applications that 154 | include the Package, and Distribute the result without restriction, 155 | provided the result does not expose a direct interface to the Package. 156 | 157 | 158 | Items That are Not Considered Part of a Modified Version 159 | 160 | (9) Works (including, but not limited to, modules and scripts) that 161 | merely extend or make use of the Package, do not, by themselves, cause 162 | the Package to be a Modified Version. In addition, such works are not 163 | considered parts of the Package itself, and are not subject to the 164 | terms of this license. 165 | 166 | 167 | General Provisions 168 | 169 | (10) Any use, modification, and distribution of the Standard or 170 | Modified Versions is governed by this Artistic License. By using, 171 | modifying or distributing the Package, you accept this license. Do not 172 | use, modify, or distribute the Package, if you do not accept this 173 | license. 174 | 175 | (11) If your Modified Version has been derived from a Modified 176 | Version made by someone other than you, you are nevertheless required 177 | to ensure that your Modified Version complies with the requirements of 178 | this license. 179 | 180 | (12) This license does not grant you the right to use any trademark, 181 | service mark, tradename, or logo of the Copyright Holder. 182 | 183 | (13) This license includes the non-exclusive, worldwide, 184 | free-of-charge patent license to make, have made, use, offer to sell, 185 | sell, import and otherwise transfer the Package with respect to any 186 | patent claims licensable by the Copyright Holder that are necessarily 187 | infringed by the Package. If you institute patent litigation 188 | (including a cross-claim or counterclaim) against any party alleging 189 | that the Package constitutes direct or contributory patent 190 | infringement, then this Artistic License to you shall terminate on the 191 | date that such litigation is filed. 192 | 193 | (14) Disclaimer of Warranty: 194 | THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER AND CONTRIBUTORS "AS 195 | IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES. THE IMPLIED 196 | WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, OR 197 | NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY YOUR LOCAL 198 | LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR CONTRIBUTOR WILL 199 | BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL 200 | DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE, EVEN IF 201 | ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 202 | -------------------------------------------------------------------------------- /lib/App/Prancer/Routes.pm6: -------------------------------------------------------------------------------- 1 | =begin pod 2 | 3 | =head1 App::Prancer::Routes 4 | 5 | Lets your application respond to HTTP routes by adding just C. 6 | 7 | =head1 Synopsis 8 | 9 | use App::Prancer::Routes; 10 | 11 | # Respond to GET /my-profile 12 | # 13 | multi GET( 'my-profile' ) is route 14 | { return "My Profile" } 15 | 16 | # Respond to GET /posts/$page-number?format=JSON 17 | # 18 | multi GET( 'posts', Int $page, Str :$format ) is route 19 | { if $format and $format eq 'JSON' 20 | { return to-JSON( { name => 'My Post', content => '...' } ) } 21 | else 22 | { return "Page $page" } } 23 | 24 | prance(); 25 | 26 | =head1 Documentation 27 | 28 | By default, L serves all static content from the C directory 29 | inside your L application. If you want to serve dynamically-generated 30 | content, you should declare a route. 31 | 32 | Like its Perl 5 counterparts Mojolicious, Dancer and Catalyst, L 33 | lets your web application "listen to" URLs that you declare. These can be as 34 | simple as displaying your L file when a browser requests the 35 | C URL, or as complex as performing database retrieval 36 | and updating after a user submits a multi-part AJAX-enabled form with JSON 37 | embedded in it. 38 | 39 | Unlike its Perl 5 counterparts, L tries not to use DSLs, instead 40 | relying on (at long last) the Perl 6 multi-method dispatch system. If this 41 | sounds scary, it shouldn't. All it really means is that instead of passing 42 | a string declaring your route to a C or C method, you just 43 | declare a function with parameters that specify the route you want to listen 44 | to. 45 | 46 | Most web applications have a "home" button somewhere on every page that lets 47 | the user return to the front page, in case they get lost. This is usually 48 | written in HTML as C<< >>. When the user 49 | clicks on the link, it sends C to your webserver, and the 50 | fun begins. 51 | 52 | In order to listen to this URL and respond with content, all you need to do is 53 | add a single function to your file. 54 | 55 | multi GET( '/' ) is route 56 | { "</head><body>Hello world!</body></html>" } 57 | 58 | Yes, it's an actual function. We use C<multi> instead of C<sub> because this 59 | is a real function (go ahead and call it like so: C<say GET('/');>), and more 60 | than likely you'll want to listen to more than one C<GET> URL. 61 | 62 | And yes, C<'/'> is a valid function parameter. It probably looks strange at 63 | first reading, but Perl 6 functions can take scalars, arrays, hashes B<and> 64 | constants as arguments, and L<Prancer> takes advantage of that. 65 | 66 | Finally, the real magic happens in C<is route>. This is how you as a programmer 67 | tell L<Prancer> that this function should be treated as a route that the web 68 | application should listen to. Without this declaration, the function will sit 69 | there unused. 70 | 71 | If your URL has more than one path element in them, you can use the C</> 72 | path separator, or list the two path elements as separate arguments. 73 | 74 | multi GET( 'posts/page' ) is route { } 75 | multi GET( 'posts', 'page' ) is route 76 | { return "/posts/page" } 77 | 78 | are the same route. If you want to use more of a REST-style URL, you can 79 | use ordinary Perl parameters as part of your parameter list. 80 | 81 | GET /posts/DrForr HTTP/1.1 82 | multi GET( 'posts', Str:D $username ) is route 83 | { return "/posts/$username" } 84 | 85 | You can use regular expressions in your URLs as well, just use a constraint as 86 | you normally would in Perl 6. Regular expression matches are tried first, 87 | followed by any catchall terms you may have supplied. 88 | 89 | GET /team/jersey-devils HTTP/1.1 90 | multi GET( 'team', Str:D $team where { /\w+\-\w+/ } ) is route 91 | { return "/team/$team (hyphenated)" } 92 | multi GET( 'team', Str:D $team ) is route 93 | { return "/team/$team" } 94 | 95 | Last, but not least, wildcards are also just Perl variables. If you want to 96 | match anything, just declare a parameter with no types. Or if you want to 97 | match anything under a given URL, declare an array which will be filled with 98 | the rest of the path. Not a slurpy array though, that does something different. 99 | 100 | GET /path/to/my/deeply-buried-avatar.png HTTP/1.1 101 | multi GET( 'path', $to, @path-to-avatar ) is route 102 | { return "/path/$to/{@path-to-avatar.join('/')}" } 103 | 104 | =head1 Ordering 105 | 106 | =head1 Arguments 107 | 108 | =head2 Query arguments 109 | 110 | Of course, any method can take query arguments. The simplest way to address 111 | this is by including them as optional parameters. 112 | 113 | GET /post/?slug=my_amazing_post&id=1 HTTP/1.1 114 | multi GET( 'post', :$slug, :$id ) is route 115 | { return "/post/?slug=$slug\&id=$id" } 116 | 117 | Or, if you'd prefer not to clutter up your argument list, you can use the 118 | C<$*QUERY> variable that L<Prancer> provides. This will be a 119 | C<Hash::MultiValue> object as keys can occur multiple times in a given query. 120 | 121 | GET /post/?slug=my_amazing_post&id=1 HTTP/1.1 122 | multi GET( 'post' ) is route 123 | { return "/post/?slug=$*QUERY.<slug>\&id=$*QUERY.<id>" } 124 | 125 | =head2 Form parameters 126 | 127 | Likewise, C<POST> methods have form content, so look for that in the C<$*BODY> 128 | argument. 129 | 130 | POST /post HTTP/1.1 [slug=value, id=value] 131 | multi POST( 'post' ) is route 132 | { return "/post/?slug=$*BODY.<slug>\&id=$*BODY.<id>" } 133 | 134 | =head2 Cookies 135 | 136 | If you need session management, you can use C<App::Prancer::Plugin::Session> 137 | and add C<$*SESSION> to manipulate user sessions. Otherwise use C<$*COOKIES> 138 | to view and update cookies. 139 | 140 | =head1 Fallback 141 | 142 | Ultimately if none of these methods work for your URL, you can always ask to 143 | have the original L<Crust> C<$env> variable passed to you in C<%*ENV>: 144 | 145 | POST /post HTTP/1.1 [slug=value, id=value] 146 | multi POST( 'post' ) is route 147 | { return "/post/?slug=$*ENV.post_parameters.<slug>" } 148 | 149 | =head1 Calling order 150 | 151 | =over 152 | 153 | =item Static files 154 | 155 | =item Dynamic routes with only literal terms 156 | 157 | =item Dynamic routes with C<Int> variables 158 | 159 | =item Dynamic routes with C<Str> variables 160 | 161 | =item Otherwise a 404 File Not Found response is returned. 162 | 163 | =back 164 | 165 | Parameters are checked from left to right, so if two or more route can match 166 | a given path, the one that matches the first term wins. Take a look at 167 | C<find-route> in L<App::Prancer::Routes> for more information, or see the test 168 | suite. 169 | 170 | =end pod 171 | 172 | use Crust::Runner; 173 | use Crust::MIME; 174 | use App::Prancer::Core; 175 | use App::Prancer::Sessions; 176 | use App::Prancer::StateMachine; 177 | 178 | #my $uri = URI.new( "$env.<p6sgi.url-scheme>://$env.<REMOTE_HOST>$env.<PATH_INFO>?$env.<QUERY_STRING>" ); 179 | 180 | #constant HTTP-REQUEST-METHODS = 181 | # <DELETE GET HEAD OPTIONS PATCH POST PUT>; 182 | 183 | our $PRANCER-INTERNAL-ROUTES = App::Prancer::Core.new; 184 | our $PRANCER-INTERNAL-SESSIONS = App::Prancer::Sessions.new; 185 | our $PRANCER-STATE-MACHINE = App::Prancer::StateMachine.new; 186 | 187 | sub routine-to-route( Routine $r ) 188 | { 189 | my @parameters; 190 | 191 | for $r.signature.params -> $param 192 | { 193 | next if $param.optional; 194 | 195 | my $rv; 196 | if $param.name { $rv = '#(' ~ $param.type.perl ~ ')' } 197 | else { $rv = param-to-string( $param ) } 198 | 199 | @parameters.append( $rv ); 200 | } 201 | 202 | return @parameters 203 | } 204 | 205 | sub param-to-string( $param ) 206 | { 207 | my $path-element; 208 | 209 | # XXX Not sure why this is necessary, except for 210 | # XXX $param.constraints being a junction 211 | # 212 | for $param.constraints -> $constraint 213 | { 214 | return $constraint; 215 | } 216 | } 217 | 218 | my class Route-Info 219 | { 220 | has Routine $.r; 221 | has @.args; 222 | has @.optional-args; 223 | has %.map; 224 | } 225 | 226 | sub URL-to-route-map( @names ) 227 | { 228 | my $strung = '/' ~ @names.join( '/' ); 229 | $strung ~~ s:g/\/+/\//; 230 | my %map; 231 | my @canon = grep { $_ ne '' }, map { ~$_ }, $strung.split( /\//, :v ); 232 | my @value; 233 | for ^@names.elems -> $value 234 | { 235 | next unless @names[$value] ~~ /^\#/; 236 | 237 | @value.push( $value ) 238 | } 239 | 240 | for ^@canon.elems -> $key 241 | { 242 | next unless @canon[$key] ~~ /^\#/; 243 | 244 | %map{$key} = shift @value 245 | } 246 | 247 | return %map 248 | } 249 | 250 | multi sub trait_mod:<is>( Routine $r, :$route! ) is export(:testing,:MANDATORY) 251 | { 252 | my $name = $r.name; 253 | my @names = routine-to-route( $r ); 254 | my $path = @names.join('/'); 255 | $path ~~ s:g/\/+/\//; 256 | 257 | my @path = grep { $_ ne '' }, map { ~$_ }, $path.split(/\//, :v); 258 | my %map = URL-to-route-map( @names ); 259 | my @optional; 260 | 261 | for $r.signature.params -> $param 262 | { 263 | next unless $param.optional; 264 | $param.name ~~ /^\$(.+)/; 265 | @optional.push( '#(' ~ $param.type.^name ~ '):' ~ $param.name ) 266 | } 267 | 268 | my $info = Route-Info.new( 269 | :r( $r ), 270 | :args( @names ), 271 | :map( %map ), 272 | :optional-args( @optional ) 273 | ); 274 | 275 | $PRANCER-INTERNAL-ROUTES.add( $name, $info, @path ); 276 | } 277 | 278 | # XXX Assign relative path correctly 279 | constant ABSOLUT-KITTEH = "/home/jgoff/Repositories/perl6-App-prancer/theperlfisher.blogspot.ro/response-kittehs"; 280 | constant STATIC-DIRECTORY = "static"; 281 | 282 | use Crust::Request; 283 | use Cookie::Baker; 284 | 285 | sub make-optional-args( $info, $req ) 286 | { 287 | my @optional-args; 288 | 289 | for $info.optional-args -> $optional 290 | { 291 | $optional ~~ /^\#\((.+)\)\:\$(.+)/; 292 | my $name = $1; 293 | my $value; 294 | if $0 eq 'Str' 295 | { 296 | $value = ~$req.query-parameters.{$1}; 297 | } 298 | elsif $0 eq 'Int' 299 | { 300 | $value = +$req.query-parameters.{$1}; 301 | } 302 | @optional-args.push( $name => $value ); 303 | } 304 | return @optional-args 305 | } 306 | 307 | sub make-path( $path-info ) 308 | { 309 | my @path; 310 | 311 | for $path-info.split(/\//, :v) -> $x 312 | { 313 | next if $x eq ''; 314 | my $foo = $x; 315 | 316 | if $x ~~ Match 317 | { $foo = ~$x } 318 | elsif $x ~~ /^'-'?\d+/ 319 | { $foo = +$x } 320 | 321 | @path.append( $foo ) 322 | } 323 | return @path; 324 | } 325 | 326 | #sub error-404( $env ) 327 | # { 328 | # my $response-code = $PRANCER-STATE-MACHINE.run($env); 329 | # unless $response-code == 200 330 | # { 331 | # my $kitteh = ABSOLUT-KITTEH ~ 332 | # "/$response-code.jpg"; 333 | # @content = $kitteh.IO.slurp :bin; 334 | # %header<Content-Type> = 'image/jpeg'; 335 | # } 336 | # return 404; 337 | # } 338 | 339 | sub app( $env ) is export(:testing,:ALL) 340 | { 341 | my ( $return-code, @content, %header, @path ); 342 | my $req = Crust::Request.new($env); 343 | my $request-method = $env.<REQUEST_METHOD>; 344 | 345 | @path = make-path( $env.<PATH_INFO> ); 346 | 347 | my $file = STATIC-DIRECTORY ~ $env.<PATH_INFO>; 348 | my $info = $PRANCER-INTERNAL-ROUTES.find( 349 | $request-method, $env.<PATH_INFO> ); 350 | 351 | # XXX *This* bit is what the Ruby state machine should be handling. 352 | # XXX "Bit", he says. Riiiight. 353 | 354 | if $info 355 | { 356 | my @args = $info.args; 357 | for $info.map.keys -> $arg 358 | { 359 | @args[$info.map.{$arg}] = @path[$arg] 360 | } 361 | 362 | my $*PRANCER-SESSION; 363 | my %cookies; 364 | if $env.<HTTP_COOKIE> 365 | { 366 | %cookies = crush-cookie( $env.<HTTP_COOKIE> ); 367 | if %cookies<session> 368 | { 369 | $*PRANCER-SESSION = 370 | $PRANCER-INTERNAL-SESSIONS.find( 371 | %cookies<session> ); 372 | } 373 | } 374 | 375 | my $*PRANCER-ENV = $env; 376 | if $env.<QUERY_STRING> ne '' and $info.optional-args.elems 377 | { 378 | my @optional-args = make-optional-args( $info, $req ); 379 | 380 | @content = $info.r.( |@args, |%(@optional-args) ); 381 | } 382 | elsif $env.<CONTENT_LENGTH> > 0 383 | { 384 | my @optional-args = make-optional-args( $info, $req ); 385 | my @optional-args = [{ username => 'admin', password => 'asdf' }]; 386 | 387 | my $buf = $env.<p6sgi.input>.read( $env.<CONTENT_LENGTH> ); 388 | #say $buf.decode; 389 | 390 | if $info.optional-args.elems 391 | { 392 | @content = $info.r.( |@args, |%(@optional-args) ); 393 | } 394 | else 395 | { 396 | @content = $info.r.( |@args ); 397 | } 398 | } 399 | else 400 | { 401 | @content = $info.r.( |@args ); 402 | } 403 | 404 | if $*PRANCER-SESSION.defined 405 | { 406 | my $cookie; 407 | if %cookies<session> 408 | { 409 | my $current-id = %cookies<session>; 410 | $PRANCER-INTERNAL-SESSIONS.set( 411 | $current-id, $*PRANCER-SESSION ); 412 | } 413 | else 414 | { 415 | my $new-id = 416 | $PRANCER-INTERNAL-SESSIONS.add( 417 | $*PRANCER-SESSION ); 418 | $cookie = bake-cookie('session', $new-id ); 419 | %header<Set-Cookie> = $cookie; 420 | } 421 | } 422 | 423 | %header<Content-Type> = 'text/html'; 424 | $return-code = 200; 425 | } 426 | elsif $file.IO.e 427 | { 428 | my $MIME-type = Crust::MIME.mime-type( $file ); 429 | if $MIME-type ~~ /text/ 430 | { 431 | @content = ( $file.IO.slurp ); 432 | } 433 | else 434 | { 435 | @content = ( $file.IO.slurp :bin ); 436 | } 437 | 438 | %header<Content-Type> = $MIME-type; 439 | $return-code = 200; 440 | } 441 | else 442 | { 443 | $return-code = 404; 444 | } 445 | 446 | say "$env.<REQUEST_METHOD> $env.<PATH_INFO>?$env.<QUERY_STRING> - $return-code" 447 | if %*ENV<PRANCER_TRACE>; 448 | 449 | return $return-code, [ %header ], [ @content ] 450 | } 451 | 452 | sub display() is export(:testing) 453 | { 454 | for $PRANCER-INTERNAL-ROUTES.available -> $method 455 | { 456 | say "$method:"; 457 | .say for map { " $_" }, 458 | $PRANCER-INTERNAL-ROUTES.list( $method ); 459 | } 460 | } 461 | 462 | sub prance() is export 463 | { 464 | my $runner = Crust::Runner.new; 465 | display if %*ENV<PRANCER_VERBOSE>; 466 | 467 | # Tell the state machine that the service is available. 468 | # 469 | $PRANCER-STATE-MACHINE.make-available; 470 | $runner.run( &app ) 471 | } 472 | -------------------------------------------------------------------------------- /lib/App/Prancer/StateMachine.pm6: -------------------------------------------------------------------------------- 1 | #`( 2 | new(R_Mod, R_ModState, R_ModExports, R_Trace) -> 3 | {?MODULE, R_Mod, R_ModState, R_ModExports, R_Trace}. 4 | 5 | default(ping) -> no_default; 6 | default(service_available) -> true; 7 | default(resource_exists) -> true; 8 | default(auth_required) -> true; 9 | default(is_authorized) -> true; 10 | default(forbidden) -> false; 11 | default(allow_missing_post) -> false; 12 | default(malformed_request) -> false; 13 | default(uri_too_long) -> false; 14 | default(known_content_type) -> true; 15 | default(valid_content_headers) -> true; 16 | default(valid_entity_length) -> true; 17 | default(options) -> []; 18 | default(allowed_methods) -> ['GET', 'HEAD']; 19 | default(known_methods) -> 20 | ['GET', 'HEAD', 'POST', 'PUT', 'DELETE', 'TRACE', 'CONNECT', 'OPTIONS']; 21 | default(content_types_provided) -> [{"text/html", to_html}]; 22 | default(content_types_accepted) -> []; 23 | default(delete_resource) -> false; 24 | default(delete_completed) -> true; 25 | default(post_is_create) -> false; 26 | default(create_path) -> undefined; 27 | default(base_uri) -> undefined; 28 | default(process_post) -> false; 29 | default(language_available) -> true; 30 | default(charsets_provided) -> 31 | no_charset; % this atom causes charset-negotation to short-circuit 32 | % the default setting is needed for non-charset responses such as image/png 33 | % an example of how one might do actual negotiation 34 | % [{"iso-8859-1", fun(X) -> X end}, {"utf-8", make_utf8}]; 35 | default(encodings_provided) -> 36 | [{"identity", fun(X) -> X end}]; 37 | % this is handy for auto-gzip of GET-only resources: 38 | % [{"identity", fun(X) -> X end}, {"gzip", fun(X) -> zlib:gzip(X) end}]; 39 | default(variances) -> []; 40 | default(is_conflict) -> false; 41 | default(multiple_choices) -> false; 42 | default(previously_existed) -> false; 43 | default(moved_permanently) -> false; 44 | default(moved_temporarily) -> false; 45 | default(last_modified) -> undefined; 46 | default(expires) -> undefined; 47 | default(generate_etag) -> undefined; 48 | default(finish_request) -> true; 49 | default(validate_content_checksum) -> not_validated; 50 | ) 51 | 52 | class App::Prancer::StateMachine 53 | { 54 | constant MAX-ITERATIONS = 54; # Number of nodes 55 | constant START-STATE = 'B13'; 56 | 57 | has Bool $.available = False; 58 | 59 | sub B13-available( $machine, $r ) 60 | { 61 | return $machine.available; 62 | } 63 | sub B12-known-method( $machine, $r ) 64 | { 65 | return $r.<REQUEST_METHOD> ~~ 66 | <GET HEAD POST PUT DELETE TRACE CONNECT OPTIONS>.any 67 | #return $r.<REQUEST_METHOD> ~~ 68 | # <DELETE GET HEAD OPTIONS PATCH POST PUT>.any 69 | } 70 | sub B11-uri-too-long( $machine, $r ) 71 | { 72 | return False; 73 | } 74 | sub B10-method-allowed-on-resource( $machine, $r ) 75 | { 76 | return True; 77 | } 78 | sub B09-malformed( $machine, $r ) 79 | { 80 | return False; 81 | } 82 | sub B08-authorized( $machine, $r ) 83 | { 84 | return True; 85 | } 86 | sub B07-forbidden( $machine, $r ) 87 | { 88 | return False; 89 | } 90 | sub B06-unsupported-content-header( $machine, $r ) 91 | { 92 | return False; 93 | } 94 | sub B05-unknown-content-type( $machine, $r ) 95 | { 96 | return True; 97 | } 98 | sub B04-request-entity-too-large( $machine, $r ) 99 | { 100 | return False; 101 | } 102 | sub B03-OPTIONS( $machine, $r ) 103 | { return $r.<method> eq 'OPTIONS' } 104 | sub C03-Accept-exists( $machine, $r ) 105 | { return ?$r.<HTTP_ACCEPT> } 106 | sub C04-Acceptable-media-type-available( $machine, $r ) 107 | { 108 | return True; 109 | } 110 | sub D04-Accept-Language-exists( $machine, $r ) 111 | { return ?$r.<HTTP_ACCEPT_LANGUAGE> } 112 | sub D05-Acceptable-language-available( $machine, $r ) 113 | { 114 | return True; 115 | } 116 | sub E05-Accept-Charset-exists( $machine, $r ) 117 | { return ?$r.<HTTP_ACCEPT_CHARSET> } 118 | sub E06-Acceptable-charset-available( $machine, $r ) 119 | { 120 | return True; 121 | } 122 | sub F06-Accept-Encoding-exists( $machine, $r ) 123 | { return ?$r.<HTTP_ACCEPT_ENCODING> } 124 | sub F07-Acceptable-encoding-available( $machine, $r ) 125 | { 126 | return True; 127 | } 128 | sub G07-Resource-exists( $machine, $r ) 129 | { 130 | return True; 131 | } 132 | sub G08-If-Match-exists( $machine, $r ) 133 | { 134 | return True; 135 | } 136 | sub G09-If-Match-star-exists( $machine, $r ) 137 | { 138 | return True; 139 | } 140 | sub G11-Etag-in-If-Match( $machine, $r ) 141 | { 142 | return True; 143 | } 144 | sub H07-If-Match-star-exists( $machine, $r ) 145 | { 146 | return True; 147 | } 148 | sub H10-If-Unmodified-Since-exists( $machine, $r ) 149 | { 150 | return True; 151 | } 152 | sub H11-If-Unmodified-Since-is-valid-date( $machine, $r ) 153 | { 154 | return True; 155 | } 156 | sub H12-Last-Modified-after-If-Unmodified-Since( $machine, $r ) 157 | { 158 | return True; 159 | } 160 | sub I04-Server-desires-different-uri( $machine, $r ) 161 | { 162 | return False; 163 | } 164 | sub I07-PUT( $machine, $r ) 165 | { return $r.<REQUEST_METHOD> eq 'PUT' } 166 | sub I12-If-None-Match-exists( $machine, $r ) 167 | { 168 | return False; 169 | } 170 | sub I13-If-None-Match-star-exists( $machine, $r ) 171 | { 172 | return False; 173 | } 174 | sub J18-GET-or-HEAD( $machine, $r ) 175 | { 176 | return $r.<REQUEST_METHOD> eq 'GET' or 177 | $r.<REQUEST_METHOD> eq 'HEAD' 178 | } 179 | sub K05-Resource-Moved-Permanently( $machine, $r ) 180 | { 181 | return False; 182 | } 183 | sub K07-Resource-previously-existed( $machine, $r ) 184 | { 185 | return False; 186 | } 187 | sub K13-Etag-in-If-None-Match( $machine, $r ) 188 | { 189 | return False; 190 | } 191 | sub L05-Resource-moved-temporarily( $machine, $r ) 192 | { 193 | return False; 194 | } 195 | sub L07-POST( $machine, $r ) 196 | { return $r.<method> eq 'POST' } 197 | sub L13-If-Modified-Since-exists( $machine, $r ) 198 | { 199 | return False; 200 | } 201 | sub L14-If-Modified-Since-is-valid-date( $machine, $r ) 202 | { 203 | return False; 204 | } 205 | sub L15-If-Modified-Since-after-Now( $machine, $r ) 206 | { 207 | return False; 208 | } 209 | sub L17-Last-Modified-after-If-Modified-Since( $machine, $r ) 210 | { 211 | return False; 212 | } 213 | sub M05-POST( $machine, $r ) 214 | { return $r.<method> eq 'POST' } 215 | sub M07-Server-permits-POST-to-missing-resource( $machine, $r ) 216 | { 217 | return False; 218 | } 219 | sub M16-DELETE( $machine, $r ) 220 | { return $r.<method> eq 'DELETE' } 221 | sub M20-Delete-enacted( $machine, $r ) 222 | { 223 | return False; 224 | } 225 | sub N05-Server-permits-POST-to-missing-resource( $machine, $r ) 226 | { 227 | return False; 228 | } 229 | sub N11-Redirect( $machine, $r ) 230 | { 231 | return False; 232 | } 233 | sub N16-POST( $machine, $r ) 234 | { return $r.<REQUEST_METHOD> eq 'POST' } 235 | sub O14-Conflict( $machine, $r ) 236 | { 237 | return False; 238 | } 239 | sub O16-PUT( $machine, $r ) 240 | { return $r.<REQUEST_METHOD> eq 'PUT' } 241 | sub O18-Multiple-representations( $machine, $r ) 242 | { 243 | return False; 244 | } 245 | sub O20-Response-includes-an-entity( $machine, $r ) 246 | { 247 | return False; 248 | } 249 | sub P03-Conflict( $machine, $r ) 250 | { 251 | return False; 252 | } 253 | sub P11-New-resource( $machine, $r ) 254 | { 255 | return False; 256 | } 257 | 258 | has %.graph = 259 | ( 260 | B13 => 261 | { 262 | node => &B13-available, 263 | true => 'B12', 264 | false => 503 265 | }, 266 | B12 => 267 | { 268 | node => &B12-known-method, 269 | true => 'B11', 270 | false => 501 271 | }, 272 | B11 => 273 | { 274 | node => &B11-uri-too-long, 275 | true => 414, 276 | false => 'B10' 277 | }, 278 | B10 => 279 | { 280 | node => &B10-method-allowed-on-resource, 281 | true => 'B09', 282 | false => 405 283 | }, 284 | B09 => 285 | { 286 | node => &B09-malformed, 287 | true => 400, 288 | false => 'B08' 289 | }, 290 | B08 => 291 | { 292 | node => &B08-authorized, 293 | true => 'B07', 294 | false => 401 295 | }, 296 | B07 => 297 | { 298 | node => &B07-forbidden, 299 | true => 403, 300 | false => 'B06' 301 | }, 302 | B06 => 303 | { 304 | node => &B06-unsupported-content-header, 305 | true => 501, 306 | false => 'B05' 307 | }, 308 | B05 => 309 | { 310 | node => &B05-unknown-content-type, 311 | true => 415, 312 | false => 'B04' 313 | }, 314 | B04 => 315 | { 316 | node => &B04-request-entity-too-large, 317 | true => 413, 318 | false => 'B03' 319 | }, 320 | B03 => 321 | { 322 | node => &B03-OPTIONS, 323 | true => 200, 324 | false => 'C03' 325 | }, 326 | C03 => 327 | { 328 | node => &C03-Accept-exists, 329 | true => 'C04', 330 | false => 'D04' 331 | }, 332 | C04 => 333 | { 334 | node => &C04-Acceptable-media-type-available, 335 | true => 'D04', 336 | false => 406 337 | }, 338 | D04 => 339 | { 340 | node => &D04-Accept-Language-exists, 341 | true => 'D05', 342 | false => 'E05' 343 | }, 344 | D05 => 345 | { 346 | node => &D05-Acceptable-language-available, 347 | true => 'E05', 348 | false => 406 349 | }, 350 | E05 => 351 | { 352 | node => &E05-Accept-Charset-exists, 353 | true => 'E06', 354 | false => 'F06' 355 | }, 356 | E06 => 357 | { 358 | node => &E06-Acceptable-charset-available, 359 | true => 'F06', 360 | false => 406 361 | }, 362 | F06 => 363 | { 364 | node => &F06-Accept-Encoding-exists, 365 | true => 'F07', 366 | false => 'G07' 367 | }, 368 | F07 => 369 | { 370 | node => &F07-Acceptable-encoding-available, 371 | true => 'G07', 372 | false => 406 373 | }, 374 | G07 => 375 | { 376 | node => &G07-Resource-exists, 377 | true => 'G08', 378 | false => 'H07' 379 | }, 380 | G08 => 381 | { 382 | node => &G08-If-Match-exists, 383 | true => 'G09', 384 | false => 'H10' 385 | }, 386 | G09 => 387 | { 388 | node => &G09-If-Match-star-exists, 389 | true => 'G11', 390 | false => 'H10' 391 | }, 392 | G11 => 393 | { 394 | node => &G11-Etag-in-If-Match, 395 | true => 'H10', 396 | false => 412 397 | }, 398 | H07 => 399 | { 400 | node => &H07-If-Match-star-exists, 401 | true => 412, 402 | false => 'I07' 403 | }, 404 | H10 => 405 | { 406 | node => &H10-If-Unmodified-Since-exists, 407 | true => 'H11', 408 | false => 'I12' 409 | }, 410 | H11 => 411 | { 412 | node => &H11-If-Unmodified-Since-is-valid-date, 413 | true => 'H12', 414 | false => 'I12' 415 | }, 416 | H12 => 417 | { 418 | node => &H12-Last-Modified-after-If-Unmodified-Since, 419 | true => 412, 420 | false => 'I12' 421 | }, 422 | I04 => 423 | { 424 | node => &I04-Server-desires-different-uri, 425 | true => 301, 426 | false => 'P03' 427 | }, 428 | I07 => 429 | { 430 | node => &I07-PUT, 431 | true => 'I04', 432 | false => 'K07' 433 | }, 434 | I12 => 435 | { 436 | node => &I12-If-None-Match-exists, 437 | true => 'I13', 438 | false => 'L13' 439 | }, 440 | I13 => 441 | { 442 | node => &I13-If-None-Match-star-exists, 443 | true => 'J18', 444 | false => 'K13' 445 | }, 446 | J18 => 447 | { 448 | node => &J18-GET-or-HEAD, 449 | true => 304, 450 | false => 412 451 | }, 452 | K05 => 453 | { 454 | node => &K05-Resource-Moved-Permanently, 455 | true => 301, 456 | false => 'L05' 457 | }, 458 | K07 => 459 | { 460 | node => &K07-Resource-previously-existed, 461 | true => 'K05', 462 | false => 'L07' 463 | }, 464 | K13 => 465 | { 466 | node => &K13-Etag-in-If-None-Match, 467 | true => 'J18', 468 | false => 'L13' 469 | }, 470 | L05 => 471 | { 472 | node => &L05-Resource-moved-temporarily, 473 | true => 307, 474 | false => 'L05' 475 | }, 476 | L07 => 477 | { 478 | node => &L07-POST, 479 | true => 'M07', 480 | false => 404 481 | }, 482 | L13 => 483 | { 484 | node => &L13-If-Modified-Since-exists, 485 | true => 'L14', 486 | false => 'M16' 487 | }, 488 | L14 => 489 | { 490 | node => &L14-If-Modified-Since-is-valid-date, 491 | true => 'L15', 492 | false => 'M16' 493 | }, 494 | L15 => 495 | { 496 | node => &L15-If-Modified-Since-after-Now, 497 | true => 'M16', 498 | false => 'L17' 499 | }, 500 | L17 => 501 | { 502 | node => &L17-Last-Modified-after-If-Modified-Since, 503 | true => 'M16', 504 | false => 304 505 | }, 506 | M05 => 507 | { 508 | node => &M05-POST, 509 | true => 'N05', 510 | false => 410 511 | }, 512 | M07 => 513 | { 514 | node => &M07-Server-permits-POST-to-missing-resource, 515 | true => 'N11', 516 | false => 404 517 | }, 518 | M16 => 519 | { 520 | node => &M16-DELETE, 521 | true => 'M20', 522 | false => 'N16' 523 | }, 524 | M20 => 525 | { 526 | node => &M20-Delete-enacted, 527 | true => 'O20', 528 | false => 202 529 | }, 530 | N05 => 531 | { 532 | node => &N05-Server-permits-POST-to-missing-resource, 533 | true => 'N11', 534 | false => 410 535 | }, 536 | N11 => 537 | { 538 | node => &N11-Redirect, 539 | true => 303, 540 | false => 'P11' 541 | }, 542 | N16 => 543 | { 544 | node => &N16-POST, 545 | true => 'N11', 546 | false => 'O16' 547 | }, 548 | O14 => 549 | { 550 | node => &O14-Conflict, 551 | true => 409, 552 | false => 'P11' 553 | }, 554 | O16 => 555 | { 556 | node => &O16-PUT, 557 | true => 'O14', 558 | false => 'O18' 559 | }, 560 | O18 => 561 | { 562 | node => &O18-Multiple-representations, 563 | true => 300, 564 | false => 'O16' 565 | }, 566 | O20 => 567 | { 568 | node => &O20-Response-includes-an-entity, 569 | true => 204, 570 | false => 'O18' 571 | }, 572 | P03 => 573 | { 574 | node => &P03-Conflict, 575 | true => 409, 576 | false => 'P11' 577 | }, 578 | P11 => 579 | { 580 | node => &P11-New-resource, 581 | true => 201, 582 | false => 'O20' 583 | }, 584 | ); 585 | 586 | method make-available() { $!available = True } 587 | 588 | method run( $env ) 589 | { 590 | my $state = START-STATE; 591 | my $iterations = MAX-ITERATIONS; 592 | while $state !~~ Int 593 | { 594 | fail "Fell off end of state machine!" 595 | unless %.graph{$state}; 596 | $state = %.graph{$state}<node>.( self, $env ) 597 | ?? %.graph{$state}<true> 598 | !! %.graph{$state}<false>; 599 | last if $iterations-- <= 0; 600 | } 601 | return $state; 602 | } 603 | } 604 | -------------------------------------------------------------------------------- /t/013-core-find-array.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Test; 3 | use App::Prancer::Core; 4 | 5 | plan 0; 6 | 7 | diag "*** Must get arrays working at some point."; 8 | diag "*** But for the moment they're a distraction."; 9 | 10 | #`( 11 | subtest sub 12 | { 13 | plan 7; 14 | 15 | my $r = App::Prancer::Core.new; 16 | 17 | $r.add( 'GET', 1, Array ); 18 | nok $r.find( 'GET', '/' ), q{Fail to find '/'}; 19 | 20 | is $r.find( 'GET', '/a' ), 1, q{Find '/a'}; 21 | is $r.find( 'GET', '/1' ), 1, q{Find '/1'}; 22 | 23 | nok $r.find( 'GET', '/a/' ), q{Fail to find '/a/'}; 24 | nok $r.find( 'GET', '/1/' ), q{Fail to find '/1/'}; 25 | 26 | is $r.find( 'GET', '/a/a' ), 1, q{Find '/a/a'}; 27 | is $r.find( 'GET', '/a/1' ), 1, q{Find '/a/1'}; 28 | }, 29 | q{Route '/#(Array)'}; 30 | 31 | subtest sub 32 | { 33 | plan 7; 34 | 35 | my $r = App::Prancer::Core.new; 36 | 37 | $r.add( 'GET', 1, Array, '/' ); 38 | nok $r.find( 'GET', '/' ), q{Fail to find '/'}; 39 | 40 | nok $r.find( 'GET', '/a' ), q{Fail to find '/a'}; 41 | nok $r.find( 'GET', '/1' ), q{Fail to find '/1'}; 42 | 43 | is $r.find( 'GET', '/a/' ), 1, q{Find '/a/'}; 44 | is $r.find( 'GET', '/1/' ), 1, q{Find '/1/'}; 45 | 46 | nok $r.find( 'GET', '/a/a' ), q{Fail to find '/a/a'}; 47 | nok $r.find( 'GET', '/a/1' ), q{Fail to find '/a/1'}; 48 | }, 49 | q{Route '/#(Array)/'}; 50 | 51 | subtest sub 52 | { 53 | subtest sub 54 | { 55 | plan 7; 56 | 57 | my $r = App::Prancer::Core.new; 58 | 59 | $r.add( 'GET', 1, '/a', Array ); 60 | nok $r.find( 'GET', '/a/' ), 61 | q{Fail to find '/a/'}; 62 | 63 | is $r.find( 'GET', '/a/a' ), 1, 64 | q{Find '/a/a'}; 65 | is $r.find( 'GET', '/a/1' ), 1, 66 | q{Find '/a/1'}; 67 | 68 | nok $r.find( 'GET', '/a/a/' ), 69 | q{Fail to find '/a/a/'}; 70 | nok $r.find( 'GET', '/a/1/' ), 71 | q{Fail to find '/a/1/'}; 72 | 73 | is $r.find( 'GET', '/a/a/a' ), 1, 74 | q{Find '/a/a/a'}; 75 | is $r.find( 'GET', '/a/a/1' ), 1, 76 | q{Find '/a/a/1'}; 77 | }, 78 | q{Route '/a/#(Array)'}; 79 | 80 | subtest sub 81 | { 82 | plan 7; 83 | 84 | my $r = App::Prancer::Core.new; 85 | 86 | $r.add( 'GET', 1, '/1', Array ); 87 | nok $r.find( 'GET', '/1/' ), 88 | q{Fail to find '/1/'}; 89 | 90 | is $r.find( 'GET', '/1/a' ), 1, 91 | q{Find '/1/a'}; 92 | is $r.find( 'GET', '/1/1' ), 1, 93 | q{Find '/1/1'}; 94 | 95 | nok $r.find( 'GET', '/1/a/' ), 96 | q{Fail to find '/1/a/'}; 97 | nok $r.find( 'GET', '/1/1/' ), 98 | q{Fail to find '/1/1/'}; 99 | 100 | is $r.find( 'GET', '/1/a/a' ), 1, 101 | q{Find '/1/a/a'}; 102 | is $r.find( 'GET', '/1/a/1' ), 1, 103 | q{Find '/1/a/1'}; 104 | }, 105 | q{Route '/1/#(Array)'}; 106 | 107 | subtest sub 108 | { 109 | plan 7; 110 | 111 | my $r = App::Prancer::Core.new; 112 | 113 | $r.add( 'GET', 1, '/#(Int)', Array ); 114 | nok $r.find( 'GET', '/1/' ), 115 | q{Fail to find '/#(Int)/'}; 116 | 117 | is $r.find( 'GET', '/1/a' ), 1, 118 | q{Find '/#(Int)/a'}; 119 | is $r.find( 'GET', '/1/1' ), 1, 120 | q{Find '/#(Int)/1'}; 121 | 122 | nok $r.find( 'GET', '/1/a/' ), 123 | q{Fail to find '/#(Int)/a/'}; 124 | nok $r.find( 'GET', '/1/1/' ), 125 | q{Fail to find '/#(Int)/1/'}; 126 | 127 | is $r.find( 'GET', '/1/a/a' ), 1, 128 | q{Find '/#(Int)/a/a'}; 129 | is $r.find( 'GET', '/1/a/1' ), 1, 130 | q{Find '/#(Int)/a/1'}; 131 | }, 132 | q{Route '/#(Int)/#(Array)'}; 133 | 134 | subtest sub 135 | { 136 | plan 7; 137 | 138 | my $r = App::Prancer::Core.new; 139 | 140 | $r.add( 'GET', 1, '/#(Str)', Array ); 141 | nok $r.find( 'GET', '/a/' ), 142 | q{Fail to find '/#(Str)/'}; 143 | 144 | is $r.find( 'GET', '/a/a' ), 1, 145 | q{Find '/#(Str)/a'}; 146 | is $r.find( 'GET', '/a/1' ), 1, 147 | q{Find '/#(Str)/1'}; 148 | 149 | nok $r.find( 'GET', '/a/a/' ), 150 | q{Fail to find '/#(Str)/a/'}; 151 | nok $r.find( 'GET', '/a/1/' ), 152 | q{Fail to find '/#(Str)/1/'}; 153 | 154 | is $r.find( 'GET', '/a/a/a' ), 1, 155 | q{Find '/#(Str)/a/a'}; 156 | is $r.find( 'GET', '/a/a/1' ), 1, 157 | q{Find '/#(Str)/a/1'}; 158 | }, 159 | q{Route '/#(Str)/#(Array)'}; 160 | 161 | # For the moment, assume that @foo indicates the final list of elemenets. 162 | #`( 163 | subtest sub 164 | { 165 | subtest sub 166 | { 167 | plan 7; 168 | 169 | my $r = App::Prancer::Core.new; 170 | 171 | $r.add( 'GET', 1, Array, 'a' ); 172 | nok $r.find( 'GET', '/a/' ), 173 | q{Fail to find '/#(Array)/'}; 174 | 175 | is $r.find( 'GET', '/a/a' ), 1, 176 | q{Find '/#(Array)/a'}; 177 | nok $r.find( 'GET', '/a/1' ), 178 | q{Fail to find '/#(Array)/1'}; 179 | 180 | nok $r.find( 'GET', '/a/a/' ), 181 | q{Fail to find '/#(Array)/a/'}; 182 | nok $r.find( 'GET', '/a/1/' ), 183 | q{Fail to find '/#(Array)/1/'}; 184 | 185 | nok $r.find( 'GET', '/a/a/a' ), 186 | q{Fail to find '/#(Array)/a/a'}; 187 | nok $r.find( 'GET', '/a/a/1' ), 188 | q{Fail to find '/#(Array)/a/1'}; 189 | }, 190 | q{Route '/#(Array)/a'}; 191 | 192 | subtest sub 193 | { 194 | plan 7; 195 | 196 | my $r = App::Prancer::Core.new; 197 | 198 | $r.add( 'GET', 1, Array, '1' ); 199 | nok $r.find( 'GET', '/a/' ), 200 | q{Fail to find '/#(Array)/'}; 201 | 202 | nok $r.find( 'GET', '/a/a' ), 203 | q{Fail to find '/#(Array)/a'}; 204 | is $r.find( 'GET', '/a/1' ), 1, 205 | q{Find '/#(Array)/1'}; 206 | 207 | nok $r.find( 'GET', '/a/a/' ), 208 | q{Fail to find '/#(Array)/a/'}; 209 | nok $r.find( 'GET', '/a/1/' ), 210 | q{Fail to find '/#(Array)/1/'}; 211 | 212 | nok $r.find( 'GET', '/a/a/a' ), 213 | q{Fail to find '/#(Array)/a/a'}; 214 | nok $r.find( 'GET', '/a/a/1' ), 215 | q{Fail to find '/#(Array)/a/1'}; 216 | }, 217 | q{Route '/#(Array)/1'}; 218 | 219 | subtest sub 220 | { 221 | plan 7; 222 | 223 | my $r = App::Prancer::Core.new; 224 | 225 | $r.add( 'GET', 1, Array, Int ); 226 | nok $r.find( 'GET', '/a/' ), 227 | q{Fail to find '/#(Array)/'}; 228 | 229 | nok $r.find( 'GET', '/a/a' ), 230 | q{Fail to find '/#(Array)/a'}; 231 | is $r.find( 'GET', '/a/1' ), 1, 232 | q{Find '/#(Array)/1'}; 233 | 234 | nok $r.find( 'GET', '/a/a/' ), 235 | q{Fail to find '/#(Array)/a/'}; 236 | nok $r.find( 'GET', '/a/1/' ), 237 | q{Fail to find '/#(Array)/1/'}; 238 | 239 | nok $r.find( 'GET', '/a/a/a' ), 240 | q{Fail to find '/#(Array)/a/a'}; 241 | nok $r.find( 'GET', '/a/a/1' ), 242 | q{Fail to find '/#(Array)/a/1'}; 243 | }, 244 | q{Route '/#(Array)/#(Int)'}; 245 | 246 | subtest sub 247 | { 248 | plan 7; 249 | 250 | my $r = App::Prancer::Core.new; 251 | 252 | $r.add( 'GET', 1, Array, Str ); 253 | nok $r.find( 'GET', '/a/' ), 254 | q{Fail to find '/#(Array)/'}; 255 | 256 | is $r.find( 'GET', '/a/a' ), 1, 257 | q{Find '/#(Array)/a'}; 258 | is $r.find( 'GET', '/a/1' ), 1, 259 | q{Find '/#(Array)/1'}; 260 | 261 | nok $r.find( 'GET', '/a/a/' ), 262 | q{Fail to find '/#(Array)/a/'}; 263 | nok $r.find( 'GET', '/a/1/' ), 264 | q{Fail to find '/#(Array)/1/'}; 265 | 266 | nok $r.find( 'GET', '/a/a/a' ), 267 | q{Fail to find '/#(Array)/a/a'}; 268 | nok $r.find( 'GET', '/a/a/1' ), 269 | q{Fail to find '/#(Array)/a/1'}; 270 | }, 271 | q{Route '/#(Array)/#(Str)'}; 272 | 273 | # ( Array, Array ) is illegal, skipping. 274 | 275 | }, 276 | q{Two route elements, start with '/#(Array)'}; 277 | ) 278 | }, 279 | q{Two route elements}; 280 | 281 | subtest sub 282 | { 283 | subtest sub 284 | { 285 | plan 8; 286 | 287 | my $r = App::Prancer::Core.new; 288 | 289 | $r.add( 'GET', 1, Array ); 290 | $r.add( 'GET', 2, '/a/b/c/d' ); 291 | 292 | is $r.find( 'GET', '/a' ), 1, q{Find '/a'}; 293 | is $r.find( 'GET', '/a/b' ), 1, q{Find '/a/b'}; 294 | is $r.find( 'GET', '/a/b/c' ), 1, q{Find '/a/b/c'}; 295 | is $r.find( 'GET', '/a/b/c/d' ), 2, q{Find '/a/b/c/d'}; 296 | 297 | nok $r.find( 'GET', '/a/' ), q{Fail to find '/a/'}; 298 | nok $r.find( 'GET', '/a/b/' ), q{Fail to find '/a/b/'}; 299 | nok $r.find( 'GET', '/a/b/c/' ), q{Fail to find '/a/b/c/'}; 300 | nok $r.find( 'GET', '/a/b/c/d/' ), q{Fail to find '/a/b/c/d/'}; 301 | }, 302 | q{Just literal}; 303 | 304 | subtest sub 305 | { 306 | plan 8; 307 | 308 | my $r = App::Prancer::Core.new; 309 | 310 | $r.add( 'GET', 1, Array, '/' ); 311 | $r.add( 'GET', 2, '/a/b/c/d/' ); 312 | 313 | nok $r.find( 'GET', '/a' ), q{Fail to find '/a'}; 314 | nok $r.find( 'GET', '/a/b' ), q{Fail to find '/a/b'}; 315 | nok $r.find( 'GET', '/a/b/c' ), q{Fail to find '/a/b/c'}; 316 | nok $r.find( 'GET', '/a/b/c/d' ), q{Fail to find '/a/b/c/d'}; 317 | 318 | is $r.find( 'GET', '/a/' ), 1, q{Find '/a/'}; 319 | is $r.find( 'GET', '/a/b/' ), 1, q{Find '/a/b/'}; 320 | is $r.find( 'GET', '/a/b/c/' ), 1, q{Find '/a/b/c/'}; 321 | is $r.find( 'GET', '/a/b/c/d/' ), 2, q{Find '/a/b/c/d/'}; 322 | }, 323 | q{Literal with trailing slash}; 324 | }, 325 | q{Literal vs. Array}; 326 | 327 | subtest sub 328 | { 329 | subtest sub 330 | { 331 | plan 8; 332 | 333 | my $r = App::Prancer::Core.new; 334 | 335 | $r.add( 'GET', 1, '/a', Array ); 336 | $r.add( 'GET', 2, '/a/b/c/d' ); 337 | 338 | nok $r.find( 'GET', '/a' ), q{Fail to find '/a'}; 339 | is $r.find( 'GET', '/a/b' ), 1, q{Find '/a/b'}; 340 | is $r.find( 'GET', '/a/b/c' ), 1, q{Find '/a/b/c'}; 341 | is $r.find( 'GET', '/a/b/c/d' ), 2, q{Find '/a/b/c/d'}; 342 | 343 | nok $r.find( 'GET', '/a/' ), q{Fail to find '/a/'}; 344 | nok $r.find( 'GET', '/a/b/' ), q{Fail to find '/a/b/'}; 345 | nok $r.find( 'GET', '/a/b/c/' ), q{Fail to find '/a/b/c/'}; 346 | nok $r.find( 'GET', '/a/b/c/d/' ), q{Fail to find '/a/b/c/d/'}; 347 | }, 348 | q{Array starts with literal}; 349 | }, 350 | q{Literal vs. Array starting with literal}; 351 | ) 352 | 353 | #subtest sub 354 | # { 355 | # plan 29; 356 | # 357 | # is-deeply $r.routes.<GET>, { }, 358 | # q{Null hypothesis}; 359 | # 360 | # ok $r.add( 'GET', 1, '/' ), q{Add '/'}; 361 | # 362 | # is-deeply $r.routes.<GET>, 363 | # { '/' => 364 | # { '' => 1 } }, 365 | # q{Inserted '/'}; 366 | # 367 | # ok $r.add( 'GET', 2, '/', 'a' ), q{Add '/a'}; 368 | # 369 | # is-deeply $r.routes.<GET>, 370 | # { '/' => 371 | # { '' => 1, 372 | # 'a' => { '' => 2 } } }, 373 | # q{Inserted '/a'}; 374 | # 375 | # ok $r.add( 'GET', 100, '/', Str ), q{Add '/#(Str)'}; 376 | # 377 | # is-deeply $r.routes.<GET>, 378 | # { '/' => 379 | # { '' => 1, 380 | # 'a' => { '' => 2 }, 381 | # '#(Str)' => { '' => 100 } } }, 382 | # q{Inserted '/#(Str)'}; 383 | # 384 | # ok $r.add( 'GET', 1000, '/', Int ), q{Add '/#(Int)'}; 385 | # 386 | # is-deeply $r.routes.<GET>, 387 | # { '/' => 388 | # { '' => 1, 389 | # 'a' => { '' => 2 }, 390 | # '#(Str)' => { '' => 100 }, 391 | # '#(Int)' => { '' => 1000 } } }, 392 | # q{Inserted '/1'}; 393 | # 394 | # ok $r.add( 'GET', 10000, '/', Array ), q{Add '/#(Array)'}; 395 | # 396 | # is-deeply $r.routes.<GET>, 397 | # { '/' => 398 | # { '' => 1, 399 | # 'a' => { '' => 2 }, 400 | # '#(Str)' => { '' => 100 }, 401 | # '#(Int)' => { '' => 1000 }, 402 | # '#(Array)' => { '' => 10000 } } }, 403 | # q{Inserted '/*'}; 404 | # 405 | # ok $r.add( 'GET', 4, '/', 'b' ), q{Add '/b'}; 406 | # 407 | # is-deeply $r.routes.<GET>, 408 | # { '/' => 409 | # { '' => 1, 410 | # 'a' => { '' => 2 }, 411 | # '#(Str)' => { '' => 100 }, 412 | # '#(Int)' => { '' => 1000 }, 413 | # '#(Array)' => { '' => 10000 }, 414 | # 'b' => { '' => 4 } } }, 415 | # q{Inserted '/b'}; 416 | # 417 | # ok $r.add( 'GET', 5, '/', 'c', '/' ), q{Add '/c/'}; 418 | # 419 | # is-deeply $r.routes.<GET>, 420 | # { '/' => 421 | # { '' => 1, 422 | # 'a' => { '' => 2 }, 423 | # '#(Str)' => { '' => 100 }, 424 | # '#(Int)' => { '' => 1000 }, 425 | # '#(Array)' => { '' => 10000 }, 426 | # 'b' => { '' => 4 }, 427 | # 'c' => { '/' => { '' => 5 } } } }, 428 | # q{Inserted '/c/'}; 429 | # 430 | # ok $r.add( 'GET', 101, '/', Str, '/' ), q{Add '/#(Str)/'}; 431 | # 432 | # is-deeply $r.routes.<GET>, 433 | # { '/' => 434 | # { '' => 1, 435 | # 'a' => { '' => 2 }, 436 | # '#(Str)' => { '' => 100, 437 | # '/' => { '' => 101 } }, 438 | # '#(Int)' => { '' => 1000 }, 439 | # '#(Array)' => { '' => 10000 }, 440 | # 'b' => { '' => 4 }, 441 | # 'c' => { '/' => { '' => 5 } } } }, 442 | # q{Inserted '/*/'}; 443 | # 444 | # ok $r.add( 'GET', 1001, '/', Int, '/' ), q{Add '/#(Int)/'}; 445 | # 446 | # is-deeply $r.routes.<GET>, 447 | # { '/' => 448 | # { '' => 1, 449 | # 'a' => { '' => 2 }, 450 | # '#(Str)' => { '' => 100, 451 | # '/' => { '' => 101 } }, 452 | # '#(Int)' => { '' => 1000, 453 | # '/' => { '' => 1001 } }, 454 | # '#(Array)' => { '' => 10000 }, 455 | # 'b' => { '' => 4 }, 456 | # 'c' => { '/' => { '' => 5 } } } }, 457 | # q{Inserted '/1/'}; 458 | # 459 | # ok $r.add( 'GET', 7, '/', 'd', '/', 'e' ), q{Add '/d/e'}; 460 | # 461 | # is-deeply $r.routes.<GET>, 462 | # { '/' => 463 | # { '' => 1, 464 | # 'a' => { '' => 2 }, 465 | # '#(Str)' => { '' => 100, 466 | # '/' => { '' => 101 } }, 467 | # '#(Int)' => { '' => 1000, 468 | # '/' => { '' => 1001 } }, 469 | # '#(Array)' => { '' => 10000 }, 470 | # 'b' => { '' => 4 }, 471 | # 'c' => { '/' => { '' => 5 } }, 472 | # 'd' => { '/' => { 'e' => { '' => 7 } } } } }, 473 | # q{Inserted '/d/e'}; 474 | # 475 | # ok $r.add( 'GET', 102, '/', Str, '/', 'f' ), q{Add '/#(Str)/f'}; 476 | # 477 | # is-deeply $r.routes.<GET>, 478 | # { '/' => 479 | # { '' => 1, 480 | # 'a' => { '' => 2 }, 481 | # '#(Str)' => { '' => 100, 482 | # '/' => { '' => 101, 483 | # 'f' => { '' => 102 } } }, 484 | # '#(Int)' => { '' => 1000, 485 | # '/' => { '' => 1001 } }, 486 | # '#(Array)' => { '' => 10000 }, 487 | # 'b' => { '' => 4 }, 488 | # 'c' => { '/' => { '' => 5 } }, 489 | # 'd' => { '/' => { 'e' => { '' => 7 } } } } }, 490 | # q{Inserted '/*/f'}; 491 | # 492 | # ok $r.add( 'GET', 1002, '/', Int, '/', 'f' ), q{Add '/#(Int)/f'}; 493 | # 494 | # is-deeply $r.routes.<GET>, 495 | # { '/' => 496 | # { '' => 1, 497 | # 'a' => { '' => 2 }, 498 | # '#(Str)' => { '' => 100, 499 | # '/' => { '' => 101, 500 | # 'f' => { '' => 102 } } }, 501 | # '#(Int)' => { '' => 1000, 502 | # '/' => { '' => 1001, 503 | # 'f' => { '' => 1002 } } }, 504 | # '#(Array)' => { '' => 10000 }, 505 | # 'b' => { '' => 4 }, 506 | # 'c' => { '/' => { '' => 5 } }, 507 | # 'd' => { '/' => { 'e' => { '' => 7 } } } } }, 508 | # q{Inserted '/*/f'}; 509 | # 510 | # ok $r.add( 'GET', 103, '/', 'g', '/', Str ), q{Add '/g/#(Str)'}; 511 | # 512 | # is-deeply $r.routes.<GET>, 513 | # { '/' => 514 | # { '' => 1, 515 | # 'a' => { '' => 2 }, 516 | # '#(Str)' => { '' => 100, 517 | # '/' => { '' => 101, 518 | # 'f' => { '' => 102 } } }, 519 | # '#(Int)' => { '' => 1000, 520 | # '/' => { '' => 1001, 521 | # 'f' => { '' => 1002 } } }, 522 | # '#(Array)' => { '' => 10000 }, 523 | # 'b' => { '' => 4 }, 524 | # 'c' => { '/' => { '' => 5 } }, 525 | # 'd' => { '/' => { 'e' => { '' => 7 } } }, 526 | # 'g' => { '/' => { '#(Str)' => { '' => 103 } } } } }, 527 | # q{Inserted '/g/*'}; 528 | # 529 | # ok $r.add( 'GET', 104, '/', Str, '/', Str ), q{Add '/#(Str)/#(Str)'}; 530 | # 531 | # is-deeply $r.routes.<GET>, 532 | # { '/' => 533 | # { '' => 1, 534 | # 'a' => { '' => 2 }, 535 | # '#(Str)' => { '' => 100, 536 | # '/' => { '' => 101, 537 | # 'f' => { '' => 102 }, 538 | # '#(Str)' => { '' => 104 } } }, 539 | # '#(Int)' => { '' => 1000, 540 | # '/' => { '' => 1001, 541 | # 'f' => { '' => 1002 } } }, 542 | # '#(Array)' => { '' => 10000 }, 543 | # 'b' => { '' => 4 }, 544 | # 'c' => { '/' => { '' => 5 } }, 545 | # 'd' => { '/' => { 'e' => { '' => 7 } } }, 546 | # 'g' => { '/' => { '#(Str)' => { '' => 103 } } } } }, 547 | # q{Inserted '/#(Str)/#(Str)'}; 548 | # }, 549 | # q{Inserted shortest routes first}; 550 | 551 | done-testing; 552 | -------------------------------------------------------------------------------- /t/012-core-find-scalar.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Test; 3 | use App::Prancer::Core; 4 | 5 | plan 7; 6 | 7 | # 8 | # Array tests are in the next file, this one's getting too long in the tooth. 9 | # 10 | subtest sub 11 | { 12 | plan 7; 13 | 14 | my $r = App::Prancer::Core.new; 15 | 16 | nok $r.find( 'GET', '/' ), q{Fail to find '/'}; 17 | 18 | nok $r.find( 'GET', '/a' ), q{Fail to find '/a'}; 19 | nok $r.find( 'GET', '/1' ), q{Fail to find '/1'}; 20 | 21 | nok $r.find( 'GET', '/a/' ), q{Fail to find '/a/'}; 22 | nok $r.find( 'GET', '/1/' ), q{Fail to find '/1/'}; 23 | 24 | nok $r.find( 'GET', '/a/a' ), q{Fail to find '/a/a'}; 25 | nok $r.find( 'GET', '/a/1' ), q{Fail to find '/a/1'}; 26 | }, 27 | q{No routes}; 28 | 29 | subtest sub 30 | { 31 | plan 7; 32 | 33 | my $r = App::Prancer::Core.new; 34 | 35 | $r.add( 'GET', 1, '/' ); 36 | is $r.find( 'GET', '/' ), 1, q{Finds '/'}; 37 | 38 | nok $r.find( 'GET', '/a' ), q{Fail to find '/a'}; 39 | nok $r.find( 'GET', '/1' ), q{Fail to find '/1'}; 40 | 41 | nok $r.find( 'GET', '/a/' ), q{Fail to find '/a/'}; 42 | nok $r.find( 'GET', '/1/' ), q{Fail to find '/1/'}; 43 | 44 | nok $r.find( 'GET', '/a/a' ), q{Fail to find '/a/a'}; 45 | nok $r.find( 'GET', '/a/1' ), q{Fail to find '/a/1'}; 46 | }, 47 | q{Default route}; 48 | 49 | subtest sub 50 | { 51 | subtest sub 52 | { 53 | plan 7; 54 | 55 | my $r = App::Prancer::Core.new; 56 | 57 | $r.add( 'GET', 1, '/a' ); 58 | nok $r.find( 'GET', '/' ), q{Fail to find '/'}; 59 | 60 | is $r.find( 'GET', '/a' ), 1, q{Find '/a'}; 61 | nok $r.find( 'GET', '/1' ), q{Fail to find '/1'}; 62 | 63 | nok $r.find( 'GET', '/a/' ), q{Fail to find '/a/'}; 64 | nok $r.find( 'GET', '/1/' ), q{Fail to find '/1/'}; 65 | 66 | nok $r.find( 'GET', '/a/a' ), q{Fail to find '/a/a'}; 67 | nok $r.find( 'GET', '/a/1' ), q{Fail to find '/a/1'}; 68 | }, 69 | q{Route '/a'}; 70 | 71 | subtest sub 72 | { 73 | plan 7; 74 | 75 | my $r = App::Prancer::Core.new; 76 | 77 | $r.add( 'GET', 1, '/1' ); 78 | nok $r.find( 'GET', '/' ), q{Fail to find '/'}; 79 | 80 | nok $r.find( 'GET', '/a' ), q{Fail to find '/a'}; 81 | is $r.find( 'GET', '/1' ), 1, q{Find '/1'}; 82 | 83 | nok $r.find( 'GET', '/a/' ), q{Fail to find '/a/'}; 84 | nok $r.find( 'GET', '/1/' ), q{Fail to find '/1/'}; 85 | 86 | nok $r.find( 'GET', '/a/a' ), q{Fail to find '/a/a'}; 87 | nok $r.find( 'GET', '/a/1' ), q{Fail to find '/a/1'}; 88 | }, 89 | q{Route '/1'}; 90 | 91 | subtest sub 92 | { 93 | plan 7; 94 | 95 | my $r = App::Prancer::Core.new; 96 | 97 | $r.add( 'GET', 1, Int ); 98 | nok $r.find( 'GET', '/' ), q{Fail to find '/'}; 99 | 100 | nok $r.find( 'GET', '/a' ), q{Fail to find '/a'}; 101 | is $r.find( 'GET', '/1' ), 1, q{Find '/1'}; 102 | 103 | nok $r.find( 'GET', '/a/' ), q{Fail to find '/a/'}; 104 | nok $r.find( 'GET', '/1/' ), q{Fail to find '/1/'}; 105 | 106 | nok $r.find( 'GET', '/a/a' ), q{Fail to find '/a/a'}; 107 | nok $r.find( 'GET', '/a/1' ), q{Fail to find '/a/1'}; 108 | }, 109 | q{Route '/#(Int)'}; 110 | 111 | subtest sub 112 | { 113 | plan 7; 114 | 115 | my $r = App::Prancer::Core.new; 116 | 117 | $r.add( 'GET', 1, Str ); 118 | nok $r.find( 'GET', '/' ), q{Fail to find '/'}; 119 | 120 | is $r.find( 'GET', '/a' ), 1, q{Find '/a'}; 121 | is $r.find( 'GET', '/1' ), 1, q{Find '/1'}; 122 | 123 | nok $r.find( 'GET', '/a/' ), q{Fail to find '/a/'}; 124 | nok $r.find( 'GET', '/1/' ), q{Fail to find '/1/'}; 125 | 126 | nok $r.find( 'GET', '/a/a' ), q{Fail to find '/a/a'}; 127 | nok $r.find( 'GET', '/a/1' ), q{Fail to find '/a/1'}; 128 | }, 129 | q{Route '/#(Str)'}; 130 | }, 131 | q{Single route element}; 132 | 133 | subtest sub 134 | { 135 | subtest sub 136 | { 137 | plan 7; 138 | 139 | my $r = App::Prancer::Core.new; 140 | 141 | $r.add( 'GET', 1, '/a/' ); 142 | nok $r.find( 'GET', '/' ), q{Fail to find '/'}; 143 | 144 | nok $r.find( 'GET', '/a' ), q{Fail to find '/a'}; 145 | nok $r.find( 'GET', '/1' ), q{Fail to find '/1'}; 146 | 147 | is $r.find( 'GET', '/a/' ), 1, q{Find '/a/'}; 148 | nok $r.find( 'GET', '/1/' ), q{Fail to find '/1/'}; 149 | 150 | nok $r.find( 'GET', '/a/a' ), q{Fail to find '/a/a'}; 151 | nok $r.find( 'GET', '/a/1' ), q{Fail to find '/a/1'}; 152 | }, 153 | q{Route '/a/'}; 154 | 155 | subtest sub 156 | { 157 | plan 7; 158 | 159 | my $r = App::Prancer::Core.new; 160 | 161 | $r.add( 'GET', 1, '/1/' ); 162 | nok $r.find( 'GET', '/' ), q{Fail to find '/'}; 163 | 164 | nok $r.find( 'GET', '/a' ), q{Fail to find '/a'}; 165 | nok $r.find( 'GET', '/1' ), q{Fail to find '/1'}; 166 | 167 | nok $r.find( 'GET', '/a/' ), q{Fail to find '/a/'}; 168 | is $r.find( 'GET', '/1/' ), 1, q{Find '/1/'}; 169 | 170 | nok $r.find( 'GET', '/a/a' ), q{Fail to find '/a/a'}; 171 | nok $r.find( 'GET', '/a/1' ), q{Fail to find '/a/1'}; 172 | }, 173 | q{Route '/1/'}; 174 | 175 | subtest sub 176 | { 177 | plan 7; 178 | 179 | my $r = App::Prancer::Core.new; 180 | 181 | $r.add( 'GET', 1, Int, '/' ); 182 | nok $r.find( 'GET', '/' ), q{Fail to find '/'}; 183 | 184 | nok $r.find( 'GET', '/a' ), q{Fail to find '/a'}; 185 | nok $r.find( 'GET', '/1' ), q{Fail to find '/1'}; 186 | 187 | nok $r.find( 'GET', '/a/' ), q{Fail to find '/a/'}; 188 | is $r.find( 'GET', '/1/' ), 1, q{Find '/1/'}; 189 | 190 | nok $r.find( 'GET', '/a/a' ), q{Fail to find '/a/a'}; 191 | nok $r.find( 'GET', '/a/1' ), q{Fail to find '/a/1'}; 192 | }, 193 | q{Route '/#(Int)/'}; 194 | 195 | subtest sub 196 | { 197 | plan 7; 198 | 199 | my $r = App::Prancer::Core.new; 200 | 201 | $r.add( 'GET', 1, Str, '/' ); 202 | nok $r.find( 'GET', '/' ), q{Fail to find '/'}; 203 | 204 | nok $r.find( 'GET', '/a' ), q{Fail to find '/a'}; 205 | nok $r.find( 'GET', '/1' ), q{Fail to find '/1'}; 206 | 207 | is $r.find( 'GET', '/a/' ), 1, q{Find '/a/'}; 208 | is $r.find( 'GET', '/1/' ), 1, q{Find '/1/'}; 209 | 210 | nok $r.find( 'GET', '/a/a' ), q{Fail to find '/a/a'}; 211 | nok $r.find( 'GET', '/a/1' ), q{Fail to find '/a/1'}; 212 | }, 213 | q{Route '/#(Str)/'}; 214 | }, 215 | q{Single route element with final slash}; 216 | 217 | subtest sub 218 | { 219 | subtest sub 220 | { 221 | subtest sub 222 | { 223 | plan 7; 224 | 225 | my $r = App::Prancer::Core.new; 226 | 227 | $r.add( 'GET', 1, '/a/a' ); 228 | nok $r.find( 'GET', '/a/' ), 229 | q{Fail to find '/a/'}; 230 | 231 | is $r.find( 'GET', '/a/a' ), 1, 232 | q{Find '/a/a'}; 233 | nok $r.find( 'GET', '/a/1' ), 234 | q{Fail to find '/a/1'}; 235 | 236 | nok $r.find( 'GET', '/a/a/' ), 237 | q{Fail to find '/a/a/'}; 238 | nok $r.find( 'GET', '/a/1/' ), 239 | q{Fail to find '/a/1/'}; 240 | 241 | nok $r.find( 'GET', '/a/a/a' ), 242 | q{Fail to find '/a/a/a'}; 243 | nok $r.find( 'GET', '/a/a/1' ), 244 | q{Fail to find '/a/a/1'}; 245 | }, 246 | q{Route '/a/a'}; 247 | 248 | subtest sub 249 | { 250 | plan 7; 251 | 252 | my $r = App::Prancer::Core.new; 253 | 254 | $r.add( 'GET', 1, '/a/1' ); 255 | nok $r.find( 'GET', '/a/' ), 256 | q{Fail to find '/a/'}; 257 | 258 | nok $r.find( 'GET', '/a/a' ), 259 | q{Fail to find '/a/a'}; 260 | is $r.find( 'GET', '/a/1' ), 1, 261 | q{Find '/a/1'}; 262 | 263 | nok $r.find( 'GET', '/a/a/' ), 264 | q{Fail to find '/a/a/'}; 265 | nok $r.find( 'GET', '/a/1/' ), 266 | q{Fail to find '/a/1/'}; 267 | 268 | nok $r.find( 'GET', '/a/a/a' ), 269 | q{Fail to find '/a/a/a'}; 270 | nok $r.find( 'GET', '/a/a/1' ), 271 | q{Fail to find '/a/a/1'}; 272 | }, 273 | q{Route '/a/1'}; 274 | 275 | subtest sub 276 | { 277 | plan 7; 278 | 279 | my $r = App::Prancer::Core.new; 280 | 281 | $r.add( 'GET', 1, '/a', Int ); 282 | nok $r.find( 'GET', '/a/' ), 283 | q{Fail to find '/a/'}; 284 | 285 | nok $r.find( 'GET', '/a/a' ), 286 | q{Fail to find '/a/a'}; 287 | is $r.find( 'GET', '/a/1' ), 1, 288 | q{Find '/a/1'}; 289 | 290 | nok $r.find( 'GET', '/a/a/' ), 291 | q{Fail to find '/a/a/'}; 292 | nok $r.find( 'GET', '/a/1/' ), 293 | q{Fail to find '/a/1/'}; 294 | 295 | nok $r.find( 'GET', '/a/a/a' ), 296 | q{Fail to find '/a/a/a'}; 297 | nok $r.find( 'GET', '/a/a/1' ), 298 | q{Fail to find '/a/a/1'}; 299 | }, 300 | q{Route '/a/#(Int)'}; 301 | 302 | subtest sub 303 | { 304 | plan 7; 305 | 306 | my $r = App::Prancer::Core.new; 307 | 308 | $r.add( 'GET', 1, '/a', Str ); 309 | nok $r.find( 'GET', '/a/' ), 310 | q{Fail to find '/a/'}; 311 | 312 | is $r.find( 'GET', '/a/a' ), 1, 313 | q{Find '/a/a'}; 314 | is $r.find( 'GET', '/a/1' ), 1, 315 | q{Find '/a/1'}; 316 | 317 | nok $r.find( 'GET', '/a/a/' ), 318 | q{Fail to find '/a/a/'}; 319 | nok $r.find( 'GET', '/a/1/' ), 320 | q{Fail to find '/a/1/'}; 321 | 322 | nok $r.find( 'GET', '/a/a/a' ), 323 | q{Fail to find '/a/a/a'}; 324 | nok $r.find( 'GET', '/a/a/1' ), 325 | q{Fail to find '/a/a/1'}; 326 | }, 327 | q{Route '/a/#(Str)'}; 328 | }, 329 | q{Two route elements, start with '/a'}; 330 | 331 | subtest sub 332 | { 333 | subtest sub 334 | { 335 | plan 7; 336 | 337 | my $r = App::Prancer::Core.new; 338 | 339 | $r.add( 'GET', 1, '/1/a' ); 340 | nok $r.find( 'GET', '/1/' ), 341 | q{Fail to find '/1/'}; 342 | 343 | is $r.find( 'GET', '/1/a' ), 1, 344 | q{Find '/1/a'}; 345 | nok $r.find( 'GET', '/1/1' ), 346 | q{Fail to find '/1/1'}; 347 | 348 | nok $r.find( 'GET', '/1/a/' ), 349 | q{Fail to find '/1/a/'}; 350 | nok $r.find( 'GET', '/1/1/' ), 351 | q{Fail to find '/1/1/'}; 352 | 353 | nok $r.find( 'GET', '/1/a/a' ), 354 | q{Fail to find '/1/a/a'}; 355 | nok $r.find( 'GET', '/1/a/1' ), 356 | q{Fail to find '/1/a/1'}; 357 | }, 358 | q{Route '/1/a'}; 359 | 360 | subtest sub 361 | { 362 | plan 7; 363 | 364 | my $r = App::Prancer::Core.new; 365 | 366 | $r.add( 'GET', 1, '/1/1' ); 367 | nok $r.find( 'GET', '/1/' ), 368 | q{Fail to find '/1/'}; 369 | 370 | nok $r.find( 'GET', '/1/a' ), 371 | q{Fail to find '/1/a'}; 372 | is $r.find( 'GET', '/1/1' ), 1, 373 | q{Find '/1/1'}; 374 | 375 | nok $r.find( 'GET', '/1/a/' ), 376 | q{Fail to find '/1/a/'}; 377 | nok $r.find( 'GET', '/1/1/' ), 378 | q{Fail to find '/1/1/'}; 379 | 380 | nok $r.find( 'GET', '/1/a/a' ), 381 | q{Fail to find '/1/a/a'}; 382 | nok $r.find( 'GET', '/1/a/1' ), 383 | q{Fail to find '/1/a/1'}; 384 | }, 385 | q{Route '/1/1'}; 386 | 387 | subtest sub 388 | { 389 | plan 7; 390 | 391 | my $r = App::Prancer::Core.new; 392 | 393 | $r.add( 'GET', 1, '/1', Int ); 394 | nok $r.find( 'GET', '/1/' ), 395 | q{Fail to find '/1/'}; 396 | 397 | nok $r.find( 'GET', '/1/a' ), 398 | q{Fail to find '/1/a'}; 399 | is $r.find( 'GET', '/1/1' ), 1, 400 | q{Find '/1/1'}; 401 | 402 | nok $r.find( 'GET', '/1/a/' ), 403 | q{Fail to find '/1/a/'}; 404 | nok $r.find( 'GET', '/1/1/' ), 405 | q{Fail to find '/1/1/'}; 406 | 407 | nok $r.find( 'GET', '/1/a/a' ), 408 | q{Fail to find '/1/a/a'}; 409 | nok $r.find( 'GET', '/1/a/1' ), 410 | q{Fail to find '/1/a/1'}; 411 | }, 412 | q{Route '/1/#(Int)'}; 413 | 414 | subtest sub 415 | { 416 | plan 7; 417 | 418 | my $r = App::Prancer::Core.new; 419 | 420 | $r.add( 'GET', 1, '/1', Str ); 421 | nok $r.find( 'GET', '/1/' ), 422 | q{Fail to find '/1/'}; 423 | 424 | is $r.find( 'GET', '/1/a' ), 1, 425 | q{Find '/1/a'}; 426 | is $r.find( 'GET', '/1/1' ), 1, 427 | q{Find '/1/1'}; 428 | 429 | nok $r.find( 'GET', '/1/a/' ), 430 | q{Fail to find '/1/a/'}; 431 | nok $r.find( 'GET', '/1/1/' ), 432 | q{Fail to find '/1/1/'}; 433 | 434 | nok $r.find( 'GET', '/1/a/a' ), 435 | q{Fail to find '/1/a/a'}; 436 | nok $r.find( 'GET', '/1/a/1' ), 437 | q{Fail to find '/1/a/1'}; 438 | }, 439 | q{Route '/1/#(Str)'}; 440 | }, 441 | q{Two route elements, start with '/1'}; 442 | 443 | subtest sub 444 | { 445 | subtest sub 446 | { 447 | plan 7; 448 | 449 | my $r = App::Prancer::Core.new; 450 | 451 | $r.add( 'GET', 1, '/#(Int)/a' ); 452 | nok $r.find( 'GET', '/1/' ), 453 | q{Fail to find '/#(Int)/'}; 454 | 455 | is $r.find( 'GET', '/1/a' ), 1, 456 | q{Find '/#(Int)/a'}; 457 | nok $r.find( 'GET', '/1/1' ), 458 | q{Fail to find '/#(Int)/1'}; 459 | 460 | nok $r.find( 'GET', '/1/a/' ), 461 | q{Fail to find '/#(Int)/a/'}; 462 | nok $r.find( 'GET', '/1/1/' ), 463 | q{Fail to find '/#(Int)/1/'}; 464 | 465 | nok $r.find( 'GET', '/1/a/a' ), 466 | q{Fail to find '/#(Int)/a/a'}; 467 | nok $r.find( 'GET', '/1/a/1' ), 468 | q{Fail to find '/#(Int)/a/1'}; 469 | }, 470 | q{Route '/#(Int)/a'}; 471 | 472 | subtest sub 473 | { 474 | plan 7; 475 | 476 | my $r = App::Prancer::Core.new; 477 | 478 | $r.add( 'GET', 1, '/#(Int)/1' ); 479 | nok $r.find( 'GET', '/1/' ), 480 | q{Fail to find '/#(Int)/'}; 481 | 482 | nok $r.find( 'GET', '/1/a' ), 483 | q{Fail to find '/#(Int)/a'}; 484 | is $r.find( 'GET', '/1/1' ), 1, 485 | q{Find '/#(Int)/1'}; 486 | 487 | nok $r.find( 'GET', '/1/a/' ), 488 | q{Fail to find '/#(Int)/a/'}; 489 | nok $r.find( 'GET', '/1/1/' ), 490 | q{Fail to find '/#(Int)/1/'}; 491 | 492 | nok $r.find( 'GET', '/1/a/a' ), 493 | q{Fail to find '/#(Int)/a/a'}; 494 | nok $r.find( 'GET', '/1/a/1' ), 495 | q{Fail to find '/#(Int)/a/1'}; 496 | }, 497 | q{Route '/#(Int)/1'}; 498 | 499 | subtest sub 500 | { 501 | plan 7; 502 | 503 | my $r = App::Prancer::Core.new; 504 | 505 | $r.add( 'GET', 1, '/#(Int)', Int ); 506 | nok $r.find( 'GET', '/1/' ), 507 | q{Fail to find '/#(Int)/'}; 508 | 509 | nok $r.find( 'GET', '/1/a' ), 510 | q{Fail to find '/#(Int)/a'}; 511 | is $r.find( 'GET', '/1/1' ), 1, 512 | q{Find '/#(Int)/1'}; 513 | 514 | nok $r.find( 'GET', '/1/a/' ), 515 | q{Fail to find '/#(Int)/a/'}; 516 | nok $r.find( 'GET', '/1/1/' ), 517 | q{Fail to find '/#(Int)/1/'}; 518 | 519 | nok $r.find( 'GET', '/1/a/a' ), 520 | q{Fail to find '/#(Int)/a/a'}; 521 | nok $r.find( 'GET', '/1/a/1' ), 522 | q{Fail to find '/#(Int)/a/1'}; 523 | }, 524 | q{Route '/#(Int)/#(Int)'}; 525 | 526 | subtest sub 527 | { 528 | plan 7; 529 | 530 | my $r = App::Prancer::Core.new; 531 | 532 | $r.add( 'GET', 1, '/#(Int)', Str ); 533 | nok $r.find( 'GET', '/1/' ), 534 | q{Fail to find '/#(Int)/'}; 535 | 536 | is $r.find( 'GET', '/1/a' ), 1, 537 | q{Find '/#(Int)/a'}; 538 | is $r.find( 'GET', '/1/1' ), 1, 539 | q{Find '/#(Int)/1'}; 540 | 541 | nok $r.find( 'GET', '/1/a/' ), 542 | q{Fail to find '/#(Int)/a/'}; 543 | nok $r.find( 'GET', '/1/1/' ), 544 | q{Fail to find '/#(Int)/1/'}; 545 | 546 | nok $r.find( 'GET', '/1/a/a' ), 547 | q{Fail to find '/#(Int)/a/a'}; 548 | nok $r.find( 'GET', '/1/a/1' ), 549 | q{Fail to find '/#(Int)/a/1'}; 550 | }, 551 | q{Route '/#(Int)/#(Str)'}; 552 | }, 553 | q{Two route elements, start with '/#(Int)'}; 554 | 555 | subtest sub 556 | { 557 | subtest sub 558 | { 559 | plan 7; 560 | 561 | my $r = App::Prancer::Core.new; 562 | 563 | $r.add( 'GET', 1, '/#(Str)/a' ); 564 | nok $r.find( 'GET', '/a/' ), 565 | q{Fail to find '/#(Str)/'}; 566 | 567 | is $r.find( 'GET', '/a/a' ), 1, 568 | q{Find '/#(Str)/a'}; 569 | nok $r.find( 'GET', '/a/1' ), 570 | q{Fail to find '/#(Str)/1'}; 571 | 572 | nok $r.find( 'GET', '/a/a/' ), 573 | q{Fail to find '/#(Str)/a/'}; 574 | nok $r.find( 'GET', '/a/1/' ), 575 | q{Fail to find '/#(Str)/1/'}; 576 | 577 | nok $r.find( 'GET', '/a/a/a' ), 578 | q{Fail to find '/#(Str)/a/a'}; 579 | nok $r.find( 'GET', '/a/a/1' ), 580 | q{Fail to find '/#(Str)/a/1'}; 581 | }, 582 | q{Route '/#(Str)/a'}; 583 | 584 | subtest sub 585 | { 586 | plan 7; 587 | 588 | my $r = App::Prancer::Core.new; 589 | 590 | $r.add( 'GET', 1, '/#(Str)/1' ); 591 | nok $r.find( 'GET', '/a/' ), 592 | q{Fail to find '/#(Str)/'}; 593 | 594 | nok $r.find( 'GET', '/a/a' ), 595 | q{Fail to find '/#(Str)/a'}; 596 | is $r.find( 'GET', '/a/1' ), 1, 597 | q{Find '/#(Str)/1'}; 598 | 599 | nok $r.find( 'GET', '/a/a/' ), 600 | q{Fail to find '/#(Str)/a/'}; 601 | nok $r.find( 'GET', '/a/1/' ), 602 | q{Fail to find '/#(Str)/1/'}; 603 | 604 | nok $r.find( 'GET', '/a/a/a' ), 605 | q{Fail to find '/#(Str)/a/a'}; 606 | nok $r.find( 'GET', '/a/a/1' ), 607 | q{Fail to find '/#(Str)/a/1'}; 608 | }, 609 | q{Route '/#(Str)/1'}; 610 | 611 | subtest sub 612 | { 613 | plan 7; 614 | 615 | my $r = App::Prancer::Core.new; 616 | 617 | $r.add( 'GET', 1, '/#(Str)', Int ); 618 | nok $r.find( 'GET', '/a/' ), 619 | q{Fail to find '/#(Str)/'}; 620 | 621 | nok $r.find( 'GET', '/a/a' ), 622 | q{Fail to find '/#(Str)/a'}; 623 | is $r.find( 'GET', '/a/1' ), 1, 624 | q{Find '/#(Str)/1'}; 625 | 626 | nok $r.find( 'GET', '/a/a/' ), 627 | q{Fail to find '/#(Str)/a/'}; 628 | nok $r.find( 'GET', '/a/1/' ), 629 | q{Fail to find '/#(Str)/1/'}; 630 | 631 | nok $r.find( 'GET', '/a/a/a' ), 632 | q{Fail to find '/#(Str)/a/a'}; 633 | nok $r.find( 'GET', '/a/a/1' ), 634 | q{Fail to find '/#(Str)/a/1'}; 635 | }, 636 | q{Route '/#(Str)/#(Int)'}; 637 | 638 | subtest sub 639 | { 640 | plan 7; 641 | 642 | my $r = App::Prancer::Core.new; 643 | 644 | $r.add( 'GET', 1, '/#(Str)', Str ); 645 | nok $r.find( 'GET', '/a/' ), 646 | q{Fail to find '/#(Str)/'}; 647 | 648 | is $r.find( 'GET', '/a/a' ), 1, 649 | q{Find '/#(Str)/a'}; 650 | is $r.find( 'GET', '/a/1' ), 1, 651 | q{Find '/#(Str)/1'}; 652 | 653 | nok $r.find( 'GET', '/a/a/' ), 654 | q{Fail to find '/#(Str)/a/'}; 655 | nok $r.find( 'GET', '/a/1/' ), 656 | q{Fail to find '/#(Str)/1/'}; 657 | 658 | nok $r.find( 'GET', '/a/a/a' ), 659 | q{Fail to find '/#(Str)/a/a'}; 660 | nok $r.find( 'GET', '/a/a/1' ), 661 | q{Fail to find '/#(Str)/a/1'}; 662 | }, 663 | q{Route '/#(Str)/#(Str)'}; 664 | }, 665 | q{Two route elements, start with '/#(Str)'}; 666 | }, 667 | q{Two route elements}; 668 | 669 | subtest sub 670 | { 671 | plan 2; 672 | 673 | my $r = App::Prancer::Core.new; 674 | 675 | $r.add( 'GET', 1, Int ); 676 | $r.add( 'GET', 2, '/a' ); 677 | 678 | is $r.find( 'GET', '/a' ), 2, q{Find '/a'}; 679 | is $r.find( 'GET', '/1' ), 1, q{Find '/1'}; 680 | }, 681 | q{Fallback to '/#(Int)'}; 682 | 683 | subtest sub 684 | { 685 | plan 3; 686 | 687 | my $r = App::Prancer::Core.new; 688 | 689 | $r.add( 'GET', 1, Str ); 690 | $r.add( 'GET', 2, '/a' ); 691 | 692 | is $r.find( 'GET', '/a' ), 2, q{Find '/a'}; 693 | is $r.find( 'GET', '/b' ), 1, q{Find '/b'}; 694 | is $r.find( 'GET', '/1' ), 1, q{Find '/1'}; 695 | }, 696 | q{Fallback to '/#(Str)'}; 697 | 698 | done-testing; 699 | --------------------------------------------------------------------------------