/[guile]/guile/guile-www/url.scm
ViewVC logotype

Diff of /guile/guile-www/url.scm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.5 by ttn, Sat Nov 17 01:54:05 2001 UTC revision 1.6 by ttn, Sat Apr 27 02:04:01 2002 UTC
# Line 1  Line 1 
1  ;;;; www/url.scm: URL manipulation tools.  ;;; www/url.scm --- URL manipulation tools
2    
3  ;;;;    Copyright (C) 1997,2001 Free Software Foundation, Inc.  ;;      Copyright (C) 1997,2001,2002 Free Software Foundation, Inc.
4  ;;;;  ;;
5  ;;;; This program is free software; you can redistribute it and/or modify  ;; This program is free software; you can redistribute it and/or modify
6  ;;;; it under the terms of the GNU General Public License as published by  ;; it under the terms of the GNU General Public License as published by
7  ;;;; the Free Software Foundation; either version 2, or (at your option)  ;; the Free Software Foundation; either version 2, or (at your option)
8  ;;;; any later version.  ;; any later version.
9  ;;;;  ;;
10  ;;;; This program is distributed in the hope that it will be useful,  ;; This program is distributed in the hope that it will be useful,
11  ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of  ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12  ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the  ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
13  ;;;; GNU General Public License for more details.  ;; GNU General Public License for more details.
14  ;;;;  ;;
15  ;;;; You should have received a copy of the GNU General Public License  ;; You should have received a copy of the GNU General Public License
16  ;;;; along with this software; see the file COPYING.  If not, write to  ;; along with this software; see the file COPYING.  If not, write to
17  ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,  ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
18  ;;;; Boston, MA 02111-1307 USA  ;; Boston, MA 02111-1307 USA
19  ;;;;  ;;
20    
21  ;;; Commentary:  ;;; Commentary:
22    
# Line 40  Line 40 
40  ;;; Code:  ;;; Code:
41    
42    
43  ;;;; TODO:  ;; TODO:
44  ;;;;   * support `user:password@' strings where appropriate in URLs.  ;;   * support `user:password@' strings where appropriate in URLs.
45  ;;;;   * make URL parsing smarter.  This is good for most TCP/IP-based  ;;   * make URL parsing smarter.  This is good for most TCP/IP-based
46  ;;;;     URL schemes, but parsing is actually specific to each URL scheme.  ;;       URL schemes, but parsing is actually specific to each URL scheme.
47  ;;;;   * fill out url:encode, include facilities for URL-scheme-specific  ;;   * fill out url:encode, include facilities for URL-scheme-specific
48  ;;;;     encoding methods (e.g. a url-scheme-reserved-char-alist)  ;;     encoding methods (e.g. a url-scheme-reserved-char-alist)
49    
50  (define-module (www url)  (define-module (www url)
51    :use-module (ice-9 regex))    :use-module (ice-9 regex))
# Line 101  Line 101 
101    
102    
103  (define-public (url:unparse url)  (define-public (url:unparse url)
104    (define (pathy scheme username host port path)    (define (pathy scheme username url)   ; username not used!
105      (string-append (symbol->string scheme)      (format #f "~A://~A~A~A"
106                     "://" host              scheme
107                     (if port (string-append ":" (number->string port))              (url:host url)
108                         "")              (cond ((url:port url) => (lambda (port) (format #f ":~A" port)))
109                     (if path (string-append "/" path)                    (else ""))
110                         "")))              (cond ((url:path url) => (lambda (path) (format #f "/~A" path)))
111                      (else ""))))
112    (case (url:scheme url)    (case (url:scheme url)
113      ((http) (pathy 'http #f      ((http) (pathy 'http #f url))
114                     (url:host url)      ((ftp)  (pathy 'ftp (url:user url) url))
115                     (url:port url)      ((mailto) (format #f "mailto:~A" (url:address url)))
                    (url:path url)))  
     ((ftp)  (pathy 'ftp  
                    (url:user url)  
                    (url:host url)  
                    (url:port url)  
                    (url:path url)))  
     ((mailto) (string-append "mailto:" (url:address url)))  
116      ((unknown) (url:unknown url))))      ((unknown) (url:unknown url))))
117    
118    
# Line 130  Line 124 
124  ;; important for code that frequently gets restarted)?  ;; important for code that frequently gets restarted)?
125    
126  (define-public (url:decode str)  (define-public (url:decode str)
127    (regexp-substitute/global #f "\\+|%([0-9A-Fa-f][0-9A-Fa-f])" str    (regexp-substitute/global
128      'pre     #f "\\+|%([0-9A-Fa-f][0-9A-Fa-f])" str
129      (lambda (m)     'pre
130        (cond ((string=? "+" (match:substring m 0)) " ")     (lambda (m)
131              (else (integer->char       (cond ((string=? "+" (match:substring m 0)) " ")
132                     (string->number             (else (integer->char
133                      (match:substring m 1)                    (string->number
134                      16)))))                     (match:substring m 1)
135      'post))                     16)))))
136       'post))
137    
138  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
139  ;; (url-encode STR)  ;; (url-encode STR)

Legend:
Removed from v.1.5  
changed lines
  Added in v.1.6

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26