Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Deprecated methods and attributes now warn as recommended by tadzik. …

…Also fixes and improvements on exception and error handling, partially based on recommendations by tadzik. Now has validating attribute that when set will require that entire parse string parse as URI. Based on p5 URI module default is to parse as much URI as possible from string but not be fully validating.
  • Loading branch information...
commit f924fb36e3ab85d208fbe0fd3ea81bd4eab91151 1 parent 6854c4a
@ronaldxs ronaldxs authored
View
10 lib/IETF/RFC_Grammar.pm
@@ -16,8 +16,14 @@ has $.grammar;
has $.parse_result;
method parse($parse_str) {
- $!grammar.parse($parse_str);
- unless $/ { die "Parse failed" } # very weak I think
+ $!grammar.parse($parse_str)
+ or die "Parse failed";
+ $!parse_result = $/
@tadzik
tadzik added a note

I think you could just do something like $!parse_result = $!grammar.parse() or die, while we're looking for simplicity.

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
+}
+
+method parse_validating($parse_str) {
+ $!grammar.parse($parse_str, :rule<TOP_validating>)
+ or die "Parse failed";
$!parse_result = $/
}
View
1  lib/IETF/RFC_Grammar/URI.pm
@@ -7,6 +7,7 @@ use IETF::RFC_Grammar::IPv6;
grammar IETF::RFC_Grammar::URI is IETF::RFC_Grammar::IPv6 {
token TOP { <URI_reference> };
+ token TOP_validating { ^ <URI_reference> $ };
token URI_reference { <URI> | <relative_ref> };
token absolute_URI { <scheme> ':' <.hier_part> [ '?' query ]? };
View
447 lib/URI.pm
@@ -1,213 +1,234 @@
-class URI;
-
-use IETF::RFC_Grammar;
-use IETF::RFC_Grammar::URI;
-use URI::Escape;
-
-has $.uri; # use of this now deprecated
-
-has $.grammar is ro;
-has $!path;
-has Bool $!is_absolute is ro;
-has $!scheme;
-has $!authority;
-has $!query;
-has $!frag;
-has %!query_form;
-
-has @.segments;
-
-method parse (Str $str) {
-
- # clear string before parsing
- my $c_str = $str;
- $c_str .= subst(/^ \s* ['<' | '"'] /, '');
- $c_str .= subst(/ ['>' | '"'] \s* $/, '');
-
- $!uri = $!path = $!is_absolute = $!scheme = $!authority = $!query =
- $!frag = Mu;
- %!query_form = @!segments = Nil;
-
- try {
- $!grammar.parse($c_str);
- }
- CATCH {
- die "Could not parse URI: $str";
- }
-
- # now deprecated
- $!uri = $!grammar.parse_result;
-
- my $comp_container = $!grammar.parse_result<URI_reference><URI> //
- $!grammar.parse_result<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> ;
-
- @!segments = $!path<segment>.list() // ('');
- if my $first_chunk = $!path<segment_nz_nc> // $!path<segment_nz> {
- unshift @!segments, $first_chunk;
- }
- if @!segments.elems == 0 {
- @!segments = ('');
- }
-# @!segments ||= ('');
-
- try {
- %!query_form = split_query( ~$!query );
- }
- CATCH {
- %!query_form = Nil;
- }
-}
-
-sub split_query(Str $query) {
- my %query_form;
-
- for map { [split(/<[=]>/, $_) ]}, split(/<[&;]>/, $query) -> $qmap {
- for (0, 1) -> $i { # could go past 1 in theory ...
- $qmap[ $i ] ~~ s:g/\+/ /;
- $qmap[ $i ] = uri_unescape($qmap[ $i ]);
- }
- if %query_form.exists($qmap[0]) {
- if %query_form{ $qmap[0] } ~~ Array {
- %query_form{ $qmap[0] }.push($qmap[1])
- }
- else {
- %query_form{ $qmap[0] } = [
- %query_form{ $qmap[0] }, $qmap[1]
- ]
- }
- }
- else {
- %query_form{ $qmap[0]} = $qmap[1]
- }
- }
-
- return %query_form;
-}
-
-# deprecated old call for parse
-method init ($str) {
- $.parse($str);
-}
-
-# new can pass alternate grammars some day ...
-submethod BUILD {
- $!grammar = IETF::RFC_Grammar.new('rfc3896');
-}
-
-method new(Str $str?) {
- my $obj = self.bless(*);
-
- if ($str.defined) {
- $obj.parse($str);
- }
-
- return $obj;
-}
-
-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;
-}
-
-# chunks now strongly deprecated
-# it's segments in p5 URI and segment is part of rfc so no more chunks soon!
-method chunks {
- return @!segments;
-}
-
-method query_form {
- return %!query_form;
-}
-
-=begin pod
-
-=head NAME
-
-URI — Uniform Resource Identifiers (absolute and relative)
-
-=head SYNOPSYS
-
- use URI;
- my $u = URI.new('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 $tag = $u.query_form<tag>; # should be woow
-
- my $is_absolute = $u.absolute;
- my $is_relative = $u.relative;
-
- # something p5 URI without grammar could not easily do !
- my $host_in_grammar =
- $u.grammar.parse_result<URI_reference><URI><hier_part><authority><host>;
- if ($host_in_grammar<reg_name>) {
- say 'Host looks like registered domain name - approved!';
- }
- else {
- say 'Sorry we do not take ip address hosts at this time.';
- say 'Please use registered domain name!';
- }
-
-=end pod
-
-
-# vim:ft=perl6
+class URI;
+
+use IETF::RFC_Grammar;
+use IETF::RFC_Grammar::URI;
+use URI::Escape;
+
+has $.grammar is ro;
+has Bool $.is_validating is rw = False;
+has $!path;
+has Bool $!is_absolute is ro;
+has $!scheme;
+has $!authority;
+has $!query;
+has $!frag;
+has %!query_form;
+has $!uri; # use of this now deprecated
+
+has @.segments;
+
+method parse (Str $str) {
+
+ # clear string before parsing
+ my $c_str = $str;
+ $c_str .= subst(/^ \s* ['<' | '"'] /, '');
+ $c_str .= subst(/ ['>' | '"'] \s* $/, '');
+
+ $!uri = $!path = $!is_absolute = $!scheme = $!authority = $!query =
+ $!frag = Mu;
+ %!query_form = @!segments = Nil;
+
+ my $note_caught;
+ try {
+ if ($.is_validating) {
+ $!grammar.parse_validating($c_str);
+ }
+ else {
+ $!grammar.parse($c_str);
+ }
+
+ CATCH {
+ $note_caught++; # exception handling still needs some work ...
+ }
+ }
+ if $note_caught {die "Could not parse URI: $str" }
+
+ # now deprecated
+ $!uri = $!grammar.parse_result;
+
+ my $comp_container = $!grammar.parse_result<URI_reference><URI> //
+ $!grammar.parse_result<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> ;
+
+ @!segments = $!path<segment>.list() // ('');
+ if my $first_chunk = $!path<segment_nz_nc> // $!path<segment_nz> {
+ unshift @!segments, $first_chunk;
+ }
+ if @!segments.elems == 0 {
+ @!segments = ('');
+ }
+# @!segments ||= ('');
+
+ try {
+ %!query_form = split_query( ~$!query );
+ CATCH {
+ %!query_form = Nil;
+ }
+ }
+}
+
+sub split_query(Str $query) {
+ my %query_form;
+
+ for map { [split(/<[=]>/, $_) ]}, split(/<[&;]>/, $query) -> $qmap {
+ for (0, 1) -> $i { # could go past 1 in theory ...
+ $qmap[ $i ] ~~ s:g/\+/ /;
+ $qmap[ $i ] = uri_unescape($qmap[ $i ]);
+ }
+ if %query_form.exists($qmap[0]) {
+ if %query_form{ $qmap[0] } ~~ Array {
+ %query_form{ $qmap[0] }.push($qmap[1])
+ }
+ else {
+ %query_form{ $qmap[0] } = [
+ %query_form{ $qmap[0] }, $qmap[1]
+ ]
+ }
+ }
+ else {
+ %query_form{ $qmap[0]} = $qmap[1]
+ }
+ }
+
+ return %query_form;
+}
+
+# deprecated old call for parse
+method init ($str) {
+ warn "init method now deprecated in favor of parse method";
+ $.parse($str);
+}
+
+# new can pass alternate grammars some day ...
+submethod BUILD($!is_validating?) {
+ $!grammar = IETF::RFC_Grammar.new('rfc3896');
+}
+
+method new(Str $str?, :$is_validating) {
+ my $obj = self.bless(*);
+
+ if $is_validating.defined {
+ $obj.is_validating = $is_validating;
+ }
+
+ if $str.defined {
+ $obj.parse($str);
+ }
+
+ return $obj;
+}
+
+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;
+}
+
+# chunks now strongly deprecated
+# it's segments in p5 URI and segment is part of rfc so no more chunks soon!
+method chunks {
+ warn "chunks attribute now deprecated in favor of segments";
+ return @!segments;
+}
+
+method uri {
+ warn "uri attribute now deprecated in favor of .grammar.parse_result";
+ return $!uri;
+}
+
+method query_form {
+ return %!query_form;
+}
+
+=begin pod
+
+=head NAME
+
+URI — Uniform Resource Identifiers (absolute and relative)
+
+=head SYNOPSYS
+
+ use URI;
+ my $u = URI.new('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 $tag = $u.query_form<tag>; # should be woow
+
+ my $is_absolute = $u.absolute;
+ my $is_relative = $u.relative;
+
+ # something p5 URI without grammar could not easily do !
+ my $host_in_grammar =
+ $u.grammar.parse_result<URI_reference><URI><hier_part><authority><host>;
+ if ($host_in_grammar<reg_name>) {
+ say 'Host looks like registered domain name - approved!';
+ }
+ else {
+ say 'Sorry we do not take ip address hosts at this time.';
+ say 'Please use registered domain name!';
+ }
+
+ # require whole string matches URI and throw exception otherwise ..
+ my $u_v = URI.new('http://?#?#', :is_validating<1>);# throw exception
+=end pod
+
+
+# vim:ft=perl6
View
13 t/01.t
@@ -1,6 +1,6 @@
use v6;
use Test;
-plan 38;
+plan 40;
use URI;
ok(1,'We use URI and we are still alive');
@@ -79,5 +79,14 @@ $u.parse('http://example.com:80/about?foo=cod&foo=trout#bar');
is($u.query_form<foo>[0], 'cod', 'query param foo - el 1');
is($u.query_form<foo>[1], 'trout', 'query param foo - el 2');
-
+my ($url_1_valid, $url_2_valid) = (1, 1);
+try {
+ my $u_v = URI.new('http:://www.perl.com', :is_validating<1>);
+ is($url_1_valid, 1, 'validating parser okd good URI');
+ $u_v = URI.new('http:://?#?#', :is_validating<1>);
+ CATCH {
+ $url_2_valid = 0;
+ }
+}
+is($url_2_valid, 0, 'validating parser rejected bad URI');
# vim:ft=perl6
View
2  t/rfc-3986-examples.t
@@ -3,7 +3,7 @@ use Test;
plan 22;
use URI;
-my $u = URI.new('ftp://ftp.is.co.za/rfc/rfc1808.txt');
+my $u = URI.new('ftp://ftp.is.co.za/rfc/rfc1808.txt', :validating<1>);
is($u.scheme, 'ftp', 'ftp scheme');
is($u.host, 'ftp.is.co.za', 'ftp host');
is($u.path, '/rfc/rfc1808.txt', 'ftp path');
Please sign in to comment.
Something went wrong with that request. Please try again.