Changeset 34884 in project


Ignore:
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:
4 edited

Legend:

Unmodified
Added
Removed
  • release/4/csv-xml/trunk/csv-out.impl

    r34223 r34884  
    2929(define-constant +quote-doubling-escapes?-default+ #t)
    3030(define-constant +quote-controls?-default+ #t)
     31(define-constant +always-quote?-default+ #t)
    3132
    3233#|
     
    8485          (comment-char +comment-char-default+)
    8586          (quote-doubling-escapes? +quote-doubling-escapes?-default+)
    86           (quote-controls? +quote-controls?-default+))
     87          (quote-controls? +quote-controls?-default+)
     88          (always-quote? +always-quote?-default+))
    8789  ;FIXME checking the input types
    8890  `((newline-char . ,newline-char)
     
    9193    (comment-char . ,comment-char)
    9294    (quote-doubling-escapes? . ,quote-doubling-escapes?)
    93     (quote-controls? . ,quote-controls?)) )
     95    (quote-controls? . ,quote-controls?)
     96    (always-quote? . ,always-quote?)) )
    9497
    9598;;
     
    120123
    121124(define (make-csv-line-writer loc out writer-spec)
     125;(print "make-csv-line-writer: " writer-spec)
    122126  (let ((writer-spec
    123127          (check-csv-writer-spec loc writer-spec) )
     
    133137          (alist-ref 'quote-doubling-escapes? writer-spec eq?) )
    134138        (quote-controls?
    135           (alist-ref 'quote-controls? writer-spec eq?) ) )
    136     (lambda (obj)
    137       (let (
     139          (alist-ref 'quote-controls? writer-spec eq?) )
     140        (always-quote?
     141          (alist-ref 'always-quote? writer-spec eq?) ) )
     142    (let* (
     143      (quote-char-str (unicode-char->string quote-char) )
     144      (quote-char-str-2 (string-append quote-char-str quote-char-str)) )
     145      ;
     146      (lambda (obj)
     147        ;
     148        (define (csv-line-object->string obj)
     149          ;
     150          (define (quote-doubling? str)
     151            (and quote-doubling-escapes? (string-index str quote-char)) )
     152          ;
     153          (define (quoting? str)
     154            (or
     155              always-quote?
     156              (quote-doubling? str)
     157              (and quote-controls? (string-index str char-set:iso-control))) )
     158          ;
     159          (type-case obj
     160            ((char)
     161              (csv-line-object->string (unicode-char->string obj)) )
     162            ((symbol)
     163              (csv-line-object->string (symbol->string obj)) )
     164            ((string)
     165              (if (and quote-char (quoting? obj))
     166                (let (
     167                  (str
     168                    (if (quote-doubling? obj)
     169                      (string-translate* obj `((,quote-char-str . ,quote-char-str-2)))
     170                      obj ) ) )
     171                  ;
     172                  (conc quote-char str quote-char) )
     173                obj ) )
     174            (number
     175              (csv-line-object->string (number->string obj)) )
     176            (else
     177              (->string obj) ) ) )
     178        ;
     179        (let* (
    138180          ;build row to output as a string with a line-ending sequence
    139181          (lin
     
    141183            (if (list? obj)
    142184              ;row data
    143               (let* (
    144                   (strs
    145                     (map ->string (check-list loc obj)) )
    146                   (qstrs
    147                     (if quote-char
    148                       (map (cut conc quote-char <> quote-char) strs)
    149                       strs ) ) )
    150                 (apply conc
    151                   (append! (intersperse qstrs separator-char) `(,newline-obj))) )
     185              (let ((qstrs (map csv-line-object->string (check-list loc obj))))
     186                (apply
     187                  conc
     188                  (append!
     189                    (intersperse qstrs separator-char)
     190                    `(,newline-obj))) )
    152191              ;are we supposed to do comments?
    153192              (if comment-char
     
    158197                  (warning loc "comments not active" obj writer-spec)
    159198                  "" ) ) ) ) )
    160           (display lin out) ) ) ) )
     199            ;
     200            (display lin out) ) ) ) ) )
    161201
    162202;;
     
    181221    (comment-char . ,(alist-ref 'comment-char writer-spec eq? +comment-char-default+))
    182222    (quote-doubling-escapes? . ,(alist-ref 'quote-doubling-escapes? writer-spec eq? +quote-doubling-escapes?-default+))
    183     (quote-controls? . ,(alist-ref 'quote-controls? writer-spec eq? +quote-controls?-default+))) )
     223    (quote-controls? . ,(alist-ref 'quote-controls? writer-spec eq? +quote-controls?-default+))
     224    (always-quote? . ,(alist-ref 'always-quote? writer-spec eq? +always-quote?-default+))) )
    184225
    185226#|
  • release/4/csv-xml/trunk/csv-xml.scm

    r34223 r34884  
    4646;;;
    4747
    48 (import (only data-structures conc intersperse ->string alist-ref))
     48(import (only data-structures conc intersperse ->string alist-ref string-translate*))
    4949(require-library data-structures)
    5050
     
    5353(require-library (srfi 1))
    5454
     55(import (only (srfi 13) string-index))
     56(require-library (srfi 13))
     57
     58(import (only (srfi 14) char-set:iso-control))
     59(require-library (srfi 14))
     60
    5561(import (only type-checks define-check+error-type check-string check-list))
    5662(require-library type-checks)
     63
     64(import (only unicode-utils unicode-char->string))
     65(require-library unicode-utils)
     66
     67(require-extension moremacros)
    5768
    5869;(from list-utils egg)
  • release/4/csv-xml/trunk/csv-xml.setup

    r34223 r34884  
    55(verify-extension-name "csv-xml")
    66
    7 (setup-shared+static-extension-module (extension-name) (extension-version "0.11.1")
     7(setup-shared+static-extension-module (extension-name) (extension-version "0.12.0")
    88  #:types? #t
    99  #:inline? #t
  • release/4/csv-xml/trunk/tests/run.scm

    r34223 r34884  
    6767  (quote-doubling-escapes? . #t)
    6868  (quote-controls? . #t)
     69  (always-quote? . #t)
    6970))
    7071
     
    7677  (quote-doubling-escapes? . #t)
    7778  (quote-controls? . #t)
     79  (always-quote? . #t)
    7880))
    7981
     
    161163;;
    162164
     165(use extras)
     166
     167(define (read-csv string delimiter)
     168  (csv->list (make-csv-reader string `((separator-chars ,delimiter)))))
     169
     170(define (write-csv rows delimiter)
     171  (call-with-output-string
     172   (lambda (out)
     173     (let ((writer (writer-spec separator-char: delimiter)))
     174       (list->csv rows (make-csv-writer out writer))))))
     175
     176(define rows '(("f\"o\"o" "1") ("b,a,r" "2") ("b'a'z" "3")))
     177
     178(let* ((delimiter #\,)
     179       (csv (write-csv rows delimiter)))
     180  ;(printf "Serialized form:\n~a\n" csv)
     181  (let ((result (read-csv csv delimiter)))
     182    (test "Roundtrip" rows result) ) )
     183
     184;;
     185
    163186(test-exit)
Note: See TracChangeset for help on using the changeset viewer.