Implement procedures to encode and decode URLs.

diff --git a/v7/src/imail/imail.pkg b/v7/src/imail/imail.pkg
index f56729e6e37c59aa3a6b492348726a80a2e87b02..7878062d4b7778302f0df57c5def445a373fc4fe 100644 (file)
--- a/v7/src/imail/imail.pkg
+++ b/v7/src/imail/imail.pkg
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail.pkg,v 1.2 2000/04/07 19:38:55 cph Exp $
+;;; $Id: imail.pkg,v 1.3 2000/04/12 02:25:56 cph Exp $
 ;;;
 ;;; Copyright (c) 2000 Massachusetts Institute of Technology
 ;;;
@@ -35,4 +35,15 @@
   (parent (edwin))
   (import (edwin rmail)
          guarantee-rmail-variables-initialized
-         rmail-spool-directory))
\ No newline at end of file
+         rmail-spool-directory))
+
+(define-package (edwin url)
+  (files "url")
+  (parent (edwin))
+  (export (edwin)
+         url:decode-string
+         url:decode-substring
+         url:encode-string
+         url:encode-substring
+         url:string-encoded?
+         url:substring-encoded?))
\ No newline at end of file

diff --git a/v7/src/imail/url.scm b/v7/src/imail/url.scm
new file mode 100644 (file)
index 0000000..71408a3
--- /dev/null
+++ b/v7/src/imail/url.scm
@@ -0,0 +1,123 @@
+;;; -*-Scheme-*-
+;;;
+;;; $Id: url.scm,v 1.1 2000/04/12 02:26:05 cph Exp $
+;;;
+;;; Copyright (c) 2000 Massachusetts Institute of Technology
+;;;
+;;; This program is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU General Public License as
+;;; published by the Free Software Foundation; either version 2 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;;; URL Encoding
+
+(declare (usual-integrations))
+\f
+(define url:char-set:safe
+  (char-set-difference
+   char-set:graphic
+   (char-set #\space #\< #\> #\" #\# #\% #\{ #\} #\| #\\ #\^ #\~ #\[ #\] #\`)))
+
+(define url:char-set:must-encode
+  (char-set-invert url:char-set:safe))
+
+(define url:encoded-char-regexp
+  "%[0-9A-Fa-f][0-9A-Fa-f]")
+
+(define (url:string-encoded? string)
+  (url:substring-encoded? string 0 (string-length string)))
+
+(define (url:encode-string string)
+  (url:encode-substring string 0 (string-length string)))
+
+(define (url:decode-string string)
+  (url:decode-substring string 0 (string-length string)))
+
+(define url:substring-encoded?
+  (let ((pattern
+        (re-compile-pattern
+         (string-append
+          (regexp-group
+           (char-set->regexp-char-range url:char-set:safe)
+           url:encoded-char-regexp)
+          "*")
+         #f)))
+    (lambda (string start end)
+      (let ((regs (re-substring-match pattern string start end)))
+       (and regs
+            (fix:= end (re-match-end-index 0 regs)))))))
+\f
+(define (url:encode-substring string start end)
+  (let ((n-to-encode
+        (let loop ((start start) (n-to-encode 0))
+          (let ((index
+                 (substring-find-next-char-in-set string start end
+                                                  url:char-set:must-encode)))
+            (if index
+                (loop (fix:+ index 1) (fix:+ n-to-encode 1))
+                n-to-encode)))))
+    (if (fix:= 0 n-to-encode)
+       (substring string start end)
+       (let ((encoded
+              (make-string (fix:+ (fix:- end start) (fix:* 2 n-to-encode))))
+             (digits "0123456789ABCDEF"))
+         (let loop ((start start) (i 0))
+           (let ((index
+                  (substring-find-next-char-in-set string start end
+                                                   url:char-set:must-encode)))
+             (if index
+                 (begin
+                   (substring-move-left! string start index encoded i)
+                   (let ((i (fix:+ i (fix:- index start)))
+                         (code (vector-8b-ref string index)))
+                     (string-set! encoded i #\%)
+                     (string-set! encoded
+                                  (fix:+ i 1)
+                                  (string-ref digits (fix:lsh code -4)))
+                     (string-set! encoded
+                                  (fix:+ i 2)
+                                  (string-ref digits (fix:and code #x0F)))
+                     (loop (fix:+ index 1) (fix:+ i 3))))
+                 (substring-move-left! string start end
+                                       encoded i))))
+         encoded))))
+
+(define (url:decode-substring string start end)
+  (let ((n-encoded
+        (let loop ((start start) (n-encoded 0))
+          (let ((regs
+                 (re-substring-search-forward url:encoded-char-regexp
+                                              string start end)))
+            (if regs
+                (loop (re-match-end-index 0 regs) (fix:+ n-encoded 1))
+                n-encoded)))))
+    (if (fix:= 0 n-encoded)
+       (substring string start end)
+       (let ((decoded
+              (make-string (fix:- (fix:- end start) (fix:* 2 n-encoded)))))
+         (let loop ((start start) (i 0))
+           (let ((regs
+                  (re-substring-search-forward url:encoded-char-regexp
+                                               string start end)))
+             (if regs
+                 (let ((index (re-match-start-index 0 regs)))
+                   (substring-move-left! string start index decoded i)
+                   (let ((i (fix:+ i (fix:- index start))))
+                     (vector-8b-set!
+                      decoded i
+                      (substring->number string
+                                          (fix:+ index 1)
+                                          (fix:+ index 3)
+                                          16))
+                     (loop (fix:+ index 3) (fix:+ i 1))))
+                 (substring-move-left! string start end decoded i))))
+         decoded))))
\ No newline at end of file

diff --git a/v7/src/runtime/url.scm b/v7/src/runtime/url.scm
new file mode 100644 (file)
index 0000000..71408a3
--- /dev/null
+++ b/v7/src/runtime/url.scm
@@ -0,0 +1,123 @@
+;;; -*-Scheme-*-
+;;;
+;;; $Id: url.scm,v 1.1 2000/04/12 02:26:05 cph Exp $
+;;;
+;;; Copyright (c) 2000 Massachusetts Institute of Technology
+;;;
+;;; This program is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU General Public License as
+;;; published by the Free Software Foundation; either version 2 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;;; URL Encoding
+
+(declare (usual-integrations))
+\f
+(define url:char-set:safe
+  (char-set-difference
+   char-set:graphic
+   (char-set #\space #\< #\> #\" #\# #\% #\{ #\} #\| #\\ #\^ #\~ #\[ #\] #\`)))
+
+(define url:char-set:must-encode
+  (char-set-invert url:char-set:safe))
+
+(define url:encoded-char-regexp
+  "%[0-9A-Fa-f][0-9A-Fa-f]")
+
+(define (url:string-encoded? string)
+  (url:substring-encoded? string 0 (string-length string)))
+
+(define (url:encode-string string)
+  (url:encode-substring string 0 (string-length string)))
+
+(define (url:decode-string string)
+  (url:decode-substring string 0 (string-length string)))
+
+(define url:substring-encoded?
+  (let ((pattern
+        (re-compile-pattern
+         (string-append
+          (regexp-group
+           (char-set->regexp-char-range url:char-set:safe)
+           url:encoded-char-regexp)
+          "*")
+         #f)))
+    (lambda (string start end)
+      (let ((regs (re-substring-match pattern string start end)))
+       (and regs
+            (fix:= end (re-match-end-index 0 regs)))))))
+\f
+(define (url:encode-substring string start end)
+  (let ((n-to-encode
+        (let loop ((start start) (n-to-encode 0))
+          (let ((index
+                 (substring-find-next-char-in-set string start end
+                                                  url:char-set:must-encode)))
+            (if index
+                (loop (fix:+ index 1) (fix:+ n-to-encode 1))
+                n-to-encode)))))
+    (if (fix:= 0 n-to-encode)
+       (substring string start end)
+       (let ((encoded
+              (make-string (fix:+ (fix:- end start) (fix:* 2 n-to-encode))))
+             (digits "0123456789ABCDEF"))
+         (let loop ((start start) (i 0))
+           (let ((index
+                  (substring-find-next-char-in-set string start end
+                                                   url:char-set:must-encode)))
+             (if index
+                 (begin
+                   (substring-move-left! string start index encoded i)
+                   (let ((i (fix:+ i (fix:- index start)))
+                         (code (vector-8b-ref string index)))
+                     (string-set! encoded i #\%)
+                     (string-set! encoded
+                                  (fix:+ i 1)
+                                  (string-ref digits (fix:lsh code -4)))
+                     (string-set! encoded
+                                  (fix:+ i 2)
+                                  (string-ref digits (fix:and code #x0F)))
+                     (loop (fix:+ index 1) (fix:+ i 3))))
+                 (substring-move-left! string start end
+                                       encoded i))))
+         encoded))))
+
+(define (url:decode-substring string start end)
+  (let ((n-encoded
+        (let loop ((start start) (n-encoded 0))
+          (let ((regs
+                 (re-substring-search-forward url:encoded-char-regexp
+                                              string start end)))
+            (if regs
+                (loop (re-match-end-index 0 regs) (fix:+ n-encoded 1))
+                n-encoded)))))
+    (if (fix:= 0 n-encoded)
+       (substring string start end)
+       (let ((decoded
+              (make-string (fix:- (fix:- end start) (fix:* 2 n-encoded)))))
+         (let loop ((start start) (i 0))
+           (let ((regs
+                  (re-substring-search-forward url:encoded-char-regexp
+                                               string start end)))
+             (if regs
+                 (let ((index (re-match-start-index 0 regs)))
+                   (substring-move-left! string start index decoded i)
+                   (let ((i (fix:+ i (fix:- index start))))
+                     (vector-8b-set!
+                      decoded i
+                      (substring->number string
+                                          (fix:+ index 1)
+                                          (fix:+ index 3)
+                                          16))
+                     (loop (fix:+ index 3) (fix:+ i 1))))
+                 (substring-move-left! string start end decoded i))))
+         decoded))))
\ No newline at end of file