Changeset 34884 in project

Timestamp:

11/11/17 23:00:28 (3 years ago)

Author:

Kon Lovett

Message:

mind p's & q's

Location:

release/4/csv-xml/trunk

Files:

• csv-out.impl (modified) (8 diffs)
• csv-xml.scm (modified) (2 diffs)
• csv-xml.setup (modified) (1 diff)
• tests/run.scm (modified) (3 diffs)

release/4/csv-xml/trunk/csv-out.impl

@@ -29 +29 @@
 (define-constant +quote-doubling-escapes?-default+ #t)
 (define-constant +quote-controls?-default+ #t)
+(define-constant +always-quote?-default+ #t)
 
 #|
@@ -84 +85 @@
           (comment-char +comment-char-default+)
           (quote-doubling-escapes? +quote-doubling-escapes?-default+)
-          (quote-controls? +quote-controls?-default+))
+          (quote-controls? +quote-controls?-default+)
+          (always-quote? +always-quote?-default+))
   ;FIXME checking the input types
   `((newline-char . ,newline-char)
@@ -91 +93 @@
     (comment-char . ,comment-char)
     (quote-doubling-escapes? . ,quote-doubling-escapes?)
-    (quote-controls? . ,quote-controls?)) )
+    (quote-controls? . ,quote-controls?)
+    (always-quote? . ,always-quote?)) )
 
 ;;
@@ -120 +123 @@
 
 (define (make-csv-line-writer loc out writer-spec)
+;(print "make-csv-line-writer: " writer-spec)
   (let ((writer-spec
           (check-csv-writer-spec loc writer-spec) )
@@ -133 +137 @@
           (alist-ref 'quote-doubling-escapes? writer-spec eq?) )
         (quote-controls?
-          (alist-ref 'quote-controls? writer-spec eq?) ) )
-    (lambda (obj)
-      (let (
+          (alist-ref 'quote-controls? writer-spec eq?) )
+        (always-quote?
+          (alist-ref 'always-quote? writer-spec eq?) ) )
+    (let* (
+      (quote-char-str (unicode-char->string quote-char) )
+      (quote-char-str-2 (string-append quote-char-str quote-char-str)) )
+      ;
+      (lambda (obj)
+        ;
+        (define (csv-line-object->string obj)
+          ;
+          (define (quote-doubling? str)
+            (and quote-doubling-escapes? (string-index str quote-char)) )
+          ;
+          (define (quoting? str)
+            (or
+              always-quote?
+              (quote-doubling? str)
+              (and quote-controls? (string-index str char-set:iso-control))) )
+          ;
+          (type-case obj
+            ((char)
+              (csv-line-object->string (unicode-char->string obj)) )
+            ((symbol)
+              (csv-line-object->string (symbol->string obj)) )
+            ((string)
+              (if (and quote-char (quoting? obj))
+                (let (
+                  (str
+                    (if (quote-doubling? obj)
+                      (string-translate* obj `((,quote-char-str . ,quote-char-str-2)))
+                      obj ) ) )
+                  ;
+                  (conc quote-char str quote-char) )
+                obj ) )
+            (number
+              (csv-line-object->string (number->string obj)) )
+            (else
+              (->string obj) ) ) )
+        ;
+        (let* (
           ;build row to output as a string with a line-ending sequence
           (lin
@@ -141 +183 @@
             (if (list? obj)
               ;row data
-              (let* (
-                  (strs
-                    (map ->string (check-list loc obj)) )
-                  (qstrs
-                    (if quote-char
-                      (map (cut conc quote-char <> quote-char) strs)
-                      strs ) ) )
-                (apply conc
-                  (append! (intersperse qstrs separator-char) `(,newline-obj))) )
+              (let ((qstrs (map csv-line-object->string (check-list loc obj))))
+                (apply
+                  conc
+                  (append!
+                    (intersperse qstrs separator-char)
+                    `(,newline-obj))) )
               ;are we supposed to do comments?
               (if comment-char
@@ -158 +197 @@
                   (warning loc "comments not active" obj writer-spec)
                   "" ) ) ) ) )
-          (display lin out) ) ) ) )
+            ;
+            (display lin out) ) ) ) ) )
 
 ;;
@@ -181 +221 @@
     (comment-char . ,(alist-ref 'comment-char writer-spec eq? +comment-char-default+))
     (quote-doubling-escapes? . ,(alist-ref 'quote-doubling-escapes? writer-spec eq? +quote-doubling-escapes?-default+))
-    (quote-controls? . ,(alist-ref 'quote-controls? writer-spec eq? +quote-controls?-default+))) )
+    (quote-controls? . ,(alist-ref 'quote-controls? writer-spec eq? +quote-controls?-default+))
+    (always-quote? . ,(alist-ref 'always-quote? writer-spec eq? +always-quote?-default+))) )
 
 #|

release/4/csv-xml/trunk/csv-xml.scm

@@ -46 +46 @@
 ;;;
 
-(import (only data-structures conc intersperse ->string alist-ref))
+(import (only data-structures conc intersperse ->string alist-ref string-translate*))
 (require-library data-structures)
 
@@ -53 +53 @@
 (require-library (srfi 1))
 
+(import (only (srfi 13) string-index))
+(require-library (srfi 13))
+
+(import (only (srfi 14) char-set:iso-control))
+(require-library (srfi 14))
+
 (import (only type-checks define-check+error-type check-string check-list))
 (require-library type-checks)
+
+(import (only unicode-utils unicode-char->string))
+(require-library unicode-utils)
+
+(require-extension moremacros)
 
 ;(from list-utils egg)

release/4/csv-xml/trunk/csv-xml.setup

@@ -5 +5 @@
 (verify-extension-name "csv-xml")
 
-(setup-shared+static-extension-module (extension-name) (extension-version "0.11.1")
+(setup-shared+static-extension-module (extension-name) (extension-version "0.12.0")
   #:types? #t
   #:inline? #t

release/4/csv-xml/trunk/tests/run.scm

@@ -67 +67 @@
   (quote-doubling-escapes? . #t)
   (quote-controls? . #t)
+  (always-quote? . #t)
 ))
 
@@ -76 +77 @@
   (quote-doubling-escapes? . #t)
   (quote-controls? . #t)
+  (always-quote? . #t)
 ))
 
@@ -161 +163 @@
 ;;
 
+(use extras)
+
+(define (read-csv string delimiter)
+  (csv->list (make-csv-reader string `((separator-chars ,delimiter)))))
+
+(define (write-csv rows delimiter)
+  (call-with-output-string
+   (lambda (out)
+     (let ((writer (writer-spec separator-char: delimiter)))
+       (list->csv rows (make-csv-writer out writer))))))
+
+(define rows '(("f\"o\"o" "1") ("b,a,r" "2") ("b'a'z" "3")))
+
+(let* ((delimiter #\,)
+       (csv (write-csv rows delimiter)))
+  ;(printf "Serialized form:\n~a\n" csv)
+  (let ((result (read-csv csv delimiter)))
+    (test "Roundtrip" rows result) ) )
+
+;;
+
 (test-exit)