diff options
Diffstat (limited to 'uri.scm')
| -rw-r--r-- | uri.scm | 139 |
1 files changed, 129 insertions, 10 deletions
@@ -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)))))))))) |