Permalink
Browse files

URI now runs with current rakudo as of May 9, 2011. URI::Escape worki…

…ng but should be revisited as rakudo progresses...
  • Loading branch information...
unknown
unknown committed May 9, 2011
1 parent eb83019 commit 5995bf40c3557da0162c107fc388bde544a208d9
Showing with 249 additions and 243 deletions.
  1. +127 −124 lib/URI.pm
  2. +71 −68 lib/URI/Escape.pm
  3. +51 −51 t/escape.t
View
@@ -1,124 +1,127 @@
-class URI;
-
-has $.uri;
-has $.path;
-has Bool $.is_absolute is ro;
-has $.scheme;
-has $.authority;
-has $.query;
-has $.frag;
-has @.chunks;
-
-method init ($str) {
- use IETF::RFC_Grammar::URI;
-
- # clear string before parsing
- my $c_str = $str;
- $c_str .= subst(/^ \s* ['<' | '"'] /, '');
- $c_str .= subst(/ ['>' | '"'] \s* $/, '');
-
- IETF::RFC_Grammar::URI.parse($c_str);
- unless $/ { die "Could not parse URI: $str" }
-
- $!uri = $!path = $!is_absolute = $!scheme = $!authority = $!query =
- $!frag = undef;
- @!chunks = undef;
-
- $!uri = $/;
-
- my $comp_container = $/<URI_reference><URI> // $/<URI_reference><relative_ref>;
- $!scheme = $comp_container<scheme>;
- $!query = $comp_container<query>;
- $!frag = $comp_container<fragment>;
- $comp_container = $comp_container<hier_part> // $comp_container<relative_part>;
-
- $!authority = $comp_container<authority>;
- $!path = $comp_container<path_abempty> //
- $comp_container<path_absolute> ;
- $!is_absolute = ?($!path // $.scheme);
-
- $!path //= $comp_container<path_noscheme> //
- $comp_container<path_rootless> ;
-
- @!chunks = $!path<segment> // ('');
- if my $first_chunk = $!path<segment_nz_nc> // $!path<segment_nz> {
- unshift @!chunks, $first_chunk;
- }
- @!chunks ||= ('');
-}
-
-method scheme {
- return ~$!scheme.lc;
-}
-
-method authority {
- return ~$!authority.lc;
-}
-
-method host {
- return ($!authority<host> // '').lc;
-}
-
-method port {
- item $!authority<port> // '';
-}
-
-method path {
- return ~($!path // '').lc;
-}
-
-method absolute {
- return $!is_absolute;
-}
-
-method relative {
- return ! $.absolute;
-}
-
-method query {
- item ~($!query // '');
-}
-method frag {
- return ~($!frag // '').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
-
-URI — Uniform Resource Identifiers (absolute and relative)
-
-=head SYNOPSYS
-
- use URI;
- my $u = URI.new;
- $u.init('http://her.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
+class URI;
+
+has $.uri;
+has $!path;
+has Bool $!is_absolute is ro;
+has $!scheme;
+has $!authority;
+has $!query;
+has $!frag;
+has @.chunks;
+
+method init ($str) {
+ use IETF::RFC_Grammar::URI;
+
+ # clear string before parsing
+ my $c_str = $str;
+ $c_str .= subst(/^ \s* ['<' | '"'] /, '');
+ $c_str .= subst(/ ['>' | '"'] \s* $/, '');
+
+ IETF::RFC_Grammar::URI.parse($c_str);
+ unless $/ { die "Could not parse URI: $str" }
+
+ $!uri = $!path = $!is_absolute = $!scheme = $!authority = $!query =
+ $!frag = Mu;
+ @!chunks = Nil;
+
+ $!uri = $/;
+
+ my $comp_container = $/<URI_reference><URI> // $/<URI_reference><relative_ref>;
+ $!scheme = $comp_container<scheme>;
+ $!query = $comp_container<query>;
+ $!frag = $comp_container<fragment>;
+ $comp_container = $comp_container<hier_part> // $comp_container<relative_part>;
+
+ $!authority = $comp_container<authority>;
+ $!path = $comp_container<path_abempty> //
+ $comp_container<path_absolute> ;
+ $!is_absolute = ?($!path // $.scheme);
+
+ $!path //= $comp_container<path_noscheme> //
+ $comp_container<path_rootless> ;
+
+ @!chunks = $!path<segment>.list() // ('');
+ if my $first_chunk = $!path<segment_nz_nc> // $!path<segment_nz> {
+ unshift @!chunks, $first_chunk;
+ }
+ if @!chunks.elems == 0 {
+ @!chunks = ('');
+ }
+# @!chunks ||= ('');
+}
+
+method scheme {
+ return ~$!scheme.lc;
+}
+
+method authority {
+ return ~$!authority.lc;
+}
+
+method host {
+ return ($!authority<host> // '').lc;
+}
+
+method port {
+ item $!authority<port> // '';
+}
+
+method path {
+ return ~($!path // '').lc;
+}
+
+method absolute {
+ return $!is_absolute;
+}
+
+method relative {
+ return ! $.absolute;
+}
+
+method query {
+ item ~($!query // '');
+}
+method frag {
+ return ~($!frag // '').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
+
+URI — Uniform Resource Identifiers (absolute and relative)
+
+=head SYNOPSYS
+
+ use URI;
+ my $u = URI.new;
+ $u.init('http://her.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
@@ -1,68 +1,71 @@
-use v6;
-
-package URI::Escape {
-
- use IETF::RFC_Grammar::URI;
-
- our %escapes;
-
- for 0 .. 255 -> $c { # map broken in module / package ?
- %escapes{ chr($c) } = sprintf "%%%02X", $c
- }
-
- # in moving from RFC 2396 to RFC 3986 this selection of characters
- # may be due for an update ...
- token artifact_unreserved {<[!*'()] +IETF::RFC_Grammar::URI::unreserved>};
-
- sub uri_escape($s is copy) is export {
- my $rc;
- while $s {
- if my $not_escape = $s ~~ /^<artifact_unreserved>+/ {
- $rc ~= $not_escape;
- $s.=substr($not_escape.chars);
- }
- if my $escape = $s ~~ /^<- artifact_unreserved>+/ {
- $rc ~= ($escape.comb().map: {
- %escapes{ chr(ord($_)) } || # chr(ord()) ??? @#^^!! it works
- die 'Can\'t escape \\' ~ sprintf('x{%04X}, try uri_escape_utf8() instead',
- ord($_))
- }).join;
- $s.=substr($escape.chars);
- }
- }
-
- return $rc;
- }
-
- sub uri_unescape(*@to_unesc) is export {
- my @rc;
- for @to_unesc -> $s is copy {
- my $rc;
- while my $next_unescape = $s ~~ /.*? '%' (<.xdigit> <.xdigit>)/ {
- $rc ~= $next_unescape.substr(0, -3) ~
- chr( :16($next_unescape[0]) );
- $s.=substr($next_unescape.chars);
- }
- @rc.push( $rc ~ $s );
- }
- return @rc;
- }
-
-}
-
-=begin pod
-
-=head NAME
-
-URI::Escape - Escape and unescape unsafe characters
-
-=head SYNOPSYS
-
- use URI::Escape;
-
- my $escaped = uri_escape("10% is enough\n");
- my $un_escaped = uri_unescape('10%25%20is%20enough%0A');
-
-=end pod
-
-# vim:ft=perl6
+use v6;
+
+package URI::Escape {
+
+ use IETF::RFC_Grammar::URI;
+
+ our %escapes;
+
+ for 0 .. 255 -> $c { # map broken in module / package ?
+ %escapes{ chr($c) } = sprintf "%%%02X", $c
+ }
+
+ # in moving from RFC 2396 to RFC 3986 this selection of characters
+ # may be due for an update ...
+
+ # commented line below used to work ...
+# token artifact_unreserved {<[!*'()] +IETF::RFC_Grammar::URI::unreserved>};
+
+ sub uri_escape($s is copy) is export {
+ my $rc;
+ while $s {
+ # regexes kludged for many broken things in rakudo
+ if my $not_escape = $s ~~ /^<[!*'()\-._~A..Za..z0..9]>+/ {
+ $rc ~= $not_escape;
+ $s.=substr($not_escape.chars);
+ }
+ if my $escape = $s ~~ /^<- [!*'()\-._~A..Za..z0..9]>+/ {
+ $rc ~= ($escape.comb().map: {
+ %escapes{ $_ } ||
+ die 'Can\'t escape \\' ~ sprintf('x{%04X}, try uri_escape_utf8() instead',
+ ord($_))
+ }).join;
+ $s.=substr($escape.chars);
+ }
+ }
+
+ return $rc;
+ }
+
+ sub uri_unescape(*@to_unesc) is export {
+ my @rc;
+ for @to_unesc -> $s is copy {
+ my $rc;
+ while my $next_unescape = $s ~~ /.*? '%' (<.xdigit> <.xdigit>)/ {
+ $rc ~= $next_unescape.substr(0, -3) ~
+ chr( :16($next_unescape[0]) );
+ $s.=substr($next_unescape.chars);
+ }
+ @rc.push( ($rc || '') ~ $s );
+ }
+ return @rc;
+ }
+
+}
+
+=begin pod
+
+=head NAME
+
+URI::Escape - Escape and unescape unsafe characters
+
+=head SYNOPSYS
+
+ use URI::Escape;
+
+ my $escaped = uri_escape("10% is enough\n");
+ my $un_escaped = uri_unescape('10%25%20is%20enough%0A');
+
+=end pod
+
+# vim:ft=perl6
Oops, something went wrong.

0 comments on commit 5995bf4

Please sign in to comment.