;;; -*-Scheme-*-
;;;
-;;; $Id: compile.scm,v 1.12 2001/08/15 03:10:30 cph Exp $
+;;; $Id: compile.scm,v 1.13 2001/10/05 19:20:01 cph Exp $
;;;
;;; Copyright (c) 2000-2001 Massachusetts Institute of Technology
;;;
"imail-util"
"imap-response"
"imap-syntax"
- "parser"
- "rexp"
- "url"))
+ "parser"))
(for-each (let ((syntax-table
(access edwin-syntax-table (->environment '(EDWIN)))))
(lambda (filename)
;;; -*-Scheme-*-
;;;
-;;; $Id: ed-ffi.scm,v 1.14 2001/05/26 02:58:27 cph Exp $
+;;; $Id: ed-ffi.scm,v 1.15 2001/10/05 19:20:03 cph Exp $
;;;
;;; Copyright (c) 2000-2001 Massachusetts Institute of Technology
;;;
("imap-syntax" (edwin imail imap-syntax)
system-global-syntax-table)
("parser" (edwin imail parser)
- system-global-syntax-table)
- ("rexp" (edwin imail rexp)
- system-global-syntax-table)
- ("url" (edwin imail url)
system-global-syntax-table)))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Id: imail.pkg,v 1.88 2001/09/28 00:41:16 cph Exp $
+;;; $Id: imail.pkg,v 1.89 2001/10/05 19:20:05 cph Exp $
;;;
;;; Copyright (c) 2000-2001 Massachusetts Institute of Technology
;;;
(global-definitions "../sos/sos")
(global-definitions "../edwin/edwinunx")
-(define-package (edwin imail rexp)
- (files "rexp")
- (parent (edwin imail))
- (export (edwin imail)
- rexp*
- rexp+
- rexp->regexp
- rexp-alternatives
- rexp-any-char
- rexp-case-fold
- rexp-compile
- rexp-group
- rexp-line-end
- rexp-line-start
- rexp-not-syntax-char
- rexp-not-word-char
- rexp-not-word-edge
- rexp-optional
- rexp-sequence
- rexp-string-end
- rexp-string-start
- rexp-syntax-char
- rexp-word-char
- rexp-word-edge
- rexp-word-end
- rexp-word-start
- rexp?))
-
(define-package (edwin imail parser)
(files "parser")
(parent (edwin imail))
simple-parser
string-matcher))
-(define-package (edwin imail url)
- (files "url")
- (parent (edwin imail))
- (export (edwin imail)
- 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:rexp:escape
- url:rexp:host
- url:rexp:hostname
- url:rexp:hostnumber
- url:rexp:hostport
- url:rexp:uchar
- url:rexp:xchar
- url:string-encoded?
- url:substring-encoded?))
-
(define-package (edwin imail)
(files "imail-util"
"imail-core")
;;; -*-Scheme-*-
;;;
-;;; $Id: load.scm,v 1.31 2001/09/28 19:18:42 cph Exp $
+;;; $Id: load.scm,v 1.32 2001/10/05 19:20:07 cph Exp $
;;;
;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology
;;;
(load-option 'HASH-TABLE)
(load-option 'REGULAR-EXPRESSION)
(load-option 'SOS)
+(load-option 'URL)
(with-working-directory-pathname (directory-pathname (current-load-pathname))
(lambda ()
(fluid-let ((*allow-package-redefinition?* #t))
+++ /dev/null
-;;; -*-Scheme-*-
-;;;
-;;; $Id: rexp.scm,v 1.15 2000/07/08 00:41:45 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.
-
-;;;; List-based Regular Expressions
-
-(declare (usual-integrations))
-\f
-(define (rexp? rexp)
- (or (char-set? rexp)
- (string? rexp)
- (and (pair? rexp)
- (list? (cdr rexp))
- (let ((one-arg
- (lambda ()
- (and (fix:= 1 (length (cdr rexp)))
- (rexp? (cadr rexp))))))
- (case (car rexp)
- ((ALTERNATIVES SEQUENCE)
- (for-all? (cdr rexp) rexp?))
- ((GROUP OPTIONAL * +)
- (and (one-arg)
- (not (or (and (string? rexp)
- (string-null? rexp))
- (and (pair? rexp)
- (memq (car rexp) boundary-rexp-types))))))
- ((CASE-FOLD)
- (and (fix:= 1 (length (cdr rexp)))
- (string? (cadr exp))))
- ((ANY-CHAR LINE-START LINE-END STRING-START STRING-END
- WORD-EDGE NOT-WORD-EDGE WORD-START WORD-END
- WORD-CHAR NOT-WORD-CHAR)
- (null? (cdr rexp)))
- ((SYNTAX-CHAR NOT-SYNTAX-CHAR)
- (and (one-arg)
- (assq (cadr rexp) syntax-type-alist)))
- (else #f))))))
-
-(define boundary-rexp-types
- '(LINE-START LINE-END STRING-START STRING-END WORD-EDGE NOT-WORD-EDGE
- WORD-START WORD-END))
-
-(define syntax-type-alist
- '((WHITESPACE . " ")
- (PUNCTUATION . ".")
- (WORD . "w")
- (SYMBOL . "_")
- (OPEN . "(")
- (CLOSE . ")")
- (QUOTE . "\'")
- (STRING-DELIMITER . "\"")
- (MATH-DELIMITER . "$")
- (ESCAPE . "\\")
- (CHAR-QUOTE . "/")
- (COMMENT-START . "<")
- (COMMENT-END . ">")))
-\f
-(define (rexp-alternatives . rexps)
- `(ALTERNATIVES ,@rexps))
-
-(define (rexp-sequence . rexps)
- (let ((rexps (simplify-sequence-args rexps)))
- (if (pair? rexps)
- (if (pair? (cdr rexps))
- `(SEQUENCE ,@rexps)
- (car rexps))
- "")))
-
-(define (simplify-sequence-args rexps)
- (append-map (lambda (rexp)
- (cond ((and (string? rexp) (string-null? rexp))
- '())
- ((and (pair? rexp) (eq? 'SEQUENCE (car rexp)))
- (cdr rexp))
- ((and (pair? rexp) (eq? 'ALTERNATIVES (car rexp)))
- (list `(GROUP ,rexp)))
- (else
- (list rexp))))
- rexps))
-
-(define (rexp-group . rexps)
- `(GROUP ,(apply rexp-sequence rexps)))
-
-(define (rexp-optional . rexps)
- `(OPTIONAL ,(rexp-groupify (apply rexp-sequence rexps))))
-
-(define (rexp* . rexps)
- `(* ,(rexp-groupify (apply rexp-sequence rexps))))
-
-(define (rexp+ . rexps)
- `(+ ,(rexp-groupify (apply rexp-sequence rexps))))
-
-(define (rexp-groupify rexp)
- (let ((group (lambda () `(GROUP ,rexp)))
- (no-group (lambda () (error "Expression can't be grouped:" rexp))))
- (cond ((and (string? rexp) (not (char-set? rexp)))
- (case (string-length rexp)
- ((0) (no-group))
- ((1) rexp)
- (else (group))))
- ((pair? rexp)
- (cond ((memq (car rexp) boundary-rexp-types)
- (no-group))
- ((memq (car rexp) '(ALTERNATIVES SEQUENCE OPTIONAL * +))
- (group))
- (else rexp)))
- (else rexp))))
-
-(define (rexp-any-char) `(ANY-CHAR))
-(define (rexp-line-start) `(LINE-START))
-(define (rexp-line-end) `(LINE-END))
-(define (rexp-string-start) `(STRING-START))
-(define (rexp-string-end) `(STRING-END))
-(define (rexp-word-edge) `(WORD-EDGE))
-(define (rexp-not-word-edge) `(NOT-WORD-EDGE))
-(define (rexp-word-start) `(WORD-START))
-(define (rexp-word-end) `(WORD-END))
-(define (rexp-word-char) `(WORD-CHAR))
-(define (rexp-not-word-char) `(NOT-WORD-CHAR))
-(define (rexp-syntax-char type) `(SYNTAX-CHAR ,type))
-(define (rexp-not-syntax-char type) `(NOT-SYNTAX-CHAR ,type))
-
-(define (rexp-case-fold rexp)
- (cond ((and (string? rexp) (not (char-set? rexp)))
- `(CASE-FOLD ,rexp))
- ((and (pair? rexp)
- (memq (car rexp) '(ALTERNATIVES SEQUENCE GROUP OPTIONAL * +))
- (list? (cdr rexp)))
- (cons (car rexp)
- (map rexp-case-fold (cdr rexp))))
- (else rexp)))
-\f
-(define (rexp-compile rexp)
- (re-compile-pattern (rexp->regexp rexp) #f))
-
-(define (rexp->regexp rexp)
- (let ((lose (lambda () (error "Malformed rexp:" rexp))))
- (cond ((char-set? rexp)
- (char-set->regexp rexp))
- ((string? rexp)
- (re-quote-string rexp))
- ((and (pair? rexp) (list? (cdr rexp)))
- (let ((one-arg
- (lambda ()
- (if (fix:= 1 (length (cdr rexp)))
- (cadr rexp)
- (lose))))
- (rexp-args (lambda () (map rexp->regexp (cdr rexp)))))
- (let ((rexp-arg (lambda () (rexp->regexp (one-arg))))
- (syntax-type
- (lambda ()
- (let ((entry (assq (one-arg) syntax-type-alist)))
- (if entry
- (cdr entry)
- (lose))))))
- (case (car rexp)
- ((ALTERNATIVES)
- (decorated-string-append "" "\\|" "" (rexp-args)))
- ((SEQUENCE) (apply string-append (rexp-args)))
- ((GROUP) (string-append "\\(" (rexp-arg) "\\)"))
- ((OPTIONAL) (string-append (rexp-arg) "?"))
- ((*) (string-append (rexp-arg) "*"))
- ((+) (string-append (rexp-arg) "+"))
- ((CASE-FOLD)
- (let ((arg (one-arg)))
- (if (and (string? arg) (not (char-set? arg)))
- (case-fold-string arg)
- (lose))))
- ((ANY-CHAR) ".")
- ((LINE-START) "^")
- ((LINE-END) "$")
- ((STRING-START) "\\`")
- ((STRING-END) "\\'")
- ((WORD-EDGE) "\\b")
- ((NOT-WORD-EDGE) "\\B")
- ((WORD-START) "\\<")
- ((WORD-END) "\\>")
- ((WORD-CHAR) "\\w")
- ((NOT-WORD-CHAR) "\\W")
- ((SYNTAX-CHAR) (string-append "\\s" (syntax-type)))
- ((NOT-SYNTAX-CHAR) (string-append "\\S" (syntax-type)))
- (else (lose))))))
- (else (lose)))))
-
-(define (case-fold-string s)
- (let ((end (string-length s)))
- (let loop ((start 0) (parts '()))
- (let ((index
- (substring-find-next-char-in-set s start end
- char-set:alphabetic)))
- (if index
- (loop (fix:+ index 1)
- (cons* (let ((char (string-ref s index)))
- (string-append "["
- (string (char-upcase char))
- (string (char-downcase char))
- "]"))
- (re-quote-string
- (substring s start index))
- parts))
- (apply string-append (reverse! parts)))))))
\ No newline at end of file
+++ /dev/null
-;;; -*-Scheme-*-
-;;;
-;;; $Id: url.scm,v 1.8 2000/07/02 05:09:21 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 (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: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:rexp:escape
- (let ((char-set:hex (string->char-set "0123456789ABCDEFabcdef")))
- (rexp-sequence "%" char-set:hex char-set:hex)))
-
-(define url:rexp:uchar
- (rexp-alternatives url:char-set:unreserved url:rexp:escape))
-
-(define url:rexp:xchar
- (rexp-alternatives url:char-set:unescaped url:rexp:escape))
-
-(define url:rexp:hostname
- (let ((tail
- (rexp-optional
- (rexp*
- (char-set-union char-set:alphanumeric (string->char-set "-")))
- char-set:alphanumeric)))
- (rexp-sequence (rexp* char-set:alphanumeric tail ".")
- char-set:alphabetic
- tail)))
-
-(define url:rexp:hostnumber
- (let ((n (rexp+ char-set:numeric)))
- (rexp-sequence n "." n "." n "." n)))
-
-(define url:rexp:host
- (rexp-alternatives url:rexp:hostname url:rexp:hostnumber))
-
-(define url:rexp:hostport
- (rexp-sequence url:rexp:host (rexp-optional ":" (rexp+ char-set:numeric))))
-\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 (rexp-compile url:rexp:xchar)))
- (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: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-substring string start end)
- (let ((patt (rexp-compile url:rexp:escape)))
- (let ((n-encoded
- (let loop ((start start) (n-encoded 0))
- (let ((regs (re-substring-search-forward patt 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 patt string start end)))
- (if regs
- (let ((index (re-match-start-index 0 regs)))
- (substring-move! 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! string start end decoded i))))
- decoded)))))
\ No newline at end of file
projects / mit-scheme.git / commitdiff