├── .gitignore ├── Configure ├── META.info ├── Makefile.in ├── README ├── bin ├── basic-demo.pl ├── kopipasta.pl ├── omgblog.pl └── run-nibbler ├── deps.proto ├── doc ├── GRANT-PROPOSAL.pod ├── PLAN ├── Tene-TODO ├── bedrock-principles ├── dispatcher ├── stages └── web-framework-roles ├── drafts ├── Controller │ ├── Comment.pm │ ├── Root.pm │ └── Topic.pm ├── Forest.pm ├── Model │ └── Topic.pm ├── SRes.pm ├── blog-example ├── blog.app ├── hitomi ├── hitomi-example.xml ├── routes.p6 └── squerl-fruits ├── lib ├── Astaire.pm ├── Configure.pm ├── HTML │ └── Entities.pm ├── Hitomi.pm ├── Hitomi │ ├── Attrs.pm │ ├── HTMLParser.pm │ ├── Input.pm │ ├── Interpolation.pm │ ├── Markup.pm │ ├── Output.pm │ ├── Stream.pm │ ├── StreamEventKind.pm │ ├── StringIO.pm │ └── XMLParser.pm ├── LolDispatch.pm ├── Ratel.pm ├── Squerl.pm ├── Tags.pm ├── Test.pm ├── URI │ └── Dispatcher.pm └── Web │ ├── Handler.pm │ ├── Handler │ └── HTTPDaemon.pm │ ├── Nibbler.pm │ ├── Request.pm │ ├── Response.pm │ └── Utils.pm ├── licenses ├── genshi │ └── COPYING ├── hpricot │ └── COPYING └── rack │ └── COPYING ├── smartlinks └── Text-SmartLinks │ ├── Changes │ ├── MANIFEST.SKIP │ ├── META.yml │ ├── Makefile.PL │ ├── README │ ├── blib │ ├── arch │ │ ├── .exists │ │ └── auto │ │ │ └── Text │ │ │ └── SmartLinks │ │ │ └── .exists │ ├── bin │ │ └── .exists │ ├── lib │ │ ├── Text │ │ │ ├── .exists │ │ │ └── SmartLinks.pm │ │ └── auto │ │ │ ├── Text │ │ │ └── SmartLinks │ │ │ │ └── .exists │ │ │ └── share │ │ │ └── dist │ │ │ └── Text-SmartLinks │ │ │ └── smartlinks.js │ ├── man1 │ │ ├── .exists │ │ └── smartlinks.pl.1 │ ├── man3 │ │ ├── .exists │ │ └── Text::SmartLinks.3pm │ └── script │ │ ├── .exists │ │ └── smartlinks.pl │ ├── eg │ └── a │ │ └── t │ │ ├── 01.t │ │ ├── assertions.t │ │ ├── many.t │ │ └── undef.t │ ├── inc │ └── Module │ │ ├── Install.pm │ │ └── Install │ │ ├── Base.pm │ │ ├── Can.pm │ │ ├── Fetch.pm │ │ ├── Makefile.pm │ │ ├── Metadata.pm │ │ ├── Scripts.pm │ │ ├── Share.pm │ │ ├── Win32.pm │ │ └── WriteAll.pm │ ├── lib │ └── Text │ │ └── SmartLinks.pm │ ├── pm_to_blib │ ├── script │ └── smartlinks.pl │ ├── share │ └── smartlinks.js │ └── t │ ├── 01-load.t │ ├── 02-parse.t │ └── 03-process-t-file.t ├── spec ├── Astaire.pod └── Core.pod ├── t ├── hitomi │ ├── 01-xml-parsing.t │ ├── 02-substitution.t │ ├── 03-if.t │ ├── 04-for.t │ ├── 05-input.t │ └── 06-markup.t ├── ratel │ └── 01-basics.t ├── spec │ └── astaire │ │ ├── 01-basics.t │ │ └── hello-world.t ├── squerl │ ├── 01-sqlite-write.t │ └── 02-dataset.t └── uri-dispatcher │ ├── 01-literal.t │ ├── 02-named.t │ └── 03-splat.t ├── talks └── yapc-eu-2009 │ └── talk.pdf └── tutorial ├── make-pdf ├── pdf └── .gitignore ├── src ├── page1.svg ├── page2.svg ├── page3.svg ├── page4.svg ├── page5.svg ├── page6.svg └── page7.svg └── win.pdf /.gitignore: -------------------------------------------------------------------------------- 1 | *.pir 2 | Makefile 3 | -------------------------------------------------------------------------------- /Configure: -------------------------------------------------------------------------------- 1 | #!perl6 2 | use v6; 3 | use Configure; 4 | -------------------------------------------------------------------------------- /META.info: -------------------------------------------------------------------------------- 1 | { 2 | "name" : "Web", 3 | "version" : "*", 4 | "description" : "A Perl 6 web framework", 5 | "depends" : ["HTTP::Daemon", "Perl6::Sqlite"], 6 | "source-url" : "git://github.com/masak/web.git" 7 | } 8 | -------------------------------------------------------------------------------- /Makefile.in: -------------------------------------------------------------------------------- 1 | PERL6= 2 | RAKUDO_DIR= 3 | PERL6LIB=':$(RAKUDO_DIR)' 4 | 5 | SOURCES=lib/Routes.pm lib/Routes/Route.pm \ 6 | lib/Tags.pm lib/Test.pm \ 7 | lib/Web/Nibbler.pm \ 8 | lib/Web/Utils.pm \ 9 | lib/Web/Request.pm lib/Web/Response.pm \ 10 | lib/Web/Handler/HTTPDaemon.pm \ 11 | lib/Astaire.pm lib/Squerl.pm lib/Ratel.pm 12 | 13 | PIRS=$(SOURCES:.pm=.pir) 14 | 15 | all: $(PIRS) 16 | 17 | %.pir: %.pm 18 | env PERL6LIB=$(PERL6LIB) $(PERL6) --target=pir --output=$@ $< 19 | 20 | clean: 21 | rm -f $(PIRS) 22 | 23 | test: all 24 | env PERL6LIB=$(PERL6LIB) prove -e '$(PERL6)' -r --nocolor t/ 25 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | Web.pm is an incubator for several related but independent web application 2 | projects. It's united by one central goal: to bring web application crafting, 3 | just like the rest of Perl 6, up-to-date with current practices that have 4 | proven to work in other languages. 5 | 6 | At the center of this group of projects sits the Web.pm core, a set of 7 | modules that abstract over common tasks related to HTTP requests and responses. 8 | 9 | Here are some other modules currently under the roof of Web.pm: 10 | 11 | Astaire 12 | A Perl 6 port of Ruby's Sinatra. Think of it as abstracting away the 13 | upper parts of the web stack; the part above Web.pm core. With Astaire 14 | you can write a "hello world"-type web application in a few lines 15 | of Perl 6. 16 | 17 | Squerl 18 | A nice implementation-independent SQL interface. Working with 'datasets' 19 | as its fundamental abstraction, Squerl allows you to construct and 20 | manipulate queries in a flexible way. Not really an ORM layer, it's more 21 | of an abstraction of SQL specifics and platform differences. 22 | 23 | Ratel 24 | A no-frills templating module. Write your HTML (or whatever), and inline 25 | Perl 6 code between a '[%' and a '%]'. Ratel will turn your template into 26 | executable Perl 6, which can then be used to generate the HTML. 27 | 28 | Hitomi 29 | A bells-and-whistles templating module. Where Ratel is fast-and-loose, 30 | Hitomi aims for strictness and scalability. A modular system based on 31 | XML SAX streams, it allows for combining (X)HTML and Perl 6 code in the 32 | same template. 33 | 34 | Contact 35 | ======= 36 | 37 | Carl Mäsak 38 | Stephen Weeks 39 | -------------------------------------------------------------------------------- /bin/basic-demo.pl: -------------------------------------------------------------------------------- 1 | use HTTP::Daemon; 2 | use Tags; 3 | 4 | sub request($c) { 5 | my $r = $c.get_request(); 6 | if $r.req_method eq 'GET' { 7 | given $r.url.path { 8 | when '/' { root_dir( $c, $r ); } 9 | when / ^ \/pub\/ $ / { pub_dir( $c, $r ); } 10 | } 11 | } 12 | else { 13 | $c.send_error('RC_FORBIDDEN'); 14 | } 15 | } 16 | 17 | sub root_dir($c, $r) { 18 | $c.send_response: show { 19 | html { 20 | head { 21 | title { "hi dood" } 22 | }; 23 | body { 24 | h1 { 'wtf dood?!?!?!' } 25 | a :href, { 'some stuff' } 26 | } 27 | } 28 | } 29 | } 30 | 31 | sub pub_dir($c, $r) { 32 | $c.send_response: show { 33 | html { 34 | head { 35 | title { "public filezzzzzzzz" } 36 | }; 37 | body { 38 | p { 'hi dood' } 39 | a :href, { 'main page' } 40 | } 41 | } 42 | } 43 | } 44 | 45 | my HTTP::Daemon $d .= new( :host('127.0.0.1'), :port(2080) ); 46 | say "Browse this Perl 6 web server at {$d.url}"; 47 | $d.daemon(); 48 | -------------------------------------------------------------------------------- /bin/kopipasta.pl: -------------------------------------------------------------------------------- 1 | use HTTP::Daemon; 2 | use Tags; 3 | use HTML::Entities; 4 | 5 | my %pastes; 6 | 7 | sub request($c) { 8 | my $r = $c.get_request(); 9 | my $m = $r.req_method(); 10 | given $r.url.path { 11 | when '/' { main_page( $c, $r ); } 12 | when m{^\/paste$} { paste( $c, $r ); } 13 | when m{^\/+$} { show_paste( $c, $r ); } 14 | when * { $c.send_error('RC_NOTFOUND'); } 15 | } 16 | } 17 | 18 | sub main_page($c, $r) { 19 | $c.send_response: show { 20 | html { 21 | head { 22 | title { 'kopipasta' }; 23 | style :type, '#recent { float: right; list-style-type: none;}'; 24 | }; 25 | body { 26 | h1 'Kopipasta is a PASTEBIN site for COPYING and/or PASTING'; 27 | if %pastes { 28 | ul :id, { 29 | p 'Recent pastes'; 30 | for %pastes.kv -> $k, $v { 31 | li a :href("/$k"), $v; 32 | } 33 | } 34 | } 35 | p { outs 'put some text in me'; strong 'I AM HUNGRY FOR TEXT'; } 36 | form :method<POST>, :action</paste>, { 37 | p { 38 | label :for<name>, 'Name: '; input :name<name>, :id<name>; 39 | } 40 | p { 41 | label :for<title>, 'Title: '; input :name<title>, :id<title>; 42 | } 43 | p { 44 | textarea :cols<80>, :rows<20>, :name<content>; 45 | } 46 | input :type<submit>, :name<paste>, :value('PASTE ME') 47 | } 48 | } 49 | } 50 | } 51 | } 52 | 53 | sub show_paste($c, $r) { 54 | my $match = $r.url.path ~~ m{^\/(<digit>+)$}; 55 | my $id = $match[0]; 56 | my %query = fetch_paste($id); 57 | my $name = encode_entities(%query<name> // "Someone"); 58 | my $title = encode_entities(%query<title>); 59 | my $content = %query<content>; 60 | $c.send_response: show { 61 | html { 62 | head { 63 | title "kopipasta \"$title\" by $name" 64 | }; 65 | body { 66 | h1 "$name pasted \"$title\" some time ago"; 67 | $content ?? pre(encode_entities($content)) !! p("wtf dood?!?! No paste here!"); 68 | a :href</>, 'make ur own paste, dood'; 69 | } 70 | } 71 | } 72 | } 73 | 74 | sub paste($c, $r) { 75 | my $id = save_paste($r.query); 76 | 77 | $c.send_status_line(303, 'See Other'); 78 | $c.send_headers(:Location("/$id")); 79 | $c.send_crlf; 80 | $c.close; 81 | } 82 | 83 | sub fetch_paste($id) { 84 | unless defined %pastes{$id} { 85 | %pastes{$id} = eval(open("/tmp/pastes/$id.paste").slurp); 86 | } 87 | return %pastes{$id}; 88 | } 89 | 90 | sub save_paste($q) { # TODO save time, etc 91 | # TODO avoid collisions 92 | my $id = int(rand*1000000); 93 | 94 | %pastes{$id} = $q; 95 | my $f = open("/tmp/pastes/$id.paste", :w); 96 | my $result = $f.say($q.perl); 97 | $f.close(); 98 | $*ERR.say("IO error: $result") unless $result; 99 | return $id; 100 | } 101 | 102 | my HTTP::Daemon $d .= new( :host('0.0.0.0'), :port(2080) ); 103 | say "Browse this Perl 6 web server at http://localhost:2080/"; 104 | $d.daemon(); 105 | -------------------------------------------------------------------------------- /bin/omgblog.pl: -------------------------------------------------------------------------------- 1 | use LolDispatch; 2 | use HTTP::Daemon; 3 | use Tags; 4 | 5 | my $posts-file = '/tmp/blog/posts.perl'; 6 | our @posts; 7 | sub index($request, $match) is http-handler</> { 8 | show { 9 | html { 10 | head { 11 | title { "blog index" } 12 | } 13 | body { 14 | h1 'blog index'; 15 | ul { 16 | for @posts.kv -> $k, $v { 17 | li { 18 | a :href("/post/$k"), $v<subject>; 19 | } 20 | } 21 | } 22 | a :href</post>, "new post"; 23 | } 24 | } 25 | }; 26 | } 27 | 28 | sub format-post($q) { 29 | return show { 30 | h2 $q<subject>; 31 | pre $q<body>; 32 | }; 33 | } 34 | 35 | sub item($request, $match) is http-handler(/^\/post\/(\d+)/) { 36 | my $q = fetch-post($match[0]); 37 | show { 38 | html { 39 | head { 40 | title $q<subject>; 41 | } 42 | body { 43 | h1 { a :href</>, "omgblog" } 44 | outs format-post($q); 45 | } 46 | } 47 | }; 48 | } 49 | 50 | sub post($request, $match) is http-handler(/^\/post\/?$/) { 51 | show { 52 | html { 53 | head { 54 | title 'make a new post'; 55 | } 56 | body { 57 | h1 'omg new post dood'; 58 | form :method<POST>, :action</submit>, { 59 | p { 60 | label :for<subject>, 'Subject: '; 61 | input :name<subject>, :id<subject>; 62 | } 63 | p { 64 | label :for<body>, 'Body: '; 65 | textarea :cols<80>, :rows<20>, :name<body>, :id<body>; 66 | } 67 | input :type<submit>, :name<submit>, :value('POST BLOG'); 68 | } 69 | } 70 | } 71 | }; 72 | } 73 | 74 | sub submit($request, $match) is http-handler(/^\/submit\/?$/) { 75 | my $id = save-post($request.query); 76 | show { 77 | p { outs 'Post number '; a :href("/post/$id"), { $id } }; 78 | }; 79 | } 80 | 81 | sub save-post($q) { 82 | my $id = @posts.elems; 83 | @posts[$id] = $q; 84 | my $fh = open($posts-file, :w); 85 | $fh.say( @posts.perl ); 86 | $fh.close(); 87 | return $id; 88 | } 89 | 90 | sub fetch-post($id) { 91 | @posts[$id]; 92 | } 93 | 94 | sub request($c) { 95 | my $response := dispatch($c.get_request); 96 | $c.send_response: $response // "Error: no content"; 97 | } 98 | 99 | @posts = $posts-file ~~ :f ?? eval(slurp($posts-file)).list !! (); 100 | 101 | my HTTP::Daemon $d .= new( :host('0.0.0.0'), :port(2080) ); 102 | say "Check out http://localhost:2080/"; 103 | $d.daemon(); 104 | -------------------------------------------------------------------------------- /bin/run-nibbler: -------------------------------------------------------------------------------- 1 | #!/usr/local/bin/perl6 2 | use Web::Nibbler; 3 | use Web::Handler::HTTPDaemon; 4 | 5 | my $port = 8888; 6 | say "Try out the Nibbler on http://127.0.0.1:$port/"; 7 | Web::Handler::HTTPDaemon.run( Web::Nibbler.new ); 8 | -------------------------------------------------------------------------------- /deps.proto: -------------------------------------------------------------------------------- 1 | # These are the dependencies needed by Web.pm 2 | http-daemon 3 | perl6-sqlite 4 | -------------------------------------------------------------------------------- /doc/GRANT-PROPOSAL.pod: -------------------------------------------------------------------------------- 1 | =head1 Web.pm – a lightweight web framework for Perl 6 2 | 3 | =over 1 4 | 5 | =item Names: 6 | 7 | Ilya Belikin, Carl Mäsak, Stephen Weeks 8 | 9 | =item Email: 10 | 11 | Ilya Belikin (forihrd@gmail.com), Carl Mäsak (cmasak@gmail.com), 12 | Stephen Weeks (tene@allalone.org) 13 | 14 | =item Amount Requested: 15 | 16 | $3000. 17 | 18 | =over 19 | 20 | =item Ilya: 1320$, for 12h/week. 21 | 22 | =item Carl: 1100$, for 10h/week. 23 | 24 | =item Stephen: 550$, for 5h/week. 25 | 26 | =back 27 | 28 | =back 29 | 30 | =head2 Synopsis 31 | 32 | Two years ago, Juerd proposed the Web.pm module for Perl 6. Meant to 33 | functionally replace Perl 5's CGI.pm, it is a revamping of the 34 | fundamentals in order to better serve today's web development needs. 35 | 36 | Apart from implementing a working web development toolkit, we intend 37 | to integrate templating as a desirable default, make sessions and 38 | sticky form values (as described in Juerd's email) work, and organize 39 | the framework according to the Model-View-Controller (MVC) pattern and 40 | the REST architecture. 41 | 42 | The structure of the Web framework will be modular, and a web 43 | application writer can choose the parts that make sense for the 44 | particular application developed. As the user's application matures, 45 | more high-level modules can be swapped in to combat the increasing 46 | complexity. 47 | 48 | We intend to develop Web.pm in the open, seeking frequent input from 49 | people on #perl6 and #parrot, and from the mailing lists 50 | perl6-compiler, perl6-users and perl6-language. 51 | 52 | =head2 Benefits to the Perl Community 53 | 54 | Having a simple, well thought-out web development toolkit can be an 55 | enormous benefit to Perl 6 and its growing developer community. There 56 | is good opportunity at this time to coordinate an effort to create 57 | such a toolkit. A web toolkit will increase Rakudo visibility, and 58 | bring more people to try Perl 6 programming. 59 | 60 | Applications like November show that it is possible to create a Perl 6 61 | web application today, but that much convenience functionality has to 62 | be reinvented in the web application itself. The fact that a bridge 63 | between Rakudo and Perl 5/CPAN does not exist at this point is an 64 | obstacle, but also an opportunity to sit down and think about the 65 | parts that we want to improve or remake rather than just inherit. 66 | 67 | As the past six months of November clearly show, development of 68 | real-world applications is one of the most effective ways to generate 69 | feedback to the Rakudo development team, and to help focus on bug 70 | fixes and features needed for everyday tasks. 71 | 72 | =head2 Deliverables 73 | 74 | =over 75 | 76 | =item HTTP::Request, HTTP::Response and Web.pm modules that run on the 77 | latest release of Rakudo. 78 | 79 | =item A URI module based on RFC 3986, using Perl 6 grammars. 80 | 81 | =item Web::Tags module for (X)HTML tags generation. 82 | 83 | =item Dispatcher and Routines (with REST support) modules for better 84 | controllers code organization. 85 | 86 | =item A simple Perl6-ish templater as a replacement for HTML::Template. 87 | 88 | =item A slightly more advanced XML-aware templating system, similar to 89 | Python's Genshi. 90 | 91 | =item Three web applications that make use of the Web module. (On the 92 | assumption that having three clients to an API gives enough clues 93 | about the different needs clients might have.) The first web 94 | application will most likely be November, the wiki, and the second 95 | Maya, a blogging engine. The third will be a proof-of-concept pastebin 96 | for Perl 6 code with color coding. 97 | 98 | =item A tutorial clearly showing the strengths of the Web module 99 | framework, why/when it should be used, and how to get started using 100 | it. 101 | 102 | =back 103 | 104 | The modules URI, HTML::Template, and Dispatcher already exist in a 105 | working alpha state within the November repository, and are being used 106 | to run the wiki engine. Ilya has begun developing the blogging engine 107 | Maya. 108 | 109 | Ilya will post weekly about progress in Russian on the perl6.ru blog. 110 | Carl will blog weekly on use.perl.org. Stephen will blog weekly. 111 | 112 | =head2 Project Details 113 | 114 | The following stages can be identified in providing the above deliverables: 115 | 116 | =over 117 | 118 | =item Specifying the basics of a Web framework organized by MVC 119 | pattern and following REST principles. 120 | 121 | =item Creating a minimal Web, HTTP, Template and Routines modules that 122 | can host a minimal "hello world" web application with a simple form, 123 | but following the specification. 124 | 125 | =item Adapting November to run on top of the new Web framework. Much 126 | of the infrastructural web code currently residing in November will 127 | thereby be the responsibility of the framework instead. 128 | 129 | =item Setting up Maya to use the framework as well. Deploying and 130 | start to use it for perl6-blog us soon as possible. 131 | 132 | =item Implementing the framework and applications features possible 133 | within the current limits of Rakudo. 134 | 135 | =item Condensing the above experience into a tutorial. 136 | 137 | =back 138 | 139 | =head2 Inch-stones 140 | 141 | =over 142 | 143 | =item Specifying framework basics: 1 week. 144 | 145 | =item Creating a minimal Web framework: 2 weeks. 146 | 147 | =item Changing November to run on top of the framework: 1 weeks. 148 | 149 | =item Setting up Maya to use the framework: 1 week. 150 | 151 | =item Setting up a proof-of-concept pastebin: 1 week. 152 | 153 | =item Implementing the features possible within the current limits of 154 | Rakudo: 4 weeks. 155 | 156 | =item Condensing the above experience into a tutorial: 1 week. 157 | 158 | =back 159 | 160 | =head2 Project Schedule 161 | 162 | =over 163 | 164 | =item Specifying framework basics: 1 week. 165 | 166 | =item Creating a minimal Web framework: 2 weeks. 167 | 168 | =item Changing November to run on top of the framework: 1 weeks. 169 | 170 | =item Setting up Maya to use the framework: 1 week. 171 | 172 | =item Setting up a third web application: 1 week. 173 | 174 | =item Implementing the features possible within the current limits of 175 | Rakudo: 4 weeks. 176 | 177 | =item Condensing the above experience into a tutorial: 1 week. 178 | 179 | =back 180 | 181 | We can start in February. 182 | 183 | =head2 Bios 184 | 185 | Ilya Belikin has been working with web technologies since 2000, 186 | functioning as an all-round project manager, CSS and HTML coder. A 187 | Perl developer since 2006, he founded a small web-developing company 188 | 2007. He uses Catalyst, TT, and DBIx::Class in his daily work. He is a 189 | productive November committer (280+ commits). He sends Rakudo and 190 | Parrot bug reports. He is one of the authors of perl6.ru. 191 | 192 | Carl Mäsak has been using Perl since 2002, and has been an avid Pugs 193 | participant since 2005. He has committed various tests, documentation 194 | files and the occasional Haskell patch, totalling over 100 commits. He 195 | is a Parrot committer, helping the main Rakudo developers with bug 196 | tickets (over 200 so far), patches and minor features. He is one of 197 | the co-founders of the November project. 198 | 199 | Stephen Weeks has been using Perl since 2004 for web development and 200 | sysadmin tasks. He has been a Parrot core developer since Feb 2008, 201 | implementing many features in Rakudo. 202 | 203 | =head2 OK to publish this proposal? 204 | 205 | Yes. 206 | 207 | =cut 208 | -------------------------------------------------------------------------------- /doc/PLAN: -------------------------------------------------------------------------------- 1 | This plan was drawn up in week 1 of the grant. It was later refined with 2 | more details in week 10 of the grant. 3 | 4 | We have something like three layers here. Here's how I view them: 5 | 6 | Templating MVC Description 7 | ---------------------+------------+-----+---------------------------------- 8 | LAYER ONE (ALEPH) | | | q&d get-out-of-my-way programming 9 | | | | 10 | LAYER TWO (BET) | X | | medium-large projects w/o a db 11 | | | | 12 | LAYER THREE (GIMEL) | X | X | large full-stack projects 13 | ---------------------+------------+-----+---------------------------------- 14 | 15 | == Layer one -- quick and dirty web programming with basically no framework 16 | 17 | This is slated to be the Perl 6 equivalent of programming on top of CGI in Perl 18 | 5. 19 | 20 | Rack will be ported more or less directly over to Perl 6-land. Then, 21 | we'll be able to write very small Perl 6 web applications like this: 22 | 23 | use v6; 24 | use Astaire; 25 | get '/hi' => { 26 | "Hello World!" 27 | }; 28 | 29 | Currently, the things providing inspiration here are these: 30 | 31 | <http://rack.rubyforge.org/> 32 | <http://www.sinatrarb.com/> 33 | 34 | On top of that, the Tags module gives us HTML syntax. It would still be 35 | nice to have static validation also, but the state-of-the-art of Perl 6 36 | self-parsing is not yet ready for something like that. 37 | 38 | I need to think up more examples that do CGI-like stuff; particularly forms 39 | and sticky fields and all that. 40 | 41 | User Authentication will go here too, as soon as wayland gets time to write 42 | about it. 43 | 44 | We'll have a templating system at this layer, which does templating without 45 | any assumptions about HTML or structure. That is, the templating system will 46 | also work in non-HTML contexts. 47 | 48 | == Layer two -- template programming without a full MVC framework 49 | 50 | In this layer, we're already quite a bit above CPAN's HTML::Template. The 51 | templates are all XML-based, but that is only a statement of the internal 52 | processing; both input and output can still be HTML. We're porting Genshi 53 | to Perl 6, and calling the port Hitomi. 54 | 55 | <http://genshi.edgewall.org/wiki/GenshiTutorial> 56 | 57 | While not high-priority, it would be nice to port something like Hpricot, 58 | an HTML document query and manipulation engine, supporting both CSS and 59 | XPath queries. 60 | 61 | <http://wiki.github.com/why/hpricot/hpricot-challenge> 62 | 63 | == Layer three -- a full Rails/Jifty-like MVC framework 64 | 65 | I (masak) am currently going through different MVC frameworks to gain some 66 | experience, and blogging about the progress. 67 | 68 | These points were things I noticed and liked in Jifty. 69 | 70 | * database versions (including DWIMmy upgrades) 71 | * simple declarative built-in dispatcher ('before', 'on', 'after') 72 | * sticky form fields 73 | * form field validation (built-in and custom) 74 | * degrading js/AJAX for everything (including URLs) 75 | * model-side parameter validation 76 | * free autogenerated REST, almost as a side effect 77 | * autogenerated class hierarchy 78 | * continuations (fake ones, but still) 79 | * full stack 80 | -------------------------------------------------------------------------------- /doc/Tene-TODO: -------------------------------------------------------------------------------- 1 | * mysql bindings for Squerl 2 | 3 | * a nopaste which uses the modern Web.pm utilities (Web::Request and 4 | Web::Response), and preferably does syntax highlighting of Perl 6. 5 | 6 | * a LolDispatch updated to modern Web.pm. 7 | -------------------------------------------------------------------------------- /doc/bedrock-principles: -------------------------------------------------------------------------------- 1 | Bedrock principles 2 | ================== 3 | 4 | -- Use pure Perl6, avoid (other) magic. 5 | 6 | -- Provide extremely reasonable defaults for everything. 7 | 8 | -- Make applications within Web.pm reusable and pluggable. 9 | 10 | -- Use MMD dispatching as base for Controller actions organization. 11 | 12 | -- Make chained actions possible. 13 | -------------------------------------------------------------------------------- /doc/dispatcher: -------------------------------------------------------------------------------- 1 | Dispatcher 2 | ========== 3 | Make possibility to use different dispatchers. 4 | 5 | 6 | Grammatic 7 | ---------- 8 | Use grammas inheritance to create DSL for uri to call transfer. 9 | Use {*} and Actions as application structure. 10 | ... 11 | 12 | 13 | MMD-based 14 | --------- 15 | 16 | Simple translator request to call: 17 | 18 | GET /foo/bar?umh=baz 19 | 20 | $app.('GET', 'foo', 'bar', :umh => 'baz') 21 | or 22 | $foo.bar(Request::Method.new('GET'), :tags => 'baz') 23 | 24 | REST, call HTTP-methods on the resource: 25 | 26 | GET /foo/bar?umh=baz 27 | 28 | $resource_foo.GET('bar', :umh('baz')) 29 | 30 | Resource is object, with HTTP-methods: GET, POST, PUT, DELETE. Use multi methods to cover typical resource manipulations by this methods. 31 | 32 | Chains realization: 33 | 34 | GET /company/1/offer 35 | 36 | $res_company.Link(1, 'offer'); 37 | and then 38 | $res_offer.GET('company', Model::Company $company); 39 | 40 | We can use types and/or some args to set chains compatibility. And this give use flexibility to have different chains from the same links: 41 | 42 | GET /company/1/offer 43 | GET /user/23/offer 44 | 45 | Can call GET on the Offer with different args. 46 | 47 | see drafts/{Forest.pm, blog.app} 48 | 49 | 50 | Routes 51 | ------ 52 | One place with rules for dispatchering. 53 | 54 | Use arrays with * as simple pattern for action or resource. 55 | 56 | ['foo', *] 57 | 58 | This is usefull for chain actions schema: 59 | 60 | ['foo', *, 'bar', * ] 61 | 62 | see drafts/Routes.pm 63 | 64 | 65 | Actions as regular Objects 66 | -------------------------- 67 | my $action = @parts.reduce: &dispatcher; 68 | 69 | Use .* to call all begins, then alll executes and then all ends of actions. 70 | 71 | see ./web-framework-roles 72 | ... 73 | -------------------------------------------------------------------------------- /doc/stages: -------------------------------------------------------------------------------- 1 | Stages 2 | ======= 3 | 4 | ruoso suggestions: 5 | 6 | 1) receiving a request 7 | that's the "engine" part 8 | it knows how to be triggered for an event 9 | and generates a "Request" object 10 | I, for one, think that Web.pm should be able to handle the engine part standalone if it has to. 11 | in Catalyst the "Request" object is very HTTP-specific 12 | this is something that can be fixed 13 | you can have a much more generic "Request" role 14 | and have a HTTPRequest role to complement it 15 | this "Request" object is the thing that takes us to the second step 16 | 17 | 2) dispatch 18 | This takes info from $req in order to dispatch 19 | I think the generic request role would provide 20 | has $.uri 21 | has %.params 22 | The mistake in Catalyst in the dispatch part 23 | is to make each dispatch type independent 24 | like it first tries to dispatch "Regex" 25 | if that fails 26 | it tries "Chained" 27 | if thoat fails "Path" 28 | you need a way to provide an unified dispatching 29 | I think the good way of doing it is basically to consider everything "Chained", while support different part matching algorigthms 30 | the third step is actually having no third step 31 | ;) 32 | 33 | and ruoso again: 34 | 35 | 1) the engine code is something external that declares $*request and $*response 36 | where you have generic Request and Response roles 37 | ihrd: there certainly doesn't seem to be a shortage of ideas, at least :) 38 | but also specific Request::HTTP and Response::HTTP 39 | or even 40 | Request::Apache and Response::Apache 41 | 42 | 2) the dispatch code is something that tries to match an action using $*request 43 | takes that action 44 | calls $action.begin 45 | $action.execute 46 | $action.end 47 | and that's all 48 | -------------------------------------------------------------------------------- /doc/web-framework-roles: -------------------------------------------------------------------------------- 1 | # the controller holds information that applies to all actions 2 | # there. The initialization will look in the config file if there is 3 | # a definition to any of the attributes defined in the package. 4 | role Controller {} 5 | 6 | # this is a normal private action 7 | role Action { 8 | has Controller $.controller; 9 | has Str $.private-name; 10 | multi method begin {...} 11 | multi method execute(*@_, *%_) {...} 12 | multi method end {...} 13 | } 14 | 15 | role Action::Private { 16 | has Callable $.begin-closure; 17 | has Callable $.execute-closure; 18 | has Callable $.end-closure; 19 | multi method begin { 20 | $.begin-closure.(self) 21 | if $.begin-closure; 22 | } 23 | multi method execute(*@_, *%_) { 24 | $.execute-closure.(self, |@_, |%_) 25 | if $.execute-closure; 26 | } 27 | multi method end { 28 | $.end-closure.(self) 29 | if $.end-closure; 30 | } 31 | } 32 | 33 | # this is an action that might be part of a chain 34 | role Action::Chained { 35 | has Action::Chained $.parent; 36 | has Regex $.regex; 37 | 38 | has Callable $.begin-closure; 39 | has Callable $.execute-closure; 40 | has Callable $.end-closure; 41 | 42 | multi method begin { 43 | $.parent.*begin 44 | if $.parent; 45 | $.begin-closure.(self) 46 | if $.begin-closure; 47 | } 48 | 49 | multi method execute(*@_, :¢_parent_action_capture, *%_) { 50 | $.parent.*execute(|¢_parent_action_capture) 51 | if $.parent; 52 | $.execute-closure.(self, |@_, |%_) 53 | if $.execute-closure; 54 | } 55 | 56 | multi method end { 57 | $.parent.*end 58 | if $.parent; 59 | $.end-closure.(self) 60 | if $.end-closure; 61 | } 62 | 63 | } 64 | 65 | # this is used to mask out the base-uri for the application 66 | role Action::Root does Action::Chained { 67 | has URI $.base; 68 | method regex { 69 | return / ^ $.base /; 70 | } 71 | } 72 | 73 | # this is an action that is seen as an endpoint 74 | role Action::Public does Action::Chained does Pattern { 75 | has Int $.priority; 76 | } 77 | 78 | # the dispatcher catalogs all actions, and is responsible for 79 | # actually trying to invoke them 80 | role Dispatcher { 81 | has %!actions; 82 | has @!public; 83 | has $.regex; 84 | 85 | method register-action(Action $a) { 86 | fail 'Duplicated action' 87 | if %!actions.exists($a.private-name); 88 | %!actions{$a.private-name} = $a; 89 | if $a ~~ Action::Public { 90 | @!public = (@!public, $a).sort { .priority }; 91 | } 92 | } 93 | 94 | # this method freezes the regexes, combining them into a single 95 | # regular expression that will evaluate the request and return the 96 | # desired action. 97 | method compile { 98 | 99 | my sub buildspec($act) { 100 | if $act.parent { 101 | my $r = buildspec($act.parent); 102 | return / $<actcap> := ( $<_parent_action_capture> := <$r> <$act.regex> ) { make $act } /; 103 | } else { 104 | return / $<actcap> := <$act.regex> { make $act } /; 105 | } 106 | } 107 | 108 | my @subregexes; 109 | 110 | for @!public -> $action { 111 | push @subregexes, buildspec($action); 112 | } 113 | 114 | $.regex = / $<action> := <@subregexes> /; 115 | 116 | } 117 | 118 | method dispatch() { 119 | self.compile unless $.regex; 120 | 121 | if $*request.uri.path ~~ $.regex { 122 | self.run-action($<action><?>, |$<action><actcap>); 123 | } else { 124 | fail 'No action matched'; 125 | } 126 | } 127 | 128 | method run-action($action, *@_, *%_) { 129 | my $errors is context<rw>; 130 | try { 131 | $action.*begin; 132 | $action.*execute(|@_, |%_); 133 | CATCH { 134 | $_.handled = 1; 135 | $errors = $_; 136 | } 137 | } 138 | $action.*end; 139 | CONTROL { 140 | when ControlExceptionDetach { 141 | self.run-action(%!actions{$_.path}, |$_.capture); 142 | } 143 | } 144 | } 145 | 146 | } 147 | 148 | # An application has components and a dispatcher 149 | role Application { 150 | has %.components; 151 | has Dispatcher $.dispatcher handles <register-action dispatch>; 152 | 153 | # this is where the several steps performed by catalyst should 154 | # reside, so application-wide plugins can modify 155 | multi method prepare { ... } 156 | multi method finalize { ... } 157 | 158 | 159 | multi method handle($request? is context = $*request, 160 | $response? is context = $*response) { 161 | my $application is context = self; 162 | self.*prepare; 163 | self.*dispatch; 164 | self.*finalize; 165 | }; 166 | 167 | } 168 | -------------------------------------------------------------------------------- /drafts/Controller/Comment.pm: -------------------------------------------------------------------------------- 1 | class Controller::Comment; 2 | 3 | multi method GET ($id) { 4 | say "Comment by id $id"; 5 | } 6 | 7 | multi method GET (Model::Topic $topic) { 8 | say "Comments for { $topic.WHAT } { $topic.id }"; 9 | } 10 | 11 | multi method GET ($id, Model::Topic $topic) { 12 | say "Comment $id for { $topic.WHAT } { $topic.id }"; 13 | } 14 | 15 | multi method POST () { 16 | say "New comment form"; 17 | } 18 | multi method POST (%data) { 19 | say "Update comment by " ~ %data.perl; 20 | } 21 | 22 | 23 | # vim: ft=perl6 24 | -------------------------------------------------------------------------------- /drafts/Controller/Root.pm: -------------------------------------------------------------------------------- 1 | class Controller::Root; 2 | 3 | method GET () { 4 | say "Root" 5 | } 6 | 7 | # vim: ft=perl6 8 | -------------------------------------------------------------------------------- /drafts/Controller/Topic.pm: -------------------------------------------------------------------------------- 1 | class Controller::Topic; 2 | use Model::Topic; 3 | 4 | multi method GET () { 5 | say "Topics"; 6 | } 7 | 8 | multi method GET ($id) { 9 | say "Topic id: $id"; 10 | } 11 | 12 | multi method POST () { 13 | say "New topic form"; 14 | } 15 | multi method POST (%data) { 16 | say "Update topic by " ~ %data.perl; 17 | } 18 | 19 | method Link ($id, *@rest_chunks) { 20 | my $topic = Model::Topic.new.find($id); 21 | my $rest = @rest_chunks; 22 | 23 | # RAKUDO: multiple return does not work properly [perl #63912] 24 | return ($rest, [$topic]); 25 | } 26 | 27 | # vim: ft=perl6 28 | -------------------------------------------------------------------------------- /drafts/Forest.pm: -------------------------------------------------------------------------------- 1 | class Forest; 2 | 3 | has %.resources; 4 | 5 | multi method handle (@chunks, $method, %data?, @stash?) { 6 | my $res_name; 7 | my @args; 8 | my $action = $method; 9 | @chunks.shift if @chunks[0] eq ''; 10 | given @chunks.elems { 11 | when 1 { 12 | if @chunks[0] ~~ Str { 13 | $res_name = @chunks[0]; 14 | } 15 | } 16 | when 2 { 17 | $res_name = @chunks.shift; 18 | @args = @chunks; 19 | } 20 | when 3..4 { 21 | $res_name = @chunks.shift; 22 | @args = @chunks; 23 | $action = 'Link'; 24 | } 25 | default { 26 | $res_name = 'Root'; 27 | @args = @chunks if @chunks; 28 | } 29 | } 30 | 31 | unless %.resources{$res_name} { 32 | $res_name = 'Controller::' ~ $res_name.capitalize; 33 | use $res_name; 34 | %.resources{$res_name} = "$res_name".new unless $!; 35 | } 36 | 37 | @args.push(@stash) if @stash; 38 | @args.push(\%data) if %data; 39 | 40 | say "$action $res_name " ~ @args.perl; 41 | 42 | # RAKUDO: multiple return does not work properly [perl #63912] 43 | my ($rest, $stash) = %!resources{$res_name}."$action"(| @args); 44 | 45 | # (| @args).perl.say; 46 | 47 | say 'R:' ~ $rest.perl; 48 | say 'S:' ~ $stash.perl; 49 | my @re = $rest.list; 50 | my @st = $stash.list; 51 | 52 | if $action eq 'Link'{ 53 | self.handle(@re, $method, %data, @st); 54 | } 55 | } 56 | 57 | # vim: ft=perl6 58 | -------------------------------------------------------------------------------- /drafts/Model/Topic.pm: -------------------------------------------------------------------------------- 1 | class Model::Topic; # is Forest::Model 2 | has $.id; 3 | has $.title; 4 | has $.body; 5 | 6 | method find ($id) { 7 | $!id = $id; 8 | # find data by id, and fill object 9 | return self; 10 | } 11 | 12 | # vim: ft=perl6 13 | -------------------------------------------------------------------------------- /drafts/SRes.pm: -------------------------------------------------------------------------------- 1 | role Chain { ... } 2 | class Foo { has $foo; } 3 | 4 | class Res { 5 | # RAKUDO: $?CLASS not implemented yet 6 | # has Str $.path = $?CLASS.lc; 7 | # this is not useful now, because we need resource table outside 8 | 9 | multi method GET () { 10 | say "Index"; 11 | } 12 | 13 | multi method GET (Int $id) { 14 | say "Show Res $id"; 15 | say "with tags: " ~ %_<tags> if %_<tags>; 16 | } 17 | 18 | multi method PUT (Int $id) { 19 | say "Form for edit $id"; 20 | } 21 | multi method PUT (Int $id, %data) { 22 | say "Update Res $id by " ~ %data.perl; 23 | } 24 | 25 | multi method POST () { 26 | say "Form for new Res"; 27 | } 28 | multi method POST (%data) { 29 | say "Create Res with " ~ %data.perl; 30 | } 31 | 32 | multi method DELETE (Int $id) { 33 | say "Delete Res $id"; 34 | } 35 | 36 | multi method DELETE { 37 | say "Delete all Reses"; 38 | } 39 | 40 | method Chain ($id, OtherRes $next ) { 41 | use Foo; 42 | my $foo = Foo.new(foo => $id); 43 | return ($rest, $foo); 44 | } 45 | } 46 | 47 | class OtherRes { 48 | multi method GET (Foo $id) { 49 | } 50 | multi method GET ($id) { 51 | } 52 | } 53 | 54 | for Res { 55 | .GET; 56 | .GET(1); 57 | .GET(2, tags => ['foo', 'bar']); # ?tags=foo&tags=bar 58 | .PUT(3); 59 | .PUT(3, {foo => 'bar'}); 60 | .POST; 61 | .POST({foo => 'bar'}); 62 | .DELETE(1); 63 | .DELETE; 64 | my ($method, @args) = 'GET', 1; 65 | ."$method"(| @args); 66 | } 67 | # vim:ft=perl6 68 | -------------------------------------------------------------------------------- /drafts/blog-example: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Viper; 3 | 4 | class User is Viper::Base { 5 | } 6 | 7 | class Post is Viper::Base { 8 | has $user_id is persisted; 9 | } 10 | 11 | class Comment is Viper::Base { 12 | has $user_id is persisted; 13 | } 14 | 15 | my $session = Viper.new( :types[User, Post, Comment], :db('data/') ); 16 | my Post @posts = Post.find($session, :all); 17 | say .name for @posts; 18 | -------------------------------------------------------------------------------- /drafts/blog.app: -------------------------------------------------------------------------------- 1 | use Forest; 2 | 3 | my $f = Forest.new; 4 | 5 | for $f { 6 | .handle([''], 'GET'); 7 | .handle(['topic'], 'GET'); 8 | .handle(['foo'], 'GET'); 9 | .handle(['topic'], 'POST'); 10 | .handle(['topic'], 'POST', {title => 'foo', body => 'text'}); 11 | .handle(['topic', '1'], 'GET'); 12 | .handle(['topic', '2', 'comment'], 'GET'); 13 | .handle(['topic', '3', 'comment', '1'], 'GET'); 14 | } 15 | 16 | # vim: ft=perl6 17 | -------------------------------------------------------------------------------- /drafts/hitomi: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | grammar XML { 4 | regex TOP { ^ <pi>* <xmlcontent>+ {*} $ }; 5 | 6 | token xmlcontent { 7 | | <node> {*} #= node 8 | | <empty> {*} #= empty 9 | | <content> {*} #= content 10 | }; 11 | 12 | rule node { 13 | '<' <name=ident> <attrs> '>' 14 | <xmlcontent>+ 15 | '</' $<name> '>' 16 | {*} 17 | } 18 | 19 | rule pi { '<!' <.ident> <.ident> '>' }; 20 | 21 | rule empty { '<' <name=ident> <attrs> '/>' {*} }; 22 | 23 | token attrs { <attr>* {*} } 24 | rule attr { $<name>=[<.ident>[':'<.ident>]?] '=' '"' $<value>=[<-["]>+] '"' } 25 | 26 | token ident { <+alnum + [\-]>+ } 27 | 28 | regex content { <-[<]>+ {*} } 29 | }; 30 | class XML::Actions { 31 | my $h = -> $/ { 32 | make [~] gather { 33 | for $/.chunks{ 34 | if .key eq '~' { 35 | take .value; 36 | } else { 37 | take .value.ast; 38 | } 39 | } 40 | } 41 | } 42 | method TOP($/) { 43 | $h($/); 44 | } 45 | 46 | method xmlcontent($/, $key) { 47 | $h($/); 48 | } 49 | 50 | method node($/) { 51 | if $<attrs><attr> { 52 | for $<attrs><attr> -> $a { 53 | if $a<name> eq "pe:if" { 54 | make eval(~$a<value>) ?? matching-if($/) !! q[]; 55 | return; 56 | } 57 | elsif $a<name> ~~ /^ 'pe:'/ { 58 | make "Unknown 'pe:' attribute!"; 59 | return; 60 | } 61 | } 62 | } 63 | $h($/); 64 | } 65 | 66 | method empty($/) { 67 | $h($/); 68 | } 69 | 70 | method attrs($/) { 71 | $h($/); 72 | } 73 | method content($/) { 74 | make ~$/; 75 | } 76 | 77 | sub matching-if($/) { 78 | return $/.ast; 79 | } 80 | } 81 | 82 | # RAKUDO: Arguably wrong that this has to be here and not in the class. 83 | # [perl #65238] 84 | sub links() { 85 | return [ 86 | { 87 | :url<http://ihrd.livejournal.com/>, 88 | :title("ihrd's blog"), 89 | :username<ihrd>, 90 | :time(1240904601) 91 | }, 92 | { :url<http://blogs.gurulabs.com/stephen/>, 93 | :title("Tene's blog"), 94 | :username<Tene>, 95 | :time(1240905184), 96 | }, 97 | { :url<http://use.perl.org/~masak/journal/>, 98 | :title("masak's blog"), 99 | :username<masak>, 100 | :time(1240905293), 101 | }, 102 | ]; 103 | } 104 | 105 | 106 | my $xml = $*IN.slurp; 107 | my $result = XML.parse($xml, :action(XML::Actions.new())); 108 | print $result.ast; 109 | 110 | # vim: ft=perl6 111 | -------------------------------------------------------------------------------- /drafts/hitomi-example.xml: -------------------------------------------------------------------------------- 1 | <!DOCTYPE html> 2 | <html xmlns="http://www.w3.org/1999/xhtml" 3 | xmlns:pl="http://github.com/masak/hitomi"> 4 | <head> 5 | <title>Slurp: News 6 | 7 | 8 | 11 | 12 |
    13 |
  1. 14 | ${$link.title} 15 | posted by ${$link.username} at ${strftime('%x %X', $link.time)} 16 |
    2. 17 |
18 | 19 |

Submit new link

20 | 21 | 25 | 26 | 27 | -------------------------------------------------------------------------------- /drafts/routes.p6: -------------------------------------------------------------------------------- 1 | # This draft was inspired by RoR Routes 2 | # see http://guides.rubyonrails.org/routing.html 3 | 4 | use Routes; 5 | 6 | given my $routes = Routes.new { 7 | .connect: ['foo', :action ]; 8 | # the same as: 9 | .add: ['foo', :action ], :conroller('Root'), { %*controller{$:controller}."{$:action}"(@_) } 10 | 11 | .connect: [:controller, :action, *], :slurp; # call controller.action(@_) 12 | } 13 | 14 | use Routes::Resources; 15 | 16 | given my $routes = Routes.new does Routes::Resources { 17 | 18 | .resource: 'company'; # pattern ['company'], call company.METHOD() 19 | .resources: 'company'; # pattern ['company', *], call company.METHOD(| @args) 20 | 21 | .resource: 'company', plural => 'comapnies'; # call comapny.GET() if url '/companies'; 22 | # mb pattern like: [[ 'companies' ], ['company', *]]? 23 | 24 | .resource: 'company', :controller('foo'); # call foo.GET() for GET '/company' 25 | 26 | .resource: 'company', has_one => ['offer', 'account'], has_many => { 27 | .resources: 'member', plural => 'members'; 28 | }; 29 | 30 | .resources-chain: ['company', *, ['offer', 'account']]; 31 | }; 32 | 33 | $routes.dispatch($*request); 34 | 35 | # vim: ft=perl6 36 | -------------------------------------------------------------------------------- /drafts/squerl-fruits: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Squerl; 3 | 4 | my $DB = Squerl.sqlite('example.db'); 5 | 6 | $DB.create_table: 'fruits', 7 | 'id' => 'primary_key', 8 | 'name' => 'String', 9 | 'qty' => 'Int', 10 | ; 11 | 12 | my $fruits = $DB; 13 | 14 | my $i = 0; 15 | for 16 | Z < 50 20 70 3 15 35> -> $name, $qty { 17 | 18 | $fruits.insert($i++, $name, +$qty); 19 | } 20 | 21 | # those ninjas get in anywhere 22 | $fruits.filter('name' => 'ninjas').delete; 23 | 24 | # new shipment of pears 25 | $fruits.filter('name' => 'pears').update('qty' => 40); 26 | 27 | for $fruits.filter(sql_number('qty').gt(35)).llist { 28 | say sprintf 'There are %d %s', .[2], .[1]; 29 | } 30 | -------------------------------------------------------------------------------- /lib/Astaire.pm: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use Web::Request; 4 | use Web::Response; 5 | 6 | class Handler { 7 | has Str $.condition; 8 | has Regex $!condition-regex; 9 | has Block $.code; 10 | has Str $.http_method; 11 | 12 | sub remove-initial-slash($s) { 13 | # RAKUDO: prefix:<~> needed because of [perl #71088] 14 | ~$s.subst(rx[ ^ '/' ], ''); 15 | } 16 | 17 | submethod BUILD(:$!condition, :$!code, :$!http_method) { 18 | my $condition 19 | = remove-initial-slash($.condition)\ 20 | .trans( [< . / * >] 21 | => [< \. \/ (.*) >] ); 22 | $condition = "/^ $condition \$/"; 23 | # RAKUDO: Doing eval here until we get variable interpolation in 24 | # regexes. 25 | $!condition-regex = eval $condition; 26 | } 27 | 28 | method matches($path) { 29 | my %result; 30 | my $clean-path = remove-initial-slash($path); 31 | $clean-path ~~ $!condition-regex; 32 | %result = @($/).map({ ~$_ }); 33 | %result = ?$/; 34 | return %result; 35 | } 36 | } 37 | 38 | class Dispatch { 39 | has Handler @.handlers handles ; 40 | 41 | method dispatch(Web::Request $request) { 42 | my Web::Response $response .= new(); 43 | 44 | for @.handlers -> $candidate { 45 | my %match = $candidate.matches( $request.path_info ); 46 | if %match 47 | && $candidate.http_method eq $request.request_method { 48 | my $code = $candidate.code; 49 | my $body; 50 | if $code.signature.params == 1 51 | && $code.signature.params[0].name eq '@splat' { 52 | $body = $code(:splat(%match)); 53 | } 54 | elsif $code.arity { 55 | $body = $code(|%match); 56 | } 57 | else { 58 | $body = $code(); 59 | } 60 | $response.write($body); 61 | return $response; 62 | } 63 | } 64 | 65 | # Not found 66 | $response.status = 404; 67 | return $response; 68 | } 69 | } 70 | 71 | # Rack-compliant application 72 | class AstaireApp { 73 | has Dispatch $.dispatch is rw; 74 | 75 | method call(Web::Request $request) { 76 | return $.dispatch.dispatch($request); 77 | } 78 | } 79 | 80 | module Astaire { 81 | my Dispatch $dispatch .= new(); 82 | 83 | sub get(Pair $param) is export { 84 | my ($condition, $code) = $param.kv; 85 | _push_to_dispatch( $condition, $code,'GET' ); 86 | }; 87 | 88 | sub post(Pair $param) is export { 89 | my ($condition, $code) = $param.kv; 90 | _push_to_dispatch( $condition, $code,'POST' ); 91 | }; 92 | 93 | sub _push_to_dispatch ($condition, $code, $http_method) { 94 | $dispatch.push( Handler.new(:$condition, :$code, :$http_method) ); 95 | } 96 | 97 | sub application () is export { 98 | my AstaireApp $application .= new(:$dispatch); 99 | return $application; 100 | } 101 | } 102 | -------------------------------------------------------------------------------- /lib/Configure.pm: -------------------------------------------------------------------------------- 1 | # Configure.pm 2 | 3 | .say for 4 | '', 5 | 'Configure.pm is preparing to make your Makefile.', 6 | ''; 7 | 8 | # Determine how this Configure.p6 was invoked, to write the same paths 9 | # and executables into the Makefile variables. The variables are: 10 | # PERL6 how to execute a Perl 6 script 11 | # PERL6LIB initial value of @*INC, where 'use ;' searches 12 | # PERL6BIN directory where executables such as 'prove' reside 13 | # RAKUDO_DIR (deprecated) currently the location of Rakudo's Test.pm 14 | 15 | my $parrot_dir = %*VM; 16 | my $rakudo_dir; 17 | my $perl6; 18 | 19 | regex parrot_in_rakudo { ( .* '/rakudo' ) '/parrot' } 20 | 21 | # There are two possible relationships between the parrot and rakudo 22 | # directories: rakudo/parrot or parrot/languages/rakudo 23 | if $parrot_dir ~~ / / { 24 | # first case, rakudo/parrot for example if installed using new 25 | # 'git clone ...rakudo.git' then 'perl Configure.pl --gen-parrot' 26 | $rakudo_dir = $parrot_dir.subst( / '/parrot' $ /, ''); #' 27 | } 28 | elsif "$parrot_dir/languages/rakudo" ~~ :d { 29 | # second case, parrot/languages/rakudo if installed the old way 30 | $rakudo_dir = "$parrot_dir/languages/rakudo"; 31 | } 32 | else { # anything else 33 | .say for 34 | "Found a PARROT_DIR to be $parrot_dir", 35 | 'but there is no Rakudo nearby. Please contact the proto people.', 36 | ''; 37 | exit(1); 38 | } 39 | if "$rakudo_dir/perl6" ~~ :f or "$rakudo_dir/perl6.exe" ~~ :f { 40 | $perl6 = "$rakudo_dir/perl6"; # the fake executable from pbc_to_exe 41 | } 42 | else { 43 | $perl6 = "$parrot_dir/parrot $rakudo_dir/perl6.pbc"; 44 | } 45 | 46 | say "PERL6 $perl6"; 47 | my $perl6lib = %*ENV ~ '/lib'; 48 | say "PERL6LIB $perl6lib"; 49 | # The perl6-examples/bin directory is a sibling of PERL6LIB 50 | my $perl6bin = $perl6lib.subst( '/lib', '/bin' ); 51 | say "PERL6BIN $perl6bin"; 52 | say "RAKUDO_DIR $rakudo_dir"; 53 | 54 | # Read Makefile.in, edit, write Makefile 55 | my $maketext = slurp( 'Makefile.in' ); 56 | $maketext .= subst( .key, .value ) for 57 | 'Makefile.in' => 'Makefile', 58 | 'To be read' => 'Written', 59 | 'replaces ' => 'defined these', 60 | # Maintainer note: keep the following in sync with pod#VARIABLES below 61 | '' => $perl6, 62 | '' => $perl6lib, 63 | '' => $perl6bin, 64 | '' => $rakudo_dir; 65 | squirt( 'Makefile', $maketext ); 66 | 67 | # Job done. 68 | .say for 69 | '', 70 | q[Makefile is ready. Ready to run 'make'.]; 71 | 72 | 73 | # The opposite of slurp 74 | sub squirt( Str $filename, Str $text ) { 75 | my $handle = open( $filename, :w ) 76 | or die $!; 77 | $handle.print: $text; 78 | $handle.close; 79 | } 80 | 81 | # This Configure.pm can work with the following ways of starting up: 82 | # 1. The explicit way Parrot runs any Parrot Byte Code: 83 | # /my/parrot/parrot /my/rakudo/perl6.pbc Configure.p6 84 | # 2. The Rakudo "Fake Executable" made by pbc_to_exe: 85 | # /my/rakudo/perl6 Configure.p6 86 | # The rest are variations of 1. and 2. to sugar the command line: 87 | # 3. A shell script perl6 for 1: '/my/parrot/parrot /my/rakudo/perl6.pbc $*': 88 | # /my/perl6 Configure.p6 # or 'perl6 Configure.p6' with search path 89 | # 4. A shell alias for 1: perl6='/my/parrot/parrot /my/rakudo/perl6.pbc': 90 | # perl6 Configure.p6 91 | # 5. A symbolic link for 2: 'sudo ln -s /my/rakudo/perl6 /bin': 92 | # perl6 Configure.p6 93 | 94 | # Do you know of another way to execute Perl 6 scripts? Please tell the 95 | # maintainers. 96 | 97 | =begin pod 98 | 99 | =head1 NAME 100 | Makefile.pm - common code for Makefile builder and runner 101 | 102 | =head1 SYNOPSIS 103 | 104 | perl6 Configure.p6 105 | 106 | Where F generally has only these lines: 107 | 108 | # Configure.p6 - installer - see documentation in ../Configure.pm 109 | use v6; BEGIN { @*INC.push( '../..' ); }; use Configure; # proto dir 110 | 111 | =head1 DESCRIPTION 112 | A Perl module often needs a Makefile to specify how to build, test and 113 | install it. A Makefile must make sense to the Unix C utility. 114 | Makefiles must often be adjusted slightly to alter the context in which 115 | they will work. There are various tools to "make Makefiles" and this 116 | F and F combination run purely in Perl 6. 117 | 118 | Configure.p6 resides in the module top level directory. For covenience, 119 | Configure.p6 usually contains only the lines shown in L 120 | above, namely a comment and one line of code to pass execution to 121 | F. Any custom actions to prepare the module can be called 122 | by the default target in Makefile.in. 123 | 124 | Configure.pm reads F from the module top level directory, 125 | replaces certain variables marked like , and writes the updated 126 | text to Makefile in the same directory. Finally it runs the standard 127 | 'make' utility, which builds the first target defined in Makefile. 128 | 129 | =head1 VARIABLES 130 | C will cause the following tokens to be substituted when 131 | creating the new F: 132 | 133 | pathname of Perl 6 (fake)executable 134 | lib/ directory of the installed project 135 | bin/ directory of the installed project 136 | whence Rakudo's Test.pm can be compiled 137 | 138 | =head1 AUTHOR 139 | Martin Berends (mberends on CPAN github #perl6 and @autoexec.demon.nl). 140 | 141 | =end pod 142 | -------------------------------------------------------------------------------- /lib/Hitomi.pm: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use Hitomi::XMLParser; 4 | use Hitomi::Markup; 5 | 6 | class Hitomi::DocType::HTML5 { 7 | } 8 | -------------------------------------------------------------------------------- /lib/Hitomi/Attrs.pm: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | class Hitomi::Attrs { 4 | } 5 | -------------------------------------------------------------------------------- /lib/Hitomi/HTMLParser.pm: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | class Hitomi::HTMLParser { 4 | # RAKUDO: https://trac.parrot.org/parrot/ticket/536 makes the method 5 | # override the global 'list' sub if we call it 'list' 6 | method llist() { 7 | return (); 8 | } 9 | } 10 | -------------------------------------------------------------------------------- /lib/Hitomi/Input.pm: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use Hitomi::Stream; 4 | use Hitomi::XMLParser; 5 | 6 | class ParseError { 7 | } 8 | 9 | sub XML($text) { 10 | return Hitomi::Stream.new(@(Hitomi::XMLParser.new($text))); 11 | } 12 | -------------------------------------------------------------------------------- /lib/Hitomi/Interpolation.pm: -------------------------------------------------------------------------------- 1 | use Hitomi::StreamEventKind; 2 | 3 | grammar Hitomi::Interpolation::Grammar { 4 | regex TOP { ^ * $ } 5 | regex chunk { || } 6 | 7 | regex plain { [ .]+ } 8 | regex expr { '$' [ | ] } 9 | 10 | regex ident { <.alpha> \w* } 11 | regex identifier { <.ident> [ <.apostrophe> <.ident> ]* } 12 | token apostrophe { <[ ' \- ]> } 13 | 14 | regex block { '{' '}' } 15 | regex content { <-[{}]>+ } 16 | } 17 | 18 | # Note: It _is_ possible for the above grammar to fail, even though it's 19 | # probably not very desirable that it can. An example of a failing 20 | # input is '$'. The way to fix this would likely be (1) see what 21 | # Genshi does about broken input, (2) write Hitomi tests to do the 22 | # same, (3) improve the grammar. 23 | 24 | sub interpolate($text, $filepath, $lineno = -1, $offset = 0, 25 | $lookup = 'strict') { 26 | 27 | # TODO: Make it impossible to fail here. See the above note. 28 | return $text 29 | unless Hitomi::Interpolation::Grammar.parse($text); 30 | 31 | return gather for @($ // []) -> $chunk { 32 | my $pos = [$filepath, $lineno, $offset]; 33 | if $chunk -> $plain { 34 | take [Hitomi::StreamEventKind::text, ~$plain, $pos]; 35 | } 36 | elsif $chunk -> $expr { 37 | my $data = $expr ?? $expr !! $expr; 38 | take [Hitomi::StreamEventKind::expr, ~$data, $pos]; 39 | } 40 | } 41 | } 42 | -------------------------------------------------------------------------------- /lib/Hitomi/Markup.pm: -------------------------------------------------------------------------------- 1 | use Hitomi::Stream; 2 | use Hitomi::XMLParser; 3 | use Hitomi::Interpolation; 4 | 5 | class Hitomi::Context { 6 | # I see from the Genshi source that %!vars will eventually be replaced by 7 | # @!frames. This suffices for now. 8 | has %!vars; 9 | 10 | method new(*%nameds, *@pairs) { 11 | my %vars = %nameds; 12 | for @pairs { 13 | %vars{.key} = .value; 14 | } 15 | return self.bless(*, :%vars); 16 | } 17 | 18 | method get($thing is copy) { 19 | if $thing ~~ /^ '$'/ { 20 | $thing .= substr(1); 21 | } 22 | %!vars{$thing}; 23 | } 24 | } 25 | 26 | class Hitomi::Template { 27 | has $!source; 28 | has $!filepath; 29 | has $!filename; 30 | has $!loader; 31 | has $!encoding; 32 | has $!lookup; 33 | has $!allow_exec; 34 | has $!stream; 35 | 36 | submethod BUILD(:$source, :$filepath, :$filename, :$loader, 37 | :$encoding, :$lookup, :$allow_exec) { 38 | 39 | $!source = $source; 40 | $!filepath = $filepath; 41 | $!filename = $filename; 42 | $!loader = $loader; 43 | $!encoding = $encoding; 44 | $!loader = $loader; 45 | $!allow_exec = $allow_exec; 46 | 47 | $!filepath //= $!filename; 48 | 49 | $!stream = self._parse($!source, $!encoding); 50 | } 51 | 52 | method new($source, $filepath?, $filename?, $loader?, 53 | $encoding?, $lookup = 'strict', $allow_exec = True) { 54 | self.bless(*, 55 | :$source, :$filepath, :$filename, :$loader, 56 | :$encoding, :$lookup, :$allow_exec); 57 | } 58 | 59 | method _parse($source, $encoding) { 60 | ... 61 | } 62 | 63 | method generate(*%nameds, *@pairs) { 64 | my $context = Hitomi::Context.new(|%nameds, |@pairs); 65 | return self._flatten($!stream, $context); 66 | } 67 | 68 | method _flatten($stream, $context) { 69 | my @newstream = gather for $stream.llist -> $event { 70 | my ($kind, $data, $pos) = @($event); 71 | if ($kind ~~ Hitomi::StreamEventKind::expr) { 72 | take [Hitomi::StreamEventKind::text, 73 | self._eval($data, $context), 74 | $pos]; 75 | } 76 | else { 77 | take [$kind, $data, $pos]; 78 | } 79 | }; 80 | return Hitomi::Stream.new(@newstream); 81 | } 82 | 83 | method _eval($data, $context) { 84 | # Well, this works for expressions which consist of one variable 85 | # and nothing more. Will expand later. 86 | $context.get($data); 87 | } 88 | } 89 | 90 | class Hitomi::MarkupTemplate is Hitomi::Template { 91 | submethod BUILD(:$!source, :$!filepath, :$!filename, :$!loader, 92 | :$!encoding, :$!lookup, :$!allow_exec) { 93 | } 94 | 95 | method _parse($source is copy, $encoding) { 96 | if $source !~~ Hitomi::Stream { 97 | $source = Hitomi::XMLParser.new($source, $!filename, $encoding); 98 | } 99 | 100 | my @stream; 101 | 102 | for $source.llist -> @event { 103 | my ($kind, $data, $pos) = @event; 104 | 105 | if $kind ~~ Hitomi::StreamEventKind::text { 106 | @stream.push: 107 | interpolate($data, $!filepath, $pos[1], $pos[2], $!lookup); 108 | } 109 | else { 110 | @stream.push( [$kind, $data, $pos] ); 111 | } 112 | } 113 | 114 | return Hitomi::Stream.new(@stream); 115 | } 116 | } 117 | 118 | class Hitomi::Markup { 119 | method new($text) { 120 | return self.bless(*, :$text); 121 | } 122 | } 123 | -------------------------------------------------------------------------------- /lib/Hitomi/Output.pm: -------------------------------------------------------------------------------- 1 | use Hitomi::StreamEventKind; 2 | 3 | sub escape($text, :$quotes = True) { 4 | $text; # TODO 5 | } 6 | 7 | class Hitomi::XMLSerializer { 8 | has @!filters; 9 | 10 | method serialize($stream) { 11 | return join '', [~] gather for $stream.llist { 12 | my ($kind, $data, $pos) = @($_); 13 | if ($kind ~~ Hitomi::StreamEventKind::start 14 | | Hitomi::StreamEventKind::empty) { 15 | my ($tag, $attribs) = @($data); 16 | take '<'; 17 | take $tag; 18 | for @($attribs) -> $attrib { 19 | my ($attr, $value) = @($attrib); 20 | take for ' ', $attr, q[="], escape($value), q["]; 21 | } 22 | take $kind ~~ Hitomi::StreamEventKind::empty ?? '/>' !! '>'; 23 | } 24 | elsif ($kind ~~ Hitomi::StreamEventKind::end) { 25 | take sprintf '', $data; 26 | } 27 | else { # TODO More types 28 | take escape($data, :!quotes); 29 | } 30 | } 31 | } 32 | } 33 | 34 | class Hitomi::XHTMLSerializer is Hitomi::XMLSerializer { 35 | } 36 | 37 | class Hitomi::HTMLSerializer { 38 | } 39 | 40 | class Hitomi::TextSerializer { 41 | } 42 | 43 | sub get_serializer($method, *%_) { 44 | my $class = ( :xml( Hitomi::XMLSerializer), 45 | :xhtml( Hitomi::XHTMLSerializer), 46 | :html( Hitomi::HTMLSerializer), 47 | :text( Hitomi::TextSerializer) ){$method.lc}; 48 | return $class.new(|%_); 49 | } 50 | 51 | -------------------------------------------------------------------------------- /lib/Hitomi/Stream.pm: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Hitomi::StreamEventKind; 3 | use Hitomi::Output; 4 | 5 | class Hitomi::Stream { 6 | has @!events; 7 | has $serializer; 8 | 9 | multi method new(@events, $serializer?) { 10 | return self.new( 11 | :events(@events), 12 | :serializer($serializer // Hitomi::XHTMLSerializer.new()) 13 | ); 14 | } 15 | 16 | # RAKUDO: We shouldn't have to provide this method. It should be handed 17 | # to us by C. 18 | multi method new(*%_) { 19 | return self.bless(self.CREATE(), |%_); 20 | } 21 | 22 | method Str() { 23 | # RAKUDO: A complex set of circumstances may cause the 24 | # array to have been nested one level too deeply at 25 | # this point. Compensating. 26 | @!events = @(@!events[0]) 27 | while @!events.elems == 1 && @!events[0] ~~ Array; 28 | return $serializer.serialize(self); 29 | } 30 | 31 | method llist() { 32 | # RAKUDO: A complex set of circumstances may cause the 33 | # array to have been nested one level too deeply at 34 | # this point. Compensating. 35 | @!events = @(@!events[0]) 36 | while @!events.elems == 1 && @!events[0] ~~ Array; 37 | return @!events; 38 | } 39 | 40 | method render($format, :$doctype) { 41 | return ""; 42 | } 43 | } 44 | -------------------------------------------------------------------------------- /lib/Hitomi/StreamEventKind.pm: -------------------------------------------------------------------------------- 1 | enum Hitomi::StreamEventKind ; 3 | 4 | -------------------------------------------------------------------------------- /lib/Hitomi/StringIO.pm: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | class Hitomi::StringIO { 4 | } 5 | 6 | -------------------------------------------------------------------------------- /lib/Hitomi/XMLParser.pm: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use Hitomi::Stream; 4 | 5 | grammar Hitomi::XMLGrammar { 6 | regex TOP { ^ ? * $ }; 7 | 8 | token xmlcontent { 9 | || 10 | || 11 | }; 12 | 13 | token element { 14 | '<' '/>' 15 | || 16 | '<' '>' 17 | + 18 | ' '>' 19 | } 20 | 21 | token attrs { * } 22 | rule attr { $=[<.ident>[':'<.ident>]?] '=' '"' 23 | $=[<-["]>+] '"' } # ' 24 | token ident { <+alnum + [\-]>+ } 25 | 26 | regex textnode { <-[<]>+ {*} } 27 | 28 | token doctype { ' '>' } 29 | token externalId { 'PUBLIC' } 30 | token pubid { '"' $=[<-["]>+] '"' } 31 | token system { '"' $=[<-["]>+] '"' } 32 | } 33 | 34 | class Hitomi::XMLParser { 35 | has $!text; 36 | 37 | method new($text, $filename?, $encoding?) { 38 | return self.bless(*, :$text); 39 | } 40 | 41 | submethod make-events(Match $m, $text) { 42 | return () unless $m; 43 | my @events; 44 | for @($m // []) -> $d { 45 | push @events, [Hitomi::StreamEventKind::doctype, *, *]; 46 | } 47 | for @($m) -> $part { 48 | if $part -> $e { 49 | my $data = [~$e, 50 | [map {; ~. => convert-entities(~.) }, 51 | $e ?? $e.list !! ()] 52 | ]; 53 | push @events, [Hitomi::StreamEventKind::start, $data, *], 54 | self.make-events($e, $text), 55 | [Hitomi::StreamEventKind::end, ~$e, *]; 56 | } 57 | elsif $part -> $t { 58 | my $line-num = +$text.substr(0, $t.from).comb(/\n/) + 1; 59 | my $pos = [Nil, $line-num, $t.from]; 60 | my $tt = convert-entities(~$t); 61 | push @events, [Hitomi::StreamEventKind::text, $tt, $pos]; 62 | } 63 | } 64 | return @events; 65 | } 66 | 67 | sub convert-entities($text) { 68 | die "Unrecognized entity $0" 69 | if $text ~~ / ('&' \w+ ';') /; 70 | $text.subst(' ', "\x[a0]", :g) 71 | } 72 | 73 | # RAKUDO: https://trac.parrot.org/parrot/ticket/536 makes the method 74 | # override the global 'list' sub if we call it 'list' 75 | method llist() { 76 | Hitomi::XMLGrammar.parse($!text) or die "Couldn't parse $!text"; 77 | my @actions = self.make-events($/, $!text); 78 | return @actions; 79 | } 80 | } 81 | -------------------------------------------------------------------------------- /lib/LolDispatch.pm: -------------------------------------------------------------------------------- 1 | role http-handler { 2 | } 3 | 4 | # Needs a better name 5 | module LolDispatch { 6 | my @routes; 7 | multi trait_auxiliary:(http-handler $trait, $block, $arg) is export { 8 | @routes.push({:route($arg[0]), :block($block)}); 9 | } 10 | 11 | sub dispatch($r) is export { 12 | for @routes -> $item{ 13 | if $r.url.path ~~ $item { 14 | my $ret = $item($r,$/); 15 | return $ret; 16 | } 17 | } 18 | warn "Could not dispatch {$r.url.path}"; 19 | } 20 | } 21 | 22 | =begin usage 23 | use LolDispatch; 24 | use HTTP::Daemon; 25 | 26 | sub foo($request, $match) is http-handler(/wtf/) { 27 | say 'dispatched to foo'; 28 | say $match.perl; 29 | } 30 | 31 | sub item($request, $match) is http-handler(/^\/item\/(\d+)/) { 32 | say 'dispatched to item'; 33 | say $match.perl; 34 | } 35 | 36 | my $request = HTTP::Request.new( 37 | req_url => HTTP::url.new(path => '/item/12345'), 38 | headers => HTTP::Headers.new( header_values => { 'Host' => 'localhost' }), 39 | req_method => 'GET', 40 | ); 41 | 42 | dispatch($request); 43 | =end usage 44 | 45 | -------------------------------------------------------------------------------- /lib/Ratel.pm: -------------------------------------------------------------------------------- 1 | class Ratel { 2 | has $!source; 3 | has $!compiled; 4 | has @!hunks; 5 | has %.transforms is rw; 6 | 7 | submethod BUILD(:%transforms, :$source) { 8 | # XXX Needs to be re-thought to allow wrapping the contents of the 9 | # unquote, use parameterized delims, etc... 10 | %!transforms = %transforms; 11 | %!transforms{'='} = -> $a {"print $a"}; 12 | %!transforms{'!'} = -> $a {"print %attrs<$a>"}; 13 | $.source($source); 14 | } 15 | multi method load(Str $filename) { 16 | $.source(slurp($filename)); 17 | } 18 | 19 | multi method source() { 20 | return $!source; 21 | } 22 | multi method source(Str $text) { 23 | my $index = 0; 24 | $!source = $text; 25 | my $source = "%]$text[%"; 26 | for %!transforms.kv -> $k, $v { 27 | $source.=subst((eval "/'[%$k' (.*?) '%]'/"), -> $match {'[%' ~ $v($match[0]) ~ '%]'}, :g); 28 | } 29 | @!hunks = $source.comb(/'%]' (.*?) '[%'/); 30 | $!compiled 31 | = $source.subst(/(['%]' | ^ ] .*? [ $ | '[%' ])/, 32 | {";\$.emit-hunk({$index++});"}, 33 | :g); 34 | $!compiled = $!compiled; 35 | return; 36 | } 37 | 38 | method emit-hunk(Int $i) { 39 | $.emit(@!hunks[$i][0]); 40 | } 41 | method emit($m) { 42 | $*result ~= $m; 43 | } 44 | 45 | method render(*%attrs) { 46 | my $*result = ''; 47 | my $obj = self; 48 | # XXX Needs cleanup... 49 | my $*OUT = (class { 50 | method say(*@args) { 51 | $obj.emit($_) for (@args, "\n"); 52 | } 53 | method print(*@args) { 54 | $obj.emit($_) for @args; 55 | } 56 | }).new();; 57 | eval $!compiled; 58 | return $*result; 59 | } 60 | } 61 | -------------------------------------------------------------------------------- /lib/Tags.pm: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | module Tags::EXPORT::DEFAULT { } 4 | 5 | module Tags { 6 | our @frames; 7 | 8 | # XXX: The below list used to contain 'map', but I removed it because it 9 | # screwed up code elsewhere. -- masak 10 | 11 | my @nocollapse =