--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/.hgignore Tue Dec 25 14:32:50 2018 -0500
@@ -0,0 +1,7 @@
+syntax: glob
+lisp.prof
+scratch.lisp
+*.log
+docs/build
+images
+test/data/fuzz.*
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/.lispwords Tue Dec 25 14:32:50 2018 -0500
@@ -0,0 +1,1 @@
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/LICENSE.markdown Tue Dec 25 14:32:50 2018 -0500
@@ -0,0 +1,19 @@
+Copyright (c) 2018 Steve Losh and contributors
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/Makefile Tue Dec 25 14:32:50 2018 -0500
@@ -0,0 +1,40 @@
+.PHONY: docs pubdocs test test-sbcl test-ccl test-ecl test-abcl
+
+sourcefiles = $(shell ffind --full-path --literal .lisp)
+docfiles = $(shell ls docs/*.markdown)
+apidocs = $(shell ls docs/*reference*.markdown)
+heading_printer = $(shell which heading || echo 'true')
+
+# Testing ---------------------------------------------------------------------
+test: test-sbcl test-ccl test-ecl test-abcl
+
+test-sbcl: vendor
+ $(heading_printer) computer 'SBCL'
+ sbcl --load test/run.lisp
+
+test-ccl: vendor
+ $(heading_printer) slant 'CCL'
+ ccl --load test/run.lisp
+
+test-ecl: vendor
+ $(heading_printer) roman 'ECL'
+ ecl --load test/run.lisp
+
+test-abcl: vendor
+ $(heading_printer) broadway 'ABCL'
+ abcl --load test/run.lisp
+
+# Documentation ---------------------------------------------------------------
+$(apidocs): $(sourcefiles)
+ sbcl --noinform --load docs/api.lisp --eval '(quit)'
+
+docs/build/index.html: $(docfiles) $(apidocs) docs/title
+ cd docs && ~/.virtualenvs/d/bin/d
+
+docs: docs/build/index.html
+
+pubdocs: docs
+ hg -R ~/src/sjl.bitbucket.org pull -u
+ rsync --delete -a ./docs/build/ ~/src/sjl.bitbucket.org/trivial-csv
+ hg -R ~/src/sjl.bitbucket.org commit -Am 'trivial-csv: Update site.'
+ hg -R ~/src/sjl.bitbucket.org push
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/README.markdown Tue Dec 25 14:32:50 2018 -0500
@@ -0,0 +1,6 @@
+`trivial-csv` is a Common Lisp library for reading and writing RFC4180 CSV data.
+
+* **License:** MIT/X11
+* **Documentation:** <https://sjl.bitbucket.io/trivial-csv/>
+* **Mercurial:** <http://bitbucket.org/sjl/trivial-csv/>
+* **Git:** <http://github.com/sjl/trivial-csv/>
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/package.lisp Tue Dec 25 14:32:50 2018 -0500
@@ -0,0 +1,7 @@
+(defpackage :trivial-csv
+ (:use :cl)
+ (:export
+ :read-row
+ :read-rows
+ :write-row
+ :write-rows))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/package.test.lisp Tue Dec 25 14:32:50 2018 -0500
@@ -0,0 +1,3 @@
+(defpackage :trivial-csv/test
+ (:use :cl :1am :trivial-csv)
+ (:export :run-tests))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/bench.lisp Tue Dec 25 14:32:50 2018 -0500
@@ -0,0 +1,104 @@
+(in-package :trivial-csv)
+
+(defun random-char (string)
+ (aref string (random (length string))))
+
+(defun random-field ()
+ (with-output-to-string (s)
+ (dotimes (i (random 100))
+ (write-char (random-char (concatenate 'string (string #\newline)
+ " abcdefghijklmnop,\""))
+ s))))
+
+(defun random-row ()
+ (loop :repeat (1+ (random 20)) :collect (random-field)))
+
+(defun random-data (rows)
+ (loop :repeat rows :collect (random-row)))
+
+(defun bench-this (data)
+ (let* ((str (make-string-input-stream
+ (with-output-to-string (s)
+ (time (write-rows data s)))))
+ (result (time (read-rows str))))
+ (equal data result)))
+
+(defun bench-other (data)
+ (let* ((str (make-string-input-stream
+ (with-output-to-string (s)
+ (time (cl-csv:write-csv data :stream s)))))
+ (result (time (cl-csv:read-csv str))))
+ (equal data result)))
+
+(defun bench ()
+ (let ((data (random-data 5000)))
+ (write-line "MINE")
+ (bench-this data)
+ (write-line "OTHER")
+ (bench-other data))
+ )
+
+
+(defparameter *data* nil)
+
+(defun generate-large-data ()
+ (setf *data* (random-data 5000)))
+
+(defun write-file-this ()
+ (with-open-file (s "test/large-this.csv"
+ :direction :output
+ :if-exists :supersede)
+ (time
+ (loop :repeat 10 :do (write-rows *data* s)))))
+
+(defun write-file-other ()
+ (with-open-file (s "test/large-other.csv"
+ :direction :output
+ :if-exists :supersede)
+ (time (loop :repeat 10 :do (cl-csv:write-csv *data*
+ :stream s
+ :newline (string #\newline))))))
+
+(defun bench-write-file ()
+ (write-line "Generating data.")
+ (time (generate-large-data))
+ (write-line "Benchmarking this (writing).")
+ (write-file-this)
+ (write-line "Benchmarking other (writing).")
+ (write-file-other))
+
+
+(defun read-file-this ()
+ (with-open-file (s "test/large-this.csv")
+ (time (loop
+ :with data = *data*
+ :for row = (read-row s nil :eof)
+ :for expected-row = (progn (when (null data)
+ (setf data *data*))
+ (pop data))
+ :until (eql :eof row)
+ :do (assert (equal expected-row row))))))
+
+(defun read-file-other ()
+ (with-open-file (s "test/large-other.csv")
+ (time (handler-case
+ (loop
+ :with data = *data*
+ :for row = (cl-csv:read-csv-row s
+ :newline (string #\newline)
+ :trim-outer-whitespace nil)
+ :for expected-row = (progn (when (null data)
+ (setf data *data*))
+ (pop data))
+ :do (assert (equal expected-row row)))
+ (end-of-file () nil)))))
+
+(defun bench-read-file ()
+ (write-line "Benchmarking this (reading).")
+ (read-file-this)
+ (write-line "Benchmarking other (reading).")
+ (read-file-other))
+
+(defun bench-file ()
+ (bench-write-file)
+ (bench-read-file))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/main.lisp Tue Dec 25 14:32:50 2018 -0500
@@ -0,0 +1,121 @@
+(in-package :trivial-csv)
+
+;;;; Configuration ------------------------------------------------------------
+(defparameter *delimiter* #\,)
+
+(defun check-delimiter ()
+ (check-type *delimiter* (and character (not (member #\newline #\")))))
+
+
+;;;; Reading ------------------------------------------------------------------
+(defun read-char-if (char stream &optional (eof-error-p t) eof-value)
+ "If the next character in `stream` is `char`, read and return it. Otherwise, return `nil`."
+ (cond
+ ((eql char (peek-char nil stream eof-error-p nil)) (read-char stream))
+ ((eql char eof-value) char)
+ (t nil)))
+
+(defun read-unquoted-field (stream delimiter)
+ "Read an unquoted field (but not the ending field delimiter) from `stream`."
+ (with-output-to-string (result)
+ (loop :for next = (peek-char nil stream nil delimiter)
+ :until (cond
+ ((char= next delimiter) t)
+ ((char= next #\newline) t)
+ ((char= next #\") (error "Unquoted field contains quote."))
+ (t nil))
+ :do (write-char (read-char stream) result))))
+
+(defun read-quoted-field (stream delimiter)
+ "Read a quoted field (but not the ending field delimiter) from `stream`."
+ (declare (ignore delimiter))
+ (read-char stream) ; chomp initial quote
+ (with-output-to-string (result)
+ (loop :for char = (read-char stream)
+ :until (and (char= #\" char)
+ (not (read-char-if #\" stream nil)))
+ :do (write-char char result))))
+
+(defun read-field (stream delimiter)
+ "Read and return a single field from `stream`."
+ (let* ((field (case (peek-char nil stream nil :eof)
+ (#\" (read-quoted-field stream delimiter))
+ (#\newline (read-char stream) nil)
+ (:eof nil)
+ (t (read-unquoted-field stream delimiter))))
+ (done (cond
+ ((null field) t) ; empty field at the end
+ ((read-char-if delimiter stream nil) nil) ; normal field
+ ((read-char-if #\newline stream nil #\newline) t) ; last field
+ (t (error "Bad data after field ~S: ~S"
+ field (peek-char nil stream))))))
+ (values (or field "") done)))
+
+(defun read-row% (stream delimiter eof-error-p eof-value)
+ (if (eql :eof (peek-char nil stream eof-error-p :eof))
+ eof-value
+ (loop
+ :with field :with done
+ :do (setf (values field done) (read-field stream delimiter))
+ :collect field
+ :until done)))
+
+
+;;;; Writing ------------------------------------------------------------------
+(defun field-needs-quoting-p (field delimiter)
+ (find-if (lambda (char)
+ (or (char= char #\newline)
+ (char= char #\")
+ (char= char delimiter)))
+ field))
+
+(defun write-quoted-field (field stream)
+ (write-char #\" stream)
+ (loop :for char :across field :do
+ (write-char char stream)
+ (when (char= #\" char)
+ (write-char char stream)))
+ (write-char #\" stream))
+
+(defun write-unquoted-field (field stream)
+ (write-string field stream))
+
+(defun write-field (field stream delimiter)
+ (if (field-needs-quoting-p field delimiter)
+ (write-quoted-field field stream)
+ (write-unquoted-field field stream)))
+
+(defun write-row% (row stream delimiter)
+ (check-type row (not null))
+ (loop :for (field . more) :on row :do
+ (write-field field stream delimiter)
+ (when more
+ (write-char delimiter stream)))
+ (write-char #\newline stream))
+
+
+;;;; API ----------------------------------------------------------------------
+(defun read-row (&optional (stream *standard-input*) (eof-error-p t) eof-value)
+ "Read and return a row of fields from `stream`."
+ (check-delimiter)
+ (read-row% stream *delimiter* eof-error-p eof-value))
+
+(defun read-rows (&optional (stream *standard-input*))
+ "Read and return all rows from `stream`."
+ (check-delimiter)
+ (loop :with delimiter = *delimiter*
+ :for row = (read-row% stream delimiter nil :eof)
+ :until (eql row :eof)
+ :collect row))
+
+(defun write-row (row &optional (stream *standard-output*))
+ (check-delimiter)
+ (write-row% row stream *delimiter*)
+ (values))
+
+(defun write-rows (rows &optional (stream *standard-output*))
+ (check-delimiter)
+ (loop :with delimiter = *delimiter*
+ :for row :in rows
+ :do (write-row% row stream delimiter)))
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/test/run.lisp Tue Dec 25 14:32:50 2018 -0500
@@ -0,0 +1,5 @@
+#+ecl (setf compiler:*user-cc-flags* "-Wno-shift-negative-value")
+
+(ql:quickload :trivial-csv :silent t)
+(time (asdf:test-system :trivial-csv))
+(quit)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/test/tests.lisp Tue Dec 25 14:32:50 2018 -0500
@@ -0,0 +1,163 @@
+(in-package :trivial-csv/test)
+
+
+;;;; Utils --------------------------------------------------------------------
+(defmacro define-test (name &body body)
+ `(test ,(symb 'test- name)
+ (let ((*package* ,*package*)
+ (r #(255 0 0))
+ (g #(0 255 0))
+ (b #(0 0 255))
+ (k #(0 0 0))
+ (w #(255 255 255)))
+ (declare (ignorable r g b k w))
+ ,@body)))
+
+(defun make-image-array (initial-data)
+ (make-array (list (length (elt initial-data 0))
+ (length initial-data))
+ :initial-contents (transpose initial-data)))
+
+(defmacro check (form expected-data expected-format expected-bit-depth)
+ (with-gensyms (data format bit-depth)
+ `(multiple-value-bind (,data ,format ,bit-depth) ,form
+ (is (equalp (make-image-array ,expected-data) ,data))
+ (is (eql ,expected-format ,format))
+ (is (= ,expected-bit-depth ,bit-depth)))))
+
+(defun run-tests ()
+ (1am:run))
+
+
+;;;; Tests --------------------------------------------------------------------
+(define-test 1x1-black-ascii-pbm
+ (check (trivial-ppm:read-from-file "test/data/1x1-black.ascii.pbm")
+ '((0))
+ :pbm
+ 1))
+
+(define-test 1x1-black-ascii-pgm
+ (check (trivial-ppm:read-from-file "test/data/1x1-black.ascii.pgm")
+ '((0))
+ :pgm
+ 255))
+
+(define-test 1x1-black-ascii-ppm
+ (check (trivial-ppm:read-from-file "test/data/1x1-black.ascii.ppm")
+ `((,k))
+ :ppm
+ 255))
+
+(define-test 4x3-rgb.ascii-ppm
+ (check (trivial-ppm:read-from-file "test/data/4x3-rgb.ascii.ppm")
+ `((,r ,r ,r ,r)
+ (,g ,g ,g ,g)
+ (,b ,b ,b ,b))
+ :ppm
+ 255))
+
+
+(define-test 1x1-black-binary-pbm
+ (check (trivial-ppm:read-from-file "test/data/1x1-black.binary.pbm")
+ '((0))
+ :pbm
+ 1))
+
+(define-test 1x1-black-binary-pgm
+ (check (trivial-ppm:read-from-file "test/data/1x1-black.binary.pgm")
+ '((0))
+ :pgm
+ 255))
+
+(define-test 1x1-black-binary-ppm
+ (check (trivial-ppm:read-from-file "test/data/1x1-black.binary.ppm")
+ `((,k))
+ :ppm
+ 255))
+
+(define-test 4x3-rgb.binary-ppm
+ (check (trivial-ppm:read-from-file "test/data/4x3-rgb.binary.ppm")
+ `((,r ,r ,r ,r)
+ (,g ,g ,g ,g)
+ (,b ,b ,b ,b))
+ :ppm
+ 255))
+
+
+;;;; Fuzzer -------------------------------------------------------------------
+(defparameter *fuzz-test-count* 500)
+
+
+(defun random-bit ()
+ (random 2))
+
+(defun random-gray ()
+ (random 256))
+
+(defun random-color ()
+ (make-array 3 :initial-contents (list (random 256)
+ (random 256)
+ (random 256))))
+
+(defun random-format ()
+ (ecase (random 3)
+ (0 :pbm)
+ (1 :pgm)
+ (2 :ppm)))
+
+(defun make-random-array ()
+ (let* ((width (1+ (random 50)))
+ (height (1+ (random 50)))
+ (format (random-format))
+ (data (make-array (list width height))))
+ (dotimes (x width)
+ (dotimes (y height)
+ (setf (aref data x y)
+ (ecase format
+ (:pbm (random-bit))
+ (:pgm (random-gray))
+ (:ppm (random-color))))))
+ (values data format)))
+
+
+(define-test fuzz-ascii
+ (dotimes (i *fuzz-test-count*)
+ (multiple-value-bind (original original-format) (make-random-array)
+ (write-to-file "test/data/fuzz.ascii" original
+ :if-exists :supersede
+ :format original-format
+ :encoding :ascii)
+ (multiple-value-bind (new new-format)
+ (read-from-file "test/data/fuzz.ascii")
+ (is (eql original-format new-format))
+ (is (equalp original new))))))
+
+(define-test fuzz-binary
+ (dotimes (i *fuzz-test-count*)
+ (multiple-value-bind (original original-format) (make-random-array)
+ (write-to-file "test/data/fuzz.binary" original
+ :if-exists :supersede
+ :format original-format
+ :encoding :binary)
+ (multiple-value-bind (new new-format)
+ (read-from-file "test/data/fuzz.binary")
+ (is (eql original-format new-format))
+ (is (equalp original new))))))
+
+(define-test fuzz-convert
+ (dotimes (i *fuzz-test-count*)
+ (multiple-value-bind (original original-format) (make-random-array)
+ (write-to-file "test/data/fuzz.convert.in" original
+ :if-exists :supersede
+ :format original-format
+ :encoding :ascii)
+ (uiop:run-program (list "convert" "-format" (ecase original-format
+ (:ppm "ppm")
+ (:pgm "pgm")
+ (:pbm "pbm"))
+ "test/data/fuzz.convert.in"
+ "test/data/fuzz.convert.out"))
+ (multiple-value-bind (new new-format)
+ (read-from-file "test/data/fuzz.convert.out")
+ (is (eql original-format new-format))
+ (is (equalp original new))))))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/trivial-csv.asd Tue Dec 25 14:32:50 2018 -0500
@@ -0,0 +1,39 @@
+(asdf:defsystem :trivial-csv
+ :description "Yet Another CSV Library for Common Lisp."
+
+ :author "Steve Losh <steve@stevelosh.com>"
+ :homepage "https://sjl.bitbucket.io/trivial-csv/"
+ :license "MIT/X11"
+ :version "0.0.1"
+
+ :depends-on ()
+
+ :in-order-to ((asdf:test-op (asdf:test-op :trivial-csv/test)))
+
+ :serial t
+ :components ((:module "vendor" :serial t
+ :components ((:file "quickutils-package")
+ (:file "quickutils")))
+ (:file "package")
+ (:module "src" :serial t
+ :components
+ ((:file "main")))))
+
+(asdf:defsystem :trivial-csv/test
+ :description
+ "Test suite for trivial-csv."
+
+ :author "Steve Losh <steve@stevelosh.com>"
+
+ :license "MIT/X11"
+
+ :depends-on (:trivial-csv :1am)
+
+ :serial t
+ :components ((:file "package.test")
+ (:module "test"
+ :serial t
+ :components ((:file "tests"))))
+ :perform (asdf:test-op (op system)
+ (funcall (read-from-string "trivial-csv/test:run-tests"))))
+