stdlib/csv.tl


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

;; Copyright 2025
;; Kaz Kylheku <kaz@kylheku.com>
;; Vancouver, Canada
;; All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are met:
;;
;; 1. Redistributions of source code must retain the above copyright notice,
;;    this list of conditions and the following disclaimer.
;;
;; 2. 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 COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
;; AND ANY EXPRESS 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 COPYRIGHT HOLDER OR CONTRIBUTORS 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.

(defun get-csv (: (stream *stdin*))
  (if (stringp stream)
    (upd stream make-string-input-stream))
  (let ((record (vec))
        (field (str 0))
        (state :rfield)
        (done nil))
    (while (not done)
      (let ((ch (get-char stream)))
        (when (eq ch #\return)
          (let ((ch2 (get-char stream)))
            (if (eq ch2 #\newline)
              (set ch ch2)
              (if ch2
                (unget-char ch2 stream)))))
        (caseq state
          (:rfield (caseql* ch
                     (#\newline (vec-push record field)
                                (set done t))
                     (#\,       (vec-push record field)
                                (set field (str 0)))
                     (#\"       (cond
                                  ((empty field)
                                   (set state :qfield))
                                  (t
                                    (string-extend field ch))))
                     (nil       (vec-push record field)
                                (set done t))
                     (t         (string-extend field ch))))
          (:qfield (caseql* ch
                     (#\"       (set state :quot))
                     (nil       (vec-push record field)
                                (set done t))
                     (t         (string-extend field ch))))
          (:quot   (caseql* ch
                     (#\,       (vec-push record field)
                                (set field (str 0)
                                     state :rfield))
                     (#\"       (string-extend field ch)
                                (set state :qfield))
                     (#\newline (vec-push record field)
                                (set done t))
                     (nil       (vec-push record field)
                                (set done t))
                     (t         (string-extend field ch)
                                (set state :rfield)))))))
    record))