--- /dev/null
+;;; dialog-items.el --- Dialog-box content for XEmacs
+
+;; Copyright (C) 2000 Andy Piper.
+;; Copyright (C) 2000 Ben Wing.
+
+;; Maintainer: XEmacs Development Team
+;; Keywords: content, gui, internal, dumped
+
+;; This file is part of XEmacs.
+
+;; XEmacs 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 2, or (at your option)
+;; any later version.
+
+;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Synched up with: Not in FSF.
+
+;;; Commentary:
+
+;;
+;; Simple search dialog
+;;
+(defvar search-dialog-direction t)
+(defvar search-dialog-regexp nil)
+(defvar search-dialog nil)
+
+(defun search-dialog-callback (parent image-instance event)
+ (save-selected-frame
+ (select-frame parent)
+ (let ((domain (frame-selected-window (event-channel event))))
+ (funcall (if search-dialog-direction
+ (if search-dialog-regexp
+ 're-search-forward
+ 'search-forward)
+ (if search-dialog-regexp
+ 're-search-backward
+ 'search-backward))
+ (glyph-image-property
+ (car (glyph-image-property
+ (nth 1 (glyph-image-property
+ search-dialog :items domain))
+ :items domain)) :text domain))
+ (isearch-highlight (match-beginning 0) (match-end 0)))))
+
+(defun make-search-dialog ()
+ "Popup a search dialog box."
+ (interactive)
+ (let ((parent (selected-frame)))
+ (make-dialog-box
+ 'general
+ :parent parent
+ :title "Search"
+ :spec
+ (setq search-dialog
+ (make-glyph
+ `[layout
+ :orientation horizontal :justify left
+ ;; neither the following height/width nor the identical one
+ ;; below should be necessary! (see below)
+ :height 11 :width 40
+ :border [string :data "Search"]
+ :items
+ ([layout :orientation vertical :justify left
+ :items
+ ([string :data "Search for:"]
+ [button :descriptor "Match Case"
+ :style toggle
+ :selected (not case-fold-search)
+ :callback (setq case-fold-search
+ (not case-fold-search))]
+ [button :descriptor "Regular Expression"
+ :style toggle
+ :selected search-dialog-regexp
+ :callback (setq search-dialog-regexp
+ (not search-dialog-regexp))]
+ [button :descriptor "Forwards"
+ :style radio
+ :selected search-dialog-direction
+ :callback (setq search-dialog-direction t)]
+ [button :descriptor "Backwards"
+ :style radio
+ :selected (not search-dialog-direction)
+ :callback (setq search-dialog-direction nil)]
+ )]
+ [layout :orientation vertical :justify left
+ :items
+ ([edit-field :width 15 :descriptor "" :active t
+ :face default :initial-focus t]
+ [button :width 10 :descriptor "Find Next"
+ :callback-ex
+ (lambda (image-instance event)
+ (search-dialog-callback ,parent
+ image-instance
+ event))]
+ [button :width 10 :descriptor "Cancel"
+ :callback-ex
+ (lambda (image-instance event)
+ (isearch-dehighlight)
+ (delete-frame
+ (event-channel event)))])])]))
+ ;; neither this height/width nor the identical one above should
+ ;; be necessary! (in fact, if you omit the one above, the layout
+ ;; sizes itself correctly; but the frame as a whole doesn't use
+ ;; the layout's size, as it should.)
+ :properties '(height 11 width 40))))
--- /dev/null
+;;; update-elc-2.el --- Recompile remaining .el files, post-dumping
+
+;; Copyright (C) 1997 by Free Software Foundation, Inc.
+;; Copyright (C) 2000 Ben Wing.
+
+;; Author: Ben Wing <ben@xemacs.org>, based on cleantree.el by
+;; Steven L Baur <steve@xemacs.org>
+;; Maintainer: XEmacs Development Team
+;; Keywords: internal
+
+;; This file is part of XEmacs.
+
+;; XEmacs 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 2, or (at your option)
+;; any later version.
+
+;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the Free
+;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+;; 02111-1307, USA.
+
+;;; Synched up with: Not in FSF
+
+;;; Commentary:
+
+;; This file should be used after XEmacs has been dumped, to recompile
+;; all remaining out-of-date .els and clean up orphaned .elcs. It should
+;; be called as
+;;
+;; xemacs -batch -vanilla -l update-elc-2.el -f batch-update-elc-2 ${dirname}
+;;
+;; where ${dirname} is the directory tree to recompile, usually `lisp'.
+;;
+;; Note that this is very different from update-elc.el, which is called
+;; BEFORE dumping, handles only the files needed to dump, and is called
+;; from temacs instead of xemacs.
+;;
+;; The original cleantree.el had the comment: This code is derived
+;; from Gnus based on a suggestion by David Moore <dmoore@ucsd.edu>
+
+;;; Code:
+
+(defvar update-elc-ignored-dirs
+ `("." ".." "CVS" "SCCS" "RCS" ,@(unless (featurep 'mule) '("mule"))))
+
+(defvar update-elc-ignored-files
+ ;; note: entries here are regexps
+ '("^," ;; #### huh?
+ "^paths.el$"
+ "^loadup.el$"
+ "^loadup-el.el$"
+ "^update-elc.el$"
+ "^update-elc-2.el$"
+ "^dumped-lisp.el$"
+ "^make-docfile.el$"
+ "^site-start.el$"
+ "^site-load.el$"
+ "^site-init.el$"
+ "^version.el$"
+ "^very-early-lisp.el$"))
+
+;; SEEN accumulates the list of already-handled dirs.
+(defun do-update-elc-2 (dir compile-stage-p seen)
+ (setq dir (file-name-as-directory dir))
+ ;; Only scan this sub-tree if we haven't been here yet.
+ (unless (member (file-truename dir) seen)
+ (push (file-truename dir) seen)
+
+ ;; Do this directory.
+ (if compile-stage-p
+ ;; Stage 2: Recompile necessary .els
+ (let ((files (directory-files dir t ".el$"))
+ file file-c)
+ (while (setq file (car files))
+ (setq files (cdr files))
+ (setq file-c (concat file "c"))
+ (when (and (file-exists-p file)
+ (or (not (file-exists-p file-c))
+ (file-newer-than-file-p file file-c))
+ (let (ignore)
+ (mapcar
+ #'(lambda (regexp)
+ (if (string-match regexp
+ (file-name-nondirectory file))
+ (setq ignore t)))
+ update-elc-ignored-files)
+ (not ignore)))
+ (byte-compile-file file))))
+
+ ;; Stage 1.
+ ;; Remove out-of-date elcs
+ (let ((files (directory-files dir t ".el$"))
+ file file-c)
+ (while (setq file (car files))
+ (setq files (cdr files))
+ (setq file-c (concat file "c"))
+ (when (and (file-exists-p file-c)
+ (file-newer-than-file-p file file-c))
+ (message "Removing out-of-date %s" file-c)
+ (delete-file file-c))))
+ ;; Remove elcs without corresponding el
+ (let ((files (directory-files dir t ".elc$"))
+ file file-c)
+ (while (setq file-c (car files))
+ (setq files (cdr files))
+ (setq file (replace-in-string file-c "c$" ""))
+ (when (and (file-exists-p file-c)
+ (not (file-exists-p file)))
+ (message "Removing %s; no corresponding .el" file-c)
+ (delete-file file-c))))
+
+ ;; We descend recursively
+ (let ((dirs (directory-files dir t nil t))
+ dir)
+ (while (setq dir (pop dirs))
+ (when (and (not (member (file-name-nondirectory dir)
+ update-elc-ignored-dirs))
+ (file-directory-p dir))
+ (do-update-elc-2 dir compile-stage-p seen))))
+
+ )))
+
+
+(defun batch-update-elc-2 ()
+ (defvar command-line-args-left)
+ (unless noninteractive
+ (error "`batch-update-elc-2' is to be used only with -batch"))
+ (let ((dir (car command-line-args-left)))
+ ;; We remove all the bad .elcs before any byte-compilation, because
+ ;; there may be dependencies between one .el and another (even across
+ ;; directories), and we don't want to load an out-of-date .elc while
+ ;; byte-compiling a file.
+ (message "Removing old or spurious .elcs in directory tree `%s'..." dir)
+ (do-update-elc-2 dir nil nil)
+ (message "Removing old or spurious .elcs in directory tree `%s'...done"
+ dir)
+ (message "Recompiling updated .els in directory tree `%s'..." dir)
+ (do-update-elc-2 dir t nil)
+ (message "Recompiling updated .els in directory tree `%s'...done" dir))
+ (setq command-line-args-left nil))
+
+;;; cleantree.el ends here
--- /dev/null
+;;; win32-native.el --- Lisp routines for MS Windows.
+
+;; Copyright (C) 1994 Free Software Foundation, Inc.
+;; Copyright (C) 2000 Ben Wing.
+
+;; Maintainer: XEmacs Development Team
+;; Keywords: mouse, dumped
+
+;; This file is part of XEmacs.
+
+;; XEmacs 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 2, or (at your option)
+;; any later version.
+
+;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Synched up with: Not synched with FSF. Almost completely divergent.
+;;; (FSF has stuff in w32-fns.el and term/w32-win.el.)
+
+;;; Commentary:
+
+;; This file is dumped with XEmacs for MS Windows (without cygwin).
+
+;; Based on NT Emacs version by Geoff Voelker (voelker@cs.washington.edu)
+;; Ported to XEmacs by Marc Paquette <marcpa@cam.org>
+;; Largely modified by Kirill M. Katsnelson <kkm@kis.ru>
+
+;;; Code:
+
+;; The cmd.exe shell uses the "/c" switch instead of the "-c" switch
+;; for executing its command line argument (from simple.el).
+;; #### Oh if we had an alist of shells and their command switches.
+(setq shell-command-switch "/c")
+
+;; For appending suffixes to directories and files in shell
+;; completions. This screws up cygwin users so we leave it out for
+;; now. Uncomment this if you only ever want to use cmd.
+
+;(defun nt-shell-mode-hook ()
+; (setq comint-completion-addsuffix '("\\" . " ")
+; comint-process-echoes t))
+;(add-hook 'shell-mode-hook 'nt-shell-mode-hook)
+
+;; Use ";" instead of ":" as a path separator (from files.el).
+(setq path-separator ";")
+
+;; Set the null device (for compile.el).
+;; #### There should be such a global thingy as null-device - kkm
+(setq grep-null-device "NUL")
+
+;; Set the grep regexp to match entries with drive letters.
+(setq grep-regexp-alist
+ '(("^\\(\\([a-zA-Z]:\\)?[^:( \t\n]+\\)[:( \t]+\\([0-9]+\\)[:) \t]" 1 3)))
+
+;;----------------------------------------------------------------------
+;; Autosave hack
+;;--------------------
+
+;; Avoid creating auto-save file names containing invalid characters
+;; (primarily "*", eg. for the *mail* buffer).
+;; Avoid "doc lost for function" warning
+(defun original-make-auto-save-file-name (&optional junk)
+ "You do not want to call this."
+ )
+(fset 'original-make-auto-save-file-name
+ (symbol-function 'make-auto-save-file-name))
+
+(defun make-auto-save-file-name ()
+ "Return file name to use for auto-saves of current buffer.
+Does not consider `auto-save-visited-file-name' as that variable is checked
+before calling this function. You can redefine this for customization.
+See also `auto-save-file-name-p'."
+ (let ((name (original-make-auto-save-file-name))
+ (start 0))
+ ;; destructively replace occurrences of * or ? with $
+ (while (string-match "[?*]" name start)
+ (aset name (match-beginning 0) ?$)
+ (setq start (1+ (match-end 0))))
+ name))
+
+;;----------------------------------------------------------------------
+;; Quoting process args
+;;--------------------
+
+(defvar debug-mswindows-process-command-lines nil
+ "If non-nil, output debug information about the command lines constructed.
+This can be useful if you are getting process errors where the arguments
+to the process appear to be getting passed incorrectly.")
+
+;; properly quotify one arg for the vc runtime argv constructor.
+(defun mswindows-quote-one-vc-runtime-arg (arg &optional quote-shell)
+ ;; we mess with any arg with whitespace, quotes, or globbing chars in it.
+ ;; we also include shell metachars if asked.
+ ;; note that \ is NOT included! it's perfectly OK to include an
+ ;; arg like c:\ or c:\foo.
+ (if (string-match (if quote-shell "[ \t\n\r\f*?\"<>|&^%]" "[ \t\n\r\f*?\"]")
+ arg)
+ (progn
+ ;; handle nested quotes, possibly preceded by backslashes
+ (setq arg (replace-in-string arg "\\([\\]*\\)\"" "\\1\\1\\\\\""))
+ ;; handle trailing backslashes
+ (setq arg (replace-in-string arg "\\([\\]+\\)$" "\\1\\1"))
+ (concat "\"" arg "\""))
+ arg))
+
+(defun mswindows-quote-one-simple-arg (arg &optional quote-shell)
+ ;; just put double quotes around args with spaces (and maybe shell
+ ;; metachars).
+ (if (string-match (if quote-shell "[ \t\n\r\f*?\"<>|&^%]" "[ \t\n\r\f*?]")
+ arg)
+ (concat "\"" arg "\"")
+ arg))
+
+(defun mswindows-quote-one-command-arg (arg)
+ ;; quote an arg to get it past COMMAND.COM/CMD.EXE: need to quote shell
+ ;; metachars with ^.
+ (replace-in-string "[<>|&^%]" "^\\1" arg))
+
+(defun mswindows-construct-verbatim-command-line (program args)
+ (mapconcat #'identity args " "))
+
+;; for use with either standard VC++ compiled programs or Cygwin programs,
+;; which emulate the same behavior.
+(defun mswindows-construct-vc-runtime-command-line (program args)
+ (mapconcat #'mswindows-quote-one-vc-runtime-arg args " "))
+
+;; note: for pulling apart an arg:
+;; each arg consists of either
+
+;; something surrounded by single quotes
+
+;; or
+
+;; one or more of
+
+;; 1. a non-ws, non-" char
+;; 2. a section of double-quoted text
+;; 3. a section of double-quoted text with end-of-string instead of the final
+;; quote.
+
+;; 2 and 3 get handled together.
+
+;; quoted text is one of
+;;
+;; 1. quote + even number of backslashes + quote, or
+;; 2. quote + non-greedy anything + non-backslash + even number of
+;; backslashes + quote.
+
+;; we need to separate the two because we unfortunately have no non-greedy
+;; ? operator. (urk! we actually do, but it wasn't documented.) --ben
+
+;; if you want to mess around, keep this test case in mind:
+
+;; this string
+
+;; " as'f 'FOO BAR' '' \"\" \"asdf \\ \\\" \\\\\\\" asdfasdf\\\\\" foo\" "
+
+;; should tokenize into this:
+
+;; (" " "as'f" " " "'FOO BAR' " "'' " "\"\"" " " "\"asdf \\ \\\" \\\\\\\" asdfasdf\\\\\"" " " "foo" "\" ")
+
+;; this regexp actually separates the arg into individual args, like a
+;; shell (such as sh) does, but using vc-runtime rules. it's easy to
+;; derive the tokenizing regexp from it, and that's exactly what i did.
+;; but oh was it hard to get this first regexp right. --ben
+;(defvar mswindows-match-one-cmd-exe-arg-regexp
+; (concat
+; "^\\("
+; "'\\([\\]*\\)\\2'" "\\|"
+; "'.*?[^\\]\\(\\([\\]*\\)\\4'\\)" "\\|"
+; "\\("
+; "[^ \t\n\r\f\v\"]" "\\|"
+; "\"\\([\\]*\\)\\6\"" "\\|"
+; "\".*?[^\\]\\(\\([\\]*\\)\\8\"\\|$\\)"
+; "\\)+"
+; "\\)"
+; "\\([ \t\n\r\f\v]+\\|$\\)"))
+
+(defvar mswindows-match-one-cmd-exe-token-regexp
+ (concat
+ "^\\("
+ "[ \t\n\r\f\v]+" "\\|"
+ "'\\([\\]*\\)\\2'" "\\([ \t\n\r\f\v]+\\|$\\)" "\\|"
+ "'.*?[^\\]\\(\\([\\]*\\)\\5'\\)" "\\([ \t\n\r\f\v]+\\|$\\)" "\\|"
+ "[^ \t\n\r\f\v\"]+" "\\|"
+ "\"\\([\\]*\\)\\7\"" "\\|"
+ "\".*?[^\\]\\(\\([\\]*\\)\\9\"\\|$\\)"
+ "\\)"))
+
+(defun mswindows-construct-command-command-line (program args)
+ ;; for use with COMMAND.COM and CMD.EXE:
+ ;; for each arg, tokenize it into quoted and non-quoted sections;
+ ;; then quote all the shell meta-chars with ^; then put everything
+ ;; back together. the truly hard part is the tokenizing -- typically
+ ;; we get a single argument (the command to execute) and we have to
+ ;; worry about quotes that are backslash-quoted and such.
+ (mapconcat
+ #'(lambda (arg)
+ (mapconcat
+ #'(lambda (part)
+ (if (string-match "^'" part)
+ (replace-in-string part "\\([<>|^&%]\\)" "^\\1")
+ part))
+ (let (parts)
+ (while (and (> (length arg) 0)
+ (string-match
+ mswindows-match-one-cmd-exe-token-regexp
+ arg))
+ (push (match-string 0 arg) parts)
+ (setq arg (substring arg (match-end 0))))
+ (if (> (length arg) 0)
+ (push arg parts))
+ (nreverse parts))
+ ""))
+ args " "))
+
+(defvar mswindows-construct-process-command-line-alist
+ '(("[\\/].?.?sh\\." . mswindows-construct-verbatim-command-line)
+ ("[\\/]command\\.com$" . mswindows-construct-command-command-line)
+ ("[\\/]cmd\\.exe$" . mswindows-construct-command-command-line)
+ ("" . mswindows-construct-vc-runtime-command-line))
+ "An alist for determining proper argument quoting given executable
+file name. Car of each cons should be a string, a regexp against
+which the file name is matched. Matching is case-insensitive but does
+include the directory, so you should begin your regexp with [\\\\/] if
+you don't want the directory to matter. Alternatively, the car can be
+a function of one arg, which is called with the executable's name and
+should return t if this entry should be processed. Cdr is a function
+symbol, which is called with two args, the executable name and a list
+of the args passed to it. It should return a string, which includes
+the executable's args (but not the executable name itself) properly
+quoted and pasted together. The list is matched in order, and the
+first matching entry specifies how the processing will happen.")
+
+(defun mswindows-construct-process-command-line (args)
+ ;;Properly quote process ARGS for executing (car ARGS).
+ ;;Called from the C code.
+ (let ((fname (car args))
+ (alist mswindows-construct-process-command-line-alist)
+ (case-fold-search t)
+ (return-me nil)
+ (assoc nil))
+ (while (and alist
+ (null return-me))
+ (setq assoc (pop alist))
+ (if (if (stringp (car assoc))
+ (string-match (car assoc) fname)
+ (funcall (car assoc) fname))
+ (setq return-me (cdr assoc))))
+ (let* ((called-fun (or return-me
+ #'mswindows-construct-vc-runtime-command-line))
+ (retval
+ (let ((str (funcall called-fun fname (cdr args)))
+ (quoted-fname (mswindows-quote-one-simple-arg fname)))
+ (if (and str (> (length str) 0))
+ (concat quoted-fname " " str)
+ quoted-fname))))
+ (when debug-mswindows-process-command-lines
+ (debug-print "mswindows-construct-process-command-line called:\n")
+ (debug-print "received args: \n%s"
+ (let ((n -1))
+ (mapconcat #'(lambda (arg)
+ (incf n)
+ (format " %d %s\n" n arg))
+ args
+ "")))
+ (debug-print "called fun %s\n" called-fun)
+ (debug-print "resulting command line: %s\n" retval))
+ retval)))
+
+;;; win32-native.el ends here
projects / chise / xemacs-chise.git- / commitdiff