Skip to content

Please pull move of URI parsing and escape logic to Perl6 URI project. #27

Open
wants to merge 3 commits into from
View
2 META.info
@@ -2,7 +2,7 @@
"name" : "November",
"version" : "*",
"description" : "A wiki engine written in Perl 6",
- "depends" : ["HTML::Template"],
+ "depends" : ["HTML::Template" , "Digest::MD5", "URI" ],
"repo-type" : "git",
"repo-url" : "git://github.com/viklund/november.git"
}
View
2 Makefile
@@ -13,8 +13,6 @@ SOURCES = \
lib/November/Storage.pm \
lib/November/Storage/File.pm \
lib/November/Tags.pm \
- lib/November/URI.pm \
- lib/November/URI/Grammar.pm \
lib/November/Utils.pm \
lib/November/Utils.pm \
lib/Test/CGI.pm \
View
8 README
@@ -32,16 +32,16 @@ See instructions on the Rakudo web site:
<http://rakudo.org/how-to-get-rakudo>
-You'll also need the projects listed in deps.proto, presently only
-HTML::Template. It is preferrable to build HTML::Template before building
-November.
+You'll also need the projects listed in META.info including HTML::Template,
+Digest::MD5, and URI. It is preferrable to build HTML::Template before
+building November.
$ pwd
/tmp
$ git clone git://github.com/viklund/november.git
$ git clone git://github.com/masak/html-template.git
$ export RAKUDO_DIR=$PARROT_DIR/languages/rakudo
-$ export PERL6LIB=$RAKUDO_DIR:/tmp/november/lib:/tmp/html-template/lib
+$ export PERL6LIB=$RAKUDO_DIR:/tmp/november/lib:/tmp/html-template/lib:/tmp/perl6-digest-md5/lib/:/tmp/uri/lib
$ cd html-template/
$ perl Makefile.PL
$ make
View
4 lib/November.pm
@@ -46,8 +46,8 @@ class November does November::Session does November::Cache {
['all'], { self.list_all_pages },
];
- my @chunks = $cgi.uri.chunks.list;
- $d.dispatch(@chunks);
+ my @segments = $cgi.uri.segments.list;
+ $d.dispatch(@segments);
}
# RAKUDO: Should `is rw` work with constant defaults? (It doesn't.)
View
62 lib/November/CGI.pm
@@ -1,11 +1,12 @@
use v6;
-use November::URI;
+use URI;
+use URI::Escape;
class November::CGI {
has %.params;
has %.cookie;
has @.keywords;
- has November::URI $.uri;
+ has URI $.uri;
has $!crlf = "\x[0D]\x[0A]";
@@ -38,7 +39,7 @@ class November::CGI {
$uri_str ~= ':' ~ %*ENV<SERVER_PORT> if %*ENV<SERVER_PORT>;
$uri_str ~= %*ENV<MODPERL6> ?? %*ENV<PATH_INFO> !! %*ENV<REQUEST_URI>;
- $!uri = November::URI.new( uri => $uri_str );
+ $!uri = URI.new( $uri_str );
}
# For debugging
@@ -85,11 +86,9 @@ class November::CGI {
method parse_params($string) {
if $string ~~ / '&' | ';' | '=' / {
- my @param_values = $string.split(/ '&' | ';' /);
-
- for @param_values -> $param_value {
- my @kvs = $param_value.split("=");
- self.add_param( @kvs[0], unescape(@kvs[1]) );
+ my %query_form = URI::split_query($string);
+ for %query_form.kv -> $k, $v {
+ self.add_param($k, uri_unescape( item $v ));
}
}
else {
@@ -98,7 +97,7 @@ class November::CGI {
}
method parse_keywords (Str $string is copy) {
- my $kws = unescape($string);
+ my $kws = uri_unescape($string);
@!keywords = $kws.split(/ \s+ /);
}
@@ -108,51 +107,8 @@ class November::CGI {
for @param_values -> $param_value {
my @kvs = $param_value.split('=');
- %!cookie{ @kvs[0] } = unescape( @kvs[1] );
- }
- }
-
- our sub unescape($string is copy) {
- $string .= subst('+', ' ', :g);
- # RAKUDO: This could also be rewritten as a single .subst :g call.
- # ...when the semantics of .subst is revised to change $/,
- # that is.
- # The percent_hack can be removed once the bug is fixed and :g is
- # added
- while $string ~~ / ( [ '%' <[0..9A..F]>**2 ]+ ) / {
- $string .= subst( ~$0,
- percent_hack_start( decode_urlencoded_utf8( ~$0 ) ) );
- }
- return percent_hack_end( $string );
- }
-
- sub percent_hack_start($str is rw) {
- if $str ~~ '%' {
- $str = '___PERCENT_HACK___';
- }
- return $str;
- }
-
- sub percent_hack_end($str) {
- return $str.subst('___PERCENT_HACK___', '%', :g);
- }
-
- sub decode_urlencoded_utf8($str) {
- my $r = '';
- my @chars = map { :16($_) }, $str.split('%').grep({$^w});
- while @chars {
- my $bytes = 1;
- my $mask = 0xFF;
- given @chars[0] {
- when { $^c +& 0xF0 == 0xF0 } { $bytes = 4; $mask = 0x07 }
- when { $^c +& 0xE0 == 0xE0 } { $bytes = 3; $mask = 0x0F }
- when { $^c +& 0xC0 == 0xC0 } { $bytes = 2; $mask = 0x1F }
- }
- my @shift = (^$bytes).reverse.map({6 * $_});
- my @mask = $mask, 0x3F xx $bytes-1;
- $r ~= chr( [+] @chars.splice(0,$bytes) »+&« @mask »+<« @shift );
+ %!cookie{ @kvs[0] } = uri_unescape( @kvs[1] );
}
- return $r;
}
method add_param ( Str $key, $value ) {
View
120 lib/November/URI.pm
@@ -1,120 +0,0 @@
-class November::URI;
-
-# This class used to be called just 'URI', but there was a collision with
-# the eponymous class in the 'uri' project. Arguably, that class has more
-# rights to that name, so this one was renamed. Since the 'uri' project
-# ought to cover the same functionality as this class, maybe long-term we
-# could switch to using that instead. One more dependency, but less code
-# duplication across projects.
-
-use November::URI::Grammar;
-# RAKUDO: Match object does not do assignment properly :(
-#my Match $.parts; dies in init with 'Type mismatch in assignment';
-# workaround:
-has $.uri;
-has @.chunks;
-
-submethod BUILD(:$uri) {
-
- # clear string before parsing
- my $c_str = $uri;
- $c_str .= subst(/^ \s* ['<' | '"'] /, '');
- $c_str .= subst(/ ['>' | '"'] \s* $/, '');
-
- November::URI::Grammar.parse($c_str);
- unless $/ { die "Could not parse URI: $uri" }
-
- $!uri = $/;
- @!chunks = @($<path><chunk>) || ('');
-}
-
-method scheme {
- my $s = $.uri<scheme> || '';
- # RAKUDO: return 1 if use ~ below die because can`t do lc on Math after
- return ~$s.lc;
-}
-
-method authority {
- my $a = $.uri<authority> || '';
- # RAKUDO: return 1 if use ~ below die because can`t do lc on Math after
- return ~$a.lc;
-}
-
-method host {
- #RAKUDO: $.uri<authority>[0]<host> return full <authority> now
- my $h = ~$.uri<authority>[0]<host>;
- return $h.lc || '';
-}
-
-method port {
- # TODO: send rakudobug
- # RAKUDO: $.uri<authority><port> return full <authority> now
- # workaround:
- item $.uri<authority>[0]<port> || '';
-}
-
-method path {
- my $p = ~$.uri<path> || '';
- return $p.lc;
-}
-
-method absolute {
- # RAKUDO: The grammar uses <slash>?, so this should be either Nil or a
- # Match object. But Rakudo returns [] or [Match] instead, so we must use
- # || instead of // to test.
- return ?($.uri<path><slash> || $.scheme);
-}
-
-method relative {
- # Rakudo: Must use || instead of //, see above.
- return !($.uri<path><slash> || $.scheme);
-}
-
-method query {
- item $.uri<query> || '';
-}
-method frag {
- my $f = $.uri<fragment> || '';
- return ~$f.lc;
-}
-
-method fragment { $.frag }
-
-method Str() {
- my $str;
- $str ~= $.scheme if $.scheme;
- $str ~= '://' ~ $.authority if $.authority;
- $str ~= $.path;
- $str ~= '?' ~ $.query if $.query;
- $str ~= '#' ~ $.frag if $.frag;
- return $str;
-}
-
-
-=begin pod
-
-=head NAME
-
-November::URI — Uniform Resource Identifiers (absolute and relative)
-
-=head SYNOPSYS
-
- use November::URI;
- my $u = November::URI.new;
- $u.init('http://example.com/foo/bar?tag=woow#bla');
-
- my $scheme = $u.scheme;
- my $authority = $u.authority;
- my $host = $u.host;
- my $port = $u.port;
- my $path = $u.path;
- my $query = $u.query;
- my $frag = $u.frag; # or $u.fragment;
-
- my $is_absolute = $u.absolute;
- my $is_relative = $u.relative;
-
-=end pod
-
-
-# vim:ft=perl6
View
27 lib/November/URI/Grammar.pm
@@ -1,27 +0,0 @@
-use v6;
-grammar November::URI::Grammar {
- token TOP { ^ [<scheme> ':']? [ '//' <authority>]? <path> ['?' <query>]? ['#' <fragment>]? $ };
- token scheme { <-[:/&?#]>+ };
- token authority { <host> [':' <port>]? };
- token host { <-[/&?#:]>* };
- token port { (\d**1..5)
- <?{ $0 < 2 ** 16 }>
- <!before \d> };
- token path { <slash>? [ <chunk> '/'?]* }; # * mb wrong, because that allow '' URI
- token slash { '/' };
- token chunk { <-[/?#]>+ };
- token query { <-[#]>* };
- token fragment { .* };
-}
-
-# Official regexp (p5):
-# my($scheme, $authority, $path, $query, $fragment) =
-# $uri =~ m/
-# (?:([^:/?#]+):)?
-# (?://([^/?#]*))?
-# ([^?#]*)
-# (?:\?([^#]*))?
-# (?:#(.*))?
-# /x;
-
-# vim:ft=perl6
View
31 t/cgi/03-urlencoded.t
@@ -1,31 +0,0 @@
-use v6;
-
-use Test;
-use November::CGI;
-
-my @t =
- '%61' => 'a',
- '%C3%A5' => 'å',
- '%C4%AC' => 'Ĭ',
- '%C7%82' => 'ǂ',
- '%E2%98%BA' => '',
- '%E2%98%BB' => '',
- 'alla+snubbar' => 'alla snubbar',
- 'text%61+abc' => 'texta abc',
- 'unicode+%C7%82%C3%A5' => 'unicode ǂå',
- '%25' => '%',
- '%25+25' => '% 25',
- '%25rr' => '%rr',
- '%2561' => '%61',
- ;
-
-plan +@t;
-
-for @t {
- my $ans = November::CGI::unescape( ~.key );
- ok( $ans eq .value, 'Decoding ' ~ .key )
- or say "GOT: {$ans.perl}\nEXPECTED: {.value.perl}";
-
-}
-
-# vim: ft=perl6
View
11 t/cgi/cgi_post_test
@@ -1,13 +1,12 @@
-#!/usr/bin/perl6
+#!/usr/bin/env perl6
use Test;
-use CGI;
-my $cgi = CGI.new();
-$cgi.init();
+use November::CGI;
+my $cgi = November::CGI.new();
-print _is_deeply( $cgi.params, eval( %*ENV<TEST_RESULT> ) )
+# _is_deeply no longer visible from Test.pm so worked around it ...
+print $cgi.params eqv eval( %*ENV<TEST_RESULT> )
?? "ok "
!! "not ok \n" ~ "got: " ~ $cgi.param.perl ~
"\nexpected: " ~ %*ENV<TEST_RESULT> ~ "\n";
-
say "- " ~ %*ENV<TEST_NAME>;
View
4 t/integration/01-view_page.t
@@ -4,7 +4,7 @@ use Test;
use November;
use Test::CGI;
use November::Config;
-use November::URI;
+use URI;
my @markups = < Text::Markup::Wiki::MediaWiki >;
my @skins = < CleanAndSoft >;
@@ -26,7 +26,7 @@ for @markups X @skins -> $m, $s {
my $c = November::Config.new( markup => $m, skin => $s );
my $w = November.new( config => $c );
for %gets.kv -> $page, $description {
- my $uri = November::URI.new( uri => 'http://testserver' ~ $page );
+ my $uri = URI.new( 'http://testserver' ~ $page );
my $cgi = Test::CGI.new( uri => $uri );
$cgi.parse_params( $page );
lives_ok( { $w.handle_request( $cgi ) }, "$m, $s, $description" );
View
60 t/uri/01.t
@@ -1,60 +0,0 @@
-use v6;
-use Test;
-plan 28;
-
-use November::URI;
-ok(1,'We use URI and we are still alive');
-
-my $u = November::URI.new(uri => 'http://example.com:80/about/us?foo#bar');
-
-is($u.scheme, 'http', 'scheme');
-is($u.host, 'example.com', 'host');
-is($u.port, '80', 'port');
-is($u.path, '/about/us', 'path');
-is($u.query, 'foo', 'query');
-is($u.frag, 'bar', 'frag');
-is($u.chunks, 'about us', 'chunks');
-is($u.chunks[0], 'about', 'first chunk');
-is($u.chunks[1], 'us', 'second chunk');
-
-is( ~$u, 'http://example.com:80/about/us?foo#bar',
- 'Complete path stringification');
-
-$u = November::URI.new(uri => 'https://eXAMplE.COM');
-
-is($u.scheme, 'https', 'scheme');
-is($u.host, 'example.com', 'host');
-is( "$u", 'https://example.com',
- 'https://eXAMplE.COM stringifies to https://example.com');
-
-$u = November::URI.new(uri => '/foo/bar/baz');
-
-is($u.chunks, 'foo bar baz', 'chunks from absolute path');
-ok($u.absolute, 'absolute path');
-nok($u.relative, 'not relative path');
-
-$u = November::URI.new(uri => 'foo/bar/baz');
-
-is($u.chunks, 'foo bar baz', 'chunks from relative path');
-ok( $u.relative, 'relative path');
-nok($u.absolute, 'not absolute path');
-
-is($u.chunks[0], 'foo', 'first chunk');
-is($u.chunks[1], 'bar', 'second chunk');
-is($u.chunks[*-1], 'baz', 'last chunk');
-
-$u = November::URI.new(uri => 'http://foo.com');
-
-ok($u.chunks.list.perl eq '[""]', ".chunks return [''] for empty path");
-ok($u.absolute, 'http://foo.com has an absolute path');
-nok($u.relative, 'http://foo.com does not have a relative path');
-
-# test November::URI parsing with <> or "" and spaces
-$u = November::URI.new(uri => "<http://foo.com> ");
-is("$u", 'http://foo.com', '<> removed from str');
-
-$u = November::URI.new(uri => ' "http://foo.com"');
-is("$u", 'http://foo.com', '"" removed from str');
-
-
-# vim:ft=perl6
View
2 wiki 100644 → 100755
@@ -1,4 +1,4 @@
-#!perl6
+#!/usr/bin/env perl6
use v6;
use November;
Something went wrong with that request. Please try again.