From 221020a96b30b7086b4ebe716a19d317d7c25124 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Wed, 12 Apr 2000 02:26:05 +0000 Subject: [PATCH] Implement procedures to encode and decode URLs. --- v7/src/imail/imail.pkg | 15 ++++- v7/src/imail/url.scm | 123 +++++++++++++++++++++++++++++++++++++++++ v7/src/runtime/url.scm | 123 +++++++++++++++++++++++++++++++++++++++++ 3 files changed, 259 insertions(+), 2 deletions(-) create mode 100644 v7/src/imail/url.scm create mode 100644 v7/src/runtime/url.scm 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 -- 2.25.1