(require 'common-list-functions)
(require 'dynamic-wind)
(require 'format)
(require 'posix-time)

;;; NO!  DO NOT require this!  SCM's got it built-in, and the SLIB
;;; version uses tempfiles.  This is inefficient, but it's worse---
;;; given that we also use encrypting string ports, this means that
;;; cleartext could be momentarily left on disk, and will still exist
;;; in the "deleted" blocks even afterwards.
;;; (require 'string-port)

;;; It's surprising how often I need to check if something is #<unspecified>...

(define *unspecified* (if #f #f))

;;;; Macros.
;;;; Note that these -must- come first, because other things need them!

;;; I -always- need these!  I should also go back through the sources
;;; & find places where I used some less obvious
;;; circumlocution and fix them to use one of these.  --- Foner 17 Jun 96.
(defmacro when (condition . actions)
  `(cond (,condition ,@actions)))
;;; Note!  -Not- "(,(not condition))", which is completely different!
;;; (expand-time vs interp-time)
(defmacro unless (condition . actions)
  `(cond ((not ,condition) ,@actions)))

;;; Another handy couple from Common Lisp, where they were incf and decf.
;;; Note also that, unlike CL, this can't really increment arbitrary locations.
;;; They return the result, for convenience.
(defmacro inc! (location)
  `(begin
     (set! ,location (1+ ,location))
     ,location))
(defmacro dec! (location)
  `(begin
     (set! ,location (1- ,location))
     ,location))

;;; Pushes ITEM on SOME-LIST unconditionally.
(defmacro push! (item some-list)
  `(begin
     (set! ,some-list (cons ,item ,some-list))
     ,some-list))			; Return the new list, for convenience.

;;; Only pushes on ITEM if it's not already on SOME-LIST.  If it is, we just leave the list alone.
;;; PREDICATE, if supplied, should be some binary comparison predicate.  (If you want a unary thingie
;;; as FIND-IF tends to use, you'll have to cons up your own.)
;;; Note that this is like a more-flexible version of COMLIST:ADJOIN.
(defmacro pushnew! (item some-list . predicate)	; If unsupplied, defaults to eq?.
  `(let* ((.item. ,item)		; Capture its value, in case it isn't idempotent!
	  (real-predicate		; Can't just say "(or ,predicate 'eq?)" 'cause '() != #f !
	  ,(if (null? predicate)	; %%% Note that this captures "real-predicate".  Should fix this.
	      `(lambda (.elt.)
		(eq? .elt. .item.))
	      `(lambda (.elt.)		; %%% Captures ".elt.".  Hope we don't need it!
		(,(car predicate) .elt. .item.))))) ; OPTIONS is actually a list, so get the real predicate.
     (unless (find-if real-predicate ,some-list)
       (push! .item. ,some-list))
     ,some-list))

;;; Like PUSHNEW!, but -replaces- any existing item found there.
;;; This implementation isn't quite right, because it removes any existing
;;; match(es), then pushes the new one on the front.  It -should- preserve
;;; the original order, but doing so is a little harder.  Anyone care to fix this?
(defmacro pushnew-replace! (item some-list . predicate)	; If unsupplied, defaults to eq?.
  `(let ((real-predicate		; Can't just say "(or ,predicate 'eq?)" 'cause '() != #f !
	  ,(if (null? predicate)	; %%% Note that this captures "real-predicate".  Should fix this.
	      `(lambda (.elt.)
		(eq? .elt. ,item))
	      `(lambda (.elt.)		; %%% Captures ".elt.".  Hope we don't need it!
		(,(car predicate) .elt. ,item))))) ; OPTIONS is actually a list, so get the real predicate.
     (set! ,some-list (remove-if real-predicate ,some-list)) ; First, make sure the old one is gone.
     (push! ,item ,some-list)		; Now just push the new one on the list.
     ,some-list))

(defmacro coerce-to-string1 (name)
    (if (string? name)
        name
        (symbol->string name)))

(defmacro with-local-bindings-export (export-list bindings . defines)
  (let* ((this-name (create-name "local-environment-" (gentemp)))
	 (defined-vars export-list)
	 (case-clauses (w-l-b:generate-cases this-name defined-vars))
	 (real-defines (w-l-b:generate-real-defines this-name defined-vars)))
    `(begin
       (define ,this-name
	 (let ,bindings
	   ,@defines
	   (lambda (var)
	     (case var
	       ,@case-clauses))))
       ,@real-defines)))

(defmacro with-local-bindings (bindings . defines)
  (let* ((this-name (create-name "local-environment-" (gentemp)))
	 (defined-vars (w-l-b:get-defined-vars defines))
	 (case-clauses (w-l-b:generate-cases this-name defined-vars))
	 (real-defines (w-l-b:generate-real-defines this-name defined-vars)))
    `(begin
       (define ,this-name
	 (let ,bindings
	   ,@defines
	   (lambda (var)
	     (case var
	       ,@case-clauses))))
       ,@real-defines)))

(define (w-l-b:generate-cases this-name defines)
  (append
   (map (lambda (def) `((,def) ,def)) defines)
   `((else (error "with-local-bindings: undefined var " var
		 " in local envronment" ,this-name)))))

(define (w-l-b:get-defined-vars defines)
  (remove #f (map (lambda (def)
		    (and (list? def)
			 (>= (length def) 3)
			 (eq? (car def) 'define)
			 (if (pair? (cadr def))
			     (caadr def) ; (define (blah args)
			     (cadr def)))) ; (define blah
		  defines)))

(define (eval-in-new-env proc-list bindings)
    (eval `(let ,bindings ,proc-list)))

(define (w-l-b:generate-real-defines this-name defines)
  (map (lambda (def) `(define ,def (,this-name ',def))) defines))

;;;; Figuring out where to store our permanent state.

;;; +++ Debugging version:  includes the local host.
;;; (define (yenta-name fname)
;;;   
;;; +++ Normal version:  host-independent.

;;; If this is set, it is used instead of $HOME/.Yenta.
;;; It should presumably have a trailing slash.
;;; Overrides all other variable-settings.
;;;
;;; NOTE!  This affects yenta-name immediately, but any Savant databases
;;; that have already been opened will -not- pick up the change!  This
;;; means that you'd better set this very early in start-yenta.
(define *yenta-name-override* #f)

;;; If this is set, we'll include the hostname in our location.
;;; Intended only so we can be different virtual people on different
;;; hosts, while debugging---if users set this in the shipped world,
;;; they'have have different personae on various machines, which is
;;; -not- what we want or they'll expect...
(define *yenta-one-persona-per-host* #f)

;;; Given a filename, compute a complete pathname, used for saving state.
(define (yenta-name fname)
  (string-append
   (or *yenta-name-override*
       (format nil "~A/.Yenta~:[/~*~;.~A/~]"
	       (getenv "HOME")
	       *yenta-one-persona-per-host*
	       (local-host)))
   fname))

;;;; String utilities.

(define (string-map f s)
  (let* ((slen (string-length s))
	 (ns (make-string slen)))
    (do ((i (- slen 1) (- i 1)))
	((< i 0) ns)
      (string-set! ns i (f (string-ref s i))))))

(define (index arg-string char . start)
  (let* ((start (optional-arg start 0))
	 (str-len (string-length arg-string)))
    (let lp ((i start))
      (cond ((= i str-len) #f)
	    ((char=? (string-ref arg-string i) char) i)
	    (else (lp (+ i 1)))))))

(define (infix-split separator string)
  ;; Separator - a regular expression
  ;; string - string to be split.
  ;; Returns a list of substrings of string,
  ;; split at the separator
  ;; (infix-split "=" "a=") returns ("a" "")
  ;; while (string-split "=" "a=") returns #("a")
  (let lp ((start 0) (result '()))
    (let ((matchv (regsearchv separator string start)))
      (if matchv
	  (lp (vector-ref matchv 1)
	      (cons (substring string start (vector-ref matchv 0))
		    result))
	  (reverse (cons (substring string start (string-length string))
			 result))))))

(define (string-tail string length)
  (substring string  (- (string-length string) length)
	     (string-length string)))

;;; Finds the first line of a string.
(define (get-first-line str)
  (when (string=? str)
    (let ((end (string-length str)))
      (do ((i 0 (1+ i))
	   (char (string-ref str 0) (string-ref str (1+ i))))
	  ((or (= (1+ i) end) (eq? char #\nl)) (substring str 0 i))
	()))))
	 
#|
(define (char-set-index str cset . maybe-start)
  (let ((start (max 0 (optional-arg maybe-start 0)))
	(len (string-length str)))
    (do ((i start (+ 1 i)))
	((or (>= i len)
	     (char-set-contains? cset (string-ref str i)))
	 (and (< i len) i)))))

(define (char-set-rindex str cset . maybe-start)
  (let* ((len (string-length str))
	 (start (min (optional-arg maybe-start len)
		     len)))
    (do ((i (- start 1) (- i 1)))
	((or (< i 0)
	     (char-set-contains? cset (string-ref str i)))
	 (and (>= i 0) i)))))
|#

(define (string-reduce nil cons s)	; %%% No apparent callers.
  (let ((slen (string-length s)))
    (do ((ans nil (cons (string-ref s i) ans))
	 (i 0 (+ i 1)))
	((= i slen) ans))))

(define (string-prefix? prefix string)
  (let ((plen (string-length prefix))
	(slen (string-length string)))
    (and (<= plen slen)
	 (let lp ((i 0))
	   (or (= i plen)
	       (and (char=? (string-ref prefix i)
			    (string-ref string i))
		    (lp (+ i 1))))))))

(define (string-suffix? suffix string)
  (let ((slen (string-length suffix))
	(len (string-length string)))
    (and (<= slen len)
	 (let lp ((i (- slen 1))
		  (j (-  len 1)))
	   (or (< i 0)
	       (and (char=? (string-ref suffix i)
			    (string-ref string j))
		    (lp (- i 1) (- j 1))))))))

(define (trim-string-suffix string suffix)
  (let ((st-length (string-length string))
	(suffix-length (string-length suffix)))
    (if (and (>= st-length suffix-length)
	     (string=? (substring string (- st-length suffix-length)
				  st-length)
		       suffix))
      (substring string 0 (- st-length suffix-length))
      string)))

(define whitespace (regcomp "[ \t\n]+"))
(define non-whitespace (regcomp "[^ \t\n]+"))

(define (skip-whitespace s)		; %%% I don't think anything actually calls this...
  (regsearch non-whitespace s))

(define (remove-whitespace s)
  (string-edit whitespace "" s #t))

;;; These two are macros to eliminate a subroutine call, since they're liable to be in inner loops.
(defmacro eof-or-char-whitespace? (char)
  `(or (eof-object? ,char) (char-whitespace? ,char)))
(defmacro eof-or-char-not-whitespace? (char)
  `(or (eof-object? ,char) (not (char-whitespace? ,char))))

(define (join-strings stringlist separator)
  (if (null? stringlist)
      ""
      (let* ((separator-length (string-length separator))
	     (strings-length (apply + (map string-length stringlist)))
	     (total-length (+ strings-length
			      (* separator-length
				 (- (length stringlist) 1))))
	     (ns (make-string total-length)))
	(do ((rest stringlist (cdr rest))
	     (i 0 (+ i separator-length)))
	    ((null? rest)
	     ns)
	  (let ((current-string (car rest)))
	    (copy-string! current-string ns 0 i)
	    (set! i (+ i (string-length current-string)))
	    (copy-string! separator ns 0 i))))))

(define (one-two-and-three l)		; Produces "one" or "one and two" or "one, two, and three" or "one, two, three, and four", etc.
  (one-two-and-three-internal l ", " "and"))

(define (one-two-or-three l)
  (one-two-and-three-internal l ", " "or"))

(define (one-two-and-three-internal l comma conj)
  (case (length l)
    ((0) "")
    ((1) (car l))
    ((2) (string-append (car l) " " conj " " (cadr l)))
    (else
     (string-append (join-strings (butlast l 1) comma) comma conj " " (car (last l 1))))))

(define (copy-string! from-string to-string . indexes)
  (let* ((indexes (parse-optionals indexes 0 0 #f))
	 (from-start (car indexes))
	 (to-start (cadr indexes))
	 (copy-length (caddr indexes))
	 (num-chars (min (- (string-length from-string) from-start)
			 (- (string-length to-string) to-start)
			 (or copy-length most-positive-fixnum))))
    (do ((i from-start (+ i 1))
	 (j to-start (+ j 1)))
	((= (- i from-start) num-chars) num-chars)
      (string-set! to-string j (string-ref from-string i)))))
	 
;;; Returns the list of indexes at which the re starts in the string.
;;; Returns '(), not #f! if there are no valid matches.
(define (substring-indexes re string)
    (let lp ((index-vect (regsearchv re string)) (result '()))
      ;; regsearchv returns a vector of 2 elements:
      ;; #(starting-index-of-match(inclusive) ending-index-of-match(exclusive))
      ;; e.g. (regsearchv "bcd" "abcd") = #(1 4)
      (cond ((not index-vect) (reverse result))
	    ;; This case is necessary if the pattern matches ""
	    ;; then regsearchv will return a vector of form #(x x)
	    ;; and substring-indexes could go into an infinite loop if
	    ;; this is not handled as a special case.
	    ((= (vector-ref index-vect 0)
		(vector-ref index-vect 1))
	     (lp (regsearchv re string (+ 1(vector-ref index-vect 1)))
		 result))
	    (else
	     (lp (regsearchv re string (vector-ref index-vect 1))
		 (cons (vector-ref index-vect 0) result))))))

(define (string->words s)
  (vector->list (string-split whitespace s)))

(define (hex-digit->integer char)
  (cond ((and (char>=? char #\0) (char<=? char #\9))
	 (- (char->integer char) (char->integer #\0)))
	(else (+ 10 (- (char->integer (char-upcase char)) 
		       (char->integer #\A))))))

(define (hex-string->integer str)
  (do ((pos 0 (+ 1 pos))
       (ret 0 ret))
      ((= pos (string-length str)) ret)
    (set! ret (+ (* ret 16) (hex-digit->integer (string-ref str pos))))))

(define (url-encode str)
  (apply string-append			; Be paranoid.
	 (map (lambda (c)
		(cond
		 ((or (char-alphabetic? c)
		      (char-numeric? c))
		  (make-string 1 c))
		 ((eq? c #\space) "+")
		 (else (format #f "%~2,48,X" (char->integer c)))))
	      (string->list str))))

;;; +++ Strings that aren't O(n^2) if you're appending characters one at a time.
(define (sr:make-string k)
  (let((new-str (make-string k #\a)))
    (cons "string-resource" (cons 0 (cons k (cons new-str '()))))))

(define (sr:add-char! char sr)
  (let ((str cadddr)
	(k cadr)
	(length caddr))
    (begin (set-car! (cdr sr) (+ (k sr) 1))
	   (cond ((= (k sr) (length sr))
		  (set-car! (cdddr sr) 
			    (string-append (str sr) 
					   (str (sr:make-string 
						 (length sr)))))
		  (set-car! (cddr sr)
			    (* 2 (length sr)))
		  (string-set! (str sr) (- (k sr) 1) char))
		 (t
		  (string-set! (str sr) (- (k sr) 1) char))))))

(define (sr:to-string sr)
  (substring (cadddr sr) 0 (cadr sr)))
;;; ---			 

;;;; List and vector utilities.

(define (list-set! lst index new-value)
  (cond ((= 0 index) (set-car! lst new-value))
	(else (list-set! (cdr lst) (- index 1) new-value))))

(define (vector-map proc vect1 . vectors)
  (let ((ans (make-vector (vector-length vect1))))
    (do ((i (- (vector-length vect1) 1) (- i 1)))
	((negative? i) ans)
      (vector-set! ans i
		   (apply proc (vector-ref vect1 i)
			  (map (lambda (v) (vector-ref v i))
			       vectors))))))

(define (vector-for-each proc vect1 . vectors)
  (let ((ans (make-vector (vector-length vect1))))
    (do ((i (- (vector-length vect1) 1) (- i 1)))
	((negative? i) ans)
      (apply proc (vector-ref vect1 i)
	     (map (lambda (v) (vector-ref v i))
		  vectors)))))
 
(define (vector-reduce combiner init vector)
  (do ((i 0 (+ i 1))
       (sum init
	    (combiner sum (vector-ref vector i))))
       ((= i (vector-length vector)) sum)
       #t))

;;; argl is an argument list
;;; Fills the empty spaces in argl with default-values
;;; and returns the modified list. If there are more values
;;; in argl than in default-values then result is the same as argl
(define (parse-optionals argl . default-values)
  (if (>= (length argl) (length default-values))
      argl
      (append argl (nthcdr (length argl) default-values))))

;;; A version of parse-optionals for one optional argument.
(define (optional-arg argl default)
  (if (null? argl)
      default
      (car argl)))

(define (nth n l)
  (list-ref l n))

(define (nthlast n l)
  (list-ref l (- (length l) n)))


(define (rev-append! a b)
  (nconc (nreverse a) b))

(define (already-exists? key alist)
   (if (null? alist)
	#f
	(or (equal? key (caar alist))
	    (already-exists? key (cdr alist)))))

(define (lookup key alist)
  (let ((x (assoc key alist)))
    (and x (cdr x))))

(define (alist-set! key value alist)
  (if (assoc key alist)
      (set-cdr! (assoc key alist) value)
      (set-cdr! alist (acons key value (cdr alist)))))


(define (tagged-pair? pair tag) 
  (and (pair? pair) (eq? (car pair) tag)))

(define (delq item lst)
  (cond ((null? lst) '())
	((eq? item (car lst)) (cdr lst))
	(else (cons (car lst) (delq item (cdr lst))))))

(define (delete! item lst)
  (cond ((null? lst) #f)
	((null? (cdr lst)) #f)
	((equal? item (cadr lst)) 
	 (set-cdr! lst (cddr lst))
	 #t)
	(else (delete! item (cdr lst)))))

(define (alist-remove key alist)
  (let ((new-lst (delq (assoc key alist) alist)))
    ;; This assumes the key only appears once.
    new-lst))

;;; Returns a list which contains the elements of lst for which proc returns a true value.
;;; %%% Bleah!  We should use the common-list-functions equivalent...  and maybe similar
;;; %%% for many of the functions near here...
(define (filter proc lst)
  (if (null? lst)
      '()
      (if (proc (car lst))
	  (cons (car lst) (filter proc (cdr lst)))
	  (filter proc (cdr lst)))))

(define (tree-replace old new tree)
  (cond ((null? tree) '())
	((equal? tree old) new)
	((pair? tree) (cons (tree-replace old new (car tree))
			    (tree-replace old new (cdr tree))))
	(else tree)))

(define (tree-shape tree)
  (cond ((null? tree) '())
	((vector? tree) (vector-map tree-shape tree))
	((pair? tree) (cons (tree-shape (car tree)) (tree-shape (cdr tree))))
	((number? tree) 'number)
	((string? tree) 'string)
	((symbol? tree) 'symbol)
	(else 'leaf)))

(define (leaves tree)
  (define (rec tree lst)
    (cond ((pair? tree)
	   (rec (car tree) (rec (cdr tree) lst)))
	  ((null? tree)
	   lst)
	  (else
	   (cons tree lst))))
  (rec tree '()))

(define (list-of count elt)
  ;; Return a list of count copies of (elt).
  (if (> count 0)
      (cons (elt) (list-of (- count 1) elt))
      '()))

;;; Returns a list for which each element defined in lst other than the one
;;; with index ref is the same as in lst, the element with index ref is obj, 
;;; and any elements before ref which are not defined in lst are nil.
;;; That is to say, it sets the specified element of the list, growing the list
;;; to accomodate it if necessary.  Does not modify the original list.
(define (set-list-ref lst ref obj)
  (define the-max (max ref (- (length lst) 1)))
  (define (loop count rest)
    (cond ((null? rest) (if (= count ref)
			    (cons obj '())
			    (if (> count the-max) 
				'()
				(cons '() (loop (+ 1 count) '())))))
	  ((= count ref) (cons obj (loop (+ 1 count) (cdr rest))))
	  (else (cons (car rest) (loop (+ 1 count) (cdr rest))))))
  (loop 0 lst))

(define (safe-list-ref lst ref)
  (if (< ref (length lst))
      (list-ref lst ref)
      '()))

(define (really-safe-list-ref lst ref)
  (if (list? lst)
      (safe-list-ref lst ref)
      '()))

(define (head lst count)
  (cond ((null? lst) lst)
	((<= count 0) '())
	(else (cons (car lst) (head (cdr lst) (- count 1))))))

;;; Returns at most count items from the start of lst; fewer only if lst is too
;;; short, and always at least 0.
(define (range lst start stop)
  (cond ((<= start 0) (head lst (+ 1 stop)))
	((null? lst) '())
	(else (range (cdr lst) (- start 1) (- stop 1)))))

;;; returns from index start to index stop from lst, nil if (< stop start), and
;;; restricted by the range of the list indices
(define (for-all? proc lst)
  (cond ((null? lst) #t)
	((proc (car lst)) (for-all? proc (cdr lst)))
	(else #f)))

(define (there-exists? proc lst)
  (cond ((null? lst) #f)
	((proc (car lst)) (car lst))
	(else (there-exists? proc (cdr lst)))))

(define (integers from to)
  (if (> from to)
      '()
      (cons from (integers (+ 1 from) to))))

;;;; File and system utilities.

;;; +++ All of the local-<foo> stuff could be made marginally more
;;;     efficient by memoizing their results.  After all, it's not
;;;     like it's gonna change across a single run...
(define (local-host)
  ;; Return the canonical name of the local host, or #f if not successful.
  ;; We ASSUME the host's idea of its name correlates with DNS's.
  (let* ((uname-info (uname))		; Should be a vector whose 2 elt.
	 (host-info (and (vector? uname-info) ; Is the local name of localhost.
			 (> (vector-length uname-info) 1)
			 (gethost (vector-ref uname-info 1)))))
    (and (vector? host-info)
	 (> (vector-length host-info) 0)
	 (vector-ref host-info 0))))

(define (local-host-ip)			; This is [apparently] a memoizing version of local-ip-address.   Aiy aiy aiy...
  (let* ((ip (inet:address->string (inet:string->address (local-host)))))
    (set! local-host-ip (lambda () ip))
    ip))				; This works because the string can be a DNS name, but when you get it back, it's not.

(define (local-ip-address-32bit)	; Returns it as a 32-bit unsigned integer.
  (inet:string->address (local-host)))	; The string can be a DNS name, not just a dotted-decimal form, so this works.

(define (local-ip-address)		; Returns it as a string, not a number!
  (inet:address->string (local-ip-address-32bit)))

(define (local-username)
  (vector-ref (getpw (getuid)) 0))
;;; ---

;;; If this is NIL, attempted deletions are no-ops, so I can examine the corpses.
(define tempfile-delete-enable t)	

;;; Note that this returns nil if the file didn't exist in the first place, else t.
(define (tempfile-delete pathname)
  (when tempfile-delete-enable
    (delete-file pathname)))

(define (open-for-appending file)
  (if (access file "rw")
      (let ((port (open-file file open_both)))
	(file-set-position
	 port
	 (vector-ref (stat port) 7))
	port)
      (open-file file open_write)))

(define dirmask (string->number "40000" 8))

(define (directory? file)
  (and (file-exists? file)
       (= dirmask
	  (logand dirmask
		  (vector-ref (stat file) 2)))))

(define (read-chars port count)		; This is not -quite- the same as vars:read-bytes.
  (let ((result (make-string count)))
    (do ((i 0 (+ i 1))
	 (char (read-char port) (read-char port)))
	((or (= i count) (eof-object? char))
	 (substring result 0 i))
      (string-set! result i char))))

(define (read-chars! port destination-string count . maybe-start)
  (let* ((start (optional-arg maybe-start 0))
	 (end (min (+ count start) (string-length destination-string))))
    (do ((i start (+ i 1))
	 (char (read-char port) (read-char port)))
	((or (= i end) (eof-object? char)) (- i start))
      (string-set! destination-string i char))))

(define (read-file file)
  (let* ((input (open-input-file file))
	 (file-length (vector-ref (stat file) 7))
	 (output (make-string file-length)))
    (do ((i 0 (+ i 1)))
	((= i file-length)
	 (close-input-port input)
	 output)
      (string-set! output i (read-char input)))))

;;; All the files in the specified directory, or the specified file.
;;; Note that this is NOT recursive!
;;;
;;; %%% The use of "/", ".", and ".." depends on UNIX semantics and is
;;; %%% inherently nonportable.  A port to something else should be more general.
(define (filenames path)
  (let ((dir (opendir path)))
    (if dir 
	(do ((next (readdir dir) (readdir dir))
	     (lst '() (if (not (or (equal? "." next) (equal? ".." next)))
			  (append (map (lambda (fn) 
					 (string-append path "/" fn))
				       (filenames next)) lst)
			  lst)))
	    ((not next) (closedir dir) lst))
	(list path))))

;;; Returns a list of all non-directories rooted at PATH.
;;; Includes links in the list---perhaps someday we shouldn't.
(define (filenames-recursive path . reject-regexp)
  (when (char=? (string-ref path (1- (string-length path))) #\/) ; Strip any trailing slash.
    (set! path (substring path 0 (1- (string-length path)))))
  (let ((files '())
	(regexp (if (pair? reject-regexp)
		    (if (string? reject-regexp)
			(regcomp (car reject-regexp)) ; %%% No error checking.  Tough.  We should error-check when the user sets this (elsewhere).
			(car reject-regexp)) ; Since there's no compiled-regexp?, assuming that any non-nil, non-string is a compiled regexp.
		    #f)))
    (define (fr path)
      (let ((dir (opendir path)))
	(cond (dir			; This was a directory.
	       (do ((next (readdir dir) (readdir dir)))
		   ((not next) (closedir dir))
		 (unless (or (equal? "." next) (equal? ".." next)
			     (and regexp (regmatch? regexp next)))
		   (fr (string-append path "/" next)))))
	      (t			; Not a directory.
	       (push! path files)))))
    (fr path)
    (nreverse files)))			; Return the files in a reasonable order.

;;;; Handling YID's.

;;; A YID's binary form (YID-b) is the SHA-1 hash of *local-yenta-pub-key*,
;;; which is itself the DER-string representation of the underlying RSA public key.
;;; The binary form of this SHA-1 hash is what gets stashed in *local-yenta-id*.
;;; Usually, we refer to the binary form of the YID, e.g., the actual contents
;;; of *local-yenta-id*, as "the YID", and we refer to the printed representation
;;; of this as the user's "public key fingerprint".
;;;
;;; The printed representation of a YID -used- to be YID-b, converted to hex digits,
;;; with spaces inserted.  Now, it is YID-b, base64-encoded, with spaces inserted.
;;;
;;; This printed representation is -only- used when presenting a YID to the user,
;;; or asking the user for a YID.  When generating certs, or swapping ID's between
;;; Yentas, and various other non-user interactions, we either use YID-b itself,
;;; or we use YID-b, converted to hex digits, with -no- spaces.  In part, we
;;; do this because it's conservative with what Yenta used to do, and in part, we
;;; do this because hex-digit representations don't also need URL-escaping, etc.

(define (public-key->yenta-id key)
  (ssl:sha1-hash key))

;;; The current theory on YID's.  The pseudoinverse of this function
;;; is ui:hex-or-base64->bytes, which takes us back to the SHA-1 hash
;;; that -is- a YID-b.
(define (binary-yid->user-rep yidb)
  (ui:spaced-string (base64-encode yidb)))

(define (local-binary-yid->user-rep)
  (binary-yid->user-rep *local-yenta-id*))

;;; ++ Probably-dead code:

;;; This is the hex form.  Perhaps this function should be renamed.  It is presumably obsolete.
(define (sha1-fingerprint-spaced key)
  (let* ((fingerprint (ssl:sha1-fingerprint key))
	 (no-colons (string-edit ":" "" fingerprint #t))
	 (lowercase (string-downcase! no-colons))) ; string-edit returns a freshly-cons string.
    (ui:spaced-string lowercase)))
	 
;;; This isn't used any more, but we might as well keep it around...
(define (fingerprint-colons-to-spaces s)
  (string-edit ":" " " s #t))
;;; --

;;;; Miscellanous.

(define (version-newer v1 v2)
  (cond ((null? v2) #f)
        ((null? v1) #t)
        ((> (car v1) (car v2)) #t)
        ((= (car v1) (car v2)) (version-newer (cdr v1) (cdr v2)))
        (else #f)))

(define (date-string . when)
  (let ((timestr (ctime (if (null? when)
			    (current-time)
			    (car when)))))
    (substring timestr 0 (- (string-length timestr) 1))))

(define (div a b)
  (inexact->exact (floor (/ a b))))

(define mod remainder) ; I can never remember the Scheme names of this function.
(define div quotient)  ; Ditto.

(define (format-error format-string . format-args)
  (error (apply format nil format-string format-args)))

(define format-debug-level 5)		; Anything lower than this level gets logged.  [This is set to -1 in customer worlds---no keyboard!]
(define (format-debug level format-string . format-args)
  (when (or (eq? level t)		; Log always, both to catch code changes from normal "format", and to give me a way to do this.
	    (< level format-debug-level))
    (apply format t format-string format-args)
    (force-output (current-output-port))))

(define (prefix-symbol-with string symbol)
  (string->symbol (string-append string (symbol->string symbol))))

(define (coerce-to-string name)
  (if (string? name) name (symbol->string name)))

(define (create-name . args)
    (string->symbol (apply string-append (map coerce-to-string args))))

(define (compose f1 f2)
    (lambda (. args) (f1 (apply f2 args))))

(define (compose-protected proc1 proc2)
    (lambda (. args-to-2)
      (let ((arg-to-1 (apply proc2 args-to-2)))
	(if arg-to-1
	    (proc1 arg-to-1)
	    #f))))

;;; Everybody seems to need this...
;;; [Checked SLIB & GLIB as of 29 Jul 98 to ensure that everyone there
;;;  uses a package prefix, so we can't be stepping on anyone.  --- Foner]
(define (flatten lst)
  (cond ((null? lst) '())
	((list? (car lst)) (append (car lst) (flatten (cdr lst))))
	(else (cons (car lst) (flatten (cdr lst))))))

;;; End of file.
