# HG changeset patch # User Steve Losh # Date 1545766370 18000 # Node ID a4abd0534b7dfac275216c1bbd3ab863808d066c Initial commit diff -r 000000000000 -r a4abd0534b7d .hgignore --- /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.* diff -r 000000000000 -r a4abd0534b7d .lispwords --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/.lispwords Tue Dec 25 14:32:50 2018 -0500 @@ -0,0 +1,1 @@ + diff -r 000000000000 -r a4abd0534b7d LICENSE.markdown --- /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. diff -r 000000000000 -r a4abd0534b7d Makefile --- /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 diff -r 000000000000 -r a4abd0534b7d README.markdown --- /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:** +* **Mercurial:** +* **Git:** diff -r 000000000000 -r a4abd0534b7d package.lisp --- /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)) diff -r 000000000000 -r a4abd0534b7d package.test.lisp --- /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)) diff -r 000000000000 -r a4abd0534b7d src/bench.lisp --- /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)) diff -r 000000000000 -r a4abd0534b7d src/main.lisp --- /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))) + diff -r 000000000000 -r a4abd0534b7d test/run.lisp --- /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) diff -r 000000000000 -r a4abd0534b7d test/tests.lisp --- /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)))))) diff -r 000000000000 -r a4abd0534b7d trivial-csv.asd --- /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 " + :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 " + + :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")))) +