1 ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
  2 
  3 ;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved.
  4 
  5 ;;; Redistribution and use in source and binary forms, with or without
  6 ;;; modification, are permitted provided that the following conditions
  7 ;;; are met:
  8 
  9 ;;;   * Redistributions of source code must retain the above copyright
 10 ;;;     notice, this list of conditions and the following disclaimer.
 11 
 12 ;;;   * Redistributions in binary form must reproduce the above
 13 ;;;     copyright notice, this list of conditions and the following
 14 ;;;     disclaimer in the documentation and/or other materials
 15 ;;;     provided with the distribution.
 16 
 17 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
 18 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
 19 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
 20 ;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
 21 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
 22 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
 23 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
 24 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
 25 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
 26 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
 27 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 28 
 29 (in-package :url-rewrite)
 30 
 31 (declaim (inline skip-whitespace))
 32 (defun skip-whitespace (&key (skip t) (write-through t))
 33   "Read characters from *STANDARD-INPUT* as long as they are
 34 whitespace. Returns the string which was read unless SKIP is true. On
 35 EOF the string read so far is returned. Writes all characters read to
 36 *STANDARD-OUTPUT* if WRITE-THROUGH is true."
 37   (read-while #'whitespacep
 38               :skip skip
 39               :write-through write-through))
 40 
 41 (defun read-delimited-string (&key (skip t) (write-through t))
 42   "Reads and returns as its first value a string from
 43 *STANDARD-INPUT*. The string is either delimited by ' or \" in which
 44 case the delimiters aren't part of the string but the second return
 45 value is the delimiter character or it is assumed to extend to the
 46 next character which is not a name constituent \(see NAME-CHAR-P). On
 47 EOF the string read so far is returned. If SKIP is true NIL is
 48 returned. Writes all characters read to *STANDARD-OUTPUT* if
 49 WRITE-THROUGH is true."
 50   ;; note that this function has no means to signal to the caller
 51   ;; that it encountered EOF before the closing delimiter was read,
 52   ;; i.e. "'foo' bar='baz'" and "'foo" yield the same result, namely
 53   ;; the values "foo" and #\'
 54   (handler-case
 55     (let* ((peek-char (peek-char))
 56            (delimiter (find peek-char '(#\' #\"))))
 57       (when delimiter
 58         (read-char)
 59         (when write-through
 60           (write-char delimiter)))
 61       (multiple-value-prog1
 62         (values
 63          (read-while (if delimiter
 64                        (lambda (c) (char/= c delimiter))
 65                        (lambda (c) (name-char-p c)))
 66                      :skip skip
 67                      :write-through write-through)
 68          delimiter)
 69         (when delimiter
 70           (read-char)
 71           (when write-through
 72             (write-char delimiter)))))
 73     (end-of-file ()
 74       ;; this can only happen if the very first PEEK-CHAR fails,
 75       ;; otherwise EOF is handled by READ-WHILE
 76       nil)))
 77 
 78 (declaim (inline read-name))
 79 (defun read-name (&key (skip t) (write-through t))
 80   "Read characters from *STANDARD-INPUT* as long as they are name
 81 constituents. Returns the string which was read unless SKIP is
 82 true. On EOF the string read so far is returned. Writes all characters
 83 read to *STANDARD-OUTPUT* if WRITE-THROUGH is true."
 84   (read-while #'name-char-p :skip skip :write-through write-through))
 85 
 86 (defun read-attribute (&key (skip t) (write-through t))
 87   "Read characters from *STANDARD-INPUT* assuming that they constitue
 88 a SGML-style attribute/value pair. Returns three values - the name of
 89 the attribute, its value, and the whole string which was read. On EOF
 90 the string(s) read so far is/are returned. If SKIP is true NIL is
 91 returned. Writes all characters read to *STANDARD-OUTPUT* if
 92 WRITE-THROUGH is true."
 93   (let* ((name (read-name :skip skip
 94                           :write-through write-through))
 95          (whitespace1 (skip-whitespace :skip skip
 96                                        :write-through write-through)))
 97     (cond ((eql (peek-char*) #\=)
 98             (read-char)
 99             (when write-through
100               (write-char #\=))
101             (let ((whitespace2 (skip-whitespace :skip skip :write-through write-through)))
102               (multiple-value-bind (value delimiter)
103                   (read-delimited-string :skip skip :write-through write-through)
104                 (let ((delimiter-string (if delimiter (string delimiter) "")))
105                   (if skip
106                     nil
107                     (values name value
108                             (concatenate 'string
109                                          name whitespace1 "=" whitespace2
110                                          delimiter-string value delimiter-string)))))))
111           (t (if skip
112                nil
113                (values name nil
114                        (concatenate 'string name whitespace1)))))))
115 
116 (defun skip-comment ()
117   "Skip SGML comment from *STANDARD-INPUT*, i.e. a string enclosed in
118 '--' on both sides. Returns no values. Writes all characters read to
119 *STANDARD-OUTPUT*. This function assumes \(without checking) that the
120 current position of *STANDARD-INPUT* is at the beginning of a comment,
121 after the first hyphen - see COMMENT-START-P."
122   (read-char)
123   (write-string "--")
124   (read-until "--")
125   (values))
126