cgit.sxemacs.org Git - packages/blob - xemacs-packages/hyperbole/hversion.el

   1 ;;; hversion.el --- Hyperbole version, system and load path information.
   2
   3 ;; Copyright (C) 1994, 1995, 2004, 2005, 2006, 2007, 2008 Free
   4 ;; Software Foundation, Inc.  Developed with support from Motorola
   5 ;; Inc.
   6
   7 ;; Author: Bob Weiner, Brown U.
   8 ;; Maintainer: Mats Lidell <matsl@contactor.se>
   9 ;; Keywords: hypermedia
  10
  11 ;; This file is part of GNU Hyperbole.
  12
  13 ;; GNU Hyperbole is free software; you can redistribute it and/or
  14 ;; modify it under the terms of the GNU General Public License as
  15 ;; published by the Free Software Foundation; either version 3, or (at
  16 ;; your option) any later version.
  17
  18 ;; GNU Hyperbole is distributed in the hope that it will be useful,
  19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  21 ;; General Public License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  25 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  26 ;; Boston, MA 02110-1301, USA.
  27
  28 ;;; Commentary:
  29
  30 ;;; Code:
  31
  32 ;;;
  33 ;;; Public variables
  34 ;;;
  35
  36 (defconst hyperb:version "5.0.5" "Hyperbole revision number.")
  37
  38 ;;; Support button highlighting and flashing under XEmacs.
  39 ;;;
  40 (defvar hyperb:xemacs-p
  41   (let ((case-fold-search t))
  42     (if (string-match "XEmacs" emacs-version)
  43         emacs-version))
  44   "Version string under XEmacs (not Lucid Emacs) or nil")
  45
  46 ;;; Support mouse handling under GNU Emacs V19 and beyond.
  47 ;;;
  48 (defvar hyperb:emacs19-p
  49   (and (not hyperb:xemacs-p)
  50        (string-match "^\\(19\\|2[0-9]\\)\\." emacs-version)
  51        emacs-version)
  52   "Version string under GNU Emacs 19 or nil")
  53
  54 ;;; Support button highlighting and flashing under obsolete Epoch.
  55 ;;;
  56 (defvar hyperb:epoch-p
  57   (if (and (boundp 'epoch::version)
  58            (stringp epoch::version))
  59       (if (string< epoch::version "Epoch 4") "V3" "V4"))
  60   "Simplified version string under Epoch, e.g. \"V4\", or nil")
  61
  62 ;; Koutlines work only with specific versions of Emacs 19 and XEmacs.
  63 (defconst hyperb:kotl-p
  64   (if hyperb:xemacs-p
  65       ;; Only works for XEmacs 19.9 and above.
  66       (emacs-version>= 19 9)
  67     hyperb:emacs19-p)
  68   "Non-nil iff this Emacs version supports the Hyperbole outliner.")
  69
  70 ;; Used by OO-Browser (Deprecated!?)
  71 (defconst hyperb:microcruft-os-p
  72   (memq system-type '(windows-nt ms-dos))
  73   "T iff Hyperbole is running under Windows or DOS.")
  74
  75 (defun sm-window-sys-term ()
  76   "Returns the first part of the term-type if running under a window system, else nil.
  77 Where a part in the term-type is delimited by a '-' or  an '_'."
  78   (let ((term (cond ((memq window-system '(x gtk ns dps pm mswindows))
  79                      ;; X11, NEXTSTEP (DPS), or OS/2 Presentation Manager (PM)
  80                      (cond (hyperb:emacs19-p "emacs19")
  81                            (hyperb:xemacs-p  "xemacs")
  82                            (hyperb:epoch-p   "epoch")
  83                            (t                "xterm")))
  84                     ((or (featurep 'eterm-fns)
  85                          (equal (getenv "TERM") "NeXT")
  86                          (equal (getenv "TERM") "eterm"))
  87                      ;; NEXTSTEP add-on support to Emacs
  88                      "next")
  89                     ((or window-system
  90                          (featurep 'sun-mouse) (featurep 'apollo))
  91                      (getenv "TERM")))))
  92     (and term
  93          (substring term 0 (string-match "[-_]" term)))))
  94
  95 (defconst hyperb:window-system (sm-window-sys-term)
  96   "String name for window system or term type under which Emacs was run.
  97 If nil, no window system or mouse support is available.")
  98
  99 ;;;
 100 ;;; Public functions to dynamically compute Hyperbole directory.
 101 ;;;
 102
 103 (defvar hyperb:automount-prefixes
 104   (if (and (boundp 'automount-dir-prefix) (stringp automount-dir-prefix))
 105       automount-dir-prefix
 106     "^/tmp_mnt/"
 107     "*Regexp to match any automounter prefix in a pathname."))
 108
 109 (defun hyperb:stack-frame (function-list &optional debug-flag)
 110   "Return the nearest Emacs Lisp stack frame which called any function symbol from FUNCTION-LIST or nil if no match.
 111 If FUNCTION-LIST contains 'load, 'autoload or 'require, detect
 112 autoloads not visible within the Lisp level stack frames.
 113
 114 With optional DEBUG-FLAG non-nil, if no matching frame is found, return list
 115 of stack frames (from innermost to outermost)."
 116   (let ((count 0)
 117         (frame-list)
 118         (load-flag (or (memq 'load function-list)
 119                        (memq 'autoload function-list)
 120                        (memq 'require function-list)))
 121         fsymbol
 122         fbody
 123         frame)
 124     (or (catch 'hyperb:stack-frame
 125           (while (setq frame (backtrace-frame count))
 126             (if debug-flag (setq frame-list (cons frame frame-list)))
 127             (setq count (1+ count)
 128                   fsymbol (nth 1 frame))
 129             (and (eq fsymbol 'command-execute)
 130                  (not (memq 'command-execute function-list))
 131                  ;; Use command being executed instead because it might not
 132                  ;; show up in the stack anywhere else, e.g. if it is an
 133                  ;; autoload under Emacs 19.
 134                  (setq fsymbol (nth 2 frame)))
 135             (cond ((and load-flag (symbolp fsymbol)
 136                         (fboundp fsymbol)
 137                         (listp (setq fbody (symbol-function fsymbol)))
 138                         (eq (car fbody) 'autoload))
 139                    (setq frame (list (car frame) 'load
 140                                      (car (cdr fbody))
 141                                      nil noninteractive nil))
 142                    (throw 'hyperb:stack-frame frame))
 143                   ((memq fsymbol function-list)
 144                    (throw 'hyperb:stack-frame frame))))
 145           nil)
 146         (if debug-flag (nreverse frame-list)))))
 147
 148 (defun hyperb:path-being-loaded ()
 149   "Return the full pathname used by the innermost `load' or 'require' call.
 150 Removes any matches for `hyperb:automount-prefixes' before returning
 151 the pathname."
 152   (let* ((frame (hyperb:stack-frame '(load require)))
 153          (function (nth 1 frame))
 154          file nosuffix)
 155     (cond ((eq function 'load)
 156            (setq file (nth 2 frame)
 157                  nosuffix (nth 5 frame)))
 158           ((eq function 'require)
 159            (setq file (or (nth 3 frame) (symbol-name (nth 2 frame))))))
 160     (if (stringp file)
 161         (setq nosuffix (or nosuffix
 162                            (string-match
 163                             "\\.\\(elc?\\|elc?\\.gz\\|elc?\\.Z\\)$"
 164                             file))
 165               file (substitute-in-file-name file)
 166               file (locate-file file load-path
 167                                 (if (null nosuffix) '(".elc" ".el" ".el.gz" ".el.Z"))
 168                                 ;; accept any existing file
 169                                 nil)
 170               file (if (and (stringp file)
 171                             (string-match hyperb:automount-prefixes file))
 172                        (substring file (1- (match-end 0)))
 173                      file)))))
 174
 175 (if (fboundp 'locate-file)
 176     nil
 177   (defun locate-file (file dir-list &optional suffixes unused)
 178     "Search for FILE in DIR-LIST.
 179 If optional SUFFIXES is provided, it should be a list of suffixes to append to file name when searching."
 180     (if (and (file-name-absolute-p file) (file-readable-p file))
 181         file;; file exists without suffix addition, so return it
 182       (if (file-name-absolute-p file) (setq dir-list '(nil)))
 183       (if (equal file "") (error "(locate-file): Empty file argument"))
 184       (let (suffxs pathname)
 185         ;; Search dir-list for a matching, readable file.
 186         (catch 'found
 187           (while dir-list
 188             (setq suffxs (or suffixes '(nil)))
 189             (while suffxs
 190               (setq pathname (expand-file-name
 191                               (concat file (car suffxs))
 192                               (car dir-list)))
 193               (if (file-readable-p pathname)
 194                   (throw 'found pathname))
 195               (setq suffxs (cdr suffxs)))
 196             (setq dir-list (cdr dir-list))))))))
 197
 198 ;;;
 199 ;;; Public functions used by pulldown and popup menus
 200 ;;;
 201
 202 (if (not (fboundp 'id-browse-file))
 203     (fset 'id-browse-file 'find-file-read-only))
 204
 205 (if (not (fboundp 'id-info))
 206     (defun id-info (node)
 207       (if (br-in-browser) (br-to-view-window))
 208       (Info-goto-node node)))
 209
 210 (if (not (fboundp 'id-tool-quit)) (fset 'id-tool-quit 'eval))
 211
 212 (if (not (fboundp 'id-tool-invoke))
 213     (defun id-tool-invoke (sexp)
 214       (if (commandp sexp)
 215           (call-interactively sexp)
 216         (funcall sexp))))
 217
 218 (provide 'hversion)
 219
 220 ;;; hversion.el ends here