From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 12 Apr 2000 02:26:05 +0000 (+0000)
Subject: Implement procedures to encode and decode URLs.
X-Git-Tag: 20090517-FFI~4048
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=221020a96b30b7086b4ebe716a19d317d7c25124;p=mit-scheme.git

Implement procedures to encode and decode URLs.
---

diff --git a/v7/src/imail/imail.pkg b/v7/src/imail/imail.pkg
index f56729e6e..7878062d4 100644
--- 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
index 000000000..71408a39e
--- /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))
+
+(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)))))))
+
+(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
index 000000000..71408a39e
--- /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))
+
+(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)))))))
+
+(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