[ create a new paste ] login | about

Project: programmingpraxis
Link: http://programmingpraxis.codepad.org/h3ENphv5    [ raw code | fork ]

programmingpraxis - Scheme, pasted on Oct 17:
(define (read-fixed-record size defs . port)
  (let ((p (if (null? port) (current-input-port) (car port))))
    (let ((fix-rec (read-chars size p)))
      (if (eof-object? fix-rec)
          fix-rec
          (let loop ((defs defs) (result '()))
            (if (null? defs)
                (reverse result)
                (loop (cdr defs)
                      (cons (substring fix-rec (caar defs) (cadar defs)) result))))))))

(define (read-chars n . port)
  (let ((p (if (null? port) (current-input-port) (car port))))
    (if (eof-object? (peek-char p))
        (peek-char p)
        (let loop ((n n) (c (peek-char p)) (s '()))
          (cond ((and (eof-object? c) (pair? s)) (list->string (reverse s)))
                ((eof-object? c) c)
                ((zero? n) (list->string (reverse s)))
                (else (let ((c (read-char p)))
                        (loop (sub1 n) (peek-char p) (cons c s)))))))))

(define (read-delim-record . args)
  (define (eat p c)
    (if (and (not (eof-object? (peek-char p)))
             (char=? (peek-char p) c))
        (read-char p)))
  (define (read-delim delim port)
    (cond ((eof-object? (peek-char port)) (peek-char port))
          ((and delim (or (char=? delim #\return) (char=? delim #\newline)))
            (let loop ((f (read-line port)) (fields '()))
              (if (or (eof-object? f) (string=? f ""))
                  (reverse fields)
                  (loop (read-line port) (cons f fields)))))
          (else
            (let loop ((c (read-char port)) (field '()) (fields '()))
              (cond ((eof-object? c) (reverse (cons (list->string (reverse field)) fields)))
                    ((char=? #\return c) (eat port #\newline)
                      (reverse (cons (list->string (reverse field)) fields)))
                    ((char=? #\newline c) (eat port #\return)
                      (reverse (cons (list->string (reverse field)) fields)))
                    ((and delim (char=? delim c))
                      (loop (read-char port) '() (cons (list->string (reverse field)) fields)))
                    ((char-whitespace? c)
                      (if (char-whitespace? (peek-char port))
                          (loop (read-char port) field fields)
                          (loop (read-char port) '()
                                (cons (list->string (reverse field)) fields))))
                    (else (loop (read-char port) (cons c field) fields)))))))
  (cond ((null? args) (read-delim #f (current-input-port)))
        ((and (null? (cdr args)) (char? (car args)))
          (read-delim (car args) (current-input-port)))
        ((and (null? (cdr args)) (port? (car args)))
          (read-delim #f (car args)))
        ((and (pair? (cdr args)) (null? (cddr args)) (char? (car args)) (port? (cadr args)))
          (read-delim (car args) (cadr args)))
        (else (read-delim #f (current-input-port)))))

(define (read-csv-record . args)
  (define (read-csv delim port)
    (define (add-field field fields)
      (cons (list->string (reverse field)) fields))
    (define (start field fields)
      (let ((c (read-char port)))
        (cond ((eof-object? c) (reverse fields))
              ((char=? #\return c) (carriage-return field fields))
              ((char=? #\newline c) (line-feed field fields))
              ((char=? #\" c) (quoted-field field fields))
              ((char=? delim c) (not-field '() (add-field field fields)))
              (else (unquoted-field (cons c field) fields)))))
    (define (not-field field fields)
      (let ((c (read-char port)))
        (cond ((eof-object? c) (cons "" fields))
              ((char=? #\return c) (carriage-return '() (add-field field fields)))
              ((char=? #\newline c) (line-feed '() (add-field field fields)))
              ((char=? #\" c) (quoted-field field fields))
              ((char=? delim c) (not-field '() (add-field field fields)))
              (else (unquoted-field (cons c field) fields)))))
    (define (quoted-field field fields)
      (let ((c (read-char port)))
        (cond ((eof-object? c) (add-field field fields))
              ((char=? #\" c) (may-be-doubled-quotes field fields))
              (else (quoted-field (cons c field) fields)))))
    (define (may-be-doubled-quotes field fields)
      (let ((c (read-char port)))
        (cond ((eof-object? c) (add-field field fields))
              ((char=? #\return c) (carriage-return '() (add-field field fields)))
              ((char=? #\newline c) (line-feed '() (add-field field fields)))
              ((char=? #\" c) (quoted-field (cons #\" field) fields))
              ((char=? delim c) (not-field '() (add-field field fields)))
              (else (unquoted-field (cons c field) fields)))))
    (define (unquoted-field field fields)
      (let ((c (read-char port)))
        (cond ((eof-object? c) (add-field field fields))
              ((char=? #\return c) (carriage-return '() (add-field field fields)))
              ((char=? #\newline c) (line-feed '() (add-field field fields)))
              ((char=? delim c) (not-field '() (add-field field fields)))
              (else (unquoted-field (cons c field) fields)))))
    (define (carriage-return field fields)
      (let ((c (peek-char port)))
        (cond ((eof-object? c) fields)
              ((char=? #\newline c) (read-char port) fields)
              (else fields))))
    (define (line-feed field fields)
      (let ((c (peek-char port)))
        (cond ((eof-object? c) fields)
              ((char=? #\return c) (read-char port) fields)
              (else fields))))
    (if (eof-object? (peek-char port)) (peek-char port) (reverse (start '() '()))))
  (cond ((null? args) (read-csv #\, (current-input-port)))
        ((and (null? (cdr args)) (char? (car args)))
          (read-csv (car args) (current-input-port)))
        ((and (null? (cdr args)) (port? (car args)))
          (read-csv #\, (car args)))
        ((and (pair? (cdr args)) (null? (cddr args)) (char? (car args)) (port? (cadr args)))
          (read-csv (car args) (cadr args)))
        (else (read-csv #\, (current-input-port)))))

(define (read-name-value-record . args)
  (define (eat p c)
    (if (and (not (eof-object? (peek-char p)))
             (char=? (peek-char p) c))
        (read-char p)))
  (define (read-name-value delim port)
    (if (eof-object? (peek-char port))
        (peek-char port)
        (let loop ((c (read-char port)) (key '()) (value '()) (fields '()))
          (if (string? key)
              (cond ((eof-object? c)
                      (reverse (cons (cons key (list->string (reverse value))) fields)))
                    ((char=? #\return c) (eat port #\newline)
                      (loop (read-char port) '() '()
                            (cons (cons key (list->string (reverse value))) fields)))
                    ((char=? #\newline c) (eat port #\return)
                      (loop (read-char port) '() '()
                            (cons (cons key (list->string (reverse value))) fields)))
                    (else (loop (read-char port) key (cons c value) fields)))
              (cond ((eof-object? c)
                      (reverse (cons (cons (list->string (reverse key)) "") fields)))
                    ((char=? #\return c) (eat port #\newline)
                      (reverse (cons (cons (list->string (reverse key)) "") fields)))
                    ((char=? #\newline c) (eat port #\return)
                      (reverse (cons (cons (list->string (reverse key)) "") fields)))
                    ((and delim (char=? delim c))
                      (loop (read-char port) (list->string (reverse key)) value fields))
                    ((and (not delim) (char-whitespace? c))
                      (if (char-whitespace? (peek-char port))
                          (loop (read-char port) key value fields)
                          (loop (read-char port) (list->string (reverse key)) value fields)))
                    (else (loop (read-char port) (cons c key) value fields)))))))
  (cond ((null? args) (read-name-value #f (current-input-port)))
        ((and (null? (cdr args)) (char? (car args)))
          (read-name-value (car args) (current-input-port)))
        ((and (null? (cdr args)) (port? (car args)))
          (read-name-value #f (car args)))
        ((and (pair? (cdr args)) (null? (cddr args)) (char? (car args)) (port? (cadr args)))
          (read-name-value (car args) (cadr args)))
        (else (read-name-value #f (current-input-port)))))


Output:
No errors or program output.


Create a new paste based on this one


Comments: