Commit 9b69250a authored by Vladimir Sedach's avatar Vladimir Sedach

Finally put this under source control

parents
0.9:
----
* Renamed *encode-uri-string* to uri-encode? (INCOMPATIBLE CHANGE)
* Renamed *decode-uri-string* to uri-decode? (INCOMPATIBLE CHANGE)
* Got rid of bind-standard-uri-components macro (INCOMPATIBLE CHANGE)
* Decision whether or not to uri encode/decode template parts is now taken at macro-expansion instead of run-time (INCOMPATIBLE CHANGE)
* Got rid of cl-ppcre:register-groups-bind style (#'parse-number foo) template binding support (INCOMPATIBLE CHANGE)
* Added Named-Readtables uri-template readtable
* Made template placeholders be an implicit progn
* Made %uri- parameters be lexical anaphors instead of special variables
* Fixed bug where %uri- parameters weren't getting uri-decoded
* Got rid of KMRCL dependency
0.8:
----
* Added %uri-head and %uri-tail convenience parameters (thanks to Roman Zaharof for the patch).
0.7:
----
* Fixed bugs in standard-uri-components regular expression (thanks to Roman Zaharof for the bug report).
0.6:
----
* Changed uri-template-bind lambda-list to resemble that of destructuring-bind
0.5:
----
* Added option to do URI decoding in URI template destructuring (on by default)
0.4:
----
* Fixed bug where strings inserted into templates were not being URI encoded
0.3:
----
* Added URI encoding support for template interpolation. URI encoding is controlled by the *encode-uri-string* flag
* Added interpolation support for Parenscript
* Added URI template destructuring
Copyright (c) 2007, 2008, 2009 Vladimir Sedach
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met: Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.
Neither the name of the copyright holder nor the names of its
contributors may be used to endorse or promote products derived from
this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR
CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
uri-template is an implementation of the URI Template proposed
standard draft version 01
(http://tools.ietf.org/html/draft-gregorio-uritemplate-01) as a reader
macro, used for both template interpolation and URI destructuring.
Although uri-template does not implement the operators introduced in
the 02 and later drafts of the URI Template standard, it does allow
arbitrary Lisp expressions in template placeholders, which gives
simpler and more powerful templates.
For more information about uri-template, see the project homepage:
http://common-lisp.net/project/uri-template/
The uri-template mailing list is uri-template-devel@common-lisp.net.
Any questions, bug reports and patches are welcome. You can subscribe
by visiting:
http://common-lisp.net/cgi-bin/mailman/listinfo/uri-template-devel
The author, Vladimir Sedach, can be contacted at vsedach@gmail.com.
For license and copyright information (BSD), see the file COPYING
included with the distribution.
(in-package #:uri-template)
(defvar uri-decode? t)
(defun uri-decode (str)
(regex-replace-all "%[\\d|a-f|A-F]{2}" str (lambda (match) (string (code-char (parse-integer match :start 1 :radix 16)))) :simple-calls t))
(defmacro weak-register-groups-bind (vars regex str &body body)
`(destructuring-bind (&optional ,@vars)
(coerce (nth-value 1 (scan-to-strings ,regex ,str)) 'list)
(declare (ignorable ,@vars))
,(when uri-decode?
`(setf ,@(loop for var in vars append `(,var (when ,var (uri-decode ,var))))))
,@body))
(defmacro uri-template-bind ((template) uri &body body)
"Binds URI template placeholders (which must be symbols) in given
URI, as well as attempting to bind a set of standard uri
components (anaphoric variables %uri-protocol, %uri-host, etc.) to
their respective parts of the given URI. Body executes only if all URI
template placeholders can be bound."
(let* ((template (cdr template)) ;; template is expected to look like output of #U: '(uri-template &rest args)
(template-vars (mapcar (lambda (x) (car (last (second x)))) (remove-if #'stringp template)))
(uri-var (gensym)))
`(let ((,uri-var ,uri))
(weak-register-groups-bind (%uri-head x1 %uri-scheme x2 %uri-authority %uri-tail %uri-path x3 %uri-query x4 %uri-fragment)
;; regex adapted from RFC 2396: "^(([^:/?#]+):)?(//([^/?#]*))?([^?#]*)(\\?([^#]*))?(#(.*))?"
"^((([^:/?#]+):)?(//([^/?#]*)))?(([^?#]*)(\\?([^#]*))?(#(.*))?)" ,uri-var
(weak-register-groups-bind (x1 %uri-user %uri-host x2 %uri-port)
"(([^@]+)@)?([^\\:]+)(\\:(\\d+))?" %uri-authority
(weak-register-groups-bind (%uri-directory %uri-file)
"(.*/)([^/]+)?" %uri-path
(weak-register-groups-bind ,template-vars
'(:sequence :start-anchor ,@(substitute-if '(:register (:greedy-repetition 0 nil :everything)) (complement #'stringp) template) :end-anchor) ,uri-var
(when (and ,@template-vars)
,@body))))))))
(in-package #:cl)
(defpackage #:uri-template
(:use #:cl #:cl-ppcre #:named-readtables)
(:export
;; common
#:uri-template
;; interpolation
#:enable-uri-template-syntax
#:read-uri-template
#:uri-encode?
;; destructuring
#:uri-template-bind
#:uri-decode?
;; RFC 2396 standard URI components
#:%uri-scheme
#:%uri-authority
#:%uri-path
#:%uri-query
#:%uri-fragment
;; extended components
#:%uri-head
#:%uri-tail
#:%uri-user
#:%uri-host
#:%uri-port
#:%uri-directory
#:%uri-file))
(in-package #:uri-template)
(defreadtable uri-template
(:merge :standard)
(:dispatch-macro-char #\# #\U (lambda (&rest args) (apply #'uri-template-reader args))))
(in-package #:cl)
(defpackage #:uri-template.test
(:use #:cl #:uri-template #:named-readtables)
(:export #:run-tests))
(in-package #:uri-template.test)
(defreadtable uri-template.test
(:merge :standard uri-template:uri-template))
(in-package #:uri-template.test)
(in-readtable uri-template.test)
(defun run-tests ()
(run-interpolation-tests)
(run-destructuring-tests))
(defun run-interpolation-tests ()
(let ((baz 1)
(bar "bar"))
(assert (string= #Uhttp://www.foo.com/bar/{baz}
"http://www.foo.com/bar/1"))
(assert (string= #Uhttp://www.foo.com/bar/{bar}/{baz}
"http://www.foo.com/bar/bar/1"))
(assert (string= #Uhttp://www.foo.com/bar/{bar}{baz}
"http://www.foo.com/bar/bar1"))
(assert (string= #Uhttp://www.foo.com/bar?foo={"^BAZ !bar"}
"http://www.foo.com/bar?foo=^BAZ%20%21bar"))))
(defun run-destructuring-tests ()
(assert (equal (uri-template-bind (#Uhttp://www.factory.com/orders/{part}/{number})
"http://www.factory.com/orders/widget/1234"
(list part (parse-integer number) %uri-host))
'("widget" 1234 "www.factory.com")))
(assert (equal (uri-template-bind (#U{uri})
"https://www.google.com/dir/1/2/search.html?arg=0-a&arg1=1-b&arg3-c#hash"
(list %uri-scheme %uri-host %uri-path %uri-directory %uri-file %uri-query %uri-fragment))
'("https" "www.google.com" "/dir/1/2/search.html" "/dir/1/2/" "search.html" "arg=0-a&arg1=1-b&arg3-c" "hash")))
(assert (equal (uri-template:uri-template-bind (#U/apps/{app-name}/{table-template}/{table-id})
"/apps/EVWeb/Fixed%20Cost/20"
(list app-name table-template table-id %uri-path))
'("EVWeb" "Fixed Cost" "20" "/apps/EVWeb/Fixed Cost/20")))
(assert (equal (uri-template-bind (#U{uri})
"http://files3.dsv.data.cod.ru/?WyIyNWQ3NWU5NTRmZDU1MWIzYmQ5NzVjNzJhZjRkZmNhZSIsMTI1MTA5NjMxNCwiXHUwNDEwXHUwNDNiXHUwNDRjXHUwNDRmXHUwNDNkXHUwNDQxIFx1MDQ0MVx1MDQzNVx1MDQ0MFx1MDQzZVx1MDQzYVx1MDQ0MFx1MDQ0Ylx1MDQzYlx1MDQ0Ylx1MDQ0NS5yYXIiLCJrTzNqSUo3bUN5WlBPenlBVGdcL0M3UkZVWHdXYkN6SWtEYzUweTl5a1lOVCtTRmlwVFdsN1UxWlVybGVLNjMyaGlYc0hvVDhGZitGWUt6eGVVRGxOVkxUN3R0MndLYjg4VGFjYmZSVnhrZjNYQXdZalpYemVEQXM4bmxzK0RCbnZEcnZQTmRMKytDS05pNjVJXC8yb2JnY0N1RmdyK1lpS0VSak8rNVZSeTIrcz0iXQ%3D%3D"
(list %uri-scheme %uri-authority %uri-path %uri-directory %uri-file %uri-query %uri-fragment))
'("http" "files3.dsv.data.cod.ru" "/" "/" nil "WyIyNWQ3NWU5NTRmZDU1MWIzYmQ5NzVjNzJhZjRkZmNhZSIsMTI1MTA5NjMxNCwiXHUwNDEwXHUwNDNiXHUwNDRjXHUwNDRmXHUwNDNkXHUwNDQxIFx1MDQ0MVx1MDQzNVx1MDQ0MFx1MDQzZVx1MDQzYVx1MDQ0MFx1MDQ0Ylx1MDQzYlx1MDQ0Ylx1MDQ0NS5yYXIiLCJrTzNqSUo3bUN5WlBPenlBVGdcL0M3UkZVWHdXYkN6SWtEYzUweTl5a1lOVCtTRmlwVFdsN1UxWlVybGVLNjMyaGlYc0hvVDhGZitGWUt6eGVVRGxOVkxUN3R0MndLYjg4VGFjYmZSVnhrZjNYQXdZalpYemVEQXM4bmxzK0RCbnZEcnZQTmRMKytDS05pNjVJXC8yb2JnY0N1RmdyK1lpS0VSak8rNVZSeTIrcz0iXQ==" nil)))
(assert (equal (uri-template-bind (#U{uri})
"http://www.foo.com/abc?bar=baz&xyz=1"
(list %uri-scheme %uri-host %uri-path %uri-directory %uri-file %uri-query %uri-fragment %uri-head %uri-tail))
'("http" "www.foo.com" "/abc" "/" "abc" "bar=baz&xyz=1" nil "http://www.foo.com" "/abc?bar=baz&xyz=1")))
(assert (equal (uri-template-bind (#U{uri})
"http://www.foo.com/?bar=baz&xyz=1"
(list %uri-scheme %uri-host %uri-path %uri-directory %uri-file %uri-query %uri-fragment))
'("http" "www.foo.com" "/" "/" nil "bar=baz&xyz=1" nil)))
(assert (equal (uri-template-bind (#U{uri}) "http://user@host.com:8080/dir1/dir2/file?query=want&a=b#hash"
(list %uri-scheme %uri-authority (list %uri-user %uri-host %uri-port)
%uri-path (list %uri-directory %uri-file) %uri-query %uri-fragment))
'("http" "user@host.com:8080" ("user" "host.com" "8080") "/dir1/dir2/file"
("/dir1/dir2/" "file") "query=want&a=b" "hash")))
(assert (equal (uri-template-bind (#U{uri}) "/foo/bar"
(list %uri-head %uri-tail %uri-scheme
%uri-authority (list %uri-user %uri-host %uri-port)
%uri-path (list %uri-directory %uri-file) %uri-query %uri-fragment))
'(NIL "/foo/bar" NIL NIL (NIL NIL NIL) "/foo/bar" ("/foo/" "bar") NIL NIL))))
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
(asdf:defsystem :uri-template
:serial t
:components ((:file "package")
(:file "uri-template")
(:file "destructure-uri"))
:depends-on (:cl-ppcre :named-readtables))
(asdf:defsystem :uri-template.test
:serial t
:components ((:file "test-package")
(:file "uri-template-test"))
:depends-on (:uri-template))
(in-package #:uri-template)
(defvar uri-encode? t)
(defun uri-encode (str)
(regex-replace-all '(:alternation #\Space #\! #\* #\' #\( #\) #\; #\: #\@ #\& #\= #\+ #\$ #\, #\/ #\? #\# #\[ #\])
str
(lambda (match) (format nil "%~16R" (char-code (elt match 0))))
:simple-calls t))
(defun read-uri-template (stream &optional recursive-p)
(let ((*readtable* (copy-readtable))
(template-accumulator ())
(string-accumulator ())
(next-char))
(set-syntax-from-char #\} #\))
(flet ((collect-string ()
(when string-accumulator
(push (coerce (reverse string-accumulator) 'string) template-accumulator)
(setf string-accumulator ()))))
(loop until (member (setf next-char (read-char stream nil #\Space recursive-p)) '(#\Space #\Newline #\Tab #\)))
do (if (char= #\{ next-char)
(progn (collect-string)
(push `(maybe-uri-encode
(progn ,@(loop until (char= #\} (peek-char t stream))
collect (read stream t nil recursive-p)
finally (read-char stream nil))))
template-accumulator))
(push next-char string-accumulator))
finally (unread-char next-char stream) (collect-string))
(reverse template-accumulator))))
(defmacro maybe-uri-encode (x)
(if uri-encode? `(uri-encode (princ-to-string ,x)) x))
#+parenscript (parenscript:defpsmacro maybe-uri-encode (x)
(if uri-encode? `(encode-u-r-i-component ,x) x))
(defun uri-template (&rest template-args)
(format nil "~{~A~}" template-args))
#+parenscript (parenscript:defpsmacro uri-template (&rest template-args)
`(+ ,@template-args))
(defun uri-template-reader (stream subchar arg)
(declare (ignore subchar arg))
`(uri-template ,@(read-uri-template stream t)))
(defun enable-uri-template-syntax ()
(set-dispatch-macro-character #\# #\U 'uri-template-reader)
(values))
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment