Newer
Older
Francois-Rene Rideau
committed
;;; -*- Mode: Lisp ; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
;;; csv: reading files in Comma-Separated Values format.
Francois-Rene Rideau
committed
#+xcvb (module (:depends-on ("package")))
Francois-Rene Rideau
committed
#| "
HOME PAGE:
http://www.cliki.net/fare-csv
LICENSE:
http://tunes.org/legalese/bugroff.html
Francois-Rene Rideau
committed
Also under no-restriction BSD license for those who insist.
DEPENDENCIES:
Francois-Rene Rideau
committed
USAGE:
Francois-Rene Rideau
committed
(read-csv-file "foo.csv")
(read-csv-stream stream)
(read-csv-line stream)
(write-csv-lines lines stream)
(write-csv-line fields stream)
Francois-Rene Rideau
committed
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
EXAMPLE USE:
...
BUGS:
I implemented just enough of CSV to import a specific file
from a PC application that will remain unnamed.
If you need more, you can cont(r)act me, and/or hack it yourself.
CSV is intrinsically an underspecified lossy format,
and the particular PC application I'm using loses heavily
(i.e. no quoting convention at all, not even a pascal-like one)
when text fields contain the quote character. Ouch.
SEE ALSO:
This spec seems to explain popular usage, is refered by docs below.
http://www.creativyst.com/Doc/Articles/CSV/CSV01.htm
This one says about the same:
http://edoceo.com/utilitas/csv-file-format
There's now an RFC that tries to standardize CSV:
http://www.rfc-editor.org/rfc/rfc4180.txt
Here's what Perl hackers think CSV is:
http://search.cpan.org/~hmbrand/Text-CSV_XS-0.59/CSV_XS.pm
Share and enjoy!
" |#
; -----------------------------------------------------------------------------
;;; Packaging stuff
(in-package :fare-csv)
; -----------------------------------------------------------------------------
;;; Optimization
(eval-when (:compile-toplevel :execute)
(declaim (optimize (speed 3) (safety 1) (debug 3))
#+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note)))
Francois-Rene Rideau
committed
; -----------------------------------------------------------------------------
;;; Thin compatibility layer
#| ;;; Not needed anymore
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (fboundp 'parse-number)
Francois-Rene Rideau
committed
(with-standard-io-syntax ()
(let* ((*read-eval* nil)
(*read-default-float-format* 'double-float)
(n (read-from-string string)))
(when (numberp n) n)))))) |#
Francois-Rene Rideau
committed
; -----------------------------------------------------------------------------
;;; Parameters
Francois-Rene Rideau
committed
(eval-when (:compile-toplevel :load-toplevel :execute)
(defparameter +cr+ #.(format nil "~A" #\Return) "String containing a CR (Carriage Return)")
(defparameter +lf+ #.(format nil "~A" #\Linefeed) "String containing a LF (Linefeed)")
(defparameter +crlf+ #.(format nil "~A~A" #\Return #\Linefeed) "String containing a CRLF line termination")
Francois-Rene Rideau
committed
(defparameter *csv-variables* '())) ; list of (var rfc4180-value creativyst-value)
(eval-when (:compile-toplevel :load-toplevel :execute)
Francois-Rene Rideau
committed
(macrolet
((def (var rfc4180 creativyst doc)
Francois-Rene Rideau
committed
`(progn
(eval-when (:compile-toplevel :load-toplevel :execute)
(pushnew `(,',var ,,rfc4180 ,,creativyst) *csv-variables* :key #'car))
(defparameter ,var ,creativyst ,doc))))
Francois-Rene Rideau
committed
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
123
124
125
(def *separator*
#\, #\,
"Separator between CSV fields")
(def *quote*
#\" #\"
"delimiter of string data; pascal-like quoted as double itself in a string.")
(def *unquoted-quotequote*
nil nil
"does a pair of quotes represent a quote outside of quotes?
M$, RFC says NIL, csv.3tcl says T")
(def *loose-quote*
nil nil
"can quotes appear anywhere in a field?")
(def *allow-binary*
t t
"do we accept non-ascii data?")
(def *keep-meta-info*
nil nil
"when parsing, include meta information?")
(def *eol*
+lf+ +crlf+
"line ending when exporting CSV")
(def *line-endings*
(list +crlf+ +lf+) (list +cr+ +lf+ +crlf+)
"acceptable line endings when importing CSV")
(def *skip-whitespace*
nil t
"shall we skip unquoted whitespace around separators?")))
(defun char-ascii-text-p (c)
(<= #x20 (char-code c) #x7E))
(defmacro with-creativyst-csv-syntax ((&optional) &body body)
"bind CSV syntax parameters to the CREATIVYST standard around evaluation of BODY"
Francois-Rene Rideau
committed
`(call-with-creativyst-csv-syntax (lambda () ,@body)))
(defun call-with-creativyst-csv-syntax (thunk)
Francois-Rene Rideau
committed
(progv (mapcar #'first *csv-variables*) (mapcar #'third *csv-variables*)
Francois-Rene Rideau
committed
(funcall thunk)))
(defmacro with-rfc4180-csv-syntax ((&optional) &body body)
"bind CSV syntax parameters to the RFC 4180 standard around evaluation of BODY"
Francois-Rene Rideau
committed
`(call-with-rfc4180-csv-syntax (lambda () ,@body)))
(defun call-with-rfc4180-csv-syntax (thunk)
Francois-Rene Rideau
committed
(progv (mapcar #'first *csv-variables*) (mapcar #'second *csv-variables*)
Francois-Rene Rideau
committed
(funcall thunk)))
(defmacro with-strict-rfc4180-csv-syntax ((&optional) &body body)
"bind CSV syntax parameters to the strict RFC 4180 standard around evaluation of BODY,
forcing CRLF as line ending and disallowing binary data amongst values"
Francois-Rene Rideau
committed
`(call-with-strict-rfc4180-csv-syntax (lambda () ,@body)))
Francois-Rene Rideau
committed
Francois-Rene Rideau
committed
(defun call-with-strict-rfc4180-csv-syntax (thunk)
Francois-Rene Rideau
committed
(with-rfc4180-csv-syntax ()
Francois-Rene Rideau
committed
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
(setf *line-endings* (list +crlf+)
*allow-binary* nil)
(funcall thunk)))
(defun valid-eol-p (x)
(member x (list +cr+ +lf+ +crlf+) :test #'equal))
(defun validate-csv-parameters ()
(assert (typep *separator* 'character) ())
(assert (typep *quote* 'character) ())
(assert (not (eql *separator* *quote*)) ())
(assert (typep *unquoted-quotequote* 'boolean) ())
(assert (typep *loose-quote* 'boolean) ())
(assert (typep *keep-meta-info* 'boolean) ())
(assert (valid-eol-p *eol*) ())
(assert (not (member (aref *eol* 0) (list *separator* *quote*))) ())
(assert (and *line-endings* (every #'valid-eol-p *line-endings*)) ())
(assert (typep *skip-whitespace* 'boolean) ()))
;; For internal use only
(defvar *accept-cr* t "internal: do we accept cr?")
(defvar *accept-lf* t "internal: do we accept lf?")
(defvar *accept-crlf* t "internal: do we accept crlf?")
; -----------------------------------------------------------------------------
;;; The parser
(defmacro defsubst (name arglist &body body)
"Declare an inline defun."
`(progn (declaim (inline ,name))
(defun ,name ,arglist ,@body)))
(defsubst char-space-p (c)
"Is character C some kind of white space?
NB: this only handles a tiny subset of whitespace characters,
even if restricted to ASCII. However, it's rather portable,
and is what the creativyst document specifies.
Be careful to not skip a separator, as it could be e.g. a tab!"
Francois-Rene Rideau
committed
(declare (type (or null character) c))
(and c (member c '(#\Space #\Tab)) (not (eql c *separator*))))
Francois-Rene Rideau
committed
;;#+DEBUG (defparameter *max* 2000)
;;#+DEBUG (defun maxbreak () (when (<= *max* 0) (setf *max* 2000) (break)) (decf *max*))
(defsubst accept-p (x stream)
(let ((c (peek-char nil stream nil nil)))
Francois-Rene Rideau
committed
;;#+DEBUG (format t "~&Current char: ~S~%" c)
;;#+DEBUG (maxbreak)
(etypecase x
(character (eql x c))
((or function symbol) (funcall x c))
(integer (eql x (char-code c))))))
(defsubst accept (x stream)
(and (accept-p x stream)
(read-char stream)))
Francois-Rene Rideau
committed
(defsubst accept-eof (stream)
(not (peek-char nil stream nil nil)))
Francois-Rene Rideau
committed
Francois-Rene Rideau
committed
(block nil
(when (and *accept-lf* (accept #\Linefeed stream)) (return t))
Francois-Rene Rideau
committed
(when (or *accept-crlf* *accept-cr*)
Francois-Rene Rideau
committed
(when *accept-crlf*
Francois-Rene Rideau
committed
(return t)
(unless *accept-cr*
(error "Carriage-return without Linefeed!"))))
(return t)))
nil))
(defsubst accept-space (stream)
(accept #'char-space-p stream))
Francois-Rene Rideau
committed
(defsubst accept-spaces (stream)
(loop :for x = (accept-space stream) :while x :collect x))
Francois-Rene Rideau
committed
(defsubst accept-quote (stream)
(accept *quote* stream))
Francois-Rene Rideau
committed
(defsubst accept-separator (stream)
(accept *separator* stream))
Francois-Rene Rideau
committed
(defun read-csv-line (stream)
"Read one line from STREAM in CSV format, using the current syntax parameters.
Return a list of strings, one for each field in the line.
Entries are read as strings;
it is up to you to interpret the strings as whatever you want."
Francois-Rene Rideau
committed
(validate-csv-parameters)
(let ((ss (make-string-output-stream))
(fields '())
(had-quotes nil)
;;(had-spaces nil)
;;(had-binary nil)
(*accept-cr* (member +cr+ *line-endings* :test #'equal))
(*accept-lf* (member +lf+ *line-endings* :test #'equal))
(*accept-crlf* (member +crlf+ *line-endings* :test #'equal)))
(labels
((do-fields ()
;;#+DEBUG (format t "~&do-field~%")
(setf had-quotes nil)
(when *skip-whitespace*
Francois-Rene Rideau
committed
;;#+DEBUG (format t "~&do-field, after spaces~%")
(cond
((or (accept-eol stream) (accept-eof stream))
Francois-Rene Rideau
committed
(done))
(t
(do-field-start))))
(do-field-start ()
;;#+DEBUG (format t "~&do-field-start~%")
(cond
Francois-Rene Rideau
committed
(add "") (do-fields))
Francois-Rene Rideau
committed
(cond
((and *unquoted-quotequote* (accept-quote stream))
Francois-Rene Rideau
committed
(add-char *quote*) (do-field-unquoted))
(t
(do-field-quoted))))
(t
(do-field-unquoted))))
(do-field-quoted ()
;;#+DEBUG (format t "~&do-field-quoted~%")
(setf had-quotes t)
(cond
Francois-Rene Rideau
committed
(error "unexpected end of stream in quotes"))
Francois-Rene Rideau
committed
(cond
Francois-Rene Rideau
committed
(quoted-field-char *quote*))
(*loose-quote*
(do-field-unquoted))
(t
(add (current-string))
(end-of-field))))
(t
(quoted-field-char (read-char stream)))))
Francois-Rene Rideau
committed
(quoted-field-char (c)
;;#+DEBUG (format t "~"ed-field-char~%")
(add-char c)
(do-field-quoted))
(do-field-unquoted ()
;;#+DEBUG (format t "~&do-field-unquoted~%")
(if *skip-whitespace*
(let ((spaces (accept-spaces stream)))
Francois-Rene Rideau
committed
(cond
Francois-Rene Rideau
committed
(add (current-string))
(do-fields))
((or (accept-eol stream) (accept-eof stream))
Francois-Rene Rideau
committed
(add (current-string))
(done))
(t
Francois-Rene Rideau
committed
(do-field-unquoted-no-skip))))
(do-field-unquoted-no-skip)))
(do-field-unquoted-no-skip ()
;;#+DEBUG (format t "~&do-field-unquoted-no-skip~%")
(cond
Francois-Rene Rideau
committed
(add (current-string))
(do-fields))
((or (accept-eol stream) (accept-eof stream))
Francois-Rene Rideau
committed
(add (current-string))
(done))
Francois-Rene Rideau
committed
(cond
((and *unquoted-quotequote* (accept-quote stream))
Francois-Rene Rideau
committed
(add-char *quote*) (do-field-unquoted))
(*loose-quote*
(do-field-quoted))
(t
(error "unexpected quote in middle of field"))))
(t
Francois-Rene Rideau
committed
(do-field-unquoted))))
(end-of-field ()
;;#+DEBUG (format t "~&end-of-field~%")
(when *skip-whitespace*
Francois-Rene Rideau
committed
(cond
((or (accept-eol stream) (accept-eof stream))
Francois-Rene Rideau
committed
(done))
Francois-Rene Rideau
committed
(do-fields))
(t
(error "end of field expected"))))
(add (x)
;;#+DEBUG (format t "~&add ~S~%" x)
(push
(if *keep-meta-info*
(list x :quoted had-quotes)
x)
fields))
(add-char (c)
;;#+DEBUG (format t "~&add-char ~S~%" c)
(write-char c ss))
(current-string ()
(get-output-stream-string ss))
(done ()
;;#+DEBUG (format t "~&done ~S~%" fields)
(nreverse fields)))
(do-fields))))
(defun read-csv-stream (stream)
"Read lines from STREAM in CSV format, using the current syntax parameters.
Return a list of list of strings, one entry for each line,
that contains one entry for each field.
Entries are read as strings;
it is up to you to interpret the strings as whatever you want."
(loop :until (accept-eof stream) :collect (read-csv-line stream)))
(defun read-csv-file (pathname &rest keys &key element-type external-format)
"Open the file designated by PATHNAME, using the provided keys if any,
and call READ-CSV-STREAM on it."
(declare (ignore element-type external-format))
(with-open-stream (stream (apply 'open pathname
:direction :input :if-does-not-exist :error keys))
(read-csv-stream stream)))
Francois-Rene Rideau
committed
(defun char-needs-quoting (x)
(or (eql x *quote*)
(eql x *separator*)
(not (char-ascii-text-p x))))
(defun string-needs-quoting (x)
(and (not (zerop (length x)))
(or (char-space-p (char x 0))
(char-space-p (char x (1- (length x))))
(some #'char-needs-quoting x))
t))
(defun write-csv-lines (lines stream)
"Given a list of LINES, each of them a list of fields, and a STREAM,
format those lines as CSV according to the current syntax parameters."
Francois-Rene Rideau
committed
(dolist (x lines)
(write-csv-line x stream)))
(defun write-csv-line (fields stream)
"Format one line of FIELDS to STREAM in CSV format,
using the current syntax parameters."
(loop :for x :on fields :do
(write-csv-field (first x) stream)
(when (cdr x)
(write-char *separator* stream)))
Francois-Rene Rideau
committed
(write-string *eol* stream))
(defun write-csv-field (field stream)
(etypecase field
(null t)
(number (princ field stream))
(string (write-csv-string-safely field stream))
(symbol (write-csv-string-safely (symbol-name field) stream))))
(defun write-csv-string-safely (string stream)
(if (string-needs-quoting string)
(write-quoted-string string stream)
(write-string string stream)))
(defun write-quoted-string (string stream)
(write-char *quote* stream)
(loop :for c :across string :do
(when (char= c *quote*)
(write-char c stream))
(write-char c stream))
Francois-Rene Rideau
committed
(write-char *quote* stream))
;;#+DEBUG (trace read-csv-line read-csv-stream)
Francois-Rene Rideau
committed
;;#+DEBUG (write (read-csv-file "test.csv"))
;;#+DEBUG (progn (setq *separator* #\;) (write (read-csv-file "/samba/ciev.csv")))