From 4896fba7e8033d63b578676843c2b6240006a902 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 9 Jan 2003 19:44:03 +0000
Subject: [PATCH] Move URL support back to the runtime system.
---
v7/src/imail/compile.scm | 5 +-
v7/src/imail/ed-ffi.scm | 7 +-
v7/src/imail/imail.pkg | 28 +-----
v7/src/imail/url.scm | 179 -------------------------------------
v7/src/runtime/ed-ffi.scm | 6 +-
v7/src/runtime/make.scm | 9 +-
v7/src/runtime/runtime.pkg | 30 ++++++-
v7/src/runtime/runtime.sf | 6 +-
v7/src/runtime/url.scm | 47 ++++++----
9 files changed, 76 insertions(+), 241 deletions(-)
delete mode 100644 v7/src/imail/url.scm
diff --git a/v7/src/imail/compile.scm b/v7/src/imail/compile.scm
index e89ab2976..5f8bf9026 100644
--- a/v7/src/imail/compile.scm
+++ b/v7/src/imail/compile.scm
@@ -1,8 +1,8 @@
;;; -*-Scheme-*-
;;;
-;;; $Id: compile.scm,v 1.17 2002/11/20 19:46:05 cph Exp $
+;;; $Id: compile.scm,v 1.18 2003/01/09 19:43:10 cph Exp $
;;;
-;;; Copyright (c) 2000-2001 Massachusetts Institute of Technology
+;;; Copyright (c) 2000,2001,2003 Massachusetts Institute of Technology
;;;
;;; This file is part of MIT Scheme.
;;;
@@ -28,7 +28,6 @@
(load-option '*PARSER)
(with-working-directory-pathname (directory-pathname (current-load-pathname))
(lambda ()
- (compile-file "url" '() (->environment '(RUNTIME)))
(for-each (lambda (filename)
(compile-file filename '() (->environment '(EDWIN))))
'("imail-browser"
diff --git a/v7/src/imail/ed-ffi.scm b/v7/src/imail/ed-ffi.scm
index 2cab7fbe1..ccbf8b774 100644
--- a/v7/src/imail/ed-ffi.scm
+++ b/v7/src/imail/ed-ffi.scm
@@ -1,8 +1,8 @@
;;; -*-Scheme-*-
;;;
-;;; $Id: ed-ffi.scm,v 1.19 2002/11/20 19:46:05 cph Exp $
+;;; $Id: ed-ffi.scm,v 1.20 2003/01/09 19:43:17 cph Exp $
;;;
-;;; Copyright (c) 2000-2001 Massachusetts Institute of Technology
+;;; Copyright (c) 2000,2001,2003 Massachusetts Institute of Technology
;;;
;;; This file is part of MIT Scheme.
;;;
@@ -34,5 +34,4 @@
("imail-umail" (edwin imail file-folder umail-folder))
("imail-util" (edwin imail))
("imap-response" (edwin imail imap-response))
- ("imap-syntax" (edwin imail imap-syntax))
- ("url" (runtime url))))
\ No newline at end of file
+ ("imap-syntax" (edwin imail imap-syntax))))
\ No newline at end of file
diff --git a/v7/src/imail/imail.pkg b/v7/src/imail/imail.pkg
index 5a7e57b94..bee38ead4 100644
--- a/v7/src/imail/imail.pkg
+++ b/v7/src/imail/imail.pkg
@@ -1,6 +1,6 @@
;;; -*-Scheme-*-
;;;
-;;; $Id: imail.pkg,v 1.97 2002/11/20 19:46:06 cph Exp $
+;;; $Id: imail.pkg,v 1.98 2003/01/09 19:43:23 cph Exp $
;;;
;;; Copyright (c) 2000-2001 Massachusetts Institute of Technology
;;;
@@ -28,32 +28,6 @@
(global-definitions "../edwin/edwin")
(global-definitions "../star-parser/parser")
-(define-package (runtime url)
- (files "url")
- (parent (runtime))
- (export ()
- url:char-set:escaped
- url:char-set:extra
- url:char-set:national
- url:char-set:punctuation
- url:char-set:reserved
- url:char-set:safe
- url:char-set:unescaped
- url:char-set:unreserved
- url:decode-string
- url:decode-substring
- url:encode-string
- url:encode-substring
- url:match:escape
- url:match:host
- url:match:hostname
- url:match:hostnumber
- url:match:uchar
- url:match:xchar
- url:parse:hostport
- url:string-encoded?
- url:substring-encoded?))
-
(define-package (edwin imail)
(files "imail-util"
"imail-core")
diff --git a/v7/src/imail/url.scm b/v7/src/imail/url.scm
deleted file mode 100644
index 7a736ca3a..000000000
--- a/v7/src/imail/url.scm
+++ /dev/null
@@ -1,179 +0,0 @@
-#| -*-Scheme-*-
-
-$Id: url.scm,v 1.12 2002/11/20 19:46:06 cph Exp $
-
-Copyright (c) 2000, 2001 Massachusetts Institute of Technology
-
-This file is part of MIT Scheme.
-
-MIT Scheme 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.
-
-MIT Scheme 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 MIT Scheme; if not, write to the Free Software Foundation,
-Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-
-|#
-
-;;;; URL Encoding
-
-(declare (usual-integrations))
-
-(define url:char-set:safe (string->char-set "$-_.+"))
-(define url:char-set:extra (string->char-set "!*'(),"))
-(define url:char-set:national (string->char-set "{}|\\^~[]`"))
-(define url:char-set:punctuation (string->char-set "<>#%\""))
-(define url:char-set:reserved (string->char-set ";/?:@&="))
-(define url:char-set:hex (string->char-set "0123456789abcdefABCDEF"))
-
-(define url:char-set:unreserved
- (char-set-union char-set:alphanumeric
- url:char-set:safe
- url:char-set:extra))
-
-(define url:char-set:unescaped
- (char-set-union url:char-set:unreserved
- url:char-set:reserved))
-
-(define url:char-set:escaped
- (char-set-invert url:char-set:unescaped))
-
-(define url:match:escape
- (*matcher
- (seq "%"
- (char-set url:char-set:hex)
- (char-set url:char-set:hex))))
-
-(define url:match:uchar
- (*matcher
- (alt (char-set url:char-set:unreserved)
- url:match:escape)))
-
-(define url:match:xchar
- (*matcher
- (alt (char-set url:char-set:unescaped)
- url:match:escape)))
-
-(define url:parse:hostport
- (*parser
- (seq (match url:match:host)
- (alt (map string->number
- (seq (noise ":")
- (match (+ (char-set char-set:numeric)))))
- (values #f)))))
-
-(define url:match:host
- (*matcher (alt url:match:hostname url:match:hostnumber)))
-
-(define url:match:hostname
- (let ((match-tail
- (*matcher
- (* (alt (char-set char-set:alphanumeric)
- (seq (+ #\-)
- (char-set char-set:alphanumeric)))))))
- (*matcher
- (seq (* (seq (char-set char-set:alphanumeric)
- match-tail
- "."))
- (char-set char-set:alphabetic)
- match-tail))))
-
-(define url:match:hostnumber
- (*matcher
- (seq (+ (char-set char-set:numeric))
- "."
- (+ (char-set char-set:numeric))
- "."
- (+ (char-set char-set:numeric))
- "."
- (+ (char-set char-set:numeric)))))
-
-(define (url:string-encoded? string)
- (url:substring-encoded? string 0 (string-length string)))
-
-(define url:substring-encoded?
- (let ((matcher (*matcher (complete (* url:match:xchar)))))
- (lambda (string start end)
- (matcher (substring->parser-buffer string start end)))))
-
-(define (url:encode-string string)
- (url:encode-substring string 0 (string-length string)))
-
-(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:escaped)))
- (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:escaped)))
- (if index
- (begin
- (substring-move! 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! string start end encoded i))))
- encoded))))
-
-(define (url:decode-string string)
- (url:decode-substring string 0 (string-length string)))
-
-(define (url:decode-substring string start end)
- (let ((n-encoded
- (let loop ((start start) (n-encoded 0))
- (let ((index (substring-find-next-char string start end #\%)))
- (if index
- (loop (fix:+ index 1) (fix:+ n-encoded 1))
- n-encoded))))
- (lose
- (lambda ()
- (error "Malformed encoded URL string:"
- (substring string start end)))))
- (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 ((index (substring-find-next-char string start end #\%)))
- (if index
- (begin
- (if (not (fix:<= (fix:+ index 3) end))
- (lose))
- (let ((k
- (substring->number string
- (fix:+ index 1)
- (fix:+ index 3)
- 16))
- (i* (fix:+ i (fix:- index start))))
- (if (not k)
- (lose))
- (substring-move! string start index decoded i)
- (vector-8b-set! decoded i* k)
- (loop (fix:+ index 3) (fix:+ i* 1))))
- (substring-move! string start end decoded i))))
- decoded))))
\ No newline at end of file
diff --git a/v7/src/runtime/ed-ffi.scm b/v7/src/runtime/ed-ffi.scm
index 7ec391f43..0ac5b150b 100644
--- a/v7/src/runtime/ed-ffi.scm
+++ b/v7/src/runtime/ed-ffi.scm
@@ -1,8 +1,9 @@
#| -*- Scheme -*-
-$Id: ed-ffi.scm,v 1.33 2002/11/20 19:46:19 cph Exp $
+$Id: ed-ffi.scm,v 1.34 2003/01/09 19:36:43 cph Exp $
-Copyright (c) 1988-2002 Massachusetts Institute of Technology
+Copyright (c) 1991,1996,1997,1999,2000 Massachusetts Institute of Technology
+Copyright (c) 2001,2002,2003 Massachusetts Institute of Technology
This file is part of MIT Scheme.
@@ -164,6 +165,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
("unxprm" (runtime os-primitives))
("unxpth" (runtime pathname unix))
("uproc" (runtime procedure))
+ ("url" (runtime url))
("urtrap" (runtime reference-trap))
("usrint" (runtime user-interface))
("utabs" (runtime microcode-tables))
diff --git a/v7/src/runtime/make.scm b/v7/src/runtime/make.scm
index f80f8409d..e7f09b84e 100644
--- a/v7/src/runtime/make.scm
+++ b/v7/src/runtime/make.scm
@@ -1,8 +1,10 @@
#| -*-Scheme-*-
-$Id: make.scm,v 14.87 2002/11/20 19:46:21 cph Exp $
+$Id: make.scm,v 14.88 2003/01/09 19:40:16 cph Exp $
-Copyright (c) 1988-2002 Massachusetts Institute of Technology
+Copyright (c) 1988,1989,1990,1991,1992 Massachusetts Institute of Technology
+Copyright (c) 1993,1994,1995,1996,1997 Massachusetts Institute of Technology
+Copyright (c) 1998,2000,2001,2002,2003 Massachusetts Institute of Technology
This file is part of MIT Scheme.
@@ -515,7 +517,8 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
;; Emacs -- last because it installs hooks everywhere which must be initted.
(RUNTIME EMACS-INTERFACE)
;; More debugging
- ((RUNTIME CONTINUATION-PARSER) INITIALIZE-SPECIAL-FRAMES! #f)))
+ ((RUNTIME CONTINUATION-PARSER) INITIALIZE-SPECIAL-FRAMES! #f)
+ (RUNTIME URL)))
(let ((obj (file->object "site" #t #t)))
(if obj
diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 7b43ebc38..d7c15e767 100644
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
#| -*-Scheme-*-
-$Id: runtime.pkg,v 14.421 2003/01/03 01:37:45 cph Exp $
+$Id: runtime.pkg,v 14.422 2003/01/09 19:36:50 cph Exp $
Copyright (c) 1988,1989,1990,1991,1992 Massachusetts Institute of Technology
Copyright (c) 1993,1994,1995,1996,1997 Massachusetts Institute of Technology
@@ -4468,4 +4468,30 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
unicode-code-point?
utf8-string->code-point
well-formed-code-points-list?
- write-utf8-code-point))
\ No newline at end of file
+ write-utf8-code-point))
+
+(define-package (runtime url)
+ (files "url")
+ (parent (runtime))
+ (export ()
+ url:char-set:escaped
+ url:char-set:extra
+ url:char-set:national
+ url:char-set:punctuation
+ url:char-set:reserved
+ url:char-set:safe
+ url:char-set:unescaped
+ url:char-set:unreserved
+ url:decode-string
+ url:decode-substring
+ url:encode-string
+ url:encode-substring
+ url:match:escape
+ url:match:host
+ url:match:hostname
+ url:match:hostnumber
+ url:match:uchar
+ url:match:xchar
+ url:parse:hostport
+ url:string-encoded?
+ url:substring-encoded?))
\ No newline at end of file
diff --git a/v7/src/runtime/runtime.sf b/v7/src/runtime/runtime.sf
index a01e333cc..51085858a 100644
--- a/v7/src/runtime/runtime.sf
+++ b/v7/src/runtime/runtime.sf
@@ -1,8 +1,9 @@
#| -*-Scheme-*-
-$Id: runtime.sf,v 14.18 2002/11/20 19:46:22 cph Exp $
+$Id: runtime.sf,v 14.19 2003/01/09 19:36:56 cph Exp $
-Copyright (c) 1988-2001 Massachusetts Institute of Technology
+Copyright (c) 1988,1989,1990,1991,1992 Massachusetts Institute of Technology
+Copyright (c) 1994,1995,1996,2001,2003 Massachusetts Institute of Technology
This file is part of MIT Scheme.
@@ -22,6 +23,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|#
+(load-option '*PARSER) ;for url.scm
(fluid-let ((sf/default-syntax-table (->environment '(RUNTIME))))
(sf-conditionally "char")
(sf-conditionally "chrset")
diff --git a/v7/src/runtime/url.scm b/v7/src/runtime/url.scm
index 8e972af9a..aa533f76b 100644
--- a/v7/src/runtime/url.scm
+++ b/v7/src/runtime/url.scm
@@ -1,6 +1,6 @@
#| -*-Scheme-*-
-$Id: url.scm,v 1.12 2003/01/09 19:23:54 cph Exp $
+$Id: url.scm,v 1.13 2003/01/09 19:37:03 cph Exp $
Copyright (c) 2000, 2001, 2003 Massachusetts Institute of Technology
@@ -26,24 +26,33 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
(declare (usual-integrations))
-(define url:char-set:safe (string->char-set "$-_.+"))
-(define url:char-set:extra (string->char-set "!*'(),"))
-(define url:char-set:national (string->char-set "{}|\\^~[]`"))
-(define url:char-set:punctuation (string->char-set "<>#%\""))
-(define url:char-set:reserved (string->char-set ";/?:@&="))
-(define url:char-set:hex (string->char-set "0123456789abcdefABCDEF"))
-
-(define url:char-set:unreserved
- (char-set-union char-set:alphanumeric
- url:char-set:safe
- url:char-set:extra))
-
-(define url:char-set:unescaped
- (char-set-union url:char-set:unreserved
- url:char-set:reserved))
-
-(define url:char-set:escaped
- (char-set-invert url:char-set:unescaped))
+(define url:char-set:safe)
+(define url:char-set:extra)
+(define url:char-set:national)
+(define url:char-set:punctuation)
+(define url:char-set:reserved)
+(define url:char-set:hex)
+(define url:char-set:unreserved)
+(define url:char-set:unescaped)
+(define url:char-set:escaped)
+
+(define (initialize-package!)
+ (set! url:char-set:safe (string->char-set "$-_.+"))
+ (set! url:char-set:extra (string->char-set "!*'(),"))
+ (set! url:char-set:national (string->char-set "{}|\\^~[]`"))
+ (set! url:char-set:punctuation (string->char-set "<>#%\""))
+ (set! url:char-set:reserved (string->char-set ";/?:@&="))
+ (set! url:char-set:hex (string->char-set "0123456789abcdefABCDEF"))
+ (set! url:char-set:unreserved
+ (char-set-union char-set:alphanumeric
+ url:char-set:safe
+ url:char-set:extra))
+ (set! url:char-set:unescaped
+ (char-set-union url:char-set:unreserved
+ url:char-set:reserved))
+ (set! url:char-set:escaped
+ (char-set-invert url:char-set:unescaped))
+ unspecific)
(define url:match:escape
(*matcher
--
2.25.1