;;!emacs
;; $Id:
;;
;; FILE:         hypb.el
;; SUMMARY:      Miscellaneous Hyperbole support features.
;; USAGE:        GNU Emacs Lisp Library
;;
;; AUTHOR:       Bob Weiner
;; ORG:          Brown U.
;;
;; ORIG-DATE:     6-Oct-91 at 03:42:38
;; LAST-MOD:     17-May-93 at 17:45:26 by Bob Weiner
;;
;; This file is part of Hyperbole.
;;
;; Copyright (C) 1991-1993, Brown University, Providence, RI
;; Developed with support from Motorola Inc.
;; Available for use and distribution under the same terms as GNU Emacs.
;;
;; DESCRIPTION:  
;; DESCRIP-END.


;;; ************************************************************************
;;; Public variables
;;; ************************************************************************

(defconst hypb:help-buf-suffix " Hypb Help*"
  "Suffix attached to all native Hyperbole help buffer names.")

;;; ************************************************************************
;;; Public functions
;;; ************************************************************************

(defun hypb:call-process-p (program infile &optional predicate &rest args)
  "Calls an external PROGRAM with INFILE for input.
If PREDICATE is given, it is evaluated in a buffer with the PROGRAM's
output and the result returned.  If PREDICATE is nil, returns t iff
program has no output or just a 0-valued output.
Rest of ARGS are passed as arguments to PROGRAM."
  (let ((buf (get-buffer-create "*test-output*"))
	(found))
    (save-excursion
      (set-buffer buf) (setq buffer-read-only nil) (erase-buffer)
      (apply 'call-process program infile buf nil args)
      (setq found 
	    (if predicate
		(eval predicate)
	      (or (= (point-max) 1) ;; No output, consider cmd a success.
		  (and (< (point-max) 4)
		       (string= (buffer-substring 1 2) "0")))))
      (set-buffer-modified-p nil)
      (kill-buffer buf))
    found))


(defun hypb:chmod (op octal-permissions file)
  "Uses OP and OCTAL-PERMISSIONS integer to set FILE permissions.
OP may be +, -, xor, or default =."
  (let ((func (cond ((eq op '+)   'logior)
		    ((eq op '-)   '(lambda (p1 p2) (logand (lognot p1) p2)))
		    ((eq op 'xor) 'logxor)
		    (t            '(lambda (p1 p2) p1)))))
    (set-file-modes file (funcall func (hypb:oct-to-int octal-permissions)
				  (file-modes file)))))

(defun hypb:cmd-key-string (cmd-sym &optional keymap)
  "Returns a single pretty printed key sequence string bound to CMD-SYM.
Global keymap is used unless optional KEYMAP is given."
  (if (and cmd-sym (symbolp cmd-sym) (fboundp cmd-sym))
  (let* ((get-keys '(lambda (cmd-sym keymap)
		      (key-description (where-is-internal
					cmd-sym keymap 'first))))
	 (keys (funcall get-keys cmd-sym keymap))
	 (extend))
    (concat "{"
	    (if (string= keys "")
		(concat (funcall get-keys 'execute-extended-command nil)
			" " (symbol-name cmd-sym) " RTN")
	      keys)
	    "}"))
  (error "(hypb:cmd-key-string): Invalid cmd-sym arg: %s." cmd-sym)))

(defun hypb:debug ()
  "Loads Hyperbole hbut.el source file and sets debugging traceback flag."
  (interactive)
  (or (featurep 'hinit) (load "hsite"))
  (or (and (featurep 'hbut)
	   (not (eq 'byte-code
		    (car (car (nthcdr 3 (symbol-function 'ebut:create)))))))
      (load "hbut.el"))
  (setq debug-on-error t))

(defun hypb:domain-name ()
  "Returns current Internet domain name with '@' prepended or nil if none."
  (let* ((src "/etc/resolv.conf")
	(dname-cmd (or (file-exists-p "/usr/bin/domainname")
		       (file-exists-p "/bin/domainname")))
	(dname (if dname-cmd
		   (hypb:call-process-p "domainname" nil 
					'(substring (buffer-string) 0 -1)))))
    (if (or (and dname (string-match "\\." dname))
	    (and (file-exists-p src) (file-readable-p src)
		 (setq dname
		       (hypb:call-process-p
			"grep" nil
			'(progn (goto-char (point-min))
				(if (looking-at "domain[ \t]+\\([^ \t\n]+\\)")
				    (buffer-substring (match-beginning 1)
						      (match-end 1))))
			"^domain[ \t]" "/etc/resolv.conf"))))
	   (concat "@" dname))))

(defun hypb:error (&rest args)
  "Signals an error typically to be caught by 'hui:menu'."
  (let ((msg (apply 'format args)))
    (put 'error 'error-message msg)
    (error msg)))

;;; Next function adapted from epoch-util.el.
;;; Copyright (C) 1990  Alan M. Carroll
(defun hypb:functionp (thing)
"Returns t if THING is a function, nil otherwise."
  (cond
    ((symbolp thing) (fboundp thing))
    ((subrp thing))
    ;; Emacs V19 byte-compiled function
    ((or (and (fboundp 'byte-code-function-p) (byte-code-function-p thing))
	 (and (fboundp 'compiled-function-p) (compiled-function-p thing))))
    ((consp thing)
     (and (eq (car thing) 'lambda) (listp (car (cdr thing)))))
    (t nil)))

(defun hypb:function-copy (func-symbol)
  "Copies FUNC-SYMBOL's body for overloading.  Returns copy of body."
  (if (fboundp func-symbol)
      (let ((func (symbol-function func-symbol)))
	(cond ((listp func) (copy-sequence func))
	      ((subrp func) (error "(hypb:function-copy): `%s' is a primitive; can't copy body."
				   func-symbol))
	      ;; Assume V19 byte-compiled function.
	      ((fboundp 'make-byte-code)
	       (apply 'make-byte-code
		      (nreverse
			(hypb:map-vector (function
					   (lambda (arg)
					     (if (sequencep arg) (copy-sequence arg) arg)))
					 func))))
	      (t (error "(hypb:function-copy): Can't copy function body: %s" func))
	      ))
    (error "(hypb:function-copy): `%s' symbol is not bound to a function."
	   func-symbol)))

(defun hypb:function-symbol-replace (func-sym sym-to-replace replace-with-sym)
  "Replaces in body of FUNC-SYM SYM-TO-REPLACE with REPLACE-WITH-SYM.
All occurrences within lists are replaced.  Returns body of modified FUNC-SYM."
  (let ((body (symbol-function func-sym))
	(arg-vector) (arg))
    (if (listp body)
	;; assume V18 byte compiler
	(setq arg-vector
	      (car (delq nil (mapcar
			       (function
				 (lambda (elt)
				   (and (listp elt)
					(vectorp (setq arg-vector (nth 2 elt)))
					arg-vector)))
			       body))))
      ;; assume V19 byte compiler   (eq (compiled-function-p body) t)
      (setq arg (aref body 2)
	    arg-vector (if (vectorp arg) arg))
      )
    (if arg-vector
	;; Code is byte-compiled.
	(let ((i (1- (length arg-vector))))
	  (setq arg nil)
	  (while (and (not arg) (>= i 0))
	    (if (eq (setq arg (aref arg-vector i)) sym-to-replace)
		(aset arg-vector i replace-with-sym)
	      (setq arg nil i (1- i)))))
      ;; Code is not byte-compiled.
      ;; Only replaces occurrence of symbol as an element of a list.
      (hypb:map-sublists
	(function
	  (lambda (atom list) (if (eq atom sym-to-replace)
				  (let ((again t))
				    (while (and again list)
				      (if (eq (car list) atom)
					  (progn (setcar list replace-with-sym)
						 (setq again nil))
					(setq list (cdr list))))))))
	body)
      )
    body))

(defun hypb:help-buf-name (&optional prefix)
  "Returns a Hyperbole help buffer name for current buffer.
With optional PREFIX string, uses it rather than buffer name."
  (let ((bn (or prefix (buffer-name))))
    (if (string-match " Hypb " bn)
	(buffer-name (generate-new-buffer bn))
      (concat "*" bn hypb:help-buf-suffix))))

(defun hypb:map-sublists (func list)
  "Applies FUNC to every atom found at any level of LIST.
FUNC must take two arguments, an atom and a list in which the atom is found.
Returns values from applications of FUNC as a list with the same
structure as LIST.  FUNC is therefore normally used just for its side-effects."
  (mapcar (function
	    (lambda (elt) (if (atom elt)
			      (funcall func elt list)
			    (hypb:map-sublists func elt)))
	    list)))

(defun hypb:map-vector (func object)
  "Returns list of results of application of FUNC to each element of OBJECT.
OBJECT should be a vector or byte-code object."
  (if (not (or (vectorp object)
	       (and (fboundp 'byte-code-function-p) (byte-code-function-p object))
	       (and (fboundp 'compiled-function-p) (compiled-function-p object))))
      (error "(hypb:map-vector): Second argument must be a vector or byte-code object."))
  (let ((end (length object))
	(i 0)
	(result))
    (while (< i end)
      (setq result (cons (funcall func (aref object i)) result)
	    i (1+ i)))
    (nreverse result)))

(defun hypb:replace-match-string (regexp str newtext &optional literal)
  "Replaces all matches for REGEXP in STR with NEWTEXT str.
Optional LITERAL non-nil means do a literal replacement.
Otherwise treat \\ in NEWTEXT string as special:
  \& means substitute original matched text,
  \N means substitute match for \(...\) number N,
  \\\\ means insert one \\.
NEWTEXT may instead be a function of one argument, the string to replace in,
that returns a replacement string."
  (if (not (stringp str))
      (error "(hypb:replace-match-string): 2nd arg must be a string: %s" str))
  (if (or (stringp newtext) (hypb:functionp newtext))
      nil
    (error "(hypb:replace-match-string): 3nd arg must be a string or func: %s"
	   newtext))
  (let ((rtn-str "")
	(start 0)
	(special)
	match prev-start)
    (while (setq match (string-match regexp str start))
      (setq prev-start start
	    start (match-end 0)
	    rtn-str
	    (concat
	      rtn-str
	      (substring str prev-start match)
	      (cond ((hypb:functionp newtext) (funcall newtext str))
		    (literal newtext)
		    (t (mapconcat
			 (function
			   (lambda (c)
			     (if special
				 (progn
				   (setq special nil)
				   (cond ((eq c ?\\) "\\")
					 ((eq c ?&)
					  (substring str
						     (match-beginning 0)
						     (match-end 0)))
					 ((and (>= c ?0) (<= c ?9))
					  (if (> c (+ ?0 (length
							   (match-data))))
					      ;; Invalid match num
					      (error "(hypb:replace-match-string) Invalid match num: %c" c)
					    (setq c (- c ?0))
					    (substring str
						       (match-beginning c)
						       (match-end c))))
					 (t (char-to-string c))))
			       (if (eq c ?\\) (progn (setq special t) nil)
				 (char-to-string c)))))
			 newtext ""))))))
    (concat rtn-str (substring str start))))

(defun hypb:screen-line (&optional pos-or-marker)
  "Returns screen line number of optional POS-OR-MARKER or current point.
Signals error if POS-OR-MARKER position is not visible on screen.
Line numbers start from 0 at screen top."
  (or pos-or-marker (setq pos-or-marker (point)))
  (let* ((wind (if (not (markerp pos-or-marker))
		   (selected-window)
		 (let ((w (get-buffer-window
			    (marker-buffer pos-or-marker))))
		   (if (pos-visible-in-window-p pos-or-marker w)
		       w
		     ;; Might be visible in another window.
		     (let ((mbuf (marker-buffer pos-or-marker)))
		       (car (delq nil (mapcar (function
						(lambda (w)
						  (and (eq mbuf
							   (window-buffer w))
						       (pos-visible-in-window-p
							 pos-or-marker w)
						       w)))
					      (hypb:window-list t)))))
		     )))))
    (if (or (null wind)
	    (not (pos-visible-in-window-p pos-or-marker wind)))
	(error
	  "(hypb:screen-line): Buffer point %s is not on screen."
	  pos-or-marker)
      (save-window-excursion
	(save-excursion
	  (select-window wind)
	  (goto-char pos-or-marker)
	  (+ (nth 1 (window-edges))
	     (1- (count-lines (window-start wind)
			      (if (and (bolp) (not (eobp)))
				  (1+ (point))
				(point)
				)))))))))

(defun hypb:supercite-p ()
  "Returns non-nil iff the Emacs add-on supercite package is in use."
  (and (boundp 'mail-yank-hooks)
       (or (eq mail-yank-hooks 'sc-cite-original)
	   (and (listp mail-yank-hooks)
		(memq 'sc-cite-original mail-yank-hooks)))))

;;; Next function is copied from a copylefted function:
;;; Copyright (C) 1987, 1988 Kyle E. Jones
(if hyperb:lemacs-p
    (defun hypb:window-list (&optional mini)
      "Returns a list of Lisp window objects for all Emacs windows.
Optional first arg MINI t means include the minibuffer window
in the list, even if it is not active.  If MINI is neither t
nor nil it means to not count the minibuffer window even if it is active."
      (let* ((first-window (next-window
			     (previous-window (selected-window) nil t)
			     mini t))
	     (windows (cons first-window nil))
	     (current-cons windows)
	     (w (next-window first-window mini t)))
    (while (not (eq w first-window))
      (setq current-cons (setcdr current-cons (cons w nil)))
      (setq w (next-window w mini t)))
    windows))
  (defun hypb:window-list (&optional mini)
    "Returns a list of Lisp window objects for all Emacs windows.
Optional first arg MINI t means include the minibuffer window
in the list, even if it is not active.  If MINI is neither t
nor nil it means to not count the minibuffer window even if it is active."
    (let* ((first-window (next-window
			   (previous-window (selected-window)) mini))
	   (windows (cons first-window nil))
	   (current-cons windows)
	   (w (next-window first-window mini)))
      (while (not (eq w first-window))
	(setq current-cons (setcdr current-cons (cons w nil)))
	(setq w (next-window w mini)))
      windows))
  )

;;; ************************************************************************
;;; Private functions
;;; ************************************************************************

(defun hypb:oct-to-int (oct-num)
  "Returns octal integer OCTAL-NUM converted to a decimal integer."
  (let ((oct-str (int-to-string oct-num))
	(dec-num 0))
    (and (string-match "[^0-7]" oct-str)
	 (error (format "(hypb:oct-to-int): Bad octal number: %s" oct-str)))
    (mapconcat '(lambda (o)
		  (setq dec-num (+ (* dec-num 8)
				   (if (and (>= o ?0) (<= o ?7))
				       (- o ?0)))))
	       oct-str "")
    dec-num))

;;; ************************************************************************
;;; Private variables
;;; ************************************************************************

(provide 'hypb)