/usr/share/common-lisp/source/drakma/read.lisp is in cl-drakma 2.0.2-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: DRAKMA; Base: 10 -*-
;;; $Header: /usr/local/cvsrep/drakma/read.lisp,v 1.17 2008/05/25 11:35:20 edi Exp $
;;; Copyright (c) 2006-2012, Dr. Edmund Weitz. All rights reserved.
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; * Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; * Redistributions in binary form must reproduce the above
;;; copyright notice, this list of conditions and the following
;;; disclaimer in the documentation and/or other materials
;;; provided with the distribution.
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(in-package :drakma)
(defun read-status-line (stream &optional log-stream)
"Reads one line from STREAM \(using Chunga's READ-LINE*) and
interprets it as a HTTP status line. Returns a list of two or
three values - the protocol \(HTTP version) as a keyword, the
status code as an integer, and optionally the reason phrase."
(let* ((*current-error-message* "While reading status line:")
(line (or (read-line* stream log-stream)
(error 'drakma-simple-error
:format-control "No status line - probably network error.")))
(first-space-pos (or (position #\Space line :test #'char=)
(syntax-error "No space in status line ~S." line)))
(second-space-pos (position #\Space line
:test #'char=
:start (1+ first-space-pos))))
(list (cond ((string-equal line "HTTP/1.0" :end1 first-space-pos) :http/1.0)
((string-equal line "HTTP/1.1" :end1 first-space-pos) :http/1.1)
(t (syntax-error "Unknown protocol in ~S." line)))
(or (ignore-errors (parse-integer line
:start (1+ first-space-pos)
:end second-space-pos))
(syntax-error "Status code in ~S is not an integer." line))
(and second-space-pos (subseq line (1+ second-space-pos))))))
(defun get-content-type (headers)
"Reads and parses a `Content-Type' header and returns it as
three values - the type, the subtype, and an alist \(possibly
empty) of name/value pairs for the optional parameters. HEADERS
is supposed to be an alist of headers as returned by
HTTP-REQUEST. Returns NIL if there is no such header amongst
HEADERS."
(when-let (content-type (header-value :content-type headers))
(with-sequence-from-string (stream content-type)
(let* ((*current-error-message* "Corrupted Content-Type header:")
(type (read-token stream))
(subtype (and (assert-char stream #\/)
(read-token stream)))
(parameters (read-name-value-pairs stream)))
(values type subtype parameters)))))
(defun read-token-and-parameters (stream)
"Reads and returns \(as a two-element list) from STREAM a token
and an optional list of parameters \(attribute/value pairs)
following the token."
(skip-whitespace stream)
(list (read-token stream)
(read-name-value-pairs stream)))
(defun skip-more-commas (stream)
"Reads and consumes from STREAM any number of commas and
whitespace. Returns the following character or NIL in case of
END-OF-FILE."
(loop while (eql (peek-char* stream nil) #\,)
do (read-char* stream) (skip-whitespace stream))
(skip-whitespace stream))
(defun read-tokens-and-parameters (string &key (value-required-p t))
"Reads a comma-separated list of tokens from the string STRING.
Each token can be followed by an optional, semicolon-separated
list of attribute/value pairs where the attributes are tokens
followed by a #\\= character and a token or a quoted string.
Returned is a list where each element is either a string \(for a
simple token) or a cons of a string \(the token) and an alist
\(the attribute/value pairs). If VALUE-REQUIRED-P is NIL, the
value part \(including the #\\= character) of each attribute/value
pair is optional."
(with-sequence-from-string (stream string)
(loop with *current-error-message* = (format nil "While parsing ~S:" string)
for first = t then nil
for next = (and (skip-whitespace stream)
(or first (assert-char stream #\,))
(skip-whitespace stream)
(skip-more-commas stream))
for token = (and next (read-token stream))
for parameters = (and token
(read-name-value-pairs stream
:value-required-p value-required-p))
while token
collect (if parameters (cons token parameters) token))))
(defun split-tokens (string)
"Splits the string STRING into a list of substrings separated
by commas and optional whitespace. Empty substrings are
ignored."
(loop for old-position = -1 then position
for position = (and old-position
(position #\, string :test #'char= :start (1+ old-position)))
for substring = (and old-position
(trim-whitespace (subseq string (1+ old-position) position)))
while old-position
when (plusp (length substring))
collect substring))
|