primitives.lisp 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 peek-char*))
32 (defun peek-char* ()
33 "PEEK-CHAR with input stream bound to *STANDARD-INPUT* and returning
34 NIL on EOF."
35 (peek-char nil nil nil))
36
37 (declaim (inline whitespacep))
38 (defun whitespacep (c)
39 "Checks whether C is a whitespace character."
40 (find c '(#\Space #\Tab #\Newline #\Linefeed #\Return #\Page)))
41
42 (declaim (inline letterp))
43 (defun letterp (c)
44 "Checks whether C is a character between A and Z
45 \(case-insensitive)."
46 (and (characterp c)
47 (or (char<= #\a c #\z)
48 (char<= #\A c #\Z))))
49
50 (declaim (inline name-char-p))
51 (defun name-char-p (c)
52 "Checks whether C is a name constituent character in the sense of
53 HTML."
54 (and (characterp c)
55 (or (letterp c)
56 (digit-char-p c)
57 (char= c #\-)
58 (char= c #\.))))
59
60 (defun comment-start-p ()
61 "Checks whether *STANDARD-OUTPUT* currently 'looks at' the string
62 \"--\". Will move the position within the stream by one unless the
63 first characters it sees is not a hyphen."
64 (unless (eql (peek-char*) #\-)
65 ;; if the first character isn't #\- we can return immediately
66 (return-from comment-start-p nil))
67 ;; otherwise read the #\- so we can check the next character
68 (read-char)
69 (eql (peek-char*) #\-))
70
71 (defun read-while (predicate &key (skip t) (write-through t))
72 "Reads characters from *STANDARD-INPUT* while PREDICATE returns a
73 true value for each character. Returns the string which was read
74 unless SKIP is true. Writes all characters read to *STANDARD-OUTPUT*
75 if WRITE-THROUGH is true. On EOF the string read so far is returned."
76 (let ((collector (or skip
77 (make-array 0
78 :element-type 'character
79 :fill-pointer t
80 :adjustable t))))
81 (handler-case
82 (loop while (funcall predicate (peek-char)) do
83 (let ((char (read-char)))
84 (when write-through
85 (write-char char))
86 (unless skip
87 (vector-push-extend char collector)))
88 finally (return (and (not skip) collector)))
89 (end-of-file ()
90 (and (not skip) collector)))))
91
92 (defun read-until (string &key (skip t) (write-through t))
93 "Reads characters from *STANDARD-INPUT* up to and including STRING.
94 Returns the string which was read \(excluding STRING) unless SKIP is
95 true. Writes all characters read to *STANDARD-OUTPUT* if
96 WRITE-THROUGH is true. On EOF the string read so far is returned."
97 (let* ((length (length string))
98 (offsets
99 ;; we first check whether some substring which starts
100 ;; STRING can be found again later in STRING - this is
101 ;; necessary because we only peek one character ahead
102 (cond ((gethash string *find-string-hash*))
103 (t (setf (gethash string *find-string-hash*)
104 ;; the resulting array of offsets is
105 ;; cached in *FIND-STRING-HASH* so we can
106 ;; use it again in case READ-UNTIL is
107 ;; called with the same STRING argument
108 (loop with offsets = (make-array length
109 :initial-element nil)
110 for i from 1 below length
111 ;; check if STRING starting from 0
112 ;; has something in common with
113 ;; STRING starting from I
114 for mismatch = (mismatch string string
115 :start1 i :test #'char=)
116 when (> mismatch i)
117 ;; if this is the case remember the
118 ;; length of the match plus the
119 ;; character which must follow in
120 ;; OFFSETS
121 do (push (cons (char string (- mismatch i))
122 (1+ (- mismatch i)))
123 (svref offsets i))
124 finally (return offsets))))))
125 (collector (or skip
126 (make-array 0
127 :element-type 'character
128 :fill-pointer t
129 :adjustable t))))
130 (handler-case
131 (loop for i = 0 then (cond (match (1+ i))
132 ;; if there is an offset (see above)
133 ;; we don't have to start from the
134 ;; beginning of STRING
135 ((cdr (assoc c (svref offsets i))))
136 (t 0))
137 for c = (peek-char)
138 for match = (char= c (char string i))
139 while (or (not match) (< (1+ i) length)) do
140 (cond (skip (read-char))
141 (t (vector-push-extend (read-char) collector)))
142 when write-through do
143 (write-char c)
144 finally (if write-through
145 (write-char (read-char))
146 (read-char))
147 (unless skip
148 ;; decrement the fill pointer because collector now also
149 ;; contains STRING itself
150 (decf (fill-pointer collector) (1- length)))
151 (return (and (not skip) collector)))
152 (end-of-file ()
153 (and (not skip) collector)))))
154