;;; glob.scm: String matching for filenames (a la BASH).
;;; Copyright (C) 1998 Radey Shouman.
;
;Permission to copy this software, to redistribute it, and to use it
;for any purpose is granted, subject to the following restrictions and
;understandings.
;
;1.  Any copy made of this software must include this copyright notice
;in full.
;
;2.  I have made no warrantee or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3.  In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.

;;$Header: /usr/local/cvsroot/slib/glob.scm,v 1.2 1998/09/03 15:34:59 jaffer Exp $
;;$Name:  $

(define (glob:match?? pat)
  (glob:make-matcher pat char-ci=? char=?))
(define (glob:match-ci?? pat)
  (glob:make-matcher pat char-ci<=? char<=?))

(define (glob:make-matcher pat ch=? ch<=?)
  (define (match-end str k)
    (= k (string-length str)))
  (define (match-char ch nxt)
    (lambda (str k)
      (and (< k (string-length str))
	   (ch=? ch (string-ref str k))
	   (nxt str (+ k 1)))))
  (define (match-? nxt)
    (lambda (str k)
      (and (< k (string-length str))
	   (nxt str (+ k 1)))))
  (define (match-set1 chrs)
    (let recur ((i 0))
      (cond ((= i (string-length chrs))
	     (lambda (ch) #f))
	    ((and (< (+ i 2) (string-length chrs))
		  (char=? #\- (string-ref chrs (+ i 1))))
	     (let ((nxt (recur (+ i 3))))
	       (lambda (ch)
		 (or (and (ch<=? ch (string-ref chrs (+ i 2)))
			  (ch<=? (string-ref chrs i) ch))
		     (nxt ch)))))
	    (else
	     (let ((nxt (recur (+ i 1)))
		   (chrsi (string-ref chrs i)))
	       (lambda (ch)
		 (or (ch=? chrsi ch) (nxt ch))))))))
  (define (match-set chrs nxt)
    (if (and (positive? (string-length chrs))
	     (memv (string-ref chrs 0) '(#\^ #\!)))
	(let ((pred (match-set1 (substring chrs 1 (string-length chrs)))))
	  (lambda (str k)
	    (and (< k (string-length str))
		 (not (pred (string-ref str k)))
		 (nxt str (+ k 1)))))
	(let ((pred (match-set1 chrs)))
	  (lambda (str k)
	    (and (< k (string-length str))
		 (pred (string-ref str k))
		 (nxt str (+ k 1)))))))
  (define (match-* nxt)
    (lambda (str k)
      (let loop ((kk (string-length str)))
	(and (>= kk k)
	     (or (nxt str kk)
		 (loop (- kk 1)))))))

  (let ((matcher
	 (let recur ((i 0))
	   (if (= i (string-length pat))
	       match-end
	       (let ((pch (string-ref pat i)))
		 (case pch
		   ((#\?)
		    (let ((nxt (recur (+ i 1))))
		      (match-? nxt)))
		   ((#\*)
		    (let ((nxt (recur (+ i 1))))
		      (match-* nxt)))
		   ((#\[)
		    (let ((j
			   (let search ((j (+ i 2)))
			     (cond
			      ((>= j (string-length pat))
			       (slib:error 'glob:make-matcher 
					   "unmatched [" pat))
			      ((char=? #\] (string-ref pat j))
			       (if (and (< (+ j 1) (string-length pat))
					(char=? #\] (string-ref pat (+ j 1))))
				   (+ j 1)
				   j))
			      (else (search (+ j 1)))))))
		      (let ((nxt (recur (+ j 1))))
			(match-set (substring pat (+ i 1) j) nxt))))
		   (else (let ((nxt (recur (+ i 1))))
			   (match-char pch nxt)))))))))
    (lambda (str) (matcher str 0))))

(define filename:match?? glob:match??)
(define filename:match-ci?? glob:match-ci??)

(define (replace-suffix str old new)
  (define (cs str)
    (let* ((len (string-length str))
	   (re (- len (string-length old))))
      (cond ((string-ci=? old (substring str re len))
	     (string-append (substring str 0 re) new))
	    (else
	     (slib:error 'replace-suffix "suffix doesn't match:"
			 old str)))))
  (if (string? str) (cs str) (map cs str)))