;;; hversion.el --- Hyperbole version, system and load path information.

;; Copyright (C) 1994, 1995, 2004, 2005, 2006, 2007, 2008 Free
;; Software Foundation, Inc.  Developed with support from Motorola
;; Inc.

;; Author: Bob Weiner, Brown U.
;; Maintainer: Mats Lidell <matsl@contactor.se>
;; Keywords: hypermedia

;; This file is part of GNU Hyperbole.

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

;; GNU Hyperbole 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
;; General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Commentary:

;;; Code:

;;;
;;; Public variables
;;;

(defconst hyperb:version "5.0.5" "Hyperbole revision number.")

;;; Support button highlighting and flashing under XEmacs.
;;;
(defvar hyperb:xemacs-p
  (let ((case-fold-search t))
    (if (string-match "XEmacs" emacs-version)
	emacs-version))
  "Version string under XEmacs (not Lucid Emacs) or nil")

;;; Support mouse handling under GNU Emacs V19 and beyond.
;;;
(defvar hyperb:emacs19-p
  (and (not hyperb:xemacs-p)
       (string-match "^\\(19\\|2[0-9]\\)\\." emacs-version)
       emacs-version)
  "Version string under GNU Emacs 19 or nil")

;;; Support button highlighting and flashing under obsolete Epoch.
;;;
(defvar hyperb:epoch-p
  (if (and (boundp 'epoch::version)
	   (stringp epoch::version))
      (if (string< epoch::version "Epoch 4") "V3" "V4"))
  "Simplified version string under Epoch, e.g. \"V4\", or nil")

;; Koutlines work only with specific versions of Emacs 19 and XEmacs.
(defconst hyperb:kotl-p
  (if hyperb:xemacs-p
      ;; Only works for XEmacs 19.9 and above.
      (emacs-version>= 19 9)
    hyperb:emacs19-p)
  "Non-nil iff this Emacs version supports the Hyperbole outliner.")

;; Used by OO-Browser (Deprecated!?)
(defconst hyperb:microcruft-os-p
  (memq system-type '(windows-nt ms-dos))
  "T iff Hyperbole is running under Windows or DOS.")

(defun sm-window-sys-term ()
  "Returns the first part of the term-type if running under a window system, else nil.
Where a part in the term-type is delimited by a '-' or  an '_'."
  (let ((term (cond ((memq window-system '(x gtk ns dps pm mswindows))
		     ;; X11, NEXTSTEP (DPS), or OS/2 Presentation Manager (PM)
		     (cond (hyperb:emacs19-p "emacs19")
			   (hyperb:xemacs-p  "xemacs")
			   (hyperb:epoch-p   "epoch")
			   (t                "xterm")))
		    ((or (featurep 'eterm-fns)
			 (equal (getenv "TERM") "NeXT")
			 (equal (getenv "TERM") "eterm"))
		     ;; NEXTSTEP add-on support to Emacs
		     "next")
		    ((or window-system 
			 (featurep 'sun-mouse) (featurep 'apollo))
		     (getenv "TERM")))))
    (and term
	 (substring term 0 (string-match "[-_]" term)))))

(defconst hyperb:window-system (sm-window-sys-term)
  "String name for window system or term type under which Emacs was run.
If nil, no window system or mouse support is available.")

;;;
;;; Public functions to dynamically compute Hyperbole directory.
;;;

(defvar hyperb:automount-prefixes
  (if (and (boundp 'automount-dir-prefix) (stringp automount-dir-prefix))
      automount-dir-prefix
    "^/tmp_mnt/"
    "*Regexp to match any automounter prefix in a pathname."))

(defun hyperb:stack-frame (function-list &optional debug-flag)
  "Return the nearest Emacs Lisp stack frame which called any function symbol from FUNCTION-LIST or nil if no match.
If FUNCTION-LIST contains 'load, 'autoload or 'require, detect
autoloads not visible within the Lisp level stack frames.

With optional DEBUG-FLAG non-nil, if no matching frame is found, return list
of stack frames (from innermost to outermost)."
  (let ((count 0)
	(frame-list)
	(load-flag (or (memq 'load function-list)
		       (memq 'autoload function-list)
		       (memq 'require function-list)))
	fsymbol
	fbody
	frame)
    (or (catch 'hyperb:stack-frame
	  (while (setq frame (backtrace-frame count))
	    (if debug-flag (setq frame-list (cons frame frame-list)))
	    (setq count (1+ count)
		  fsymbol (nth 1 frame))
	    (and (eq fsymbol 'command-execute)
		 (not (memq 'command-execute function-list))
		 ;; Use command being executed instead because it might not
		 ;; show up in the stack anywhere else, e.g. if it is an
		 ;; autoload under Emacs 19.
		 (setq fsymbol (nth 2 frame)))
	    (cond ((and load-flag (symbolp fsymbol)
			(fboundp fsymbol)
			(listp (setq fbody (symbol-function fsymbol)))
			(eq (car fbody) 'autoload))
		   (setq frame (list (car frame) 'load
				     (car (cdr fbody))
				     nil noninteractive nil))
		   (throw 'hyperb:stack-frame frame))
		  ((memq fsymbol function-list)
		   (throw 'hyperb:stack-frame frame))))
	  nil)
	(if debug-flag (nreverse frame-list)))))

(defun hyperb:path-being-loaded ()
  "Return the full pathname used by the innermost `load' or 'require' call.
Removes any matches for `hyperb:automount-prefixes' before returning
the pathname."
  (let* ((frame (hyperb:stack-frame '(load require)))
	 (function (nth 1 frame))
	 file nosuffix)
    (cond ((eq function 'load)
	   (setq file (nth 2 frame)
		 nosuffix (nth 5 frame)))
	  ((eq function 'require)
	   (setq file (or (nth 3 frame) (symbol-name (nth 2 frame))))))
    (if (stringp file)
	(setq nosuffix (or nosuffix
			   (string-match
			    "\\.\\(elc?\\|elc?\\.gz\\|elc?\\.Z\\)$"
			    file))
	      file (substitute-in-file-name file)
	      file (locate-file file load-path
				(if (null nosuffix) '(".elc" ".el" ".el.gz" ".el.Z"))
				;; accept any existing file
				nil)
	      file (if (and (stringp file)
			    (string-match hyperb:automount-prefixes file))
		       (substring file (1- (match-end 0)))
		     file)))))

(if (fboundp 'locate-file)
    nil
  (defun locate-file (file dir-list &optional suffixes unused)
    "Search for FILE in DIR-LIST.
If optional SUFFIXES is provided, it should be a list of suffixes to append to file name when searching."
    (if (and (file-name-absolute-p file) (file-readable-p file))
	file;; file exists without suffix addition, so return it
      (if (file-name-absolute-p file) (setq dir-list '(nil)))
      (if (equal file "") (error "(locate-file): Empty file argument"))
      (let (suffxs pathname)
	;; Search dir-list for a matching, readable file.
	(catch 'found
	  (while dir-list
	    (setq suffxs (or suffixes '(nil)))
	    (while suffxs
	      (setq pathname (expand-file-name
			      (concat file (car suffxs))
			      (car dir-list)))
	      (if (file-readable-p pathname)
		  (throw 'found pathname))
	      (setq suffxs (cdr suffxs)))
	    (setq dir-list (cdr dir-list))))))))

;;;
;;; Public functions used by pulldown and popup menus
;;;

(if (not (fboundp 'id-browse-file))
    (fset 'id-browse-file 'find-file-read-only))

(if (not (fboundp 'id-info))
    (defun id-info (node)
      (if (br-in-browser) (br-to-view-window))
      (Info-goto-node node)))

(if (not (fboundp 'id-tool-quit)) (fset 'id-tool-quit 'eval))

(if (not (fboundp 'id-tool-invoke))
    (defun id-tool-invoke (sexp)
      (if (commandp sexp)
	  (call-interactively sexp)
	(funcall sexp))))

(provide 'hversion)

;;; hversion.el ends here