summaryrefslogtreecommitdiffstats
path: root/uri.scm
diff options
context:
space:
mode:
Diffstat (limited to 'uri.scm')
-rw-r--r--uri.scm139
1 files changed, 129 insertions, 10 deletions
diff --git a/uri.scm b/uri.scm
index 0fe685f..6a02827 100644
--- a/uri.scm
+++ b/uri.scm
@@ -8,7 +8,7 @@
;1. Any copy made of this software must include this copyright notice
;in full.
;
-;2. I have made no warrantee or representation that the operation of
+;2. I have made no warranty or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
@@ -17,11 +17,13 @@
;promotional, or sales literature without prior written consent in
;each case.
-(require 'coerce)
+(require 'scanf)
(require 'printf)
+(require 'coerce)
(require 'string-case)
(require 'string-search)
(require 'common-list-functions)
+(require-if 'compiling 'directory) ; path->uri uses current-directory
;;@code{(require 'uri)}
;;@ftindex uri
@@ -67,10 +69,12 @@
(cond ((string? path) (uric:encode path "/$,;:@&=+"))
((null? path) "")
((list? path) (uri:make-path path))
- (else path))
+ (else (or path "")))
(if query (sprintf #f "?%s" (uric:encode query "?/$,;:@&=+")) "")
(if fragment (sprintf #f "#%s" (uric:encode fragment "?/$,;:@&=+")) ""))))
+;;@body
+;;Returns a URI string combining the components of list @1.
(define (uri:make-path path)
(apply string-append
(uric:encode (car path) "$,;:@&=+")
@@ -108,12 +112,23 @@
(define (html:isindex prompt)
(sprintf #f "<ISINDEX PROMPT=\"%s\">" prompt))
-;;@body Returns a list of 5 elements corresponding to the parts
+(define (uri:scheme? str)
+ (let ((lst (scanf-read-list "%[-+.a-zA-Z0-9] %s" str)))
+ (and (list? lst)
+ (eqv? 1 (length lst))
+ (char-alphabetic? (string-ref str 0)))))
+
+;;@args uri-reference base-tree
+;;@args uri-reference
+;;
+;;Returns a list of 5 elements corresponding to the parts
;;(@var{scheme} @var{authority} @var{path} @var{query} @var{fragment})
;;of string @1. Elements corresponding to absent parts are #f.
;;
;;The @var{path} is a list of strings. If the first string is empty,
-;;then the path is absolute; otherwise relative.
+;;then the path is absolute; otherwise relative. The optional @2 is a
+;;tree as returned by @0; and is used as the base address for relative
+;;URIs.
;;
;;If the @var{authority} component is a
;;@dfn{Server-based Naming Authority}, then it is a list of the
@@ -133,9 +148,11 @@
(lambda (scheme authority path query fragment)
(define uri-empty?
(and (equal? "" path) (not scheme) (not authority) (not query)))
- (list (if scheme
+ (list (if (and scheme (uri:scheme? scheme))
(string-ci->symbol scheme)
- b-scheme)
+ (cond ((not scheme) b-scheme)
+ (else (slib:warn 'uri->tree 'bad 'scheme scheme)
+ b-scheme)))
(if authority
(uri:decode-authority authority)
b-authority)
@@ -150,7 +167,7 @@
(or (and fragment (uric:decode fragment))
(and uri-empty? b-fragment))))
split))
- (if (or (car split) (null? base-tree) (car split))
+ (if (or (car split) (null? base-tree))
'(#f #f #f #f #f)
(car base-tree))))
@@ -197,7 +214,9 @@
(if (or userinfo port)
(list userinfo host (or (string->number port) port))
host)))
-
+;;@args txt chr
+;;Returns a list of @1 split at each occurrence of @2. @2 does not
+;;appear in the returned list of strings.
(define uri:split-fields
(let ((cr (integer->char #xd)))
(lambda (txt chr)
@@ -212,7 +231,7 @@
chr))
(list txt)))))
-;; @body Converts a @dfn{URI} encoded @1 to a query-alist.
+;;@body Converts a @dfn{URI} encoded @1 to a query-alist.
(define (uri:decode-query query-string)
(set! query-string (string-subst query-string " " "" "+" " "))
(do ((lst '())
@@ -311,9 +330,109 @@
(else uri)))
(sub uri-component))
+;;@body @1 is a path-list as returned by @code{uri:split-fields}. @0
+;;returns a list of items returned by @code{uri:decode-path}, coerced
+;;to types @2.
(define (uri:path->keys path-list ptypes)
(and (not (null? path-list))
(not (equal? '("") path-list))
(let ((path (uri:decode-path (map uric:decode path-list) #f)))
(and (= (length path) (length ptypes))
(map coerce path ptypes)))))
+
+;;@subheading File-system Locators and Predicates
+
+;;@body Returns a URI-string for @1 on the local host.
+(define (path->uri path)
+ (require 'directory)
+ (if (absolute-path? path)
+ (sprintf #f "file:%s" path)
+ (sprintf #f "file:%s/%s" (current-directory) path)))
+
+;;@body Returns #t if @1 is an absolute-URI as indicated by a
+;;syntactically valid (per RFC 2396) @dfn{scheme}; otherwise returns
+;;#f.
+(define (absolute-uri? str)
+ (let ((lst (scanf-read-list "%[-+.a-zA-Z0-9]:%s" str)))
+ (and (list? lst)
+ (eqv? 2 (length lst))
+ (char-alphabetic? (string-ref str 0)))))
+
+;;@body Returns #t if @1 is a fully specified pathname (does not
+;;depend on the current working directory); otherwise returns #f.
+(define (absolute-path? file-name)
+ (and (string? file-name)
+ (positive? (string-length file-name))
+ (memv (string-ref file-name 0) '(#\\ #\/))))
+
+;;@body Returns #t if changing directory to @1 would leave the current
+;;directory unchanged; otherwise returns #f.
+(define (null-directory? str)
+ (member str '("" "." "./" ".\\")))
+
+;;@body Returns #t if the string @1 contains characters used for
+;;specifying glob patterns, namely @samp{*}, @samp{?}, or @samp{[}.
+(define (glob-pattern? str)
+ (let loop ((idx (+ -1 (string-length str))))
+ (if (negative? idx)
+ #f
+ (case (string-ref str idx)
+ ((#\* #\[ #\?) #t)
+ (else (loop (+ -1 idx)))))))
+
+;;@noindent
+;;Before RFC 2396, the @dfn{File Transfer Protocol} (FTP) served a
+;;similar purpose.
+
+;;@body
+;;Returns a list of the decoded FTP @1; or #f if indecipherable. FTP
+;;@dfn{Uniform Resource Locator}, @dfn{ange-ftp}, and @dfn{getit}
+;;formats are handled. The returned list has four elements which are
+;;strings or #f:
+;;
+;;@enumerate 0
+;;@item
+;;username
+;;@item
+;;password
+;;@item
+;;remote-site
+;;@item
+;;remote-directory
+;;@end enumerate
+(define (parse-ftp-address uri)
+ (let ((length? (lambda (len lst) (and (eqv? len (length lst)) lst))))
+ (cond
+ ((not uri) #f)
+ ((length? 1 (scanf-read-list " ftp://%s %s" uri))
+ => (lambda (host)
+ (let ((login #f) (path #f) (dross #f))
+ (sscanf (car host) "%[^/]/%[^@]%s" login path dross)
+ (and login
+ (append (cond
+ ((length? 2 (scanf-read-list "%[^@]@%[^@]%s" login))
+ => (lambda (userpass@hostport)
+ (append
+ (cond ((length? 2 (scanf-read-list
+ "%[^:]:%[^@/]%s"
+ (car userpass@hostport))))
+ (else (list (car userpass@hostport) #f)))
+ (cdr userpass@hostport))))
+ (else (list "anonymous" #f login)))
+ (list path))))))
+ (else
+ (let ((user@site #f) (colon #f) (path #f) (dross #f))
+ (case (sscanf uri " %[^:]%[:]%[^@] %s" user@site colon path dross)
+ ((2 3)
+ (let ((user #f) (site #f))
+ (cond ((or (eqv? 2 (sscanf user@site "/%[^@/]@%[^@]%s"
+ user site dross))
+ (eqv? 2 (sscanf user@site "%[^@/]@%[^@]%s"
+ user site dross)))
+ (list user #f site path))
+ ((eqv? 1 (sscanf user@site "@%[^@]%s" site dross))
+ (list #f #f site path))
+ (else (list #f #f user@site path)))))
+ (else
+ (let ((site (scanf-read-list " %[^@/] %s" uri)))
+ (and (length? 1 site) (list #f #f (car site) #f))))))))))