Mercurial > hg > xemacs-beta

comparison lisp/winnt.el @ 286:57709be46d1b r21-0b41

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-0b41
author cvs
date Mon, 13 Aug 2007 10:35:03 +0200
parents 8efd647ea9ca
children e11d67e05968
comparison
equal deleted inserted replaced
285:9a3756523c1b 286:57709be46d1b
1 ;;; winnt.el --- Lisp routines for Windows NT. 1 ;;; winnt.el --- Lisp routines for Windows NT.
2 2
3 ;; Copyright (C) 1994 Free Software Foundation, Inc. 3 ;; Copyright (C) 1994 Free Software Foundation, Inc.
4 4
5 ;; Author: Geoff Voelker (voelker@cs.washington.edu) 5 ;; Maintainer: XEmacs Development Team
6 ;; Keywords: mouse, dumped
6 7
7 ;; This file is part of GNU Emacs. 8 ;; This file is part of XEmacs.
8 9
9 ;; GNU Emacs is free software; you can redistribute it and/or modify 10 ;; XEmacs is free software; you can redistribute it and/or modify it
10 ;; it under the terms of the GNU General Public License as published by 11 ;; under the terms of the GNU General Public License as published by
11 ;; the Free Software Foundation; either version 2, or (at your option) 12 ;; the Free Software Foundation; either version 2, or (at your option)
12 ;; any later version. 13 ;; any later version.
13 14
14 ;; GNU Emacs is distributed in the hope that it will be useful, 15 ;; XEmacs is distributed in the hope that it will be useful, but
15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
17 ;; GNU General Public License for more details. 18 ;; General Public License for more details.
18 19
19 ;; You should have received a copy of the GNU General Public License 20 ;; You should have received a copy of the GNU General Public License
20 ;; along with GNU Emacs; see the file COPYING. If not, write to the 21 ;; along with XEmacs; see the file COPYING. If not, write to the
21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, 22 ;; Free Software Foundation, 59 Temple Place - Suite 330,
22 ;; Boston, MA 02111-1307, USA. 23 ;; Boston, MA 02111-1307, USA.
24
25 ;;; Synched up with: Not synched with FSF. Almost completely divergent.
23 26
24 ;;; Commentary: 27 ;;; Commentary:
25 28
26 ;; (August 12, 1993) 29 ;; This file is dumped with XEmacs for MS Windows (without cygwin).
27 ;; Created.
28 30
29 ;; (November 21, 1994) 31 ;; Based on NT Emacs version by Geoff Voelker (voelker@cs.washington.edu)
30 ;; [C-M-backspace] defined.
31 ;; mode-line-format defined to show buffer file type.
32 ;; audio bell initialized.
33 ;;
34 ;; (March 18, 1997)
35 ;; Ported to XEmacs by Marc Paquette <marcpa@cam.org> 32 ;; Ported to XEmacs by Marc Paquette <marcpa@cam.org>
36 ;; 33 ;; Largely modified by Kirill M. Katsnelson <kkm@kis.ru>
37 34
38 ;;; Code: 35 ;;; Code:
39 36
40 ;; Map delete and backspace
41 ;; Not sure this is really needed in XEmacs... --marcpa
42 (define-key global-map [(backspace)] 'backward-delete-char)
43 (define-key global-map [(delete)] 'delete-char)
44 (define-key global-map [(meta backspace)] 'backward-kill-word)
45 (define-key global-map [(control meta backspace)] 'backward-kill-sexp)
46
47 ;; Ignore case on file-name completion
48 (setq completion-ignore-case t)
49
50 ;; The cmd.exe shell uses the "/c" switch instead of the "-c" switch 37 ;; The cmd.exe shell uses the "/c" switch instead of the "-c" switch
51 ;; for executing its command line argument (from simple.el). 38 ;; for executing its command line argument (from simple.el).
39 ;; #### Oh if we had an alist of shells and their command switches.
52 (setq shell-command-switch "/c") 40 (setq shell-command-switch "/c")
53 41
54 ;; For appending suffixes to directories and files in shell completions. 42 ;; For appending suffixes to directories and files in shell completions.
55 (add-hook 'shell-mode-hook 43 (defun nt-shell-mode-hook ()
56 '(lambda () (setq comint-completion-addsuffix '("\\" . " ")))) 44 (setq comint-completion-addsuffix '("\\" . " ")
45 comint-process-echoes t))
46 (add-hook 'shell-mode-hook 'nt-shell-mode-hook)
57 47
58 ;; Use ";" instead of ":" as a path separator (from files.el). 48 ;; Use ";" instead of ":" as a path separator (from files.el).
59 (setq path-separator ";") 49 (setq path-separator ";")
60 50
61 ;; Set the null device (for compile.el). 51 ;; Set the null device (for compile.el).
52 ;; #### There should be such a global thingy as null-device - kkm
62 (setq grep-null-device "NUL") 53 (setq grep-null-device "NUL")
63 54
64 ;; Set the grep regexp to match entries with drive letters. 55 ;; Set the grep regexp to match entries with drive letters.
65 (setq grep-regexp-alist 56 (setq grep-regexp-alist
66 '(("^\\(\\([a-zA-Z]:\\)?[^:( \t\n]+\\)[:( \t]+\\([0-9]+\\)[:) \t]" 1 3))) 57 '(("^\\(\\([a-zA-Z]:\\)?[^:( \t\n]+\\)[:( \t]+\\([0-9]+\\)[:) \t]" 1 3)))
67 58
68 ;; Taken from dos-fn.el ... don't want all that's in the file, maybe 59 ;;----------------------------------------------------------------------
69 ;; separate it out someday. 60 ;; Autosave hack
61 ;;--------------------
70 62
71 (defvar file-name-buffer-file-type-alist 63 ;; Avoid creating auto-save file names containing invalid characters
72 '( 64 ;; (primarily "*", eg. for the *mail* buffer).
73 ("[:/].*config.sys$" . nil) ; config.sys text 65 ;; Avoid "doc lost for function" warning
74 ("\\.elc$" . t) ; emacs stuff 66 (defun original-make-auto-save-file-name (&optional junk)
75 ("\\.\\(obj\\|exe\\|com\\|lib\\|sys\\|chk\\|out\\|bin\\|ico\\|pif\\)$" . t) 67 "You do not want to call this."
76 ; MS-Dos stuff 68 )
77 ("\\.\\(arc\\|zip\\|pak\\|lzh\\|zoo\\)$" . t)
78 ; Packers
79 ("\\.\\(a\\|o\\|tar\\|z\\|gz\\|taz\\)$" . t)
80 ; Unix stuff
81 ("\\.tp[ulpw]$" . t)
82 ; Borland Pascal stuff
83 )
84 "*Alist for distinguishing text files from binary files.
85 Each element has the form (REGEXP . TYPE), where REGEXP is matched
86 against the file name, and TYPE is nil for text, t for binary.")
87
88 (defun find-buffer-file-type (filename)
89 (let ((alist file-name-buffer-file-type-alist)
90 (found nil)
91 (code nil))
92 (let ((case-fold-search t))
93 (setq filename (file-name-sans-versions filename))
94 (while (and (not found) alist)
95 (if (string-match (car (car alist)) filename)
96 (setq code (cdr (car alist))
97 found t))
98 (setq alist (cdr alist))))
99 (if found
100 (cond((memq code '(nil t)) code)
101 ((and (symbolp code) (fboundp code))
102 (funcall code filename)))
103 default-buffer-file-type)))
104
105 (defun find-file-binary (filename)
106 "Visit file FILENAME and treat it as binary."
107 (interactive "FFind file binary: ")
108 (let ((file-name-buffer-file-type-alist '(("" . t))))
109 (find-file filename)))
110
111 (defun find-file-text (filename)
112 "Visit file FILENAME and treat it as a text file."
113 (interactive "FFind file text: ")
114 (let ((file-name-buffer-file-type-alist '(("" . nil))))
115 (find-file filename)))
116
117 (defun find-file-not-found-set-buffer-file-type ()
118 (save-excursion
119 (set-buffer (current-buffer))
120 (setq buffer-file-type (find-buffer-file-type (buffer-file-name))))
121 nil)
122
123 ;;; To set the default file type on new files.
124 (add-hook 'find-file-not-found-hooks 'find-file-not-found-set-buffer-file-type)
125
126 ;;; For using attached Unix filesystems.
127 (defun save-to-unix-hook ()
128 (save-excursion
129 (setq buffer-file-type t))
130 nil)
131
132 (defun revert-from-unix-hook ()
133 (save-excursion
134 (setq buffer-file-type (find-buffer-file-type (buffer-file-name))))
135 nil)
136
137 ;; Really should provide this capability at the drive letter granularity.
138 (defun using-unix-filesystems (flag)
139 "Read and write files without CR/LF translation, if FLAG is non-nil.
140 This is in effect assuming the files are on a remote Unix file system.
141 If FLAG is nil, resume using CR/LF translation as usual."
142 (if flag
143 (progn
144 (add-hook 'write-file-hooks 'save-to-unix-hook)
145 (add-hook 'after-save-hook 'revert-from-unix-hook))
146 (progn
147 (remove-hook 'write-file-hooks 'save-to-unix-hook)
148 (remove-hook 'after-save-hook 'revert-from-unix-hook))))
149
150 ;;; Avoid creating auto-save file names containing invalid characters
151 ;;; (primarily "*", eg. for the *mail* buffer).
152 (fset 'original-make-auto-save-file-name 69 (fset 'original-make-auto-save-file-name
153 (symbol-function 'make-auto-save-file-name)) 70 (symbol-function 'make-auto-save-file-name))
154 71
155 (defun make-auto-save-file-name () 72 (defun make-auto-save-file-name ()
156 "Return file name to use for auto-saves of current buffer. 73 "Return file name to use for auto-saves of current buffer.
163 (while (string-match "[?*]" name start) 80 (while (string-match "[?*]" name start)
164 (aset name (match-beginning 0) ?$) 81 (aset name (match-beginning 0) ?$)
165 (setq start (1+ (match-end 0)))) 82 (setq start (1+ (match-end 0))))
166 name)) 83 name))
167 84
168 ;; ### FIX ME: need to look at XEmacs xmouse.el versus FSF mouse.el 85 ;;----------------------------------------------------------------------
169 ;; and adjust accordingly: I think 'x-selections is an FSFism. 86 ;; Quoting process args
170 ;; --marcpa 87 ;;--------------------
171 ;;; Fix interface to (X-specific) mouse.el
172 (defun x-set-selection (type data)
173 (or type (setq type 'PRIMARY))
174 (put 'x-selections type data))
175 88
176 (defun x-get-selection (&optional type data-type) 89 (defun nt-quote-args-verbatim (args)
177 (or type (setq type 'PRIMARY)) 90 "Copy ARG list verbatim, separating each arg with space."
178 (get 'x-selections type)) 91 (mapconcat 'identity args " "))
179 92
180 ;; FSFisms 93 (defun nt-quote-args-prefix-quote (prefix args)
181 ;(fmakunbound 'font-menu-add-default) 94 (mapconcat (lambda (str)
182 ;(global-unset-key [C-down-mouse-1]) 95 (concat "\""
183 ;(global-unset-key [C-down-mouse-2]) 96 (mapconcat (lambda (ch)
184 ;(global-unset-key [C-down-mouse-3]) 97 (concat (if (eq ch ?\") prefix)
98 (char-to-string ch)))
99 str nil)
100 "\""))
101 args " "))
185 102
186 ;;; Set to a system sound if you want a fancy bell. 103 (defun nt-quote-args-backslash-quote (args)
187 ;(set-message-beep nil) 104 "Place ARG list in quotes, prefixing quotes in args with backslashes."
105 (nt-quote-args-prefix-quote "\\" args))
106
107 (defun nt-quote-args-double-quote (args)
108 "Place ARG list in quotes, doubling quotes in args."
109 (nt-quote-args-prefix-quote "\"" args))
110
111 (defvar nt-quote-args-functions-alist
112 '(("^.?.?sh\\." . nt-quote-args-double-quote))
113 "An alist for determining proper argument quoting given executable file name.
114 Car of each cons must be a string, a regexp against which a file name sans
115 directory is matched. Cdr is a function symbol. The list is mathced in
116 forward order, and mathcing entry cdr's funcrion is called with a list of
117 strings, process arguments. It must return a string which is passed to
118 the newly created process.
119
120 If not found, then `nt-quote-args-verbatim' is called on the argument list.")
121
122 (defun nt-quote-process-args (args)
123 ;;Properly quote process ARGS for executing (car ARGS).
124 (let ((fname (file-name-nondirectory (car args)))
125 (alist nt-quote-args-functions-alist)
126 (case-fold-search nil)
127 (return-me nil)
128 (assoc nil))
129 (while (and alist
130 (null return-me))
131 (setq assoc (pop alist))
132 (if (string-match (car assoc) fname)
133 (setq return-me (funcall (cdr assoc) (cdr args)))))
134 (or return-me
135 (nt-quote-args-verbatim args))))
188 136
189 ;;; winnt.el ends here 137 ;;; winnt.el ends here