;;;
;;; <mime-util.ss> ---- Extra utilities
;;; Time-stamp: <01/05/07 17:41:12 solsona>
;;;
;;; Copyright (C) 2001 by Francisco Solsona. 
;;;
;;; This file is part of mime-plt.

;;; mime-plt is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
;;; License as published by the Free Software Foundation; either
;;; version 2.1 of the License, or (at your option) any later version.

;;; mime-plt is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; Lesser General Public License for more details.

;;; You should have received a copy of the GNU Lesser General Public
;;; License along with mime-plt; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

;;; Author: Francisco Solsona <solsona@acm.org>
;;
;;
;; Commentary:

(module mime-util mzscheme
  (require (lib "etc.ss"))

  (provide string-tokenizer
           trim-all-spaces
           trim-spaces
           trim-comments
           lowercase
           warning
           cat)

  ;; string-index returns the leftmost index in string s
  ;; that has character c
  (define string-index
    (lambda (s c)
      (let ((n (string-length s)))
	(let loop ((i 0))
	  (cond ((>= i n) #f)
		((char=? (string-ref s i) c) i)
		(else (loop (+ i 1))))))))

  ;; string-tokenizer breaks string s into substrings separated by character c
  (define string-tokenizer
    (lambda (c s)
      (let loop ((s s))
	(if (string=? s "") '()
	    (let ((i (string-index s c)))
	      (if i (cons (substring s 0 i)
			  (loop (substring s (+ i 1)
					   (string-length s))))
		  (list s)))))))

  ;; Trim all spaces, except those in quoted strings.
  (define re:quote-start (regexp "\""))
  (define re:space (regexp "[ \t\n\r\v]"))
  (define trim-all-spaces
    (lambda (str)
      ;; Break out alternate quoted and unquoted parts.
      ;; Initial and final string are unquoted.
      (let-values ([(unquoted quoted)
		    (let loop ([str str][unquoted null][quoted null])
		      (let ([m (regexp-match-positions re:quote-start str)])
			(if m
			    (let ([prefix (substring str 0 (caar m))]
				  [rest (substring str (add1 (caar m)) (string-length str))])
			      ;; Find closing quote
			      (let ([m (regexp-match-positions re:quote-start rest)])
				(if m
				    (let ([inside (substring rest 0 (caar m))]
					  [rest (substring rest (add1 (caar m)) (string-length rest))])
				      (loop rest (cons prefix unquoted) (cons (format "\"~a\"" inside) quoted)))
				    ;; No closing quote! 
				    (loop "" (cons prefix unquoted) (cons (format "\"~a" rest) quoted)))))
			    (values (reverse! (cons str unquoted)) (reverse! quoted)))))])
          ;; Put the pieces back together, stripping spaces for unquoted parts:
	  (apply
	   string-append
	   (let loop ([unquoted unquoted][quoted quoted])
	     (let ([clean (regexp-replace* re:space (car unquoted) "")])
	       (if (null? quoted)
		   (list clean)
		   (list* clean
			  (car quoted)
			  (loop (cdr unquoted) (cdr quoted))))))))))

  ;; Only trims left and right spaces:
  (define trim-spaces
    (lambda (str)
      (trim-right (trim-left str))))

  (define re:left-spaces (regexp "^[ \t\r\n\v]+"))
  (define trim-left
    (lambda (str)
      (regexp-replace re:left-spaces str "")))

  (define re:right-spaces (regexp "[ \t\r\n\v]+$"))
  (define trim-right
    (lambda (str)
      (regexp-replace re:right-spaces str "")))

  (define re:comments (regexp "^[^\"]*(\"[^\"]*\")*[^\"]*(\\(.*\\))"))
  (define trim-comments
    (lambda (str)
      (let* ((positions (regexp-match-positions re:comments str)))
	(if positions
	    (string-append (substring str 0 (caaddr positions))
			   (substring str (cdaddr positions) (string-length str)))
	    str))))

  (define lowercase
    (lambda (str)
      (let loop ((out "") (rest str) (size (string-length str)))
	(cond ((zero? size) out)
	      (else
	       (loop (string-append out (string
					 (char-downcase
					  (string-ref rest 0))))
		     (substring rest 1 size)
		     (sub1 size)))))))

  (define warning void)
#|
    (lambda (msg . args)
      (fprintf (current-error-port)
	       (apply format (cons msg args)))
      (newline (current-error-port))))
|#

  ;; Copies its input `in' to its ouput port if given, it uses
  ;; current-output-port if out is not provided.
  (define cat
    (opt-lambda (in (out (current-output-port)))
		(let loop ((ln (read-line in)))
		  (unless (eof-object? ln)
			  (fprintf out "~a~n" ln)
			  (loop (read-line in))))))

  )
;;; mime-util.ss ends here