added schemes attribute to Mojo::URL

mojolicious · May 7, 2013 · be51a3b · be51a3b
1 parent 0a98e3e
commit be51a3b
Show file tree

Hide file tree

Showing 3 changed files with 35 additions and 15 deletions.
diff --git a/Changes b/Changes
@@ -1,5 +1,6 @@
 
 3.98  2013-05-07
+  - Added schemes attribute to Mojo::URL.
   - Added is_empty method to Mojo::Transaction::HTTP.
   - Added close_gracefully method to Mojo::IOLoop::Stream.
   - Removed deprecated build_form_tx, build_json_tx, post_form and post_json

diff --git a/lib/Mojo/URL.pm b/lib/Mojo/URL.pm
@@ -11,6 +11,7 @@ use Mojo::Util qw(punycode_decode punycode_encode url_escape url_unescape);
 
 has base => sub { Mojo::URL->new };
 has [qw(data fragment host port scheme userinfo)];
+has schemes => sub { [qw(http https ws wss)] };
 
 sub new { shift->SUPER::new->parse(@_) }
 
@@ -45,7 +46,8 @@ sub clone {
   my $self = shift;
 
   my $clone = $self->new;
-  $clone->$_($self->$_) for qw(scheme data userinfo host port fragment);
+  $clone->$_($self->$_)
+    for qw(schemes scheme data userinfo host port fragment);
   $clone->path($self->path->clone);
   $clone->query($self->query->clone);
   $clone->base($self->base->clone) if $self->{base};
@@ -80,18 +82,15 @@ sub parse {
   # Official regex
   $url =~ m!(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?!;
 
-  # Supported scheme
-  my $proto = $self->scheme($1)->protocol;
-  if (!$proto || grep { $proto eq $_ } qw(http https ws wss)) {
-    $self->authority($2);
-    $self->path->parse($3);
-    $self->query($4)->fragment($5);
-  }
-
   # Preserve scheme data
-  else { $self->data(substr($url, length($proto) + 1)) }
+  my $proto = $self->scheme($1)->protocol;
+  return $self->data(substr($url, length($proto) + 1))
+    if $proto && !grep { $proto eq $_ } @{$self->schemes};
 
-  return $self;
+  # Supported scheme or relative
+  $self->authority($2);
+  $self->path->parse($3);
+  return $self->query($4)->fragment($5);
 }
 
 sub path {
@@ -323,6 +322,13 @@ Port part of this URL.
 
 Scheme part of this URL.
 
+=head2 schemes
+
+  my $schemes = $url->schemes;
+  $url        = $url->schemes([qw(http https)]);
+
+Schemes that can be parsed, defaults to C<http>, C<https>, C<ws> and C<wss>.
+
 =head2 userinfo
 
   my $userinfo = $url->userinfo;
@@ -375,17 +381,20 @@ Check if URL is absolute.
 
   $url = $url->parse('http://127.0.0.1:3000/foo/bar?fo=o&baz=23#foo');
 
-Parse relative or absolute URL for the C<http>, C<https>, C<ws> as well as
-C<wss> schemes and preserve scheme data for all unknown ones.
+Parse relative or absolute URL for supported C<schemes> and preserve scheme
+data for all unknown ones.
 
   # "/test/123"
   $url->parse('/test/123?foo=bar')->path;
 
   # "example.com"
   $url->parse('http://example.com/test/123?foo=bar')->host;
 
-  # "mailto:sri@example.com"
-  $url->parse('mailto:sri@example.com')->to_string;
+  # "sri@example.com"
+  $url->parse('mailto:sri@example.com')->data;
+
+  # "/baz"
+  $url->schemes(['foo'])->parse('foo://bar/baz')->path;
 
 =head2 path
 

diff --git a/t/mojo/url.t b/t/mojo/url.t
@@ -130,7 +130,17 @@ is "$url", 'foo://test/123', 'right format';
 is $url->scheme('Bar')->to_string, 'Bar://test/123', 'right format';
 is $url->scheme,   'Bar',        'right scheme';
 is $url->protocol, 'bar',        'right protocol';
+is $url->host,     undef,        'no host';
+is $url->path,     '',           'no path';
 is $url->data,     '//test/123', 'right data';
+$url = Mojo::URL->new->schemes(['foo'])->parse('foo://test/123');
+is $url->scheme,   'foo',  'right scheme';
+is $url->protocol, 'foo',  'right protocol';
+is $url->host,     'test', 'right host';
+is $url->path,     '/123', 'right path';
+is $url->data,     undef,  'no data';
+is "$url", 'foo://test/123', 'right format';
+is_deeply $url->clone->schemes, ['foo'], 'right schemes';
 
 # Relative
 $url = Mojo::URL->new('foo?foo=bar#23');