add 'host' method

2 files changed, 25 insertions, 6 deletions

diff --git a/lib/Web/Request.pm b/lib/Web/Request.pm
index fa8cf3a..d0d90e0 100644
--- a/lib/Web/Request.pm
+++ b/lib/Web/Request.pm
@@ -81,10 +81,7 @@ has _base_uri => (
         my $env = $self->env;
 
         my $scheme = $self->scheme || "http";
-        my $server = $env->{HTTP_HOST};
-        $server = ($env->{SERVER_NAME} || '') . ':'
-                . ($env->{SERVER_PORT} || 80)
-            unless defined $server;
+        my $server = $self->host;
         my $path = $self->script_name || '/';
 
         return "${scheme}://${server}${path}";
@@ -431,6 +428,18 @@ sub _new_upload {
     $self->upload_class->new(@_);
 }
 
+sub host {
+    my $self = shift;
+
+    my $env = $self->env;
+    my $host = $env->{HTTP_HOST};
+    $host = ($env->{SERVER_NAME} || '') . ':'
+          . ($env->{SERVER_PORT} || 80)
+        unless defined $host;
+
+    return $host;
+}
+
 sub path {
     my $self = shift;
 
@@ -559,6 +568,12 @@ Returns the HTTP method (GET, POST, etc.) used in the current request.
 
 Returns the local port that this request was made on.
 
+=method host
+
+Returns the contents of the HTTP C<Host> header. If it doesn't exist, falls
+back to recreating the host from the C<SERVER_NAME> and C<SERVER_PORT>
+variables.
+
 =method path
 
 Returns the request path for the current request. Unlike C<path_info>, this
diff --git a/t/base.t b/t/base.t
index af1a4ed..21aab54 100644
--- a/t/base.t
+++ b/t/base.t
@@ -26,11 +26,13 @@ my @tests = (
   { scheme => 'http',
     server_name => 'example.com',
     server_port => 80,
-    base => 'http://example.com/' },
+    base => 'http://example.com/',
+    expected_host => 'example.com:80' },
   { scheme => 'http',
     server_name => 'example.com',
     server_port => 8080,
-    base => 'http://example.com:8080/' },
+    base => 'http://example.com:8080/',
+    expected_host => 'example.com:8080' },
   { host => 'foobar.com',
     server_name => 'example.com',
     server_port => 8080,
@@ -48,6 +50,8 @@ for my $block (@tests) {
 
     my $req = Web::Request->new_from_env($env);
     is $req->base_uri, $block->{base};
+    my $expected_host = $block->{expected_host} || $block->{host};
+    is $req->host, $expected_host;
 }
 
 done_testing;