annotate lisp/gutter-items.el @ 502:7039e6323819

[xemacs-hg @ 2001-05-04 22:41:46 by ben] ----------------------- byte-comp warning fixes ----------------- New functions for cleanly eliminating byte-compiler warnings. Their definitions require no changes at all in bytecomp.el, meaning that any package that wants to use them and be compatible with older versions of XEmacs need only copy the code and rename the functions (i.e. prefix them with the package name). Eliminate byte-compiler warnings using the new functions in bytecomp-runtime.el. Move coding-system-put,get,category, since they're not Mule-specific and are used in prefer-coding-system. font.el was incredibly ugly. Clean it up. Avoid using defsubst for any exported functions, to avoid possible compatibility problems if we later change the internal interface. (It happened before, with face accessors, between 19.8 and 19.9). Fix tons of warnings. Clean up (new function gpm-is-supported-p eliminates duplicate code in gpm-create/delete-device-hook) and eliminate warnings. ---------- make byte-recompile-directory work in the --------- core `lisp' dir, even in the absence of a Mule XEmacs (i.e. make it skip the Mule files rather than trying to compile them). now you should be able to do `touch *.el' in the `lisp' dir, then M-x byte-recompile-directory, and get no warnings. Avoid trying to compile Mule files in byte-recompile-directory when we're not in a Mule XEmacs, since we're highly likely to get syntax errors. Add a coding-system cookie to all Mule files so that byte-recompile-directory ignores them. Magic cookie function moved to files.el from code-files.el (for use by bytecomp even in a non-coding-system XEmacs), and changed names and semantics for use by bytecomp. NOTE: IMO this is an internal function that we can change as we like (and there is absolutely no code anywhere else using the function). ---------------- GUI improvements: menus, help ------------------- Rearrange order of keymap declarations to be alphabetical. Improve help on help to include all bindings, and group by category. Add bindings for new Info commands. Remove warnings. Use command-hyper-apropos in place of command-apropos. Add a function to do the equivalent of command-apropos. Evals its help-text argument so you can put expressions there. Used now by help-for-help. Add binding to continue text searches. Expand index searches to work over multiple info documents. Add commands to search text/index in User and Lispref. Add new entry, "Uncomment Region" (parallels "Comment Out Region"). Redo Help menu; add bindings for new Info commands to search the index or text of the User and Lispref manuals. Add command for mark-paragraph, activate-region. Make Edit->R accelerator be rectangle, not register (more commonly used), and put rectangle first. Fix the Edit Init File entry to never load the .elc file. Simplify the default-popup-menu. Add Cmds->Tabs menu. Use kp-left not kp_left, etc. ---------------- Miscellaneous bug fixes/cleanup ------------------- byte-compiler-options: Correct doc string. easy-menu-do-define: fix extra quote. fill-paragraph-or-region:Rewrite to be more correct -- use call-interactively so that we always get exactly the same behavior as if the functions were called directly. No need to fiddle with zmacs-region-stays, now that bogus clearing of it (2001-04-28 src/ChangeLog) is removed. Put dialog titles back in -- this time correctly. Fix various other problems with leaks and such. key-sequence-list-description: Clean up fun to always correctly canonicalize. Clean up Kinsoku comments, synch comment-region with FSF 20.7. * simple.el (region-exists-p): * simple.el (region-active-p): Add comment about which one is correct to use in menu specs. * sound.el (load-sound-file): Minor code clean up. * startup.el: * startup.el (command-line-early): * startup.el (initial-scratch-message): Comment changes. Add info about sample.init.el to splash screen. Improve initial-scratch-message and clarify purpose of Scratch buffer. Fix byte-compile warning. ------------------------ Added features ------------------------- Add new variable to control whether etags checks all parent directories for tag files. (On by default.) * hash-table.el: New file, useful utility functions. * dumped-lisp.el (preloaded-file-list): Dump hash-table.el. ------------ notable bug fix: Windows event code -------------- Get critical quit working. ------------ notable bug fix and new feature: regex code -------------- Shy groups were implemented in a horrible, half-assed way that would cause them to screw up regex searching in most cases. Fixed to work correctly. Also extended back-reference syntax past 9. Only is recognized as such if there are at least that many non-shy groups; and optionally will warn about such uses, to catch old code that might be using them differently. (Added variable to control this in search.c -- `warn-about-possibly-incompatible-back- references', on by default for the moment. Declared in lisp.h. ---------------- process/SIGIO improvements ------------------- define USE_GETADDRINFO to replace more complex conditional, and use it. the code conditionalized on this in unix_open_network_stream had *serious* problems handling errors. it's now fixed, and major amounts of duplicate code between the two versions were combined. don't disable SIGIO and other interrupts unless CONNECT_NEEDS_SLOWED_INTERRUPTS is defined -- don't penalize OS's without bugs. similarly for a freebsd bug that was affecting all OS's. * s\ultrix.h: define CONNECT_NEEDS_SLOWED_INTERRUPTS, since that's the OS mentioned as having a kernel bug. * sysdep.c (request_sigio_on_device): * sysdep.c (unrequest_sigio_on_device): fix SIGIO problems on Linux. add check for O_ASYNC in case it's defined and FASYNC isn't. add comment about other ways to do SIGIO on Linux. * callproc.c (Fold_call_process_internal): * process.c (Fstart_process_internal): Deal with the possibility that `default-directory' doesn't have terminating slash. Correct comments about vfork. ---------------- Miscellaneous bug fixes/cleanup ------------------- * callint.c (Finteractive): Add lots of documentation -- exactly what the Lisp equivalents of all the interactive specs are. * console.h (struct console): change type of quit_char to Emchar. * event-msw.c (lstream_type_create_mswindows_selectable): spacing change. Eliminate events-mod.h and combine into events.h. * emacs.c: * emacs.c (make_arg_list_1): * emacs.c (main_1): A couple of char->Extbyte changes, add a comment. * glyphs-msw.c: Correct indentation of function defns to not exceed 80 cols. Try (sort of) to fix some code that sets the colors of the progress gauge. (Commented out) * keymap.c (syms_of_keymap): use DEFSYMBOL. * process.c (read_process_output): No need to fiddle with zmacs_region_stays, now that bogus clearing of it (see below) is removed. * search.c (Freplace_match): warning fix.
author ben
date Fri, 04 May 2001 22:42:35 +0000
parents c33ae14dd6d0
children 943eaba38521
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1 ;;; gutter-items.el --- Gutter content for XEmacs.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3 ;; Copyright (C) 1999 Free Software Foundation, Inc.
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4 ;; Copyright (C) 1999, 2000 Andy Piper.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
5 ;; Copyright (C) 2000 Ben Wing.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
7 ;; Maintainer: XEmacs Development Team
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
8 ;; Keywords: frames, extensions, internal, dumped
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
9
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
10 ;; This file is part of XEmacs.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
11
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
12 ;; XEmacs is free software; you can redistribute it and/or modify it
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
13 ;; under the terms of the GNU General Public License as published by
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
14 ;; the Free Software Foundation; either version 2, or (at your option)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
15 ;; any later version.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
16
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
17 ;; XEmacs is distributed in the hope that it will be useful, but
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
18 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
20 ;; General Public License for more details.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
21
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
22 ;; You should have received a copy of the GNU General Public License
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
23 ;; along with Xmacs; see the file COPYING. If not, write to the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
24 ;; Free Software Foundation, 59 Temple Place - Suite 330,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
25 ;; Boston, MA 02111-1307, USA.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
26
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
27 ;; Some of this is taken from the buffer-menu stuff in menubar-items.el
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
28
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
29 ;;; The Buffers tab
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
30
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
31 (defgroup buffers-tab nil
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
32 "Customization of `Buffers' tab."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
33 :group 'gutter)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
34
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
35 (defvar gutter-buffers-tab nil
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
36 "A tab widget in the gutter for displaying buffers.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
37 Do not set this. Use `set-glyph-image' to change the properties of the tab.")
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
38
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
39 (defcustom gutter-buffers-tab-visible-p
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
40 (gutter-element-visible-p default-gutter-visible-p 'buffers-tab)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
41 "Whether the buffers tab is globally visible.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
42 This option should be set through the options menu."
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
43 :group 'buffers-tab
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
44 :type 'boolean
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
45 :set #'(lambda (var val)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
46 (set-gutter-element-visible-p default-gutter-visible-p
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
47 'buffers-tab val)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
48 (setq gutter-buffers-tab-visible-p val)))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
49
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
50 (defcustom gutter-buffers-tab-enabled t
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
51 "*Whether to enable support for buffers tab in the gutter.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
52 This is different to `gutter-buffers-tab-visible-p' which still runs hooks
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
53 even when the gutter is invisible."
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
54 :group 'buffers-tab
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
55 :type 'boolean)
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
56
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 430
diff changeset
57 (defvar gutter-buffers-tab-orientation 'top
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 430
diff changeset
58 "Where the buffers tab currently is. Do not set this.")
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 430
diff changeset
59
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
60 (defcustom buffers-tab-max-size 6
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
61 "*Maximum number of entries which may appear on the \"Buffers\" tab.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
62 If this is 10, then only the ten most-recently-selected buffers will be
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
63 shown. If this is nil, then all buffers will be shown. Setting this to
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
64 a large number or nil will slow down tab responsiveness."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
65 :type '(choice (const :tag "Show all" nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
66 (integer 6))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
67 :group 'buffers-tab)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
68
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
69 (defcustom buffers-tab-switch-to-buffer-function 'buffers-tab-switch-to-buffer
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
70 "*The function to call to select a buffer from the buffers tab.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
71 `switch-to-buffer' is a good choice, as is `pop-to-buffer'."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
72 :type '(radio (function-item switch-to-buffer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
73 (function-item pop-to-buffer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
74 (function :tag "Other"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
75 :group 'buffers-tab)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
76
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
77 (defcustom buffers-tab-omit-function 'buffers-menu-omit-invisible-buffers
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
78 "*If non-nil, a function specifying the buffers to omit from the buffers tab.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
79 This is passed a buffer and should return non-nil if the buffer should be
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
80 omitted. The default value `buffers-menu-omit-invisible-buffers' omits
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
81 buffers that are normally considered \"invisible\" (those whose name
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
82 begins with a space)."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
83 :type '(choice (const :tag "None" nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
84 function)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
85 :group 'buffers-tab)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
86
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
87 (defcustom buffers-tab-selection-function 'select-buffers-tab-buffers-by-mode
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
88 "*If non-nil, a function specifying the buffers to select from the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
89 buffers tab. This is passed two buffers and should return non-nil if
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
90 the second buffer should be selected. The default value
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
91 `select-buffers-tab-buffers-by-mode' groups buffers by major mode and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
92 by `buffers-tab-grouping-regexp'."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
93
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
94 :type '(choice (const :tag "None" nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
95 function)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
96 :group 'buffers-tab)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
97
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
98 (defcustom buffers-tab-filter-functions (list buffers-tab-selection-function)
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
99 "*If non-nil, a list of functions specifying the buffers to select
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
100 from the buffers tab.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
101 Each function in the list is passed two buffers, the buffer to
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
102 potentially select and the context buffer, and should return non-nil
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
103 if the first buffer should be selected. The default value groups
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
104 buffers by major mode and by `buffers-tab-grouping-regexp'."
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
105
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
106 :type '(choice (const :tag "None" nil)
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
107 sexp)
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
108 :group 'buffers-tab)
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
109
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
110 (defcustom buffers-tab-sort-function nil
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
111 "*If non-nil, a function specifying the buffers to select from the
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
112 buffers tab. This is passed the buffer list and returns the list in the
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
113 order desired for the tab widget. The default value `nil' leaves the
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
114 list in `buffer-list' order (usual most-recently-selected-first)."
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
115
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
116 :type '(choice (const :tag "None" nil)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
117 function)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
118 :group 'buffers-tab)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
119
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 430
diff changeset
120 (make-face 'buffers-tab "Face for displaying the buffers tab.")
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 430
diff changeset
121 (set-face-parent 'buffers-tab 'default)
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 430
diff changeset
122
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 430
diff changeset
123 (defcustom buffers-tab-face 'buffers-tab
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
124 "*Face to use for displaying the buffers tab."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
125 :type 'face
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
126 :group 'buffers-tab)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
127
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
128 (defcustom buffers-tab-grouping-regexp
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
129 '("^\\(gnus-\\|message-mode\\|mime/viewer-mode\\)"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
130 "^\\(emacs-lisp-\\|lisp-\\)")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
131 "*If non-nil, a list of regular expressions for buffer grouping.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
132 Each regular expression is applied to the current major-mode symbol
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
133 name and mode-name, if it matches then any other buffers that match
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
134 the same regular expression be added to the current group."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
135 :type '(choice (const :tag "None" nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
136 sexp)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
137 :group 'buffers-tab)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
138
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
139 (defcustom buffers-tab-format-buffer-line-function 'format-buffers-tab-line
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
140 "*The function to call to return a string to represent a buffer in the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
141 buffers tab. The function is passed a buffer and should return a
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
142 string. The default value `format-buffers-tab-line' just returns the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
143 name of the buffer, optionally truncated to
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
144 `buffers-tab-max-buffer-line-length'. Also check out
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
145 `slow-format-buffers-menu-line' which returns a whole bunch of info
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
146 about a buffer."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
147 :type 'function
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
148 :group 'buffers-tab)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
149
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
150 (defvar buffers-tab-default-buffer-line-length
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
151 (make-specifier-and-init 'generic '((global ((default) . 25))) t)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
152 "*Maximum length of text which may appear in a \"Buffers\" tab.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
153 This is a specifier, use set-specifier to modify it.")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
154
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
155 (defcustom buffers-tab-max-buffer-line-length
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
156 (specifier-instance buffers-tab-default-buffer-line-length)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
157 "*Maximum length of text which may appear in a \"Buffers\" tab.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
158 Buffer names over this length will be truncated with elipses.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
159 If this is 0, then the full buffer name will be shown."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
160 :type '(choice (const :tag "Show all" 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
161 (integer 25))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
162 :group 'buffers-tab
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
163 :set #'(lambda (var val)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
164 (set-specifier buffers-tab-default-buffer-line-length val)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
165 (setq buffers-tab-max-buffer-line-length val)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
166
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
167 (defun buffers-tab-switch-to-buffer (buffer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
168 "For use as a value for `buffers-tab-switch-to-buffer-function'."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
169 (unless (eq (window-buffer) buffer)
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
170 ;; this used to add the norecord flag to both calls below.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
171 ;; this is bogus because it is a pervasive assumption in XEmacs
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
172 ;; that the current buffer is at the front of the buffers list.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
173 ;; for example, select an item and then do M-C-l
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
174 ;; (switch-to-other-buffer). Things get way confused.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
175 (if (> (length (windows-of-buffer buffer)) 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
176 (select-window (car (windows-of-buffer buffer)))
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
177 (switch-to-buffer buffer))))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
178
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
179 (defun select-buffers-tab-buffers-by-mode (buffer-to-select buf1)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
180 "For use as a value of `buffers-tab-selection-function'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
181 This selects buffers by major mode `buffers-tab-grouping-regexp'."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
182 (let ((mode1 (symbol-name (symbol-value-in-buffer 'major-mode buf1)))
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
183 (mode2 (symbol-name (symbol-value-in-buffer 'major-mode
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
184 buffer-to-select)))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
185 (modenm1 (symbol-value-in-buffer 'mode-name buf1))
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
186 (modenm2 (symbol-value-in-buffer 'mode-name buffer-to-select)))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
187 (cond ((or (eq mode1 mode2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
188 (eq modenm1 modenm2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
189 (and (string-match "^[^-]+-" mode1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
190 (string-match
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
191 (concat "^" (regexp-quote
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
192 (substring mode1 0 (match-end 0))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
193 mode2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
194 (and buffers-tab-grouping-regexp
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
195 (find-if #'(lambda (x)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
196 (or
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
197 (and (string-match x mode1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
198 (string-match x mode2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
199 (and (string-match x modenm1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
200 (string-match x modenm2))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
201 buffers-tab-grouping-regexp)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
202 t)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
203 (t nil))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
204
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
205 (defun format-buffers-tab-line (buffer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
206 "For use as a value of `buffers-tab-format-buffer-line-function'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
207 This just returns the buffer's name, optionally truncated."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
208 (let ((len (specifier-instance buffers-tab-default-buffer-line-length)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
209 (if (and (> len 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
210 (> (length (buffer-name buffer)) len))
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
211 (if (string-match ".*<.>$" (buffer-name buffer))
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
212 (concat (substring (buffer-name buffer)
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
213 0 (- len 6)) "..."
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
214 (substring (buffer-name buffer) -3))
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
215 (concat (substring (buffer-name buffer)
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
216 0 (- len 3)) "..."))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
217 (buffer-name buffer))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
218
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
219 (defsubst build-buffers-tab-internal (buffers)
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
220 (let ((selected t))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
221 (mapcar
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
222 #'(lambda (buffer)
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
223 (prog1
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
224 (vector
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
225 (funcall buffers-tab-format-buffer-line-function
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
226 buffer)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
227 (list buffers-tab-switch-to-buffer-function
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
228 (buffer-name buffer))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
229 :selected selected)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
230 (when selected (setq selected nil))))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
231 buffers)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
232
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
233 ;;; #### SJT would like this function to have a sort function list. I
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
234 ;;; don't see how this could work given that sorting is not
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
235 ;;; cumulative --andyp.
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
236 (defun buffers-tab-items (&optional in-deletion frame force-selection)
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
237 "Return a list of tab instantiators based on the current buffers list.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
238 This function is used as the tab filter for the top-level buffers
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
239 \"Buffers\" tab. It dynamically creates a list of tab instantiators
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
240 to use as the contents of the tab. The contents and order of the list
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
241 is controlled by `buffers-tab-filter-functions' which by default
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
242 groups buffers according to major mode and removes invisible buffers.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
243 You can control how many buffers will be shown by setting
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
244 `buffers-tab-max-size'. You can control the text of the tab items by
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
245 redefining the function `format-buffers-menu-line'."
430
a5df635868b2 Import from CVS: tag r21-2-23
cvs
parents: 428
diff changeset
246 (save-match-data
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
247 ;; NB it is too late if we run the omit function as part of the
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
248 ;; filter functions because we need to know which buffer is the
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
249 ;; context buffer before they get run.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
250 (let* ((buffers (delete-if
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
251 buffers-tab-omit-function (buffer-list frame)))
430
a5df635868b2 Import from CVS: tag r21-2-23
cvs
parents: 428
diff changeset
252 (first-buf (car buffers)))
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
253 ;; maybe force the selected window
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
254 (when (and force-selection
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
255 (not in-deletion)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
256 (not (eq first-buf (window-buffer (selected-window frame)))))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
257 (setq buffers (cons (window-buffer (selected-window frame))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
258 (delq first-buf buffers))))
430
a5df635868b2 Import from CVS: tag r21-2-23
cvs
parents: 428
diff changeset
259 ;; if we're in deletion ignore the current buffer
a5df635868b2 Import from CVS: tag r21-2-23
cvs
parents: 428
diff changeset
260 (when in-deletion
a5df635868b2 Import from CVS: tag r21-2-23
cvs
parents: 428
diff changeset
261 (setq buffers (delq (current-buffer) buffers))
a5df635868b2 Import from CVS: tag r21-2-23
cvs
parents: 428
diff changeset
262 (setq first-buf (car buffers)))
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
263 ;; filter buffers
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
264 (when buffers-tab-filter-functions
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
265 (setq buffers
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
266 (delete-if
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
267 #'null
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
268 (mapcar #'(lambda (buf)
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
269 (let ((tmp-buf buf))
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
270 (mapc #'(lambda (fun)
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
271 (unless (funcall fun buf first-buf)
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
272 (setq tmp-buf nil)))
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
273 buffers-tab-filter-functions)
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
274 tmp-buf))
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
275 buffers))))
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
276 ;; maybe shorten list of buffers
430
a5df635868b2 Import from CVS: tag r21-2-23
cvs
parents: 428
diff changeset
277 (and (integerp buffers-tab-max-size)
a5df635868b2 Import from CVS: tag r21-2-23
cvs
parents: 428
diff changeset
278 (> buffers-tab-max-size 1)
a5df635868b2 Import from CVS: tag r21-2-23
cvs
parents: 428
diff changeset
279 (> (length buffers) buffers-tab-max-size)
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 446
diff changeset
280 (setcdr (nthcdr (1- buffers-tab-max-size) buffers) nil))
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
281 ;; sort buffers in group (default is most-recently-selected)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
282 (when buffers-tab-sort-function
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
283 (setq buffers (funcall buffers-tab-sort-function buffers)))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
284 ;; convert list of buffers to list of structures used by tab widget
430
a5df635868b2 Import from CVS: tag r21-2-23
cvs
parents: 428
diff changeset
285 (setq buffers (build-buffers-tab-internal buffers))
a5df635868b2 Import from CVS: tag r21-2-23
cvs
parents: 428
diff changeset
286 buffers)))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
287
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
288 (defun add-tab-to-gutter ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
289 "Put a tab control in the gutter area to hold the most recent buffers."
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 430
diff changeset
290 (setq gutter-buffers-tab-orientation (default-gutter-position))
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
291 (let* ((gutter-string (copy-sequence "\n"))
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
292 (gutter-buffers-tab-extent (make-extent 0 1 gutter-string)))
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
293 (set-extent-begin-glyph gutter-buffers-tab-extent
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
294 (setq gutter-buffers-tab
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
295 (make-glyph)))
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
296 ;; Nuke all existing tabs
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
297 (remove-gutter-element top-gutter 'buffers-tab)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
298 (remove-gutter-element bottom-gutter 'buffers-tab)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
299 (remove-gutter-element left-gutter 'buffers-tab)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
300 (remove-gutter-element right-gutter 'buffers-tab)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
301 ;; Put tabs into all devices that will be able to display them
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
302 (mapcar
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
303 #'(lambda (x)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
304 (when (valid-image-instantiator-format-p 'tab-control x)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
305 (cond ((eq gutter-buffers-tab-orientation 'top)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
306 ;; This looks better than a 3d border
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
307 (set-specifier top-gutter-border-width 0 'global x)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
308 (set-gutter-element top-gutter 'buffers-tab
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
309 gutter-string 'global x))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
310 ((eq gutter-buffers-tab-orientation 'bottom)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
311 (set-specifier bottom-gutter-border-width 0 'global x)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
312 (set-gutter-element bottom-gutter 'buffers-tab
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
313 gutter-string 'global x))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
314 ((eq gutter-buffers-tab-orientation 'left)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
315 (set-specifier left-gutter-border-width 0 'global x)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
316 (set-gutter-element left-gutter 'buffers-tab
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
317 gutter-string 'global x))
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
318 ((eq gutter-buffers-tab-orientation 'right)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
319 (set-specifier right-gutter-border-width 0 'global x)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
320 (set-gutter-element right-gutter 'buffers-tab
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
321 gutter-string 'global x))
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
322 )))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
323 (console-type-list))))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
324
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
325 (defun update-tab-in-gutter (frame &optional force-selection)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
326 "Update the tab control in the gutter area."
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
327 ;; dedicated frames don't get tabs
446
1ccc32a20af4 Import from CVS: tag r21-2-38
cvs
parents: 444
diff changeset
328 (unless (or (window-dedicated-p (frame-selected-window frame))
1ccc32a20af4 Import from CVS: tag r21-2-38
cvs
parents: 444
diff changeset
329 (frame-property frame 'popup))
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
330 (when (specifier-instance default-gutter-visible-p frame)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
331 (unless (and gutter-buffers-tab
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 430
diff changeset
332 (eq (default-gutter-position)
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 430
diff changeset
333 gutter-buffers-tab-orientation))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
334 (add-tab-to-gutter))
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
335 (when (valid-image-instantiator-format-p 'tab-control frame)
446
1ccc32a20af4 Import from CVS: tag r21-2-38
cvs
parents: 444
diff changeset
336 (let ((items (buffers-tab-items nil frame force-selection)))
1ccc32a20af4 Import from CVS: tag r21-2-38
cvs
parents: 444
diff changeset
337 (when items
1ccc32a20af4 Import from CVS: tag r21-2-38
cvs
parents: 444
diff changeset
338 (set-glyph-image
1ccc32a20af4 Import from CVS: tag r21-2-38
cvs
parents: 444
diff changeset
339 gutter-buffers-tab
1ccc32a20af4 Import from CVS: tag r21-2-38
cvs
parents: 444
diff changeset
340 (vector 'tab-control :descriptor "Buffers" :face buffers-tab-face
1ccc32a20af4 Import from CVS: tag r21-2-38
cvs
parents: 444
diff changeset
341 :orientation gutter-buffers-tab-orientation
1ccc32a20af4 Import from CVS: tag r21-2-38
cvs
parents: 444
diff changeset
342 (if (or (eq gutter-buffers-tab-orientation 'top)
1ccc32a20af4 Import from CVS: tag r21-2-38
cvs
parents: 444
diff changeset
343 (eq gutter-buffers-tab-orientation 'bottom))
1ccc32a20af4 Import from CVS: tag r21-2-38
cvs
parents: 444
diff changeset
344 :pixel-width :pixel-height)
1ccc32a20af4 Import from CVS: tag r21-2-38
cvs
parents: 444
diff changeset
345 (if (or (eq gutter-buffers-tab-orientation 'top)
1ccc32a20af4 Import from CVS: tag r21-2-38
cvs
parents: 444
diff changeset
346 (eq gutter-buffers-tab-orientation 'bottom))
1ccc32a20af4 Import from CVS: tag r21-2-38
cvs
parents: 444
diff changeset
347 '(gutter-pixel-width) '(gutter-pixel-height))
1ccc32a20af4 Import from CVS: tag r21-2-38
cvs
parents: 444
diff changeset
348 :items items)
1ccc32a20af4 Import from CVS: tag r21-2-38
cvs
parents: 444
diff changeset
349 frame)
1ccc32a20af4 Import from CVS: tag r21-2-38
cvs
parents: 444
diff changeset
350 ;; set-glyph-image will not make the gutter dirty
458
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 452
diff changeset
351 (set-gutter-dirty-p gutter-buffers-tab-orientation)))))))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
352
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
353 ;; A myriad of different update hooks all doing slightly different things
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
354 (add-one-shot-hook
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
355 'after-init-hook
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
356 #'(lambda ()
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
357 ;; don't add the hooks if the user really doesn't want them
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
358 (when gutter-buffers-tab-enabled
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
359 (add-hook 'create-frame-hook
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
360 #'(lambda (frame)
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
361 (when gutter-buffers-tab (update-tab-in-gutter frame t))))
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
362 (add-hook 'buffer-list-changed-hook 'update-tab-in-gutter)
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
363 (add-hook 'default-gutter-position-changed-hook
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
364 #'(lambda ()
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
365 (when gutter-buffers-tab
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
366 (mapc #'update-tab-in-gutter (frame-list)))))
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
367 (add-hook 'gutter-element-visibility-changed-hook
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
368 #'(lambda (prop visible-p)
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
369 (when (and (eq prop 'buffers-tab) visible-p)
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
370 (mapc #'update-tab-in-gutter (frame-list)))))
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
371 (update-tab-in-gutter (selected-frame) t))))
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
372
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
373 ;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
374 ;; progress display
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
375 ;; ripped off from message display
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
376 ;;
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
377 (defcustom progress-feedback-use-echo-area nil
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
378 "*Whether progress gauge display should display in the echo area.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
379 If NIL then progress gauges will be displayed with whatever native widgets
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
380 are available on the current console. If non-NIL then progress display will be
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
381 textual and displayed in the echo area."
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
382 :type 'boolean
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
383 :group 'gutter)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
384
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
385 (defvar progress-glyph-height 24
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
386 "Height of the progress gauge glyph.")
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
387
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
388 (defvar progress-feedback-popup-period 0.5
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
389 "The time that the progress gauge should remain up after completion")
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
390
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
391 (defcustom progress-feedback-style 'large
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
392 "*Control the appearance of the progress gauge.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
393 If 'large, the default, then the progress-feedback text is displayed
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
394 above the gauge itself. If 'small then the gauge and text are arranged
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
395 side-by-side."
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
396 :group 'gutter
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
397 :type '(choice (const :tag "large" large)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
398 (const :tag "small" small)))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
399
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
400 ;; private variables
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
401 (defvar progress-text-instantiator [string :data ""])
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
402 (defvar progress-layout-glyph (make-glyph))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
403 (defvar progress-layout-instantiator nil)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
404
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
405 (defvar progress-gauge-instantiator
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
406 [progress-gauge
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
407 :value 0
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
408 :pixel-height (eval progress-glyph-height)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
409 :pixel-width 250
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
410 :descriptor "Progress"])
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
411
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
412 (defun set-progress-feedback-instantiator (&optional locale)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
413 (cond
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
414 ((eq progress-feedback-style 'small)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
415 (setq progress-glyph-height 16)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
416 (setq progress-layout-instantiator
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
417 `[layout
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
418 :orientation horizontal
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
419 :margin-width 4
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
420 :items (,progress-gauge-instantiator
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
421 [button
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
422 :pixel-height (eval progress-glyph-height)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
423 ;; 'quit is special and acts "asynchronously".
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
424 :descriptor "Stop" :callback 'quit]
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
425 ,progress-text-instantiator)])
458
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 452
diff changeset
426 (set-glyph-image progress-layout-glyph progress-layout-instantiator
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 452
diff changeset
427 locale))
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
428 (t
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
429 (setq progress-glyph-height 24)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
430 (setq progress-layout-instantiator
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
431 `[layout
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
432 :orientation vertical :justify left
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
433 :margin-width 4
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
434 :items (,progress-text-instantiator
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
435 [layout
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
436 :orientation horizontal
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
437 :items (,progress-gauge-instantiator
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
438 [button
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
439 :pixel-height (eval progress-glyph-height)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
440 :descriptor " Stop "
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
441 ;; 'quit is special and acts "asynchronously".
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
442 :callback 'quit])])])
458
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 452
diff changeset
443 (set-glyph-image progress-layout-glyph progress-layout-instantiator
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 452
diff changeset
444 locale))))
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 452
diff changeset
445
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 452
diff changeset
446 (defvar progress-abort-glyph (make-glyph))
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 452
diff changeset
447
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 452
diff changeset
448 (defun set-progress-abort-instantiator (&optional locale)
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 452
diff changeset
449 (set-glyph-image progress-abort-glyph
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 452
diff changeset
450 `[layout :orientation vertical :justify left
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 452
diff changeset
451 :items (,progress-text-instantiator
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 452
diff changeset
452 [layout
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 452
diff changeset
453 :margin-width 4
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 452
diff changeset
454 :pixel-height progress-glyph-height
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 452
diff changeset
455 :orientation horizontal])]
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 452
diff changeset
456 locale))
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
457
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
458 (defvar progress-stack nil
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
459 "An alist of label/string pairs representing active progress gauges.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
460 The first element in the list is currently displayed in the gutter area.
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
461 Do not modify this directly--use the `progress-feedback' or
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
462 `display-progress-feedback'/`clear-progress-feedback' functions.")
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
463
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
464 (defun progress-feedback-displayed-p (&optional return-string frame)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
465 "Return a non-nil value if a progress gauge is presently displayed in the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
466 gutter area. If optional argument RETURN-STRING is non-nil,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
467 return a string containing the message, otherwise just return t."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
468 (let ((buffer (get-buffer-create " *Gutter Area*")))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
469 (and (< (point-min buffer) (point-max buffer))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
470 (if return-string
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
471 (buffer-substring nil nil buffer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
472 t))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
473
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
474 ;;; Returns the string which remains in the echo area, or nil if none.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
475 ;;; If label is nil, the whole message stack is cleared.
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
476 (defun clear-progress-feedback (&optional label frame no-restore)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
477 "Remove any progress gauge with LABEL from the progress gauge-stack,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
478 erasing it from the gutter area if it's currently displayed there.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
479 If a message remains at the head of the progress-stack and NO-RESTORE
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
480 is nil, it will be displayed. The string which remains in the gutter
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
481 area will be returned, or nil if the progress-stack is now empty.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
482 If LABEL is nil, the entire progress-stack is cleared.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
483
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
484 Unless you need the return value or you need to specify a label,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
485 you should just use (progress nil)."
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
486 (if (or (not (valid-image-instantiator-format-p 'progress-gauge frame))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
487 progress-feedback-use-echo-area)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
488 (clear-message label frame nil no-restore)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
489 (or frame (setq frame (selected-frame)))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
490 (remove-progress-feedback label frame)
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 458
diff changeset
491 (let ((inhibit-read-only t))
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
492 (erase-buffer (get-buffer-create " *Gutter Area*")))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
493 (if no-restore
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
494 nil ; just preparing to put another msg up
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
495 (if progress-stack
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
496 (let ((oldmsg (cdr (car progress-stack))))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
497 (raw-append-progress-feedback oldmsg nil frame)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
498 oldmsg)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
499 ;; nothing to display so get rid of the gauge
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
500 (set-specifier bottom-gutter-border-width 0 frame)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
501 (set-gutter-element-visible-p bottom-gutter-visible-p
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
502 'progress nil frame)))))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
503
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
504 (defun progress-feedback-clear-when-idle (&optional label)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
505 (add-one-shot-hook 'pre-idle-hook
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
506 `(lambda ()
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
507 (clear-progress-feedback ',label))))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
508
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
509 (defun remove-progress-feedback (&optional label frame)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
510 ;; If label is nil, we want to remove all matching progress gauges.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
511 (while (and progress-stack
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
512 (or (null label) ; null label means clear whole stack
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
513 (eq label (car (car progress-stack)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
514 (setq progress-stack (cdr progress-stack)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
515 (let ((s progress-stack))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
516 (while (cdr s)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
517 (let ((msg (car (cdr s))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
518 (if (eq label (car msg))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
519 (progn
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
520 (setcdr s (cdr (cdr s))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
521 (setq s (cdr s)))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
522
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
523 (defun progress-feedback-dispatch-non-command-events ()
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
524 ;; don't allow errors to hose things
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
525 (condition-case t
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
526 ;; (sit-for 0) is too agressive and cause more display than we
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
527 ;; want.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
528 (dispatch-non-command-events)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
529 nil))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
530
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
531 (defun append-progress-feedback (label message &optional value frame)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
532 (or frame (setq frame (selected-frame)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
533 ;; Add a new entry to the message-stack, or modify an existing one
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
534 (let* ((top (car progress-stack))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
535 (tmsg (cdr top)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
536 (if (eq label (car top))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
537 (progn
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
538 (setcdr top message)
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
539 (if (equal tmsg message)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
540 (progn
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
541 (set-instantiator-property progress-gauge-instantiator :value value)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
542 (set-progress-feedback-instantiator (frame-selected-window frame)))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
543 (raw-append-progress-feedback message value frame))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
544 (redisplay-gutter-area))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
545 (push (cons label message) progress-stack)
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
546 (raw-append-progress-feedback message value frame))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
547 (progress-feedback-dispatch-non-command-events)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
548 ;; either get command events or sit waiting for them
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
549 (when (eq value 100)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
550 ; (sit-for progress-feedback-popup-period nil)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
551 (clear-progress-feedback label))))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
552
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
553 (defun abort-progress-feedback (label message &optional frame)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
554 (if (or (not (valid-image-instantiator-format-p 'progress-gauge frame))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
555 progress-feedback-use-echo-area)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
556 (display-message label (concat message "aborted.") frame)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
557 (or frame (setq frame (selected-frame)))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
558 ;; Add a new entry to the message-stack, or modify an existing one
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
559 (let* ((top (car progress-stack))
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 458
diff changeset
560 (inhibit-read-only t))
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
561 (if (eq label (car top))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
562 (setcdr top message)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
563 (push (cons label message) progress-stack))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
564 (unless (equal message "")
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
565 (insert-string message (get-buffer-create " *Gutter Area*"))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
566 (let* ((gutter-string (copy-sequence "\n"))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
567 (ext (make-extent 0 1 gutter-string)))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
568 ;; do some funky display here.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
569 (set-extent-begin-glyph ext progress-abort-glyph)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
570 ;; fixup the gutter specifiers
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
571 (set-gutter-element bottom-gutter 'progress gutter-string frame)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
572 (set-specifier bottom-gutter-border-width 2 frame)
458
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 452
diff changeset
573 (set-instantiator-property progress-text-instantiator :data message)
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 452
diff changeset
574 (set-progress-abort-instantiator (frame-selected-window frame))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
575 (set-specifier bottom-gutter-height 'autodetect frame)
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
576 (set-gutter-element-visible-p bottom-gutter-visible-p
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
577 'progress t frame)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
578 ;; we have to do this so redisplay is up-to-date and so
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
579 ;; redisplay-gutter-area performs optimally.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
580 (redisplay-gutter-area)
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
581 (sit-for progress-feedback-popup-period nil)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
582 (clear-progress-feedback label frame)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
583 (set-extent-begin-glyph ext progress-layout-glyph)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
584 (set-gutter-element bottom-gutter 'progress gutter-string frame)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
585 )))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
586
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
587 (defun raw-append-progress-feedback (message &optional value frame)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
588 (unless (equal message "")
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
589 (let* ((inhibit-read-only t)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
590 (val (or value 0))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
591 (gutter-string (copy-sequence "\n"))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
592 (ext (make-extent 0 1 gutter-string)))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
593 (insert-string message (get-buffer-create " *Gutter Area*"))
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
594 ;; do some funky display here.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
595 (set-extent-begin-glyph ext progress-layout-glyph)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
596 ;; fixup the gutter specifiers
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
597 (set-gutter-element bottom-gutter 'progress gutter-string frame)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
598 (set-specifier bottom-gutter-border-width 2 frame)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
599 (set-instantiator-property progress-gauge-instantiator :value val)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
600 (set-progress-feedback-instantiator (frame-selected-window frame))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
601
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
602 (set-instantiator-property progress-text-instantiator :data message)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
603 (set-progress-feedback-instantiator (frame-selected-window frame))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
604 (if (and (eq (specifier-instance bottom-gutter-height frame)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
605 'autodetect)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
606 (gutter-element-visible-p bottom-gutter-visible-p
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
607 'progress frame))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
608 ;; if the gauge is already visible then just draw the gutter
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
609 ;; checking for user events
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
610 (progn
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
611 (redisplay-gutter-area)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
612 (progress-feedback-dispatch-non-command-events))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
613 ;; otherwise make the gutter visible and redraw the frame
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
614 (set-specifier bottom-gutter-height 'autodetect frame)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
615 (set-gutter-element-visible-p bottom-gutter-visible-p
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
616 'progress t frame)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
617 ;; we have to do this so redisplay is up-to-date and so
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
618 ;; redisplay-gutter-area performs optimally. This may also
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
619 ;; make sure the frame geometry looks ok.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
620 (progress-feedback-dispatch-non-command-events)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
621 (redisplay-frame frame)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
622 ))))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
623
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
624 (defun display-progress-feedback (label message &optional value frame)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
625 "Display a progress gauge and message in the bottom gutter area.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
626 First argument LABEL is an identifier for this message. MESSAGE is
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
627 the string to display. Use `clear-progress-feedback' to remove a labelled
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
628 message."
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
629 (cond ((eq value 'abort)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
630 (abort-progress-feedback label message frame))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
631 ((or (not (valid-image-instantiator-format-p 'progress-gauge frame))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
632 progress-feedback-use-echo-area)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
633 (display-message label
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
634 (concat message (if (eq value 100) "done."
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
635 (make-string (/ value 5) ?.)))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
636 frame))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
637 (t
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
638 (append-progress-feedback label message value frame))))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
639
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
640 (defun current-progress-feedback (&optional frame)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
641 "Return the current progress gauge in the gutter area, or nil.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
642 The FRAME argument is currently unused."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
643 (cdr (car progress-stack)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
644
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
645 ;;; may eventually be frame-dependent
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
646 (defun current-progress-feedback-label (&optional frame)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
647 (car (car progress-stack)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
648
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
649 (defun progress-feedback (fmt &optional value &rest args)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
650 "Print a progress gauge and message in the bottom gutter area of the frame.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
651 The arguments are the same as to `format'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
652
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
653 If the only argument is nil, clear any existing progress gauge."
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
654 (save-excursion
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
655 (if (and (null fmt) (null args))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
656 (prog1 nil
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
657 (clear-progress-feedback nil))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
658 (let ((str (apply 'format fmt args)))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
659 (display-progress-feedback 'progress str value)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
660 str))))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
661
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
662 (defun progress-feedback-with-label (label fmt &optional value &rest args)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
663 "Print a progress gauge and message in the bottom gutter area of the frame.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
664 First argument LABEL is an identifier for this progress gauge. The rest of the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
665 arguments are the same as to `format'."
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
666 ;; #### sometimes the buffer gets changed temporarily. I don't know
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
667 ;; why this is, so protect against it.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
668 (save-excursion
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
669 (if (and (null fmt) (null args))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
670 (prog1 nil
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
671 (clear-progress-feedback label nil))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
672 (let ((str (apply 'format fmt args)))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
673 (display-progress-feedback label str value)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
674 str))))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
675
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
676 (provide 'gutter-items)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
677 ;;; gutter-items.el ends here.