added experimental support for IPv4 and IPv6 address checks to Mojo::URL

mojolicious · Oct 24, 2010 · cb72634 · cb72634
1 parent a303536
commit cb72634
Show file tree

Hide file tree

Showing 3 changed files with 89 additions and 2 deletions.
diff --git a/Changes b/Changes
@@ -4,6 +4,8 @@ This file documents the revision history for Perl extension Mojolicious.
         - Removed tag helpers label and img.
         - Renamed tag helper script to javascript and added CDATA support.
         - Renamed tag helper input to input_tag.
+        - Added EXPERIMENTAL support for IPv4 and IPv6 addess checks to
+          Mojo::URL.
         - Added stylesheet tag helper.
         - Added before and after methods to Mojo::DOM.
         - Hide command overview from prove. (omega)

diff --git a/lib/Mojo/URL.pm b/lib/Mojo/URL.pm
@@ -13,14 +13,33 @@ use Mojo::Path;
 __PACKAGE__->attr([qw/fragment host port scheme userinfo/]);
 __PACKAGE__->attr(base => sub { Mojo::URL->new });
 
-# RFC 3986
+# Characters (RFC 3986)
 our $UNRESERVED = 'A-Za-z0-9\-\.\_\~';
 our $SUBDELIM   = '!\$\&\'\(\)\*\+\,\;\=';
 our $PCHAR      = "$UNRESERVED$SUBDELIM\%\:\@";
 
 # The specs for this are blurry, it's mostly a collection of w3c suggestions
 our $PARAM = "$UNRESERVED\!\$\'\(\)\*\,\:\@\/\?";
 
+# IPv4 regex (RFC 3986)
+my $DEC_OCTET_RE = qr/(?:[0-9]|[1-9][0-9]|1[0-9][0-9]|2[0-4][0-9]|25[0-5])/;
+our $IPV4_RE = qr/$DEC_OCTET_RE\.$DEC_OCTET_RE\.$DEC_OCTET_RE\.$DEC_OCTET_RE/;
+
+# IPv6 regex (RFC 3986)
+my $H16_RE  = qr/[0-9A-Fa-f]{1,4}/;
+my $LS32_RE = qr/(?:$H16_RE:$H16_RE|$IPV4_RE)/;
+our $IPV6_RE = qr/(?:
+                                             (?: $H16_RE : ){6} $LS32_RE
+    |                                     :: (?: $H16_RE : ){5} $LS32_RE
+    | (?:                      $H16_RE )? :: (?: $H16_RE : ){4} $LS32_RE
+    | (?: (?: $H16_RE : ){0,1} $H16_RE )? :: (?: $H16_RE : ){3} $LS32_RE
+    | (?: (?: $H16_RE : ){0,2} $H16_RE )? :: (?: $H16_RE : ){2} $LS32_RE
+    | (?: (?: $H16_RE : ){0,3} $H16_RE )? ::     $H16_RE :      $LS32_RE
+    | (?: (?: $H16_RE : ){0,4} $H16_RE )? ::                    $LS32_RE
+    | (?: (?: $H16_RE : ){0,5} $H16_RE )? ::                    $H16_RE
+    | (?: (?: $H16_RE : ){0,6} $H16_RE )? ::
+)/x;
+
 sub new {
     my $self = shift->SUPER::new();
     $self->parse(@_);
@@ -127,6 +146,16 @@ sub is_abs {
     return;
 }
 
+sub is_ipv4 {
+    return 1 if shift->host =~ $IPV4_RE;
+    return;
+}
+
+sub is_ipv6 {
+    return 1 if shift->host =~ $IPV6_RE;
+    return;
+}
+
 sub parse {
     my ($self, $url) = @_;
 
@@ -418,6 +447,20 @@ Host part of this URL in punycode format.
 
 Check if URL is absolute.
 
+=head2 C<is_ipv4>
+
+    my $is_ipv4 = $url->is_ipv4;
+
+Check if C<host> is an C<IPv4> address.
+Note that this method is EXPERIMENTAL and might change without warning!
+
+=head2 C<is_ipv6>
+
+    my $is_ipv6 = $url->is_ipv6;
+
+Check if C<host> is an C<IPv6> address.
+Note that this method is EXPERIMENTAL and might change without warning!
+
 =head2 C<parse>
 
     $url = $url->parse('http://127.0.0.1:3000/foo/bar?fo=o&baz=23#foo');

diff --git a/t/mojo/url.t b/t/mojo/url.t
@@ -5,7 +5,7 @@ use warnings;
 
 use utf8;
 
-use Test::More tests => 124;
+use Test::More tests => 154;
 
 # I don't want you driving around in a car you built yourself.
 # You can sit there complaining, or you can knit me some seat belts.
@@ -254,3 +254,45 @@ $url = Mojo::URL->new('http://kraih.com/foo///bar/23/');
 $url->base->parse('http://kraih.com/');
 is $url->is_abs, 1;
 is $url->to_rel, '/foo///bar/23/';
+
+# Check host for IPv4 and IPv6 addresses
+$url = Mojo::URL->new('http://mojolicio.us');
+is $url->host,    'mojolicio.us', 'right host';
+is $url->is_ipv4, undef,          'not an IPv4 address';
+is $url->is_ipv6, undef,          'not an IPv6 address';
+$url = Mojo::URL->new('http://[::1]');
+is $url->host,    '[::1]', 'right host';
+is $url->is_ipv4, undef,   'not an IPv4 address';
+is $url->is_ipv6, 1,       'is an IPv6 address';
+$url = Mojo::URL->new('http://127.0.0.1');
+is $url->host,    '127.0.0.1', 'right host';
+is $url->is_ipv4, 1,           'is an IPv4 address';
+is $url->is_ipv6, undef,       'not an IPv6 address';
+$url = Mojo::URL->new('http://0::127.0.0.1');
+is $url->host,    '0::127.0.0.1', 'right host';
+is $url->is_ipv4, 1,              'is an IPv4 address';
+is $url->is_ipv6, 1,              'is an IPv6 address';
+$url = Mojo::URL->new('http://[0::127.0.0.1]');
+is $url->host,    '[0::127.0.0.1]', 'right host';
+is $url->is_ipv4, 1,                'is an IPv4 address';
+is $url->is_ipv6, 1,                'is an IPv6 address';
+$url = Mojo::URL->new('http://mojolicio.us:3000');
+is $url->host,    'mojolicio.us', 'right host';
+is $url->is_ipv4, undef,          'not an IPv4 address';
+is $url->is_ipv6, undef,          'not an IPv6 address';
+$url = Mojo::URL->new('http://[::1]:3000');
+is $url->host,    '[::1]', 'right host';
+is $url->is_ipv4, undef,   'not an IPv4 address';
+is $url->is_ipv6, 1,       'is an IPv6 address';
+$url = Mojo::URL->new('http://127.0.0.1:3000');
+is $url->host,    '127.0.0.1', 'right host';
+is $url->is_ipv4, 1,           'is an IPv4 address';
+is $url->is_ipv6, undef,       'not an IPv6 address';
+$url = Mojo::URL->new('http://0::127.0.0.1:3000');
+is $url->host,    '0::127.0.0.1', 'right host';
+is $url->is_ipv4, 1,              'is an IPv4 address';
+is $url->is_ipv6, 1,              'is an IPv6 address';
+$url = Mojo::URL->new('http://[0::127.0.0.1]:3000');
+is $url->host,    '[0::127.0.0.1]', 'right host';
+is $url->is_ipv4, 1,                'is an IPv4 address';
+is $url->is_ipv6, 1,                'is an IPv6 address';