Move TO-URL from L>server.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51
diff --git a/package.lisp b/package.lisp
index 824abf9..85e57c2 100644
--- a/package.lisp
+++ b/package.lisp
@@ -25,6 +25,8 @@
;; URI
#:canonical-document-uri
#:%-encode-char
+ #:to-url
+ #:unaccent
;; URI Template
#:uri-template
#:uri-template-p
diff --git a/uri.lisp b/uri.lisp
index fe9125c..8d039b9 100644
--- a/uri.lisp
+++ b/uri.lisp
@@ -107,3 +107,33 @@
#+test
(%-encode "plop/%é%C3")
+
+(defun unaccent (c)
+ (or (cl-ppcre:register-groups-bind (name)
+ ("(.*) WITH .*" (cl-unicode:unicode-name c))
+ (cl-unicode:character-named name))
+ c))
+
+(defun to-url (str)
+ (string-trim
+ "-"
+ (with-output-to-string (out)
+ (let ((len (length str)))
+ (labels ((out (c)
+ (write-char (unaccent (char-downcase c)) out))
+ (nohyphen (i)
+ (when (< i len)
+ (let ((c (char str i)))
+ (if (alphanumericp c)
+ (progn (out c)
+ (hyphen (1+ i)))
+ (nohyphen (1+ i))))))
+ (hyphen (i)
+ (when (< i len)
+ (let ((c (char str i)))
+ (if (alphanumericp c)
+ (progn (out c)
+ (hyphen (1+ i)))
+ (progn (write-char #\- out)
+ (nohyphen (1+ i))))))))
+ (nohyphen 0))))))