Changeset 34223 in project


Ignore:
Timestamp:
07/03/17 22:03:38 (4 weeks ago)
Author:
kon
Message:

fix the output stuff - just so wrong

Location:
release/4/csv-xml
Files:
8 edited
1 copied

Legend:

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

    r34218 r34223  
    66;;Issues
    77;;
    8 ;;- missing explicit types for exports
    9 
    10 ;;
    11 
    12 (define-constant +newline-default+ #t)  ;#t - <system>
    13 (define-constant +separator-char+ #\,)
    14 (define-constant +quote-char+ #\")
     8;;- missing explicit types for exports; too much '*' type
     9
     10;;
    1511
    1612(define-constant CRLF-STR "\r\n")
     
    1814(define-constant CR-STR "\r") ;old MacOS
    1915
     16(define *system-newline*
     17  (cond-expand
     18    (windows
     19      CRLF-STR )
     20    (unix
     21      LF-STR )
     22    (else
     23      LF-STR ) ) )
     24
     25(define-constant +newline-char-default+ #t)               ;#t - <system> | #\n | ...
     26(define-constant +separator-char-default+ #\,)
     27(define-constant +quote-char-default+ #\")                ;#f | #\" | ...
     28(define-constant +comment-char-default+ #\#)              ;#f | #\# | ...
     29(define-constant +quote-doubling-escapes?-default+ #t)
     30(define-constant +quote-controls?-default+ #t)
     31
     32#|
    2033(define-constant +sxml-top-symbol+ '|*TOP*|)
    2134(define-constant +sxml-row-element-default+ 'row)
    2235(define-constant +sxml-col-elements-limit-default+ 32) ; arbitrary (see csv.ss)
    23 
    24 (define (make-sxml-col-symbol n)
    25   (string->symbol (string-append "col-" (number->string n))) )
    26 
    27 ;;
    28 
    29 ;very loose : newline | separator-char | quote-char
     36|#
     37
     38;;
     39
     40;very loose : newline-char | separator-char | quote-char
     41;see "csv-xml.scm"
    3042(define csv-writer-spec? alist?)
    3143(define-check+error-type csv-writer-spec)
     
    3648;;
    3749
     50(define *default-writer-spec* (writer-spec-with-defaults '()))
     51
    3852(define (list->csv ls #!optional (writer-or-out (current-output-port)))
    39   (let ((writer
    40           (cond
    41             ((csv-writer? writer-or-out)
    42               writer-or-out )
    43             ((output-port? writer-or-out)
    44               (csv-line-writer 'list->csv
    45                 writer-or-out (writer-spec-with-defaults '())) )
    46             (else
    47               (error 'list->csv "invalid csv-writer or output-port" writer-or-out) ) ) ) )
     53  (let (
     54      (writer
     55        (cond
     56          ((csv-writer? writer-or-out)
     57            writer-or-out )
     58          ((output-port? writer-or-out)
     59            (make-csv-line-writer 'list->csv writer-or-out *default-writer-spec*) )
     60          (else
     61            (error 'list->csv "invalid csv-writer or output-port" writer-or-out) ) ) ) )
    4862    (for-each writer ls) ) )
    4963
     64#|
    5065;;
    5166
     
    5368          #!optional
    5469          (row-element (sxml-row-element-default))
    55           (column-elements (sxml-col-elements-default)))
     70          (column-elements (sxml-col-elements-default))
     71          (writer-spec *default-writer-spec*))
    5672  (append!
    5773    `(,(sxml-top-symbol))
    58     (map (cut list->sxml-element <> row-element column-elements) ls)) )
     74    (map (cut list->sxml-element <> row-element column-elements writer-spec) ls)) )
     75|#
    5976
    6077;;
     
    6279(define (writer-spec
    6380          #!key
    64           (newline +newline-default+)
    65           (separator-char +separator-char+)
    66           (quote-char +quote-char+))
    67   `((newline . ,newline)
     81          (newline-char +newline-char-default+)
     82          (separator-char +separator-char-default+)
     83          (quote-char +quote-char-default+)
     84          (comment-char +comment-char-default+)
     85          (quote-doubling-escapes? +quote-doubling-escapes?-default+)
     86          (quote-controls? +quote-controls?-default+))
     87  ;FIXME checking the input types
     88  `((newline-char . ,newline-char)
    6889    (separator-char . ,separator-char)
    69     (quote-char . ,quote-char)) )
    70 
    71 ;;
    72 
    73 (define (make-csv-writer out-or-str #!optional writer-spec)
    74   (let ((actual-make-csv-writer (make-csv-writer-maker writer-spec)))
    75     (actual-make-csv-writer out-or-str) ) )
    76 
    77 (define (make-csv-writer-maker writer-spec)
     90    (quote-char . ,quote-char)
     91    (comment-char . ,comment-char)
     92    (quote-doubling-escapes? . ,quote-doubling-escapes?)
     93    (quote-controls? . ,quote-controls?)) )
     94
     95;;
     96
     97(define (make-csv-writer out-or-str #!optional (writer-spec '()))
     98  (let ((make-spec-csv-writer (make-csv-writer-maker writer-spec)))
     99    (make-spec-csv-writer out-or-str) ) )
     100
     101(define (make-csv-writer-maker #!optional (writer-spec '()))
    78102  (let ((writer-spec
    79103          (writer-spec-with-defaults
     
    90114                (error
    91115                  'csv-writer-maker
    92                   "invalid output-port or stirng" out-or-str) ) ) ) )
    93         (csv-line-writer 'csv-writer-maker out writer-spec) ) ) ) )
    94 
    95 ;;
    96 
    97 (define (csv-line-writer loc out writer-spec)
    98 ;(print 'csv-line-writer " " loc " " out " " writer-spec)
    99   (let* ((writer-spec
     116                  "invalid output-port or string" out-or-str) ) ) ) )
     117        (make-csv-line-writer 'csv-writer-maker out writer-spec) ) ) ) )
     118
     119;;
     120
     121(define (make-csv-line-writer loc out writer-spec)
     122  (let ((writer-spec
    100123          (check-csv-writer-spec loc writer-spec) )
    101          (newline
    102           (select-newline loc (cdr (assq 'newline writer-spec))) )
    103          (separator-char
    104           (cdr (assq 'separator-char writer-spec)) )
    105          (quote-char
    106           (let ((obj (assq 'quote-char writer-spec)))
    107             (if (pair? obj)
    108               (cdr obj)
    109               obj ) ) ) )
    110     (lambda (objs)
    111       (check-list loc objs)
    112       (let* (
    113           (strs
    114             (map ->string objs) )
    115           (qstrs
    116             (if quote-char
    117               (map (cut conc quote-char <> quote-char) strs)
    118               strs ) )
    119            (str
    120             (apply conc (append! (intersperse qstrs separator-char) `(,newline))) ) )
    121         (display str out) ) ) ) )
    122 
    123 ;;
    124 
    125 (define (list->sxml-element ls row-element col-elements)
    126   `(,row-element ,@(map list col-elements ls)) )
    127 
    128 ;;
    129 
    130 (define *system-newline*
    131   (cond-expand
    132     (windows
    133       CRLF-STR )
    134     (unix
    135       LF-STR )
    136     (else
    137       LF-STR ) ) )
    138 
    139 (define (select-newline loc spec)
     124        (newline-obj
     125          (select-newline-object loc (alist-ref 'newline-char writer-spec eq?)) )
     126        (separator-char
     127          (alist-ref 'separator-char writer-spec eq?) )
     128        (quote-char
     129          (alist-ref 'quote-char writer-spec eq?) )
     130        (comment-char
     131          (alist-ref 'comment-char writer-spec eq?) )
     132        (quote-doubling-escapes?
     133          (alist-ref 'quote-doubling-escapes? writer-spec eq?) )
     134        (quote-controls?
     135          (alist-ref 'quote-controls? writer-spec eq?) ) )
     136    (lambda (obj)
     137      (let (
     138          ;build row to output as a string with a line-ending sequence
     139          (lin
     140            ;comment desired?
     141            (if (list? obj)
     142              ;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))) )
     152              ;are we supposed to do comments?
     153              (if comment-char
     154                (conc comment-char obj newline-obj)
     155                obj
     156                #;
     157                (begin
     158                  (warning loc "comments not active" obj writer-spec)
     159                  "" ) ) ) ) )
     160          (display lin out) ) ) ) )
     161
     162;;
     163
     164(define (select-newline-object loc spec)
    140165  (case spec
    141166    ((cr)
     
    146171      CRLF-STR )
    147172    (else
    148       *system-newline*
    149       #; ;be generous - THIS IS NOT A EITHER/OR - only 1 is right
    150       (if (and (boolean? spec) spec)
    151         *system-newline*
    152         (error loc "invalid newline specification" spec) ) ) ) )
    153 
    154 ;;
     173      *system-newline* ) ) )
     174
     175;;
     176
     177(define (writer-spec-with-defaults writer-spec)
     178  `((newline-char . ,(alist-ref 'newline-char writer-spec eq? +newline-char-default+))
     179    (separator-char . ,(alist-ref 'separator-char writer-spec eq? +separator-char-default+))
     180    (quote-char . ,(alist-ref 'quote-char writer-spec eq? +quote-char-default+))
     181    (comment-char . ,(alist-ref 'comment-char writer-spec eq? +comment-char-default+))
     182    (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+))) )
     184
     185#|
     186;;
     187
     188(define (list->sxml-element ls row-element col-elements writer-spec)
     189  (if (list? ls)
     190    ;row data
     191    `(,row-element ,@(map list col-elements (map ->string ls)))
     192    ;are we supposed to do comments?
     193    (if (alist-ref 'comment-char writer-spec eq?)
     194      `(*COMMENT* ,(->string ls))
     195      ls ) ) )
     196
     197(define (make-sxml-col-symbol n)
     198  (string->symbol (string-append "col-" (number->string n))) )
    155199
    156200(define +sxml-col-elements-default+
     
    173217       (ls '() (cons (make-sxml-col-symbol i) ls)) )
    174218      ((= i +sxml-col-elements-limit-default+) ls) ) )
    175 
    176 (define (writer-spec-with-defaults writer-spec)
    177   (let ((newline
    178           (assq 'newline writer-spec) )
    179         (separator-char
    180           (assq 'separator-char writer-spec) )
    181         (quote-char
    182           (let ((obj (assq 'quote-char writer-spec)))
    183             (if (pair? obj)
    184               (cdr obj)
    185               obj ) ) ) )
    186     `((newline . ,(or newline +newline-default+))
    187       (separator-char . ,(or separator-char +separator-char+))
    188       (quote-char . ,(or quote-char +quote-char+))) ) )
     219|#
  • release/4/csv-xml/tags/0.11.1/csv-xml.scm

    r34218 r34223  
    2626  ;
    2727  list->csv
    28   list->sxml
     28  #;list->sxml
    2929  ;
    3030  csv-writer? check-csv-writer error-csv-writer
     
    4646;;;
    4747
    48 (import (only data-structures conc intersperse ->string))
     48(import (only data-structures conc intersperse ->string alist-ref))
    4949(require-library data-structures)
    5050
     
    5858;(from list-utils egg)
    5959(define (alist? obj)
    60   (and
    61     (list? obj)
    62     (every pair? obj) ) )
     60  (if (pair? obj)
     61    (every pair? obj)
     62    (null? obj) ) )
    6363
    6464;very loose ...
  • release/4/csv-xml/tags/0.11.1/csv-xml.setup

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

    r34218 r34223  
    22
    33(use csv-xml)
     4
     5;;;
    46
    57;Need to process `#lang' as well. So just "commented out" the "offending"
     
    1012(include "test-csv.ss")
    1113
     14;;;
     15
    1216(newline)
    1317
    1418(use test)
     19
     20;;
     21
     22(test-begin "csv-xml in")
    1523
    1624(define +reader-spec-default+ '(
     
    2634))
    2735
    28 (test +reader-spec-default+ (reader-spec))
     36(test "reader-spec defaults"
     37  +reader-spec-default+ (reader-spec))
    2938
    3039(define +reader-spec-default-2+ '(
     
    4049))
    4150
    42 (test +reader-spec-default-2+ (reader-spec #:quote-doubling-escapes? #f))
     51(test "reader-spec overrides"
     52  +reader-spec-default-2+ (reader-spec #:quote-doubling-escapes? #f))
     53
     54(test-end "csv-xml in")
     55
     56;;
    4357
    4458(test-begin "csv-xml out")
    4559
     60;
     61
    4662(define +writer-spec-default+ '(
    47   (newline . #t)
     63  (newline-char . #t)
    4864  (separator-char . #\,)
    4965  (quote-char . #\")
     66  (comment-char . #\#)
     67  (quote-doubling-escapes? . #t)
     68  (quote-controls? . #t)
    5069))
    5170
    52 (test +writer-spec-default+ (writer-spec))
    53 
    5471(define +writer-spec-default-2+ '(
    55   (newline . #f)
     72  (newline-char . #f)
    5673  (separator-char . #\,)
    5774  (quote-char . #\")
     75  (comment-char . #\#)
     76  (quote-doubling-escapes? . #t)
     77  (quote-controls? . #t)
    5878))
    5979
    60 (test +writer-spec-default-2+ (writer-spec #:newline #f))
     80;
     81
     82(test "writer-spec defaults" +writer-spec-default+ (writer-spec))
     83
     84(test "writer-spec overrides" +writer-spec-default-2+ (writer-spec #:newline-char #f))
     85
     86;
    6187
    6288(define +list-in-1+ '((1 22 333) (11 2222 333333)))
    6389
     90(define +list-in-2+ '((1 22 333) "a comment" (11 2222 333333)))
     91
     92#|
    6493(define +list->sxml-out-1+ '(
    65   |*TOP*|
     94  *TOP*
    6695  (scull
    67     (foo 1)
    68     (bar 22)
    69     (baz 333))
     96    (foo "1")
     97    (bar "22")
     98    (baz "333"))
    7099  (scull
    71     (foo 11)
    72     (bar 2222)
    73     (baz 333333))
     100    (foo "11")
     101    (bar "2222")
     102    (baz "333333"))
    74103))
    75104
    76 (test +list->sxml-out-1+ (list->sxml +list-in-1+ 'scull '(foo bar baz)))
     105(define +list->sxml-out-2+ '(
     106  *TOP*
     107  (scull
     108    (foo "1")
     109    (bar "22")
     110    (baz "333"))
     111  (*COMMENT* "a comment")
     112  (scull
     113    (foo "11")
     114    (bar "2222")
     115    (baz "333333"))
     116))
     117
     118;
     119
     120(test "sxml"
     121  +list->sxml-out-1+ (list->sxml +list-in-1+ 'scull '(foo bar baz)))
     122
     123(test "sxml & comment w/ comments"
     124  +list->sxml-out-2+ (list->sxml +list-in-2+ 'scull '(foo bar baz)))
     125|#
     126
     127;
    77128
    78129(use ports)
    79130
    80 (test
     131(test "csv"
    81132  "\"1\",\"22\",\"333\"\n\"11\",\"2222\",\"333333\"\n"
    82133  (with-output-to-string
     
    84135      (list->csv +list-in-1+))))
    85136
     137(test "csv & comment w/ comments"
     138  "\"1\",\"22\",\"333\"\n#a comment\n\"11\",\"2222\",\"333333\"\n"
     139  (with-output-to-string
     140    (lambda ()
     141      (let ((writer
     142              (make-csv-writer
     143                (current-output-port)
     144                (writer-spec #:comment-char #\#))))
     145        ;(test-assert (procedure? writer))
     146        (list->csv +list-in-2+ writer)))))
     147
     148(test "csv & comment w/o comments"
     149  "\"1\",\"22\",\"333\"\na comment\"11\",\"2222\",\"333333\"\n"
     150  (with-output-to-string
     151    (lambda ()
     152      (let ((writer
     153              (make-csv-writer
     154                (current-output-port)
     155                (writer-spec #:comment-char #f))))
     156        ;(test-assert (procedure? writer))
     157        (list->csv +list-in-2+ writer)))))
     158
     159(test-end "csv-xml out")
     160
     161;;
     162
    86163(test-exit)
  • release/4/csv-xml/trunk/csv-out.impl

    r34218 r34223  
    66;;Issues
    77;;
    8 ;;- missing explicit types for exports
    9 
    10 ;;
    11 
    12 (define-constant +newline-default+ #t)  ;#t - <system>
    13 (define-constant +separator-char+ #\,)
    14 (define-constant +quote-char+ #\")
     8;;- missing explicit types for exports; too much '*' type
     9
     10;;
    1511
    1612(define-constant CRLF-STR "\r\n")
     
    1814(define-constant CR-STR "\r") ;old MacOS
    1915
     16(define *system-newline*
     17  (cond-expand
     18    (windows
     19      CRLF-STR )
     20    (unix
     21      LF-STR )
     22    (else
     23      LF-STR ) ) )
     24
     25(define-constant +newline-char-default+ #t)               ;#t - <system> | #\n | ...
     26(define-constant +separator-char-default+ #\,)
     27(define-constant +quote-char-default+ #\")                ;#f | #\" | ...
     28(define-constant +comment-char-default+ #\#)              ;#f | #\# | ...
     29(define-constant +quote-doubling-escapes?-default+ #t)
     30(define-constant +quote-controls?-default+ #t)
     31
     32#|
    2033(define-constant +sxml-top-symbol+ '|*TOP*|)
    2134(define-constant +sxml-row-element-default+ 'row)
    2235(define-constant +sxml-col-elements-limit-default+ 32) ; arbitrary (see csv.ss)
    23 
    24 (define (make-sxml-col-symbol n)
    25   (string->symbol (string-append "col-" (number->string n))) )
    26 
    27 ;;
    28 
    29 ;very loose : newline | separator-char | quote-char
     36|#
     37
     38;;
     39
     40;very loose : newline-char | separator-char | quote-char
     41;see "csv-xml.scm"
    3042(define csv-writer-spec? alist?)
    3143(define-check+error-type csv-writer-spec)
     
    3648;;
    3749
     50(define *default-writer-spec* (writer-spec-with-defaults '()))
     51
    3852(define (list->csv ls #!optional (writer-or-out (current-output-port)))
    39   (let ((writer
    40           (cond
    41             ((csv-writer? writer-or-out)
    42               writer-or-out )
    43             ((output-port? writer-or-out)
    44               (csv-line-writer 'list->csv
    45                 writer-or-out (writer-spec-with-defaults '())) )
    46             (else
    47               (error 'list->csv "invalid csv-writer or output-port" writer-or-out) ) ) ) )
     53  (let (
     54      (writer
     55        (cond
     56          ((csv-writer? writer-or-out)
     57            writer-or-out )
     58          ((output-port? writer-or-out)
     59            (make-csv-line-writer 'list->csv writer-or-out *default-writer-spec*) )
     60          (else
     61            (error 'list->csv "invalid csv-writer or output-port" writer-or-out) ) ) ) )
    4862    (for-each writer ls) ) )
    4963
     64#|
    5065;;
    5166
     
    5368          #!optional
    5469          (row-element (sxml-row-element-default))
    55           (column-elements (sxml-col-elements-default)))
     70          (column-elements (sxml-col-elements-default))
     71          (writer-spec *default-writer-spec*))
    5672  (append!
    5773    `(,(sxml-top-symbol))
    58     (map (cut list->sxml-element <> row-element column-elements) ls)) )
     74    (map (cut list->sxml-element <> row-element column-elements writer-spec) ls)) )
     75|#
    5976
    6077;;
     
    6279(define (writer-spec
    6380          #!key
    64           (newline +newline-default+)
    65           (separator-char +separator-char+)
    66           (quote-char +quote-char+))
    67   `((newline . ,newline)
     81          (newline-char +newline-char-default+)
     82          (separator-char +separator-char-default+)
     83          (quote-char +quote-char-default+)
     84          (comment-char +comment-char-default+)
     85          (quote-doubling-escapes? +quote-doubling-escapes?-default+)
     86          (quote-controls? +quote-controls?-default+))
     87  ;FIXME checking the input types
     88  `((newline-char . ,newline-char)
    6889    (separator-char . ,separator-char)
    69     (quote-char . ,quote-char)) )
    70 
    71 ;;
    72 
    73 (define (make-csv-writer out-or-str #!optional writer-spec)
    74   (let ((actual-make-csv-writer (make-csv-writer-maker writer-spec)))
    75     (actual-make-csv-writer out-or-str) ) )
    76 
    77 (define (make-csv-writer-maker writer-spec)
     90    (quote-char . ,quote-char)
     91    (comment-char . ,comment-char)
     92    (quote-doubling-escapes? . ,quote-doubling-escapes?)
     93    (quote-controls? . ,quote-controls?)) )
     94
     95;;
     96
     97(define (make-csv-writer out-or-str #!optional (writer-spec '()))
     98  (let ((make-spec-csv-writer (make-csv-writer-maker writer-spec)))
     99    (make-spec-csv-writer out-or-str) ) )
     100
     101(define (make-csv-writer-maker #!optional (writer-spec '()))
    78102  (let ((writer-spec
    79103          (writer-spec-with-defaults
     
    90114                (error
    91115                  'csv-writer-maker
    92                   "invalid output-port or stirng" out-or-str) ) ) ) )
    93         (csv-line-writer 'csv-writer-maker out writer-spec) ) ) ) )
    94 
    95 ;;
    96 
    97 (define (csv-line-writer loc out writer-spec)
    98 ;(print 'csv-line-writer " " loc " " out " " writer-spec)
    99   (let* ((writer-spec
     116                  "invalid output-port or string" out-or-str) ) ) ) )
     117        (make-csv-line-writer 'csv-writer-maker out writer-spec) ) ) ) )
     118
     119;;
     120
     121(define (make-csv-line-writer loc out writer-spec)
     122  (let ((writer-spec
    100123          (check-csv-writer-spec loc writer-spec) )
    101          (newline
    102           (select-newline loc (cdr (assq 'newline writer-spec))) )
    103          (separator-char
    104           (cdr (assq 'separator-char writer-spec)) )
    105          (quote-char
    106           (let ((obj (assq 'quote-char writer-spec)))
    107             (if (pair? obj)
    108               (cdr obj)
    109               obj ) ) ) )
    110     (lambda (objs)
    111       (check-list loc objs)
    112       (let* (
    113           (strs
    114             (map ->string objs) )
    115           (qstrs
    116             (if quote-char
    117               (map (cut conc quote-char <> quote-char) strs)
    118               strs ) )
    119            (str
    120             (apply conc (append! (intersperse qstrs separator-char) `(,newline))) ) )
    121         (display str out) ) ) ) )
    122 
    123 ;;
    124 
    125 (define (list->sxml-element ls row-element col-elements)
    126   `(,row-element ,@(map list col-elements ls)) )
    127 
    128 ;;
    129 
    130 (define *system-newline*
    131   (cond-expand
    132     (windows
    133       CRLF-STR )
    134     (unix
    135       LF-STR )
    136     (else
    137       LF-STR ) ) )
    138 
    139 (define (select-newline loc spec)
     124        (newline-obj
     125          (select-newline-object loc (alist-ref 'newline-char writer-spec eq?)) )
     126        (separator-char
     127          (alist-ref 'separator-char writer-spec eq?) )
     128        (quote-char
     129          (alist-ref 'quote-char writer-spec eq?) )
     130        (comment-char
     131          (alist-ref 'comment-char writer-spec eq?) )
     132        (quote-doubling-escapes?
     133          (alist-ref 'quote-doubling-escapes? writer-spec eq?) )
     134        (quote-controls?
     135          (alist-ref 'quote-controls? writer-spec eq?) ) )
     136    (lambda (obj)
     137      (let (
     138          ;build row to output as a string with a line-ending sequence
     139          (lin
     140            ;comment desired?
     141            (if (list? obj)
     142              ;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))) )
     152              ;are we supposed to do comments?
     153              (if comment-char
     154                (conc comment-char obj newline-obj)
     155                obj
     156                #;
     157                (begin
     158                  (warning loc "comments not active" obj writer-spec)
     159                  "" ) ) ) ) )
     160          (display lin out) ) ) ) )
     161
     162;;
     163
     164(define (select-newline-object loc spec)
    140165  (case spec
    141166    ((cr)
     
    146171      CRLF-STR )
    147172    (else
    148       *system-newline*
    149       #; ;be generous - THIS IS NOT A EITHER/OR - only 1 is right
    150       (if (and (boolean? spec) spec)
    151         *system-newline*
    152         (error loc "invalid newline specification" spec) ) ) ) )
    153 
    154 ;;
     173      *system-newline* ) ) )
     174
     175;;
     176
     177(define (writer-spec-with-defaults writer-spec)
     178  `((newline-char . ,(alist-ref 'newline-char writer-spec eq? +newline-char-default+))
     179    (separator-char . ,(alist-ref 'separator-char writer-spec eq? +separator-char-default+))
     180    (quote-char . ,(alist-ref 'quote-char writer-spec eq? +quote-char-default+))
     181    (comment-char . ,(alist-ref 'comment-char writer-spec eq? +comment-char-default+))
     182    (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+))) )
     184
     185#|
     186;;
     187
     188(define (list->sxml-element ls row-element col-elements writer-spec)
     189  (if (list? ls)
     190    ;row data
     191    `(,row-element ,@(map list col-elements (map ->string ls)))
     192    ;are we supposed to do comments?
     193    (if (alist-ref 'comment-char writer-spec eq?)
     194      `(*COMMENT* ,(->string ls))
     195      ls ) ) )
     196
     197(define (make-sxml-col-symbol n)
     198  (string->symbol (string-append "col-" (number->string n))) )
    155199
    156200(define +sxml-col-elements-default+
     
    173217       (ls '() (cons (make-sxml-col-symbol i) ls)) )
    174218      ((= i +sxml-col-elements-limit-default+) ls) ) )
    175 
    176 (define (writer-spec-with-defaults writer-spec)
    177   (let ((newline
    178           (assq 'newline writer-spec) )
    179         (separator-char
    180           (assq 'separator-char writer-spec) )
    181         (quote-char
    182           (let ((obj (assq 'quote-char writer-spec)))
    183             (if (pair? obj)
    184               (cdr obj)
    185               obj ) ) ) )
    186     `((newline . ,(or newline +newline-default+))
    187       (separator-char . ,(or separator-char +separator-char+))
    188       (quote-char . ,(or quote-char +quote-char+))) ) )
     219|#
  • release/4/csv-xml/trunk/csv-xml.scm

    r34218 r34223  
    2626  ;
    2727  list->csv
    28   list->sxml
     28  #;list->sxml
    2929  ;
    3030  csv-writer? check-csv-writer error-csv-writer
     
    4646;;;
    4747
    48 (import (only data-structures conc intersperse ->string))
     48(import (only data-structures conc intersperse ->string alist-ref))
    4949(require-library data-structures)
    5050
     
    5858;(from list-utils egg)
    5959(define (alist? obj)
    60   (and
    61     (list? obj)
    62     (every pair? obj) ) )
     60  (if (pair? obj)
     61    (every pair? obj)
     62    (null? obj) ) )
    6363
    6464;very loose ...
  • release/4/csv-xml/trunk/csv-xml.setup

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

    r34218 r34223  
    22
    33(use csv-xml)
     4
     5;;;
    46
    57;Need to process `#lang' as well. So just "commented out" the "offending"
     
    1012(include "test-csv.ss")
    1113
     14;;;
     15
    1216(newline)
    1317
    1418(use test)
     19
     20;;
     21
     22(test-begin "csv-xml in")
    1523
    1624(define +reader-spec-default+ '(
     
    2634))
    2735
    28 (test +reader-spec-default+ (reader-spec))
     36(test "reader-spec defaults"
     37  +reader-spec-default+ (reader-spec))
    2938
    3039(define +reader-spec-default-2+ '(
     
    4049))
    4150
    42 (test +reader-spec-default-2+ (reader-spec #:quote-doubling-escapes? #f))
     51(test "reader-spec overrides"
     52  +reader-spec-default-2+ (reader-spec #:quote-doubling-escapes? #f))
     53
     54(test-end "csv-xml in")
     55
     56;;
    4357
    4458(test-begin "csv-xml out")
    4559
     60;
     61
    4662(define +writer-spec-default+ '(
    47   (newline . #t)
     63  (newline-char . #t)
    4864  (separator-char . #\,)
    4965  (quote-char . #\")
     66  (comment-char . #\#)
     67  (quote-doubling-escapes? . #t)
     68  (quote-controls? . #t)
    5069))
    5170
    52 (test +writer-spec-default+ (writer-spec))
    53 
    5471(define +writer-spec-default-2+ '(
    55   (newline . #f)
     72  (newline-char . #f)
    5673  (separator-char . #\,)
    5774  (quote-char . #\")
     75  (comment-char . #\#)
     76  (quote-doubling-escapes? . #t)
     77  (quote-controls? . #t)
    5878))
    5979
    60 (test +writer-spec-default-2+ (writer-spec #:newline #f))
     80;
     81
     82(test "writer-spec defaults" +writer-spec-default+ (writer-spec))
     83
     84(test "writer-spec overrides" +writer-spec-default-2+ (writer-spec #:newline-char #f))
     85
     86;
    6187
    6288(define +list-in-1+ '((1 22 333) (11 2222 333333)))
    6389
     90(define +list-in-2+ '((1 22 333) "a comment" (11 2222 333333)))
     91
     92#|
    6493(define +list->sxml-out-1+ '(
    65   |*TOP*|
     94  *TOP*
    6695  (scull
    67     (foo 1)
    68     (bar 22)
    69     (baz 333))
     96    (foo "1")
     97    (bar "22")
     98    (baz "333"))
    7099  (scull
    71     (foo 11)
    72     (bar 2222)
    73     (baz 333333))
     100    (foo "11")
     101    (bar "2222")
     102    (baz "333333"))
    74103))
    75104
    76 (test +list->sxml-out-1+ (list->sxml +list-in-1+ 'scull '(foo bar baz)))
     105(define +list->sxml-out-2+ '(
     106  *TOP*
     107  (scull
     108    (foo "1")
     109    (bar "22")
     110    (baz "333"))
     111  (*COMMENT* "a comment")
     112  (scull
     113    (foo "11")
     114    (bar "2222")
     115    (baz "333333"))
     116))
     117
     118;
     119
     120(test "sxml"
     121  +list->sxml-out-1+ (list->sxml +list-in-1+ 'scull '(foo bar baz)))
     122
     123(test "sxml & comment w/ comments"
     124  +list->sxml-out-2+ (list->sxml +list-in-2+ 'scull '(foo bar baz)))
     125|#
     126
     127;
    77128
    78129(use ports)
    79130
    80 (test
     131(test "csv"
    81132  "\"1\",\"22\",\"333\"\n\"11\",\"2222\",\"333333\"\n"
    82133  (with-output-to-string
     
    84135      (list->csv +list-in-1+))))
    85136
     137(test "csv & comment w/ comments"
     138  "\"1\",\"22\",\"333\"\n#a comment\n\"11\",\"2222\",\"333333\"\n"
     139  (with-output-to-string
     140    (lambda ()
     141      (let ((writer
     142              (make-csv-writer
     143                (current-output-port)
     144                (writer-spec #:comment-char #\#))))
     145        ;(test-assert (procedure? writer))
     146        (list->csv +list-in-2+ writer)))))
     147
     148(test "csv & comment w/o comments"
     149  "\"1\",\"22\",\"333\"\na comment\"11\",\"2222\",\"333333\"\n"
     150  (with-output-to-string
     151    (lambda ()
     152      (let ((writer
     153              (make-csv-writer
     154                (current-output-port)
     155                (writer-spec #:comment-char #f))))
     156        ;(test-assert (procedure? writer))
     157        (list->csv +list-in-2+ writer)))))
     158
     159(test-end "csv-xml out")
     160
     161;;
     162
    86163(test-exit)
Note: See TracChangeset for help on using the changeset viewer.