1 ;;; tinylibenv.el --- Library for environment check functions
3 ;; This file is not part of Emacs
7 ;; Copyright (C) 2003-2007 Jari Aalto
8 ;; Keywords: extensions
10 ;; Maintainer: Jari Aalto
12 ;; To get information on this program, call M-x tinyliba-version.
13 ;; Look at the code with folding.el
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)
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
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.
32 ;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
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"
41 ;; (require 'tinylibm)
53 (autoload 'executable-find "executable")
54 (autoload 'ti::directory-up "tinylib")
56 (if (not (or (boundp 'xemacs-logo)
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
66 (string-match "cmdproxy"
67 (or shell-name "")))))
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))
77 ;;{{{ code: Macros, utility functions
79 ;; These are from SEMI::APEL::poe.el
81 ;;; ----------------------------------------------------------------------
83 (put 'defun-maybe 'lisp-indent-function 'defun)
84 (defmacro defun-maybe (name &rest everything-else)
85 (when (or (not (fboundp name))
90 (symbol-function name)))))
92 (defun (, name) (,@ everything-else))
93 (put (quote (, name)) 'defun-maybe t)))))
95 ;;; ----------------------------------------------------------------------
97 (put 'defsubst-maybe 'lisp-indent-function 'defun)
98 (defmacro defsubst-maybe (name &rest everything-else)
99 (when (or (not (fboundp name))
104 (symbol-function name)))))
106 (defsubst (, name) (,@ everything-else))
107 (put (quote (, name)) 'defsubst-maybe t)))))
109 ;;; ----------------------------------------------------------------------
111 (put 'defmacro-maybe 'lisp-indent-function 'defun)
112 (defmacro defmacro-maybe (name &rest everything-else)
113 (when (or (not (fboundp name))
118 (symbol-function name)))))
120 (defmacro (, name) (,@ everything-else))
121 (put (quote (, name)) 'defmacro-maybe t)))))
123 ;;; ----------------------------------------------------------------------
125 (defmacro defalias-maybe (sym newdef)
126 "Make defalias SYM if it does not exist and NEWDEF exists."
128 (when (and (not (fboundp (, sym)))
129 (fboundp (, newdef)))
130 (defalias (, sym) (, newdef)))))
132 ;;; ----------------------------------------------------------------------
134 (defmacro defconst-maybe (name &rest everything-else)
135 (or (and (boundp name)
136 (not (get name 'defconst-maybe)))
137 (` (or (boundp (quote (, name)))
139 (defconst (, name) (,@ everything-else))
140 (put (quote (, name)) 'defconst-maybe t))))))
143 ;;{{{ Environment checks
145 ;;; ----------------------------------------------------------------------
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+
157 ((null version-string)
159 ((not (string< emacs-version version-string))
162 ;;; ----------------------------------------------------------------------
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))
171 ((null version-string)
173 ((not (string< emacs-version version-string))
176 ;;; ----------------------------------------------------------------------
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))))
183 ;;; ----------------------------------------------------------------------
185 (defsubst ti::emacs-type-win32-p ()
186 "Check if running native Win32 version of Emacs or XEmacs."
188 (not (ti::emacs-type-cygwin-p))))
190 ;;; ----------------------------------------------------------------------
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)))
197 ;;; ----------------------------------------------------------------------
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
208 ;;; ----------------------------------------------------------------------
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))))
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.
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.
224 ;; See also `invocation-directory', The directory in which the Emacs
225 ;; executable was found
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
231 ;;; ----------------------------------------------------------------------
233 (defun ti::emacs-install-root ()
234 "Return Emacs install ROOT by searching emacs version number from `load-path'."
237 ".*" (regexp-quote (ti::emacs-version-number-as-string-major))
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" )))
252 ;;; ----------------------------------------------------------------------
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)))
259 (file-name-directory bin)))))
261 ;;; ----------------------------------------------------------------------
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"))))
271 ;;; ----------------------------------------------------------------------
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)))
278 ;;; ----------------------------------------------------------------------
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")))
286 ;;; ----------------------------------------------------------------------
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?")))
294 ;;; ----------------------------------------------------------------------
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'."
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."))))
311 ;;; ----------------------------------------------------------------------
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
317 (w32-system-shell-p (or shell-file-name ""))))
319 ;;; ----------------------------------------------------------------------
321 (defsubst ti::win32-nt-p ()
322 "Check windows NT/W2K/XP."
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")))
331 (or (string-match "windows.*NT" (or (getenv "OS") "" ))
334 (file-name-as-directory nt-root)
335 "system32/cmd.exe"))))))))
337 ;;; ----------------------------------------------------------------------
339 (defsubst ti::win32-9x-p ()
341 (not (ti::win32-nt-p)))
343 ;;; ----------------------------------------------------------------------
345 (defun ti::win32-cygwin-p-1 (&optional use-no-cache)
346 "You should use `ti::win32-cygwin-p'. Optionally USE-NO-CACHE value."
349 ((and (null use-no-cache)
350 (get 'ti::win32-cygwin-p 'cache-set))
351 (setq ret (get 'ti::win32-cygwin-p 'cache-value)))
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
367 (file-name-as-directory path) "cygwin1.dll"))
370 (file-name-as-directory path) "cygpath.exe")))
371 ;; The root directory is one DIR up from bin/cygwin1.dll
373 ;; 1) Drop the trailing slash ../bin
374 ;; 2) Go one directory up ..
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)
380 (when (string-match "^\\(.*\\)[/\\]" path)
382 (match-string 1 path))
384 ;; This is native Cygwin Emacs, not a Win32 version
385 ;; if path is empty: /bin => one up => ''
386 (when (string= ret "")
388 (put 'ti::win32-cygwin-p 'cache-value ret)
392 ;;; ----------------------------------------------------------------------
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."
398 (ti::win32-cygwin-p-1)))
400 ;;; ----------------------------------------------------------------------
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)))
408 ;;; ----------------------------------------------------------------------
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))
416 (setq path (executable-find bin))
417 (string-match (regexp-quote cygwin) path))
420 ;;; ----------------------------------------------------------------------
422 (defun ti::emacs-debug-mode (&optional mode)
423 "Toggle XEmacs/Emacs debug on and off."
425 ;; The normal debug flag
428 (setq debug-on-error (not debug-on-error)))
429 ((and (integerp mode)
431 (setq debug-on-error 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)))
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"))
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"))))
463 ;;; ----------------------------------------------------------------------
465 (defun ti::turn-on-emacs-debug ()
466 "Turn on Emacs or XEmacs debug."
468 (ti::emacs-debug-mode 1))
470 ;;; ----------------------------------------------------------------------
472 (defun ti::turn-off-emacs-debug ()
473 "Turn off Emacs or XEmacs debug."
475 (ti::emacs-debug-mode -1))
480 ;;; ----------------------------------------------------------------------
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)))
489 (if (null find-file-hooks) ;; No-op, byte compiler silencer
490 (setq find-file-hooks nil))
492 (goto-char (point-min))
493 (if (re-search-forward
494 "^;+[ \t]+Version:[ \t]+\\(.+\\)" nil t)
495 (setq version (match-string 1)))
499 ;;; ----------------------------------------------------------------------
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.
510 PROGRAM the name of the program (.exe not required)
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
518 ((and (eq type 'cygwin)
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)))
526 ((and (eq type 'win32)
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))
534 (let ((exec-path (nreverse list))) ;; Reverse preserves the order.
535 (executable-find program))))
539 ;;; tinylibenv.el ends here