emacs_el/tiny-tools/tiny/tinylibenv.el

   1 ;;; tinylibenv.el --- Library for environment check functions
   2
   3 ;; This file is not part of Emacs
   4
   5 ;;{{{ Id
   6
   7 ;; Copyright (C)    2003-2007 Jari Aalto
   8 ;; Keywords:        extensions
   9 ;; Author:          Jari Aalto
  10 ;; Maintainer:      Jari Aalto
  11 ;;
  12 ;; To get information on this program, call M-x tinyliba-version.
  13 ;; Look at the code with folding.el
  14
  15 ;; COPYRIGHT NOTICE
  16 ;;
  17 ;; This program is free software; you can redistribute it and/or modify it
  18 ;; under the terms of the GNU General Public License as published by the Free
  19 ;; Software Foundation; either version 2 of the License, or (at your option)
  20 ;; any later version.
  21 ;;
  22 ;; This program is distributed in the hope that it will be useful, but
  23 ;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
  24 ;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  25 ;; for more details.
  26 ;;
  27 ;; You should have received a copy of the GNU General Public License
  28 ;; along with program; see the file COPYING. If not, write to the
  29 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  30 ;; Boston, MA 02110-1301, USA.
  31 ;;
  32 ;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
  33
  34 ;;}}}
  35 ;;{{{ Install
  36
  37 ;; ........................................................ &t-install ...
  38 ;; DO NOT LOAD THIS FILE, but load the central library "m". It loads this
  39 ;; file and backward compatible library "b"
  40 ;;
  41 ;;      (require 'tinylibm)
  42
  43 ;;}}}
  44
  45 ;;; Change Log:
  46
  47 ;;; Code:
  48
  49 ;;{{{ code: Init
  50
  51 (eval-when-compile
  52   (require 'backquote)
  53   (autoload 'executable-find "executable")
  54   (autoload 'ti::directory-up "tinylib")
  55
  56   (if (not (or (boundp 'xemacs-logo)
  57                (featurep 'xemacs)))
  58       ;; Emacs function, but it's buried and not published.
  59       (autoload 'w32-system-shell-p "w32-fns")
  60     (unless (fboundp 'w32-system-shell-p)
  61       ;;  Emacs function => compatibility for XEmacs
  62       (defun w32-system-shell-p (shell-name)
  63         "Tinylib: Emacs an XEmacs compatibility."
  64         ;;  This is simplistic alternative if the original function
  65         ;;  is not available.
  66         (string-match "cmdproxy"
  67                       (or shell-name "")))))
  68
  69   ;; defvar silences Byte Compiler
  70   (defvar byte-compile-dynamic nil "") ;; Introduced in 19.29
  71   (make-local-variable 'byte-compile-dynamic)
  72   (setq byte-compile-dynamic t))
  73
  74 (provide 'tinylibenv)
  75
  76 ;;}}}
  77 ;;{{{ code: Macros, utility functions
  78
  79 ;; These are from SEMI::APEL::poe.el
  80
  81 ;;; ----------------------------------------------------------------------
  82 ;;;
  83 (put 'defun-maybe 'lisp-indent-function 'defun)
  84 (defmacro defun-maybe (name &rest everything-else)
  85   (when (or (not (fboundp name))
  86             (and (fboundp name)
  87                  (string-match
  88                   "autoload"
  89                   (prin1-to-string
  90                    (symbol-function name)))))
  91     (` (progn
  92          (defun (, name) (,@ everything-else))
  93          (put (quote (, name)) 'defun-maybe t)))))
  94
  95 ;;; ----------------------------------------------------------------------
  96 ;;;
  97 (put 'defsubst-maybe 'lisp-indent-function 'defun)
  98 (defmacro defsubst-maybe (name &rest everything-else)
  99   (when (or (not (fboundp name))
 100             (and (fboundp name)
 101                  (string-match
 102                   "autoload"
 103                   (prin1-to-string
 104                    (symbol-function name)))))
 105     (` (progn
 106          (defsubst (, name) (,@ everything-else))
 107          (put (quote (, name)) 'defsubst-maybe t)))))
 108
 109 ;;; ----------------------------------------------------------------------
 110 ;;;
 111 (put 'defmacro-maybe 'lisp-indent-function 'defun)
 112 (defmacro defmacro-maybe (name &rest everything-else)
 113   (when (or (not (fboundp name))
 114             (and (fboundp name)
 115                  (string-match
 116                   "autoload"
 117                   (prin1-to-string
 118                    (symbol-function name)))))
 119     (` (progn
 120          (defmacro (, name) (,@ everything-else))
 121          (put (quote (, name)) 'defmacro-maybe t)))))
 122
 123 ;;; ----------------------------------------------------------------------
 124 ;;;
 125 (defmacro defalias-maybe (sym newdef)
 126   "Make defalias SYM if it does not exist and NEWDEF exists."
 127   (`
 128    (when (and (not (fboundp (, sym)))
 129               (fboundp (, newdef)))
 130      (defalias (, sym) (, newdef)))))
 131
 132 ;;; ----------------------------------------------------------------------
 133 ;;;
 134 (defmacro defconst-maybe (name &rest everything-else)
 135   (or (and (boundp name)
 136            (not (get name 'defconst-maybe)))
 137       (` (or (boundp (quote (, name)))
 138              (progn
 139                (defconst (, name) (,@ everything-else))
 140                (put (quote (, name)) 'defconst-maybe t))))))
 141
 142 ;;}}}
 143 ;;{{{ Environment checks
 144
 145 ;;; ----------------------------------------------------------------------
 146 ;;;
 147 (defsubst ti::xemacs-p (&optional version-string)
 148   "Check if running XEmacs. Optionally at least VERSION-STRING.
 149 Tested string is like  \"20.4\". Value t is returned if version
 150 is equal or greater than VERSION-STRING."
 151   ;; `emacs-version' can't be modified, be bomb sure
 152   (let ((case-fold-search t))
 153     (when (string-match "xemacs" (emacs-version))
 154       (if (or (boundp 'xemacs-logo)
 155               (featurep 'xemacs))       ;Appeared in 20.2+
 156           (cond
 157            ((null version-string)
 158             emacs-version)
 159            ((not (string< emacs-version version-string))
 160             emacs-version))))))
 161
 162 ;;; ----------------------------------------------------------------------
 163 ;;;
 164 (defsubst ti::emacs-p (&optional version-string)
 165   "Check if running Emacs. Optionally at least VERSION-STRING.
 166 Tested string is like  \"20.4\". Value t is returned if version
 167 is equal or greater than VERSION-STRING."
 168   (let ((case-fold-search t))
 169     (unless (string-match "xemacs" (emacs-version))
 170       (cond
 171        ((null version-string)
 172         emacs-version)
 173        ((not (string< emacs-version version-string))
 174         emacs-version)))))
 175
 176 ;;; ----------------------------------------------------------------------
 177 ;;;
 178 (defsubst ti::emacs-type-cygwin-p ()
 179   "Check if running Win32 Cygwin version."
 180   (let ((case-fold-search t))
 181     (string-match "cygwin" (emacs-version))))
 182
 183 ;;; ----------------------------------------------------------------------
 184 ;;;
 185 (defsubst ti::emacs-type-win32-p ()
 186   "Check if running native Win32 version of Emacs or XEmacs."
 187   (and (ti::win32-p)
 188        (not (ti::emacs-type-cygwin-p))))
 189
 190 ;;; ----------------------------------------------------------------------
 191 ;;;
 192 (defsubst ti::emacs-type-unix-like-p ()
 193   "Check if running Unix Emacs or Cygwin Emacs."
 194   (or (not (ti::win32-p))
 195       (ti::emacs-type-cygwin-p)))
 196
 197 ;;; ----------------------------------------------------------------------
 198 ;;;
 199 (defsubst ti::emacs-version-number-as-string ()
 200   "Emacs and XEmacs compatibility. Return plain version number string."
 201   ;;  Emacs: "19.34", XEmacs: "19.14 XEmacs Lucid".
 202   ;;  The regexp will work for both Emacs
 203   (and (string-match "\\([0-9]+\\(\\.[0-9.]\\)+\\)" emacs-version)
 204        (substring emacs-version
 205                   (match-beginning 1)
 206                   (match-end 1))))
 207
 208 ;;; ----------------------------------------------------------------------
 209 ;;;
 210 (defsubst ti::emacs-version-number-as-string-major ()
 211   "Return major version number string. 20.4.1 --> 20.4"
 212   (and (string-match "^\\([0-9]+\\.[0-9]+\\)" emacs-version)
 213        (substring emacs-version 0 (match-end 1))))
 214
 215 ;;  Note: While Emacs would return 20.4.1 for version number,
 216 ;;  The installation directory is not emacs-20.4.1 but 20.4 for
 217 ;;  official releases.
 218 ;;
 219 ;;  Win32: (getenv "emacs_dir"))
 220 ;;  emacs_dir is one of the variables that are taken from
 221 ;;  the registry and mapped into the environment during startup
 222 ;;  of the emacs binary.
 223 ;;
 224 ;;  See also `invocation-directory', The directory in which the Emacs
 225 ;;  executable was found
 226 ;;
 227 ;;  See also `data-directory' Directory of machine-independent files that
 228 ;;  come with GNU Emacs. These are files intended for Emacs to use while
 229 ;;  it runs.
 230
 231 ;;; ----------------------------------------------------------------------
 232 ;;;
 233 (defun ti::emacs-install-root ()
 234   "Return Emacs install ROOT by searching emacs version number from `load-path'."
 235   (let ((regexp
 236          (concat
 237           ".*" (regexp-quote (ti::emacs-version-number-as-string-major))
 238           "[.0-9]*"))
 239         try
 240         ret)
 241     (dolist (elt load-path)
 242       (when (and (stringp elt)
 243                  (string-match regexp elt)
 244                  (setq try (match-string 0 elt))
 245                  ;;  load-path may contain whatever directories, but
 246                  ;;  is it on disk too?
 247                  (file-directory-p (concat try "/lisp" )))
 248         (setq ret try)
 249         (return)))
 250     ret))
 251
 252 ;;; ----------------------------------------------------------------------
 253 ;;;
 254 (defun ti::emacs-install-root-emacsen (binary)
 255   "Search `exec-path' to find BINARY (emacs, xemacs) install root."
 256   (let* ((bin (executable-find binary)))
 257     (when bin
 258       (ti::directory-up
 259        (file-name-directory bin)))))
 260
 261 ;;; ----------------------------------------------------------------------
 262 ;;;
 263 (defsubst ti::os-check-linux-p ()
 264   "Check if operating system is Linux."
 265   (or (string-match "linux" (emacs-version))
 266       (memq system-type '(gnu/linux))
 267       ;;  ... in case the above fails, this call is more expensive
 268       (or (file-exists-p "/boot/vmlinuz")
 269           (file-exists-p "/vmlinuz"))))
 270
 271 ;;; ----------------------------------------------------------------------
 272 ;;;
 273 (defsubst ti::os-check-linux-like-p ()
 274   "Check Operating system is Linux or If running under Cygwin Emacs."
 275   (or (ti::os-check-linux-p)
 276       (ti::emacs-type-cygwin-p)))
 277
 278 ;;; ----------------------------------------------------------------------
 279 ;;;
 280 (defsubst ti::os-check-sunos-p ()
 281   "Check Operating system is SunOS."
 282   (or (string-match "sparc\\|sun\\|sunos\\|solaris" (emacs-version))
 283       ;;  ... in case the above fails
 284       (file-directory-p "/vol/bin")))
 285
 286 ;;; ----------------------------------------------------------------------
 287 ;;;
 288 (defsubst ti::os-check-hpux-p ()
 289   "Check Operating system is HP-UX Unix."
 290   (or (string-match "hpux\\|hppa" (emacs-version))))
 291       ;;  #todo: ... in case the above fails
 292       ;; (file-directory-p "/what/to/test/here?")))
 293
 294 ;;; ----------------------------------------------------------------------
 295 ;;;
 296 (defun ti::win32-p ()
 297   "Check if running under Win32 system.
 298 NOTE: Running under Cygwin is not considered as Win32, use
 299 functions `ti::os-check-linux-like-p' or `ti::win32-cygwin-p'."
 300   (cond
 301    ((memq system-type '(ms-dos windows-nt))) ;; Emacs
 302    ((fboundp 'console-type)
 303     ;; Quiet Emacs byte compiler
 304     (memq (funcall (symbol-function 'console-type))
 305           '(win32 w32 mswindows)))
 306    ((boundp 'window-system)
 307     (memq (symbol-value 'window-system)
 308           '(win32 w32 mswindows)))
 309    ((error "Internal alert, contact maintainer of TinyLib."))))
 310
 311 ;;; ----------------------------------------------------------------------
 312 ;;;
 313 (defun ti::win32-shell-p ()
 314   "Check if shell filename is traditional win32 shell."
 315   ;;  Prevent loading w32-fns.el, which might cause trouble in Unix
 316   (and (ti::win32-p)
 317        (w32-system-shell-p (or shell-file-name ""))))
 318
 319 ;;; ----------------------------------------------------------------------
 320 ;;;
 321 (defsubst ti::win32-nt-p ()
 322   "Check windows NT/W2K/XP."
 323   (when (ti::win32-p)
 324     (or (and (fboundp 'w32-using-nt)
 325              ;;  - This function is in w32-fns.el
 326              ;;  - Hide the call from Byte Compiler that does not understand
 327              ;;    already checked `fboundp'
 328              (funcall (symbol-function 'w32-using-nt)))
 329         (let ((nt-root  (getenv "systemroot")))
 330           (and nt-root
 331                (or (string-match "windows.*NT"  (or (getenv "OS") "" ))
 332                    (file-exists-p
 333                     (concat
 334                      (file-name-as-directory nt-root)
 335                      "system32/cmd.exe"))))))))
 336
 337 ;;; ----------------------------------------------------------------------
 338 ;;;
 339 (defsubst ti::win32-9x-p ()
 340   "Check windows 9x."
 341   (not (ti::win32-nt-p)))
 342
 343 ;;; ----------------------------------------------------------------------
 344 ;;;
 345 (defun ti::win32-cygwin-p-1 (&optional use-no-cache)
 346   "You should use `ti::win32-cygwin-p'. Optionally USE-NO-CACHE value."
 347   (let (ret)
 348     (cond
 349      ((and (null use-no-cache)
 350            (get 'ti::win32-cygwin-p 'cache-set))
 351       (setq ret (get 'ti::win32-cygwin-p 'cache-value)))
 352      (t
 353       (put 'ti::win32-cygwin-p 'cache-set t)
 354       (dolist (path exec-path)
 355         ;;  Sometimes there can be $PATH errors like "/bin::/sbin" and
 356         ;;  Emacs exec-path gets corrupted to read "/:/bin"  etc. Fix those.
 357         (when (and (stringp path)
 358                    (not (string-match "^[a-z]:" path))
 359                    (string-match ".*:" path))
 360           (setq path (replace-match "" nil nil path)))
 361         (when (and (stringp path)
 362                    ;;  Many embedded programs do include *.dll, but
 363                    ;;  not the whole cygwin suite. Search also typical
 364                    ;;  cygpath.exe
 365                    (file-exists-p
 366                     (concat
 367                      (file-name-as-directory path) "cygwin1.dll"))
 368                    (file-exists-p
 369                     (concat
 370                      (file-name-as-directory path) "cygpath.exe")))
 371           ;;  The root directory is one DIR up from bin/cygwin1.dll
 372           ;;
 373           ;;  1) Drop the trailing slash  ../bin
 374           ;;  2) Go one directory up    ..
 375           ;;
 376           ;;  Leave a trailing slash, because the resulting
 377           ;;  directory may be in the worst case at C:/
 378           ;;  (which is NOT a recommended place for cygwin install)
 379           ;;
 380           (when (string-match "^\\(.*\\)[/\\]" path)
 381             (setq path
 382                   (match-string 1 path))
 383             (setq ret path)
 384             ;;  This is native Cygwin Emacs, not a Win32 version
 385             ;;  if path is empty: /bin => one up => ''
 386             (when (string= ret "")
 387               (setq ret "/"))
 388             (put 'ti::win32-cygwin-p 'cache-value ret)
 389             (return))))))
 390     ret))
 391
 392 ;;; ----------------------------------------------------------------------
 393 ;;;
 394 (defsubst ti::win32-cygwin-p (&optional use-cache)
 395   "Return path if cygwin1.dll is found from `exec-path'.
 396  USE-CACHE is non-nil, retrieve cached value which is faster."
 397   (and (ti::win32-p)
 398        (ti::win32-cygwin-p-1)))
 399
 400 ;;; ----------------------------------------------------------------------
 401 ;;;
 402 (defsubst ti::os-check-gnu-support-p ()
 403   "Check if GNU tools are available in this system.
 404 at is, Linux and Cygwin qualifies."
 405   (or (ti::os-check-linux-p)
 406       (ti::win32-cygwin-p)))
 407
 408 ;;; ----------------------------------------------------------------------
 409 ;;;
 410 (defun ti::win32-cygwin-binary-p (bin &optional use-cache)
 411   "Check if program BIN is from Cygwin. The program must be an .exe
 412  USE-CACHE is non-nil, retrieve cached value."
 413   (let ((cygwin (ti::win32-cygwin-p))
 414         path)
 415     (when (and cygwin
 416                (setq path (executable-find bin))
 417                (string-match (regexp-quote cygwin) path))
 418       path)))
 419
 420 ;;; ----------------------------------------------------------------------
 421 ;;;
 422 (defun ti::emacs-debug-mode (&optional mode)
 423   "Toggle XEmacs/Emacs debug on and off."
 424   (interactive "P")
 425   ;;  The normal debug flag
 426   (cond
 427    ((null mode)
 428     (setq debug-on-error (not debug-on-error)))
 429    ((and (integerp mode)
 430          (> mode 0))
 431     (setq debug-on-error t))
 432    (t
 433     (setq debug-on-error nil)))
 434   ;;  Save state for later restoring
 435   (when (boundp 'debug-ignored-errors)
 436     (unless (get 'debug-ignored-errors 'tinyliba)
 437       (put 'debug-ignored-errors 'tinyliba t)
 438       (put 'debug-ignored-errors 'tinyliba-saved debug-ignored-errors)))
 439   (cond
 440    (debug-on-error
 441     ;;   Emacs 20. You want to see all errors when this variable is cleared.
 442     (when (boundp 'debug-ignored-errors)
 443       (set 'debug-ignored-errors nil))
 444     (setq debug-on-error t)
 445     ;;  Must be nil, otherwise it get's on your nervers
 446     ;;  too much when yo hit C-g to interrupt inputs.
 447     ;;  This only exists in New emacs releases.
 448     (if (boundp 'debug-on-quit)
 449         (setq debug-on-quit nil))
 450     (if (boundp 'debug-on-signal) ;;  This must *not* be on!
 451         (setq debug-on-signal nil))
 452     (if (boundp 'stack-trace-on-error) ;; XEmacs
 453         (set 'stack-trace-on-error t))
 454     (message "TinyLib: Emacs debug is ON"))
 455    (t
 456     (when (boundp 'debug-ignored-errors)
 457       (set 'debug-ignored-errors
 458            (get 'debug-ignored-errors 'tinyliba-value)))
 459     (if (boundp 'stack-trace-on-error) ;; XEmacs
 460         (set 'stack-trace-on-error nil))
 461     (message "TinyLib: Emacs debug is OFF"))))
 462
 463 ;;; ----------------------------------------------------------------------
 464 ;;;
 465 (defun ti::turn-on-emacs-debug ()
 466   "Turn on Emacs or XEmacs debug."
 467   (interactive)
 468   (ti::emacs-debug-mode 1))
 469
 470 ;;; ----------------------------------------------------------------------
 471 ;;;
 472 (defun ti::turn-off-emacs-debug ()
 473   "Turn off Emacs or XEmacs debug."
 474   (interactive)
 475   (ti::emacs-debug-mode -1))
 476
 477 ;;}}}
 478 ;;{{{ Other
 479
 480 ;;; ----------------------------------------------------------------------
 481 ;;;
 482 (defun ti::file-version (file)
 483   "Find 'Version:' tag from lisp FILE. Retun numric version string if any."
 484   (let* ((lib    (locate-library file))
 485          (buffer (and lib (find-file-noselect lib)))
 486          find-file-hooks
 487          version)
 488     (save-excursion
 489       (if (null find-file-hooks) ;; No-op, byte compiler silencer
 490           (setq find-file-hooks nil))
 491       (set-buffer buffer)
 492       (goto-char (point-min))
 493       (if (re-search-forward
 494            "^;+[ \t]+Version:[ \t]+\\(.+\\)" nil t)
 495           (setq version (match-string 1)))
 496       (kill-buffer buffer)
 497       version)))
 498
 499 ;;; ----------------------------------------------------------------------
 500 ;;;
 501 (defun ti::executable-find (program &optional type)
 502   "Find PROGRAM, according to TYPE (default is 'cygwin). For example
 503 Windows includes program `ftp', but also Cygwin distribution includes
 504 program `ftp'. The one which is found depends on the order of paths in
 505 `exec-path'. In some case the wanted location could be either windows or
 506 Cygwin version, regardless of the path order.
 507
 508 Input:
 509
 510   PROGRAM    the name of the program (.exe not required)
 511   TYPE       [optional]
 512              'cygwin, which means that windows %SYSTEMROOT% is ignored.
 513              'win32, which means Cygwin root path and below are ignored."
 514   (let* ((cygwin-root (ti::win32-cygwin-p))
 515          (win32-root  (getenv "SYSTEMROOT")) ; Win2000
 516          (list        exec-path))
 517     (cond
 518      ((and (eq type 'cygwin)
 519            win32-root)
 520       (dolist (path exec-path)
 521         ;;  1) backward slashes, 2) forward slashes
 522         (when (not (or (string-match (regexp-quote win32-root) path)
 523                        (string-match (regexp-quote
 524                                       (expand-file-name win32-root)) path)))
 525           (push path list))))
 526      ((and (eq type 'win32)
 527            cygwin-root)
 528       (dolist (path exec-path)
 529         (when (not (or (string-match (regexp-quote cygwin-root) path)
 530                        (string-match (regexp-quote
 531                                       (replace-regexp "/" "\\" cygwin-root))
 532                                      path)))
 533           (push path list)))))
 534     (let ((exec-path (nreverse list))) ;; Reverse preserves the order.
 535       (executable-find program))))
 536
 537 ;;}}}
 538
 539 ;;; tinylibenv.el ends here