From 12afcd2c2c0e2d0062db8d88a4399576bbde3895 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sat, 4 Oct 2008 13:26:17 -0500
Subject: [PATCH] add relative-url to urls

---
 basis/urls/urls-docs.factor | 6 ++++++
 basis/urls/urls.factor      | 2 ++
 2 files changed, 8 insertions(+)

diff --git a/basis/urls/urls-docs.factor b/basis/urls/urls-docs.factor
index 03ffaded05..dc61623571 100644
--- a/basis/urls/urls-docs.factor
+++ b/basis/urls/urls-docs.factor
@@ -135,6 +135,12 @@ HELP: relative-url
     }
 } ;
 
+HELP: relative-url?
+{ $values
+     { "url" url }
+     { "?" "a boolean" } }
+{ $description "Tests whether a given url is relative to a domain." } ;
+
 HELP: secure-protocol?
 { $values { "protocol" string } { "?" "a boolean" } }
 { $description "Tests if protocol connections must be made with secure sockets (SSL/TLS)." }
diff --git a/basis/urls/urls.factor b/basis/urls/urls.factor
index 30e8c68f9d..597cdfdb7f 100644
--- a/basis/urls/urls.factor
+++ b/basis/urls/urls.factor
@@ -155,6 +155,8 @@ PRIVATE>
         f >>host
         f >>port ;
 
+: relative-url? ( url -- ? ) protocol>> not ;
+
 ! Half-baked stuff follows
 : secure-protocol? ( protocol -- ? )
     "https" = ;