diff options
145 files changed, 258 insertions, 47709 deletions
diff --git a/00AddingFiles b/00AddingFiles index 5b4d1c3..56a90a6 100755 --- a/00AddingFiles +++ b/00AddingFiles @@ -1,3 +1,7 @@ +DO NOT ADD ANY FILES TO THIS PACKAGE. + +This document preserved for historical reasons. + This is a checklist for adding files to the emacs-goodies-el package. - Make sure the upstream file can be used and customized using only the diff --git a/debian/NEWS b/debian/NEWS new file mode 100644 index 0000000..76d4203 --- /dev/null +++ b/debian/NEWS @@ -0,0 +1,18 @@ +emacs-goodies-el (38.0) experimental; urgency=medium + + We are migrating emacs-goodies-el to use Debian's support for GNU Emacs's + package.el, also known as "ELPA packages". The main user visible changes are: + + - binary packages will be renamed to elpa-foo, where foo is the name of + the addon; transitional packages are provided, so you will find the + elpa- packages automatically installed when you upgrade; and + + - xemacs is no longer supported. + + We are also dropping some very old addons which we no longer consider to + be maintained or maintainable. + + See /usr/share/doc/emacs-goodies-el/README.Debian.gz for the current + status of the migration. + + -- Sean Whitton <spwhitton@spwhitton.name> Sat, 30 Jun 2018 07:11:36 +0100 diff --git a/debian/README.Debian b/debian/README.Debian index 8df417b..4ec8632 100644 --- a/debian/README.Debian +++ b/debian/README.Debian @@ -9,13 +9,24 @@ Info node `emacs-goodies-el' for more complete information. Introduction to files in emacs-goodies-el ----------------------------------------- + In the following list, a prefix of "D" means "dropped", "E" means +"elpafied", and "T" means "transitioned to an actively maintained +alternative that has equivalent functionality". Elpafied or +transitioned packages have been declared as dependencies in +debian/control, and will usually have names like "elpa-package". +Packages that are dead upstream and have been broken in Debian for a +number of years have been (or will be) dropped, and debian/changelog +can be consulted for the bug report number that contains the history +and justification for this decision. + + ,----[ nice title ] | boxquote.el allows the easy creation of boxes that look like this, | with a nice title and all. Look for the M-x boxquote-* commands. `---- align-string.el provides M-x align-string and M-x align-all-strings, -to align vertically the first occurences of a regexp over several +to align vertically the first occurrences of a regexp over several lines. all.el provides M-x all, a way to see all lines matching a regexp @@ -28,25 +39,25 @@ files. ascii.el provides a way to display ASCII code on a window, that is, display in another window an ASCII table highlighting the current character code. -auto-fill-inhibit.el provides a finer grained control over -auto-fill-mode activation. Tu use it, simply load the file. For -instance, adding (load-library "auto-fill-inhibit") to your .emacs -should do the trick. You'll need to set the auto-fill-inhibit-list -variable to an appropriate value. + D auto-fill-inhibit.el provides a finer grained control over + auto-fill-mode activation. Tu use it, simply load the file. For + instance, adding (load-library "auto-fill-inhibit") to your .emacs + should do the trick. You'll need to set the + auto-fill-inhibit-list variable to an appropriate value. bar-cursor.el allows you to change your cursor from a block to a vertical bar in insert mode, and back to a block in overwrite mode. Try M-x bar-cursor-mode. -bm.el provides visible, buffer local, bookmarks and the ability to jump -forward and backward to the next bookmark. + E bm.el provides visible, buffer local, bookmarks and the ability to + jump forward and backward to the next bookmark. browse-huge-tar.el allows you to browse large tar files without reading them into memory. The trade off is memory usage vs. speed. -browse-kill-ring.el provides M-x browse-kill-ring.el, to, well, browse -through your kill ring, perform searches on it, and insert items into -a buffer. + E browse-kill-ring.el provides M-x browse-kill-ring.el, to, well, browse + through your kill ring, perform searches on it, and insert items into + a buffer. button-lock.el is a minor mode which provides simple facilities to define clickable text based on regular expressions (used by maplev.el). @@ -60,9 +71,9 @@ can involve some basic template replacement. color-theme.el changes the colors used within Emacs. They are lots of themes to choose from. -csv-mode.el is a major mode for editing files of CSV type, which provides -commands, key bindings and a menu to sort records by field, kill and yank -columns, align and unalign fields, and transpose rows and columns. + E csv-mode.el is a major mode for editing files of CSV type, which provides + commands, key bindings and a menu to sort records by field, kill and yank + columns, align and unalign fields, and transpose rows and columns. ctypes.el can search through source files hunting down typedefs. When found, font-lock is informed and your source code will be even more @@ -77,9 +88,9 @@ When a window is "dedicated", Emacs will not select files into that window. df.el provides M-x df, to display in the mode line space left on devices. -diminish.el provides M-x diminish, M-x diminish-undo and M-x -diminished-modes. Diminished modes are minor modes with a shorter or -no modeline display. + E diminish.el provides M-x diminish, M-x diminish-undo and M-x + diminished-modes. Diminished modes are minor modes with a shorter or + no modeline display. dir-locals.el provides a functionality similar to the local variables defined in a file, but for an entire directory tree. Use This library @@ -93,59 +104,65 @@ name (or other keywords) in buffers. If you use Gnus, you might want to add (add-hook 'gnus-article-prepare-hook 'egocentric-mode) to your Gnus init file. -eproject.el is an extension that lets you group related files together as -projects. It aims to be as unobtrusive as possible -- no new files are -created (or required to exist) on disk, and buffers that aren't a member of -a project are not affected in any way. + E eproject.el is an extension that lets you group related files together as + projects. It aims to be as unobtrusive as possible -- no new files are + created (or required to exist) on disk, and buffers that aren't a member + of a project are not affected in any way. ff-paths.el allows you to use C-x C-f normally most of the time, except that if the requested file doesn't exist, it is checked against a list of patterns for special paths to search for a file of the same name. Use (require 'ff-paths) in your .emacs to activate it. -filladapt.el enhances the behavior of Emacs's fill functions by -guessing the proper fill prefix in many contexts. Emacs has a -built-in adaptive fill mode but Filladapt is said to be much better. -Use `M-x filladapt-mode' to toggle Filladapt mode on/off in the current -buffer. Use 'turn-on-filladapt-mode in mode hooks. + D filladapt.el enhances the behavior of Emacs's fill functions by + guessing the proper fill prefix in many contexts. Emacs has a + built-in adaptive fill mode but Filladapt is said to be much + better. Use `M-x filladapt-mode' to toggle Filladapt mode on/off + in the current buffer. Use 'turn-on-filladapt-mode in mode hooks. -folding.el provides a minor mode for folding (hiding) parts of the edited -text or program. Folding mode handles a document as a tree, where each -branch is bounded by special markers `{{{' and `}}}'. + E folding.el provides a minor mode for folding (hiding) parts of the edited + text or program. Folding mode handles a document as a tree, where each + branch is bounded by special markers `{{{' and `}}}'. -framepop.el makes temporary buffers such as *Help* or *Completions* appear -in a separate frame which is easily dismissed when no longer needed. + D framepop.el makes temporary buffers such as *Help* or + *Completions* appear in a separate frame which is easily dismissed + when no longer needed. floatbg.el provides M-x floatbg-mode, to slowly modify the background color of your Emacs. -graphviz-dot-mode.el provides a mode for editing files in the dot-language -(www.graphviz.org and http://www.research.att.com/sw/tools/graphviz/). + E graphviz-dot-mode.el provides a mode for editing files in the dot-language + (www.graphviz.org and http://www.research.att.com/sw/tools/graphviz/). -highlight-beyond-fill-column.el highlights (with a face you choose) text -that is beyond the fill-column, therefore providing a visual indication of -where the fill-* functions would wrap the lines. Enable it on a buffer -using `M-x highlight-beyond-fill-column.' You may use that command in a -hook (e.g. text-mode-hook) + T highlight-beyond-fill-column.el highlights (with a face you + choose) text that is beyond the fill-column, therefore providing a + visual indication of where the fill-* functions would wrap the + lines. Enable it on a buffer using `M-x highlight-beyond-fill-column.' + You may use that command in a hook (e.g. text-mode-hook). + - The functionality of highlight-beyond-fill-column is now + provided by the GNU Emacs builtin whitespace-line-column. -highlight-current-line.el highlights the line the cursor is in. Enable a -buffer using the command `M-x highlight-current-line-minor-mode'. You may -enable the minor-mode automatically for (almost) all buffers by + D highlight-completion highlights completions in the minibuffer -home-end.el provides some useful bindings for Home and End keys: hit the -key once to go to the beginning/end of a line, hit it twice in a row to go -to the beginning/end of the window, three times in a row goes to the -beiginning/end of the buffer. To enable it, customize the variable -`home-end-enable'. + T highlight-current-line.el highlights the line the cursor is in. + Enable a buffer using the command `M-x highlight-current-line-minor-mode'. + - The functionality of highlight-current-line.el is now provided by + the GNU Emacs builtin hl-line-mode. -htmlize.el provides many M-x htmlize-* commands that turn files, -buffers, or region of font-lock colorised text into an HTML -representation. + D home-end.el provides some useful bindings for Home and End keys: hit the + key once to go to the beginning/end of a line, hit it twice in a row to go + to the beginning/end of the window, three times in a row goes to the + beiginning/end of the buffer. To enable it, customize the variable + `home-end-enable'. + + E htmlize.el provides many M-x htmlize-* commands that turn files, + buffers, or region of font-lock colorised text into an HTML + representation. initsplit.el allows you to split Emacs customizations (set via M-x customize) into different files, based on the names of the variables. To use it, just load the file in your .emacs: (load "initsplit"). -Note that that you *must* load each file that contains your various +Note that you *must* load each file that contains your various customizations from your .emacs. joc-toggle-buffer.el provides M-x joc-toggle-buffer, a command that can be @@ -173,6 +190,9 @@ maplev.el is a major mode for Maple. map-lines.el provides M-x map-lines, a command to iterate a given command over lines matching a regexp. + E markdown-mode.el provides support for editing Markdown files. It + provides syntax highlighting and basic element insertion commands. + marker-visit.el provides a simple way to navigate among marks in a buffer. All the marks you've left while editing a buffer serve as bread crumb trails of areas in the buffer you've edited. It is convenient to navigate @@ -180,18 +200,22 @@ back and forth among these marks in order. This file provides two methods to do just that, marker-visit-prev and marker-visit-next to visit the nearest mark in either direction. -matlab.el provides support for editing MATLAB dot-m files. It -automatically indents for block structures, line continuations (e.g., ...), -and comments. + D matlab.el provides support for editing MATLAB dot-m files. It + automatically indents for block structures, line continuations + (e.g., ...), and comments. -minibuf-electric.el eases minibuffer typing. When you type "//", it clears -the minibuffer back to the start, leaving only a single "/". When you type -a "~", it does the similar, leaving only "~/". This is nicer than having -to explicitly erase the contents of the minibuffer. + T minibuf-electric.el eases minibuffer typing. When you type "//", it + clears the minibuffer back to the start, leaving only a single "/". + When you type a "~", it does the similar, leaving only "~/". This is + nicer than having to explicitly erase the contents of the minibuffer. + - This is now provided by GNU Emacs, in rfn-eshadow.el. + Use this instead: + ;; (setq file-name-shadow-tty-properties '(invisible t)) + ;; (file-name-shadow-mode 1) -minibuffer-complete-cycle.el makes `minibuffer-complete' select each of the -possible completions in turn, inserting it into the minibuffer and -highlighting it in the *Completions* buffer. + D minibuffer-complete-cycle.el makes `minibuffer-complete' select + each of the possible completions in turn, inserting it into the + minibuffer and highlighting it in the *Completions* buffer. miniedit.el toggles minibuffer editing into a full text-mode buffer for easy multi-line editing of commands. @@ -205,8 +229,8 @@ of Mutt configuration files. To use it, either open a file named muttrc, or add a local variables section to the end of your file to specify the mode to be "muttrc". -obfusurl.el provides M-x obfuscate-url, a command that will obfuscate -an URL under the cursor. + D obfusurl.el provides M-x obfuscate-url, a command that will + obfuscate an URL under the cursor. pack-windows.el resizes all windows vertically to display as much information as possible with the command `M-x pack-windows'. @@ -217,8 +241,8 @@ Perl-mode or CPerl-mode buffers. Use (require 'perldoc) in your pp-c-l displays Control-l characters in a pretty way. -pod-mode.el provides support for editing Plain Old Documentation -(Perl documentation) files. It provides syntax highlighting. + E pod-mode.el provides support for editing Plain Old Documentation + (Perl documentation) files. It provides syntax highlighting. projects.el provides M-x add-project, remove-project and list-projects, and introduces the concept of PROJECT ROOTS that allow @@ -229,57 +253,59 @@ protbuf.el provides M-x protect-buffer-from-kill-mode and M-x protect-process-buffer-from-kill-mode, two commands to protect buffers from being accidentally killed. -protocols.el provides M-x protocols-lookup, to search for info in your -/etc/protocols. + D protocols.el provides M-x protocols-lookup, to search for info in + your /etc/protocols. -quack.el provides enhanced support for editing and running Scheme code -in both the major and minor modes. It also provides easy access to online -references for plt-scheme, books on Scheme, and SRFIs (Scheme Requests -For Implementation). Because it invasively changes scheme-mode, it is -not enabled by default. To enable it, customize the variable `quack-install'. + D quack.el provides enhanced support for editing and running Scheme code in + both the major and minor modes. It also provides easy access to online + references for plt-scheme, books on Scheme, and SRFIs (Scheme Requests + For Implementation). Because it invasively changes scheme-mode, it is not + enabled by default. To enable it, customize the variable `quack-install'. -rfcview.el formats IETF RFCs for improved readability. + E rfcview.el formats IETF RFCs for improved readability. -services.el provides M-x services-lookup, to search for info in your -/etc/services. + D services.el provides M-x services-lookup, to search for info in + your /etc/services. -session.el restores various variables (e.g., input histories) from your -last session. It also provides a menu containing recently changed/visited -files and restores the places (e.g., point) of such a file when you revisit -it. + E session.el restores various variables (e.g., input histories) from + your last session. It also provides a menu containing recently + changed/visited files and restores the places (e.g., point) of + such a file when you revisit it. setnu.el provides M-x setnu-mode, a vi-style line number mode. -shell-command.el is an an enhancement for shell-command, enabling +shell-command.el is an enhancement for shell-command, enabling tab-completion of commands and dir/filenames within the shell-command input context. -show-wspace.el is a minor mode to highlight whitespaces of various kinds. + D show-wspace.el is a minor mode to highlight whitespaces of various kinds. slang-mode.el is a major mode for editing S-Lang files. silly-mail.el provides M-x add-sm-* commands to add various headers to your email messages. -sys-apropos.el provides M-x sys-apropos, an interface to the "apropos" -command. + T sys-apropos.el provides M-x sys-apropos, an interface to the + "apropos" command. + - This functionality is provided by M-x man -tabbar.el displays buffers as tabs in the header line, and provides commands -to switch between them. You can bind keys to M-x tabbar-forward and M-x -tabbar-backward, and use these to quickly switch between buffers. By default, -tabbar-mode will group buffers into various groups, and only display one group -at a time on the tabbar; you can change this by customizing tabbar. + E tabbar.el displays buffers as tabs in the header line, and + provides commands to switch between them. You can bind keys to + M-x tabbar-forward and M-x tabbar-backward, and use these to + quickly switch between buffers. By default, tabbar-mode will + group buffers into various groups, and only display one group at a + time on the tabbar; you can change this by customizing tabbar. -tail.el provides the commands M-x tail-file and M-x tail-command, to -follow the output of a command (or to follow a log file) without using -any terminals. + D tail.el provides the commands M-x tail-file and M-x tail-command, + to follow the output of a command (or to follow a log file) + without using any terminals. tc.el provides a nice way to quote cited texts, with proper filling and attribution. You can use it for instance by setting the cite function to 'trivial-cite: (setq message-cite-function 'trivial-cite). -thinks.el provides cartoon-like think bubbles . o O ( like this ). -Look for M-x thinks* commands. + D thinks.el provides cartoon-like think bubbles . o O ( like this ). + Look for M-x thinks* commands. tlc.el is a major mode for editing Target Language Compiler scripts. It automatically indents the programming constructs. @@ -300,11 +326,11 @@ interest: twiddle-start and twiddle-compile. under.el provides M-x underline-region, to underline a bit of text with ^ characters like this. ^^^^^^^^^ -upstart-mode.el is a major-mode for editing .upstart files. + D upstart-mode.el is a major-mode for editing .upstart files. xrdb-mode.el provides the xrdb-mode major mode, to help you editing X resource database files. To use it, simple open a file named .Xdefaults, .Xenvironment, .Xresources or *.ad after having enabled it by customising `xrdb-mode-setup-auto-mode-alist'. - -- Peter S Galbraith <psg@debian.org>, Sun, 6 Nov 2016 14:50:31 -0500 + -- Nicholas D Steeves <nsteeves@gmail.com>, Sat, 21 Jul 2018 23:51:50 -0400 diff --git a/debian/changelog b/debian/changelog index fb1b3ea..bac3fe2 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,80 @@ +emacs-goodies-el (39.0) unstable; urgency=medium + + [ Nicholas D Steeves ] + * Drop highlight-current-line.el and highlight-beyond-fill-column.el + because both are unmaintained (Closes: #902751). + - The functionality of highlight-current-line.el is now provided by + the GNU Emacs builtin hl-line-mode. + - The functionality of highlight-beyond-fill-column is now provided by + the GNU Emacs builtin whitespace-line-column. + * Drop bm.el, which was elpafied (Closes: #902837). + * Drop sys-apropos.el, which has no upstream (Closes: #553401). + - The functionality of sys-apropos is provided by M-x man. + * Drop session.el, which will be elpafied (See Bug #902564). + * Drop framepop.el, which has no upstream (Closes: #902750). + * Drop graphviz-dot-mode.el, which was elpafied (See Bug #902604). + * Drop rfcview.el, whose elpafication is planned (See Bug #903703). + * Drop tabbar.el, which was elpafied (See Bug #437114). + * Drop auto-fill-inhibit.el, which has no upstream (Closes: #496128). + * Drop minibuffer-complete-cycle.el, which has few users (Closes: #845494). + * Drop folding.el, whose elpafication is planned (See Bug #639221). + * Drop eproject.el and eproject-extras.el, whose elpafication is planned + (See Bug #904157). + * Drop upstart-mode.el due to the likelyhood of its disuse during + buster's lifecycle (Closes: #902948). + * Drop services.el and protocols.el, which have few users (Closes: #904167). + * Drop quack.el, because SLIME, Geiser, and racket-mode are all good + alternatives and are already elpafied (Closes: #904169). + * Drop minibuf-electric.el, whose functionality is provided by GNU Emacs + builtin rfn-eshadow.el. + * Drop matlab.el (Closes: #557932). RFP bug for elpafication is #902739. + * Drop obfusurl.el, because it has very few downloads on MELPA. + * Drop thinks.el, because it has very few downloads on MELPA. + * Drop pod-mode.el, which may be elpafied (See Bug #672180). + + -- David Bremner <bremner@debian.org> Mon, 23 Jul 2018 16:52:18 +0800 + +emacs-goodies-el (38.0) experimental; urgency=medium + + [ Nicholas D Steeves ] + * Drop elpafied pkgs from goodies customisation group. + * Add elpafied packages to emacs-goodies-el's Recommends. + * Drop highlight-completion.el (Closes: #581238). + * Add debian/NEWS, to provide a short introduction to how this + package is changing, particularly as this will affect xemacs users. + * Document the state of emacs-goodies-el's subpackages in README.Debian. + eg: Elpafied, Dropped, or Transitioned to a suitable replacement. + * Drop browse-kill-ring.el (it was elpafied). + * Drop home-end.el, which is dead upstream (Closes: #759721). + * Drop htmlize.el (it was elpafied). + * Drop diminish.el, which was elpafied (Closes: #850151). + * Drop csv-mode.el, which was elpafied (Closes: #495989). + * Drop show-wspace.el, which is obsolete and dead upstream. + See Bug #590994 for more information. + * Fix typos in README.Debian. + * Drop filladapt.el, which is dead upstream (Closes: #552164). + * Drop tail.el, which is dead upstream (Closes: #584305). + + [ David Bremner ] + * Patch emacs-goodies-el.texinfo. Bug fix: "emacs-goodies-el info manual + ccmode xref", thanks to Kevin Ryde (Closes: #591432). Note that this + file will eventually go away. + + [ Sean Whitton ] + * debian/NEWS: rewrite to exclude all details not relevant to end users. + + -- David Bremner <bremner@debian.org> Sat, 30 Jun 2018 07:36:47 -0300 + +emacs-goodies-el (37.0) experimental; urgency=medium + + * Adopt by emacsen-team + * Don't generate binary-packages debian-el and dpkg-dev-el from this + source package (now generated by source packages of the same name). + * Update maintainer scripts for unversioned emacs: byte-compile flavour + emacs, just don't symlink. + + -- David Bremner <bremner@debian.org> Sun, 24 Jun 2018 13:08:55 -0300 + emacs-goodies-el (36.4) unstable; urgency=medium * Move to salsa.debian.org; update Vcs-Browser and Vcs-Git in diff --git a/debian/control b/debian/control index 2f8ad18..bf2fbf8 100644 --- a/debian/control +++ b/debian/control @@ -1,17 +1,39 @@ Source: emacs-goodies-el Section: editors Priority: optional -Maintainer: Peter S Galbraith <psg@debian.org> -Uploaders: Julian Gilbey <jdg@debian.org> +Maintainer: Debian Emacsen team <debian-emacsen@lists.debian.org> +Uploaders: David Bremner <bremner@debian.org> + , Nicholas D Steeves <nsteeves@gmail.com> Build-Depends: debhelper (>= 9), quilt, texinfo Standards-Version: 3.9.5 -Vcs-Browser: https://salsa.debian.org/debian/emacs-goodies-el -Vcs-Git: https://salsa.debian.org/debian/emacs-goodies-el.git +Vcs-Browser: https://salsa.debian.org/emacsen-team/emacs-goodies-el +Vcs-Git: https://salsa.debian.org/emacsen-team/emacs-goodies-el.git Package: emacs-goodies-el Architecture: all Depends: emacs | emacsen, emacsen-common (>= 2.0.8), bash (>= 2.05a) | bash-static, ${misc:Depends}, dpkg (>= 1.15.4) | install-info Recommends: wget, perl-doc + , elpa-browse-kill-ring + , elpa-diminish + , elpa-htmlize + , elpa-markdown-mode + , elpa-debian-el + , elpa-dpkg-dev-el + , elpa-graphviz-dot-mode +# NEED SPONSORSHIP +# , elpa-bm (git@salsa.debian.org:emacsen-team/bm-el.git) -- 11876 downloads: q83 +# , elpa-tabbar (Bug #437114) -- 25799 downloads: q88 +# , elpa-pod-mode (git@salsa.debian.org:emacsen-team/emacs-pod-mode.git) +# +# TODO bugs tagged elpafy and newcomer +# If a newcomer does not step forward, +# these should be elpafied by the team before the buster freeze. +# , elpa-session (Bug #902564) -- 42498 downloads: q91 +# +# STALLED waiting for upstream or some other reason +# , elpa-folding (Bug #639221) -- 3236 downloads: q70 +# , elpa-eproject (Bug #904157) -- 5851 downloads: q76 +# , elpa-rfcview (Bug #903703) Replaces: emacs-goodies-extra-el Provides: emacs-goodies-extra-el Description: Miscellaneous add-ons for Emacs @@ -20,35 +42,21 @@ Description: Miscellaneous add-ons for Emacs all - edit all lines matching a given regexp; apache-mode - major mode for editing Apache configuration files; ascii - ASCII code display for character under point; - auto-fill-inhibit - finer grained control over auto-fill-mode; bar-cursor - change your cursor to a bar instead of a block; - bm - visible bookmarks in buffers; boxquote - quote texts in nice boxes; browse-huge-tar - browse tar files without reading them into memory; - browse-kill-ring - browse, search, modify the kill ring; button-lock - clickable text defined by regular expression; clipper - save strings of data for further use; coffee - now Emacs can even brew coffee; color-theme - changes the colors used within Emacs; - csv-mode - major mode for comma-separated value files; ctypes - enhanced Font lock support for custom defined types; dedicated - make a window dedicated to a single buffer; df - display in the mode line space left on devices; - diminish - shorten or erase modeline presence of minor modes; dir-locals - provides directory-wide local variables; edit-env - display, edit, delete and add environment variables; egocentric - highlight your name inside emacs buffers; - eproject - assign files to projects, programatically ff-paths - $PATH-like searching in C-x C-f; - filladapt - enhances Emacs's built-in adaptive fill; floatbg - slowly modify background color; - framepop - display temporary buffers in a dedicated frame; - graphviz-dot-mode.el - mode for the dot-language used by graphviz (att). - highlight-beyond-fill-column - highlight lines that are too long; - highlight-completion - highlight completions in the minibuffer; - highlight-current-line - highlight line where the cursor is; - home-end - alternative Home and End commands; - htmlize - HTML-ize font-lock buffers; initsplit - split customizations into different files; joc-toggle-buffer - fast switching between two buffers; joc-toggle-case - a set of functions to toggle the case of characters; @@ -58,41 +66,25 @@ Description: Miscellaneous add-ons for Emacs maplev - major mode for Maple; map-lines - map a command over lines matching a regexp; marker-visit - navigate through a buffer's marks in order; - matlab - major mode for MatLab dot-m files; - minibuf-electric - electric minibuffer behavior from XEmacs; - minibuffer-complete-cycle - cycle through the *Completions* buffer; miniedit - enhanced editing for minibuffer fields; mutt-alias - lookup and insert the expansion of mutt mail aliases; muttrc-mode - major mode for editing Mutt config files; - obfusurl - obfuscate an URL; pack-windows - resize all windows to display as much info as possible; perldoc - show help for Perl functions and modules. (Depends on perl-doc); - pod-mode - major mode for editing POD files; pp-c-l - display Control-l characters in a pretty way; projects - create project-based meaningful buffer names; prot-buf - protect buffers from accidental killing; - protocols - perform lookups in /etc/protocols; - quack - enhanced support for editing and running Scheme code; - rfcview - view IETF RFCs with readability-improved formatting; - services - perform lookups in /etc/services; - session - saves settings between Emacs invocations and visits to a file; setnu - setnu-mode, a vi-style line number mode; shell-command - enables tab-completion for shell-command; - show-wspace - highlight whitespaces of various kinds; silly-mail - generate bozotic mail headers; slang-mode.el - a major-mode for editing S-Lang scripts; - sys-apropos - interface for the *nix apropos command; - tabbar - Display a tab bar in the header line; - tail - "tail -f" a file or a command from within Emacs; tc - cite text with proper filling; - thinks - quote texts in cartoon-like think bubbles; tlc - major mode for editing Target Language Compiler scripts; tld - explain top-level domain names; todoo - major mode for editing TODO files; toggle-option - easily toggle frequently toggled options; twiddle - mode line hacks to keep you awake; under - underline a region with ^ characters; - upstart-mode - mode for editing upstart files; xrdb-mode - mode for editing X resource database files. . See /usr/share/doc/emacs-goodies-el/README.Debian.gz for a short @@ -109,44 +101,3 @@ Description: Emacs wrappers for the commands in devscripts pbuilder - wrappers around pbuilder . See /usr/share/doc/devscripts-el/README.Debian for a short description. - -Package: debian-el -Architecture: all -Pre-Depends: xz-utils -Depends: emacs | emacsen, emacsen-common (>= 2.0.8), reportbug (>= 4.12), ${misc:Depends}, dpkg (>= 1.15.4) | install-info, bzip2, file -Recommends: wget, dlocate, groff-base -Suggests: gnus -Replaces: debbugs-el, debview -Provides: debbugs-el, debview -Section: utils -Description: Emacs helpers specific to Debian users - This package contains: - . - apt-sources - major mode for editing Debian sources.list files; - apt-utils - interface to APT (Debian package management); - debian-bug - an Emacs command to submit a bug report; - deb-view - view contents of Debian package, similarly to tar-mode; - gnus-BTS - provides buttons for bug numbers seen in Gnus messages; - preseed - major mode for editing debian-installer preseed files. - . - See /usr/share/doc/debian-el/README.Debian for a short description of - all files, or the Info node `debian-el' for details. - -Package: dpkg-dev-el -Architecture: all -Depends: emacs | emacsen, emacsen-common (>= 2.0.8), debian-el (>= 33.2), ${misc:Depends} -Suggests: dpkg-dev -Recommends: wget -Conflicts: dpkg-dev (<< 1.7.2) -Section: utils -Description: Emacs helpers specific to Debian development - This package contains: - . - debian-bts-control - builds control@bugs.debian.org email messages; - debian-changelog-mode - a helper mode for Debian changelogs; - debian-control-mode - a helper mode for debian/control files; - debian-copyright - major mode for Debian package copyright files; - readme-debian - major mode for editing README.Debian files. - . - See /usr/share/doc/dpkg-dev-el/README.Debian for a short description of - all files. diff --git a/debian/debian-el.README.Debian b/debian/debian-el.README.Debian deleted file mode 100644 index 6600f3f..0000000 --- a/debian/debian-el.README.Debian +++ /dev/null @@ -1,35 +0,0 @@ - The file you're currently reading is mostly meant as an introductory -starter for the various goodies included in debian-el. Consult the Info -node `debian-el' for more complete information. - -To customize all files in this package, use: - - M-x customize-group [RET] debian-el [RET] - - -Introduction to files in debian-el ----------------------------------- - -apt-sources.el provides apt-sources-mode, a major mode to help the -edition of /etc/apt/sources.list (and suchlike) files. To use it, -either open a file named sources.list and it will be autoloaded, or -add a local variables section to the end of your file to specify the -mode to be "apt-sources". - -apt-utils.el provides an interface to APT. Start things off using e.g.: -M-x apt-utils-show-package RET emacs21 RET - -debian-bug.el provides M-x debian-bug (and variants), to submit bugs -to the Debian bug tracking system. - -deb-view.el presents the contents of debian package archive files for -viewing (similar to tar-mode). - -gnus-BTS.el makes bug numbers clickable in messages viewed in Gnus. -It expects to see bug references in the form of (for example): -"#48273", "closes: 238742" or similar. To use, add the following to -your .gnus: "(require 'gnus-BTS)". - -preseed.el is a major mode for editing debian-installer preseed files. - - -- Peter S Galbraith <psg@debian.org>, Mon Oct 24 21:10:25 2005 diff --git a/debian/debian-el.copyright b/debian/debian-el.copyright deleted file mode 100644 index a68c893..0000000 --- a/debian/debian-el.copyright +++ /dev/null @@ -1,66 +0,0 @@ -Format: http://www.debian.org/doc/packaging-manuals/copyright-format/1.0/ -Comment: - This collection of files was assembled by Roland Mas <lolando@debian.org> - from various messages posted on the gnu.emacs.sources newsgroup, as well as - from various collections of Emacs Lisp files found on the web. Some - authors contacted Roland directly, some users sent me the files by email. - Most of them are covered by the GNU GPL, but the individual licences can - vary. - -Files: * -Copyright: 2000-2003 Roland Mas <lolando@debian.org>, - 2005-2014 Peter S Galbraith <psg@debian.org> - 2014 Julian Gilbey <jdg@debian.org> -License: GPL-2+ -Comment: - This covers the debian/* files, and various other glue files written - specificially for this package. - -Files: elisp/debian-el/apt-sources.el -Copyright: 2001-2002, Dr. Rafael Sepúlveda <drs@gnulinux.org.mx> -License: GPL-2+ - -Files: elisp/debian-el/apt-utils.el -Copyright: 2002, 03 Matthew P. Hodges -License: GPL-2+ - -Files: elisp/debian-el/debian-bug.el -Copyright: 1998, 1999 Free Software Foundation, Inc., - 2001, 2002 Peter S Galbraith <psg@debian.org> -License: GPL-2+ -Comment: - Author (Up to version 1.7): Francesco Potortì <pot@gnu.org> - Maintainer from version 1.8 onwards: Peter S Galbraith <psg@debian.org> - -Files: elisp/debian-el/deb-view.el -Copyright: Rick Macdonald <rickm@vsl.com> -License: GPL-2+ - -Files: elisp/debian-el/gnus-BTS.el -Copyright: 2001 Andreas Fuchs <asf@acm.org> -License: GPL-2+ - -Files: elisp/debian-el/preseed.el -Copyright: 2004 W. Borgert <debacle@debian.org> -License: GPL-2+ - -License: GPL-2+ - This program 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. - . - This program 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 this package; if not, write to the Free - Software Foundation, Inc., 51 Franklin St, Fifth Floor, - Boston, MA 02110-1301 USA - . - On Debian systems, the full text of the GNU General Public - License version 2 can be found in the file - `/usr/share/common-licenses/GPL-2'. diff --git a/debian/debian-el.emacsen-compat b/debian/debian-el.emacsen-compat deleted file mode 100644 index 573541a..0000000 --- a/debian/debian-el.emacsen-compat +++ /dev/null @@ -1 +0,0 @@ -0 diff --git a/debian/debian-el.emacsen-install.in b/debian/debian-el.emacsen-install.in deleted file mode 100644 index e3f7691..0000000 --- a/debian/debian-el.emacsen-install.in +++ /dev/null @@ -1,35 +0,0 @@ -#! /bin/bash -e -# /usr/lib/emacsen-common/packages/install/debian-el - -# Written by Jim Van Zandt <jrv@vanzandt.mv.com>, borrowing heavily -# from the install scripts for gettext by Santiago Vila -# <sanvila@ctv.es> and octave by Dirk Eddelbuettel <edd@debian.org>. -# -# Patched by Roland Mas <lolando@debian.org> to add support for lists of -# flavor-dependently included/excluded files and by Peter S Galbraith -# <psg@debian.org> to add a STAMPFILE (to only byte-compile once) and -# APPEND_LOAD_PATH ton augment the load-path for byte-compilation. - -FLAVOR=$1 -PACKAGE=debian-el -STAMPFILE=debian-el.elc - -# INCLUDED_emacs20="" -# INCLUDED_emacs21="" -# INCLUDED_xemacs21="" -# INCLUDED_emacs_snapshot="" - -# EXCLUDED_emacs20="" -# EXCLUDED_emacs21="" -# EXCLUDED_xemacs21="" -# EXCLUDED_emacs_snapshot="" - -# Don't byte-compile gnus-BTS.el since it uses gnus macros and will break -# if compiled and then used with different versions of gnus (e.g. as -# shipped wth Emacs vs package separately). -SOURCEONLY_emacs20="gnus-BTS.el" -SOURCEONLY_emacs21="gnus-BTS.el" -SOURCEONLY_emacs22="gnus-BTS.el" -SOURCEONLY_emacs23="gnus-BTS.el" -SOURCEONLY_xemacs21="gnus-BTS.el" -SOURCEONLY_emacs_snapshot="gnus-BTS.el" diff --git a/debian/debian-el.emacsen-remove.in b/debian/debian-el.emacsen-remove.in deleted file mode 100644 index efd7e44..0000000 --- a/debian/debian-el.emacsen-remove.in +++ /dev/null @@ -1,5 +0,0 @@ -#!/bin/sh -e -# /usr/lib/emacsen-common/packages/remove/debian-el - -FLAVOR=$1 -PACKAGE=debian-el diff --git a/debian/debian-el.emacsen-startup b/debian/debian-el.emacsen-startup deleted file mode 100644 index 51fa4d3..0000000 --- a/debian/debian-el.emacsen-startup +++ /dev/null @@ -1,18 +0,0 @@ -;; -*-emacs-lisp-*- -;; -;; Emacs startup file for the Debian GNU/Linux devscripts-el package - -(cond - ((not (file-exists-p "/usr/share/emacs/site-lisp/debian-el")) - (message "Package debian-el removed but not purged. Skipping setup.")) - ((not (file-exists-p (concat "/usr/share/" - (symbol-name debian-emacs-flavor) - "/site-lisp/debian-el/preseed.elc"))) - (message "Package debian-el not fully installed. Skipping setup.")) - (t - (debian-pkg-add-load-path-item - (concat "/usr/share/" - (symbol-name debian-emacs-flavor) - "/site-lisp/debian-el")) - - (require 'debian-el))) diff --git a/debian/debian-el.info b/debian/debian-el.info deleted file mode 100644 index 14a3d8a..0000000 --- a/debian/debian-el.info +++ /dev/null @@ -1 +0,0 @@ -info/debian-el diff --git a/debian/debian-el.install b/debian/debian-el.install deleted file mode 100644 index d82ee64..0000000 --- a/debian/debian-el.install +++ /dev/null @@ -1,8 +0,0 @@ -elisp/debian-el/apt-sources.el /usr/share/emacs/site-lisp/debian-el/ -elisp/debian-el/apt-utils.el /usr/share/emacs/site-lisp/debian-el/ -elisp/debian-el/deb-view.el /usr/share/emacs/site-lisp/debian-el/ -elisp/debian-el/debian-bug.el /usr/share/emacs/site-lisp/debian-el/ -elisp/debian-el/debian-el.el /usr/share/emacs/site-lisp/debian-el/ -elisp/debian-el/debian-el-loaddefs.el /usr/share/emacs/site-lisp/debian-el/ -elisp/debian-el/gnus-BTS.el /usr/share/emacs/site-lisp/debian-el/ -elisp/debian-el/preseed.el /usr/share/emacs/site-lisp/debian-el/ diff --git a/debian/debian-el.postinst b/debian/debian-el.postinst deleted file mode 100644 index 5ca4e57..0000000 --- a/debian/debian-el.postinst +++ /dev/null @@ -1,21 +0,0 @@ -#!/bin/sh -# Remove old /etc/50debian-el file that may still be on systems from -# previous versions of debian-el -set -e - -case "$1" in - configure) - - if [ -f /etc/emacs/site-start.d/50debian-el ]; then - rm -f /etc/emacs/site-start.d/50debian-el - fi - ;; - - abort-upgrade|abort-remove|abort-deconfigure) - ;; - *) - echo "postinst called with unknown argument \`$1'" >&2 - ;; -esac - -#DEBHELPER# diff --git a/debian/dpkg-dev-el.README.Debian b/debian/dpkg-dev-el.README.Debian deleted file mode 100644 index 1620bc6..0000000 --- a/debian/dpkg-dev-el.README.Debian +++ /dev/null @@ -1,35 +0,0 @@ - This file is an introductory starter for the various goodies included in -dpkg-dev-el. It does not intend to replace reading the documentation that -is made available in the files themselves (or not available at all, except -insofar as code is self-documenting). - -To customize all files in this package, use: - - M-x customize-group [RET] dpkg-dev-el [RET] - -Introduction to files in dpkg-dev-el ------------------------------------- - -debian-bts-control.el provides an interface for composing email messages to -the Debian BTS control interface (control@bugs.debian.org). Tab completions -works for all possible commands and their options. - -debian-changelog-mode.el provides a mode for editing debian/changelog -files. This mode adds colouring, a few commands to manipulate -changelog entries and bug reports, and a nice filling function. This -mode can also be used to add colours to buffers visiting the -changelogs in /usr/share/doc/<package>/changelog.Debian files. - -debian-copyright.el provides a mode for editing debian/copyright files. -This mode adds a bit of colouring and if `goto-addr' is loaded, it will -make the URLs clickable. - -debian-control-mode.el provides a mode for editing debian/control -files. This mode adds a bit of colouring, a working filling function -(bound to "M-q" by default), tab-completion for adding fields (bound -to "C-c C-a" by default), and viewing bugs (bound to "C-c C-b"). - -readme-debian.el provides readme-debian-mode, a major mode to -highlight README.Debian files. - - -- Peter S Galbraith <psg@debian.org>, Mon Oct 24 21:08:04 2005 diff --git a/debian/dpkg-dev-el.copyright b/debian/dpkg-dev-el.copyright deleted file mode 100644 index a01ede2..0000000 --- a/debian/dpkg-dev-el.copyright +++ /dev/null @@ -1,60 +0,0 @@ -Format: http://www.debian.org/doc/packaging-manuals/copyright-format/1.0/ -Comment: - This collection of files was assembled by Roland Mas <lolando@debian.org> - from various messages posted on the gnu.emacs.sources newsgroup, as well as - from various collections of Emacs Lisp files found on the web. Some - authors contacted Roland directly, some users sent me the files by email. - Most of them are covered by the GNU GPL, but the individual licences can - vary. - -Files: * -Copyright: 2000-2003 Roland Mas <lolando@debian.org>, - 2005-2014 Peter S Galbraith <psg@debian.org> - 2014 Julian Gilbey <jdg@debian.org> -License: GPL-2+ -Comment: - This covers the debian/* files, and various other glue files written - specificially for this package. - -Files: elisp/dpkg-dev-el/debian-bts-control.el -Copyright: 2003 Peter S Galbraith -License: GPL-2+ - -Files: elisp/dpkg-dev-el/debian-changelog-mode.el -Copyright: 1996 Ian Jackson, 1997 Klee Dienes, 1999 Chris Waters, - 2000 Peter S Galbraith -License: GPL-2+ - -Files: elisp/dpkg-dev-el/debian-control-mode.el -Copyright: 2001 Free Software Foundation, Inc. -License: GPL-2+ -Comment: Author: Colin Walters <walters@debian.org> - -Files: elisp/dpkg-dev-el/debian-copyright.el -Copyright: 2002, 2003 Junichi Uekawa <dancer@netfort.gr.jp> -License: GPL-2+ - -Files: elisp/dpkg-dev-el/readme-debian.el -Copyright: 2002 Junichi Uekawa <dancer@netfort.gr.jp> -License: GPL-2+ - -License: GPL-2+ - This program 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. - . - This program 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 this package; if not, write to the Free - Software Foundation, Inc., 51 Franklin St, Fifth Floor, - Boston, MA 02110-1301 USA - . - On Debian systems, the full text of the GNU General Public - License version 2 can be found in the file - `/usr/share/common-licenses/GPL-2'. diff --git a/debian/dpkg-dev-el.emacsen-compat b/debian/dpkg-dev-el.emacsen-compat deleted file mode 100644 index 573541a..0000000 --- a/debian/dpkg-dev-el.emacsen-compat +++ /dev/null @@ -1 +0,0 @@ -0 diff --git a/debian/dpkg-dev-el.emacsen-install.in b/debian/dpkg-dev-el.emacsen-install.in deleted file mode 100644 index 94f087c..0000000 --- a/debian/dpkg-dev-el.emacsen-install.in +++ /dev/null @@ -1,23 +0,0 @@ -#! /bin/bash -e -# /usr/lib/emacsen-common/packages/install/dpkg-dev-el - -# Written by Jim Van Zandt <jrv@vanzandt.mv.com>, borrowing heavily -# from the install scripts for gettext by Santiago Vila -# <sanvila@ctv.es> and octave by Dirk Eddelbuettel <edd@debian.org>. -# -# Patched by Roland Mas <lolando@debian.org> to add support for lists -# of flavor-dependently included/excluded files - -FLAVOR=$1 -STAMPFILE=debian-changelog-mode.elc -PACKAGE=dpkg-dev-el - -APPEND_LOAD_PATH="'(\"/usr/share/emacs/site-lisp/debian-el/\")" - -# INCLUDED_emacs20="" -# INCLUDED_emacs21="" -# INCLUDED_xemacs21="" - -# EXCLUDED_emacs20="" -# EXCLUDED_emacs21="" -# EXCLUDED_xemacs21="" diff --git a/debian/dpkg-dev-el.emacsen-remove.in b/debian/dpkg-dev-el.emacsen-remove.in deleted file mode 100644 index 000fa24..0000000 --- a/debian/dpkg-dev-el.emacsen-remove.in +++ /dev/null @@ -1,5 +0,0 @@ -#!/bin/sh -e -# /usr/lib/emacsen-common/packages/remove/dpkg-dev-el - -FLAVOR=$1 -PACKAGE=dpkg-dev-el diff --git a/debian/dpkg-dev-el.emacsen-startup b/debian/dpkg-dev-el.emacsen-startup deleted file mode 100644 index 4483b8e..0000000 --- a/debian/dpkg-dev-el.emacsen-startup +++ /dev/null @@ -1,18 +0,0 @@ -;; -*-emacs-lisp-*- -;; -;; Emacs startup file for the Debian GNU/Linux dpkg-dev-el package - -(cond - ((not (file-exists-p "/usr/share/emacs/site-lisp/dpkg-dev-el")) - (message "Package dpkg-dev-el removed but not purged. Skipping setup.")) - ((not (file-exists-p (concat "/usr/share/" - (symbol-name debian-emacs-flavor) - "/site-lisp/dpkg-dev-el/readme-debian.elc"))) - (message "Package dpkg-dev-el not fully installed. Skipping setup.")) - (t - (debian-pkg-add-load-path-item - (concat "/usr/share/" - (symbol-name debian-emacs-flavor) - "/site-lisp/dpkg-dev-el")) - - (require 'dpkg-dev-el))) diff --git a/debian/dpkg-dev-el.install b/debian/dpkg-dev-el.install deleted file mode 100644 index e49cf6c..0000000 --- a/debian/dpkg-dev-el.install +++ /dev/null @@ -1,7 +0,0 @@ -elisp/dpkg-dev-el/debian-bts-control.el /usr/share/emacs/site-lisp/dpkg-dev-el/ -elisp/dpkg-dev-el/debian-changelog-mode.el /usr/share/emacs/site-lisp/dpkg-dev-el/ -elisp/dpkg-dev-el/debian-control-mode.el /usr/share/emacs/site-lisp/dpkg-dev-el/ -elisp/dpkg-dev-el/debian-copyright.el /usr/share/emacs/site-lisp/dpkg-dev-el/ -elisp/dpkg-dev-el/dpkg-dev-el-loaddefs.el /usr/share/emacs/site-lisp/dpkg-dev-el/ -elisp/dpkg-dev-el/dpkg-dev-el.el /usr/share/emacs/site-lisp/dpkg-dev-el/ -elisp/dpkg-dev-el/readme-debian.el /usr/share/emacs/site-lisp/dpkg-dev-el/ diff --git a/debian/emacs-goodies-el.copyright b/debian/emacs-goodies-el.copyright index 701dd46..7edd7b7 100644 --- a/debian/emacs-goodies-el.copyright +++ b/debian/emacs-goodies-el.copyright @@ -36,53 +36,10 @@ Files: elisp/emacs-goodies-el/ascii.el Copyright: 1999, 2000, 2001 Vinicius Jose Latorre License: GPL-2+ -Files: elisp/emacs-goodies-el/auto-fill-inhibit.el -Copyright: 2001 Michael Weber <michaelw@debian.org> -License: GPL-2-no-virus - This program is free software; you can redistribute it and/or - modify it under the terms of the GNU General Public License - version 2 as published by the Free Software Foundation. - . - This program 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 this package; if not, write to the Free - Software Foundation, Inc., 51 Franklin St, Fifth Floor, - Boston, MA 02110-1301 USA - . - On Debian systems, the full text of the GNU General Public - License version 2 can be found in the file - `/usr/share/common-licenses/GPL-2'. - . - NO-VIRUS CLAUSE: - The intent of this license is to protect free redistribution and - reuse of the source of the licensed distribution, not to prejudice - the authorship rights of programmers of other code to control - their original inventions. - . - No portion of this license is to be interpreted as forbidding the - reuse of this code or its constituent parts, algorithms, or - inventions in commercial products. - . - Nor shall such inclusion be construed to require the GPLing or - disclosure of any portions of said commercial products other than - those falling under the copyright of the licensed distribution. - Files: elisp/emacs-goodies-el/bar-cursor.el Copyright: 2001 by Joseph L. Casadonte Jr. <emacs@northbound-train.com> License: GPL-2+ -Files: elisp/emacs-goodies-el/bm.el -Copyright: 2000-2010 Jo Odland <jo.odland(at)gmail.com>, - Portions Copyright 2002 by Ben Key, - Updated by Ben Key <bkey1(at)tampabay.rr.com> on 2002-12-05 - to add support for XEmacs -License: GPL-2+ - Files: elisp/emacs-goodies-el/boxquote.el Copyright: 1999-2009 by Dave Pearson <davep@davep.org> License: GPL-2+ @@ -91,10 +48,6 @@ Files: elisp/emacs-goodies-el/browse-huge-tar.el Copyright: Gareth Owen 1999 License: GPL-2+ -Files: elisp/emacs-goodies-el/browse-kill-ring.el -Copyright: 2001 Colin Walters -License: GPL-2+ - Files: elisp/emacs-goodies-el/button-lock.el Copyright: 2011 D Roland Walker License: GPL-2+ @@ -134,12 +87,6 @@ Files: elisp/emacs-goodies-el/color-theme_selfdefcustom.el Copyright: 2005 Peter S Galbraith <psg@debian.org> License: GPL-2+ -Files: elisp/emacs-goodies-el/csv-mode.el -Copyright: 2003, 2004 Francis J. Wright <F.J.Wright at qmul.ac.uk> -License: GPL-2+ -Comment: - http://centaur.maths.qmul.ac.uk/Emacs/ - Files: elisp/emacs-goodies-el/ctypes.el Copyright: 1997, 1999 Anders Lindgren <andersl@andersl.com> License: GPL-2+ @@ -153,13 +100,6 @@ Copyright: 1999 by Association April License: GPL-2+ Comment: Author: Benjamin Drieu <bdrieu@april.org> -Files: elisp/emacs-goodies-el/diminish.el -Copyright: 1998 Free Software Foundation, Inc. -License: GPL-2+ -Comment: - Author: Will Mengarini <seldon@eskimo.com> - URL: <http://www.eskimo.com/~seldon> - Files: elisp/emacs-goodies-el/dir-locals.el Copyright: 2005, 2006 Free Software Foundation, Inc. License: GPL-2+ @@ -175,10 +115,6 @@ Files: elisp/emacs-goodies-el/egocentric.el Copyright: 2001 Benjamin Drieu <bdrieu@april.org> License: GPL-2+ -Files: elisp/emacs-goodies-el/eproject.el -Copyright: 2008, 2009 Jonathan Rockway <jon@jrock.us> -License: GPL-2+ - Files: elisp/emacs-goodies-el/eproject-extras.el Copyright: 2009 Jonathan Rockway <jon@jrock.us> License: GPL-3+ @@ -188,62 +124,10 @@ Copyright: 1994-2001 Peter S. Galbraith <GalbraithP@dfo-mpo.gc.ca>, <psg@debian.org> License: GPL-2+ -Files: elisp/emacs-goodies-el/filladapt.el -Copyright: 1989, 1995-1998 Kyle E. Jones -License: GPL-2+ - Files: elisp/emacs-goodies-el/floatbg.el Copyright: 2001 John Paul Wallington <jpw@shootybangbang.com> License: GPL-2+ -Files: elisp/emacs-goodies-el/folding.el -Copyright: 1994-2004 Jari Aalto, Anders Lindgren, All rights reserved. - 1992, 1993 Jamie Lokier, All rights reserved. -License: GPL-2+ -Comment: - http://cvs.sourceforge.net/viewcvs.py/tiny-tools/tiny-tools/lisp/other/ - -Files: elisp/emacs-goodies-el/framepop.el -Copyright: 1993, 1995 Free Software Foundation, Inc. - 2003 Peter S Galbraith -License: GPL-2+ -Comment: - Author: David Smith <D.M.Smith@lancaster.ac.uk> - Maintainer: Peter S Galbraith <psg@debian.org> - -Files: elisp/emacs-goodies-el/graphviz-dot-mode.el -Copyright: 2002 - 2005 Pieter Pareit <pieter.pareit@scarlet.be> -License: GPL-2+ -Comment: - Authors: Pieter Pareit <pieter.pareit@scarlet.be> - Rubens Ramos <rubensr AT users.sourceforge.net> - Maintainer: Pieter Pareit <pieter.pareit@planetinternet.be> - -Files: elisp/emacs-goodies-el/highlight-beyond-fill-column.el -Copyright: 1985, 1986, 1987, 1992 Free Software Foundation, Inc. -License: GPL-2+ -Comment: - Author: Sandip Chitale (sandip.chitale@blazesoft.com) - -Files: elisp/emacs-goodies-el/highlight-completion.el -Copyright: 1991-1996 Mark Haiman, Nick Reingold, John Palmieri, - 1997-2001 John Palmieri <palmieri@math.washington.edu> -License: GPL-2+ -Comment: - Author: John Palmieri <palmieri@math.washington.edu> - -Files: elisp/emacs-goodies-el/highlight-current-line.el -Copyright: 1997 Christoph Conrad <Christoph.Conrad@post.rwth-aachen.de> -License: GPL-2+ - -Files: elisp/emacs-goodies-el/home-end.el -Copyright: 1996 Kai Grossjohann and Toby Speight, 2002 Toby Speight -License: GPL-3 - -Files: elisp/emacs-goodies-el/htmlize.el -Copyright: 1997,1998,1999,2000 Hrvoje Niksic <hniksic@xemacs.org> -License: GPL-2+ - Files: elisp/emacs-goodies-el/initsplit.el Copyright: 2000, 2001 John Wiegley <johnw@gnu.org> License: GPL-2+ @@ -290,21 +174,6 @@ Files: elisp/emacs-goodies-el/marker-visit.el Copyright: 2001 Benjamin Rutt License: GPL-2+ -Files: elisp/emacs-goodies-el/matlab.el -Copyright: 1997-1999 Eric M. Ludlam, 1991-1997 Matthew R. Wette -License: GPL-2+ - -Files: elisp/emacs-goodies-el/minibuf-electric.el -Copyright: 1992, 1993, 1994, 1997 Free Software Foundation, Inc. - 1995 Tinker Systems. - 1995, 1996, 2000 Ben Wing. - Modified by Karl Hegbloom for GNU Emacs. -License: GPL-2+ - -Files: elisp/emacs-goodies-el/minibuffer-complete-cycle.el -Copyright: 1997,1998,2000,2003 Kevin Rodgers <ihs_4664@yahoo.com> -License: GPL-2+ - Files: elisp/emacs-goodies-el/miniedit.el Copyright: 2001, 2002 Free Software Foundation, Inc. License: GPL-2+ @@ -320,10 +189,6 @@ Files: elisp/emacs-goodies-el/muttrc-mode.el Copyright: 2000, 2001, 2002 Laurent Pelecq <laurent.pelecq@soleil.org> License: GPL-2+ -Files: elisp/emacs-goodies-el/obfusurl.el -Copyright: 2001-2008 by Dave Pearson <davep@davep.org> -License: GPL-2+ - Files: elisp/emacs-goodies-el/pack-windows.el Copyright: 2000 Michel Schinz License: GPL-2+ @@ -334,11 +199,6 @@ Copyright: 2000-2002 Steve Kemp <skx@tardis.ed.ac.uk>, 2008-2009 Ben Voui <intrigeri@boum.org> License: GPL-2+ -Files: elisp/emacs-goodies-el/pod-mode.el -Copyright: 2003-2005 Steffen Schwigon <schwigon@webit.de> -License: GPL-2+ -Comment: http://search.cpan.org/~schwigon/pod-mode/ - Files: elisp/emacs-goodies-el/pp-c-l.el Copyright: 2007-2010, Drew Adams, all rights reserved. License: GPL-2+ @@ -354,29 +214,6 @@ Files: elisp/emacs-goodies-el/protbuf.el Copyright: 1994, 1999 Noah S. Friedman <friedman@splode.com> License: GPL-2+ -Files: elisp/emacs-goodies-el/protocols.el -Copyright: 2000-2008 Dave Pearson <davep@davep.org> -License: GPL-2+ - -Files: elisp/emacs-goodies-el/quack.el -Copyright: 2002-2009 Neil Van Dyke <neil@neilvandyke.org> -License: GPL-2+ - -Files: elisp/emacs-goodies-el/rfcview.el -Copyright: 2001-2002 Neil W. Van Dyke <neil@neilvandyke.org> -License: GPL-2+ - -Files: elisp/emacs-goodies-el/services.el -Copyright: 2000-2008 Dave Pearson <davep@davep.org> -License: GPL-2+ - -Files: elisp/emacs-goodies-el/session.el -Copyright: 1996-1999, 2001-2003 Free Software Foundation, Inc. -License: GPL-2+ -Comment: - Author: Christoph Wedler <wedler@users.sourceforge.net> - X-URL: http://emacs-session.sourceforge.net/ - Files: elisp/emacs-goodies-el/setnu.el Copyright: 1994, 1995, 1997 Kyle E. Jones License: GPL-2+ @@ -385,13 +222,6 @@ Files: elisp/emacs-goodies-el/shell-command.el Copyright: 1998-2003 TSUCHIYA Masatoshi <tsuchiya@namazu.org> License: GPL-2+ -Files: elisp/emacs-goodies-el/show-wspace.el -Copyright: 2000-2007, Drew Adams, all rights reserved. -License: GPL-2+ -Comment: - Author: Peter Steiner <unistein@isbe.ch>, Drew Adams - Maintainer: Drew Adams - Files: elisp/emacs-goodies-el/silly-mail.el Copyright: 1993, 94, 95, 96, 97, 98, 99, 2000 Noah S. Friedman License: GPL-2+ @@ -410,26 +240,10 @@ Comment: Original Author: Gregor Schmid <schmid@fb3-s7.math.tu-berlin.de> http://home.mchsi.com/~jmrobert5/files/slang-mode.el -Files: elisp/emacs-goodies-el/sys-apropos.el -Copyright: 2002 Henrik Enberg <henrik@enberg.org> -License: GPL-2+ - -Files: elisp/emacs-goodies-el/tabbar.el -Copyright: 2003 David Ponce <david@dponce.com> -License: GPL-2+ - -Files: elisp/emacs-goodies-el/tail.el -Copyright: 2000 Benjamin Drieu <bdrieu@april.org> -License: GPL-2+ - Files: elisp/emacs-goodies-el/tc.el Copyright: 1998 Lars R. Clausen <lrclause@cs.uiuc.edu> License: GPL-2+ -Files: elisp/emacs-goodies-el/thinks.el -Copyright: 2000-2008 Dave Pearson <davep@davep.org> -License: GPL-2+ - Files: elisp/emacs-goodies-el/tlc.el Copyright: 1997, 1998 by The MathWorks, Inc. License: GPL-2+ @@ -454,10 +268,6 @@ Files: elisp/emacs-goodies-el/under.el Copyright: 1998 Benjamin Drieu <bdrieu@april.org> License: GPL-2+ -Files: elisp/emacs-goodies-el/upstart-mode.el -Copyright: 2010 Stig Sandbeck Mathisen <ssm@debian.org> -License: GPL-2+ - Files: elisp/emacs-goodies-el/xrdb-mode.el Copyright: 1998,1999,2000 Free Software Foundation, Inc. License: GPL-2+ diff --git a/debian/emacs-goodies-el.emacsen-install.in b/debian/emacs-goodies-el.emacsen-install.in index be580c2..7ee3575 100644 --- a/debian/emacs-goodies-el.emacsen-install.in +++ b/debian/emacs-goodies-el.emacsen-install.in @@ -16,13 +16,11 @@ PACKAGE=emacs-goodies-el # INCLUDED_emacs21="" # INCLUDED_xemacs21="" -EXCLUDED_emacs20="tabbar.el session.el csv-mode.el maplev.el pod-mode.el button-lock.el" -EXCLUDED_emacs21="pod-mode.el" -EXCLUDED_xemacs21="csv-mode.el minibuf-electric.el pp-c-l.el tabbar.el todoo.el rfcview.el upstart-mode.el maplev.el button-lock.el" +EXCLUDED_emacs20="maplev.el button-lock.el" +#EXCLUDED_emacs21="" +EXCLUDED_xemacs21="pp-c-l.el todoo.el maplev.el button-lock.el" #EXCLUDED_emacs_snapshot="cua.el cfengine.el ibuffer.el ido.el newsticker.el table.el " #EXCLUDED_emacs22="cua.el cfengine.el ibuffer.el ido.el newsticker.el table.el " -EXCLUDED_emacs22="minibuffer-complete-cycle.el" -EXCLUDED_emacs23="minibuffer-complete-cycle.el" # Skip byte-compilation here if necessary: #SOURCEONLY_all="emacs-goodies-el.el emacs-goodies-loaddefs.el" diff --git a/debian/emacs-goodies-el.install b/debian/emacs-goodies-el.install index e0d82d9..344c70e 100644 --- a/debian/emacs-goodies-el.install +++ b/debian/emacs-goodies-el.install @@ -2,41 +2,25 @@ elisp/emacs-goodies-el/align-string.el /usr/share/emacs/site-lisp/emacs-goodies- elisp/emacs-goodies-el/all.el /usr/share/emacs/site-lisp/emacs-goodies-el/ elisp/emacs-goodies-el/apache-mode.el /usr/share/emacs/site-lisp/emacs-goodies-el/ elisp/emacs-goodies-el/ascii.el /usr/share/emacs/site-lisp/emacs-goodies-el/ -elisp/emacs-goodies-el/auto-fill-inhibit.el /usr/share/emacs/site-lisp/emacs-goodies-el/ elisp/emacs-goodies-el/bar-cursor.el /usr/share/emacs/site-lisp/emacs-goodies-el/ -elisp/emacs-goodies-el/bm.el /usr/share/emacs/site-lisp/emacs-goodies-el/ elisp/emacs-goodies-el/boxquote.el /usr/share/emacs/site-lisp/emacs-goodies-el/ elisp/emacs-goodies-el/browse-huge-tar.el /usr/share/emacs/site-lisp/emacs-goodies-el/ -elisp/emacs-goodies-el/browse-kill-ring.el /usr/share/emacs/site-lisp/emacs-goodies-el/ elisp/emacs-goodies-el/button-lock.el /usr/share/emacs/site-lisp/emacs-goodies-el/ elisp/emacs-goodies-el/coffee.el /usr/share/emacs/site-lisp/emacs-goodies-el/ elisp/emacs-goodies-el/color-theme.el /usr/share/emacs/site-lisp/emacs-goodies-el/ elisp/emacs-goodies-el/color-theme-library.el /usr/share/emacs/site-lisp/emacs-goodies-el/ elisp/emacs-goodies-el/color-theme_seldefcustom.el /usr/share/emacs/site-lisp/emacs-goodies-el/ elisp/emacs-goodies-el/clipper.el /usr/share/emacs/site-lisp/emacs-goodies-el/ -elisp/emacs-goodies-el/csv-mode.el /usr/share/emacs/site-lisp/emacs-goodies-el/ elisp/emacs-goodies-el/ctypes.el /usr/share/emacs/site-lisp/emacs-goodies-el/ elisp/emacs-goodies-el/dedicated.el /usr/share/emacs/site-lisp/emacs-goodies-el/ elisp/emacs-goodies-el/df.el /usr/share/emacs/site-lisp/emacs-goodies-el/ -elisp/emacs-goodies-el/diminish.el /usr/share/emacs/site-lisp/emacs-goodies-el/ elisp/emacs-goodies-el/dir-locals.el /usr/share/emacs/site-lisp/emacs-goodies-el/ elisp/emacs-goodies-el/edit-env.el /usr/share/emacs/site-lisp/emacs-goodies-el/ -elisp/emacs-goodies-el/eproject.el /usr/share/emacs/site-lisp/emacs-goodies-el/ -elisp/emacs-goodies-el/eproject-extras.el /usr/share/emacs/site-lisp/emacs-goodies-el/ elisp/emacs-goodies-el/egocentric.el /usr/share/emacs/site-lisp/emacs-goodies-el/ elisp/emacs-goodies-el/emacs-goodies-custom.el /usr/share/emacs/site-lisp/emacs-goodies-el/ elisp/emacs-goodies-el/emacs-goodies-el.el /usr/share/emacs/site-lisp/emacs-goodies-el/ elisp/emacs-goodies-el/ff-paths.el /usr/share/emacs/site-lisp/emacs-goodies-el/ -elisp/emacs-goodies-el/filladapt.el /usr/share/emacs/site-lisp/emacs-goodies-el/ elisp/emacs-goodies-el/floatbg.el /usr/share/emacs/site-lisp/emacs-goodies-el/ -elisp/emacs-goodies-el/folding.el /usr/share/emacs/site-lisp/emacs-goodies-el/ -elisp/emacs-goodies-el/framepop.el /usr/share/emacs/site-lisp/emacs-goodies-el/ -elisp/emacs-goodies-el/graphviz-dot-mode.el /usr/share/emacs/site-lisp/emacs-goodies-el/ -elisp/emacs-goodies-el/highlight-beyond-fill-column.el /usr/share/emacs/site-lisp/emacs-goodies-el/ -elisp/emacs-goodies-el/highlight-completion.el /usr/share/emacs/site-lisp/emacs-goodies-el/ -elisp/emacs-goodies-el/highlight-current-line.el /usr/share/emacs/site-lisp/emacs-goodies-el/ -elisp/emacs-goodies-el/home-end.el /usr/share/emacs/site-lisp/emacs-goodies-el/ -elisp/emacs-goodies-el/htmlize.el /usr/share/emacs/site-lisp/emacs-goodies-el/ elisp/emacs-goodies-el/initsplit.el /usr/share/emacs/site-lisp/emacs-goodies-el/ elisp/emacs-goodies-el/joc-toggle-buffer.el /usr/share/emacs/site-lisp/emacs-goodies-el/ elisp/emacs-goodies-el/joc-toggle-case.el /usr/share/emacs/site-lisp/emacs-goodies-el/ @@ -46,39 +30,23 @@ elisp/emacs-goodies-el/lcomp.el /usr/share/emacs/site-lisp/emacs-goodies-el/ elisp/emacs-goodies-el/maplev.el /usr/share/emacs/site-lisp/emacs-goodies-el/ elisp/emacs-goodies-el/map-lines.el /usr/share/emacs/site-lisp/emacs-goodies-el/ elisp/emacs-goodies-el/marker-visit.el /usr/share/emacs/site-lisp/emacs-goodies-el/ -elisp/emacs-goodies-el/matlab.el /usr/share/emacs/site-lisp/emacs-goodies-el/ -elisp/emacs-goodies-el/minibuf-electric.el /usr/share/emacs/site-lisp/emacs-goodies-el/ -elisp/emacs-goodies-el/minibuffer-complete-cycle.el /usr/share/emacs/site-lisp/emacs-goodies-el/ elisp/emacs-goodies-el/miniedit.el /usr/share/emacs/site-lisp/emacs-goodies-el/ elisp/emacs-goodies-el/mutt-alias.el /usr/share/emacs/site-lisp/emacs-goodies-el/ elisp/emacs-goodies-el/muttrc-mode.el /usr/share/emacs/site-lisp/emacs-goodies-el/ -elisp/emacs-goodies-el/obfusurl.el /usr/share/emacs/site-lisp/emacs-goodies-el/ elisp/emacs-goodies-el/pack-windows.el /usr/share/emacs/site-lisp/emacs-goodies-el/ elisp/emacs-goodies-el/perldoc.el /usr/share/emacs/site-lisp/emacs-goodies-el/ elisp/emacs-goodies-el/pp-c-l.el /usr/share/emacs/site-lisp/emacs-goodies-el/ -elisp/emacs-goodies-el/pod-mode.el /usr/share/emacs/site-lisp/emacs-goodies-el/ elisp/emacs-goodies-el/projects.el /usr/share/emacs/site-lisp/emacs-goodies-el/ elisp/emacs-goodies-el/protbuf.el /usr/share/emacs/site-lisp/emacs-goodies-el/ -elisp/emacs-goodies-el/protocols.el /usr/share/emacs/site-lisp/emacs-goodies-el/ -elisp/emacs-goodies-el/quack.el /usr/share/emacs/site-lisp/emacs-goodies-el/ -elisp/emacs-goodies-el/rfcview.el /usr/share/emacs/site-lisp/emacs-goodies-el/ -elisp/emacs-goodies-el/services.el /usr/share/emacs/site-lisp/emacs-goodies-el/ -elisp/emacs-goodies-el/session.el /usr/share/emacs/site-lisp/emacs-goodies-el/ elisp/emacs-goodies-el/setnu.el /usr/share/emacs/site-lisp/emacs-goodies-el/ elisp/emacs-goodies-el/shell-command.el /usr/share/emacs/site-lisp/emacs-goodies-el/ -elisp/emacs-goodies-el/show-wspace.el /usr/share/emacs/site-lisp/emacs-goodies-el/ elisp/emacs-goodies-el/silly-mail.el /usr/share/emacs/site-lisp/emacs-goodies-el/ elisp/emacs-goodies-el/slang-mode.el /usr/share/emacs/site-lisp/emacs-goodies-el/ -elisp/emacs-goodies-el/sys-apropos.el /usr/share/emacs/site-lisp/emacs-goodies-el/ -elisp/emacs-goodies-el/tabbar.el /usr/share/emacs/site-lisp/emacs-goodies-el/ -elisp/emacs-goodies-el/tail.el /usr/share/emacs/site-lisp/emacs-goodies-el/ elisp/emacs-goodies-el/tc.el /usr/share/emacs/site-lisp/emacs-goodies-el/ -elisp/emacs-goodies-el/thinks.el /usr/share/emacs/site-lisp/emacs-goodies-el/ elisp/emacs-goodies-el/tlc.el /usr/share/emacs/site-lisp/emacs-goodies-el/ elisp/emacs-goodies-el/tld.el /usr/share/emacs/site-lisp/emacs-goodies-el/ elisp/emacs-goodies-el/todoo.el /usr/share/emacs/site-lisp/emacs-goodies-el/ elisp/emacs-goodies-el/toggle-option.el /usr/share/emacs/site-lisp/emacs-goodies-el/ elisp/emacs-goodies-el/twiddle.el /usr/share/emacs/site-lisp/emacs-goodies-el/ elisp/emacs-goodies-el/under.el /usr/share/emacs/site-lisp/emacs-goodies-el/ -elisp/emacs-goodies-el/upstart-mode.el /usr/share/emacs/site-lisp/emacs-goodies-el/ elisp/emacs-goodies-el/xrdb-mode.el /usr/share/emacs/site-lisp/emacs-goodies-el/ diff --git a/debian/emacsen-install.template b/debian/emacsen-install.template index 4300555..6fb63eb 100644 --- a/debian/emacsen-install.template +++ b/debian/emacsen-install.template @@ -14,8 +14,6 @@ sourceonly_all=$(for i in ${!SOURCEONLY_*} ; do eval echo \$$i done | sort -u) -if [ ${FLAVOR} = emacs ]; then exit 0; fi - LOG=`tempfile -pelc_ -s.log -m644` ELDIR=/usr/share/emacs/site-lisp/${PACKAGE} ELCDIR=/usr/share/${FLAVOR}/site-lisp/${PACKAGE} @@ -67,9 +65,11 @@ FILES=$(for i in $FILES ; do echo $i ; done | sort -u) # Symlinks instead of copying... cd ${ELCDIR} -for i in $FILES $sourceonly_all; do - ln -fs /usr/share/emacs/site-lisp/${PACKAGE}/$i -done +if [ ${FLAVOR} != emacs ]; then + for i in $FILES $sourceonly_all; do + ln -fs /usr/share/emacs/site-lisp/${PACKAGE}/$i + done +fi # Prepare the flavour specific autoload file if [ ${PACKAGE} = emacs-goodies-el ]; then diff --git a/debian/emacsen-remove.template b/debian/emacsen-remove.template index c84eeb8..6682290 100644 --- a/debian/emacsen-remove.template +++ b/debian/emacsen-remove.template @@ -1,5 +1,4 @@ -if [ ${FLAVOR} != emacs ]; then - echo remove/${PACKAGE}: purging byte-compiled files for ${FLAVOR} - rm -rf /usr/share/${FLAVOR}/site-lisp/${PACKAGE} -fi +echo remove/${PACKAGE}: purging byte-compiled files for ${FLAVOR} +rm -f /usr/share/${FLAVOR}/site-lisp/${PACKAGE}/*.elc + diff --git a/debian/patches/50_browse-kill-ring_bug224751.diff b/debian/patches/50_browse-kill-ring_bug224751.diff deleted file mode 100644 index dacb6fd..0000000 --- a/debian/patches/50_browse-kill-ring_bug224751.diff +++ /dev/null @@ -1,16 +0,0 @@ -## 50_browse-kill-ring_bug224751.diff by Peter S Galbraith <psg@debian.org> - ---- a/elisp/emacs-goodies-el/browse-kill-ring.el 2009-09-03 09:43:06.000000000 -0400 -+++ b/elisp/emacs-goodies-el/browse-kill-ring.el 2009-09-03 09:55:51.000000000 -0400 -@@ -591,7 +591,10 @@ - (unwind-protect - (progn - (setq buffer-read-only nil) -- (let ((target (overlay-get over 'browse-kill-ring-target))) -+ (let ((target (overlay-get over 'browse-kill-ring-target)) -+ ;; See http://bugs.debian.org/224751 -+ ;; Emacs 21.1 fails when text was read-only -+ (inhibit-read-only t)) - (delete-region (overlay-start over) - (1+ (overlay-end over))) - (setq kill-ring (delete target kill-ring))) diff --git a/debian/patches/50_diminish-defcustom.diff b/debian/patches/50_diminish-defcustom.diff deleted file mode 100644 index 1afce39..0000000 --- a/debian/patches/50_diminish-defcustom.diff +++ /dev/null @@ -1,153 +0,0 @@ -## 50_diminish-defcustom.diff by Peter S Galbraith <psg@debian.org> - ---- a/elisp/emacs-goodies-el/diminish.el 2003-06-17 21:01:24.000000000 -0400 -+++ b/elisp/emacs-goodies-el/diminish.el 2003-06-18 19:51:22.000000000 -0400 -@@ -1,11 +1,11 @@ - ;;; diminish.el --- Diminished modes are minor modes with no modeline display - --;; Copyright (C) 1998 Free Software Foundation, Inc. -+;; Copyright (C) 1998, 2003 Free Software Foundation, Inc. - - ;; Author: Will Mengarini <seldon@eskimo.com> - ;; URL: <http://www.eskimo.com/~seldon> - ;; Created: Th 19 Feb 98 --;; Version: 0.44, Sa 23 Jan 99 -+;; Version: 0.45, 18 Jun 2003 - ;; Keywords: extensions, diminish, minor, codeprose - - ;; This file is part of GNU Emacs. -@@ -95,6 +95,11 @@ - ;; near the end of your .emacs file. It should be near the end so that any - ;; minor modes your .emacs loads will already have been loaded by the time - ;; they're to be converted to diminished modes. -+;; -+;; Alternatively, you can setup dimished modes using the customize -+;; interface by customizing the variable `diminished-minor-modes'. The -+;; same caveat as above applies and the minor mode libraries should be -+;; loaded in ~/.emacs before the `(custom-set-variables' line. - - ;; To diminish a major mode, (setq mode-name "whatever") in the mode hook. - -@@ -104,6 +109,21 @@ - ;; by our facility with language." - ;; --J. Michael Straczynski - -+ -+;;; History: -+;; -+;; 2003-06-08 Peter S. Galbraith <psg@debian.org> -+;; -+;; - Make diminished-minor-modes a defcustom. You can now setup the -+;; package using `M-x customize-variable[RET]diminished-minor-modes[RET]'. -+;; -+;; The minor modes still need to be loaded in ~/.emacs prior to diminish -+;; setup but I'm not too sure how to best handle that. An list of -+;; (MINOR-MODE . LIBRARY-FILE) obtained by pre-parsing the Emacs elisp -+;; files perhaps, and then add an eval-after-load? Seems like a kludge -+;; because it relies on outside information remaining constant, but it -+;; would help. -+ - ;;; Code: - - (eval-when-compile (require 'cl)) -@@ -152,7 +172,7 @@ - ;; perhaps at first in surprise, the freedom they thus gain, and grow strong. - - ;;;###autoload --(defun diminish (mode &optional to-what) -+(defun diminish (mode &optional to-what annotate-flag) - "Diminish mode-line display of minor mode MODE to TO-WHAT (default \"\"). - - Interactively, enter (with completion) the name of any minor mode, followed -@@ -167,7 +187,10 @@ - letters for some modes, without leading spaces. Capitalizing them works - best; if you then diminish some mode to \"X\" but have abbrev-mode enabled as - well, you'll get a display like \"AbbrevX\". This function prepends a space --to TO-WHAT if it's > 1 char long & doesn't already begin with a space." -+to TO-WHAT if it's > 1 char long & doesn't already begin with a space. -+ -+If ANNOTATE-FLAG is nil or omitted, the normal case in interactive use, then -+the variable `diminished-minor-modes' will be modified to reflect the change." - (interactive (list (read (completing-read - "Diminish what minor mode: " - (mapcar (lambda (x) (list (symbol-name (car x)))) -@@ -184,7 +207,11 @@ - (callf2 concat " " to-what))) - (or (assq mode diminished-mode-alist) - (push (copy-sequence minor) diminished-mode-alist)) -- (setcdr minor (list to-what)))) -+ (setcdr minor (list to-what)) -+ (if (not annotate-flag) -+ (setq diminished-minor-modes -+ (append diminished-minor-modes -+ (list (cons (car minor) to-what))))))) - - ;; But an image comes to me, vivid in its unreality, of a loon alone on his - ;; forest lake, shrieking his soul out into a canopy of stars. Alone this -@@ -203,7 +230,7 @@ - ;; He was shot dead by police. - - ;;;###autoload --(defun diminish-undo (mode) -+(defun diminish-undo (mode &optional annotate-flag) - "Restore mode-line display of diminished mode MODE to its minor-mode value. - Do nothing if the arg is a minor mode that hasn't been diminished. - -@@ -211,7 +238,10 @@ - mode that was formerly a minor mode on which you invoked M-x diminish). - To restore all diminished modes to minor status, answer `diminished-modes'. - The response to the prompt shouldn't be quoted. However, in Lisp code, --the arg must be quoted as a symbol, as in (diminish-undo 'diminished-modes)." -+the arg must be quoted as a symbol, as in (diminish-undo 'diminished-modes). -+ -+If ANNOTATE-FLAG is nil or omitted, the normal case in interactive use, then -+the variable `diminished-minor-modes' will be modified to reflect the change." - (interactive - (list (read (completing-read - "Restore what diminished mode: " -@@ -229,7 +259,10 @@ - (or minor - (error "%S is not currently registered as a minor mode" mode)) - (when diminished -- (setcdr minor (cdr diminished)))))) -+ (setcdr minor (cdr diminished)) -+ (when (not annotate-flag) -+ (setq diminished-minor-modes -+ (assq-delete-all (car minor) diminished-minor-modes))))))) - - ;; Plumber Bob was not from Seattle, my grey city, for rainy Seattle is a - ;; city of interiors, a city of the self-diminished. When I moved here one -@@ -288,6 +321,31 @@ - ;; in line with the ducks and geese at the espresso counter, gazing placidly - ;; out on the world through loon-red eyes, thinking secret thoughts. - -+(defgroup diminish nil -+ "Diminished modes are minor modes with no modeline display." -+ :group 'convenience) -+ -+(defcustom diminished-minor-modes nil -+ "List of minor modes to diminish and their mode line display strings. -+The display string can be the empty string if you want the name of the mode -+completely removed from the mode line. If you prefer, you can abbreviate -+the name. For 2 characters or more will be displayed as a separate word on -+the mode line, just like minor modes' names. A single character will be -+scrunched up against the previous word. Multiple single-letter diminished -+modes will all be scrunched together. -+ -+The display of undiminished modes will not be affected." -+ :group 'diminish -+ :type '(alist :key-type (symbol :tag "Minor-mode") -+ :value-type (string :tag "Title")) -+ :options (mapcar 'car minor-mode-alist) -+ :set (lambda (symbol value) -+ (if (and (boundp 'diminished-minor-modes) diminished-minor-modes) -+ (mapcar -+ (lambda (x) (diminish-undo (car x) t)) diminished-minor-modes)) -+ (set-default symbol value) -+ (mapcar (lambda (x) (diminish (car x) (cdr x) t)) value))) -+ - (provide 'diminish) - --;;; diminish.el ends here -\ No newline at end of file -+;;; diminish.el ends here diff --git a/debian/patches/50_filladapt_bug420845.diff b/debian/patches/50_filladapt_bug420845.diff deleted file mode 100644 index 3b5ca7f..0000000 --- a/debian/patches/50_filladapt_bug420845.diff +++ /dev/null @@ -1,21 +0,0 @@ -## 50_filladapt_bug420845.diff by <psg@mixed.dyndns.org> - ---- a/elisp/emacs-goodies-el/filladapt.el 2003-04-04 15:16:01.000000000 -0500 -+++ b/elisp/emacs-goodies-el/filladapt.el 2007-05-14 19:41:02.000000000 -0400 -@@ -72,7 +72,7 @@ - - (provide 'filladapt) - --(defvar filladapt-version "2.12" -+(defvar filladapt-version "2.12debian" - "Version string for filladapt.") - - ;; BLOB to make custom stuff work even without customize -@@ -620,6 +620,7 @@ - - (defun turn-on-filladapt-mode () - "Unconditionally turn on Filladapt mode in the current buffer." -+ (interactive) - (filladapt-mode 1)) - - (defun turn-off-filladapt-mode () diff --git a/debian/patches/50_gnus-BTS.diff b/debian/patches/50_gnus-BTS.diff deleted file mode 100644 index f50503c..0000000 --- a/debian/patches/50_gnus-BTS.diff +++ /dev/null @@ -1,186 +0,0 @@ -## 50_gnus-BTS.diff by Peter S Galbraith <psg@debian.org> - ---- a/elisp/debian-el/gnus-BTS.el 2005-09-15 21:38:07.000000000 -0400 -+++ b/elisp/debian-el/gnus-BTS.el 2005-09-19 18:54:07.000000000 -0400 -@@ -33,42 +33,74 @@ - ;; references to the Bug Tracking system in them. It expects to see - ;; Bug references in the form of (for example): "#48273", "closes: - ;; 238742" or similar. -+;; -+;; Use `M-x' `gnus-dbts-browse-debpkg-or-bug' over the bug number. - -+;;; Change log: -+;; 2005-08-20 Jari Aalto <jari aalto A T cante net> -+;; -+;; * gnus-BTS.el: -+;; (top level): Changed all variable and function names to use common -+;; prefix `gnus-dbts-'. This makes package namespace clean. Converted -+;; all lambda forms to real functions. Cleaned up -+;; `gnus-select-article-hook' setting. -+;; Changed all 'setq' to 'defvar'. -+;; (gnus-dbts-gnus-install): New. -+;; (gnus-dbts-gnus-select-article-hook): New. -+;; (gnus-dbts-buttonize): New. -+;; (eval-after-load): New. Install at point when Gnus is being loaded. -+;; -+;; 2005-09-19 Peter S Galbraith <psg@debian.org> -+;; -+;; Minor bug fix: gnus-dbts-gnus-install missing brackets. -+;; - ;;; Code: - - --(setq anti-bug-special-keywords "reassign\\|merge") --(setq anti-bug-keywords (concat -- "tags\\|severity\\|retitle\\|close\\|closes:\\|Merged\\|reopen\\|Bug\\|" -- anti-bug-special-keywords)) -+;; gnus-dbts = Gnus inerface to Debian Bug Tracking System - --(setq anti-bug-prefix " *#?\\|Bugs?\\|#") --(setq anti-bug-number " *\\([0-9]+\\)") --(setq anti-bug-special " +\\([0-9]+\\|[-.A-Za-z0-9]+\\)") -+(autoload 'thing-at-point "thingatpt") - --(setq anti-gnus-debian-bug-regexp (concat -- "\\(" -- "\\(" -- anti-bug-keywords -- "\\)" -- anti-bug-prefix -- "\\)" -- anti-bug-number)) -+(defvar gnus-dbts-in-debian-group-p nil) - --(setq anti-gnus-debian-reassign-or-merge-regexp -- (concat -- "\\(" -- anti-bug-special-keywords -- "\\)" -- anti-bug-number -- anti-bug-special)) -+(defvar gnus-dbts-in-debian-devel-announce-group-p nil) - --(setq anti-gnus-debian-reassign-regexp "reassigned from package `\\([^']*\\)' to `\\([^']*\\)'") --(setq anti-gnus-debian-bug-BTS-regexp "^ *\\([0-9]+\\)") -+(defvar gnus-dbts-bug-special-keywords "reassign\\|merge") - --(defun anti-browse-debpkg-or-bug (thing) -+(defvar gnus-dbts-bug-keywords -+ (concat -+ "tags\\|severity\\|retitle\\|close\\|closes:\\|Merged\\|reopen\\|Bug\\|" -+ gnus-dbts-bug-special-keywords)) -+ -+(defvar gnus-dbts-bug-prefix " *#?\\|Bugs?\\|#") -+(defvar gnus-dbts-bug-number " *\\([0-9]+\\)") -+(defvar gnus-dbts-bug-special " +\\([0-9]+\\|[-.A-Za-z0-9]+\\)") -+ -+(defvar gnus-dbts-debian-bug-regexp -+ (concat -+ "\\(" -+ "\\(" -+ gnus-dbts-bug-keywords -+ "\\)" -+ gnus-dbts-bug-prefix -+ "\\)" -+ gnus-dbts-bug-number)) -+ -+(defvar gnus-dbts-debian-reassign-or-merge-regexp -+ (concat -+ "\\(" -+ gnus-dbts-bug-special-keywords -+ "\\)" -+ gnus-dbts-bug-number -+ gnus-dbts-bug-special)) -+ -+(defvar gnus-dbts-debian-reassign-regexp -+ "reassigned from package `\\([^']*\\)' to `\\([^']*\\)'") -+ -+(defvar gnus-dbts-debian-bug-regexp "^ *\\([0-9]+\\)") -+ -+(defun gnus-dbts-browse-debpkg-or-bug (thing) - (interactive "i") -- (require 'thingatpt) - (let* ((the-thing (if (null thing) - (thing-at-point 'sexp) - thing)) -@@ -80,45 +112,48 @@ - the-thing)) - (url (if bugp - "http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=" -- "http://cgi.debian.org/cgi-bin/search_packages.pl?&searchon=names&version=all&release=all&keywords="))) -+ (concat -+ "http://bugs.debian.org/cgi-bin/bugreport.cgi" -+ "?&searchon=names&version=all&release=all&keywords=")))) - (browse-url (concat url bug-or-feature)))) - --(defvar in-debian-group-p nil) --(add-hook 'gnus-select-article-hook -- (lambda () -- (setq in-debian-group-p (string-match "debian" -- (gnus-group-real-name -- gnus-newsgroup-name))))) -- --(defvar in-debian-devel-announce-group-p nil) --(add-hook 'gnus-select-article-hook -- (lambda () -- (setq in-debian-devel-announce-group-p -- (string-match "debian.devel.announce" -- (gnus-group-real-name -- gnus-newsgroup-name))))) -- --(defun anti-buttonize-debian (regexp num predicate) -+(defun gnus-dbts-buttonize-debian (regexp num predicate) - (add-to-list 'gnus-button-alist - (list regexp - num - predicate -- 'anti-browse-debpkg-or-bug -+ 'gnus-dbts-browse-debpkg-or-bug - num))) - --(add-hook -- 'gnus-article-mode-hook ; only run once, as soon as the article buffer has been created. -- (lambda () -- (anti-buttonize-debian anti-gnus-debian-bug-regexp 3 -- 'in-debian-group-p) -- (anti-buttonize-debian anti-gnus-debian-reassign-or-merge-regexp 3 -- 'in-debian-group-p) -- (anti-buttonize-debian anti-gnus-debian-bug-BTS-regexp 1 -- 'in-debian-devel-announce-group-p) -- -- (anti-buttonize-debian anti-gnus-debian-reassign-regexp 1 -- 'in-debian-group-p) -- (anti-buttonize-debian anti-gnus-debian-reassign-regexp 2 -- 'in-debian-group-p))) -+(defun gnus-dbts-buttonize () -+ (gnus-dbts-buttonize-debian gnus-dbts-debian-bug-regexp 3 -+ 'gnus-dbts-in-debian-group-p) -+ (gnus-dbts-buttonize-debian gnus-dbts-debian-reassign-or-merge-regexp 3 -+ 'gnus-dbts-in-debian-group-p) -+ (gnus-dbts-buttonize-debian gnus-dbts-debian-bug-regexp 1 -+ 'gnus-dbts-in-debian-devel-announce-group-p) -+ (gnus-dbts-buttonize-debian gnus-dbts-debian-reassign-regexp 1 -+ 'gnus-dbts-in-debian-group-p) -+ (gnus-dbts-buttonize-debian gnus-dbts-debian-reassign-regexp 2 -+ 'gnus-dbts-in-debian-group-p)) -+ -+(defun gnus-dbts-gnus-select-article-hook () -+ (setq gnus-dbts-in-debian-group-p -+ (string-match "debian" -+ (gnus-group-real-name -+ gnus-newsgroup-name))) -+ (setq gnus-dbts-in-debian-devel-announce-group-p -+ (string-match "debian.devel.announce" -+ (gnus-group-real-name -+ gnus-newsgroup-name)))) -+ -+(defun gnus-dbts-gnus-install () -+ (add-hook 'gnus-select-article-hook 'gnus-dbts-gnus-select-article-hook) -+ ;; only run once, as soon as the article buffer has been created. -+ (add-hook 'gnus-article-mode-hook 'gnus-dbts-buttonize)) -+ -+(eval-after-load "gnus" '(progn (gnus-dbts-gnus-install))) - - (provide 'gnus-BTS) -+ -+;; End of file diff --git a/debian/patches/50_highlight-beyond-fill-column.diff b/debian/patches/50_highlight-beyond-fill-column.diff deleted file mode 100644 index 94b1ba9..0000000 --- a/debian/patches/50_highlight-beyond-fill-column.diff +++ /dev/null @@ -1,181 +0,0 @@ -## 50_highlight-beyond-fill-column.diff by Peter S Galbraith <psg@debian.org> - ---- a/elisp/emacs-goodies-el/highlight-beyond-fill-column.el 2003-09-19 19:52:15.000000000 -0400 -+++ b/elisp/emacs-goodies-el/highlight-beyond-fill-column.el 2003-09-20 14:26:58.000000000 -0400 -@@ -1,15 +1,16 @@ --;;; highlight-beyond-fill-column.el --- font-lock-add-keywords aid for Emacs -+;;; highlight-beyond-fill-column.el --- fontify beyond the fill-column. - - ;; Copyright (C) 1985, 1986, 1987, 1992 Free Software Foundation, Inc. -+;; Copyright (C) 2003 Peter S Galbraith <psg@debian.org> - - ;; Author: Sandip Chitale (sandip.chitale@blazesoft.com) - ;; Keywords: programming decipline convenience - - ;; Keywords: - ;; Time-stamp: Aug 23 2001 8:56 PM Pacific Daylight Time --;; Version: 1.1 -+;; Version: 1.2 - --;; This file is *NOT* (yet?) part of GNU Emacs. -+;; This file is not part of GNU Emacs. - - ;; This program is free software; you can redistribute it and/or modify - ;; it under the terms of the GNU General Public License as published by -@@ -26,10 +27,11 @@ - ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, - ;; Boston, MA 02111-1307, USA. - --;; Commentary: -- --;; This defines a function that can be used by `font-lock-add-keywords' to find the columns --;; that are beyond `fill-column'. -+;;; Commentary: -+;; -+;; This defines a function that can be used by `font-lock-add-keywords' to -+;; find the columns that are beyond `fill-column'. It does not currently -+;; work in XEmacs because it lacks the funcyom `font-lock-add-keywords'. - ;; - ;; Installation: - ;; Put the following in your .emacs -@@ -38,88 +40,70 @@ - ;; - ;; Example usage: - ;; --;; Customize the `highlight-beyond-fill-column-in-modes' variable to --;; setup the list of modes in which to highlight-beyond-fill-column -+;; Enable it on a buffer using `M-x highlight-beyond-fill-column. -+;; You may use that command in a hook (e.g. text-mode-hook) - ;; --;; Customize the `highlight-beyond-fill-column-face' variable to --;; to setup the face used for highlight-beyond-fill-column -+;; Customize the `highlight-beyond-fill-column-face' variable to -+;; to setup the face used for highlight-beyond-fill-column - ;; - ;; Acknowledgement: - ;; - ;; This is based on initial code provided by Jim Janney (jjanney@xmission.com) --;; -+ -+;;; History: -+;; -+;; V1.2 2003-09-12 by Peter S Galbraith <psg@debian.org> -+;; - Made checkdoc clean and fixed indentation and parentheses placement. -+;; - Added defgroup; used defface. -+;; - Removed `highlight-beyond-fill-column-in-modes' since it didn't work -+;; anymore. -+;; - Created `highlight-beyond-fill-column' to use on a single buffer or as -+;; a hook. - - ;;; Code: --(defcustom highlight-beyond-fill-column-in-modes nil -- "The list of modes in which to highlight-beyond-fill-column." -- :group 'fill -- :type '(repeat string) -- ) -+(defgroup highlight-beyond-fill-column nil -+ "Fontify beyond the fill-column." -+ :group 'fill) - --(defcustom highlight-beyond-fill-column-face 'underline -- "The face to use with highlight-beyond-fill-column." -- :group 'fill -- :type 'face -- ) -+(defface highlight-beyond-fill-column-face -+ '((t (:underline t))) -+ "Face used to highlight beyond the fill-column." -+ :group 'highlight-current-line) - --(defun find-after-fill-column (limit) -- "A function that can be used by `font-lock-add-keywords' to find columns that are --beyond the `fill-column'." -- (let ( -- ; remember the point -- (original-point (point)) -- ) -- ; if already past the fill column start on next line -+(defun highlight-beyond-fill-column-lock (limit) -+ "Function for font-lock to highlight beyond the `fill-column' until LIMIT." -+ (let ((original-point (point))) ;; remember the point -+ ;; if already past the fill column start on next line - (if (> (current-column) fill-column) -- (forward-line 1) -- ) -- (while (and (< (point) limit) ; still within limit -- (or (< (move-to-column fill-column) fill-column) ; the line has less than `fill-column' columns -- (= (point) (line-end-position)) ; end of line -- ) -- ) -- ; goto next line -- (forward-line 1) -- ) -+ (forward-line 1)) -+ (while (and (< (point) limit) ; still within limit -+ ;; the line has less than `fill-column' columns -+ (or (< (move-to-column fill-column) fill-column) -+ (= (point) (line-end-position)))) ; end of line -+ ;; goto next line -+ (forward-line 1)) - -- (if (>= (point) limit) ; beyond limit -- (progn -- (goto-char original-point) ; restore point -- nil ; return nil -- ) -- (set-match-data (list (point-marker) ; set match data -- (progn -- (end-of-line) -- (forward-char) ; this gives the highlight till the end of the window -- (point-marker) -- ) -- ) -- ) -- t) ; return t indicating that the match data was set -- ) -- ) -+ (if (>= (point) limit) ; beyond limit -+ (progn -+ (goto-char original-point) ; restore point -+ nil) ; return nil - --(defun init-highlight-beyond-fill-column () -- "" -- (let ( -- (modelist highlight-beyond-fill-column-in-modes) -- mode -- ) -- (while modelist -- (setq mode (intern (car modelist))) -- (if (and mode -- (functionp mode)) -- (font-lock-add-keywords mode -- '( -- (find-after-fill-column 0 highlight-beyond-fill-column-face prepend) -- ) -- ) -- ) -- (setq modelist (cdr modelist)) -- ) -- ) -- ) -+ (set-match-data (list (point-marker) ; set match data -+ (progn -+ (end-of-line) -+ (point-marker)))) -+ ;; return t indicating that the match data was set -+ t))) - --(add-hook 'after-init-hook 'init-highlight-beyond-fill-column) -+;;;###autoload -+(defun highlight-beyond-fill-column () -+ "Setup this buffer to highlight beyond the `fill-column'." -+ (interactive) -+ (font-lock-add-keywords -+ nil -+ '((highlight-beyond-fill-column-lock 0 'highlight-beyond-fill-column-face -+ prepend)))) - - (provide 'highlight-beyond-fill-column) -+ -+;;; highlight-beyond-fill-column.el ends here diff --git a/debian/patches/50_minibuf-electric.diff b/debian/patches/50_minibuf-electric.diff deleted file mode 100644 index 0bfa4a2..0000000 --- a/debian/patches/50_minibuf-electric.diff +++ /dev/null @@ -1,23 +0,0 @@ -Index: emacs-goodies-el-35.12ubuntu1/elisp/emacs-goodies-el/minibuf-electric.el -=================================================================== ---- emacs-goodies-el-35.12ubuntu1.orig/elisp/emacs-goodies-el/minibuf-electric.el -+++ emacs-goodies-el-35.12ubuntu1/elisp/emacs-goodies-el/minibuf-electric.el -@@ -46,12 +46,17 @@ in `substitute-in-file-name'." - :require 'minibuf-electric - :group 'minibuffer) - -+;;; HACK -+(defvar directory-sep-char ?/) -+ - ;;; originally by Stig@hackvan.com, taken from XEmacs 21.4 - ;;; - (defun minibuffer-electric-separator () - "Insert / separator, but clear line first if typed twice in a row." - (interactive) -- (let ((c last-command-char)) -+ (let ((c (if (not (>= emacs-major-version 24)) -+ last-command-char -+ last-command-event))) - (and minibuffer-completing-file-name ; added for GNU Emacs - minibuffer-electric-file-name-behavior - (eq c directory-sep-char) diff --git a/debian/patches/50_quack_autoload.diff b/debian/patches/50_quack_autoload.diff deleted file mode 100644 index 9914bd2..0000000 --- a/debian/patches/50_quack_autoload.diff +++ /dev/null @@ -1,100 +0,0 @@ -## 50_quack_autoload.diff by Daniel Moerner <dmoerner@gmail.com> - ---- a/elisp/emacs-goodies-el/quack.el -+++ b/elisp/emacs-goodies-el/quack.el -@@ -62,9 +62,10 @@ - ;; INSTALLATION: - ;; - ;; To install, put this file (`quack.el') somewhere in your Emacs load --;; path, and add the following line to your `.emacs' file: -+;; path, and add the following lines to your `.emacs' file: - ;; - ;; (require 'quack) -+;; (quack-install) - ;; - ;; If you don't know what your Emacs load path is, try invoking the command - ;; "C-h v load-path RET" or consulting the Emacs manual. -@@ -3159,6 +3160,8 @@ - ;; Non-Scheme: - ("\\.plt\\'" . quack-pltfile-mode))) - -+;;;###autoload(add-to-list 'auto-mode-alist '("\\.plt\\'" . quack-pltfile-mode)) -+ - ;; Syntax Table: - - (defmacro quack-str-syntax (str) -@@ -3508,10 +3511,6 @@ - (add-submenu nil quack-global-menuspec "Help" current-menubar) - (set-menubar-dirty-flag)))) - --;; TODO: We should make sure the user's custom settings have been loaded --;; before we do this. --(quack-install-global-menu) -- - ;; And die some more! - ;;(quack-when-xemacs (add-hook 'after-init-hook 'quack-install-global-menu)) - -@@ -4132,9 +4131,11 @@ - (quack-when-xemacs - (quack-install-global-menu))) - -+;;;###autoload - (defun quack-inferior-scheme-mode-hookfunc () - (quack-shared-mode-hookfunc-stuff)) - -+;;;###autoload - (defun quack-scheme-mode-hookfunc () - (quack-shared-mode-hookfunc-stuff) - -@@ -4147,9 +4148,6 @@ - ;;(quack-install-tool-bar))) - ) - --(add-hook 'scheme-mode-hook 'quack-scheme-mode-hookfunc) --(add-hook 'inferior-scheme-mode-hook 'quack-inferior-scheme-mode-hookfunc) -- - ;; Compilation Mode: - - ;; TODO: Add compilation-directory-matcher support for "setup-plt: in". -@@ -4215,8 +4213,6 @@ - (append quack-compilation-error-regexp-alist-additions - quack-saved-compilation-error-regexp-alist))) - --(quack-install-compilation-mode-stuff) -- - ;; Interpreter-mode-alist: - - (defvar quack-saved-interpreter-mode-alist nil) -@@ -4256,8 +4252,6 @@ - (append quack-interpreter-mode-alist-additions - quack-saved-interpreter-mode-alist))) - --(quack-install-interpreter-mode-alist) -- - ;; PLT Package Mode: - - ;; TODO: Do some simple checking and summarize what directories and files are -@@ -4285,6 +4279,7 @@ - - ;; TODO: Make a menu map for pltfile-mode. - -+;;;###autoload - (defun quack-pltfile-mode () - (interactive) - "Major mode for viewing PLT Scheme `.plt' package files. -@@ -4812,6 +4807,15 @@ - - ;; End: - -+;;;###autoload -+(defun quack-install () -+ "Install quack.el into scheme-mode." -+ (add-hook 'scheme-mode-hook 'quack-scheme-mode-hookfunc) -+ (add-hook 'inferior-scheme-mode-hook 'quack-inferior-scheme-mode-hookfunc) -+ (quack-install-compilation-mode-stuff) -+ (quack-install-interpreter-mode-alist) -+ (quack-install-global-menu)) -+ - (provide 'quack) - - ;; quack.el ends here diff --git a/debian/patches/50_rfcview.diff b/debian/patches/50_rfcview.diff deleted file mode 100644 index 897d407..0000000 --- a/debian/patches/50_rfcview.diff +++ /dev/null @@ -1,11 +0,0 @@ ---- a/elisp/emacs-goodies-el/rfcview.el -+++ b/elisp/emacs-goodies-el/rfcview.el -@@ -376,7 +376,7 @@ - (if (= n 0) "?" (1+ n)))))) - (overlay-put overlay - 'before-string -- (concat (make-string (max (- 79 -+ (concat (make-string (max (- fill-column - (- (match-beginning 1) - (match-beginning 0)) - (length page-str)) diff --git a/debian/patches/50_session_enable_custom.diff b/debian/patches/50_session_enable_custom.diff deleted file mode 100644 index 74658e0..0000000 --- a/debian/patches/50_session_enable_custom.diff +++ /dev/null @@ -1,18 +0,0 @@ -## 50_session_enable_custom.diff by Peter S Galbraith <psg@debian.org> - ---- a/elisp/emacs-goodies-el/session.el -+++ b/elisp/emacs-goodies-el/session.el -@@ -244,7 +244,12 @@ - (const :tag "Load/Save Session" session) - (const :tag "Store/Use Places" places) - (const :tag "Setup Key/Mouse Bindings" keys) -- (const :tag "Setup Menus" menus)))) -+ (const :tag "Setup Menus" menus))) -+ :require 'session -+ :set (lambda (symbol value) -+ (set-default symbol value) -+ (when value -+ (add-hook 'after-init-hook 'session-initialize)))) - - - ;;;=========================================================================== diff --git a/debian/patches/51_diminishSamuelBronson.diff b/debian/patches/51_diminishSamuelBronson.diff deleted file mode 100644 index 3d2fc3a..0000000 --- a/debian/patches/51_diminishSamuelBronson.diff +++ /dev/null @@ -1,81 +0,0 @@ ---- a/elisp/emacs-goodies-el/diminish.el -+++ b/elisp/emacs-goodies-el/diminish.el -@@ -8,7 +8,7 @@ - ;; Version: 0.45, 18 Jun 2003 - ;; Keywords: extensions, diminish, minor, codeprose - --;; This file is part of GNU Emacs. -+;; This file is NOT part of GNU Emacs. - - ;; This program is free software; you can redistribute it and/or modify - ;; it under the terms of the GNU General Public License as published by -@@ -123,6 +123,17 @@ - ;; files perhaps, and then add an eval-after-load? Seems like a kludge - ;; because it relies on outside information remaining constant, but it - ;; would help. -+;; -+;; 2011-01-12 Samuel J. J. Bronson <naesten@gmail.com> -+;; -+;; - Make `diminished-minor-modes' (probably) Just Work. It should -+;; no longer be necessary ot do anything special in elisp; instead -+;; of trying to minimize computation, we simply redo everything -+;; after any elisp gets loaded. (If this turns out to be too slow, -+;; there are some relatively straightforward improvements that -+;; could be made without having to rely on foreknowledge of what -+;; gets defined where. For example, by keeping track of "pending" -+;; diminished modes and only trying to diminish those.) - - ;;; Code: - -@@ -252,7 +263,7 @@ - (if (eq mode 'diminished-modes) - (let ((diminished-modes diminished-mode-alist)) - (while diminished-modes -- (diminish-undo (caar diminished-modes)) -+ (diminish-undo (caar diminished-modes) annotate-flag) - (callf cdr diminished-modes))) - (let ((minor (assq mode minor-mode-alist)) - (diminished (assq mode diminished-mode-alist))) -@@ -321,10 +332,28 @@ - ;; in line with the ducks and geese at the espresso counter, gazing placidly - ;; out on the world through loon-red eyes, thinking secret thoughts. - -+;;;###autoload -+(defun diminish-maybe-refresh () -+ "Should redo `diminish'ing only if something has changed. -+Right now, do it regardless and hope this isn't too slow." -+ (interactive) -+ (diminish-undo 'diminished-modes t) -+ (mapcar #'(lambda (x) (diminish (car x) (cdr x) t)) -+ diminished-minor-modes)) -+ -+(defun diminish-oneshot-post-command-hook () -+ (diminish-maybe-refresh) -+ (remove-hook 'post-command-hook 'diminish-oneshot-post-command-hook)) -+ -+(defun diminish-after-load-hook (file) -+ (add-hook 'post-command-hook 'diminish-oneshot-post-command-hook)) -+(add-hook 'after-load-functions 'diminish-after-load-hook) -+ - (defgroup diminish nil - "Diminished modes are minor modes with no modeline display." - :group 'convenience) - -+;;;###autoload - (defcustom diminished-minor-modes nil - "List of minor modes to diminish and their mode line display strings. - The display string can be the empty string if you want the name of the mode -@@ -340,11 +369,9 @@ - :value-type (string :tag "Title")) - :options (mapcar 'car minor-mode-alist) - :set (lambda (symbol value) -- (if (and (boundp 'diminished-minor-modes) diminished-minor-modes) -- (mapcar -- (lambda (x) (diminish-undo (car x) t)) diminished-minor-modes)) - (set-default symbol value) -- (mapcar (lambda (x) (diminish (car x) (cdr x) t)) value))) -+ (diminish-maybe-refresh)) -+ :require 'diminish) - - (provide 'diminish) - diff --git a/debian/patches/51_gnus-BTS_bug363161.diff b/debian/patches/51_gnus-BTS_bug363161.diff deleted file mode 100644 index e650cdc..0000000 --- a/debian/patches/51_gnus-BTS_bug363161.diff +++ /dev/null @@ -1,34 +0,0 @@ -## 51_gnus-BTS_bug363161.diff by <psg@mixed.dyndns.org> - ---- a/elisp/debian-el/gnus-BTS.el 2007-09-18 21:19:47.000000000 -0400 -+++ b/elisp/debian-el/gnus-BTS.el 2007-09-18 21:20:47.000000000 -0400 -@@ -53,6 +53,11 @@ - ;; 2005-09-19 Peter S Galbraith <psg@debian.org> - ;; - ;; Minor bug fix: gnus-dbts-gnus-install missing brackets. -+;; -+;; 2007-09-17 Peter S Galbraith <psg@debian.org> -+;; -+;; Wrong regexp part of gnus-dbts-debian-bug-regexp called by -+;; gnus-dbts-buttonize-debian (Closes #363161, #442438). - ;; - ;;; Code: - -@@ -97,8 +102,6 @@ - (defvar gnus-dbts-debian-reassign-regexp - "reassigned from package `\\([^']*\\)' to `\\([^']*\\)'") - --(defvar gnus-dbts-debian-bug-regexp "^ *\\([0-9]+\\)") -- - (defun gnus-dbts-browse-debpkg-or-bug (thing) - (interactive "i") - (let* ((the-thing (if (null thing) -@@ -130,7 +133,7 @@ - 'gnus-dbts-in-debian-group-p) - (gnus-dbts-buttonize-debian gnus-dbts-debian-reassign-or-merge-regexp 3 - 'gnus-dbts-in-debian-group-p) -- (gnus-dbts-buttonize-debian gnus-dbts-debian-bug-regexp 1 -+ (gnus-dbts-buttonize-debian gnus-dbts-debian-bug-regexp 3 - 'gnus-dbts-in-debian-devel-announce-group-p) - (gnus-dbts-buttonize-debian gnus-dbts-debian-reassign-regexp 1 - 'gnus-dbts-in-debian-group-p) diff --git a/debian/patches/51_session_autoload.diff b/debian/patches/51_session_autoload.diff deleted file mode 100644 index 982c1df..0000000 --- a/debian/patches/51_session_autoload.diff +++ /dev/null @@ -1,12 +0,0 @@ -## 51_session_autoload.diff by Peter S Galbraith <psg@debian.org> - ---- a/elisp/emacs-goodies-el/session.el -+++ b/elisp/emacs-goodies-el/session.el -@@ -1717,7 +1717,6 @@ - :require 'session - :set 'session-initialize-and-set) - --;;;###autoload - (defun session-initialize () - "Initialize package session and read previous session file. - Setup hooks and load `session-save-file', see variable `session-initialize'. At diff --git a/debian/patches/52_gnus-BTS_bug218286.diff b/debian/patches/52_gnus-BTS_bug218286.diff deleted file mode 100644 index 9c32b2c..0000000 --- a/debian/patches/52_gnus-BTS_bug218286.diff +++ /dev/null @@ -1,60 +0,0 @@ -## 52_gnus-BTS_bug218286.diff by <psg@mixed.dyndns.org> - ---- a/elisp/debian-el/gnus-BTS.el 2007-09-24 19:17:09.000000000 -0400 -+++ b/elisp/debian-el/gnus-BTS.el 2007-09-24 19:23:14.000000000 -0400 -@@ -3,7 +3,6 @@ - ;; Copyright (C) 2001 Andreas Fuchs <asf@acm.org> - - ;; Author: Andreas Fuchs --;; Maintainer: Andreas Fuchs <asf@acm.org> - ;; Keywords: gnus, Debian, Bug - ;; Status: Works in XEmacs (I think >=21) - ;; Created: 2001-02-07 -@@ -59,6 +58,13 @@ - ;; Wrong regexp part of gnus-dbts-debian-bug-regexp called by - ;; gnus-dbts-buttonize-debian (Closes #363161, #442438). - ;; -+;; 2007-09-24 intrigeri <intrigeri@boum.org> -+;; Peter S Galbraith <psg@debian.org> -+;; -+;; Bug#218286: [Fwd: Re: [gnus-BTS] please make bug numbers in mail -+;; clickable to read them as email. -+;; Introduce `gnus-dbts-read-bugs-as-email' -+;; - ;;; Code: - - -@@ -66,6 +72,12 @@ - - (autoload 'thing-at-point "thingatpt") - -+(defcustom gnus-dbts-read-bugs-as-email nil -+ "If t, highlighted Debian bug numbers' buttons call -+ `debian-bug-get-bug-as-email'; else, `browse-url' is used." -+ :type 'boolean -+ :group 'gnus-BTS) -+ - (defvar gnus-dbts-in-debian-group-p nil) - - (defvar gnus-dbts-in-debian-devel-announce-group-p nil) -@@ -102,6 +114,9 @@ - (defvar gnus-dbts-debian-reassign-regexp - "reassigned from package `\\([^']*\\)' to `\\([^']*\\)'") - -+;; debian-bug-get-bug-as-email autoload -+(require 'debian-el-loaddefs) -+ - (defun gnus-dbts-browse-debpkg-or-bug (thing) - (interactive "i") - (let* ((the-thing (if (null thing) -@@ -118,7 +133,9 @@ - (concat - "http://cgi.debian.org/cgi-bin/search_packages.pl" - "?&searchon=names&version=all&release=all&keywords=")))) -- (browse-url (concat url bug-or-feature)))) -+ (if (and bugp gnus-dbts-read-bugs-as-email) -+ (debian-bug-get-bug-as-email bug-or-feature) -+ (browse-url (concat url bug-or-feature))))) - - (defun gnus-dbts-buttonize-debian (regexp num predicate) - (add-to-list 'gnus-button-alist diff --git a/debian/patches/series b/debian/patches/series index 8c694ad..55c5766 100644 --- a/debian/patches/series +++ b/debian/patches/series @@ -1,28 +1,17 @@ 50_tc.diff -50_rfcview.diff 40_missing_provide.diff 49_bar-cursor-customize.diff 50_bar-cursor_bug331430.diff -50_browse-kill-ring_bug224751.diff 50_ctypes.diff 50_coffee_no-autoload.diff 50_color-theme_custom.diff 50_dedicated.diff -50_diminish-defcustom.diff -51_diminishSamuelBronson.diff 50_edit-env_autoload.diff 51_edit-env_copy-list.diff -50_filladapt_bug420845.diff -50_gnus-BTS.diff -51_gnus-BTS_bug363161.diff -52_gnus-BTS_bug218286.diff -50_highlight-beyond-fill-column.diff 50_joc-toggle-case.diff 50_joc-toggle-buffer.diff 50_maplevtexi.diff 50_marker-visit_autoloads.diff -50_session_enable_custom.diff -51_session_autoload.diff 50_silly-mail.diff 50_slang-mode_bug336352.diff 50_protbuf_custom_and_toggle.diff @@ -32,6 +21,4 @@ 52_todoo_bug414781.diff 53_todoo_bug438964.diff 50_setnu.diff -50_quack_autoload.diff 56_make_local_hook.diff -50_minibuf-electric.diff diff --git a/debian/rules b/debian/rules index a5b00e1..64d3465 100755 --- a/debian/rules +++ b/debian/rules @@ -10,14 +10,9 @@ override_dh_auto_build: for i in debian/*.emacsen-remove.in ; do cat $$i debian/emacsen-remove.template > debian/$$(basename $$i .in) ; done install -d info makeinfo elisp/emacs-goodies-el/emacs-goodies-el.texi - makeinfo elisp/debian-el/debian-el.texi makeinfo -o info/ elisp/emacs-goodies-el/maplev.texi dh_auto_build -override_dh_installemacsen: - dh_installemacsen -Ndebian-el - dh_installemacsen -pdebian-el --priority=51 - override_dh_auto_clean: for i in debian/*.emacsen-install.in ; do rm -f debian/$$(basename $$i .in) ; done for i in debian/*.emacsen-remove.in ; do rm -f debian/$$(basename $$i .in) ; done diff --git a/elisp/debian-el/apt-sources.el b/elisp/debian-el/apt-sources.el deleted file mode 100755 index e6458f2..0000000 --- a/elisp/debian-el/apt-sources.el +++ /dev/null @@ -1,524 +0,0 @@ -;;; apt-sources.el --- Mode for editing apt source.list file -;; -;; Version: 0.9.9 -;; $Revision: -;; $Id: -;; $Source: - -;; Author: Dr. Rafael Sepúlveda. <drs@gnulinux.org.mx> -;; Maintainer: Peter S. Galbraith <psg@debian.org> -;; (I can't find Dr. Rafael Sepúlveda) - -;; Copyright (C) 2001-2003, Dr. Rafael Sepúlveda <drs@gnulinux.org.mx> -;; Copyright (C) 2009 Peter S. Galbraith <psg@debian.org> - -;; This program 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. - -;; This program 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 this program; if not, write to the Free Software Foundation, -;; Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; This mode is for editing '/etc/apt/sources.list', the APT (Advanced -;; Package Tool) configuration file found on Debian systems. - -;; APT is a package retrieval tool for Debian (a GNU distribution, see -;; http://www.debian.org); for example you could install Emacs with -;; the command: -;; -;; apt-get install emacs21 -;; -;; and APT will then retrieve the package and install it for you. The -;; sources.list file tells APT where to look for packages. Mine looks -;; like this: -;; -;; deb http://http.us.debian.org/debian unstable main contrib -;; deb http://non-us.debian.org/debian-non-US unstable/non-US main -;; -;; deb ftp://ftp.de.debian.org/debian ../project/experimental main -;; -;; This mode font-locks the file and add some things including new -;; source lines and modifying existing source lines. -;; -;; This mode can be customized in diferent parts. You can (interactively) -;; change if you want blank lines around a new source line and comment -;; with `apt-sources-around-lines'. Also you can change the way that -;; this mode names each source line, with variable`apt-sources-source-name'; -;; if no name is entered, no commente name will be inserted. -;; To customize, try `M-x customize-group [RET] apt-sources' -;; -;; You can modify existing parts of the source line; check the mode -;; documentation for mor details. Another thing that this mode can do is to -;; replicate an existing line (`C-c C-r') that will be changed to the 'deb' or -;; 'deb-src' corresponding line. If it replicates a 'deb' line, an identical -;; 'deb-src' source line will be created. -;; -;; To load this mode, you can add a "Local Variables" block at the end of -;; the sources.list file with `C-c C-v' after you change the file's mode to -;; 'apt-sources'. But this should not be needed since an entry is added to -;; `auto-mode-alist' to automatically enter this mode when editing files -;; named `sources.list'. -;; -;; You can always find the latest version of this mode on -;; 'http://people.gnulinux.org.mx/drs/emacs/apt-sources.el' - -;;; TODO: - -;;; History: - -;; 0.9.9 2009-11-25 Peter S. Galbraith <psg@debian.org> -;; -- Create syntax table and add comments. (Closes: #469971) -;; 0.9.8 -- Remove dependency to autoinsert, because it's no longer required. -;; (suggested by Peter S. Galbraith <psg@debian.org>) -;; 0.9.7 -- Converted relevant defvar statements to defcustom, and added -;; `auto-mode-alist' entry. (Peter S. Galbraith <psg@debian.org>) -;; -- Add completion to some of the fields in `apt-sources-new-source' -;; and the functions that change parameters. (suggested by -;; Peter S. Galbraith <psg@debian.org>) -;; -- Add menu support. (suggested by Peter S. Galbraith <psg@debian.org>) -;; -- Change name from `apt-sources-insert-source' to -;; `apt-sources-new-source'. (suggested by Peter S. Galbraith -;; <psg@debian.org>) -;; -- Change name from `apt-sources-insert-local-var' to -;; `apt-sources-insert-local-vars'. (suggested by Peter S. Galbraith -;; <psg@debian.org>) -;; -- Change `apt-sources-change-components' to handle absence of -;; components. (Dr. Rafael Sepúlveda <drs@gnulinux.org.mx>) -;; -- Change the web page address form where you can find the latest version. -;; (Dr. Rafael Sepúlveda <drs@gnulinux.org.mx>) -;; 0.9.6 -- Added a better description to what is APT and file 'sources.list'. -;; (Ole Laursen <olau@hardworking.dk>) -;; 0.9.5 -- Fixed typo in docstring of function `apt-sources-around-lines'. -;; -- Rewrite function `apt-sources-around-lines' with a better algorithm. -;; (John Paul Wallington <jpw@shootybangbang.com>) -;; -- Added a description to apt and sources.list -;; (David Combs <dkcombs@panix.com>) -;; -- Added name and email from contributors. :) -;; (Dr. Rafael Sepúlveda <drs@gnulinux.org.mx>) -;; 0.9.4 -- Added a missing option in function `apt-sources-insert-source' to -;; select 'ftp' type. -;; -- Added URI-type 'https'. -;; -- Fix some function's documentation mistakes. -;; (Dr. Rafael Sepúlveda <drs@gnulinux.org.mx>) -;; 0.9.3 -- Fix a recently introduced bug that prevents keybindings work under -;; Xemacs. -;; (John Paul Wallington <jpw@shootybangbang.com>) -;; 0.9.2 -- Fix a bug with a keybinding that called a function with another name. -;; -- Make variable `comment-start' buffer-local. -;; -- Change the keybinding zone to be more compact and portable. -;; (John Paul Wallington <jpw@shootybangbang.com>) -;; -- Change some keybindings. -;; (Dr. Rafael Sepúlveda <drs@gnulinux.org.mx>) -;; -;; 0.9.1 -- Corrected a bug in the 'cond' clauses that prevented to byte-compile. -;; (Perkens-Golomb, Burkhard <burkhard.perkens-golomb@sdm.de>)' -;; -- Make variable `comment-start-skip' buffer-local. -;; (Stefan Monnier <monnier+gnu.emacs.sources/news/@flint.cs.yale.edu>) -;; 0.9 -- first release. -;; (Dr. Rafael Sepúlveda <drs@gnulinux.org.mx>) - -;;; Code: - -;;(require 'autoinsert) - -(defgroup apt-sources nil "Mode for editing apt source.list file" - :group 'tools - :prefix "apt-sources-") - -(defcustom apt-sources-mode-hook nil - "*Hook for customising apt-sources mode." - :type 'hook - :group 'apt-sources) - -(defcustom apt-sources-load-hook nil - "*Hook run when the `apt-sources-mode' is loaded." - :type 'hook - :group 'apt-sources) - -(defcustom apt-sources-around-lines t - "Put blank lines around the inserted source lines. -This variable can be changed by function `apt-sources-around-lines'" - :type 'boolean - :group 'apt-sources) - -(defcustom apt-sources-source-name "##\n## %s\n##\n\n" - "Format used in the name of a new source line. -This line is inserted by `apt-source-new-source' function. You can -use ANSI quoting as described in the info elisp manual, chapter -'Character Type'. The '%s' is where the name of the source line will be -inserted." - :type 'string - :group 'apt-sources) - -(defvar apt-sources-mode-syntax-table nil - "Syntax table used in `apt-sources-mode' buffers.") -(if apt-sources-mode-syntax-table - () - (setq apt-sources-mode-syntax-table (make-syntax-table)) - - ;; Support # style comments - (modify-syntax-entry ?# "<" apt-sources-mode-syntax-table) - (modify-syntax-entry ?\n "> " apt-sources-mode-syntax-table)) - -;;Regexps for identifying source line parts for font-lock. -(defvar apt-sources-font-lock-deb-regexp "\\(deb\\|deb-src\\)" - "A regexp that matches 'deb' or 'deb-src' at the begining of line.") - -(defvar apt-sources-font-lock-uri-regexp - "\\([^ ]+\\)" - "A regexp that matches the URI part of the source line.") - -(defvar apt-sources-font-lock-distribution-regexp - "\\([^ ]+\\)" - "A regexp that matches the distribution name part of the source line.") - - -(defvar apt-sources-font-lock-keywords - (list - ;; Comments - ;;'("^#.*$" . font-lock-comment-face) - ;; sources.list lines: - ;; deb http://http.us.debian.org/debian unstable main contrib - (cons - (concat "^" - apt-sources-font-lock-deb-regexp " +" - apt-sources-font-lock-uri-regexp " +" - apt-sources-font-lock-distribution-regexp - " +\\([^#\n]+\\)") - '( - (1 font-lock-constant-face) - (2 font-lock-variable-name-face) - (3 font-lock-type-face) - (4 font-lock-keyword-face)))) - "Info for function `font-lock-mode'.") - -(defvar apt-sources-mode-map nil - "Keymap used in apt-sources mode.") - -(unless apt-sources-mode-map - (let ((map (make-sparse-keymap))) - - ;; Keybindings - (define-key map (kbd "C-c C-i") 'apt-sources-new-source) - (define-key map (kbd "C-c C-l") 'apt-sources-around-lines) - (define-key map (kbd "C-c C-v") 'apt-sources-insert-local-vars) - (define-key map (kbd "C-c C-r") 'apt-sources-deb-or-src-replicate) - - (define-key map (kbd "C-c C-s") 'apt-sources-change-source-type) - (define-key map (kbd "C-c C-t") 'apt-sources-change-uri-type) - (define-key map (kbd "C-c C-a") 'apt-sources-change-uri-address) - (define-key map (kbd "C-c C-d") 'apt-sources-change-distribution) - (define-key map (kbd "C-c C-c") 'apt-sources-change-components) - - (define-key map (kbd "C-c C-n") 'apt-sources-next-source-line) - (define-key map (kbd "C-c C-p") 'apt-sources-previous-source-line) - (setq apt-sources-mode-map map) - - ;; Menu - (define-key apt-sources-mode-map [menu-bar] (make-sparse-keymap)) - (define-key apt-sources-mode-map [menu-bar apt-sources] - (cons "Apt-sources" map)) - - (define-key map [menu-bar apt-sources previous-source-line] - '("Go to previous source line" . apt-sources-previous-source-line)) - (define-key map [menu-bar apt-sources next-source-line] - '("Go to next source line" . apt-sources-next-source-line)) - (define-key map [menu-bar apt-sources separator-actions] - '("--")) - (define-key map [menu-bar apt-sources change-components] - '("Change components" . apt-sources-change-components)) - (define-key map [menu-bar apt-sources change-distribution] - '("Change distribution" . apt-sources-change-distribution)) - (define-key map [menu-bar apt-sources change-uri-address] - '("Change URI address" . apt-sources-change-uri-address)) - (define-key map [menu-bar apt-sources change-uri-type] - '("Change URI type" . apt-sources-change-uri-type)) - (define-key map [menu-bar apt-sources change-source-type] - '("Change source type" . apt-sources-change-source-type)) - (define-key map [menu-bar apt-sources separator-changes] - '("--")) - (define-key map [menu-bar apt-sources insert-local-vars] - '("Insert local variables" . apt-sources-insert-local-vars)) - (define-key map [menu-bar apt-sources around-lines] - '("Toogle empty lines between source" . apt-sources-around-lines)) - (define-key map [menu-bar apt-sources deb-or-src-replicate] - '("Copy source changing type" . apt-sources-deb-or-src-replicate)) - (define-key map [menu-bar apt-sources new-source] - '("Add new source" . apt-sources-new-source)))) - - - -;;;###autoload -(defun apt-sources-mode () - "Major mode for editing apt's sources.list file. -Sets up command `font-lock-mode'. - -\\{apt-sources-mode-map}" - (interactive) - ;; - (kill-all-local-variables) - (setq mode-name "apt-sources") - (setq major-mode 'apt-sources-mode) - (use-local-map apt-sources-mode-map) - ;; - (set (make-local-variable 'comment-start) "#") - (set (make-local-variable 'comment-start-skip) "#+ *") - (set-syntax-table apt-sources-mode-syntax-table) - ;; - (make-local-variable 'font-lock-defaults) - (setq font-lock-defaults '(apt-sources-font-lock-keywords)) - ;; - (run-hooks 'apt-sources-mode-hook)) - - - -(defun apt-sources-new-source (name) - "Insert interactively a new source line into the current buffer. -This will insert a new source in the current line. - -NAME is the name you want to this source line; it will be a comment. - If no NAME is entered, only the line will be inserted. - -You should read sources.list documentation for further explanation -of the format." - (interactive "*sName of new source: ") - - (let ((source-type (completing-read "Source type: " '(("deb" 1) ("deb-src" 2)) nil t)) - (uri-type (completing-read "URI type: " ;type used to retrieve the URI, like http, ftp, etc. - '(("cdrom:/" 1) - ("copy://" 2) - ("file://" 3) - ("ftp://" 4) - ("http://" 5) - ("https://" 6) - ("rsh://" 7) - ("ssh://" 8)) nil t)) - (uri-address (read-from-minibuffer "URI address: ")) ;URI that will be used to specify the base - ;of the Debian distribution, from which APT - ;will find the information it needs. - (distribution (completing-read "Distribution: " ;specific arquitecture or an exact path. - '(("unstable" 1) - ("testing" 2) - ("frozen" 3) - ("stable" 4) - ("sid" 5) - ("squeeze" 6) - ("wheezy" 7) - ("jessie" 8)) nil t)) - (components (completing-read "Components: " ;list of componenst used by APT. - '(("main") - ("main contrib") - ("main contrib non-free") - ("contrib") - ("contrib non-free") - ("non-free")))) - (blank-line (if apt-sources-around-lines "\n" ""))) - - (save-excursion - (beginning-of-line) - (insert blank-line) ;insert line if `apt-sources-around-lines' - (and (< 0 (length name)) - (insert (format apt-sources-source-name name))) - (insert ;insert rest of arguments except components - (format "%s %s%s %s" source-type uri-type uri-address distribution)) - - ;if `distribution' ends in '/', then don't process components. - (if (string-match "/$" distribution) - distribution - (insert " " components) - (insert blank-line))))) ;insert line if `apt-sources-around-lines' - - -(defun apt-sources-around-lines () - "Toggle insertion of newlines around a future creation of source lines. -This modifies the state of variable `apt-sources-around-lines'." - (interactive) - (setq apt-sources-around-lines (not apt-sources-around-lines)) - (message "Surrounding blank lines %s" - (if apt-sources-around-lines "On" "Off"))) - - -(defun apt-sources-insert-local-vars () - "Insert the current values of buffer local variables." - (interactive) - (end-of-buffer) - (and (not (bolp)) - (insert "\n")) ;insert a newline if the file doesn't end in a blank line. - (insert "\n" - comment-start " Local " "Variables:\n" - comment-start " mode: " (format "%s\n" (or mode-name "apt-sources")) - comment-start " End:\n")) - - -(defun apt-sources-next-source-line (arg) - "Go to the next source line. - -ARG is the prefix argument." - (interactive "p") - (let ((source-line-search (if (> arg 0) - (progn - (end-of-line) - 're-search-forward) - 're-search-backward))) - (and (apply source-line-search - '("^\\(deb \\|deb-src \\)" nil)) - (beginning-of-line)))) - - -(defun apt-sources-previous-source-line () - "Go to the previous source line." - (interactive) - (apt-sources-next-source-line -1)) - - -;;Modifying functions -(defun apt-sources-source-line-p () - "Return t if we are in an apt source line." - (save-excursion - (if (progn (beginning-of-line) - (re-search-forward "^deb[^ ]*" (line-end-position) t 1)) - t ;return t if we are in an apt source line - (message "Not in a source line!") - nil))) ;return nil if we aren't in an apt source line - - -(defun apt-sources-change-source-type () - "Change the type of the source line. -TYPE is either 'd' or 's' to change the type to 'deb' or 'deb-src'. - -This function will rise an error if we are not in a source line." - (interactive) - (and (apt-sources-source-line-p) - ;type used to retrieve the URI, like http, ftp, etc. - (let ((new-type (completing-read "'deb' or 'deb-src': " '(("deb" 1) ("deb-src" 2)) nil t))) - (save-excursion - (beginning-of-line) - (delete-region (point) (re-search-forward "^deb[^ ]*" (line-end-position) nil 1)) - (insert new-type))))) - - -(defun apt-sources-change-uri-type () - "Change the URI type of the source line. - -This function will rise an error if we are not in a source line." - (interactive) - - (and (apt-sources-source-line-p) - (let ((uri-type (completing-read "URI type: " ;type used to retrieve the URI, like http, ftp, etc. - '(("cdrom:/" 1) - ("copy://" 2) - ("file://" 3) - ("ftp://" 4) - ("http://" 5) - ("https://" 6) - ("rsh://" 7) - ("ssh://" 8)) nil t))) - (save-excursion - (beginning-of-line) - (delete-region (re-search-forward "^deb[^ ]*." (line-end-position) nil 1) - (re-search-forward ":/*" (line-end-position) nil 1)) - (insert uri-type))))) - - -(defun apt-sources-change-uri-address (uri-address) - "Change the URI address of the source line. -String URI-ADDRESS is the address (without the type of address, -ex: 'http://'). - -This function will rise an error if we are not in a source line." - (interactive "sURI address: ") - - (and (apt-sources-source-line-p) - (save-excursion - (beginning-of-line) - (delete-region (re-search-forward ":/*" (line-end-position) nil 1) - (re-search-forward "[^ ]*" (line-end-position) nil 1)) - (insert uri-address)))) - - -(defun apt-sources-change-distribution () - "Change the distribution of the source line. - -This function will rise an error if we are not in a source line." - (interactive) - - (and (apt-sources-source-line-p) - (let ((distribution (completing-read "Distribution: " ;specific arquitecture or an exact path. - '(("unstable" 1) - ("testing" 2) - ("frozen" 3) - ("stable" 4) - ("sid" 5) - ("squeeze" 6) - ("wheezy" 7) - ("jessie" 8)) nil t))) - (save-excursion - (beginning-of-line) - (delete-region (re-search-forward ":/*[^ ]*." (line-end-position) t 1) - (re-search-forward "[^ ]*" (line-end-position) t 1)) - (insert distribution))))) - - -(defun apt-sources-change-components () - "Change the components of the source line. - -This function will rise an error if we are not in a source line." - (interactive) - - (and (apt-sources-source-line-p) - (let ((components (completing-read "Components: " ;list of componenst used by APT. - '(("main") - ("main contrib") - ("main contrib non-free") - ("contrib") - ("contrib non-free") - ("non-free"))))) - (save-excursion - (beginning-of-line) - (delete-region (re-search-forward ":/*[^ ]* [^ ]*." (line-end-position) t 1) - (line-end-position)) - (and (save-excursion - (backward-char) - (looking-at "[^ ]")) - (insert " ")) - (insert components))))) - - - -(defun apt-sources-deb-or-src-replicate () - "Copy the source line and change the 'deb' to 'deb-src' or viceversa. - -This function will rise an error if we are not on a source line." - (interactive) - - (and (apt-sources-source-line-p) - (let ((copy (buffer-substring (line-beginning-position) - (line-end-position)))) - (save-excursion - (end-of-line) - (insert (concat "\n" copy)) - (beginning-of-line) - (if (re-search-forward "^deb " (line-end-position) t 1) - (progn - (backward-char) - (insert "-src")) - (delete-region (line-beginning-position) - (re-search-forward "^deb[^ ]*" (line-end-position) t 1)) - (insert "deb")))))) - - - -(run-hooks 'apt-sources-load-hook) -(add-to-list 'auto-mode-alist '("sources\\.list\\'" . apt-sources-mode)) -(add-to-list 'auto-mode-alist '("sources\\.list\\.d/.*\\.list\\'" . apt-sources-mode)) -(provide 'apt-sources) - -;;; apt-sources.el ends here diff --git a/elisp/debian-el/apt-utils.el b/elisp/debian-el/apt-utils.el deleted file mode 100644 index 297fef4..0000000 --- a/elisp/debian-el/apt-utils.el +++ /dev/null @@ -1,2116 +0,0 @@ -;;; apt-utils.el --- Emacs interface to APT (Debian package management) - -;;; Copyright (C) 2002-2010 Matthew P. Hodges - -;; Author: Matthew P. Hodges <MPHodges@member.fsf.org> -;; $Id: apt-utils.el,v 1.23 2016/11/05 22:18:48 psg Exp $ - -;; apt-utils.el 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. - -;; apt-utils.el 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. - -;;; Commentary: -;; -;; Package to interface Emacs with APT. Start things off using e.g.: -;; M-x apt-utils-show-package RET emacs21 RET -;; -;; Other packages (dependencies, conflicts etc.) can be navigated -;; using apt-utils-{next,previous}-package, -;; apt-utils-choose-package-link or apt-utils-follow-link. Return to -;; the previous package with apt-utils-view-previous-package. -;; ChangeLog and README files for the current package can easily be -;; accessed with, for example, apt-utils-view-changelog. -;; -;; For normal (i.e., not virtual) packages, the information can be -;; toggled between `package' and `showpkg' displays using -;; apt-utils-toggle-package-info; the latter is useful for the -;; "Reverse Depends". -;; -;; View the key bindings with describe-mode (bound to ? by default). - -;;; Code: - -(defconst apt-utils-version "2.12.0" - "Version number of this package.") - -(require 'browse-url) -(require 'jka-compr) -(require 'thingatpt) - -(defalias 'apt-utils-puthash 'puthash) - -;; Customizable variables - -(defgroup apt-utils nil - "Emacs interface to APT (Debian package management)." - :group 'tools - :link '(url-link "http://mph-emacs-pkgs.alioth.debian.org/AptUtilsEl.html")) - -(defcustom apt-utils-fill-packages t - "*Fill APT package names if t." - :group 'apt-utils - :type 'boolean) - -(defcustom apt-utils-show-link-info t - "*Show APT package descriptions when cycling through links if t." - :group 'apt-utils - :type 'boolean) - -(defcustom apt-utils-show-all-versions nil - "*Show APT descriptions for multiple package versions if t." - :group 'apt-utils - :type 'boolean) - -(defcustom apt-utils-automatic-update 'ask - "*Controls automatic rebuilding of APT package lists. - -If t always rebuilt when `apt-utils-timestamped-file' is newer -than the timestamp stored in `apt-utils-package-list-built'. If -equal to the symbol ask, ask the user about the update. If nil, -never update automatically." - :group 'apt-utils - :type '(choice (const :tag "Always update automatically" t) - (const :tag "Ask user about update" ask) - (const :tag "Never update automatically" nil))) - -(defcustom apt-utils-grep-dctrl-args '("-e") - "*List of arguments to pass to `apt-utils-grep-dctrl-program'." - :group 'apt-utils - :type '(repeat string)) - -(defcustom apt-utils-kill-buffer-confirmation-function 'yes-or-no-p - "Function called before killing any buffers. -The function is called with one argument, which is a prompt. -Suitable non-nil values include `yes-or-no-p', `y-or-n-p' and -`ignore'." - :group 'apt-utils - :type '(choice (const :tag "Kill buffers only after yes or no query" yes-or-no-p) - (const :tag "Kill buffers only after y or n query" y-or-n-p) - (const :tag "Never kill buffers" ignore) - (const :tag "Kill buffers without confirmation" nil))) - -(defcustom apt-utils-search-split-regexp "\\s-*&&\\s-*" - "Regular expression used to split multiple search terms. -See `apt-utils-search' and `apt-utils-search-names-only'." - :group 'apt-utils - :type 'regexp) - -(defcustom apt-utils-web-browse-debian-changelog-url - "http://packages.debian.org/changelogs/pool/main/%d/%s/%s_%v/changelog" - "Template URL for Debian ChangeLog files. -See `apt-utils-web-format-url'." - :group 'apt-utils - :type 'string) - -(defcustom apt-utils-web-browse-bug-reports-url - "http://bugs.debian.org/%p" - "Template URL for Debian bug reports. -See `apt-utils-web-format-url'." - :group 'apt-utils - :type 'string) - -(defcustom apt-utils-web-browse-copyright-url - "http://packages.debian.org/changelogs/pool/main/%d/%s/%s_%v/%p.copyright" - "Template URL for Debian copyright files. -See `apt-utils-web-format-url'." - :group 'apt-utils - :type 'string) - -(defcustom apt-utils-web-browse-versions-url - "http://packages.debian.org/%p" - "Template URL for Debian version information. -See `apt-utils-web-format-url'." - :group 'apt-utils - :type 'string) - -(defcustom apt-utils-show-package-hooks nil - "Hooks to be run after presenting package information." - :group 'apt-utils - :type 'hook) - -(defcustom apt-utils-use-current-window nil - "If non-nil always display APT utils buffers in the current window. -In this case `switch-to-buffer' is used to select the APT utils -buffer. If nil, `display-buffer' is used, and the precise -behaviour depends on the value of `pop-up-windows'." - :group 'apt-utils - :type 'boolean) - -(defcustom apt-utils-dpkg-program "/usr/bin/dpkg" - "Location of the dpkg program. -This can be set to dlocate, which has the advantage of better -performance, but uses cached data that may be out of date." - :group 'apt-utils - :type '(choice (const :tag "dpkg" "/usr/bin/dpkg") - (const : tag "dlocate" "/usr/bin/dlocate") - (file :must-match t))) - -(defcustom apt-utils-display-installed-status t - "If non-nil display the installed status of the current package." - :group 'apt-utils - :type 'boolean) - -;; Faces - -(defface apt-utils-normal-package-face - '((((class color) (background light)) - (:foreground "blue")) - (((class color) (background dark)) - (:foreground "yellow"))) - "Face used for APT normal package hyperlinks." - :group 'apt-utils) - -(defface apt-utils-normal-installed-package-face - '((((class color)) - (:inherit apt-utils-normal-package-face :bold t))) - "Face used for APT installed package hyperlinks." - :group 'apt-utils) - -(defface apt-utils-virtual-package-face - '((((class color) (background light)) - (:foreground "green4")) - (((class color) (background dark)) - (:foreground "green"))) - "Face used for APT virtual package hyperlinks." - :group 'apt-utils) - -(defface apt-utils-field-keyword-face - '((((class color) (background light)) - (:foreground "purple" :bold t)) - (((class color) (background dark)) - (:foreground "purple" :bold t))) - "Face used for APT field keywords." - :group 'apt-utils) - -(defface apt-utils-field-contents-face - '((((class color) (background light)) - (:foreground "orchid")) - (((class color) (background dark)) - (:foreground "orange"))) - "Face used for APT field contents." - :group 'apt-utils) - -(defface apt-utils-description-face - '((((class color)) - (:foreground "cadet blue"))) - "Face used for APT package description." - :group 'apt-utils) - -(defface apt-utils-version-face - '((((class color)) - (:italic t))) - "Face used for APT package versions." - :group 'apt-utils) - -(defface apt-utils-broken-face - '((((class color)) - (:foreground "red"))) - "Face used for unknown APT package." - :group 'apt-utils) - -(defface apt-utils-file-face - '((((class color)) - (:foreground "brown"))) - "Face used for files." - :group 'apt-utils) - -(defface apt-utils-installed-status-face - '((((class color)) - (:italic t))) - "Face used for installed status." - :group 'apt-utils) - -;; Other variables - -(defvar apt-utils-apt-cache-program "/usr/bin/apt-cache" - "Location of the apt-cache program.") - -(defvar apt-utils-grep-dctrl-program "/usr/bin/grep-dctrl" - "Location of the grep-dctrl program.") - -(defvar apt-utils-grep-dctrl-file-directory "/var/lib/apt/lists" - "Directory used by `apt-utils-search-grep-dctrl'. -See also `apt-utils-grep-dctrl-file-list'.") - -(defvar apt-utils-grep-dctrl-file-list nil - "List of files searched by `apt-utils-search-grep-dctrl'. -If no list is specified, this is computed on demand from files in -`apt-utils-grep-dctrl-file-directory'.") - -(defvar apt-utils-package-list nil - "Hash table containing APT packages types.") - -(defvar apt-utils-package-list-built nil - "If non-nil, a timestamp for the APT package list data.") - -(defvar apt-utils-package-history nil - "History of packages for each `apt-utils-mode' buffer.") -(make-variable-buffer-local 'apt-utils-package-history) - -(defvar apt-utils-current-links nil - "Package links associated with the `apt-utils-mode' buffer.") -(make-variable-buffer-local 'apt-utils-current-links) - -(defvar apt-utils-buffer-positions nil - "Cache of positions associated with package history. -These are stored in a hash table. See also -`apt-utils-package-history'") -(make-variable-buffer-local 'apt-utils-buffer-positions) - -(defvar apt-utils-dired-buffer nil - "Keep track of dired buffer.") - -(defvar apt-utils-automatic-update-asked nil - "Non-nil if user already asked about updating package lists.") - -(defvar apt-utils-timestamped-file "/var/cache/apt/pkgcache.bin" - "File to check timestamp of (see `apt-utils-automatic-update').") - -;; XEmacs support - -(defconst apt-utils-xemacs-p - (or (featurep 'xemacs) - (string-match "XEmacs\\|Lucid" (emacs-version))) - "True if we are using apt-utils under XEmacs.") - -;; Other version-dependent configuration - -(defalias 'apt-utils-line-end-position - (cond - ((fboundp 'line-end-position) 'line-end-position) - ((fboundp 'point-at-eol) 'point-at-eol))) - -(defalias 'apt-utils-line-beginning-position - (cond - ((fboundp 'line-beginning-position) 'line-beginning-position) - ((fboundp 'point-at-bol) 'point-at-bol))) - -(defconst apt-utils-completing-read-hashtable-p - ;; I think this is a valid way to check this feature... - (condition-case nil - (or (all-completions "" (make-hash-table)) t) - (error nil)) - "Non-nil if `completing-read' supports hash table as input.") - -(defconst apt-utils-face-property - (if (with-temp-buffer - ;; We have to rename to something without a leading space, - ;; otherwise font-lock-mode won't get activated. - (rename-buffer "*test-font-lock*") - (font-lock-mode 1) - (and (boundp 'char-property-alias-alist) - (member 'font-lock-face - (assoc 'face char-property-alias-alist)))) - 'font-lock-face - 'face) - "Use font-lock-face if `add-text-properties' supports it. -Otherwise, just use face.") - -(cond - ;; Emacs 21 - ((fboundp 'replace-regexp-in-string) - (defalias 'apt-utils-replace-regexp-in-string 'replace-regexp-in-string)) - ;; Emacs 20 - ((and (require 'dired) - (fboundp 'dired-replace-in-string)) - (defalias 'apt-utils-replace-regexp-in-string 'dired-replace-in-string)) - ;; XEmacs - ((fboundp 'replace-in-string) - (defun apt-utils-replace-regexp-in-string (regexp rep string) - (replace-in-string string regexp rep))) - ;; Bail out - (t - (error "No replace in string function found"))) - -;; Commands and functions - -;;;###autoload -(defun apt-utils-show-package (&optional new-session) - "Show information for a Debian package. -A selection of known packages is presented. See `apt-utils-mode' -for more detailed help. If NEW-SESSION is non-nil, generate a -new `apt-utils-mode' buffer." - (interactive "P") - (let ((package (apt-utils-choose-package))) - (when (> (length package) 0) - (apt-utils-show-package-1 package t new-session)))) - -(defun apt-utils-show-package-1 (package-spec &optional interactive new-session) - "Present Debian package information in a dedicated buffer. - -PACKAGE-SPEC can be either a string (the name of the package) or -a list, where the car of the list is the name of the package, and -the cdr is the package type. - -If INTERACTIVE is non-nil, then we have been called -interactively (or from a keyboard macro) via -`apt-utils-show-package'. Hence, reset the history of visited -packages. - -If NEW-SESSION is non-nil, generate a new `apt-utils-mode' -buffer." - (apt-utils-check-package-lists) - (let (package type) - (cond ((and package-spec (listp package-spec)) - (setq package (car package-spec)) - (setq type (cdr package-spec))) - ((stringp package-spec) - (setq package package-spec - type (apt-utils-package-type package)))) - ;; Set up the buffer - (cond - (new-session - (set-buffer (generate-new-buffer "*APT package info*")) - (apt-utils-mode) - (apt-utils-update-mode-name)) - ((eq major-mode 'apt-utils-mode) - ;; do nothing - ) - (t - (set-buffer (get-buffer-create "*APT package info*")) - (apt-utils-mode))) - ;; If called interactively, initialize apt-utils-package-history - (when (or interactive new-session) - (setq apt-utils-package-history (cons (cons package type) nil)) - (if (hash-table-p apt-utils-buffer-positions) - (clrhash apt-utils-buffer-positions) - (setq apt-utils-buffer-positions (make-hash-table :test 'equal)))) - (let ((inhibit-read-only t)) - (erase-buffer) - (cond - ((memq type '(normal normal-installed)) - (call-process apt-utils-apt-cache-program nil '(t nil) nil "show" package) - ;; Remove old versions if not wanted - (unless apt-utils-show-all-versions - (goto-char (point-min)) - (re-search-forward "^$") - (unless (eobp) - (delete-region (point) (point-max)))) - (apt-utils-add-package-links)) - ;; Virtual package or normal package w/ showpkg - ((memq type '(virtual normal-showpkg)) - (call-process apt-utils-apt-cache-program nil '(t nil) nil "showpkg" package) - (apt-utils-add-showpkg-links package)) - ;; Normal search - ((equal type 'search) - (insert (format "Debian package search for %s\n\n" package)) - (apply 'call-process apt-utils-apt-cache-program nil '(t nil) nil - "search" "--" - (split-string package apt-utils-search-split-regexp)) - (apt-utils-sort-result) - (apt-utils-add-search-links 'search)) - ;; Search for names only - ((equal type 'search-names-only) - (insert (format "Debian package search (names only) for %s\n\n" package)) - (apply 'call-process apt-utils-apt-cache-program nil '(t nil) nil - "search" "--names-only" "--" - (split-string package apt-utils-search-split-regexp)) - (apt-utils-sort-result) - (apt-utils-add-search-links 'search-names-only)) - ;; Search for file names - ((equal type 'search-file-names) - (insert (format "Debian package search (file names) for %s\n\n" package)) - (apply 'call-process apt-utils-dpkg-program nil t nil - "-S" (list package)) - (apt-utils-sort-result) - (apt-utils-add-search-links 'search-file-names)) - ;; grep-dctrl search - ((equal type 'search-grep-dctrl) - (insert (format "grep-dctrl search for %s\n\n" - (concat (format "\"%s\" " (car package)) - (mapconcat 'identity (cdr package) " ")))) - (apply 'call-process apt-utils-grep-dctrl-program nil t nil package) - (apt-utils-sort-result) - ;; Don't check installed status; may take forever - (let ((apt-utils-display-installed-status nil)) - (apt-utils-add-package-links)))) - (if apt-utils-use-current-window - (switch-to-buffer (current-buffer)) - (select-window (display-buffer (current-buffer)))) - ;; Point only needs setting for new sessions or when choosing - ;; new packages with apt-utils-follow-link or - ;; apt-utils-choose-package-link. - (goto-char (point-min)) - (run-hooks 'apt-utils-show-package-hooks))) - (set-buffer-modified-p nil) - (setq buffer-read-only t)) - -(defun apt-utils-list-package-files () - "List the files associated with the current package. -The list appears in a `dired-mode' buffer. Only works for -installed packages; uses `apt-utils-dpkg-program'." - (interactive) - (let ((package (caar apt-utils-package-history)) - (type (cdar apt-utils-package-history)) - files) - (setq files (apt-utils-get-package-files package)) - ;; Some meta packages contain only directories, so - ;; apt-utils-get-package-files returns '("/."); however, we don't - ;; want to list /. - (when (equal files '("/.")) - (setq files nil)) - (cond - ((memq type '(normal normal-showpkg normal-installed)) - (if files - (progn - ;; Some versions of Emacs won't update dired for the same - ;; directory name if it already exists - (if (buffer-live-p apt-utils-dired-buffer) - (kill-buffer apt-utils-dired-buffer)) - (setq apt-utils-dired-buffer (dired-noselect files)) - (display-buffer apt-utils-dired-buffer)) - (message "Package does not contain any files/is not installed."))) - (t - (message "No files associated for type: %s." type))))) - -(defalias 'apt-utils-view-package-files 'apt-utils-list-package-files) - -(defun apt-utils-get-package-files (package &optional filter installed) - "Return a list of files belonging to package PACKAGE. -With optional argument FILTER, return files matching this regular -expression. - -With non-nil INSTALLED, return t if package is installed, -otherwise nil." - (let (files) - (catch 'installed - (with-temp-buffer - (call-process apt-utils-dpkg-program nil t nil "-L" package) - ;; Check for files - (cond - ((or (search-backward "does not contain any files" nil t) - (search-backward "not installed" nil t) - ;; dlocate returns nothing for uninstalled packages - (or (zerop (buffer-size)))) - (when installed - (throw 'installed nil))) - (installed - (throw 'installed t)) - (t - (setq files (split-string (buffer-string) "\n")) - ;; Keep regular files or top directory (for dired) - (setq files - (delq nil - (mapcar (lambda (elt) - (if (and (or (file-regular-p elt) - (string-equal "/." elt)) - (string-match (or filter ".") elt)) - elt - nil)) - files)))))) - files))) - -(defun apt-utils-current-package-installed-p () - "Return non-nil if the current-package is installed." - (apt-utils-get-package-files (caar apt-utils-package-history) nil t)) - -;;;###autoload -(defun apt-utils-search () - "Search Debian packages for regular expression. -To search for multiple patterns use a string like \"foo && bar\". -The regular expression used to split the -terms (`apt-utils-search-split-regexp') is customisable." - (interactive) - (apt-utils-search-internal 'search - "Search packages for regexp: ")) - -(defun apt-utils-search-names-only () - "Search Debian package names for regular expression. -To search for multiple patterns use a string like \"foo && bar\". -The regular expression used to split the -terms (`apt-utils-search-split-regexp') is customisable." - (interactive) - (apt-utils-search-internal 'search-names-only - "Search package names for regexp: ")) - -(defun apt-utils-search-file-names () - "Search Debian file names for string." - (interactive) - (apt-utils-search-internal 'search-file-names - "Search file names for string: ")) - -(defun apt-utils-search-internal (type prompt) - "Search Debian packages for regular expression or string. -The type of search is specified by TYPE, the prompt for the -search is specified by PROMPT." - (apt-utils-check-package-lists) - (let ((regexp (read-from-minibuffer prompt))) - ;; Set up the buffer - (cond - ((eq major-mode 'apt-utils-mode) - ;; do nothing - ) - (t - (set-buffer (get-buffer-create "*APT package info*")) - (apt-utils-mode))) - (let ((inhibit-read-only t) - result) - (erase-buffer) - ;; Can't search for string starting with "-" because the "--" - ;; option isn't understood by dpkg or dlocate - (when (and (eq type 'search-file-names) - (string-match "^-" regexp)) - (setq regexp (apt-utils-replace-regexp-in-string "^-+" "" regexp))) - (insert (format "Debian package search%s for %s\n\n" - (cond ((eq type 'search-names-only) " (names only)") - ((eq type 'search-file-names) " (file names)") - (t "")) - regexp)) - (setq result - (cond - ((eq type 'search) - (setq apt-utils-package-history (cons (cons regexp 'search) nil)) - (apply 'call-process apt-utils-apt-cache-program nil '(t nil) nil - "search" "--" - (split-string regexp apt-utils-search-split-regexp))) - ((eq type 'search-names-only) - (setq apt-utils-package-history (cons (cons regexp 'search-names-only) nil)) - (apply 'call-process apt-utils-apt-cache-program nil '(t nil) nil - "search" "--names-only" "--" - (split-string regexp apt-utils-search-split-regexp))) - - ((eq type 'search-file-names) - (setq apt-utils-package-history (cons (cons regexp 'search-file-names) nil)) - (apply 'call-process apt-utils-dpkg-program nil t nil - "-S" (list regexp))))) - (if (hash-table-p apt-utils-buffer-positions) - (clrhash apt-utils-buffer-positions) - (setq apt-utils-buffer-positions (make-hash-table :test 'equal))) - (if (eq result 0) - (apt-utils-add-search-links type) - (if (hash-table-p apt-utils-current-links) - (clrhash apt-utils-current-links))) - (goto-char (point-min)) - ;; Sort results - (apt-utils-sort-result) - (set-buffer-modified-p nil) - (setq buffer-read-only t) - (display-buffer (current-buffer))))) - -(defun apt-utils-search-grep-dctrl () - "Search Debian packages for regular expression using grep-dctrl." - (interactive) - (apt-utils-check-package-lists) - (let (args - (fields (apt-utils-read-fields "Search package fields: ")) - (show (apt-utils-read-fields "Show package fields: ")) - (regexp (read-from-minibuffer "Search regexp: "))) - ;; Check args - (cond - ((equal (length fields) 0) - (error "No fields selected for search")) - ((equal (length show) 0) - (error "No fields selected for show")) - ((equal (length regexp) 0) - (error "No regexp selected"))) - (setq fields (concat "-F" fields)) - (setq show (concat "-s" show)) - (cond - ((eq major-mode 'apt-utils-mode) - ;; do nothing - ) - (t - (set-buffer (get-buffer-create "*APT package info*")) - (apt-utils-mode))) - (let ((inhibit-read-only t) - result) - (erase-buffer) - ;; Construct argument list (need to keep this) - (setq args (append (list regexp fields show) apt-utils-grep-dctrl-args - (or apt-utils-grep-dctrl-file-list - (directory-files apt-utils-grep-dctrl-file-directory - t "_Packages$")))) - (insert (format "grep-dctrl search for %s\n\n" - (mapconcat - (lambda (elt) - (if (string-equal regexp elt) - (format "\"%s\"" regexp) - elt)) - args " "))) - (setq result - (apply 'call-process - apt-utils-grep-dctrl-program nil t nil args)) - (setq apt-utils-package-history (cons (cons args 'search-grep-dctrl) nil)) - (if (hash-table-p apt-utils-buffer-positions) - (clrhash apt-utils-buffer-positions) - (setq apt-utils-buffer-positions (make-hash-table :test 'equal))) - (if (eq result 0) - (apt-utils-add-package-links) - (if (hash-table-p apt-utils-current-links) - (clrhash apt-utils-current-links))) - (goto-char (point-min)) - (set-buffer-modified-p nil) - (setq buffer-read-only t) - (display-buffer (current-buffer))))) - -(defun apt-utils-read-fields (prompt) - "Read fields for `apt-utils-search-grep-dctrl'. -Use PROMPT for `completing-read'." - (let ((chosen "foo") - (completion-ignore-case t) - ;; Why can't I use '(...) for the list? - (keywords (list "Architecture" "Bugs" "Conffiles" "Conflicts" - "Depends" "Description" "Enhances" "Essential" - "Filename" "Installed-Size" "MD5sum" "Maintainer" - "Origin" "Package" "Pre-Depends" "Priority" - "Provides" "Recommends" "Replaces" "Section" - "Size" "Source" "Suggests" "Tag" "Task" "Version" - "url")) - fields) - (while (> (length chosen) 0) - (setq chosen - (completing-read prompt - (mapcar (lambda (elt) - (list elt elt)) - keywords) - nil - t)) - (setq keywords (delete chosen keywords)) - (if (stringp fields) - (progn - (when (> (length chosen) 0) - (setq fields (concat fields "," chosen)))) - (setq fields chosen))) - fields)) - -(defun apt-utils-toggle-package-info () - "Toggle between package and showpkg info for normal packages." - (interactive) - (unless (equal major-mode 'apt-utils-mode) - (error "Not in APT utils buffer")) - (let ((package (caar apt-utils-package-history)) - (type (cdar apt-utils-package-history)) - posns) - (cond - ((memq type '(normal normal-installed)) - (setq posns (apt-utils-update-buffer-positions 'toggle)) - (setq apt-utils-package-history - (cons (cons package 'normal-showpkg) - (cdr apt-utils-package-history))) - (apt-utils-show-package-1 (car apt-utils-package-history) nil) - (goto-char (car posns)) - (set-window-start (selected-window) (cadr posns))) - ((equal type 'normal-showpkg) - (setq posns (apt-utils-update-buffer-positions 'toggle)) - (setq apt-utils-package-history - (cons (cons package 'normal) - (cdr apt-utils-package-history))) - (apt-utils-show-package-1 (car apt-utils-package-history) nil) - (goto-char (car posns)) - (set-window-start (selected-window) (cadr posns))) - ((equal type 'virtual) - (message "Cannot toggle info for virtual packages.")) - ((memq type '(search search-names-only - search-file-names - search-grep-dctrl)) - (message "Cannot toggle info for searches."))))) - -(defun apt-utils-normal-package-p () - "Return non-nil if the current package is a normal package. -That is, not a normal-showpkg, search or a virtual package." - (eq (cdar apt-utils-package-history) 'normal)) - -(defun apt-utils-toggle-package-p () - "Return non-nil if we can toggle between package and showpkg. -See also `apt-utils-toggle-package-info'." - (memq (cdar apt-utils-package-history) '(normal normal-showpkg normal-installed))) - -(defun apt-utils-check-package-lists () - "Determine whether package lists need rebuilding." - (apt-utils-update-mode-name) - (cond - ((null apt-utils-package-list-built) - (apt-utils-build-package-list)) - ((and (apt-utils-packages-needs-update) - ;; Only act for non-nil apt-utils-automatic-update - apt-utils-automatic-update - (cond - ((eq apt-utils-automatic-update t)) - ((eq apt-utils-automatic-update 'ask) - (unless apt-utils-automatic-update-asked - (setq apt-utils-automatic-update-asked t) - (yes-or-no-p - "APT package lists may be out of date. Update them? "))))) - (apt-utils-build-package-list t)))) - -;; Find ChangeLog files - -(defun apt-utils-view-changelog () - "Find ChangeLog for the current package." - (interactive) - (cond - ((not (equal major-mode 'apt-utils-mode)) - (message "Not in APT utils buffer.")) - ((not (memq (cdar apt-utils-package-history) '(normal normal-showpkg normal-installed))) - (message "Not a normal package.")) - (t - (let* ((package (caar apt-utils-package-history)) - (file (apt-utils-changelog-file package))) - (if file - (apt-utils-view-file file) - (message "No ChangeLog file found for %s." package)))))) - -(defun apt-utils-changelog-file (&optional package) - "Find ChangeLog file for PACKAGE or the current package." - (unless package (setq package (caar apt-utils-package-history))) - (let ((file - (apt-utils-find-readable-file - (format "/usr/share/doc/%s/" package) - '("CHANGELOG" "ChangeLog" "Changelog" "changelog") - '("" ".gz")))) - file)) - -;; Find Debian ChangeLog files - -(defun apt-utils-view-debian-changelog () - "Find Debian ChangeLog for the current package." - (interactive) - (cond - ((not (equal major-mode 'apt-utils-mode)) - (message "Not in APT utils buffer.")) - ((not (memq (cdar apt-utils-package-history) '(normal normal-showpkg normal-installed))) - (message "Not a normal package.")) - (t - (let* ((package (caar apt-utils-package-history)) - (file (apt-utils-debian-changelog-file package))) - (if file - (apt-utils-view-file file) - (message "No Debian ChangeLog file found for %s." package)))))) - -(defun apt-utils-debian-changelog-file (&optional package) - "Find Debian ChangeLog file for PACKAGE or the current package." - (unless package (setq package (caar apt-utils-package-history))) - (let ((file - (apt-utils-find-readable-file - (format "/usr/share/doc/%s/" package) - '("changelog.Debian") - '(".gz")))) - file)) - -;; Find NEWS files - -(defun apt-utils-view-news () - "Find NEWS for the current package." - (interactive) - (cond - ((not (equal major-mode 'apt-utils-mode)) - (message "Not in APT utils buffer.")) - ((not (memq (cdar apt-utils-package-history) '(normal normal-showpkg normal-installed))) - (message "Not a normal package.")) - (t - (let* ((package (caar apt-utils-package-history)) - (file (apt-utils-news-file package))) - (if file - (apt-utils-view-file file) - (message "No NEWS file found for %s." package)))))) - -(defun apt-utils-news-file (&optional package) - "Find NEWS file for PACKAGE or the current package." - (unless package (setq package (caar apt-utils-package-history))) - (let ((file - (apt-utils-find-readable-file - (format "/usr/share/doc/%s/" package) - '("NEWS") - '("" ".gz")))) - file)) - -;; Find Debian NEWS files - -(defun apt-utils-view-debian-news () - "Find Debian NEWS for the current package." - (interactive) - (cond - ((not (equal major-mode 'apt-utils-mode)) - (message "Not in APT utils buffer.")) - ((not (memq (cdar apt-utils-package-history) '(normal normal-showpkg normal-installed))) - (message "Not a normal package.")) - (t - (let* ((package (caar apt-utils-package-history)) - (file (apt-utils-debian-news-file package))) - (if file - (apt-utils-view-file file) - (message "No Debian NEWS file found for %s." package)))))) - -(defun apt-utils-debian-news-file (&optional package) - "Find Debian NEWS file for PACKAGE or the current package." - (unless package (setq package (caar apt-utils-package-history))) - (let ((file - (apt-utils-find-readable-file - (format "/usr/share/doc/%s/" package) - '("NEWS.Debian") - '(".gz")))) - file)) - -;; Find README files - -(defun apt-utils-view-readme () - "Find README for the current package." - (interactive) - (cond - ((not (equal major-mode 'apt-utils-mode)) - (message "Not in APT utils buffer.")) - ((not (memq (cdar apt-utils-package-history) '(normal normal-showpkg normal-installed))) - (message "Not a normal package.")) - (t - (let* ((package (caar apt-utils-package-history)) - (file (apt-utils-readme-file package))) - (if file - (apt-utils-view-file file) - (message "No README file found for %s." package)))))) - -(defun apt-utils-readme-file (&optional package) - "Find README file for PACKAGE or the current package." - (unless package (setq package (caar apt-utils-package-history))) - (let ((file - (apt-utils-find-readable-file - (format "/usr/share/doc/%s/" package) - '("README" "readme") - '("" ".gz")))) - file)) - -;; Find Debian README files - -(defun apt-utils-view-debian-readme () - "Find Debian README for the current package." - (interactive) - (cond - ((not (equal major-mode 'apt-utils-mode)) - (message "Not in APT utils buffer.")) - ((not (memq (cdar apt-utils-package-history) '(normal normal-showpkg normal-installed))) - (message "Not a normal package.")) - (t - (let* ((package (caar apt-utils-package-history)) - (file (apt-utils-debian-readme-file package))) - (if file - (apt-utils-view-file file) - (message "No Debian README file found for %s." package)))))) - -(defun apt-utils-debian-readme-file (&optional package) - "Find Debian README file for PACKAGE or the current package." - (unless package (setq package (caar apt-utils-package-history))) - (let ((file - (apt-utils-find-readable-file - (format "/usr/share/doc/%s/" package) - '("README.Debian" "README.debian") - '("" ".gz")))) - file)) - -;; Find copyright files - -(defun apt-utils-view-copyright () - "Find copyright file for the current package." - (interactive) - (cond - ((not (equal major-mode 'apt-utils-mode)) - (message "Not in APT utils buffer.")) - ((not (memq (cdar apt-utils-package-history) '(normal normal-showpkg normal-installed))) - (message "Not a normal package.")) - (t - (let* ((package (caar apt-utils-package-history)) - (file (apt-utils-copyright-file package))) - (if file - (apt-utils-view-file file) - (message "No copyright file found for %s." package)))))) - -(defun apt-utils-copyright-file (&optional package) - "Find copyright file for PACKAGE or the current package." - (unless package (setq package (caar apt-utils-package-history))) - (let ((file - (apt-utils-find-readable-file - (format "/usr/share/doc/%s/copyright" package) - '("") - '("")))) - file)) - -(defun apt-utils-view-man-page () - "View man page for the current package. -If there is more than one man page associated with the package, -offer a choice." - (interactive) - (cond - ((not (equal major-mode 'apt-utils-mode)) - (message "Not in APT utils buffer.")) - ((not (memq (cdar apt-utils-package-history) '(normal normal-showpkg normal-installed))) - (message "Not a normal package.")) - (t - (let ((package (caar apt-utils-package-history)) - (regexp - "^.*/man/\\([a-zA-Z_/.]+\\)?man[0-9]/\\(.*\\)\\.\\([0-9a-z]+\\)\\.gz") - choice chosen files table) - (setq files (apt-utils-get-package-files package - "/man/.*\\.gz$")) - (cond - ((null files) - (message "No man pages found for %s." package)) - ((not (cdr files)) - (setq chosen (car files))) - (t - (setq table (mapcar - (lambda (file) - (setq choice - (with-temp-buffer - (insert file) - (when (re-search-backward regexp nil t) - (replace-match "\\2 (\\1\\3)" nil nil)) - (buffer-string))) - (cons choice file)) - files)) - (setq chosen - (cdr (assoc - (let ((completion-ignore-case t)) - (completing-read "Choose man page: " table nil t)) - table))))) - (when chosen - (if (fboundp 'woman-find-file) - (woman-find-file chosen) - (manual-entry chosen))))))) - -(defun apt-utils-view-emacs-startup-file () - "View Emacs startup file for the current package. -If there is more than one file associated with the package, offer -a choice." - (interactive) - (cond - ((not (equal major-mode 'apt-utils-mode)) - (message "Not in APT utils buffer.")) - ((not (memq (cdar apt-utils-package-history) '(normal normal-showpkg normal-installed))) - (message "Not a normal package.")) - (t - (let ((package (caar apt-utils-package-history)) - chosen files table) - (setq files - (or (apt-utils-get-package-files package - "^/etc/emacs/site-start.d/.*") - (and (boundp 'debian-emacs-flavor) - (apt-utils-get-package-files - package - (format "^/etc/%s/site-start.d/.*" - (symbol-name debian-emacs-flavor)))))) - (cond - ((null files) - (message "No Emacs startup files found for %s." package)) - ((not (cdr files)) - (setq chosen (car files))) - (t - (setq table (mapcar - (lambda (file) - (cons file file)) - files)) - (setq chosen - (cdr (assoc - (let ((completion-ignore-case t)) - (completing-read "Choose Emacs startup file: " table nil t)) - table))))) - (when chosen - (apt-utils-view-file chosen)))))) - -(defun apt-utils-view-version () - "View installed version information for current package." - (interactive) - (let ((package (caar apt-utils-package-history)) - (type (cdar apt-utils-package-history))) - (if (memq type '(normal normal-showpkg normal-installed)) - (let ((info (apt-utils-get-installed-info package))) - (if info - (message (apply #'format - "%s: version %s (Desired = %s; Status = %s; Error = %s)" - package info)) - (message "Not installed; not known to dkpg"))) - (message "Can show version info only for normal packages")))) - -(defun apt-utils-get-installed-info (package) - "Return list of installation information for package PACKAGE." - (let ((desired-list '((?u "Unknown") - (?i "Install") - (?r "Remove") - (?p "Purge") - (?h "Hold"))) - (status-list '((?n "Not installed") - (?i "Installed") - (?c "Config files") - (?u "Unpackage") - (?f "Failed config") - (?h "Half installed"))) - (err-list '((? "None") - (?h "Hold") - (?r "Reinstall required") - (?x "Hold + reinstall required"))) - desired status err status-bad err-bad) - (unless (eq package 'broken) - (with-temp-buffer - (let ((process-environment (append '("COLUMNS=200") (copy-alist process-environment)))) - (call-process apt-utils-dpkg-program nil t nil "-l" package)) - (when (re-search-backward - (format "^\\([a-z ][a-z ][a-z ]\\)\\s-+%s\\s-+\\(\\S-+\\)" - (regexp-quote package)) nil t) - (progn - (setq desired (aref (match-string 1) 0) - status (aref (match-string 1) 1) - err (aref (match-string 1) 2) - status-bad (not (eq status (downcase status))) - err-bad (not (eq err (downcase err)))) - ;; Return list of information - (list (match-string 2) ; version - (cadr (assoc desired desired-list)) - (concat (cadr (assoc (downcase status) status-list)) - (and status-bad " [bad]")) - (concat (cadr (assoc (downcase err) err-list)) - (and err-bad " [bad]"))))))))) - -(defun apt-utils-insert-installed-info (package) - "Insert installed information for package PACKAGE at point." - (let ((posn (point))) - (insert (format " (%s)" (or (nth 2 (apt-utils-get-installed-info package)) - "Not installed; not known to dpkg"))) - (add-text-properties (1+ posn) - (point) - '(face apt-utils-installed-status-face)))) - -;; File-related utility functions - -(defun apt-utils-find-readable-file (dir prefixes suffixes) - "Find a readable file composed of directory prefix and suffix. -Directory is DIR, prefix is one of PREFIXES and suffix is one of -SUFFIXES." - (catch 'found - (dolist (prefix prefixes) - (dolist (suffix suffixes) - (when (file-readable-p (concat dir prefix suffix)) - (throw 'found (concat dir prefix suffix))))) - nil)) ; Return nil, if no file found - -(defun apt-utils-view-file (file) - "View file FILE in function `view-mode'." - (cond ((string-match "\\.gz$" file) - (if (fboundp 'with-auto-compression-mode) - (with-auto-compression-mode - (view-file file)) - (auto-compression-mode 1) - (view-file file))) - (t - (view-file file)))) - -;; Follow hyperlinks - -(defun apt-utils-follow-link (new-session) - "Follow hyperlink at point. -With non-nil NEW-SESSION, follow link in a new buffer." - (interactive "P") - (unless (equal major-mode 'apt-utils-mode) - (error "Not in APT utils buffer")) - (let ((package - (cadr - (member 'apt-package (text-properties-at (point)))))) - (apt-utils-follow-link-internal package new-session))) - -(defun apt-utils-mouse-follow-link (event) - "Follow hyperlink at mouse click. -Argument EVENT is a mouse event." - (interactive "e") - (let (package) - (save-selected-window - (mouse-set-point event) - (setq package (apt-utils-package-at-point)) - (apt-utils-follow-link-internal package nil)))) - -(defun apt-utils-package-at-point () - "Return name of package at point, if any." - (cadr - (member 'apt-package (text-properties-at - (point))))) - -(defun apt-utils-follow-link-internal (package new-session) - "Follow hyperlink for PACKAGE. -With non-nil NEW-SESSION, follow link in a new buffer." - (cond - ((equal package 'broken) - (message "Package name is broken somehow.")) - (package - (unless new-session - (apt-utils-update-buffer-positions 'forward)) - (apt-utils-show-package-1 package nil new-session) - (unless new-session - (setq apt-utils-package-history - (cons (cons package (apt-utils-package-type package)) - apt-utils-package-history)))) - (t - (message "No known package at point.")))) - -;; Go to previous package in list - -(defun apt-utils-view-previous-package () - "Go back to previous package displayed." - (interactive) - (unless (equal major-mode 'apt-utils-mode) - (error "Not in APT utils buffer")) - (if (cdr apt-utils-package-history) - (progn - (let ((posns (apt-utils-update-buffer-positions 'backward))) - (apt-utils-show-package-1 (cadr apt-utils-package-history) nil) - (goto-char (car posns)) - (set-window-start (selected-window) (cadr posns))) - (setq apt-utils-package-history (cdr apt-utils-package-history))) - (message "No further package history."))) - -(defun apt-utils-previous-package-p () - "Return non-nil if there is a previous entry in the package history. -See also `apt-utils-package-history'." - (cdr apt-utils-package-history)) - -;; Adapted from widget-move - -(defun apt-utils-next-package (&optional arg) - "Move point to the ARG next package. -ARG may be negative to move backward." - (interactive "p") - (unless (equal major-mode 'apt-utils-mode) - (error "Not in APT utils buffer")) - (cond - ;; No links - ((or (null apt-utils-current-links) - (= (hash-table-count apt-utils-current-links) 0)) - (message "No package links.")) - ;; One link - ((and (= (hash-table-count apt-utils-current-links) 1) - (not (eq (cdar apt-utils-package-history) 'search-file-names))) - (goto-char (point-min)) - (goto-char (next-single-property-change (point) - 'apt-package))) - (t - (let ((old (apt-utils-package-at))) - ;; Forward. - (while (> arg 0) - (cond ((eobp) - (goto-char (point-min))) - (t - (goto-char (or (next-single-property-change - (point) 'apt-package) - (point-max))))) - (let ((new (apt-utils-package-at))) - (when new - (unless (eq new old) - (setq arg (1- arg)) - (setq old new))))) - ;; Backward. - (while (< arg 0) - (cond ((bobp) - (goto-char (point-max))) - (t - (goto-char (or (previous-single-property-change - (point) 'apt-package) - (point-min))))) - (let ((new (apt-utils-package-at))) - (when new - (unless (eq new old) - (setq arg (1+ arg)))))) - ;; Go to beginning of field. - (let ((new (apt-utils-package-at))) - (while (eq (apt-utils-package-at) new) - (backward-char))) - (forward-char)))) - ;; Echo some info - (when apt-utils-show-link-info - (apt-utils-package-at-message))) - -(defun apt-utils-previous-package (&optional arg) - "Move point to the ARG previous package. -ARG may be negative to move forward." - (interactive "p") - (apt-utils-next-package (- arg))) - -;; Choose a package from the known links - -(defun apt-utils-choose-package-link (new-session) - "Choose a Debian package from a list of links. -With non-nil NEW-SESSION, follow link in a new buffer." - (interactive "P") - (apt-utils-choose-package-link-internal new-session)) - -(defun apt-utils-choose-package-link-internal (new-session) - "Choose a Debian package from a list of links. -With non-nil NEW-SESSION, follow link in a new buffer." - (cond - ((not (equal major-mode 'apt-utils-mode)) - (error "Not in APT utils buffer")) - ((= (hash-table-count apt-utils-current-links) 0) - (message "No package links.")) - (t - (let* ((PC-word-delimiters "-") - (package - (completing-read "Choose related Debian package: " - (cond - (apt-utils-completing-read-hashtable-p - apt-utils-current-links) - (t - (apt-utils-build-completion-table - apt-utils-current-links))) - nil t))) - (when (> (length package) 0) - (unless new-session - (apt-utils-update-buffer-positions 'forward)) - (apt-utils-show-package-1 package nil new-session) - (unless new-session - (setq apt-utils-package-history - (cons (cons package (apt-utils-package-type package)) - apt-utils-package-history)))))))) - -(defun apt-utils-build-package-list (&optional force) - "Build list of Debian packages known to APT. -With optional argument FORCE, rebuild the packages lists even if -they are defined. When package lists are not up-to-date, this is -indicated in `mode-name'." - (when (or force (null apt-utils-package-list-built)) - (unwind-protect - (progn - (setq apt-utils-package-list-built nil - apt-utils-automatic-update-asked nil) - (message "Building Debian package lists...") - ;; Hash table listing package types - (if (hash-table-p apt-utils-package-list) - (clrhash apt-utils-package-list) - (setq apt-utils-package-list (make-hash-table :test 'equal))) - ;; All packages except virtual ones - (with-temp-buffer - ;; Virtual and normal packages - (call-process apt-utils-apt-cache-program nil '(t nil) nil "pkgnames") - (goto-char (point-min)) - (while (not (eobp)) - (apt-utils-puthash (buffer-substring (apt-utils-line-beginning-position) - (apt-utils-line-end-position)) - 'virtual apt-utils-package-list) - (forward-line 1)) - ;; Normal packages - (erase-buffer) - (call-process apt-utils-apt-cache-program nil '(t nil) nil "pkgnames" - "-o" "APT::Cache::AllNames=0") - (goto-char (point-min)) - (while (not (eobp)) - (apt-utils-puthash (buffer-substring (apt-utils-line-beginning-position) - (apt-utils-line-end-position)) - 'normal apt-utils-package-list) - (forward-line 1)) - ;; Installed packages - (erase-buffer) - (call-process apt-utils-dpkg-program nil t nil "-l") - (goto-char (point-min)) - (let (package) - (while (not (eobp)) - (when (looking-at "^ii") - (setq package - (nth 1 (split-string (buffer-substring - (apt-utils-line-beginning-position) - (apt-utils-line-end-position)) - "\\s-+"))) - (apt-utils-puthash package - 'normal-installed - apt-utils-package-list)) - (forward-line 1)))) - (message "Building Debian package lists...done.") - (setq apt-utils-package-list-built (current-time)) - (apt-utils-update-mode-name)) - (unless apt-utils-package-list-built - (message "Building Debian package lists...interrupted.") - (apt-utils-update-mode-name) - (if (hash-table-p apt-utils-package-list) - (clrhash apt-utils-package-list)))))) - -(defun apt-utils-rebuild-package-lists () - "Rebuild the APT package lists." - (interactive) - (apt-utils-build-package-list t)) - -(defun apt-utils-choose-package () - "Choose a Debian package name." - (let ((package - (and (eq major-mode 'apt-utils-mode) - (cadr (member 'apt-package - (text-properties-at (point)))))) - (PC-word-delimiters "-")) - (when (not (stringp package)) - (setq package (word-at-point))) - (completing-read (if package - (format "Choose Debian package (%s): " package) - "Choose Debian package: ") - 'apt-utils-choose-package-completion - nil t package))) - -;; emacs 22 has `dynamic-completion-table' to help construct a -;; function like this, but emacs 21 and xemacs 21) don't -(defun apt-utils-choose-package-completion (str pred all) - "Apt package name completion handler, for `completing-read'." - (let ((enable-recursive-minibuffers t)) - (apt-utils-check-package-lists)) - (cond ((null all) - (try-completion str (if apt-utils-completing-read-hashtable-p - apt-utils-package-list - (apt-utils-build-completion-table - apt-utils-package-list)) - pred)) - ((eq all t) - (all-completions str (if apt-utils-completing-read-hashtable-p - apt-utils-package-list - (apt-utils-build-completion-table - apt-utils-package-list)) - pred)) - ((eq all 'lambda) - (if (fboundp 'test-completion) - ;; `test-completion' is new in emacs22, and it takes - ;; hashtables, so don't really need to test - ;; apt-utils-completing-read-hashtable-p - (test-completion str (if apt-utils-completing-read-hashtable-p - apt-utils-package-list - (apt-utils-build-completion-table - apt-utils-package-list)) - pred) - (and (gethash str apt-utils-package-list) - t))))) - -(defun apt-utils-build-completion-table (hash) - "Build completion table for packages using keys of hashtable HASH." - (let (ret) - (maphash (lambda (key value) - (setq ret (cons (list key) ret))) - hash) - ret)) - -;; Add hyperlinks - -(defun apt-utils-add-package-links () - "Add hyperlinks to related Debian packages." - (let ((keywords '("Conflicts" "Depends" "Enhances" "Package" - "Pre-Depends" "Provides" "Recommends" "Replaces" - "Suggests")) - match) - (if (hash-table-p apt-utils-current-links) - (clrhash apt-utils-current-links) - (setq apt-utils-current-links (make-hash-table :test 'equal))) - (goto-char (point-min)) - (while (re-search-forward "^\\([^ \n:]+\\):\\( \\|$\\)" - (point-max) t) - (setq match (match-string 1)) - (add-text-properties (if (looking-at "$") - (point) ;; Conffiles (also see below) - (1- (point))) - (save-excursion - (beginning-of-line) - (point)) - `(,apt-utils-face-property apt-utils-field-keyword-face)) - (cond - ((member match keywords) - ;; Remove newline characters in field - (let ((end (apt-field-end-position))) - (subst-char-in-region (point) end ?\n ?\ ) - (canonically-space-region (point) end)) - ;; Find packages - (let ((packages (apt-utils-current-field-packages)) - (inhibit-read-only t) - face - length length-no-version - package) - (while packages - (setq package (car packages)) - (setq length (length package)) - ;; Remove version info (in parenthesis), and whitespace - (setq package (apt-utils-replace-regexp-in-string - "\\((.*)\\|\\s-+\\)" "" package)) - (setq length-no-version (length package)) - ;; Package type - (cond - ((equal (apt-utils-package-type package t) 'normal) - (setq face 'apt-utils-normal-package-face)) - ((equal (apt-utils-package-type package t) 'normal-installed) - (setq face 'apt-utils-normal-installed-package-face)) - ((equal (apt-utils-package-type package t) 'virtual) - (setq face 'apt-utils-virtual-package-face)) - (t - (setq face 'apt-utils-broken-face) - (setq package 'broken))) - ;; Store package links - (apt-utils-current-links-add-package package) - ;; Add text properties - (add-text-properties (point) (+ (point) length-no-version) - `(,apt-utils-face-property ,face - mouse-face highlight - apt-package ,package)) - ;; Version? - (when (> length length-no-version) - (add-text-properties (+ (point) length-no-version 1) - (+ (point) length) - `(,apt-utils-face-property apt-utils-version-face))) - ;; Fill package names - (when (and apt-utils-fill-packages - (> (current-column) (+ 2 (length match))) - (> (+ (current-column) length) fill-column)) - (when (equal (char-before) ?\ ) - (delete-char -1)) ; trailing whitespace - (insert "\n" (make-string (+ 2 (length match)) ? ))) - (forward-char length) - (when (and (equal match "Package") - apt-utils-display-installed-status) - (apt-utils-insert-installed-info package)) - (skip-chars-forward ", |\n") - (setq packages (cdr packages))))) - ((string-match-p "Description\\(-..\\)?" match) - (add-text-properties (point) - (save-excursion - (or - (re-search-forward "^[^ ]" (point-max) t) - (point-max))) - `(,apt-utils-face-property apt-utils-description-face))) - ;; Conffiles doesn't have trailing space - ((looking-at "$") - nil) - (t - (add-text-properties (1- (point)) - (save-excursion - (end-of-line) - (point)) - `(,apt-utils-face-property apt-utils-field-contents-face))))))) - -(defun apt-utils-add-showpkg-links (package) - "Add hyperlinks to related Debian packages for PACKAGE." - (let ((keywords '("Reverse Depends" "Reverse Provides")) - (inhibit-read-only t) - start end regexp face link) - (if (hash-table-p apt-utils-current-links) - (clrhash apt-utils-current-links) - (setq apt-utils-current-links (make-hash-table :test 'equal))) - (while keywords - (setq regexp (concat "^" (car keywords) ": ")) - (goto-char (point-min)) - (when (re-search-forward regexp (point-max) t) - (add-text-properties (match-beginning 0) (1- (match-end 0)) - `(,apt-utils-face-property - apt-utils-field-keyword-face)) - ;; Limits of search - (setq start (1+ (point))) - (setq end (or (re-search-forward "[a-z]:" (point-max) t) - (point-max))) - (save-restriction - (narrow-to-region start end) - (goto-char (point-min)) - (while (not (eobp)) - (when (or (looking-at "^\\s-+\\(.*\\),") - (looking-at "^\\(.*\\) ")) - (setq link (match-string 1)) - (cond - ((equal (apt-utils-package-type link t) 'normal) - (setq face 'apt-utils-normal-package-face)) - ((equal (apt-utils-package-type package t) 'normal-installed) - (setq face 'apt-utils-normal-installed-package-face)) - ((equal (apt-utils-package-type link t) 'virtual) - (setq face 'apt-utils-virtual-package-face)) - (t - (setq face 'apt-utils-broken-face) - (setq link 'broken))) - ;; Store package links - (apt-utils-current-links-add-package link) - (add-text-properties (match-beginning 1) (match-end 1) - `(,apt-utils-face-property ,face - mouse-face highlight - apt-package ,link))) - (forward-line)))) - (setq keywords (cdr keywords)))) - (when (and apt-utils-display-installed-status - (memq (apt-utils-package-type package t) - '(normal normal-installed))) - (goto-char (point-min)) - (re-search-forward "Package: .*$") - (apt-utils-insert-installed-info package))) - -(defun apt-utils-add-search-links (type) - "Add hyperlinks to related Debian packages. -The type of search is specified by TYPE." - (let ((inhibit-read-only t) - local-keymap - face link regexp) - (when (eq type 'search-file-names) - (setq local-keymap (make-sparse-keymap)) - (define-key local-keymap (kbd "RET") - (lambda () - (interactive) - (view-file (or (get-text-property (point) 'apt-package-file) - (get-text-property (1- (point)) 'apt-package-file)))))) - (if (hash-table-p apt-utils-current-links) - (clrhash apt-utils-current-links) - (setq apt-utils-current-links (make-hash-table :test 'equal))) - (goto-char (point-min)) - (forward-line 2) ; Move past header - (cond - ((eq type 'search-file-names) - ;; Reformat diversion information - (save-excursion - (while (re-search-forward "diversion by \\(.*\\) \\(from\\|to\\): \\(.*\\)" nil t) - (replace-match "\\1: \\3 (diversion \\2)" nil nil))) - (setq regexp "\\([^:,]+\\)[,:]")) - (t - (setq regexp"^\\([^ ]+\\) - "))) - (while (re-search-forward regexp (point-max) t) - (setq link (match-string 1)) - (cond - ((equal (apt-utils-package-type link t) 'normal) - (setq face 'apt-utils-normal-package-face)) - ((equal (apt-utils-package-type link t) 'normal-installed) - (setq face 'apt-utils-normal-installed-package-face)) - ((equal (apt-utils-package-type link t) 'virtual) - (setq face 'apt-utils-virtual-package-face)) - (t - (setq face 'apt-utils-broken-face) - (setq link 'broken))) - ;; Store package links - (apt-utils-current-links-add-package link) - (add-text-properties (match-beginning 1) (match-end 1) - `(,apt-utils-face-property ,face - mouse-face highlight - apt-package ,link)) - ;; Multiple fields separated by commas - (when (eq type 'search-file-names) - (if (eq (char-before) ?\:) - (progn - (when local-keymap - (let ((start (1+ (point))) - (end (save-excursion - (goto-char (apt-utils-line-end-position)) - (re-search-backward " (diversion \\(from\\|to\\))" - (apt-utils-line-beginning-position) - t) - (point)))) - (add-text-properties start end - `(face apt-utils-file-face - keymap ,local-keymap - ;; Pretend we're a package - ;; so that we can move - ;; here with - ;; apt-utils-next-package - apt-package dummy - apt-package-file - ,(buffer-substring-no-properties start end) - )))) - (goto-char (1+ (apt-utils-line-end-position)))) - (skip-chars-forward ", ")))))) - -(defun apt-utils-package-type (package &optional no-error) - "Return what type of package PACKAGE is. -With optional argument NO-ERROR, don't flag an error for unknown -packages." - (or (gethash package apt-utils-package-list) - (cond - (no-error - nil) - (t - (error - (substitute-command-keys - "Package name is broken: rebuild package lists using \\[apt-utils-rebuild-package-lists] may help") - package))))) - -(defun apt-utils-package-at () - "Get package at point." - (get-text-property (point) 'apt-package)) - -(defun apt-utils-package-at-message () - "Emit message describing package at point." - (let ((package (apt-utils-package-at))) - (cond - ((eq package 'dummy) - ;; Do nothing as this isn't really a package - ) - ((equal package 'broken) - (message "Package name is broken somehow.")) - (package - (with-temp-buffer - (call-process apt-utils-apt-cache-program nil t nil "show" package) - (if (re-search-backward "^Description: \\(.*\\)$" (point-min) t) - (message "%s: %s." package (match-string 1)) - (message "%s: virtual package (no description)." - package))))))) - -(defun apt-utils-quit (&optional kill-buffer) - "Quit this `apt-utils-mode' buffer. -With prefix argument KILL-BUFFER, kill the `apt-utils-mode' -buffer." - (interactive "P") - (unless (equal major-mode 'apt-utils-mode) - (error "Not in APT utils buffer")) - (let ((buffer (current-buffer))) - (if (fboundp 'quit-window) - (quit-window) - (bury-buffer)) - (when kill-buffer - (kill-buffer buffer))) - (run-hooks 'apt-utils-quit-hooks)) - -(defun apt-utils-cleanup () - "Clean up lists used by `apt-utils-mode'. -Specifically, nullify `apt-utils-package-list'. Only do this if -there are no buffers left in `apt-utils-mode'." - (unless (memq 'apt-utils-mode - (mapcar (lambda (b) - (with-current-buffer b - major-mode)) - (delete (current-buffer) (buffer-list)))) - (clrhash apt-utils-package-list) - (setq apt-utils-package-list-built nil))) - -(defun apt-utils-describe-package () - "Describe package at point." - (interactive) - (apt-utils-package-at-message)) - -(defun apt-utils-kill-other-window-buffers () - "Kill buffers in other windows and the windows themselves. -See `apt-utils-kill-buffer-confirmation-function' for -customisation options." - (interactive) - (cond - ((not (eq major-mode 'apt-utils-mode)) - (error "Not in APT utils buffer")) - ((not (cdr (window-list))) - (message "No other windows to kill")) - (t - (when (or (null apt-utils-kill-buffer-confirmation-function) - (funcall apt-utils-kill-buffer-confirmation-function - "Kill buffers in other windows? ")) - (let ((buffer-list - (delq (current-buffer) - (mapcar #'window-buffer (window-list))))) - (mapc (lambda (b) - (when (buffer-live-p b) - (kill-buffer b))) - buffer-list)) - (delete-other-windows)) - (message nil)))) - -;; Track positions - -(defun apt-utils-update-buffer-positions (type) - "Update `apt-utils-buffer-positions'. -TYPE can be forward, backward, or toggle." - (let (posns) - (cond - ((eq type 'forward) - ;; Make the key unique; we could visit the same package more - ;; than once - (apt-utils-puthash (format "%s/%s/%d" - (caar apt-utils-package-history) - (cdar apt-utils-package-history) - (length apt-utils-package-history)) - (list (point) (window-start (selected-window))) - apt-utils-buffer-positions)) - ((eq type 'backward) - ;; Remove old values - (remhash (format "%s/normal/%d" - (caar apt-utils-package-history) - (length apt-utils-package-history)) - apt-utils-buffer-positions) - (remhash (format "%s/normal-showpkg/%d" - (caar apt-utils-package-history) - (length apt-utils-package-history)) - apt-utils-buffer-positions) - (remhash (format "%s/virtual/%d" - (caar apt-utils-package-history) - (length apt-utils-package-history)) - apt-utils-buffer-positions) - ;; Get position for previous package - (setq posns - (gethash (format "%s/%s/%d" - (car (cadr apt-utils-package-history)) - (cdr (cadr apt-utils-package-history)) - (1- (length apt-utils-package-history))) - apt-utils-buffer-positions))) - ((eq type 'toggle) - ;; new/old package types - (let ((package (caar apt-utils-package-history)) - (type (cdar apt-utils-package-history)) - new old) - (if (equal type 'normal) - (setq old 'normal - new 'normal-showpkg) - (setq old 'normal-showpkg - new 'normal)) - ;; Set position for old entry - (apt-utils-puthash (format "%s/%s/%d" - package - old - (length apt-utils-package-history)) - (list (point) (window-start (selected-window))) - apt-utils-buffer-positions) - ;; Get position for new entry - (setq posns - (gethash (format "%s/%s/%d" - package - new - (length apt-utils-package-history)) - apt-utils-buffer-positions - (list 1 1))) ; default value - ))) - posns)) - -(defun apt-utils-current-field-packages () - "Return a list of the packages on the current line." - (let ((keywords '("Conflicts" "Depends" "Enhances" "Package" - "Pre-Depends" "Provides" "Recommends" "Replaces" - "Suggests")) - eol match packages posn string) - (save-excursion - (end-of-line) - (setq eol (point)) - (beginning-of-line) - (cond - ((eobp) - (message "Not on package field line.") - nil) - ((and (re-search-forward "^\\([^ \n:]+\\): " eol t) - (setq match (match-string 1)) - (member match keywords)) - (setq posn (point)) - (goto-char (apt-field-end-position)) - (setq string (buffer-substring-no-properties posn (point))) - (with-temp-buffer - (insert string) - (goto-char (point-min)) - (while (re-search-forward "\n *" nil t) - (replace-match " ")) - (setq packages - ;; Packages split by commas, or alternatives by vertical - ;; bars; for Enhances, multiple lines my be spanned - (split-string (buffer-substring (point-min) (point-max)) - " ?[,|] ?"))) - packages) - (t - (message "Not on package field line.") - nil))))) - -(defun apt-field-end-position () - "Move to end of current field." - (save-excursion - (re-search-forward "\\(^[^: ]+:\\|^$\\)") - (beginning-of-line) - (backward-char) - (point))) - -;; Borrowed from gnus/lisp/time-date.el - -(defun apt-utils-time-less-p (t1 t2) - "Say whether time value T1 is less than time value T2." - (or (< (car t1) (car t2)) - (and (= (car t1) (car t2)) - (< (nth 1 t1) (nth 1 t2))))) - -(defun apt-utils-web-browse-debian-changelog () - "Browse web version of Debian ChangeLog file for the current package." - (interactive) - (apt-utils-web-browse-url - apt-utils-web-browse-debian-changelog-url)) - -(defun apt-utils-web-browse-bug-reports () - "Browse Debian bug reports for the current package." - (interactive) - (apt-utils-web-browse-url - apt-utils-web-browse-bug-reports-url)) - -(defun apt-utils-web-browse-copyright () - "Browse web version of Debian copyright file for the current package." - (interactive) - (apt-utils-web-browse-url - apt-utils-web-browse-copyright-url)) - -(defun apt-utils-web-browse-versions () - "Browse web version information for the current package." - (interactive) - (apt-utils-web-browse-url - apt-utils-web-browse-versions-url)) - -(defun apt-utils-web-browse-url (url) - "Browse Debian-related URL. -The URL can contain tokens that need formatting (see -`apt-utils-web-format-url')." - (cond - ((not (equal major-mode 'apt-utils-mode)) - (message "Not in APT utils buffer.")) - ((not (memq (cdar apt-utils-package-history) '(normal normal-showpkg normal-installed))) - (message "Not a normal package.")) - (t - (browse-url (apt-utils-web-format-url url))))) - -(defun apt-utils-web-format-url (url) - "Format and return Debian URL. -The tokens that can be replaced are: - %d: pool directory - %s: source package name - %p: package name - %v: package version." - (let ((buffer (current-buffer)) - (package (caar apt-utils-package-history)) - (type (cdar apt-utils-package-history)) - char source-package version) - (save-excursion ; for normal package type - (with-temp-buffer - (cond - ((memq type '(normal normal-installed)) - (set-buffer buffer)) - ((eq type 'normal-showpkg) - (call-process apt-utils-apt-cache-program nil '(t nil) nil "show" package))) - (goto-char (point-min)) - (if (re-search-forward "^Source: \\(.*\\)$" (point-max) t) - (setq source-package (match-string 1)) - (setq source-package package)) - (goto-char (point-min)) - (re-search-forward "^Version: \\([0-9]:\\)?\\(.*\\)$" (point-max)) - (setq version (match-string 2)))) - ;; Format the URL - (while (string-match "%\\(.\\)" url) - (setq char (string-to-char (match-string 1 url))) - (setq url (apt-utils-replace-regexp-in-string - (match-string 0 url) - (cond - ((eq char ?d) - (substring source-package 0 - (if (string-match "^lib[a-z]" - source-package) - 4 1))) - ((eq char ?s) source-package) - ((eq char ?p) package) - ((eq char ?v) version) - (t - (error "Unrecognized token (%%%c) in URL: %s" char url))) - url)))) - url) - -(defun apt-utils-packages-needs-update () - "Return t if `apt-utils' package lists needs updating." - (or (not apt-utils-package-list-built) - (apt-utils-time-less-p apt-utils-package-list-built - (nth 5 (file-attributes apt-utils-timestamped-file))))) - -(defun apt-utils-update-mode-name () - "Update `mode-name' for all buffers in `apt-utils-mode'." - (let* ((need-update (apt-utils-packages-needs-update)) - (update-string - (and need-update - (substitute-command-keys - ": update using \\<apt-utils-mode-map>\\[apt-utils-rebuild-package-lists]"))) - (name (concat "APT utils" update-string))) - (mapc (lambda (b) - (with-current-buffer b - (when (eq major-mode 'apt-utils-mode) - (setq mode-name name)))) - (buffer-list)))) - -(defun apt-utils-current-links-add-package (package) - "Add PACKAGE to `apt-utils-current-links' hashtable." - (unless (eq package 'broken) - (apt-utils-puthash package nil apt-utils-current-links))) - -;; Mode settings - -(defvar apt-utils-mode-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "#") 'apt-utils-rebuild-package-lists) - (define-key map (kbd "1") 'delete-other-windows) - (define-key map (kbd "<") 'apt-utils-view-previous-package) - (define-key map (kbd ">") 'apt-utils-choose-package-link) - (define-key map (kbd "?") 'describe-mode) - (define-key map (kbd "DEL") 'scroll-down) - (define-key map (kbd "M-TAB") 'apt-utils-previous-package) - (define-key map (kbd "RET") 'apt-utils-follow-link) - (define-key map (kbd "S s") 'apt-utils-search) - (define-key map (kbd "S f") 'apt-utils-search-file-names) - (define-key map (kbd "S g") 'apt-utils-search-grep-dctrl) - (define-key map (kbd "S n") 'apt-utils-search-names-only) - (define-key map (kbd "SPC") 'scroll-up) - (define-key map (kbd "TAB") 'apt-utils-next-package) - (define-key map (kbd "b C") 'apt-utils-web-browse-debian-changelog) - (define-key map (kbd "b b") 'apt-utils-web-browse-bug-reports) - (define-key map (kbd "b l") 'apt-utils-web-browse-copyright) - (define-key map (kbd "b v") 'apt-utils-web-browse-versions) - (define-key map (kbd "d") 'apt-utils-describe-package) - (when (fboundp 'window-list) - (define-key map (kbd "k") 'apt-utils-kill-other-window-buffers)) - (define-key map (kbd "l") 'apt-utils-list-package-files) - (define-key map (kbd "o") 'other-window) - (define-key map (kbd "q") 'apt-utils-quit) - (define-key map (kbd "s") 'apt-utils-show-package) - (define-key map (kbd "t") 'apt-utils-toggle-package-info) - (define-key map (kbd "v C") 'apt-utils-view-debian-changelog) - (define-key map (kbd "v R") 'apt-utils-view-debian-readme) - (define-key map (kbd "v N") 'apt-utils-view-debian-news) - (define-key map (kbd "v c") 'apt-utils-view-changelog) - (define-key map (kbd "v e") 'apt-utils-view-emacs-startup-file) - (define-key map (kbd "v f") 'apt-utils-view-package-files) - (define-key map (kbd "v l") 'apt-utils-view-copyright) - (define-key map (kbd "v m") 'apt-utils-view-man-page) - (define-key map (kbd "v n") 'apt-utils-view-news) - (define-key map (kbd "v r") 'apt-utils-view-readme) - (define-key map (kbd "v v") 'apt-utils-view-version) - (define-key map [(shift iso-lefttab)] 'apt-utils-previous-package) - (define-key map [(shift tab)] 'apt-utils-previous-package) - (define-key map - (if apt-utils-xemacs-p '(button2) (kbd "<mouse-2>")) - 'apt-utils-mouse-follow-link) - map) - "Keymap for apt-utils mode.") - -;; Menus - -(defvar apt-utils-menu nil - "Menu to use for `apt-utils-mode'.") - -(when (fboundp 'easy-menu-define) - - (easy-menu-define apt-utils-menu apt-utils-mode-map "Apt Utils Menu" - `("Apt Utils" - ["Show Package" apt-utils-show-package t] - ["Toggle Package Info" apt-utils-toggle-package-info - (apt-utils-toggle-package-p)] - ["View Previous Package" apt-utils-view-previous-package - (apt-utils-previous-package-p)] - ["Choose Package Link" apt-utils-choose-package-link - (> (hash-table-count apt-utils-current-links) 0)] - ["Next Package Link" apt-utils-next-package - (> (hash-table-count apt-utils-current-links) 0)] - ["Previous Package Link" apt-utils-previous-package - (> (hash-table-count apt-utils-current-links) 0)] - ["Follow Link at Point" apt-utils-follow-link - (apt-utils-package-at-point)] - ["Rebuild Package Lists" apt-utils-rebuild-package-lists t] - "---" - ("Search" - ["Package Descriptions" apt-utils-search t] - ["Package Names" apt-utils-search-names-only t] - ["Installed Files" apt-utils-search-file-names t] - ["Grep-Dctrl" apt-utils-search-grep-dctrl t]) - ("View Files" - ,@(list (if apt-utils-xemacs-p - :included - :active) - '(apt-utils-current-package-installed-p)) - ["ChangeLog" apt-utils-view-changelog - (apt-utils-changelog-file)] - ["Debian ChangeLog" apt-utils-view-debian-changelog - (apt-utils-debian-changelog-file)] - ["README" apt-utils-view-readme - (apt-utils-readme-file)] - ["Debian README" apt-utils-view-debian-readme - (apt-utils-debian-readme-file)] - ["NEWS" apt-utils-view-news - (apt-utils-news-file)] - ["Debian NEWS" apt-utils-view-debian-news - (apt-utils-debian-news-file)] - ["Copyright" apt-utils-view-copyright - (apt-utils-copyright-file)] - "---" - ["Man Page" apt-utils-view-man-page - (apt-utils-current-package-installed-p)] - "---" - ["All Package Files (dired)" apt-utils-view-package-files - (apt-utils-current-package-installed-p)]) - ("Browse URL" - ,@(list (if apt-utils-xemacs-p - :included - :active) - '(apt-utils-toggle-package-p)) - ["Debian ChangeLog" apt-utils-web-browse-debian-changelog t] - ["Bug Reports" apt-utils-web-browse-bug-reports t] - ["Copyright" apt-utils-web-browse-copyright t] - ["Package Versions" apt-utils-web-browse-versions t]) - "---" - ["Help" describe-mode t] - ["Quit" apt-utils-quit t]))) - -(defun apt-utils-mode () - "Major mode to interface Emacs with APT (Debian package management). - -Start things off with, for example: - - M-x apt-utils-show-package RET emacs21 RET - -Other packages (dependencies, conflicts etc.) can be navigated -using: - - \\[apt-utils-toggle-package-info] toggle package and showpkg information - \\[apt-utils-view-previous-package] show the previous package from history - \\[apt-utils-choose-package-link] choose next package from current links - \\[apt-utils-next-package] move to next package link - \\[apt-utils-previous-package] move to previous package link - \\[apt-utils-follow-link] show package for the link at point - \\[apt-utils-list-package-files] list package files (in a `dired' buffer) - -Confirmation will be requested before updating the list of known -packages. The update can be started at any time with -\\[apt-utils-rebuild-package-lists]. - -Package searches can be performed using: - - \\[apt-utils-search] search for regular expression in package names and descriptions - \\[apt-utils-search-names-only] search for regular expression in package names - \\[apt-utils-search-file-names] search for string in filenames - \\[apt-utils-search-grep-dctrl] search for regular expression in selected package fields - (using the grep-dctrl program) - -Files associated with installed packages can be accessed using: - - \\[apt-utils-view-changelog] view ChangeLog file - \\[apt-utils-view-debian-changelog] view Debian ChangeLog file - \\[apt-utils-view-readme] view README file - \\[apt-utils-view-debian-readme] view Debian README file - \\[apt-utils-view-news] view NEWS file - \\[apt-utils-view-debian-news] view Debian NEWS file - \\[apt-utils-view-copyright] view copyright (licence) file - \\[apt-utils-view-man-page] view man page - -Web locations can be visited using: - - \\[apt-utils-web-browse-debian-changelog] browse Debian ChangeLog URL - \\[apt-utils-web-browse-bug-reports] browse bug report URL - \\[apt-utils-web-browse-copyright] browse copyright (licence) URL - \\[apt-utils-web-browse-versions] browse package versions URL - -A history of navigated packages is maintained when package links -are followed using `apt-utils-choose-package-link' or -`apt-utils-follow-link'. This history is reset when -`apt-utils-show-package' or any of the search commands is used. - -Key definitions: -\\{apt-utils-mode-map}" - (kill-all-local-variables) - (use-local-map apt-utils-mode-map) - (setq major-mode 'apt-utils-mode) - (setq mode-name "APT utils") - (setq buffer-undo-list t) - (setq truncate-lines t) - ;; XEmacs - (when (and (fboundp 'easy-menu-add) - apt-utils-menu) - (easy-menu-add apt-utils-menu)) - (add-hook 'kill-buffer-hook 'apt-utils-cleanup nil t) - (run-hooks 'apt-utils-mode-hook)) - -;; Debugging - -(defun apt-utils-trace-all () - "Trace all `apt-utils' functions. For debugging." - (require 'trace) - (let ((buffer (get-buffer-create "*APT Utils Trace*"))) - (buffer-disable-undo buffer) - (all-completions "apt-utils" obarray - (lambda (sym) - (and (fboundp sym) - (not (memq (car-safe (symbol-function sym)) - '(autoload macro))) - (trace-function-background sym buffer)))))) - -(defun apt-utils-sort-result () - (save-excursion - (goto-char (point-min)) - (forward-line 2) - (sort-lines nil (point) (point-max)))) - -(provide 'apt-utils) - -;;; apt-utils.el ends here diff --git a/elisp/debian-el/deb-view.el b/elisp/debian-el/deb-view.el deleted file mode 100755 index 072fc88..0000000 --- a/elisp/debian-el/deb-view.el +++ /dev/null @@ -1,715 +0,0 @@ -;;; deb-view.el --- view Debian package files with tar-mode - -;; Copyright (C) 1998 Rick Macdonald <rickmacd@shaw.ca> -;; Copyright (C) 2003, 2004, 2005, 2009 Peter S Galbraith <psg@debian.org> - -;; Author: Rick Macdonald <rickmacd@shaw.ca> -;; Maintainer: Peter S. Galbraith <psg@debian.org> -;; Version: 1.15 - -;; This file is not part of GNU Emacs. - -;; deb-view 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. - -;; deb-view 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 deb-view; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; deb-view presents the contents of debian package archive files for -;; viewing. The viewing is done with the major mode "debview", which -;; is derived from emacs tar-mode with a few enhancements for viewing -;; compressed files, HTML files and formatted man pages. The normal -;; editing and saving features of tar-mode are not supported by -;; deb-view. - -;; deb-view includes a command called deb-find which requires that you -;; have the debian distribution directories on a local or mounted -;; filesystem. Give it a string or regular expression and it presents a -;; buffer of matching deb file names. Click with the middle mouse button -;; or press RETURN (or ^C^C) and it launches deb-view on the selected -;; file. deb-find can be configured to use locate or find, or any other -;; external command. The find method passes your search specification to -;; egrep, whereas the locate method uses your string directly. - -;; deb-view extracts the control.tar.gz and data.tar.gz files from -;; debian package and presents two buffers in a derivitive of -;; tar-mode. See tar-mode for info. - -;; Required programs: ar, gzip. -;; Optionally required programs: nroff for formatting man pages. -;; Optionally required programs: dpkg-deb for old-style binary .deb files. -;; Optionally required programs: w3-mode for viewing HTML pages. - -;; For new-style .deb files (2.0), dpkg-deb isn't used. Therefore -;; deb-view should work on any platform with the ar command, although -;; "ar -p" doesn't seem to work for .deb files on Solaris 2.4 and 2.5. -;; It works on Solaris 2.6, SGI's IRIX 6.1 and 6.2, and Linux, of course. - -;; Old-style .deb files require the dpkg-deb program. I don't know how to -;; extract control.tar.gz from these deb files, so you only get to see -;; the package control file, but nothing else such as the install scripts. -;; If you know how to get the control.tar.gz file out, let me know! -;; The data file is still viewable thanks to the "dpkg-deb --fsys-tarfile" -;; option. - -;;; Installation: - -;; 1) Quick test to see if you like deb-view. - -;; Put this file in your home directory, and call it deb-view.el. -;; Start up emacs and do the following: -;; ESCAPE x load-file RETURN ~/deb-view.el RETURN -;; Then, view a deb file with CTRL-d in Dired mode, -;; or execute: -;; ESCAPE x deb-view RETURN {/full/path/of/file.deb} RETURN -;; or execute: -;; ESCAPE : (setq deb-find-directory "/your/debian/directory") RETURN -;; ESCAPE x deb-find RETURN {deb-file-search-string} RETURN -;; and select a deb file to view with RETURN or middle mouse button in -;; the search results buffer that is created. Exit this buffer with "q". - -;; 2) Permanent installation. - -;; When installed this way, all find-file operations (such as "f" or "v" in -;; dired-mode) will automatically recognize debian files and load deb-view -;; when required. - -;; Put this file somewhere where Emacs can find it (i.e., in one of the paths -;; in your `load-path'), `byte-compile-file' it, and put the following six -;; lines (with semi-colons removed) in your ~/.emacs file (or create ~/.emacs -;; if you don't have one): -;;(autoload 'deb-find "deb-view" "Debian Archive File Finder" t) -;;(autoload 'deb-view-mode "deb-view" "Debian Archive File Mode" t) -;;(autoload 'deb-view "deb-view" "Debian Archive File Viewer" t) -;;(autoload 'deb-view-dired-view "deb-view" "Debian Archive File Viewer" t) -;;(setq auto-mode-alist (append '(("\\.deb$" . deb-view-mode)) auto-mode-alist)) -;;(define-key dired-mode-map "\C-d" 'deb-view-dired-view) - -;; If you're not very familiar with emacs customization, here is a simpler -;; approach. Add this line to your ~/.emacs file (or create ~/.emacs if you -;; don't have one): -;; (load "~/deb-view.el") -;; Or, if you can put deb-view into your load-path (execute -;; "^h v load-path RETURN" to see your load-path setting) -;; then just add the following to your ~./emacs file: -;; (require 'deb-view) - -;; deb-view is mostly unobtrusive, but does bind ^d in dired to -;; deb-view-dired-view. The "debview" mode is derived from -;; tar-mode.el using derived.el. Compared to tar-mode, debview-mode -;; binds q, N, W, and re-binds v. Also, the normal editing and saving -;; features of tar-mode are not supported by debview mode and those -;; keys are disabled. - -;; 3) Configuration - -;; deb-find has two variables to set. deb-find-method can be "locate" or -;; "find". Any other value will be assumed to be an external script or -;; program that you supply. If you set deb-find-method to "find" then you -;; must also set deb-find-directory to the directory containing the -;; debian distribution. The find command starts at this point. I originally -;; used the locate option, but contrary to the man page it doesn't seem to -;; understand even simple regular expressions. I prefer the find option. It -;; uses egrep and therefore understands complex regular expressions. -;; You might want to bind deb-find to a special key. I use ^C^D like this: -;; (define-key ctl-x-map "\C-d" 'deb-find) -;; Note that this key is normally the brief list-directory command, a -;; command that I never used anyway. - - -;;; Usage: - -;; In dired, press f or e on the dired line of the .deb file to view. -;; You can also use ^d, which is actually slightly faster since the -;; deb file isn't loaded into a buffer needlessly. - -;; Or, execute: ESCAPE x deb-view RETURN, and enter the .deb file name -;; at the prompt. - -;; Or, execute: ESCAPE x deb-find RETURN, and enter any substring of a -;; deb file name to search for. A buffer of matches is created. -;; Launch deb-view by selecting a deb file with the middle mouse button, -;; or RETURN or ^c^c. Exit this buffer with "q". - -;; You are shown two tar files in debview-mode (see tar-mode for help). -;; In the case of old .deb format files, the control info is shown -;; but not the other files of control.tar, such as install scripts. -;; Note that regular tar-mode commands e, f and RETURN show raw files -;; without any special uncompressing or formatting. -;; Additional features that deb-view adds to tar-mode: -;; q - kill both view buffers (INFO and DATA) and return to the -;; dired buffer if that's where you executed deb-mode. -;; v - executes deb-view-tar-view instead of tar-view, with the -;; additional smarts to uncompress .gz and .Z files for viewing. -;; N - Like in dired, formats man pages for viewing, with the -;; additional smarts to uncompress .gz and .Z man files for viewing. -;; W - use w3-mode to view an HTML file. - -;; To view files not supported by deb-view, such as graphics, use the -;; copy command ("c") to copy the file to a temp directory. You can -;; then do what you want to the file. - - -;;; History: -;; - -;; 1.3 - modified logic that determines old or new style Debian packages. -;; On systems where the file command recognizes debian files, it -;; wrongly always came up with old format. - -;; 1.4 - added missing semicolons in the comments for Changelog 1.3. -;; - fixed various spacing issues in doc strings. -;; - disabled tar-mode keys that are not applicable to deb-view. - -;; 1.5 - added an auto-mode-alist and deb-view mode so that deb-view -;; is launched from any find-file command. -;; - added a deb-find command that takes a search string and creates -;; a buffer of matching deb files. ^C^C, RETURN or middle mouse button -;; runs deb-view on the selected deb file. -;; - added deb-view-help to "?" key in deb-view. - -;; 1.6 - improved doc strings for deb-find and deb-find-method. -;; - added (provide 'deb-view) and instructions for using -;; (require 'deb-view). -;; - reworked the documentation somewhat, but it's still too long. -;; - changed the copyright notice to refer to deb-view, not Emacs. - -;; 1.7 - make copy of compilation-minor-mode map rather than changing -;; it directly. It was breaking actual compilation buffer keymaps, -;; such as grep mode. - -;; 1.8 - fixed deb-find when deb-find-method is set to "find". It wasn't -;; adding "/*" to the end of the directory name for the find command. - -;; 1.9 - Added support for handling remote deb files (ange-ftp). -;; - reworked to use derived.el instead of messing with tar-mode -;; directly. (Thanks to era eriksson <era@iki.fi>) - -;; 1.10 2003-10-30 -;; - New maintainer: Peter S. Galbraith <psg@debian.org> -;; - checkdoc edits. -;; - made defvars into defcustoms. - -;; 1.11 2004-01-16 Peter S. Galbraith <psg@debian.org> -;; - Resize top (control) window to fit number of lines since it -;; doesn't really need to be 1/2 the screen. Thanks to Dan -;; Jacobson for suggesting this change (Closes: #224950). - -;; 1.12 2005-10-24 Peter S. Galbraith <psg@debian.org> -;; - Output an error message if the package file is corrupted -;; (e.g. partial download). -;; Thanks to Dan Jacobson for suggesting this change (Closes: #235673). -;; - deb-view-dired-view: Check if file in dired is a .deb before opening. -;; Thanks to Dan Jacobson for suggesting this change (Closes: #273902) -;; - deb-view-tar-view: If the file to be opned is from the INFO buffer, -;; then open in the other (larger) window. -;; Thanks to Dan Jacobson for suggesting this change (Closes: #321869) - -;; 1.13 2006-02-02 Sven Joachim <sven_joachim@web.de> -;; Bug fix for UTF-8 (Closes: #344260) -;; The `call-process' and `call-process-region' use -;; default-process-coding-system rather than coding-system-for-read. -;; The former is set to '(mule-utf-8 . mule-utf-8) in my setup, and that -;; caused the problem. So the solution is to bind -;; default-process-coding-system as well in deb-view-process - -;; 1.14 2009-10-25 Peter S. Galbraith <psg@debian.org> -;; Added support for data.tar.bz2 deb files (Closes: #457094). - -;; 1.15 2009-11-02 Peter S. Galbraith <psg@debian.org> -;; Fixed stupid bug "deb-view.el fails on own debian-el_30.9-1_all.deb", -;; thanks to Kevin Ryde (Closes: #554039). - -;; 1.16 2011-08-16 Peter S. Galbraith <psg@debian.org> -;; Added support for data.tar.xz deb files (Closes: #637579). - -;;; Code: - -(defgroup deb-view nil - "View Debian package files with tar-mode" - :group 'tools - :prefix "deb-view") - -(defcustom deb-view-tar-uncompress-program "gzip -cd" - "*Program to use for uncompression of .gz and .Z files in `deb-view'." - :group 'deb-view - :type 'string) - -;; Note the following useful variable from tar-mode: -;;(defvar tar-mode-show-date nil -;; "*Non-nil means Tar mode should show the date/time of each subfile. -;;This information is useful, but it takes screen space away from file names.") - -(defcustom deb-find-method "find" - "Internal `deb-find' methods supported: locate or find. -Any other entry is assumed to be an external command. -See also the variable deb-find-directory." - :group 'deb-view - :type '(radio (const "find") (const "locate"))) - -(defcustom deb-find-directory "/usr/local/src/debian" - "Directory to run find in when deb-find-method is \"find\"." - :group 'deb-view - :type 'directory) - -(define-derived-mode debview-mode tar-mode "debview" - "Major mode for debview.\n\n\\{debview-mode-map}") - -;; Prohibit things that tar-mode does that deb-view doesn't: -(define-key debview-mode-map "\C-d" 'undefined) -(define-key debview-mode-map "G" 'undefined) -(define-key debview-mode-map "M" 'undefined) -(define-key debview-mode-map "O" 'undefined) -(define-key debview-mode-map "d" 'undefined) -(define-key debview-mode-map "g" 'undefined) -(define-key debview-mode-map "r" 'undefined) -(define-key debview-mode-map "u" 'undefined) -(define-key debview-mode-map "x" 'undefined) -(define-key debview-mode-map "" 'undefined) - -(define-key debview-mode-map "?" 'deb-view-help) -(define-key debview-mode-map "q" 'deb-view-dired-view-cleanup) -(define-key debview-mode-map "N" 'deb-view-tar-man) -(define-key debview-mode-map "W" 'deb-view-tar-w3) -(define-key debview-mode-map "v" 'deb-view-tar-view) -(define-key debview-mode-map [up] 'tar-previous-line) -(define-key debview-mode-map [down] 'tar-next-line) -(define-key debview-mode-map "\eOA" 'tar-previous-line) -(define-key debview-mode-map "\eOB" 'tar-next-line) -(define-key debview-mode-map "\e[A" 'tar-previous-line) -(define-key debview-mode-map "\e[B" 'tar-next-line) - -(defvar deb-view-dired-view-return-buffer "" - "Return to this buffer after deb-view-dired-view-cleanup is called.") -(make-variable-buffer-local 'deb-view-dired-view-return-buffer) - -(defvar deb-view-tempfile "" - "Flag saying if the deb file is temporary (ange-ftp) and needs deleting.") - -(defvar deb-view-file-name "" - "The file name being processed by `deb-view'.") - -;; You might not like the key bindings that I chose: -(if (featurep 'dired) - (define-key dired-mode-map "\C-d" 'deb-view-dired-view) - (add-hook - 'dired-load-hook - (function (lambda () - (define-key dired-mode-map "\C-d" 'deb-view-dired-view))))) - -;;;###autoload -(defun deb-view-dired-view () - "View Debian package control and data files. -Press \"q\" in either window to kill both buffers -and return to the dired buffer. See deb-view." - (interactive) - (let ((file (dired-get-filename))) - (if (string-match ".deb$" file) - (deb-view file) - (error "Not a Debian package file")))) - -;;;###autoload -(defun deb-view (debfile) - "View Debian package DEBFILE's control and data files. -Press \"q\" in either window to kill both buffers. - -In dired, press ^d on the dired line of the .deb file to view. -Or, execute: ESCAPE x deb-view RETURN, and enter the .deb file name -at the prompt." - (interactive "fdeb file to view: ") - (if (and (or (string-match "Lucid" emacs-version) - (string-match "XEmacs" emacs-version)) - (>= emacs-major-version 21)) - (require 'view-less) - (require 'view)) - (require 'view) - (if (< (nth 1 (file-attributes debfile)) 0) - (progn - ;; This is a remote file. - ;; Call view-file to force ange-ftp to get it first. - (message "deb-view remote file: %s" debfile) - (find-file debfile)) - ;; This is a local file. - (setq debfile (expand-file-name debfile)) - ;;(message "deb-view local file: %s" debfile) - (setq deb-view-file-name debfile) - (setq deb-view-tempfile nil) - (deb-view-process debfile))) - -(defun deb-view-process (debfile) - "View Debian Archive Files for package DEBFILE." - (let* ((deb-view-buffer-name (file-name-nondirectory deb-view-file-name)) - (info-buffer-name (concat deb-view-buffer-name "-INFO")) - (data-buffer-name (concat deb-view-buffer-name "-DATA")) - (info-buffer (progn (and (get-buffer info-buffer-name) - (kill-buffer (get-buffer info-buffer-name))) - (get-buffer-create info-buffer-name))) - (data-buffer (progn (and (get-buffer data-buffer-name) - (kill-buffer (get-buffer data-buffer-name))) - (get-buffer-create data-buffer-name))) - (return-buffer (current-buffer)) - (coding-system-for-read 'no-conversion) - (default-process-coding-system '(no-conversion . no-conversion)) - file-buffer - new-archive-format) - (message "deb-view processing deb file %s..." deb-view-buffer-name) - ;; info - (setq file-buffer (get-buffer-create " *file-data*")) - (setq new-archive-format - (save-excursion - (set-buffer file-buffer) - (erase-buffer) - (call-process shell-file-name nil t nil shell-command-switch - (concat "file " debfile)) - (goto-char 1) - (if (string-match "archive" (buffer-string)) - t - (goto-char 1) - (if (string-match "old debian" (buffer-string)) - nil - t)))) - (kill-buffer file-buffer) - (set-buffer info-buffer) - (cond - (new-archive-format - ;; New deb format (archive) - (call-process shell-file-name nil t nil shell-command-switch - (concat "ar -p " debfile - " control.tar.gz | gzip -cd")) - (goto-char 1) - (setq buffer-file-name (concat deb-view-file-name "-INFO")) - (if (fboundp 'set-buffer-multibyte) (set-buffer-multibyte nil)) - (debview-mode) - ;; Turn off view-mode in this buffer: - (make-variable-buffer-local 'view-mode-hook) - (add-hook - 'view-mode-hook - (function (lambda () - (view-mode -1) - (setq view-exit-action 'deb-view-dired-view-cleanup)))) - (message "deb-view processing deb file %s..." deb-view-buffer-name) - (tar-next-line 1) - (switch-to-buffer info-buffer t)) - (t - ;; Old deb format - (message "deb-view old dpkg binary format") - (call-process shell-file-name nil t nil shell-command-switch - (concat "dpkg-deb -I " debfile)) - (setq buffer-read-only t) - (set-buffer-modified-p nil) - (goto-char 1) - (switch-to-buffer info-buffer t) - (view-mode-enter return-buffer 'deb-view-dired-view-cleanup))) - (set-buffer-modified-p nil) - (setq buffer-read-only t) - (setq deb-view-dired-view-return-buffer return-buffer) - (delete-other-windows) - ;; data - (set-buffer data-buffer) - (buffer-disable-undo) - (cond - (new-archive-format - (call-process "ar" nil '(t t) nil "-t" debfile) - (goto-char 1) - (cond - ((re-search-forward "data.tar.gz" nil t) - (erase-buffer) - (call-process "ar" nil '(t t) nil "-p" debfile "data.tar.gz") - (goto-char (point-max)) - (when (search-backward "is not a valid archive" nil t) - (kill-buffer data-buffer) - (kill-buffer info-buffer) - (error "%s: Not a valid package file" deb-view-buffer-name)) - (call-process-region (point-min) (point-max) "gzip" t t nil "-cd")) - ((and (goto-char 1)(re-search-forward "data.tar.bz2" nil t)) - (erase-buffer) - (call-process "ar" nil '(t t) nil "-p" debfile "data.tar.bz2") - (goto-char (point-max)) - (when (search-backward "is not a valid archive" nil t) - (kill-buffer data-buffer) - (kill-buffer info-buffer) - (error "%s: Not a valid package file" deb-view-buffer-name)) - (call-process-region (point-min) (point-max) "bzip2" t t nil "-cd")) - ((and (goto-char 1)(re-search-forward "data.tar.xz" nil t)) - (erase-buffer) - (call-process "ar" nil '(t t) nil "-p" debfile "data.tar.xz") - (goto-char (point-max)) - (when (search-backward "is not a valid archive" nil t) - (kill-buffer data-buffer) - (kill-buffer info-buffer) - (error "%s: Not a valid package file" deb-view-buffer-name)) - (call-process-region (point-min) (point-max) "xz" t t nil "-cd")))) - (t - (call-process shell-file-name nil t nil shell-command-switch - (concat "dpkg-deb --fsys-tarfile " debfile)))) - (goto-char 1) - (setq buffer-file-name (concat deb-view-file-name "-DATA")) - (if (fboundp 'set-buffer-multibyte) (set-buffer-multibyte nil)) - (debview-mode) - (message "deb-view processing deb file %s..." deb-view-buffer-name) - (tar-next-line 1) - (setq deb-view-dired-view-return-buffer return-buffer) - (set-buffer-modified-p nil) - (setq buffer-read-only t) - (buffer-enable-undo) - (switch-to-buffer-other-window data-buffer) - (if new-archive-format (other-window 1)) - (shrink-window-if-larger-than-buffer) - (when deb-view-tempfile - (message "deb-view deleting tempfile: %s" debfile) - (delete-file debfile)) - (message "deb-view: ? for help. q to quit."))) - -;;;###autoload -(defun deb-view-mode () - "View mode for Debian Archive Files." - (interactive) - (let ((debfile buffer-file-name) - (return-buffer (nth 0 (buffer-list))) - (curbuf (current-buffer))) - (setq deb-view-file-name debfile) - (if (< (nth 1 (file-attributes debfile)) 0) - (progn - (message "deb-view remote file: %s" debfile) - (setq debfile (make-temp-name "/tmp/deb-view.")) - ;;(message "deb-view processing deb file %s..." debfile) - (write-file debfile) - (setq deb-view-tempfile t)) - ;;(message "deb-view local file: %s" debfile) - (setq deb-view-tempfile nil)) - (set-buffer return-buffer) - (kill-buffer curbuf) - (deb-view-process debfile))) - -;;;###autoload -(defun deb-find () - "Search for deb files. -Use the method specified by the variable deb-find-method, and collect -output in a buffer. See also the variable deb-find-directory. - -This command uses a special history list, so you can -easily repeat a `deb-find' command." - (interactive) - (require 'compile) - (let* ((deb-file-string (read-from-minibuffer "deb file to find: " - nil nil nil 'deb-find-history)) - (output-buffer-name "*deb-find*") - (command (cond ((string-equal deb-find-method "locate") - (concat "locate '" deb-file-string - "' | egrep '\.deb$'")) - ((string-equal deb-find-method "find") - (concat "find " deb-find-directory "/* | egrep '" - deb-file-string "' | egrep '\.deb$'")) - (t - (concat deb-find-method " '" deb-file-string "'"))))) - (compile-internal command "Not applicable in deb-find" "deb-find" nil nil - (function (lambda (mode) output-buffer-name))) - (switch-to-buffer-other-window output-buffer-name) - (setq deb-view-find-minor-mode-map - (copy-keymap compilation-minor-mode-map)) - (use-local-map deb-view-find-minor-mode-map) - (define-key deb-view-find-minor-mode-map [mouse-2] - 'deb-find-mouse-deb-view) - (define-key deb-view-find-minor-mode-map "\C-c\C-c" 'deb-find-deb-view) - (define-key deb-view-find-minor-mode-map "\C-m" 'deb-find-deb-view) - (define-key deb-view-find-minor-mode-map "?" 'deb-find-help) - (define-key deb-view-find-minor-mode-map "q" 'kill-this-buffer) - (define-key deb-view-find-minor-mode-map "\M-n" 'undefined) - (define-key deb-view-find-minor-mode-map "\M-p" 'undefined) - (define-key deb-view-find-minor-mode-map "\M-{" 'undefined) - (define-key deb-view-find-minor-mode-map "\M-}" 'undefined) - (beginning-of-buffer) - (message "deb-view: ? for help. q to quit."))) - - -;;; Internal functions: - -(defvar deb-view-version "1.9" - "The version of `deb-view'.") - -(defun deb-view-version () - "Return string describing the version of `deb-view'. -When called interactively, displays the version." - (interactive) - (if (interactive-p) - (message "deb-view version %s" (deb-view-version)) - deb-view-version)) - -(defun deb-view-dired-view-cleanup (&optional buffer) - "Delete the buffers created by deb-view-dired-view." - (interactive) - (let* ((quit-buffer (or buffer (current-buffer))) - (bufname (buffer-name quit-buffer)) - (debfile (substring bufname 0 (- (length bufname) 5))) - (info-buffer (get-buffer (concat debfile "-INFO"))) - (data-buffer (get-buffer (concat debfile "-DATA"))) - (ddir-buffer (save-excursion - (set-buffer quit-buffer) - deb-view-dired-view-return-buffer))) - (delete-other-windows) - (and (buffer-live-p info-buffer) - (kill-buffer info-buffer)) - (and (buffer-live-p data-buffer) - (kill-buffer data-buffer)) - (and (buffer-live-p quit-buffer) - (kill-buffer quit-buffer)) - (and (buffer-live-p ddir-buffer) - (switch-to-buffer ddir-buffer)))) - -(defun deb-find-help () - "Show help information for `deb-find'." - (interactive) - (with-output-to-temp-buffer "*Help*" - (princ (format "deb-find mode: version %s" (deb-view-version))) - (princ "\n -RET - view the deb file on this line with deb-view. -C-c C-c - view the deb file on this line with deb-view. -mouse-2 - view the deb file on this line with deb-view. -? - show deb-find-help. -q - quit deb-find.") - (save-excursion - (set-buffer standard-output) - (help-mode)) - (print-help-return-message))) - -(defun deb-view-help () - "Show help information for `deb-view'." - (interactive) - (with-output-to-temp-buffer "*Help*" - (princ (format "deb-view mode: version %s" (deb-view-version))) - (princ " -Derived from tar-mode, with additional features for viewing deb files. -Execute \"^h m\" to see tar-mode bindings. - -You are shown two tar files in tar-mode (see tar-mode for help). -In the case of old .deb format files, the control info is shown -but not the other files of control.tar, such as install scripts. - -Note that regular tar-mode commands e, f and RETURN show raw files -without any special uncompressing or formatting. - -Additional features that deb-view adds to tar-mode: -? - show deb-view help. -q - kill both view buffers (INFO and DATA) and return to the - dired buffer if that's where you executed deb-mode. -v - executes deb-view-tar-view instead of tar-view, with the - additional smarts to uncompress .gz and .Z files for viewing. -N - Like in dired, formats man pages for viewing, with the - additional smarts to uncompress .gz and .Z man files for viewing. -W - use w3-mode to view an HTML file. -These functions are also available in tar-mode on normal tar files -when deb-view is loaded. - -To view files not supported by deb-view, such as graphics, use the -copy command in tar-mode (\"c\") to copy the file to a temp directory. -You can then do what you want to the file.") - (save-excursion - (set-buffer standard-output) - (help-mode)) - (print-help-return-message))) - -(defun deb-view-tar-man () - "*In Tar mode, view the tar file entry on this line as a man page." - (interactive) - (require 'man) - (let ((auto-mode-alist - (append '(("\\.gz$" . deb-view-tar-uncompress-while-visiting) - ("\\.Z$" . deb-view-tar-uncompress-while-visiting) - ) auto-mode-alist))) - (tar-extract 'view) - (setq buffer-read-only nil) - (shell-command-on-region (point-min) (point-max) "nroff -man -h " t t) - (Man-cleanup-manpage) - (setq buffer-read-only t) - (set-buffer-modified-p nil) - (message ""))) - -(defun deb-view-tar-uncompress-while-visiting () - "Temporary \"major mode\" used for .Z and .gz files, to uncompress them. -It then selects a major mode from the uncompressed file name and contents. -\(Modifed uncompress-while-visiting from uncompress.el\)" - (interactive) - (message "Uncompressing...") - (let ((buffer-read-only nil)) - (shell-command-on-region (point-min) (point-max) - deb-view-tar-uncompress-program t)) - (message "Uncompressing...done") - (set-buffer-modified-p nil) - (goto-char 1)) - -(defun deb-view-tar-view () - "*In Tar mode, view the tar file entry on this line. -If the file is from the INFO buffer, then open in the other (larger) window." - (interactive) - (let ((auto-mode-alist - (append '(("\\.gz$" . deb-view-tar-uncompress-while-visiting) - ("\\.Z$" . deb-view-tar-uncompress-while-visiting) - ) auto-mode-alist))) - (if (string-match "INFO$" buffer-file-name) - (tar-extract-other-window) - (tar-extract 'view)))) - -(defun deb-view-tar-w3 () - "*In Tar mode, view the tar file entry on this line as HTML with w3-mode." - (interactive) - (if (fboundp 'w3-preview-this-buffer) - (let ((auto-mode-alist - (append '(("\\.gz$" . deb-view-tar-uncompress-while-visiting) - ("\\.Z$" . deb-view-tar-uncompress-while-visiting) - ) auto-mode-alist))) - (tar-extract 'view) - (rename-buffer (concat " " (buffer-name))) - (w3-preview-this-buffer) - (define-key w3-mode-map "q" 'deb-view-tar-w3-quit)) - (error "Sorry, you don't seem to have w3 loaded"))) - -(defun deb-view-tar-w3-quit () - "Quit WWW mode in a buffer from `deb-view'." - (interactive) - (let ((x w3-current-last-buffer)) - (and (fboundp 'w3-mpeg-kill-processes) (w3-mpeg-kill-processes)) - (kill-buffer (current-buffer)) - (if (and (bufferp x) (buffer-name x)) - (if w3-mutable-windows (pop-to-buffer x) (switch-to-buffer x)))) - (view-exit)) - -(defvar deb-find-history nil - "History list for `deb-find' commands.") - -(defvar deb-find-regexp "^/.*\.deb$" - "Regexp for deb file names in the `deb-find' buffer.") - -(defun deb-find-deb-view () - "Run `deb-view' in package under point." - (interactive) - (let ((deb-file (thing-at-point 'filename))) - (if (and deb-file - (string-match deb-find-regexp deb-file)) - (deb-view (thing-at-point 'filename)) - (error "No deb file on this line")))) - -(defun deb-find-mouse-deb-view (event) - "Run `deb-view' in package under mouse EVENT." - (interactive "e") - (pop-to-buffer (window-buffer (posn-window (event-end event)))) - (goto-char (posn-point (event-end event))) - (let ((deb-file (thing-at-point 'filename))) - (if (and deb-file - (string-match deb-find-regexp deb-file)) - (deb-view (thing-at-point 'filename)) - (error "No deb file on this line")))) - -(provide 'deb-view) - -;;; deb-view.el ends here diff --git a/elisp/debian-el/debian-bug.el b/elisp/debian-el/debian-bug.el deleted file mode 100755 index b856b65..0000000 --- a/elisp/debian-el/debian-bug.el +++ /dev/null @@ -1,2412 +0,0 @@ -;;; debian-bug.el --- report a bug to Debian's bug tracking system - -;; Copyright (C) 1998, 1999 Free Software Foundation, Inc. -;; Copyright (C) 2001, 2002, 2003, 2004 Peter S Galbraith <psg@debian.org> -;; Copyright (C) 2005, 2006, 2007, 2008 Peter S Galbraith <psg@debian.org> -;; Copyright (C) 2009, 2010 Peter S Galbraith <psg@debian.org> - -;; Help texts from -;; http://www.debian.org/Bugs/Developer#severities -;; http://www.debian.org/Bugs/Developer#tags -;; http://www.debian.org/Bugs/pseudo-packages -;; Copyright 1999 Darren O. Benham, 1994-1997 Ian Jackson, -;; 1997 nCipher Corporation Ltd. - -;; Author (Up to version 1.7): Francesco Potortì <pot@gnu.org> -;; Maintainer from version 1.8 onwards: Peter S Galbraith <psg@debian.org> -;; Keywords: debian, bug, reporter - -;; debian-bug.el 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. -;; -;; debian-bug.el 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. -;; -;; ---------------------------------------------------------------------------- -;;; Commentary: -;; -;; Useful commands provided by this mode: -;; -;; debian-bug - submit a bug report concerning a Debian package -;; debian-bug-web-bug - view a bug report on a web browser (via browse-url) -;; debian-bug-wnpp - submit a Work Needed on Prospective Package bug report -;; debian-bug-request-for-package -;; - shortcut for a WNPP bug type. -;; debian-bug-ITP - shortcut for a WNPP bug type -;; -;; debian-bug depends on either the bug package or the reportbug (>1.21) -;; package for best results. -;; -;; ---------------------------------------------------------------------------- -;;; Change log: -;; -;; V1.5 23sep99 Francesco Potortì <pot@gnu.org> -;; - V1.1 -> 1.5 versions had no changelogs; starting one now. -;; V1.6 and V1.7 by Francesco Potortì <pot@gnu.org> were unreleased. -;; V1.8 04aug01 Peter S Galbraith <psg@debian.org> -;; - WNPP interface code added. I'm unsure whether the functions useful -;; only to Debian developpers should be in here. Perhaps split into a -;; second .el file bundled in dpkg-dev-el? -;; V1.9 10aug01 Peter S Galbraith <psg@debian.org> -;; - gratuitous changes (sorry Francesco) while going through the code base: -;; document defvars, s/debian-bug-program/debian-bug-helper-program/, -;; s/debian-bug-init-program/debian-bug-helper-program-init/, -;; - updated list of pseudo-packages -;; V1.10 11aug01 Peter S Galbraith <psg@debian.org> -;; Apply most of patch (made against v1.4!) from -;; Kim-Minh Kaplan <kmkaplan@vocatex.fr>, Dated 03 Oct 1999. -;; (mostly, it inserts the package version numbers in the completion obarray -;; eliminating the need to parse the status file later). -;; V1.11 11aug01 Peter S Galbraith <psg@debian.org> -;; - Don't use external bug command when package name does not exist locally -;; (fixes an old bug). -;; - Add font-lock support (e.g. release-critical severities in red) -;; V1.12 13aug01 Peter S Galbraith <psg@debian.org> -;; - generalize debian-bug-wnpp-email to debian-bug-use-From-address -;; - debian-bug-ITP and debian-bug-request-for-package shortcuts. -;; - Add menubar via minor-mode -;; -> set address to send to (submit, quiet, maintonly) -;; -> set/unset custom From header line. -;; -> set/unset X-Debbugs-CC header line. -;; -> change bug severity -;; -> add/change Tags -;; -> browse-url web interface to BTS -;; -> various help texts -;; -> customize -;; V1.13 14aug01 Peter S Galbraith <psg@debian.org> -;; - Confirm when package is not in status file. -;; - Fix for reportbug >= 1.22 -;; V1.14 15aug01 Peter S Galbraith <psg@debian.org> -;; - merge in wget BTS code from debian-changelog.el -;; - clarify help texts about maintonly and ftp.debian.org -;; - defaliases for -ITP and -RFP (closes: #108808) -;; - Add menu option for X-Debbugs-CC to myself. -;; - small format fixes. -;; V1.15 15aug01 Peter S Galbraith <psg@debian.org> -;; - Change all address related menu comands to toggling radio switches. -;; V1.16 21sep01 Peter S Galbraith <psg@debian.org> -;; - Temporary fix for XEmacs' lack of font-lock-add-keywords. -;; - Add template as done by reportbug for ITP and RFP wnpp bugs. -;; (closes: #111615) -;; V1.17 20oct01 Peter S Galbraith <psg@debian.org> -;; - load poe for match-string-no-properties if using XEmacs. -;; - Use only one arg with format-time-string for XEmacs compatibility. -;; - After generating the bug list menu in XEmacs, remove both menus and add -;; them again. Otherwise the menu is not refreshed. (Closes: #111332) -;; V1.18 11nov01 Peter S Galbraith <psg@debian.org> -;; - customize debian-bug-helper-program so bug isn't necessarily used first. -;; V1.19 11nov01 Peter S Galbraith <psg@debian.org> -;; - debian-bug: change from "Package; title" from reporter-submit-bug-report -;; into "Package: title" (closes: #117976). -;; - debian-bug-From-address-init: recognize all env vars used by reportbug -;; and bug to set the From line. -;; - debian-bug-use-From-address: default to t if any of the above env vars -;; are set. I could also try to detect is debian-bug-From-address is -;; customized, but that's for another day. (closes #117855). -;; - debian-bug-prefill-report: don't add superfluous line at the beginning -;; of the bug report body (closes #117842). -;; V1.20 11dec01 Peter S Galbraith <psg@debian.org> -;; - debian-bug: display message that we are fetching system info (which can -;; take a while). (Closes: #122033) -;; - debian-bug: fix function doc string (Closes: #121932 if Roland fixes -;; the corresponding autoload). -;; V1.21 11dec01 Peter S Galbraith <psg@debian.org> -;; - debian-bug, debian-bug-wnpp: Use simpler 'reporter-compose-outgoing' -;; instead of 'reporter-submit-bug-report' -;; - debian-bug, debian-bug-wnpp: reset buffer to "*mail*" if mail-user-agent -;; is gnus-user-agent (Closes: #121532). -;; V1.22 11dec01 Peter S Galbraith <psg@debian.org> -;; - menu: Implement most of Bill Wohler's excellent suggestions to improve -;; the main menu (Closes: #123476) -;; V1.23 12dec01 Peter S Galbraith <psg@debian.org> -;; - use new option --template with reportbug for garanteed non-interactive -;; use of reportbug. The package must depend on reportbug >= 1.41.1 -;; (Closes: #122032) -;; V1.24 24Jan02 Peter S Galbraith <psg@debian.org> -;; debian-bug-web-bugs: return all bugs for the source package. -;; V1.25 07Feb02 Peter S Galbraith <psg@debian.org> -;; debian-bug-build-bug-menu: return all bugs for the source package. -;; V1.26 08Feb02 Peter S Galbraith <psg@debian.org> -;; debian-bug-help-tags-text and debian-bug-help-severity-text: updated -;; debian-bug-tags-alist: Added "upstream" to list -;; V1.27 11Jul02 Peter S Galbraith <psg@debian.org> -;; reset buffer to "*mail*" only when in buffer " *nttpd*" (Closes: #151717) -;; V1.28 30Jul02 Peter S Galbraith <psg@debian.org> -;; added debian-bug-filename (Closes: 117036) -;; V1.29 02Augl02 Peter S Galbraith <psg@debian.org> -;; Add a few functions from debian-changelog, since we are taking over -;; its duplicate commands. -;; New: debian-bug-web-this-bug -;; New: debian-bug-web-this-bug-under-mouse -;; V1.30 15Aug02 Peter S Galbraith <psg@debian.org> -;; Kalle Olavi Niemitalo <kon@iki.fi> suggested the use of "toggle" buttons -;; instead of "radio" buttons, where appropriate (Closes: #156297). -;; V1.31 15Aug02 Peter S Galbraith <psg@debian.org> -;; Remove erroneous [] brackets around WNPP tags (Closes: #156391). -;; V1.32 13Sep02 Peter S Galbraith <psg@debian.org> -;; - Deal with reportbug 1.99.54 (or so) that adds MIME stuff to mail headers. -;; Patch from Brian Warner <warner@lothar.com> (Closes: #160750) -;; - debian-bug-prefill-report: Don't pass desired severity to reportbug -;; because it is interactive when high settings are passed. Set after -;; reportbug template is entered instead. (Closes: #159625) -;; V1.33 27Sep02 Peter S Galbraith <psg@debian.org> -;; Split long bug menus, first into categories, then into number ranges. -;; (Closes: #161155) -;; V1.34 20Nov02 Peter S Galbraith <psg@debian.org> -;; debian-bug-build-bug-menu: removed one character from the regexp for -;; the bug menu. I don't know if the web format changed, but -;; debian-bug-alist was short by the last number in its bug numbers. -;; V1.35 19Mar03 Peter S Galbraith <psg@debian.org> -;; debian-bug-build-bug-menu: Adapted to change in BTS web page format. -;; Bugs were no longer found by the old regexp. -;; V1.36 19Mar03 Peter S Galbraith <psg@debian.org> -;; debian-bug: Call proper debian-bug--set-custom-From, which will delete -;; an existing From line before inserting a new one. Closes: #184954. -;; debian-bug-prefill-report: Don't flake out on search if "\n\n" not -;; found. This might help with bug #165290, but I should really check -;; that reportbug doesn't fail. -;; debian-bug: Check if empty Subject field has trailing space. Should -;; fix bug #173040 and part of #177259. -;; V1.37 10Apr2003 Peter S Galbraith <psg@debian.org> -;; - Switch priority of reportbug and bug, preferring reportbug. -;; - send to maintonly if priority wishlist or minor. Closes: #176429. -;; V1.38 14Apr2003 Peter S Galbraith <psg@debian.org> -;; - Revert `send to maintonly if priority wishlist or minor' change. -;; maintonly is for mass filings. -;; - New buffer-local variable `debian-bug-open-alist' for open bugs. -;; This will be used for completion in debian-changelog-mode.el -;; - debian-bug: always build package list. Closes: #186338 -;; - Use executable-find. Patch contributed by Romain FRANCOISE -;; <romain@orebokech.com>. Closes: #189605 -;; - New actions in Bugs list menu: can now read bug reports as file or Email! -;; - Apply checkdoc patch from Bill Wohler <wohler@newt.com>. Thanks! -;; - Byte-compilation cleanup. -;; - Added debian-bug-menu-preload-flag. -;; V1.39 22Apr2003 Peter S Galbraith <psg@debian.org> -;; - debian-bug-alltags-alist: new variable for complete Tags list. -;; - debian-bug-help-control: new command for menu help for d-b-control -;; - Minor doc string fixes. -;; - renamed X-Debbugs-CC commands to simple CC, specifying the field to -;; use as an new argument. So it can be used in d-b-control. -;; V1.40 12May2003 Peter S Galbraith <psg@debian.org> -;; - check if `debian-changelog-mode' is available as a feature, and not -;; simply the if the autoloaded are fboundp (which is always true). -;; V1.41 15May2003 Peter S Galbraith <psg@debian.org> -;; - Add `confirmed' tag. -;; V1.42 23May2003 Matt Swift <swift@alum.mit.edu> -;; debian-bug-prefill-report: announce error if reportbug gives empty -;; template. -;; V1.42 31May2003 Peter S Galbraith <psg@debian.org> -;; Add `d-i', `ipv6' and `lfs' tags. -;; V1.43 01Sep2003 Peter S Galbraith <psg@debian.org> -;; debian-bug-build-bug-menu: Create closing changlog entries in -;; debian-bug-open-alist cdr's. (Closes: #207852) -;; V1.44 03Sep2003 Peter S Galbraith <psg@debian.org> -;; - Display help when prompting for package name and bug severity -;; (Closes: #200058) -;; - debian-bug-display-help: new defcustom. -;; V1.45 05Sep2003 Peter S Galbraith <psg@debian.org> -;; - debian-bug-filename: Added File: in informational block. -;; - debian-bug-search-file: Added message about system call to dpkg. -;; - debian-bug-font-lock-keywords: added File: -;; - debian-bug: make it a front-end to `debian-bug-package' (the old -;; `debian-bug') and `debian-bug-filename' and make those non-interactive, -;; reducing the number of interactive commands. (Closes: #167214) -;; - checkdoc fixes. -;; V1.46 17Sep2003 Peter S Galbraith <psg@debian.org> -;; - I think V1.43 added the # character before bug numbers in the menu -;; and broke the splitting-up of large bug categories. Fixed. -;; - bugs.debian.org added HTML "name" tags which I need to exclude from -;; titles. -;; V1.47 20Sep2003 Peter S Galbraith <psg@debian.org> -;; - debian-bug-search-file: Use dlocate if available when filename is -;; given. thanks to Jeff Sheinberg (Closes: #211598). -;; V1.48 01Oct2003 Peter S Galbraith <psg@debian.org> -;; - Make debian-bug accept P or F without a carriage return. -;; V1.49 05Oct2003 Peter S Galbraith <psg@debian.org> -;; - Add tags "sarge-ignore" and "fixed-uptsream". -;; V1.50 09Oct2003 Peter S Galbraith <psg@debian.org> -;; - Add debian-bug-rfc2047-decode-string. -;; V1.51 28Oct2003 Peter S Galbraith <psg@debian.org> -;; - Send to maintonly if priority minor. Closes: #214242. -;; See http://www.debian.org/Bugs/Reporting.en.html: -;; "if a bug report is minor, for example, a documentation typo or a -;; trivial build problem, please adjust the severity appropriately and -;; send it to maintonly@bugs" -;; V1.52 27Nov2003 Kalle Olavi Niemitalo <kon@iki.fi> -;; - Contain debian-bug's cursor-in-echo-area to when it's needed so the -;; list of pseudo-packages can be scrolled. (Closes: #222332) -;; - debian-bug-package: Let M-<next> and M-<prev> scroll the pseudo-package -;; list window by making _it_ the other window. (Closes: #222333) -;; V1.53 27Nov2003 Peter S Galbraith <psg@debian.org> -;; - Add menu entry for "Archived Bugs for this package" and for -;; "Developer Page for This Package". Create debian-bug-web-developer-page. -;; V1.54 02Aug2004 Peter S Galbraith <psg@debian.org> -;; - Add RFH tag to wnpp. -;; V1.54 11Nov2004 Camm Maguire <camm@enhanced.com> -;; - debian-bug: Add "--list-cc=none" to call to reportbug after changes -;; in new version of reportbug. (Closes: #280780) -;; V1.55 05Jan2005 Kevin Ryde <user42@zip.com.au> -;; - adds gnus support to debian-bug-get-bug-as-email, bringing the bug -;; messages up in a gnus group. (Closes: #288469) -;; V1.55 05Jan2005 Peter S Galbraith <psg@debian.org> -;; debian-bug-package: skip over mml directives in new drafts. -;; Thanks to Luca Capello <luca@pca.it> (Closes: #336466) -;; V1.56 03Nov2005 Peter S Galbraith <psg@debian.org> -;; - debian-bug-prompt-bug-number: new function to prompt user for a bug -;; number using number under point if any. -;; - debian-bug-web-bug: use it. -;; - debian-bug-web-this-bug: deleted (no longer needed). -;; - debian-bug-get-bug-as-file: use it. -;; - debian-bug-get-bug-as-email: use it. -;; (Closes: #337233) -;; V1.57 03Nov2005 Peter S Galbraith <psg@debian.org> -;; - Swap CC: for X-Debbugs-CC: in mail header (Closes: #208570) -;; V1.58 05Nov2005 Peter S Galbraith <psg@debian.org> -;; - debian-bug-wnpp: skip over mml directives in new drafts. -;; Thanks to Luca Capello <luca@pca.it> (Closes: #337659) -;; V1.59 14Nov2005 Peter S Galbraith <psg@debian.org> -;; - Search for "^cc:" instead of simply "cc:" in Bug #208570 change. -;; V1.60 30May2006 Luca Capello <luca@pca.it> -;; - Change the face of Tags: for experimental, (Closes: #357265) -;; V1.61 05Sep2006 Kevin Ryde <user42@zip.com.au> -;; - word-at-point needs an autoload or a require statement (Closes: #384542) -;; V1.62 22Sep2006 Peter S Galbraith <psg@debian.org> -;; - Added "Owner:" to ITP bugs. Thanks to Romain Francoise for bringing -;; this to my attention (Closes: #388747) -;; - Updated the list of valid tags. -;; V1.63 25Jul2007 Peter S Galbraith <psg@debian.org> -;; - Adapt patch from Luca Capello <luca@pca.it> for bug #431091 -;; V1.64 29Aug2007 Peter S Galbraith <psg@debian.org> -;; - `debian-changelog-close-bug-statement' may not be bound (Closes: #440002) -;; Thanks to my friend Bill Wohler for finding this bug. -;; V1.65 02Sep2007 Peter S Galbraith <psg@debian.org> -;; - Implement pacakge lookup on http://packages.debian.org/ -;; See http://bugs.debian.org/87725 -;; V1.66 24Sep2007 Luca Capello <luca@pca.it> -;; - Add `debian-bug-get-bug-as-email-hook' and relative `run-hooks' -;; (Closes: #392475) -;; V1.67 09Sept2008 Peter S Galbraith <psg@debian.org> -;; - Bug fix: "Bug submenus have vanished", thanks to Bill Wohler for the -;; report and to Camm Maguire for an initial patch (Closes: #463053). -;; V1.68 23Feb2009 Peter S Galbraith <psg@debian.org> -;; - Bug fix: Adapted patch from HÃ¥kon Stordahl <haastord@online.no> to -;; quote bug descriptions when building the bug menu. (Closes: #489786) -;; - Bug fix: Applied patch from HÃ¥kon Stordahl <hakon@stordahl.org> -;; for garbled Help buffer (Closes: #502426) -;; V1.69 13May2009 Peter S Galbraith <psg@debian.org> -;; - Updated debian-bug-pseudo-packages (Closes: #526496) -;; - [PATCH] using the "maintainer mbox" instead of "mbox folder". -;; Thanks to Evgeny M. Zubok (Closes: #521571). -;; - Fix "incomplete Bugs menu again", thanks to A Mennucc (Closes: #524043). -;; V1.70 11Nov2009 Peter S Galbraith <psg@debian.org> -;; - Add `debian-bug-bts-URL' variable -;; - Add `emacs-bug-web-bug', `emacs-bug-get-bug-as-email': -;; New commands to interface with Emacs BTS -;; V1.71 19Dec2009 Peter S Galbraith <psg@debian.org> -;; - Emacs BTS moved to debbugs.gnu.org -;; V1.72 27Apr2010 Peter S Galbraith <psg@debian.org> -;; - debian-bug-build-bug-menu takes optional SOURCE argument to create a -;; menu for source package. The problem comes from the BTS that no longer -;; finds source packages automatically, e.g. this won't work: -;; http://bugs.debian.org/cgi-bin/pkgreport.cgi?src=debian-el -;; but this is needed instead: -;; http://bugs.debian.org/cgi-bin/pkgreport.cgi?src=emacs-goodes-el -;; with the _real_ source package name. -;; V1.73 28Apr2010 H. Stordahl <hakon@stordahl.org> -;; As of version 4.12 reportbug has a --no-bug-script option which can -;; be used to work around bug #502317. -;; V1.74 07May2010 H. Stordahl <hakon@stordahl.org> -;; A better way to run bug scripts... (Closes #422506) -;; New functions: debian-bug-help-presubj, debian-bug-file-is-executable, -;; debian-bug-find-bug-script, debian-bug-script-sentinel, -;; debian-bug-run-bug-script, debian-bug-insert-bug-script-temp-file, -;; debian-bug-compose-report -;; Patch debian-bug-package to use them. -;; V1.74 07May2010 H. Stordahl <hakon@stordahl.org> -;; Support "Bugs:" control field for unofficial packages (Closes #222392) -;; New variable `debian-bug-bts-address' -;; New functions: -;; debian-bug-read-control-file-field -;; debian-bug-read-bug-control-file-field -;; debian-bug-find-bts-address -;; debian-bug-bts-mail -;; Patch debian-bug-prefill-report to use them -;; V1.75 13Mar2010 Peter S Galbraith <psg@debian.org> -;; Updated `debian-bug-pseudo-packages'. -;; V1.76 30Jan2014 Peter S Galbraith <psg@debian.org> -;; Finally applied patch from Sven Joachim to fix Bug #679390. Sorry! -;; V1.77 06Nov2016 Peter S Galbraith <psg@debian.org> -;; - Updated tags -;; - Bug fix: "Missing ; in debian-bug.el first line header", thanks -;; to Antoine R. Dumont (Closes: #842566). -;;---------------------------------------------------------------------------- - -;;; Todo (Peter's list): -;; -;; - Add extra prompt for release-critical severities (e.g. "This indicates -;; the package is not suitable for release. Proceed?") -;; - Possibly add a pre-send-mail hook to check that all entries are -;; validated. -;; - Help texts need a top-level general one (say where to look them up, -;; and how to search by package, bug submitter, maintainer, etc) -;; - debian-bug-wnpp accepts empty package name! -;; - debian-bug-wnpp doesn't get a Bugs menu or web lookup. -;; -> should lookup specified package to [O] and [ITO] ? -;; -> or list all bugs for wnpp? -;; - add debian-bug-pseudo-package (with completion on those only, possibly -;; with description) - -;;; User customizable variables: - -;;; Code: -(defgroup debian-bug nil "Debian Bug report helper" - :group 'tools - :prefix "debian-bug-") - -(defcustom debian-bug-display-help t - "Display help text when prompting for package name and bug severity." - :group 'debian-bug - :type 'boolean) - -(defcustom debian-bug-helper-program nil - "Helper program to use to generate bug report background info. -Possible values are 'bug, 'reportbug or nil (for neither). -If not customized, it will get set to at runtime to 'reportbug if the command -exists, or else to 'bug if that command exists, or else simply parse the -status file." - :group 'debian-bug - :type '(radio (const :tag "reportbug" reportbug) - (const :tag "bug" bug) - (const :tag "set at runtime" nil))) - -(defcustom debian-bug-use-From-address - (or (getenv "DEBEMAIL") ; reportbug - (getenv "REPORTBUGEMAIL") ; reportbug - (getenv "EMAIL")) ; reportbug and bug - "Insert a custom From line in the bug report header. -Use it to specify what email your bugs will be archived under." - :group 'debian-bug - :type 'boolean) - -(defcustom debian-bug-download-directory "~/" - "Directory for mbox file downloads from the Debian BTS." - :group 'debian-bug - :type 'directory) - -(defcustom debian-bug-mh-folder "+debian-bug" - "The folder to put all bug folders into when using MH-E (7.3 or better)." - :group 'debian-bug - :type '(choice (string :tag "Folder name") - (const :tag "Don't use a folder" nil))) - -;;; Not implemented yet. -;; (defcustom debian-bug-create-package-directories-flag nil -;; "Non-nil means to create a directory for each package. -;; For rmail, this means a directory beneath `debian-bug-download-directory'. -;; For MH-E, this means a folder beneath `debian-bug-mh-folder'." -;; :group 'debian-bug -;; :type 'boolean) - -;; This function is from emacs/lisp/calendar/icalendar.el, -;; necessary to replace "%s" with the bug number in -;; `debian-changelog-close-bug-statement' -(defsubst debian-bug--rris (&rest args) - "Replace regular expression in string. -Pass ARGS to `replace-regexp-in-string' (GNU Emacs) or to -`replace-in-string' (XEmacs)." - ;; XEmacs: - (if (fboundp 'replace-in-string) - (save-match-data ;; apparently XEmacs needs save-match-data - (apply 'replace-in-string args)) - ;; Emacs: - (apply 'replace-regexp-in-string args))) - -(defvar debian-bug-minor-mode nil) -(defvar debian-bug-minor-mode-map nil - "Keymap for `debian-bug' minor mode.") -(if debian-bug-minor-mode-map - nil - (setq debian-bug-minor-mode-map (make-sparse-keymap))) - -(if (not (fboundp 'match-string-no-properties)) - (load "poe" t t)) ;XEmacs21.1 doesn't autoload this - -;;; Guess From address initial value (if not set via customize) -(defun debian-bug-From-address-init () - "Return email to use for the From: line of the BTS email. -The full name is from the environment variable DEBFULLNAME or else the -variable `user-full-name'. -The email address is from the environment variable DEBEMAIL or EMAIL, -or else the `user-mail-address' variable." - (let ((fullname (or (getenv "DEBFULLNAME") - (getenv "DEBNAME") ; reportbug - (getenv "NAME") ; reportbug - (user-full-name))) - (mailing-address - (or (getenv "DEBEMAIL") ; reportbug - (getenv "REPORTBUGEMAIL") ; reportbug - (getenv "EMAIL") ; reportbug and bug - (and (boundp 'user-mail-address) user-mail-address) - (and (fboundp 'user-mail-address) (user-mail-address))))) - (cond - ((and fullname mailing-address) - (format "%s <%s>" fullname mailing-address)) - (mailing-address - mailing-address) - (t - nil)))) - -(defcustom debian-bug-From-address (debian-bug-From-address-init) - "Email address to use for the From: and CC: lines of Debian bug reports. -The default value is obtained from the function `debian-bug-From-address-init'." - :group 'debian-bug - :type 'string) - -(defcustom debian-bug-always-CC-myself t - "Insert a CC line to myself in the bug report header. -Will only actually do it if the variable `debian-bug-From-address' is set." - :group 'debian-bug - :type 'boolean) - -;;(defvar debian-bug-menu-action) -;;(defvar debian-bug-menu-action-default) -;;(defun debian-bug-menu-action-set (symbol value) -;; "Set SYMBOL to VALUE for -;; (set-default symbol value) -;; (setq-default debian-bug-menu-action debian-bug-menu-action-default) -;; (setq debian-bug-menu-action debian-bug-menu-action-default)) - -(defcustom debian-bug-menu-action-default 'browse - "Default action enabled at startup in Bugs menu-bar." - :group 'debian-bug -;; :set 'debian-bug-menu-action-set - :set (lambda (symbol value) - (set-default symbol value) - (setq-default debian-bug-menu-action debian-bug-menu-action-default) - (setq debian-bug-menu-action debian-bug-menu-action-default)) - :type '(radio (const :tag "Browse" browse) - (const :tag "Read as File" readfile) - (const :tag "Read as Email" email))) - -(defvar debian-bug-menu-action debian-bug-menu-action-default - "Action to take when selecting a bug number from the Bugs menu-bar.") -(make-variable-buffer-local 'debian-bug-menu-action) - -(defcustom debian-bug-menu-preload-flag nil - "Non-nil means to fetch bug list from the web and populate Bugs menu. -Otherwise, simply use the menu entry to generate it." - :group 'debian-bug - :type 'boolean) - -;; hooks -(defcustom debian-bug-get-bug-as-email-hook nil - "Hook run when getting a bug through `mail-user-agent'." - :group 'debian-bug - :type 'hook) - - -;;; Internal variables: - -(defvar debian-bug-bts-URL "http://bugs.debian.org/cgi-bin/bugreport.cgi?" - "URL of the Bug Tracking System to query.") - -(defvar debian-bts-control-for-emacs nil - "Whether `debian-bts-control' is being called for Emacs BTS.") - -(defvar debian-bug-mail-address - "Debian Bug Tracking System <submit@bugs.debian.org>" - "Email address that bugs are sent to.") - -(defvar debian-bug-mail-quiet-address - "Debian Bug Tracking System <quiet@bugs.debian.org>" - "Address to use to send to the BTS but not forward to the maintainer.") - -(defvar debian-bug-mail-maintonly-address - "Debian Bug Tracking System <maintonly@bugs.debian.org>" - "Address to use to send to the maintainer but not forward to the BTS.") - -(defvar debian-bug-status-file "/var/lib/dpkg/status" - "Debian installed package status file. -Used to get list of packages for prompt completion, and for report generation -when the shell commands \"bug\" and \"reportbug\" are not available") - -(defvar debian-bug-severity-alist - '(("critical") ("grave") ("serious") ("important") - ("normal") ("minor") ("wishlist")) - "Alist of possible bug severities used for prompt completion.") - -(defvar debian-bug-tags-alist - '(("patch") ("security") ("upstream")) -;;'(("patch") ("security") ("upstream") ("potato") ("woody") ("sarge") ("sid")) - "Alist of valid Tags aimed at Debian users. -The complete list of valid tags is longer, but the others are for use by -Debian maintainers.") - -(defvar debian-bug-alltags-alist - '(("patch") ("wontfix") ("moreinfo") ("unreproducible") ("help") ("pending") - ("fixed") ("fixed-in-experimental") ("fixed-upstream") ("security") - ("upstream") ("confirmed") ("d-i") ("ipv6") ("lfs") ("l10n") ("potato") - ("woody") ("sarge") ("sarge-ignore") ("etch") ("etch-ignore") ("lenny") - ("squeeze") ("wheezy") ("jessie") ("sid") ("experimental")) - "Alist of all valid Tags, aimed at Debian developpers.") - -(defvar debian-bug-pseudo-packages - '("base" "bugs.debian.org" "buildd.debian.org" "buildd.emdebian.org" - "cdimage.debian.org" "cdrom" "debian-i18n" "debian-maintainers" - "ftp.debian.org" "general" "installation-reports" "lists.debian.org" - "mirrors" "nm.debian.org" "press" "project" "qa.debian.org" "release-notes" - "release.debian.org" "security-tracker" "security.debian.org" - "snapshot.debian.org" "tech-ctte" "upgrade-reports" "wiki.debian.org" - "wnpp" "www.debian.org") - - "List of Debian pseudo-packages available for completion. -See http://www.debian.org/Bugs/pseudo-packages") - -(defvar debian-bug-packages-obarray nil - "List of Debian packages from status file used for completion.") - -(defvar debian-bug-packages-date nil - "Last modification time of status file used for internal package list. -Used to determine if internal list is uptodate.") - -(defvar debian-bug-package-name nil - "Buffer-local variable holding the package name for this submission.") -(make-variable-buffer-local 'debian-bug-package-name) - -(defvar debian-bug-bts-address "bugs.debian.org" - "Name of BTS to which the bug report will be submitted.") -(make-variable-buffer-local 'debian-bug-bts-address) - -(defvar debian-bug-easymenu-list nil - "Holds the dynamically built easymenu list.") -(defvar debian-bug-bugs-menu nil - "Buffer local Bugs menu.") -(make-variable-buffer-local 'debian-bug-bugs-menu) -(defvar debian-bug-alist nil - "Buffer local alist of bug numbers (and description) for this package.") -(make-variable-buffer-local 'debian-bug-alist) -(defvar debian-bug-open-alist nil - "Buffer local alist of open bug numbers (and description) for this package.") -(make-variable-buffer-local 'debian-bug-open-alist) - -(defalias 'report-debian-bug 'debian-bug) - -;;; Functions: -(autoload 'reporter-compose-outgoing "reporter") -(autoload 'mail-header-end "sendmail") -(autoload 'match-string-no-properties "poe") ;XEmacs -(autoload 'debian-changelog-suggest-package-name "debian-changelog-mode") -(autoload 'debian-changelog-close-bug "debian-changelog-mode") -(autoload 'mh-find-path "mh-utils") -(autoload 'mh-expand-file-name "mh-utils") -(autoload 'mh-visit-folder "mh-e") -(autoload 'mh-exec-cmd-quiet "mh-utils") -(autoload 'mh-inc-folder "mh-e") - -(defun debian-bug-intern (pair) - "Simple function to intern PAIR of car cdr in `debian-bug-packages-obarray'." - (set (intern (car pair) debian-bug-packages-obarray) (cdr pair))) - -(defun debian-bug-fill-packages-obarray () - "Build `debian-bug-packages-obarray' and return its value. -The obarray associates each package with the installed version of the package." - (if (not (and (vectorp debian-bug-packages-obarray) - (equal debian-bug-packages-date - (nth 5 (file-attributes debian-bug-status-file))))) - (let ((case-fold-search t) - (packages (length debian-bug-pseudo-packages)) - (real-pkgs '()) - this-pkg this-ver) - (message "Building list of installed packages...") - (with-temp-buffer - (insert-file-contents-literally debian-bug-status-file) - (while (not (eobp)) - (cond ((looking-at "$") - (if (and this-pkg this-ver) - (setq real-pkgs (cons (cons this-pkg this-ver) real-pkgs) - packages (1+ packages))) - (setq this-pkg nil - this-ver nil)) - ((looking-at "Package *: *\\([^ ]*\\)$") - (setq this-pkg (match-string 1))) - ((looking-at "Version *: *\\([^ ]*\\)$") - (setq this-ver (match-string 1)))) - (forward-line))) - (setq debian-bug-packages-obarray - (make-vector (1- (ash 4 (logb packages))) 0) - debian-bug-packages-date - (nth 5 (file-attributes debian-bug-status-file))) - (mapcar 'debian-bug-intern (mapcar 'list debian-bug-pseudo-packages)) - (mapcar 'debian-bug-intern real-pkgs) - (message "Building list of installed packages...done"))) - (if debian-bts-control-for-emacs - '(("bzr") ("debbugs.gnu.org") ("gnus") ("octave") - ("other") ("rmail")) - debian-bug-packages-obarray)) - -(defun debian-bug-check-for-program (program) - "Check if PROGRAM is installed on the system. -Done by calling `executable-find' or the external \"which\" utility." - (if (fboundp 'executable-find) - (executable-find program) - (zerop (call-process "which" nil nil nil program)))) - -(defun debian-bug-helper-program () - "Return helper program found on system. -This can be removed at some point since `bug' is not released in sarge." - (or debian-bug-helper-program - (cond - ((debian-bug-check-for-program "reportbug") - 'reportbug) - ((debian-bug-check-for-program "bug") - 'bug) - (t - 'none)))) - -(defun debian-bug-read-control-file-field (package field) - "In the control file of PACKAGE, return the value of FIELD. -This is achieved by parsing the output of dpkg -s. If the field -doesn't exist, nil is returned." - (let ((case-fold-search t)) - (with-temp-buffer - (call-process "dpkg" nil '(t nil) nil "-s" package) - (goto-char (point-min)) - (if (re-search-forward - (concat "^" field " *: *\\(.+\\)$") nil t) - (match-string 1))))) - -(defun debian-bug-read-bug-control-file-field (package field) - "In the bug control file of PACKAGE, return the value of FIELD if it exists. -Otherwise nil is returned." - (let ((control (concat "/usr/share/bug/" package "/control")) - (case-fold-search t)) - (if (file-readable-p control) - (with-temp-buffer - (insert-file-contents-literally control) - (goto-char (point-min)) - (if (re-search-forward - (concat "^" field " *: *\\(.+\\)$") nil t) - (match-string 1)))))) - -(defun debian-bug-find-bts-address (package) - "Return address of BTS where bug reports on PACKAGE should be submitted. -This is specified by either the Bugs field in the control file for PACKAGE, -or the Send-To field in the file /usr/share/bug/PACKAGE/control. If neither -of these fields have been specified, the address of the Debian BTS is -returned. Note that the address returned can be either a complete e-mail -address or the host address of the BTS. In the latter case the address -must be expanded, by prepending \"submit\", \"maintonly\" or \"quiet\", as -appropriate, followed by the at-sign, before it can be used to submit bug -reports." - (let ((bugs-field (debian-bug-read-control-file-field - package "Bugs")) - (send-to-field (debian-bug-read-bug-control-file-field - package "Send-To"))) - (cond - ((and bugs-field (string-match "^\\(debbugs://\\|mailto:\\)\\(.+\\)$" - bugs-field)) - (match-string 2 bugs-field)) - (send-to-field send-to-field) - (t "bugs.debian.org")))) - -(defun debian-bug-bts-mail (type bts-address) - "Return the complete e-mail address which should be used to submit the bug. -The TYPE parameter is typically either of the strings \"submit\", -\"quiet\" or \"maintonly\". However, if BTS-ADDRESS is already a -complete e-mail address, the TYPE parameter is ignored, and this -function simply returns BTS-ADDRESS." - (if (string-match "@" bts-address) - bts-address - (concat type "@" bts-address))) - -(defun debian-bug-prefill-report (package severity) - "Prefill bug report for PACKAGE at SEVERITY, calling bug or reportbug." - (cond - ;; bug - ((and (eq (debian-bug-helper-program) 'bug) - (intern-soft package debian-bug-packages-obarray)) - (save-excursion - (call-process "bug" nil '(t t) nil "-p" "-s" "" "-S" severity package)) - (forward-line 4)) - - ;; reportbug - ((eq (debian-bug-helper-program) 'reportbug) - (save-excursion - (call-process "reportbug" nil '(t t) nil - "--template" "-T" "none" "-s" "none" "-S" "normal" "-b" - "--list-cc=none" "--no-bug-script" - "-q" package) - (debian-bug--set-severity severity)) - ;; delete the mail headers, leaving only the BTS pseudo-headers - (delete-region - (point) - (or (search-forward "\n\n" nil t) - ;; Fix from Matt Swift - (error "Reportbug did not produce expected output! Bailing out. -Reportbug may have sent an empty report!"))) - ;; and skip forward to them - (search-forward "\n\n" nil t) - ) - - ;; neither reportbug nor bug - (t - (insert - "Package: " (or (debian-bug-read-bug-control-file-field - package "Submit-As") - package) - "\nVersion: " (let ((sym (intern-soft package debian-bug-packages-obarray))) - (or (if (boundp sym) (symbol-value sym)) - (format-time-string "+N/A; reported %Y-%m-%d"))) - "\nSeverity: " severity - "\n\n\n\n-- System Information" - "\nDebian Release: ") - - (if (file-readable-p "/etc/debian_version") - (forward-char (cadr - (insert-file-contents-literally "/etc/debian_version"))) - (insert "unknwown\n")) - - (insert "Kernel Version: ") - (call-process "uname" nil '(t t) nil "-a") - (forward-line -5)))) - -(defun debian-bug-help-presubj (package) - "Display contents of /usr/share/bug/PACKAGE/presubj." - (let ((presubj (concat "/usr/share/bug/" package "/presubj"))) - (if (file-readable-p presubj) - (with-output-to-temp-buffer "*Help*" - (with-current-buffer "*Help*" - (insert-file-contents presubj)))))) - -(defun debian-bug-file-is-executable (file) - "Return non-nil if FILE is executable. Otherwise nil is returned." - (and - (file-regular-p file) - (file-executable-p file))) - -(defun debian-bug-find-bug-script (package) - "Return the full path name of the bug script of PACKAGE. -If such script exists, otherwise nil is returned." - (let ((script-alt1 (concat "/usr/share/bug/" package "/script")) - (script-alt2 (concat "/usr/share/bug/" package))) - (cond - ((debian-bug-file-is-executable script-alt1) script-alt1) - ((debian-bug-file-is-executable script-alt2) script-alt2)))) - -(defun debian-bug-script-sentinel - (process event package severity subject filename - bug-script-temp-file win-config) - "This function is the process sentinel for bug script processes. -When called, if the process has terminated, this function cleans -up the buffer used by the process and proceeds to the next step in the -bug reporting process by calling `debian-bug-compose-report'. Note that -this process sentinel is different from regular process sentinels in -that it requires more arguments. So, it cannot be assigned to a process -with `set-process-sentinel' directly, but requires some tweaking instead." - (if (memq (process-status process) '(exit signal)) - (let* ((bug-script-buffer - (process-buffer process)) - (bug-script-buffer-empty - (= (buffer-size bug-script-buffer) 0))) - - ;; Call the process sentinel provided by the term module, to - ;; clean up the terminal buffer. The sentinel will print a - ;; message in the buffer, so we have been careful to check - ;; whether the buffer is empty above, before this call. - ;; Note, XEmacs' term module doesn't provide this sentinel. - (if (fboundp 'term-sentinel) - (term-sentinel process event)) - - ;; The reportbug program doesn't seem to care about the exit - ;; status of a bug script, so we won't do it either. - ;; (if (/= (process-exit-status process) 0) - ;; (error (concat "Error occured while collecting" - ;; " information about the package"))) - - ;; If there is a window displaying the bug script buffer, - ;; restore the original window configuration, because it - ;; might have been changed when the bug script buffer was - ;; displayed. Otherwise, if the buffer isn't visible, - ;; assume that the window configuration hasn't changed, so - ;; don't restore anything. - (if (get-buffer-window bug-script-buffer) - (set-window-configuration win-config)) - - ;; If the process output buffer still exists, kill it if it's - ;; empty, otherwise bury it. - (if (buffer-name bug-script-buffer) - (if bug-script-buffer-empty - (kill-buffer bug-script-buffer) - (bury-buffer bug-script-buffer))) - - (debian-bug-compose-report package severity subject filename - bug-script-temp-file)))) - -(defun debian-bug-run-bug-script (package severity subject filename) - "Run a script, if provided by PACKAGE, to collect information. -The information about the package which should be supplied with -the bug report, and then proceed to the next step in the bug -reporting process by calling `debian-bug-compose-report'." - (let ((handler "/usr/share/reportbug/handle_bugscript") - (bug-script (debian-bug-find-bug-script package))) - (if (and bug-script - (debian-bug-file-is-executable handler) - (if (featurep 'xemacs) - (or (featurep 'term) (load "term" 'noerror)) - (require 'term nil 'noerror))) - (let ((bug-script-buffer - (get-buffer-create "*debian-bug-script*")) - (bug-script-temp-file - (cond ((fboundp 'make-temp-file) ;; XEmacs doesn't know - (make-temp-file "debian-bug-")) ;; make-temp-file. - ((fboundp 'temp-directory) - (make-temp-name (expand-file-name - "debian-bug-" (temp-directory)))) - (t (error "Cannot create temporary file")))) - (bug-script-process) - - ;; XEmacs' term module doesn't set the appropriate - ;; coding system for process output from term-exec. - ;; Thus the following workaround, otherwise the terminal - ;; displayed by XEmacs can get messed up. - (coding-system-for-read 'binary)) - - (message (concat "Collecting information about the package." - " This may take some time.")) - (with-current-buffer bug-script-buffer - (erase-buffer) - (term-mode) - (term-exec bug-script-buffer "debian-bug-script" handler nil - (list bug-script bug-script-temp-file)) - (setq bug-script-process - (get-buffer-process bug-script-buffer)) - - ;; The process sentinel should handle process termination. - ;; Note that we need to pass more information to the - ;; process sentinel than just the process object and event - ;; type. Ideally, the process property list seems suitable - ;; for this purpose, but that is only supported in GNU - ;; Emacs 22 and later. So, a hack is used to construct the - ;; process sentinel with the required data on the fly. - ;; However, I suspect there are better ways to do this, - ;; perhaps to use lexical-let. - (set-process-sentinel - bug-script-process - (list 'lambda '(process event) - (list 'debian-bug-script-sentinel 'process 'event - package severity subject filename - bug-script-temp-file - (current-window-configuration)))) - - (term-char-mode) - - ;; The function set-process-query-on-exit-flag is only - ;; available in GNU Emacs version 22 and later. - (if (fboundp 'set-process-query-on-exit-flag) - (set-process-query-on-exit-flag bug-script-process nil))) - - ;; Delay switching to the process output buffer by waiting - ;; for output from the process, the process to terminate or - ;; 200 seconds, because ideally we don't want to display the - ;; buffer unless the process will be requesting input, but - ;; it's no way to tell that in advance. If the process - ;; prints to stdout, it's likely it will be expecting input, - ;; so we display the buffer. If the process terminates with - ;; no output, we simply don't do anything; the process - ;; sentinel will kill the buffer, and proceed, upon process - ;; termination. - (accept-process-output bug-script-process 200) - - ;; Short wait required here for the process-status to be - ;; updated. (Maybe a bug in Emacs?) - (sleep-for 0.050) - (if (not (memq (process-status bug-script-process) - '(exit signal))) - (switch-to-buffer-other-window bug-script-buffer))) - - (debian-bug-compose-report package severity subject filename)))) - -(defun debian-bug-insert-bug-script-temp-file (temp-file) - "Insert the output from the bug script, if any, into the current buffer." - (when (and temp-file (file-readable-p temp-file)) - (save-excursion - (next-line 1) - (insert "\n") - (insert "-- Package-specific info:\n") - (let ((beg (point)) - (end (+ (point) - (nth 1 (insert-file-contents temp-file))))) - (save-restriction - (narrow-to-region beg end) - (goto-char (point-max)) - (beginning-of-line) - (when (not (looking-at "$")) - (end-of-line) - (insert "\n")) - (when (or (and (boundp 'mml-mode) mml-mode) - (memq mail-user-agent '(mh-e-user-agent - message-user-agent - gnus-user-agent))) - (mml-quote-region (point-min) (point-max)) - (goto-char (point-min)) - (insert "<#part type=\"text/plain\" disposition=attachment" - " description=\"Bug script output\">\n") - (goto-char (point-max)) - (insert "<#/part>\n")))) - (delete-file temp-file)))) - -(defun debian-bug-package (&optional package filename) - "Submit a Debian bug report about PACKAGE." - (if (or (not package) (string= "" package)) - (save-window-excursion - (when debian-bug-display-help - (debian-bug-help-pseudo-packages) - ;; This lets M-<next> and M-<prev> scroll the pseudo-package list - ;; window by making _it_ the other window. - (if (get-buffer-window "*Help*") - (select-window (get-buffer-window "*Help*")))) - (setq package (completing-read - "Package name: " - (debian-bug-fill-packages-obarray) - nil nil nil nil (current-word))))) - (if (string= package "wnpp") - (debian-bug-wnpp) - (debian-bug-fill-packages-obarray) - (if (and (not (intern-soft package debian-bug-packages-obarray)) - (not (y-or-n-p - "Package does not appear to be installed. Continue? "))) - (error "Quitting")) - (let ((severity (save-window-excursion - (if debian-bug-display-help - (debian-bug-help-severity)) - (completing-read "Severity (default normal): " - debian-bug-severity-alist - nil t nil nil "normal"))) - (subject (save-window-excursion - (debian-bug-help-presubj package) - (read-string "(Very) brief summary of problem: ")))) - (debian-bug-run-bug-script package severity subject filename)))) - -(defun debian-bug-compose-report - (package severity subject filename &optional bug-script-temp-file) - "Compose the initial contents of the bug report and present it in a buffer. -The buffer will be completed by the user." -;;; (require 'reporter) - (reporter-compose-outgoing) - (if (and (equal mail-user-agent 'gnus-user-agent) - (string-equal " *nntpd*" (buffer-name))) - (set-buffer "*mail*")) ; Bug in emacs21.1? Moves to " *nntpd*" - (goto-char (point-min)) - (when (re-search-forward "^cc:" nil t) - (delete-region (match-beginning 0)(match-end 0)) - (insert "X-Debbugs-CC:")) - (setq debian-bug-bts-address - (debian-bug-find-bts-address package)) - (goto-char (point-min)) - (cond - ((re-search-forward "To: " nil t) - (insert debian-bug-mail-address)) - ((re-search-forward "To:" nil t) - (insert " " debian-bug-mail-address)) - (t - (insert "To: " debian-bug-mail-address))) - (if (string-equal severity "minor") - (debian-bug--set-bts-address - (debian-bug-bts-mail "maintonly" debian-bug-bts-address)) - (debian-bug--set-bts-address - (debian-bug-bts-mail "submit" debian-bug-bts-address))) - (goto-char (point-min)) - (cond - ((re-search-forward "Subject: " nil t) - (insert package ": " subject)) - ((re-search-forward "Subject:" nil t) - (insert " " package ": " subject)) - (t - (insert "Subject: " package ": " subject))) - (require 'sendmail) - (goto-char (mail-header-end)) - (forward-line 1) - (if (looking-at "^<#secure") ;Skip over mml directives - (forward-line 1)) - (message "Getting package information from reportbug...") - (debian-bug-prefill-report package severity) - (message "Getting package information from reportbug...done") - (if debian-bug-use-From-address - (debian-bug--set-custom-From)) - (if debian-bug-always-CC-myself - (debian-bug--set-CC debian-bug-From-address "X-Debbugs-CC:")) - (when filename - (forward-char -1) - (insert "File: " filename "\n") - (forward-char 1)) - (debian-bug-insert-bug-script-temp-file bug-script-temp-file) - (set-window-start (selected-window) (point-min) t) - (setq debian-bug-package-name package) - (debian-bug-minor-mode 1) - (set-buffer-modified-p nil)) - -;;; --------- -;;; WNPP interface by Peter S Galbraith <psg@debian.org>, August 4th 2001 -(defvar debian-bug-wnpp-alist - '(("Intent to Package [ITP]" . "ITP") - ("Orphaned [O]". "O") - ("Request for Adoption [RFA]" . "RFA") - ("Request For Package [RFP]" . "RFP") - ("Request For Help [RFH]" . "RFH")) - "Alist of WNPP possible bug reports.") - -(defvar debian-bug-wnpp-severities - '(("ITP" . "wishlist") - ("O". "normal") - ("RFA" . "normal") - ("RFP" . "wishlist") - ("RFH" . "normal")) - "Bug severeties for each WNPP bug type.") - -;;;###autoload -(defun debian-bug-wnpp (&optional action) - "Submit a WNPP bug report to Debian. -Optional argument ACTION can be provided in programs." - (interactive - (list (completing-read - "Action: (Press TAB) " debian-bug-wnpp-alist nil t nil))) - (if (or (not action) (string= action "")) - (setq action (completing-read - "Action: (Press TAB) " debian-bug-wnpp-alist nil t nil))) - (if (or (not action) (string= action "")) - (error "Nothing to do")) - (require 'reporter) - (debian-bug-fill-packages-obarray) - (let* ((tag (cdr (assoc action debian-bug-wnpp-alist))) - (severity (cdr (assoc tag debian-bug-wnpp-severities))) - (package - (completing-read - (cond ((string-equal action "Intent to Package [ITP]") - "Proposed package name: ") - ((string-equal action "Request For Package [RFP]") - "Requested package name: ") - (t - "package name: ")) - debian-bug-packages-obarray nil nil nil)) - ;;FIXME: Should fetch description from system for "[O]" and "[ITO]" - (description (read-string "Very short package description: ")) - (CC-devel (y-or-n-p "CC bug report to debian-devel? "))) - (require 'reporter) - (reporter-compose-outgoing) - (if (and (equal mail-user-agent 'gnus-user-agent) - (string-equal " *nntpd*" (buffer-name))) - (set-buffer "*mail*")) ; Bug in emacs21.1? Moves to " *nntpd*" - (goto-char (point-min)) - (if (re-search-forward "To:" nil t) - (insert " " debian-bug-mail-address) - (insert "To: " debian-bug-mail-address)) - (require 'sendmail) - (goto-char (mail-header-end)) - (forward-line 1) - (if (looking-at "^<#secure") ;Skip over mml directives - (forward-line 1)) - (save-excursion - (goto-char (point-min)) - (if debian-bug-use-From-address - (debian-bug--set-custom-From)) - (if debian-bug-always-CC-myself - (debian-bug--set-CC debian-bug-From-address "X-Debbugs-CC:")) - (if (re-search-forward "Subject: " nil t) - (insert (format "%s: %s -- %s" tag package description)) - (re-search-forward "Subject:" nil t) - (insert (format " %s: %s -- %s" tag package description))) - (if CC-devel - (debian-bug--set-CC "debian-devel@lists.debian.org" - "X-Debbugs-CC:"))) - (insert "Package: wnpp\n") - (when (and (string-equal tag "ITP") - debian-bug-From-address) - (insert (format "Owner: %s\n" debian-bug-From-address))) - (insert (format "Severity: %s\n\n" severity)) - (when (or (string-equal tag "ITP") - (string-equal tag "RFP")) - (insert -;;; "< Enter some information about the package, upstream URL and license here. >\n" - "* Package name : " package "\n" - " Version : \n" - " Upstream Author : \n" - "* URL or Web page : \n" - "* License : \n" - " Description : " description "\n") - (forward-line -1)) - (set-window-start (selected-window) (point-min) t) - (debian-bug-wnpp-minor-mode 1) - (set-buffer-modified-p nil))) - -;;;###autoload -(defun debian-bug-request-for-package () - "Shortcut for `debian-bug-wnpp' with RFP action." - (interactive) - (debian-bug-wnpp "Request For Package [RFP]")) -(defalias 'debian-bug-RFP 'debian-bug-request-for-package) - -;;;###autoload -(defun debian-bug-intent-to-package () - "Shortcut for `debian-bug-wnpp' with ITP action (for Debian developers)." - (interactive) - (debian-bug-wnpp "Intent to Package [ITP]")) -(defalias 'debian-bug-ITP 'debian-bug-intent-to-package) - -;;; font-lock by Peter S Galbraith <psg@debian.org>, August 11th 2001 -(defvar debian-bug-font-lock-keywords - '(("^ *\\(Package:\\) *\\([^ ]+\n\\)?" - (1 font-lock-keyword-face) - (2 font-lock-type-face nil t)) - ("^ *\\(Owner:\\) *\\(.+\n\\)?" - (1 font-lock-keyword-face) - (2 font-lock-type-face nil t)) - ("^ *\\(File:\\) *\\([^ ]+\n\\)?" - (1 font-lock-keyword-face) - (2 font-lock-type-face nil t)) - ("^ *\\(Version:\\) *\\([^ \n]+\n\\)?" - (1 font-lock-keyword-face) - (2 font-lock-type-face nil t)) - ("^ *\\(Tags:\\).*\\(\\(patch\\|experimental\\)\\)" - (1 font-lock-keyword-face) - (2 font-lock-type-face nil t)) - ("^ *\\(Tags:\\).*\\(security\\)" - (1 font-lock-keyword-face) - (2 font-lock-warning-face nil t)) - ("^ *\\(Severity:\\) *\\(\\(critical\\|grave\\|serious\\)\\|\\(important\\)\\|\\(normal\\)\\|\\(\\(minor\\)\\|\\(wishlist\\)\\)\\)" - (1 font-lock-keyword-face) - (3 font-lock-warning-face nil t) - (4 font-lock-function-name-face nil t) - (5 font-lock-type-face nil t) - (6 font-lock-string-face nil t)) - ("^Subject: \\[\\(ITP\\|O\\|RFA\\|RFP\\)\\]" - (1 font-lock-warning-face t t))) - "Regexp keywords to fontify `debian-bug' reports.") - -;;; --------- -;;; Menu-bar via minor-mode -;; Peter S Galbraith <psg@debian.org>, August 12th 2001 - -(defun debian-bug--is-custom-From () - "Return t if first line begins in From:." - (save-excursion - (goto-char (point-min)) - (looking-at "^From:"))) - -(defun debian-bug--unset-custom-From () - "Remove From line in the mail header." - (save-excursion - (goto-char (point-min)) - (let ((header-end (re-search-forward "^-*$" nil t))) - (goto-char (point-min)) - (when (re-search-forward "^From:" header-end t) - (delete-region (progn (beginning-of-line)(point)) - (progn (forward-line 1)(point))))))) - -(defun debian-bug--set-custom-From () - "Set a From line using the `debian-bug-From-address' variable." - (if (not debian-bug-From-address) - (error "Variable debian-bug-From-address is unset, please customize it") - (save-excursion - (goto-char (point-min)) - (debian-bug--unset-custom-From) - (insert "From: " debian-bug-From-address "\n")))) - -(defun debian-bug--toggle-custom-From () - "Toggle the From line using the `debian-bug-From-address' variable." - (if (debian-bug--is-custom-From) - (debian-bug--unset-custom-From) - (debian-bug--set-custom-From))) - -(defun debian-bug--is-CC (address field) - "Return t if ADDRESS is present in FIELD." - (save-excursion - (goto-char (point-min)) - (let ((case-fold-search t)) - (re-search-forward - (concat "^" field ".*" (regexp-quote address)) nil t)))) - -(defun debian-bug--remove-CC (address field &optional nocleanup) - "Remove ADDRESS from FIELD. -Non-nil optional argument NOCLEANUP means remove empty field." - (save-excursion - (goto-char (point-min)) - (if (or (re-search-forward (concat "^" field ".*\\(" - (regexp-quote address) ", \\)") nil t) - (re-search-forward (concat "^" field ".*\\(, " - (regexp-quote address) "\\)") nil t) - (re-search-forward (concat "^" field ".*\\(" - (regexp-quote address) "\\)") nil t)) - (delete-region (match-beginning 1)(match-end 1))) - (goto-char (point-min)) - (if (and (not nocleanup) - (re-search-forward (concat "^ *" field " *\n") nil t)) - (delete-region (match-beginning 0)(match-end 0))))) - -(defun debian-bug--set-CC (address field) - "Add ADDRESS to FIELD." - (debian-bug--remove-CC address field t) - (save-excursion - (goto-char (point-min)) - (cond - ((re-search-forward (concat "^" field " +$") nil t) ;Empty X-Debbugs-CC: - (insert address)) - ((re-search-forward (concat "^" field "$") nil t) ;Empty X-Debbugs-CC: - (insert " " address)) - ((re-search-forward (concat "^" field ".*$") nil t) ;Existing X-Debbugs-CC - (insert ", " address)) - ((re-search-forward "^Subject:.*\n" nil t) - (insert field " " address "\n")) - ((re-search-forward "^To: .*\n" nil t) - (insert field " " address "\n")) - (t - (insert field " " address "\n"))))) - -(defun debian-bug--toggle-CC (address field) - "Add ADDRESS to FIELD or remove it if present." - (if (debian-bug--is-CC address field) - (debian-bug--remove-CC address field) - (debian-bug--set-CC address field))) - -(defun debian-bug--toggle-CC-myself () - "Toggle X-Debbugs-CC: or Cc: line for myself in the mail header." - (when debian-bug-From-address - (if debian-bug-minor-mode - (debian-bug--toggle-CC debian-bug-From-address "X-Debbugs-CC:") - (debian-bug--toggle-CC debian-bug-From-address "cc:")))) - -(defun debian-bug--toggle-CC-devel () - "Toggle X-Debbugs-CC: or CC: line for debian-devel in the mail header." - (if debian-bug-minor-mode - (debian-bug--toggle-CC "debian-devel@lists.debian.org" "X-Debbugs-CC:") - (debian-bug--toggle-CC "debian-devel@lists.debian.org" "cc:"))) - -(defun debian-bug--is-severity (severity) - "Return t is current report has severity of SEVERITY." - (save-excursion - (goto-char (point-min)) - (if (re-search-forward "^ *Severity: +\\([a-zA-Z]+\\)" nil t) - (let ((actualSeverity (match-string-no-properties 1))) - (string= actualSeverity severity))))) - -(defun debian-bug--set-severity (severity) - "Set bug SEVERITY level." - (interactive (list (completing-read "Severity: " debian-bug-severity-alist - nil t nil nil))) - (if (not severity) - nil ; We're done! - (save-excursion - (goto-char (point-min)) - (cond - ((re-search-forward "^ *Severity: \\([a-zA-Z]+\\)" nil t) - (goto-char (match-beginning 1)) - (delete-region (match-beginning 1)(match-end 1)) - (insert severity)) - ((re-search-forward "^ *Version: .*\n" nil t) - (insert "Severity: " severity)) - ((re-search-forward "^ *Package: .*\n" nil t) - (insert "Severity: " severity)) - (t - (forward-line 6) - (insert "\nSeverity: " severity "\n")))))) - - -(defun debian-bug--is-tags (tag) - "Return t if current report has a tags entry of TAG." - (save-excursion - (goto-char (point-min)) - (re-search-forward (concat "^ *Tags:.*" tag) nil t))) - -(defun debian-bug--remove-tags (tag &optional nocleanup) - "Remove TAG. -Non-nil optional argument NOCLEANUP means remove empty field." - (save-excursion - (goto-char (point-min)) - (if (or (re-search-forward (concat "^ *Tags:.*\\(" tag ", \\)") nil t) - (re-search-forward (concat "^ *Tags:.*\\(, " tag "\\)") nil t) - (re-search-forward (concat "^ *Tags:.*\\(" tag "\\)") nil t)) - (delete-region (match-beginning 1)(match-end 1))) - (goto-char (point-min)) - (if (and (not nocleanup) - (re-search-forward "^ *Tags: *\n" nil t)) - (delete-region (match-beginning 0)(match-end 0))))) - -(defun debian-bug--set-tags (tag) - "Set TAG." - (debian-bug--remove-tags tag t) - (save-excursion - (goto-char (point-min)) - (cond - ((re-search-forward "^ *Tags: *$" nil t) ; Empty "Tags: " - (insert tag)) - ((re-search-forward "^ *Tags:.*$" nil t) ; Existing "Tags: " - (insert ", " tag)) - ((re-search-forward "^ *Severity: .*\n" nil t) - (insert "Tags: " tag "\n")) - ((re-search-forward "^ *Version: .*\n" nil t) - (insert "Tags: " tag "\n")) - ((re-search-forward "^ *Package: .*\n" nil t) - (insert "Tags: " tag "\n")) - (t - (forward-line 6) - (insert "\nTags: " tag "\n"))))) - -(defun debian-bug--toggle-tags (tag) - "Toggle TAG." - (interactive (list (completing-read "Tag: " debian-bug-tags-alist - nil t nil nil))) - (if (not tag) - nil ; We're done! - (if (debian-bug--is-tags tag) - (debian-bug--remove-tags tag) - (debian-bug--set-tags tag)))) - -(defun debian-bug--is-bts-address (address) - "Return t if ADDRESS is present in address field." - (save-excursion - (goto-char (point-min)) - (re-search-forward (concat "^To:.*" (regexp-quote address)) nil t))) - -(defun debian-bug--set-bts-address (address) - "Set \"To\" header field to ADDRESS." - (interactive (list (completing-read "To: " - '(("submit@bugs.debian.org") - ("quiet@bugs.debian.org") - ("maintonly@bugs.debian.org")) - nil t nil nil))) - (cond - ((string= "submit@bugs.debian.org" address) - (setq address debian-bug-mail-address)) - ((string= "quiet@bugs.debian.org" address) - (setq address debian-bug-mail-quiet-address)) - ((string= "maintonly@bugs.debian.org" address) - (setq address debian-bug-mail-maintonly-address))) - (if (not address) - nil ; We're done! - (save-excursion - (goto-char (point-min)) - (cond - ((re-search-forward "^To: \\(.*\\)" nil t) - (goto-char (match-beginning 1)) - (delete-region (match-beginning 1)(match-end 1)) - (insert address)) - (t - (insert "To: " address "\n")))))) - -(defun debian-bug-help-severity () - "Display severity help." - (with-output-to-temp-buffer "*Help*" - (princ "Severity levels - - The bug system records a severity level with each bug report. This is set to - normal by default, but can be overridden either by supplying a Severity line - in the pseudo-header when the bug is submitted (see the instructions for - reporting bugs), or by using the severity command with the control request - server. - - The severity levels are: - - critical - makes unrelated software on the system (or the whole system) break, or - causes serious data loss, or introduces a security hole on systems - where you install the package. - grave - makes the package in question unuseable or mostly so, or causes data - loss, or introduces a security hole allowing access to the accounts of - users who use the package. - serious - is a severe violation of Debian policy (that is, it violates a \"must\" - or \"required\" directive), or, in the package maintainer's opinion, - makes the package unsuitable for release. - important - a bug which has a major effect on the usability of a package, without - rendering it completely unusable to everyone. - normal - the default value, applicable to most bugs. - minor - a problem which doesn't affect the package's usefulness, and is - presumably trivial to fix. - wishlist - for any feature request, and also for any bugs that are very difficult - to fix due to major design considerations. - fixed - for bugs that are fixed but should not yet be closed. This is an - exception for bugs fixed by non-maintainer uploads. Note: the \"fixed\" - tag should be used instead. - -Certain severities are considered release-critical, meaning the bug will -have an impact on releasing the package with the stable release of -Debian. Currently, these are critical, grave and serious. - -Info from http://www.debian.org/Bugs/Developer#severities -Feb 8th 2002, checked Apr 22 2003."))) - -(defun debian-bug-help-tags () - "Display tags help." - (with-output-to-temp-buffer "*Help*" - (princ - "Tags for bug reports - - Each bug can have zero or more of a set of given tags. These tags are - displayed in the list of bugs when you look at a package's page, and when - you look at the full bug log. - - Tags can be set by supplying a Tags line in the pseudo-header when the bug - is submitted (see the instructions for reporting bugs), or by using the - tags command with the control request server. Separate multiple tags with - commas, spaces, or both. - - The current bug tags are: - - patch - A patch or some other easy procedure for fixing the bug is included in - the bug logs. If there's a patch, but it doesn't resolve the bug adequately - or causes some other problems, this tag should not be used. - - wontfix - This bug won't be fixed. Possibly because this is a choice between - two arbitrary ways of doing things and the maintainer and submitter prefer - different ways of doing things, possibly because changing the behaviour - will cause other, worse, problems for others, or possibly for other - reasons. - - moreinfo - This bug can't be addressed until more information is provided by the - submitter. The bug will be closed if the submitter doesn't provide more - information in a reasonable (few months) timeframe. This is for bugs like - \"It doesn't work\". What doesn't work? - - unreproducible - This bug can't be reproduced on the maintainer's system. Assistance - from third parties is needed in diagnosing the cause of the problem. - - help - The maintainer is requesting help with dealing with this bug. - - pending - A solution to this bug has been found and an upload will be made soon. - - fixed - This bug is fixed or worked around (by a non-maintainer upload, for - example), but there's still an issue that needs to be resolved. This tag - replaces the old \"fixed\" severity. - - security - This bug describes a security problem in a package (e.g., bad - permissions allowing access to data that shouldn't be accessible, buffer - overruns allowing people to control a system in ways they shouldn't be - able to, denial of service attacks that should be fixed, etc). Most - security bugs should also be set at critical or grave severity. - - upstream - This bug applies to the upstream part of the package. - - confirmed - The maintainer has looked at, understands, and basically agrees with - the bug, but has yet to fix it. (Use of this tag is optional, it is - intended mostly for maintainers who need to manage large numbers of open - bugs.) fixed-upstream - - The bug has been fixed by the upstream maintainer, but not yet in the - package (for whatever reason: perhaps it is too complicated to backport - the change or too minor to be worth bothering). - - fixed-in-experimental - The bug has been fixed in the package of the experimental - distribution, but not yet in the unstable distribution. - - d-i - This bug is relevant to the development of debian-installer. It is - expected that this will be used when the bug affects installer development - but is not filed against a package that forms a direct part of the - installer itself. - - ipv6 - This bug affects support for Internet Protocol version 6. - - lfs - This bug affects support for large files (over 2 gigabytes). - - l10n - This bug is relevant to the localisation of the package. - - potato - This bug particularly applies to the potato release of Debian. - - woody - This bug particularly applies to the woody distribution. - - sarge - This bug should not be archived until it is fixed in sarge. - - sarge-ignore - This release-critical bug is to be ignored for the purposes of - releasing sarge. This tag should only be used by the release manager, do - not set it yourself without explicit authorization from them. - - etch - This bug should not be archived until it is fixed in etch. - - etch-ignore - This release-critical bug is to be ignored for the purposes of - releasing etch. This tag should only be used by the release manager, do - not set it yourself without explicit authorization from them. - - sid - This bug should not be archived until it is fixed in sid. - - experimental - This bug should not be archived until it is fixed in experimental. - -The meanings of the latter 6 tags have changed recently, the ignore tags -ignore the bug for the purpose of a testing propagation. The release tags, -which used to indicate which bugs affected a specific release now indicate -when a bug can be archived. -Info from http://www.debian.org/Bugs/Developer#tags -Sep 22, 2006"))) - -(defun debian-bug-help-pseudo-packages () - "Display pseudo-packages help." - (with-output-to-temp-buffer "*Help*" - (princ "List of Debian pseudo packages - base — Base system general bugs - bugs.debian.org — The bug tracking system, @bugs.debian.org - buildd.debian.org — Problems and requests related to the Debian Buildds - buildd.emdebian.org — Problems related to building packages for Emdebian - cdimage.debian.org — CD Image issues - cdrom — Installation system - debian-i18n — Requests regarding Internationalization (i18n) of the distribution - debian-maintainers — Problems and requests related to Debian Maintainers - ftp.debian.org — Problems with the FTP site - general — General problems (e.g. \"many manpages are mode 755\") - installation-reports — Reports of installation problems with stable & testing - lists.debian.org — The mailing lists, debian-*@lists.debian.org - mirrors — Problems with the official mirrors - nm.debian.org — New Maintainer process and nm.debian.org webpages - press — Press release issues - project — Problems related to project administration - qa.debian.org — The Quality Assurance group - release-notes — Problems with the Release Notes - release.debian.org — Requests regarding Debian releases and release team tools - security-tracker — The Debian Security Bug Tracker - security.debian.org — The Debian Security Team - snapshot.debian.org — Issues with the snapshot.debian.org service - tech-ctte — The Debian Technical Committee (see the Constitution) - upgrade-reports — Reports of upgrade problems for stable & testing - wiki.debian.org — Problems with the Debian wiki - wnpp — Work-Needing and Prospective Packages list - www.debian.org — Problems with the WWW site - -from http://www.debian.org/Bugs/pseudo-packages, May 13th 2010. -Copyright 1999 Darren O. Benham, 1997, 2003 nCipher Corporation Ltd, -1994-1997 Ian Jackson. -"))) - -(defun debian-bug-help-email () - "Display help about various bug report emails to use." - (with-output-to-temp-buffer "*Help*" - (princ "Info from http://www.debian.org/Bugs/Reporting -Aug 10th 2001 - - If a bug report is minor, for example, a documentation typo or a - trivial build problem, please adjust the severity appropriately and - send it to maintonly@bugs instead of submit@bugs. maintonly will - forward the report to the package maintainer only, it won't forward it - to the BTS mailing lists. - - If you wish to report a bug to the bug tracking system that's already been - sent to the maintainer, you can use quiet@bugs. Bugs sent to quiet@bugs - will not be forwarded anywhere, only filed. - - Bugs sent to maintonly@bugs or to quiet@bugs are *still* posted to - the Debian Bug Tracking System web site (--psg)."))) - - -(easy-menu-define debian-bug-menu debian-bug-minor-mode-map - "Debian Bug Mode Menu" - '("Debian-Bug" - ("Header" - ["Custom From Address" (debian-bug--toggle-custom-From) - :style toggle :active debian-bug-From-address - :selected (debian-bug--is-custom-From)] - "--" - ["To BTS, Maintainer and Mailing Lists" - (debian-bug--set-bts-address - (debian-bug-bts-mail "submit" debian-bug-bts-address)) - :style radio - :selected (debian-bug--is-bts-address - (debian-bug-bts-mail "submit" debian-bug-bts-address))] - ["To BTS and Maintainer Only" - (debian-bug--set-bts-address - (debian-bug-bts-mail "maintonly" debian-bug-bts-address)) - :style radio - :selected (debian-bug--is-bts-address - (debian-bug-bts-mail "maintonly" debian-bug-bts-address))] - ["To BTS Only" - (debian-bug--set-bts-address - (debian-bug-bts-mail "quiet" debian-bug-bts-address)) - :style radio - :selected (debian-bug--is-bts-address - (debian-bug-bts-mail "quiet" debian-bug-bts-address))] - "--" - ["CC debian-devel" (debian-bug--toggle-CC-devel) - :style toggle - :selected (debian-bug--is-CC - "debian-devel@lists.debian.org" "X-Debbugs-CC:")] - ["CC me" (debian-bug--toggle-CC-myself) - :style toggle :active debian-bug-From-address - :selected (debian-bug--is-CC debian-bug-From-address "X-Debbugs-CC:")] - ) - ("Severity" - ["critical" (debian-bug--set-severity "critical") - :style radio :selected (debian-bug--is-severity "critical")] - ["grave" (debian-bug--set-severity "grave") - :style radio :selected (debian-bug--is-severity "grave")] - ["serious" (debian-bug--set-severity "serious") - :style radio :selected (debian-bug--is-severity "serious")] - ["important" (debian-bug--set-severity "important") - :style radio :selected (debian-bug--is-severity "important")] - ["normal" (debian-bug--set-severity "normal") - :style radio :selected (debian-bug--is-severity "normal")] - ["minor" (debian-bug--set-severity "minor") - :style radio :selected (debian-bug--is-severity "minor")] - ["wishlist" (debian-bug--set-severity "wishlist") - :style radio :selected (debian-bug--is-severity "wishlist")] - ) - ("Tags" - ["Patch Included" (debian-bug--toggle-tags "patch") - :style toggle :selected (debian-bug--is-tags "patch")] - ["Security Issue!" (debian-bug--toggle-tags "security") - :style toggle :selected (debian-bug--is-tags "security")] - ) - ("Web View" - ["Bugs for This Package" (debian-bug-web-bugs) t] - ["Archived Bugs for This Package" (debian-bug-web-bugs t) t] - ["Bug Number..." (debian-bug-web-bug) t] - ["Package search for all releases" (debian-bug-web-packages) t] - "-- Package Web Pages --" - ["Stable" (debian-bug-web-package "stable") t] - ["Testing" (debian-bug-web-package "testing") t] - ["Unstable" (debian-bug-web-package "unstable") t] - ) - ["Customize" - (customize-group "debian-bug") (fboundp 'customize-group)] - ("Help" - ["Severities" (debian-bug-help-severity) t] - ["Tags" (debian-bug-help-tags) t] - ["Pseudo-Packages" (debian-bug-help-pseudo-packages) t] - ["Addresses" (debian-bug-help-email) t] - ) - )) - -(defun debian-bug-minor-mode (arg) - "Toggle `debian-bug' mode. -A positive prefix argument ARG turns on `debian-bug' mode\; a negative prefix -argument turn sit off." - (interactive "P") - (set (make-local-variable 'debian-bug-minor-mode) - (if arg - (> (prefix-numeric-value arg) 0) - (not debian-bug-minor-mode))) - (cond - (debian-bug-minor-mode ;Setup the minor-mode - (if (fboundp 'font-lock-add-keywords) - (font-lock-add-keywords nil debian-bug-font-lock-keywords t)) - (debian-bug-bug-menu-init debian-bug-minor-mode-map) - (easy-menu-add debian-bug-menu)))) - -;; Install ourselves: -(or (assq 'debian-bug-minor-mode minor-mode-alist) - (setq minor-mode-alist - (cons '(debian-bug-minor-mode " DBug") minor-mode-alist))) -(or (assq 'debian-bug-minor-mode minor-mode-map-alist) - (setq minor-mode-map-alist - (cons (cons 'debian-bug-minor-mode debian-bug-minor-mode-map) - minor-mode-map-alist))) - -;;; --------- -;;; wnpp-minor-mode - like debian-bug-minor-mode but with limited menu - -(defvar debian-bug-wnpp-minor-mode nil) -(defvar debian-bug-wnpp-minor-mode-map nil - "Keymap for `debian-bug' minor mode.") -(if debian-bug-wnpp-minor-mode-map - nil - (setq debian-bug-wnpp-minor-mode-map (make-sparse-keymap))) - -(easy-menu-define debian-bug-wnpp-menu debian-bug-wnpp-minor-mode-map - "Debian Bug Mode Menu" - '("Debian-Bug" - ["Custom From address" (debian-bug--toggle-custom-From) - :style radio :active debian-bug-From-address - :selected (debian-bug--is-custom-From)] - ["CC to debian-devel header line" (debian-bug--toggle-CC-devel) - :style radio - :selected (debian-bug--is-CC "debian-devel@lists.debian.org" - "X-Debbugs-CC:")] - ["CC to myself header line" (debian-bug--toggle-CC-myself) - :style radio :active debian-bug-From-address - :selected (debian-bug--is-CC debian-bug-From-address "X-Debbugs-CC:")] - ["Customize debian-bug" - (customize-group "debian-bug") (fboundp 'customize-group)] - )) - -(defun debian-bug-wnpp-minor-mode (arg) - "Toggle `debian-bug' mode. -A positive prefix argument ARG turns on `debian-bug' mode\; a negative prefix -argument turn sit off." - (interactive "P") - (set (make-local-variable 'debian-bug-wnpp-minor-mode) - (if arg - (> (prefix-numeric-value arg) 0) - (not debian-bug-wnpp-minor-mode))) - (cond - (debian-bug-wnpp-minor-mode ;Setup the minor-mode - (if (fboundp 'font-lock-add-keywords) - (font-lock-add-keywords nil debian-bug-font-lock-keywords t)) - (easy-menu-add debian-bug-wnpp-menu)))) - -;; Install ourselves: -(or (assq 'debian-bug-wnpp-minor-mode minor-mode-alist) - (setq minor-mode-alist - (cons '(debian-bug-wnpp-minor-mode " WNPPBug") minor-mode-alist))) -(or (assq 'debian-bug-wnpp-minor-mode minor-mode-map-alist) - (setq minor-mode-map-alist - (cons (cons 'debian-bug-wnpp-minor-mode debian-bug-wnpp-minor-mode-map) - minor-mode-map-alist))) - -;;; --------- -;;; browse-url interfaces from debian-changelog-mode.el -;; by Peter Galbraith, Feb 23 2001 - -;;;###autoload -(defun debian-bug-web-bugs (&optional archived) - "Browse the BTS for this package via `browse-url'. -With optional argument prefix ARCHIVED, display archived bugs." - (interactive "P") - (if (not (featurep 'browse-url)) - (progn - (load "browse-url" nil t) - (if (not (featurep 'browse-url)) - (error "This function requires the browse-url elisp package")))) - (let ((pkg-name (or debian-bug-package-name - (and (featurep 'debian-changelog-mode) - (debian-changelog-suggest-package-name)) - (read-string "Package name: ")))) - (if (string-equal "" pkg-name) - (message "No package name to look up") - (if archived - (browse-url - (concat "http://bugs.debian.org/cgi-bin/pkgreport.cgi?src=" - pkg-name "&archive=yes")) - (browse-url (concat "http://bugs.debian.org/cgi-bin/pkgreport.cgi?src=" - pkg-name))) - (message "Looking up bugs for source package %s via browse-url" - pkg-name)))) - -;;;FIXME - This might not be a source package name, and then the page -;;; doesn't exist. -;;;###autoload -(defun debian-bug-web-developer-page () - "Browse the web for this package's developer page." - (interactive) - (if (not (featurep 'browse-url)) - (progn - (load "browse-url" nil t) - (if (not (featurep 'browse-url)) - (error "This function requires the browse-url elisp package")))) - (let ((pkg-name (or debian-bug-package-name - (and (featurep 'debian-changelog-mode) - (debian-changelog-suggest-package-name)) - (read-string "Package name: ")))) - (if (string-equal "" pkg-name) - (message "No package name to look up") - (or (string-match "^lib[a-zA-Z]" pkg-name) - (string-match "^[a-zA-Z]" pkg-name)) - (browse-url (concat "http://packages.qa.debian.org/" - (match-string 0 pkg-name) "/" pkg-name ".html")) - (message "Looking up developer web page for package %s via browse-url" - pkg-name)))) - -(defun debian-bug-prompt-bug-number (prompt) - "Prompt the user for a bug number using PROMPT." - (require 'thingatpt) - (let ((default-number) - (item (word-at-point))) - ;; First see if there's a number under point - (if (and item - (string-match "^[0-9]+[0-9]$" item)) - (setq default-number (match-string-no-properties 0 item)) - ;; If not, try for mail message header - (save-excursion - (goto-char (point-min)) - (if (re-search-forward "\\([0-9]+\\)@bugs.debian.org" - (mail-header-end) t) - (setq default-number (match-string-no-properties 1))))) - (list (completing-read (if default-number - (format "%s [%s]: " prompt default-number) - (format "%s: " prompt)) - debian-bug-alist nil nil nil nil default-number)))) - -;;;###autoload -(defun debian-bug-web-bug (&optional bug-number) - "Browse the BTS for BUG-NUMBER via `browse-url'." - (interactive (debian-bug-prompt-bug-number "Bug number to lookup")) - (if (not (featurep 'browse-url)) - (progn - (load "browse-url" nil t) - (if (not (featurep 'browse-url)) - (error "This function requires the browse-url elisp package")))) - (if (or (not bug-number) (string-equal bug-number "none")) - (setq bug-number (completing-read "Bug number to lookup: " - debian-bug-alist nil nil))) - (if (string-equal bug-number "") - (message "No bug number to look up") - (browse-url (concat debian-bug-bts-URL "archive=yes&bug=" bug-number)) - (message "Looking up bug number %s via browse-url" bug-number))) - -;;;###autoload -(defun emacs-bug-web-bug (&optional bug-number) - "Browse the Emacs BTS for BUG-NUMBER via `browse-url'." - (interactive "NBug number: ") - (let ((debian-bug-bts-URL - "http://debbugs.gnu.org/cgi/bugreport.cgi?")) - (debian-bug-web-bug (number-to-string bug-number)))) - -;;;###autoload -(defun debian-bug-web-this-bug-under-mouse (EVENT) - "Browse the BTS via `browse-url' for the bug report number under mouse. -In a program, mouse location is in EVENT." - (interactive "e") - (mouse-set-point EVENT) - (if (not (looking-at "[0-9]")) - (error "Not a number under point/mouse")) - (save-excursion - (skip-chars-backward "0123456789") - (if (looking-at "[0-9]+") - (let ((bug-number (match-string 0))) - (debian-bug-web-bug bug-number))))) - -;;;###autoload -(defun debian-bug-web-packages () - "Search Debian web page for this package via `browse-url'." - (interactive) - (if (not (featurep 'browse-url)) - (progn - (load "browse-url" nil t) - (if (not (featurep 'browse-url)) - (error "This function requires the browse-url elisp package")))) - (let ((pkg-name (or debian-bug-package-name - (and (featurep 'debian-changelog-mode) - (debian-changelog-suggest-package-name)) - (read-string "Package name: ")))) - (if (string-equal "" pkg-name) - (message "No package name to look up") - (browse-url (concat "http://packages.debian.org/" pkg-name)) -;; 2007-09-02 This URL is becoming obsolete... -;; (concat -;; "http://packages.debian.org/cgi-bin/search_packages.pl?keywords=" -;; pkg-name -;; "&searchon=names&version=all&release=all") - (message "Looking up web pages for package %s via browse-url" pkg-name)))) - -(defvar debian-bug-archive-alist - '(("stable") ("testing") ("unstable")) - "Alist of valid Debian archives for web interface (excludes experimental).") - -(defvar debian-bug-archive-list - '("stable" "testing" "unstable") - "List of valid Debian archives.") - -;;;###autoload -(defun debian-bug-web-package (archive) - "Search Debian web page in ARCHIVE for this package via `browse-url'." - (interactive "P") - (if (not (featurep 'browse-url)) - (progn - (load "browse-url" nil t) - (if (not (featurep 'browse-url)) - (error "This function requires the browse-url elisp package")))) - (let ((pkg-name (or debian-bug-package-name - (and (featurep 'debian-changelog-mode) - (debian-changelog-suggest-package-name)) - (read-string "Package name: ")))) - (if (string-equal "" pkg-name) - (message "No package name to look up") - (if (not (member (list archive) debian-bug-archive-alist)) - (setq archive - (completing-read "Debian archive: " - debian-bug-archive-alist nil t nil))) - (if (string-equal "" archive) - (message "No archive name to look up") - (browse-url (format "http://packages.debian.org/%s/%s" - archive pkg-name)) - (message "Looking up %s web page for package %s via browse-url" - archive pkg-name))))) - -;;;------------- -;;; wget bug from BTS stuff - Peter Galbraith, August 2001 -;;; from debian-changelog-mode.el - -(defun debian-bug-menucount () - "Return the number of bug lines after wget process." - (save-excursion - (goto-char (point-min)) - (- (count-lines (point)(point-max)) 5))) - -(defun debian-bug-menusplit-p (submenu) - "Return t if we should split the menu, comparing bug numbers to frame size. -If SUBMENU is t, then check for current sexp submenu only." - (let* ((menu-count (if submenu - (save-excursion - (count-lines (point) - (progn (forward-sexp 1)(point)))) - (debian-bug-menucount))) - (frame-lines (cond ((< 60 (frame-height)) ;Big frames - (- (frame-height) 17)) - ((< 40 (frame-height)) ;Med frames - (- (frame-height) 10)) - (t - (- (frame-height) 6))))) ;Smaller frames - (if (>= frame-lines menu-count) - nil ; No split at all - t))) - -(defun debian-bug-submenusplit () - "Split this submenu, located in sexp." - (save-excursion - (save-restriction - ;; First, narrow to submenu - (narrow-to-region (point) - (progn (forward-sexp 1)(forward-char -2)(point))) - (goto-char (point-min)) - (forward-line 1) - ;; Now on first bug... - (let ((lines (cond ((< 60 (frame-height)) ;Big frames - (- (frame-height) 25)) - ((< 40 (frame-height)) ;Med frames - (- (frame-height) 20)) - (t - (- (frame-height) 6)))) ;Smaller frames - (start (point)) - (bugn-end)(bugn-beg)) - (while (< (point) (point-max)) - (forward-line lines) - (beginning-of-line) - (looking-at "^\\[\"\\(#?[0-9]+\\):") - (setq bugn-end (match-string 1)) - (end-of-line) - (insert ")") - (goto-char start) - (looking-at "^\\[\"\\(#?[0-9]+\\):") - (setq bugn-beg (match-string 1)) - (insert (format "(\"%s-%s\"\n" bugn-beg bugn-end)) - (forward-line -1) - (forward-sexp 1) - (forward-line 1) - (setq start (point)))))) - (forward-sexp 1) - (beginning-of-line)) - -(defun debian-bug-wget-mbox (&optional bug-number) - "Wget the mbox file for bug BUG-NUMBER and return the filename created." - (if (not debian-bug-download-directory) - (error "Please set ` debian-bug-download-directory'")) - (if (and (not (file-exists-p debian-bug-download-directory)) - (make-directory debian-bug-download-directory) - (not (file-exists-p debian-bug-download-directory))) - (error "Please create directory %s" debian-bug-download-directory)) - (if (not bug-number) - (setq bug-number (completing-read "Bug number to fetch: " - debian-bug-alist nil nil))) - (when bug-number - (let ((filename (expand-file-name - (concat "debian-bug-" - (if debian-bug-package-name - (concat debian-bug-package-name "-")) - bug-number) - debian-bug-download-directory)) - (status) - (url (concat debian-bug-bts-URL "bug=" bug-number - "&mbox=yes&mboxmaint=yes"))) - (if (and (file-exists-p filename) - (not (y-or-n-p "Bug file already exists. Download again? "))) - filename - (message "Downloading bug %s..." bug-number ) - (setq status - (call-process "wget" nil '(t t) nil "--quiet" "-O" filename url)) - (message "Downloading bug %s...done" bug-number) - (if (= 0 status) - filename - (error "`wget' failed")))))) - -;;;###autoload -(defun debian-bug-get-bug-as-file (&optional bug-number) - "Read bug report #BUG-NUMBER as a regular file." - (interactive (debian-bug-prompt-bug-number "Bug number to fetch")) - (let ((filename (debian-bug-wget-mbox bug-number))) - (find-file filename) - (text-mode))) - -;;;###autoload -(defun debian-bug-get-bug-as-email (&optional bug-number) - "Read bug report #BUG-NUMBER via Email interface." - (interactive (progn - ;; a second gnus in a second emacs can clobber .newsrc, ask - ;; the user to start gnus where they want it - (if (and (eq mail-user-agent 'gnus-user-agent) - (not (and (fboundp 'gnus-alive-p) - (gnus-alive-p)))) - (error "Please start `gnus' (or `gnus-slave') first")) - (debian-bug-prompt-bug-number "Bug number to fetch"))) - (run-hooks 'debian-bug-get-bug-as-email-hook) - (cond - ((and (eq mail-user-agent 'mh-e-user-agent) - (featurep 'mh-inc)) - ;; MH-E - (mh-find-path) - (let* ((package-name (cond - (debian-bug-package-name - debian-bug-package-name) - ((featurep 'debian-changelog-mode) - (debian-changelog-suggest-package-name)) - (t - (read-string "Package name: ")))) - (mh-e-folder (concat - (if debian-bug-mh-folder - (concat debian-bug-mh-folder "/") - "+debian-bug-") - (if package-name - (format "%s-" package-name)) - bug-number))) - (if (and (file-exists-p (mh-expand-file-name mh-e-folder)) - (not (y-or-n-p "Bug folder already exists. Download again? "))) - (mh-visit-folder mh-e-folder) - (if (file-exists-p (mh-expand-file-name mh-e-folder)) - (mh-exec-cmd-quiet nil "rmf" mh-e-folder)) - (let ((filename (debian-bug-wget-mbox bug-number))) - (mh-inc-folder filename mh-e-folder) - (delete-file filename))))) - ((eq mail-user-agent 'gnus-user-agent) - (gnus-group-read-ephemeral-group - bug-number `(nndoc "bug" - (nndoc-address ,(debian-bug-wget-mbox bug-number)) - (nndoc-article-type mbox)) - nil - ;; restore current window configuration after quitting the summary - (cons (current-buffer) (current-window-configuration)))) - (t - ;; rmail - (let ((filename (debian-bug-wget-mbox bug-number))) - (rmail filename))))) - -;;;###autoload -(defun emacs-bug-get-bug-as-email (&optional bug-number) - "Read Emacs bug report #BUG-NUMBER via Email interface." - (interactive "NBug number: ") - (let ((debian-bug-package-name "Emacs") - (debian-bug-bts-URL "http://debbugs.gnu.org/cgi/bugreport.cgi?")) - (debian-bug-get-bug-as-email (number-to-string bug-number)))) - -(defvar debian-changelog-menu) - -(defun debian-bug-menu-action (bugnumber) - "Do something with BUGNUMBER based on variable `debian-bug-menu-action'." - (cond - ((equal debian-bug-menu-action 'browse) - (debian-bug-web-bug bugnumber)) - ((equal debian-bug-menu-action 'readfile) - (debian-bug-get-bug-as-file bugnumber)) - ((equal debian-bug-menu-action 'email) - (debian-bug-get-bug-as-email bugnumber)) - ((equal debian-bug-menu-action 'close) - (debian-changelog-close-bug bugnumber)))) - -(defvar debian-changelog-mode-map) - -(load "rfc2047" t t) -(defun debian-bug-rfc2047-decode-string (string) - "Decode the quoted-printable-encoded STRING and return the results. -Only decodes if `rfc2047-decode-string' is available." - (if (fboundp 'rfc2047-decode-string) - (rfc2047-decode-string string) - string)) - -(defvar debian-changelog-close-bug-statement) -(defun debian-bug-build-bug-menu (package &optional source) - "Build a menu listing the bugs for PACKAGE. -Optionally, if SOURCE is t, make it a source package." - (setq debian-bug-alist nil - debian-bug-open-alist nil) - (let ((debian-bug-tmp-buffer - (get-buffer-create "*debian-bug-tmp-buffer*")) - (bug-alist) - (bug-open-alist) - (bugs-are-open-flag t) - (is-changelog-mode - (and (equal major-mode 'debian-changelog-mode) - (boundp 'debian-changelog-close-bug-takes-arg)))) - (save-excursion - (set-buffer debian-bug-tmp-buffer) - (insert "(setq debian-bug-easymenu-list\n'(\"Bugs\"\n") - (insert "[\"* Regenerate list *\" (debian-bug-build-bug-this-menu) t] - \"--\" - [\"Browse\" - (list (setq debian-bug-menu-action 'browse)) - :style radio :selected (equal debian-bug-menu-action 'browse)] - [\"Read as a File\" - (list (setq debian-bug-menu-action 'readfile)) - :style radio :selected (equal debian-bug-menu-action 'readfile)] - [\"Read as Email\" - (list (setq debian-bug-menu-action 'email)) - :style radio :selected (equal debian-bug-menu-action 'email)]\n") - (if is-changelog-mode - (insert " [\"Close Bug\" - (list (setq debian-bug-menu-action 'close)) - :style radio :selected (equal debian-bug-menu-action 'close)]\n")) - (insert " \"-\"\n") - (with-temp-buffer - (message "Fetching bug list...") - (call-process "wget" nil '(t t) nil "--quiet" "-O" "-" - (concat - "http://bugs.debian.org/cgi-bin/pkgreport.cgi?" - (if source "src=" "pkg=") - package)) - (message "Fetching bug list...done") - (goto-char (point-min)) - (while - (re-search-forward -;;; "\\(<H2.*</a>\\(.+\\)</H2>\\)\\|\\(<a href=\"\\(bugreport.cgi\\?bug=\\([0-9]+\\)\\)\">\\(.+: \\(.+\\)\\)</a>\\)" - "\\(<H2.*</a>\\(.+\\)</H2>\\)\\|\\(<a href=\"\\(bugreport.cgi\\?bug=\\([0-9]+\\)\\)\">\\([^#].+\\)</a>\\)" - nil t) - (let ((type (match-string 2)) - ;;(URL (match-string 4)) - (bugnumber (match-string 5)) - (description (match-string 6)) - (shortdescription (match-string 6))) - (cond - ((string= type "-->")) ;Do nothing - (type - (setq bugs-are-open-flag (not (string-match "resolved" type))) - (save-excursion - (set-buffer debian-bug-tmp-buffer) - (insert "\"-\"\n\"" type "\"\n"))) - ((null description)) ;Do nothing - ((string-match "^#?[0-9]+$" description)) ;Do nothing - (t - (if (string-match "^[^ ]+: \\(.+\\)" description) - (setq shortdescription (match-string 1 description))) - (setq bug-alist (cons (list bugnumber description) bug-alist)) - (when bugs-are-open-flag - (when (and (re-search-forward - "Reported by: <a href=\"pkgreport.cgi\\?submitter=[^\"]+\">" - nil t) - (or (looking-at ""\\(.*\\)" <") - (looking-at "\\(.*\\) <") - (looking-at "\\(.*\\)<"))) - (setq shortdescription - (concat "Bug fix: \"" shortdescription - "\", thanks to " - (debian-bug-rfc2047-decode-string - (match-string 1)) - " " (if (fboundp 'replace-regexp-in-string) - (replace-regexp-in-string - "%s" bugnumber - (if (boundp 'debian-changelog-close-bug-statement) - debian-changelog-close-bug-statement - "(Closes: #%s)")) - (debian-bug--rris - "%s" bugnumber - (if (boundp 'debian-changelog-close-bug-statement) - debian-changelog-close-bug-statement - "(Closes: #%s)")))))) - (setq bug-open-alist - (cons - (list bugnumber shortdescription) bug-open-alist))) - (save-excursion - (set-buffer debian-bug-tmp-buffer) - (insert - "[" - (format "%S" (concat "#" bugnumber " " - (if (< 60 (length description)) - (substring description 0 60) - description))) - " (debian-bug-menu-action \"" bugnumber "\")" - " :active " - (if bugs-are-open-flag - "t" - "(not (eq debian-bug-menu-action 'close))") - "]\n"))))))) - (set-buffer debian-bug-tmp-buffer) ;Make sure we're here - (insert "))") - (when (debian-bug-menusplit-p nil) - (goto-char (point-min)) - ;; First split on bug severities - (when (and (re-search-forward "^\"-" nil t) - (re-search-forward "^\"" nil t)) - (when (search-forward " to upstream software authors" - (save-excursion (progn (end-of-line)(point))) - t) - (replace-match " upstream")) - (beginning-of-line) - (insert "(") - (while (and (re-search-forward "^\"-" nil t) - (re-search-forward "^\"" nil t)) - (when (search-forward " to upstream software authors" - (save-excursion (progn (end-of-line)(point))) - t) - (replace-match " upstream")) - (beginning-of-line) - (insert ")(")) - (goto-char (point-max)) - (insert ")") - ;; Next check for long menus, and split those again - (goto-char (point-min)) - (while (re-search-forward "^)?(\"" nil t) - (forward-char -2) - (if (debian-bug-menusplit-p t) - (debian-bug-submenusplit) - (end-of-line))) - )) - (eval-buffer debian-bug-tmp-buffer) - (kill-buffer nil) - ) - (setq debian-bug-alist bug-alist) - (setq debian-bug-open-alist bug-open-alist) - (cond - ((equal major-mode 'debian-changelog-mode) - (easy-menu-define - debian-bug-bugs-menu - debian-changelog-mode-map "Debian Bug Mode Bugs Menu" - debian-bug-easymenu-list) - (cond - ((string-match "XEmacs" emacs-version) - (easy-menu-remove debian-bug-bugs-menu) - (easy-menu-remove debian-changelog-menu) - (easy-menu-add debian-bug-bugs-menu) - (easy-menu-add debian-changelog-menu)))) - (t - (easy-menu-define - debian-bug-bugs-menu - debian-bug-minor-mode-map "Debian Bug Mode Bugs Menu" - debian-bug-easymenu-list) - (cond - ((string-match "XEmacs" emacs-version) - (easy-menu-remove debian-bug-bugs-menu) - (easy-menu-remove debian-bug-menu) - (easy-menu-add debian-bug-bugs-menu) - (easy-menu-add debian-bug-menu))))))) - -(defun debian-bug-build-bug-this-menu () - "Regenerate Bugs list menu for this buffer's package." - (if (and (featurep 'debian-changelog-mode) - (debian-changelog-suggest-package-name)) - (debian-bug-build-bug-menu (debian-changelog-suggest-package-name) t) - (let ((package (or (and (boundp 'debian-bug-package-name) - debian-bug-package-name) - (read-string "Package name: ")))) - (debian-bug-build-bug-menu package nil)))) - -(defun debian-bug-bug-menu-init (minor-mode-map) - "Initialize empty bug menu. -Call this function from the mode setup with MINOR-MODE-MAP." - (if debian-bug-menu-preload-flag - (debian-bug-build-bug-this-menu) - (easy-menu-define debian-bug-bugs-menu minor-mode-map - "Debian Bug Mode Bugs Menu" - '("Bugs" - ["* Generate menu *" (debian-bug-build-bug-this-menu) - (debian-bug-check-for-program "wget")]))) - (easy-menu-add debian-bug-bugs-menu)) - -;;;------------- -;;; debian-bug-filename - Peter Galbraith, July 2002. -;;; - -(defun debian-bug-search-file (filename) - "Search for FILENAME returning which package name it belongs to." - (save-excursion - (let ((tmp-buffer (get-buffer-create " *debian-bug-tmp*")) - (expanded-file (expand-file-name filename)) - (package)) - (set-buffer tmp-buffer) - (unwind-protect - (progn - (condition-case err - (call-process "dlocate" nil '(t nil) nil "-S" expanded-file) - (file-error - (message "dlocate not installed..."))) - (goto-char (point-min)) - (when (re-search-forward - (concat "^\\(.*\\): " (regexp-quote expanded-file) "$") - nil t) - ;; found one at least. Try for another. - (setq package (match-string 1)) - (when (re-search-forward - (concat "^.*: " (regexp-quote expanded-file) "$") nil t) - (setq package nil))) - (if package - package - (message "Calling dpkg for the search...") - (erase-buffer) - (call-process "dpkg" nil '(t nil) nil "-S" - (expand-file-name filename)) - (message "Calling dpkg for the search...done") - (goto-char (point-min)) - (cond - ((re-search-forward "not found.$" nil t) - (message "%s not found in package list" filename) - nil) - ((re-search-forward "^\\(.*, .*\\): " nil t) - (with-output-to-temp-buffer "*Help*" - (princ (format "Please refine your search,\nthere is more than one matched package:\n\n%s" (match-string 1)))) - nil) - ((re-search-forward "^\\(.*\\): " nil t) - (match-string 1)) - (t - (message "%s not found in package list" filename) - nil)))) - (kill-buffer tmp-buffer))))) - -(defun debian-bug-filename () - "Submit a Debian bug report for a given filename's package." - (let ((filename (read-file-name "Filename: " "/" nil t nil))) - (cond - ((string-equal "" filename) - (message "Giving up")) - (t - (let ((package (debian-bug-search-file filename))) - (if package - (let ((answer (y-or-n-p (format "File is in package %s; continue? " - package)))) - (when answer - (debian-bug-package package filename))))))))) - -;;;###autoload -(defun debian-bug () - "Submit a Debian bug report." - (interactive) - (let ((type (let ((cursor-in-echo-area t)) - (message - "Report a bug for a [P]ackage or [F]ile: (default P) ") - (capitalize (read-char-exclusive))))) - (cond - ((or (equal 13 type) ; <CR> - (equal ?\r type) ; <CR> - (equal ?\ type) ; <space> - (equal 32 type) ; <space> - (equal ?p type) - (equal ?P type)) - (debian-bug-package)) - ((equal ?F type) - (debian-bug-filename)) - (t - (message "Sorry, try that again"))))) - -(provide 'debian-bug) - -;;; debian-bug.el ends here diff --git a/elisp/debian-el/debian-el-loaddefs.el b/elisp/debian-el/debian-el-loaddefs.el deleted file mode 100755 index 3df68ee..0000000 --- a/elisp/debian-el/debian-el-loaddefs.el +++ /dev/null @@ -1,175 +0,0 @@ -;;; debian-el-loaddefs.el --- automatically extracted autoloads -;; -;;; Code: - -(provide 'debian-el-loaddefs) - -;;;### (autoloads (apt-sources-mode) "apt-sources" "apt-sources.el" -;;;;;; (19215 18611)) -;;; Generated autoloads from apt-sources.el - -(autoload 'apt-sources-mode "apt-sources" "\ -Major mode for editing apt's sources.list file. -Sets up command `font-lock-mode'. - -\\{apt-sources-mode-map} - -\(fn)" t nil) - -;;;*** - -;;;### (autoloads (apt-utils-search apt-utils-show-package) "apt-utils" -;;;;;; "apt-utils.el" (18850 53763)) -;;; Generated autoloads from apt-utils.el - -(autoload 'apt-utils-show-package "apt-utils" "\ -Show information for a Debian package. -A selection of known packages is presented. See `apt-utils-mode' -for more detailed help. If NEW-SESSION is non-nil, generate a -new `apt-utils-mode' buffer. - -\(fn &optional NEW-SESSION)" t nil) - -(autoload 'apt-utils-search "apt-utils" "\ -Search Debian packages for regular expression. -To search for multiple patterns use a string like \"foo && bar\". -The regular expression used to split the -terms (`apt-utils-search-split-regexp') is customisable. - -\(fn)" t nil) - -;;;*** - -;;;### (autoloads (deb-find deb-view-mode deb-view deb-view-dired-view) -;;;;;; "deb-view" "deb-view.el" (19183 30392)) -;;; Generated autoloads from deb-view.el - -(autoload 'deb-view-dired-view "deb-view" "\ -View Debian package control and data files. -Press \"q\" in either window to kill both buffers -and return to the dired buffer. See deb-view. - -\(fn)" t nil) - -(autoload 'deb-view "deb-view" "\ -View Debian package DEBFILE's control and data files. -Press \"q\" in either window to kill both buffers. - -In dired, press ^d on the dired line of the .deb file to view. -Or, execute: ESCAPE x deb-view RETURN, and enter the .deb file name -at the prompt. - -\(fn DEBFILE)" t nil) - -(autoload 'deb-view-mode "deb-view" "\ -View mode for Debian Archive Files. - -\(fn)" t nil) - -(autoload 'deb-find "deb-view" "\ -Search for deb files. -Use the method specified by the variable deb-find-method, and collect -output in a buffer. See also the variable deb-find-directory. - -This command uses a special history list, so you can -easily repeat a `deb-find' command. - -\(fn)" t nil) - -;;;*** - -;;;### (autoloads (debian-bug emacs-bug-get-bug-as-email debian-bug-get-bug-as-email -;;;;;; debian-bug-get-bug-as-file debian-bug-web-package debian-bug-web-packages -;;;;;; debian-bug-web-this-bug-under-mouse emacs-bug-web-bug debian-bug-web-bug -;;;;;; debian-bug-web-developer-page debian-bug-web-bugs debian-bug-intent-to-package -;;;;;; debian-bug-request-for-package debian-bug-wnpp) "debian-bug" -;;;;;; "debian-bug.el" (19428 39961)) -;;; Generated autoloads from debian-bug.el - -(autoload 'debian-bug-wnpp "debian-bug" "\ -Submit a WNPP bug report to Debian. -Optional argument ACTION can be provided in programs. - -\(fn &optional ACTION)" t nil) - -(autoload 'debian-bug-request-for-package "debian-bug" "\ -Shortcut for `debian-bug-wnpp' with RFP action. - -\(fn)" t nil) - -(autoload 'debian-bug-intent-to-package "debian-bug" "\ -Shortcut for `debian-bug-wnpp' with ITP action (for Debian developers). - -\(fn)" t nil) - -(autoload 'debian-bug-web-bugs "debian-bug" "\ -Browse the BTS for this package via `browse-url'. -With optional argument prefix ARCHIVED, display archived bugs. - -\(fn &optional ARCHIVED)" t nil) - -(autoload 'debian-bug-web-developer-page "debian-bug" "\ -Browse the web for this package's developer page. - -\(fn)" t nil) - -(autoload 'debian-bug-web-bug "debian-bug" "\ -Browse the BTS for BUG-NUMBER via `browse-url'. - -\(fn &optional BUG-NUMBER)" t nil) - -(autoload 'emacs-bug-web-bug "debian-bug" "\ -Browse the Emacs BTS for BUG-NUMBER via `browse-url'. - -\(fn &optional BUG-NUMBER)" t nil) - -(autoload 'debian-bug-web-this-bug-under-mouse "debian-bug" "\ -Browse the BTS via `browse-url' for the bug report number under mouse. -In a program, mouse location is in EVENT. - -\(fn EVENT)" t nil) - -(autoload 'debian-bug-web-packages "debian-bug" "\ -Search Debian web page for this package via `browse-url'. - -\(fn)" t nil) - -(autoload 'debian-bug-web-package "debian-bug" "\ -Search Debian web page in ARCHIVE for this package via `browse-url'. - -\(fn ARCHIVE)" t nil) - -(autoload 'debian-bug-get-bug-as-file "debian-bug" "\ -Read bug report #BUG-NUMBER as a regular file. - -\(fn &optional BUG-NUMBER)" t nil) - -(autoload 'debian-bug-get-bug-as-email "debian-bug" "\ -Read bug report #BUG-NUMBER via Email interface. - -\(fn &optional BUG-NUMBER)" t nil) - -(autoload 'emacs-bug-get-bug-as-email "debian-bug" "\ -Read Emacs bug report #BUG-NUMBER via Email interface. - -\(fn &optional BUG-NUMBER)" t nil) - -(autoload 'debian-bug "debian-bug" "\ -Submit a Debian bug report. - -\(fn)" t nil) - -;;;*** - -;;;### (autoloads nil nil ("debian-el.el" "gnus-BTS.el") (19428 40248 -;;;;;; 570272)) - -;;;*** - -;;;### (autoloads (preseed-mode) "preseed" "preseed.el" (17245 35005)) -;;; Generated autoloads from preseed.el - -(autoload (quote preseed-mode) "preseed" "\ -Major mode for editing debian-installer preseed files colourfully." t nil) - -;;;*** diff --git a/elisp/debian-el/debian-el-loaddefs.make b/elisp/debian-el/debian-el-loaddefs.make deleted file mode 100755 index 0957567..0000000 --- a/elisp/debian-el/debian-el-loaddefs.make +++ /dev/null @@ -1 +0,0 @@ - emacs -batch --no-site-file --multibyte --eval '(setq load-path (cons "." load-path))' -l autoload --eval '(setq generated-autoload-file (expand-file-name "debian-el-loaddefs.el"))' --eval '(setq make-backup-files nil)' -f batch-update-autoloads . diff --git a/elisp/debian-el/debian-el.el b/elisp/debian-el/debian-el.el deleted file mode 100755 index 26424ca..0000000 --- a/elisp/debian-el/debian-el.el +++ /dev/null @@ -1,104 +0,0 @@ -;;; debian-el.el --- startup file for the debian-el package - -;;; Commentary: -;; -;; This file is loaded from /etc/emacs/site-start.d/50debian-el.el - -;;; History: -;; -;; 2008-04-12 - Géraud Meyer -;; - Use apt-sources-mode for files in /etc/apt/sources.list.d/ too. -;; - Use \' instead of $ for the end of filenames. -;; 2003-09-01 - Peter Galbraith -;; - Created. - -;;; Code: - -(defgroup debian-el nil - "Debian debian-el package customization." - :group 'convenience) - -(require 'debian-el-loaddefs) -;;(require 'debian-el-custom) - -;; apt-sources -(add-to-list 'auto-mode-alist '("sources\\.list\\'" . apt-sources-mode)) -(add-to-list 'auto-mode-alist '("sources\\.list\\.d/.*\\.list\\'" . apt-sources-mode)) -(defgroup apt-sources nil "Mode for editing apt sources.list files" - :group 'tools - :prefix "apt-sources-" - :link '(custom-manual "(debian-el)apt-sources") - :load 'apt-sources -;;:require 'apt-sources - :group 'debian-el) - -;; apt-utils -(defgroup apt-utils nil - "Emacs interface to APT (Debian package management)" - :group 'tools - :link '(url-link "http://www.tc.bham.ac.uk/~matt/AptUtilsEl.html") - :link '(custom-manual "(debian-el)apt-utils") - :load 'apt-utils -;;:require 'apt-utils - :group 'debian-el) - -;; debian-bug.el -(defgroup debian-bug nil "Debian Bug report helper" - :group 'tools - :prefix "debian-bug-" - :link '(custom-manual "(debian-el)debian-bug") - :load 'debian-bug -;;:require 'debian-bug - :group 'debian-el) - -;; deb-view.el -(setq auto-mode-alist - (append '(("\\.u?deb\\'" . deb-view-mode)) auto-mode-alist)) -(defgroup deb-view nil - "View Debian package files with tar-mode" - :group 'tools - :prefix "deb-view" - :link '(custom-manual "(debian-el)deb-view") - :load 'deb-view - :group 'debian-el) -(add-hook - 'dired-load-hook - (function (lambda () - (define-key dired-mode-map "\C-d" 'deb-view-dired-view)))) - -(when (member 'utf-8 (coding-system-list)) - ;; The following from Kevin Ryde <user42@zip.com.au> - ;; Closes: #484027 - (defun deb-view-control-coding (arg-list) - "Return coding system for the \"control\" file in a deb. -This function is for use from `file-coding-system-alist'. - -ARG-LIST is arguments passed to `find-operation-coding-system'. -The only operation handled here is `insert-file-contents' with a -buffer filename \".deb-INFO!./control\", for which the return is -'utf-8, and for anything else the return is nil (letting -`find-operation-coding-system' try other things). - -This is done as a function because the filename passed to -find-operation-coding-system by tar-mode is merely the archive -member \"./control\". By looking at the buffer-file-name we can -tell if it's from a deb. - -Note: This only works in emacs22, in emacs21 or xemacs21 tar-mode -does something a bit different and doesn't reach here (and -there's no buffer passed to coding system functions)." - (if (and (eq (car arg-list) 'insert-file-contents) ;; first arg - (consp (cadr arg-list)) ;; second arg like ("./control" . BUFFER) - (let ((buffer (cdr (cadr arg-list)))) - (and (buffer-file-name buffer) - (string-match "\\.deb-INFO!\\./control\\'" - (buffer-file-name buffer)) - 'utf-8))) - 'undecided)) - - (add-to-list 'file-coding-system-alist - '("\\'control\\'" . deb-view-control-coding))) - -(provide 'debian-el) - -;;; debian-el.el ends here diff --git a/elisp/debian-el/debian-el.texi b/elisp/debian-el/debian-el.texi deleted file mode 100755 index 37b53c6..0000000 --- a/elisp/debian-el/debian-el.texi +++ /dev/null @@ -1,331 +0,0 @@ -@c -*- mode: texinfo -*- -\input texinfo - -@c $Id: debian-el.texi,v 1.7 2008-04-12 13:10:57 psg Exp $ -@c %**start of header -@setfilename info/debian-el -@settitle debian-el -@c %**end of header - -@dircategory Emacs -@direntry -* Debian-el: (debian-el). Debian-specific tools for Emacs -@end direntry - -@c Version variables. -@set EDITION 1.1 -@set UPDATED 24 October 2005 - -@ifinfo -This is Edition @value{EDITION}, last updated @value{UPDATED}, of -@cite{debian-el}. -@end ifinfo - -@titlepage -@title debian-el: Debian-specific tools for Emacs -@subtitle A manual for what's in this package. -@author Peter S. Galbraith -@end titlepage - -@node Top, apt-sources, (dir), (dir) -@top The debian-el Package Setup - -This manual describes the debian-el package and its -setup. A quick descriptions of elisp files contained in this package -can be found in the file -@file{/usr/share/doc/debian-el/README.Debian}. - -All packaged files are installed, setup and ready to use (they don't -override standard Emacs commands, modes, or settings). - -To customize setup of all customizable packages on a finer-grain -basis, do: -@example -@kbd{M-x} customize-group @key{RET} debian-el @key{RET} -@end example - -@menu -* apt-sources:: Mode for editing apt sources.list files -* apt-utils:: Emacs interface to APT -* debian-bug:: Report a bug to Debian's bug tracking system -* deb-view:: View Debian package archive files with tar-mode -* gnus-BTS:: Access the Debian Bug Tracking System from Gnus -* pressed:: Mode for debian-installer preseed files -@detailmenu - --- The Detailed Node Listing --- - -deb-view - View Debian package archive files with tar-mode - -* deb-view configuration:: -* deb-view usage:: - -@end detailmenu -@end menu - -This work compiles GPL'ed documentation from the files in -/usr/share/emacs/site-lisp/debian-el/. As a derived work from GPL'ed -works, this text is also licensed under the GPL V2 (See -/usr/share/common-licenses/GPL-2) and is edited by Peter S. Galbraith -@email{psg@@debian.org}. - -@node apt-sources, apt-utils, Top, Top -@chapter apt-sources - Mode for editing apt sources.list files. - -This mode is for editing @file{/etc/apt/sources.list} and -@file{/etc/apt/sources.list.d/*.list}, the APT (Advanced Package Tool) -configuration files found on Debian systems. - -APT is a package retrieval tool for Debian; for example you could -install Emacs with the command: - -@example - apt-get install emacs21 -@end example - -and APT will then retrieve the package and install it for you. The -sources.list file tells APT where to look for packages. Mine looks -like this: - -@example - deb http://http.us.debian.org/debian unstable main contrib - deb http://non-us.debian.org/debian-non-US unstable/non-US main - - deb ftp://ftp.de.debian.org/debian ../project/experimental main -@end example - -This mode font-locks the file and add some things including new -source lines and modifying existing source lines. - -This mode can be customized in diferent parts. You can (interactively) -change if you want blank lines around a new source line and comment -with @code{apt-sources-around-lines}. Also you can change the way that -this mode names each source line with the variable -@code{apt-sources-source-name}; if no name is entered, no comment name -will be inserted. - -You can modify existing parts of the source line; check the mode -documentation for more details. Another thing that this mode can do is -to replicate an existing line (@kbd{C-c C-r}) that will be changed to -the 'deb' or 'deb-src' corresponding line. If it replicates a 'deb' -line, an identical 'deb-src' source line will be created. - -@node apt-utils, debian-bug, apt-sources, Top -@chapter apt-utils - Emacs interface to APT - -Start things off using e.g.: -@example -@kbd{M-x} apt-utils-show-package @key{RET} emacs21 @key{RET} -@end example - -Other packages (dependencies, conflicts etc) can be navigated using -@command{apt-utils-next-package} (@key{TAB}), -@command{apt-utils-prev-package} (@key{M-TAB}), -@command{apt-utils-choose-package-link} (@key{>}) or -@command{apt-utils-follow-link} (@key{RET}). Return to the previous -package with @command{apt-utils-view-previous-package} (@key{<}). - -ChangeLog and README files for the current package can easily be -accessed with, for example, @command{apt-utils-view-changelog} (@key{C}). - -For normal (i.e., not virtual) packages, the information can be toggled -between `package' and `showpkg' displays using -@command{apt-utils-toggle-package-info} (@key{t}); the latter is useful -for the "Reverse Depends". - -View the key bindings with describe-mode (bound to ? by default) -or use the menu. - -You may alter various settings of @code{apt-utils} bu customizing the -group @code{apt-utils}. - -@node debian-bug, deb-view, apt-utils, Top -@chapter debian-bug - report a bug to Debian's bug tracking system - -@noindent Useful commands provided by this package: - -@table @samp -@item debian-bug -Submit a Debian bug report against a package or file. - -@item debian-bug-wnpp -Submit a WNPP bug report to Debian. - -@item debian-bug-request-for-package -Shortcut for @code{debian-bug-wnpp} with RFP action. - -@item debian-bug-intent-to-package -Shortcut for @code{debian-bug-wnpp} with ITP action (for Debian developers). - -@item debian-bug-web-bugs -Browse the BTS for this package via @code{browse-url}." - -@item debian-bug-web-bug -Browse the BTS for BUG-NUMBER via @code{browse-url} - -@item debian-bug-web-this-bug -Browse the BTS via @code{browse-url} for the bug report number under point. - -@item debian-bug-web-this-bug-under-mouse -Browse the BTS via @code{browse-url} for the bug report number under mouse. -(Normally bound to mouse-2 in some modes) - -@item debian-bug-web-packages -Search Debian web page for this package via @code{browse-url}. - -@item debian-bug-web-package -Search Debian web page in ARCHIVE for this package via @code{browse-url}. - -@item debian-bug-get-bug-as-file -Read bug report #BUG-NUMBER as a regular file. - -@item debian-bug-get-bug-as-email -Read bug report #BUG-NUMBER via Email interface. - -@end table - -@noindent The command @command{M-x debian-bug} prompts for required -information to start filling in the mail draft buffer. It then allows -you to edit these fields in the mail draft buffer with a useful -menu-bar and view help text about your various options. If the Debian -package @code{wget} is installed, you may download the list of bugs -for the affected package at that time, and download the text of a -specific bug number as well. - -@noindent The debian-bug facility depends on the reportbug package. - -@node deb-view, gnus-BTS, debian-bug, Top -@chapter deb-view - View Debian package archive files with tar-mode - -@noindent Author: Rick Macdonald (rickm@@vsl.com) - -deb-view presents the contents of debian package archive files for -viewing. The viewing is done with the major mode "debview", which -is derived from emacs tar-mode with a few enhancements for viewing -compressed files, HTML files and formatted man pages. The normal -editing and saving features of tar-mode are not supported by -deb-view. - -deb-view includes a command called @command{deb-find} which requires that you -have the debian distribution directories on a local or mounted -filesystem. Give it a string or regular expression and it presents a -buffer of matching deb file names. Click with the middle mouse button -or press @key{RETURN} (or @key{C-c C-c}) and it launches deb-view on the selected -file. deb-find can be configured to use locate or find, or any other -external command. The find method passes your search specification to -egrep, whereas the locate method uses your string directly. - -deb-view extracts the control.tar.gz and data.tar.gz files from -debian package and presents two buffers in a derivitive of -tar-mode. See tar-mode for info. - -@noindent Optionally required programs: -@table @samp -@item nroff -for formatting man pages. -@item dpkg-deb -for old-style binary .deb files. -@item w3-mode -for viewing HTML pages. -@end table - -For new-style .deb files (2.0), dpkg-deb isn't used. - -@menu -* deb-view configuration:: -* deb-view usage:: -@end menu - -@node deb-view configuration, deb-view usage, deb-view, deb-view -@section Configuration - -deb-view is mostly unobtrusive, but does bind @key{C-d} in dired to -@command{deb-view-dired-view}. The "debview" mode is derived from -tar-mode.el using derived.el. Compared to tar-mode, debview-mode -binds @key{q}, @key{N}, @key{W}, and re-binds @key{v}. Also, the normal editing and saving -features of tar-mode are not supported by debview mode and those -keys are disabled. - -@command{deb-find} has two variables to set. @code{deb-find-method} can be "locate" or -"find". Any other value will be assumed to be an external script or -program that you supply. If you set @code{deb-find-method} to "find" then you -must also set @code{deb-find-directory} to the directory containing the -debian distribution. The find command starts at this point. I originally -used the locate option, but contrary to the man page it doesn't seem to -understand even simple regular expressions. I prefer the find option. It -uses egrep and therefore understands complex regular expressions. -You might want to bind @command{deb-find} to a special key. I use @key{C-d} like this: - -@verbatim - (define-key ctl-x-map "\C-d" 'deb-find) -@end verbatim - -Note that this key is normally the brief @command{list-directory} command, a -command that I never used anyway. - - -@node deb-view usage, , deb-view configuration, deb-view -@section Usage - -In dired, press @key{f} or @key{e} on the dired line of the .deb file to view. -You can also use @key{C-d}, which is actually slightly faster since the -deb file isn't loaded into a buffer needlessly. - -Or, execute: @command{M-x deb-view RETURN}, and enter the .deb file name -at the prompt. - -Or, execute: @command{M-x deb-find RETURN}, and enter any substring of a -deb file name to search for. A buffer of matches is created. -Launch @command{deb-view} by selecting a deb file with the middle mouse button, -or @key{RETURN} or @key{C-c}. Exit this buffer with @key{q}. - -You are shown two tar files in debview-mode (see tar-mode for help). -In the case of old .deb format files, the control info is shown -but not the other files of control.tar, such as install scripts. -Note that regular tar-mode commands @key{e}, @key{f} and @key{RETURN} show raw files -without any special uncompressing or formatting. -Additional features that deb-view adds to tar-mode: - -@table @samp -@item q -kill both view buffers (INFO and DATA) and return to the -dired buffer if that's where you executed deb-mode. -@item v -executes deb-view-tar-view instead of tar-view, with the -additional smarts to uncompress .gz and .Z files for viewing. -@item N -Like in dired, formats man pages for viewing, with the -additional smarts to uncompress .gz and .Z man files for viewing. -@item W -use w3-mode to view an HTML file. -@end table - -To view files not supported by deb-view, such as graphics, use the -copy command (@key{c}) to copy the file to a temp directory. You can -then do what you want to the file. - -@node gnus-BTS, pressed, deb-view, Top -@chapter gnus-BTS - access the Debian Bug Tracking System from Gnus - -Use this if you read a lot of debian lists in GNUS and see references -to the Bug Tracking system in them. It expects to see Bug references -in the form of (for example): "#48273", "closes: 238742" or similar -and will make them clickable. - -To enable this, add the following to your @file{~/.emacs} file: - -@example -(require 'gnus-BTS) -@end example - -@node pressed, , gnus-BTS, Top -@chapter preseed - major mode for debian-installer preseed files - -@noindent Author: W. Borgert <debacle@@debian.org> - -A simple major-mode for editing debian-installer preseed files. Since -such files don't always have the same extension, this mode is not -autoloaded. Enter it by using teh command line: - -@example -M-x preseed-mode -@end example diff --git a/elisp/debian-el/gnus-BTS.el b/elisp/debian-el/gnus-BTS.el deleted file mode 100755 index 2785edd..0000000 --- a/elisp/debian-el/gnus-BTS.el +++ /dev/null @@ -1,124 +0,0 @@ -;;; gnus-BTS.el --- access the Debian Bug Tracking System from Gnus - -;; Copyright (C) 2001 Andreas Fuchs <asf@acm.org> - -;; Author: Andreas Fuchs -;; Maintainer: Andreas Fuchs <asf@acm.org> -;; Keywords: gnus, Debian, Bug -;; Status: Works in XEmacs (I think >=21) -;; Created: 2001-02-07 - -;; $Id: gnus-BTS.el,v 1.2 2013/12/04 22:32:10 psg Exp $ - -;; This file is not part of GNU Emacs. - -;; gnus-BTS.el 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. - -;; gnus-BTS.el 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; Use this program if you read a lot of debian lists and see many -;; references to the Bug Tracking system in them. It expects to see -;; Bug references in the form of (for example): "#48273", "closes: -;; 238742" or similar. - -;;; Code: - - -(setq anti-bug-special-keywords "reassign\\|merge") -(setq anti-bug-keywords (concat - "tags\\|severity\\|retitle\\|close\\|closes:\\|Merged\\|reopen\\|Bug\\|" - anti-bug-special-keywords)) - -(setq anti-bug-prefix " *#?\\|Bugs?\\|#") -(setq anti-bug-number " *\\([0-9]+\\)") -(setq anti-bug-special " +\\([0-9]+\\|[-.A-Za-z0-9]+\\)") - -(setq anti-gnus-debian-bug-regexp (concat - "\\(" - "\\(" - anti-bug-keywords - "\\)" - anti-bug-prefix - "\\)" - anti-bug-number)) - -(setq anti-gnus-debian-reassign-or-merge-regexp - (concat - "\\(" - anti-bug-special-keywords - "\\)" - anti-bug-number - anti-bug-special)) - -(setq anti-gnus-debian-reassign-regexp "reassigned from package `\\([^']*\\)' to `\\([^']*\\)'") -(setq anti-gnus-debian-bug-BTS-regexp "^ *\\([0-9]+\\)") - -(defun anti-browse-debpkg-or-bug (thing) - (interactive "i") - (require 'thingatpt) - (let* ((the-thing (if (null thing) - (thing-at-point 'sexp) - thing)) - (bugp (string-match "[0-9]+$" the-thing)) - (bug-or-feature (if bugp - (progn - (string-match "^[^0-9]*\\([0-9]+\\)$" the-thing) - (match-string 1 the-thing)) - the-thing)) - (url (if bugp - "http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=" - "http://cgi.debian.org/cgi-bin/search_packages.pl?&searchon=names&version=all&release=all&keywords="))) - (browse-url (concat url bug-or-feature)))) - -(defvar in-debian-group-p nil) -(add-hook 'gnus-select-article-hook - (lambda () - (setq in-debian-group-p (string-match "debian" - (gnus-group-real-name - gnus-newsgroup-name))))) - -(defvar in-debian-devel-announce-group-p nil) -(add-hook 'gnus-select-article-hook - (lambda () - (setq in-debian-devel-announce-group-p - (string-match "debian.devel.announce" - (gnus-group-real-name - gnus-newsgroup-name))))) - -(defun anti-buttonize-debian (regexp num predicate) - (add-to-list 'gnus-button-alist - (list regexp - num - predicate - 'anti-browse-debpkg-or-bug - num))) - -(add-hook - 'gnus-article-mode-hook ; only run once, as soon as the article buffer has been created. - (lambda () - (anti-buttonize-debian anti-gnus-debian-bug-regexp 3 - 'in-debian-group-p) - (anti-buttonize-debian anti-gnus-debian-reassign-or-merge-regexp 3 - 'in-debian-group-p) - (anti-buttonize-debian anti-gnus-debian-bug-BTS-regexp 1 - 'in-debian-devel-announce-group-p) - - (anti-buttonize-debian anti-gnus-debian-reassign-regexp 1 - 'in-debian-group-p) - (anti-buttonize-debian anti-gnus-debian-reassign-regexp 2 - 'in-debian-group-p))) - -(provide 'gnus-BTS) diff --git a/elisp/debian-el/preseed.el b/elisp/debian-el/preseed.el deleted file mode 100755 index d555129..0000000 --- a/elisp/debian-el/preseed.el +++ /dev/null @@ -1,48 +0,0 @@ -;;; preseed.el --- a major mode for editing debian-installer preseed files - -;; Copyright (C) 2004 W. Borgert <debacle@debian.org> - -;; This package 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. - -;; This package 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. - -;;; Code: -(require 'font-lock) - -(defvar preseed-mode-abbrev-table nil - "Abbreviation table used in d-i preseed buffers.") -(define-abbrev-table 'preseed-mode-abbrev-table ()) - -(defvar preseed-font-lock-keywords - '(("^\\([a-z-]+\\)[ \t]+\\([^ ]+\\)[ \t]+\\([^ ]+\\)" - (1 font-lock-keyword-face) - (2 font-lock-function-name-face) - (3 font-lock-type-face)) - ("\\(^\\s-*#.*\\)" - (1 font-lock-comment-face))) - "Keyword patterns for preseed-mode fontification.") - -;;;###autoload -(defun preseed-mode () - "Major mode for editing debian-installer preseed files colourfully." - (interactive) - (kill-all-local-variables) - (setq comment-start "#" - comment-multi-line nil - comment-start-skip "#+[\t ]*") - (setq major-mode 'preseed-mode - mode-name "Preseed" - local-abbrev-table preseed-mode-abbrev-table) - (run-hooks 'preseed-mode-hook) - (set (make-local-variable 'font-lock-defaults) - '(preseed-font-lock-keywords nil nil ((?_ . "w"))))) - -(provide 'preseed) - -;;; preseed.el ends here diff --git a/elisp/devscripts-el/devscripts.el b/elisp/devscripts-el/devscripts.el index 4c6e64c..4c6e64c 100755..100644 --- a/elisp/devscripts-el/devscripts.el +++ b/elisp/devscripts-el/devscripts.el diff --git a/elisp/devscripts-el/pbuilder-log-view-mode.el b/elisp/devscripts-el/pbuilder-log-view-mode.el index db3db13..db3db13 100755..100644 --- a/elisp/devscripts-el/pbuilder-log-view-mode.el +++ b/elisp/devscripts-el/pbuilder-log-view-mode.el diff --git a/elisp/devscripts-el/pbuilder-mode.el b/elisp/devscripts-el/pbuilder-mode.el index c24770a..c24770a 100755..100644 --- a/elisp/devscripts-el/pbuilder-mode.el +++ b/elisp/devscripts-el/pbuilder-mode.el diff --git a/elisp/dpkg-dev-el/debian-bts-control.el b/elisp/dpkg-dev-el/debian-bts-control.el deleted file mode 100755 index 7ecae22..0000000 --- a/elisp/dpkg-dev-el/debian-bts-control.el +++ /dev/null @@ -1,1231 +0,0 @@ -;;; debian-bts-control.el --- Create messages for Debian BTS control interface - -;; Copyright (C) 2003, 2005, 2007, 2009 Peter S Galbraith -;; -;; Help text from http://www.debian.org/Bugs/server-control: -;; Debian BTS administrators <owner@bugs.debian.org> -;; Copyright 1999 Darren O. Benham, 1994-1997 Ian Jackson, -;; 1997 nCipher Corporation Ltd. -;; -;; This file 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. -;; -;; debian-bts-mode.el 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 your Debian installation, in /usr/share/common-licenses/GPL -;; If not, write to the Free Software Foundation, 675 Mass Ave, -;; Cambridge, MA 02139, USA. - -;;; Commentary: -;; -;; Use `M-x debian-bts-control' to create an initial message, and -;; `M-x debian-bts-control' again (or `C-c C-b') to insert new directives. - -;;; Change log: -;; -;; V1.00 30apr2003 Peter S Galbraith <psg@debian.org> -;; - Initial release. -;; V1.01 23May2003 Peter S Galbraith <psg@debian.org> -;; - Add `debian-bts-control-modes-to-reuse'. -;; V1.02 09Aug2003 Peter S Galbraith <psg@debian.org> -;; - add `debian-bts-control-prompt' to Prompt for bug number using sensible -;; default if found. -;; V1.03 03Sep2003 Peter S Galbraith <psg@debian.org> -;; - Don't set `debian-bts-control-verbose-prompts-flag' to t for Emacs20 -;; since it can't display multi-line prompts. (Closes: #208553) -;; V1.04 05Sep2003 Peter S Galbraith <psg@debian.org> -;; - debian-bts-help-control: was missing! -;; V1.05 18Sep2003 Peter S Galbraith <psg@debian.org> -;; - Add `package', `owner' and `noowner'. -;; V1.06 05Oct2003 Peter S Galbraith <psg@debian.org> -;; - Add tags "sarge-ignore" and "fixed-uptsream". -;; V1.07 03Nov2003 Peter S Galbraith <psg@debian.org> -;; - Created defgroup debian-bts-control. -;; V1.08 20Nov2005 Peter S Galbraith <psg@debian.org> -;; - patch from Jari Aalto <jari aalto A T cante net>: -;; It is now possible to put point at "Bug#NNNN" e.g. in debian/changelog -;; and use that as default number. -;; (top level): Added '(require 'cl) -;; (debian-bts-bug-number-at-point): New function. -;; (debian-bts-control-prompt): Code structure slightly redesigned. -;; (debian-bts-control): Use `debian-bts-bug-number-at-point' to -;; set `number-default'. -;; V1.08 08Aug2007 Peter S Galbraith <psg@debian.org> -;; - Use `C-c C-b' instead of `C-c c' (Closes: #435247). -;; V1.09 30Aug2007 Peter S Galbraith <psg@debian.org> -;; - skip over mml directives (Closes: #392132) -;; V1.10 30Aug2007 Peter S Galbraith <psg@debian.org> -;; - Add `fixed' `notfixed' `block' `unblock' `archive' `unarchive' -;; `found' `notfound'. (Closes: #391647) -;; V1.11 23Feb2009, Patch from Luca Capello <luca@pca.it>. -;; - Add `debian-bts-control-cc-or-bcc' (Closes: #392494) -;; V1.12 11Nov2009 Peter S Galbraith <psg@debian.org> -;; - Add `debian-bts-emailaddress' and `debian-bts-emaildomain'. -;; - Add command `emacs-bts-control', new command to interface with Emacs BTS. -;; V1.13 21Nov2009 Peter S Galbraith <psg@debian.org> -;; - Patches from Sven Joachim (Closes: #557408, #557412) -;; V1.14 19Dec2009 Peter S Galbraith <psg@debian.org> -;; - Emacs BTS moved to debbugs.gnu.org -;; V1.15 22Feb2010 Peter S Galbraith <psg@debian.org> -;; - add autoload cookie for `emacs-bts-control' (Closes: #565934) -;; V1.16 05Nov2016 Peter S Galbraith <psg@debian.org> -;; Bug fix: "please add all BTS commands (e.g. affects and usertags)", -;; thanks to Luca Capello (Closes: #643888). -;; - Add `affects', `forcemerge', `summary' and font-lock for `tag'. -;; - Remove `close' -;;; Code: - -(eval-when-compile '(require 'cl)) -(require 'debian-bug) -(autoload 'word-at-point "thingatpt") - -(defgroup debian-bts-control nil - "Create messages for Debian BTS control interface" - :group 'debian-bug) - -(defcustom debian-bts-control-verbose-prompts-flag t - "Non-nil means to be very verbose for `debian-bts-control' prompts." - :group 'debian-bts-control - :type 'boolean - :set (lambda (symbol value) - (if (<= 21 emacs-major-version) - (set-default symbol value) - (message - "debian-bts-control-verbose-prompts-flag overridden for Emacs20") - (set-default symbol nil)))) - -(defcustom debian-bts-control-modes-to-reuse - '(mh-letter-mode mail-mode message-mode) - "List of modes in which calling `debian-bts-control' will reuse the buffer. -No new draft will be created. Instead control@bugs.debian.org will be -added to the `debian-bts-control-cc-or-bcc' field and the commands added at -the top of the message." - :group 'debian-bts-control - :type '(repeat symbol)) - -(defcustom debian-bts-control-cc-or-bcc 'cc - "Whether to use Cc: or Bcc: header." - :group 'debian-bts-control - :type '(choice (const cc) (const bcc))) - -(defvar debian-bts-emailaddress "control@bugs.debian.org" - "Email address to send control message to.") - -(defvar debian-bts-emaildomain "bugs.debian.org" - "Email address domain to send control message to.") - -(defvar debian-bts-control-minor-mode nil) -(defvar debian-bts-control-minor-mode-map nil - "Keymap for `debian-bts-control' minor mode.") -(if debian-bts-control-minor-mode-map - nil - (setq debian-bts-control-minor-mode-map (make-sparse-keymap)) - (define-key debian-bts-control-minor-mode-map "\C-c\C-b" 'debian-bts-control)) - -(easy-menu-define debian-bts-control-menu debian-bts-control-minor-mode-map - "Debian Bug Mode Menu" - '("Control" - ("Header" - ["Custom From Address" (debian-bug--toggle-custom-From) - :style toggle :active debian-bug-From-address - :selected (debian-bug--is-custom-From)] - "--" - ["CC debian-devel" (debian-bug--toggle-CC-devel) - :style toggle - :selected (debian-bug--is-CC "debian-devel@lists.debian.org" "cc:")] - ["CC me" (debian-bug--toggle-CC-myself) - :style toggle :active debian-bug-From-address - :selected (debian-bug--is-CC debian-bug-From-address "cc:")] - ) - "--" - ["Affects" (debian-bts-control "affects") t] - ["Package" (debian-bts-control "package") t] - ["Reassign" (debian-bts-control "reassign") t] - ["Reopen" (debian-bts-control "reopen") t] - ["Owner" (debian-bts-control "owner") t] - ["NoOwner" (debian-bts-control "noowner") t] - ["Submitter" (debian-bts-control "submitter") t] - ["Forwarded" (debian-bts-control "forwarded") t] - ["NotForwarded" (debian-bts-control "notforwarded") t] - ["Retitle" (debian-bts-control "retitle") t] - ["Severity" (debian-bts-control "severity") t] - ["Summary" (debian-bts-control "summary") t] - ["Clone" (debian-bts-control "clone") t] - ["Merge" (debian-bts-control "merge") t] - ["ForceMerge" (debian-bts-control "forcemerge") t] - ["UnMerge" (debian-bts-control "unmerge") t] - ["Tags" (debian-bts-control "tags") t] - ["Close" (debian-bts-control "close") t] - "--" - ("Web View" - ["Bugs for a Package..." (debian-bug-web-bugs) t] - ["Bug Number..." (debian-bug-web-bug) t] - ["Package Info..." (debian-bug-web-packages) t] - ) - ["Customize" - (customize-group "debian-bug") (fboundp 'customize-group)] - ("Help" - ["Severities" (debian-bug-help-severity) t] - ["Tags" (debian-bug-help-tags) t] - ["Pseudo-Packages" (debian-bug-help-pseudo-packages) t] -;; ["Addresses" (debian-bug-help-email) t] - ["control commands" (debian-bts-help-control) t] - ) - )) - -;; - Add `fixed' `notfixed' `block' `unblock' `archive' `unarchive' -;; `found' `notfound'. (Closes: #391647) - -(defvar debian-bts-control-font-lock-keywords - '(("#.*$" . font-lock-comment-face) - ("^ *thank.*$" . font-lock-function-name-face) - ("^ *\\(summary\\) +\\(-?[0-9]+\\) *\\(.*\\)$" - (1 font-lock-function-name-face) - (2 font-lock-type-face) - (3 font-lock-string-face)) - ("^ *\\(affects\\) +\\(-?[0-9]+\\) *\\(.*\\)$" - (1 font-lock-function-name-face) - (2 font-lock-type-face) - (3 font-lock-string-face)) - ("^ *\\(found\\) +\\(-?[0-9]+\\) *\\(.*\\)$" - (1 font-lock-function-name-face) - (2 font-lock-type-face) - (3 font-lock-string-face)) - ("^ *\\(notfound\\) +\\(-?[0-9]+\\) +\\(.+\\)$" - (1 font-lock-function-name-face) - (2 font-lock-type-face) - (3 font-lock-string-face)) - ("^ *\\(archive\\) +\\(-?[0-9]+\\)$" - (1 font-lock-function-name-face) - (2 font-lock-type-face)) - ("^ *\\(unarchive\\) +\\(-?[0-9]+\\)$" - (1 font-lock-function-name-face) - (2 font-lock-type-face)) - ("^ *\\(block\\) +\\(-?[0-9]+\\) +\\(by\\) +\\(.+\\)$" - (1 font-lock-function-name-face) - (2 font-lock-type-face) - (3 font-lock-function-name-face) - (4 font-lock-string-face)) - ("^ *\\(unblock\\) +\\(-?[0-9]+\\) +\\(by\\) +\\(.+\\)$" - (1 font-lock-function-name-face) - (2 font-lock-type-face) - (3 font-lock-function-name-face) - (4 font-lock-string-face)) - ("^ *\\(fixed\\) +\\(-?[0-9]+\\) +\\(.+\\)$" - (1 font-lock-function-name-face) - (2 font-lock-type-face) - (3 font-lock-string-face)) - ("^ *\\(notfixed\\) +\\(-?[0-9]+\\) +\\(.+\\)$" - (1 font-lock-function-name-face) - (2 font-lock-type-face) - (3 font-lock-string-face)) - ("^ *\\(package\\) +\\([a-z0-9\\.\\-]+\\)$" - (1 font-lock-function-name-face) - (2 font-lock-keyword-face nil t)) - ("^ *\\(owner\\) +\\(-?[0-9]+\\) +\\(\\(!\\)\\|\\(.+\\)\\)$" - (1 font-lock-function-name-face) - (2 font-lock-type-face) - (4 font-lock-keyword-face nil t) - (5 font-lock-string-face nil t)) - ("^ *\\(noowner\\) +\\(-?[0-9]+\\)" - (1 font-lock-function-name-face) - (2 font-lock-type-face)) - ("^ *\\(reassign\\) +\\(-?[0-9]+\\) +\\([a-z0-9\\.\\-]+\\)$" - (1 font-lock-function-name-face) - (2 font-lock-type-face) - (3 font-lock-keyword-face nil t)) - ("^ *\\(reopen\\) +\\(-?[0-9]+\\) +\\(\\(!\\|=\\)\\|\\(.+\\)\\)$" - (1 font-lock-function-name-face) - (2 font-lock-type-face) - (4 font-lock-keyword-face nil t) - (5 font-lock-string-face nil t)) - ("^ *\\(submitter\\) +\\(-?[0-9]+\\) +\\(\\(!\\)\\|\\(.+\\)\\)$" - (1 font-lock-function-name-face) - (2 font-lock-type-face) - (4 font-lock-keyword-face nil t) - (5 font-lock-string-face nil t)) - ("^ *\\(forwarded\\) +\\(-?[0-9]+\\) +\\(.+\\)$" - (1 font-lock-function-name-face) - (2 font-lock-type-face) - (3 font-lock-string-face)) - ("^ *\\(notforwarded\\) +\\(-?[0-9]+\\)" - (1 font-lock-function-name-face) - (2 font-lock-type-face)) - ("^ *\\(retitle\\) +\\(-?[0-9]+\\) +\\(.+\\)$" - (1 font-lock-function-name-face) - (2 font-lock-type-face) - (3 font-lock-string-face)) - ("^ *\\(severity\\) +\\(-?[0-9]+\\) +\\(\\(critical\\|grave\\|serious\\)\\|\\(important\\)\\|\\(normal\\)\\|\\(\\(minor\\)\\|\\(wishlist\\)\\)\\)" - (1 font-lock-function-name-face) - (2 font-lock-type-face) - (4 font-lock-warning-face nil t) - (5 font-lock-keyword-name-face nil t) - (6 font-lock-type-face nil t) - (7 font-lock-string-face nil t)) - ("^ *\\(clone\\) +\\([0-9]+\\) +\\(-[0-9]+\\( +-[0-9]+\\)*\\)$" - (1 font-lock-function-name-face) - (2 font-lock-type-face) - (3 font-lock-keyword-face)) - ("^ *\\(merge\\) +\\(-?[0-9]+ +-?[0-9]+\\( +-?[0-9]+\\)*\\)$" - (1 font-lock-function-name-face) - (2 font-lock-type-face) - (3 font-lock-keyword-face)) - ("^ *\\(forcemerge\\) +\\(-?[0-9]+ +-?[0-9]+\\( +-?[0-9]+\\)*\\)$" - (1 font-lock-function-name-face) - (2 font-lock-type-face) - (3 font-lock-keyword-face)) - ("^ *\\(unmerge\\) +\\(-?[0-9]+\\)$" - (1 font-lock-function-name-face) - (2 font-lock-type-face)) - ("^ *\\(tags?\\) +\\(-?[0-9]+\\) +\\([-+=]? +\\)?\\(security\\)" - (1 font-lock-function-name-face) - (2 font-lock-type-face) - (3 font-lock-keyword-face nil t) - (4 font-lock-warning-face)) - ("^ *\\(tags?\\) +\\(-?[0-9]+\\) +\\([-+=]? +\\)?\\(patch\\|wontfix\\|moreinfo\\|unreproducible\\|help\\|pending\\|fixed-in-experimental\\|fixed-upstream\\|fixed\\|security\\|upstream\\|confirmed\\|d-i\\|ipv6\\|lfs\\|l10n\\|potato\\|woody\\|sarge-ignore\\|sarge\\|etch-ignore\\|etch\\|jessie\\|jessie-ignore\\|sid\\|experimental\\)" - (1 font-lock-function-name-face) - (2 font-lock-type-face) - (3 font-lock-keyword-face nil t) - (4 font-lock-keyword-face))) - "Regexp keywords to fontify `debian-bts-control' reports.") - -(defun debian-bts-control-minor-mode (arg) - "Toggle `debian-bts-control' mode. -A positive prefix argument ARG turns on `debian-bts-control' mode\; -a negative prefix argument turns it off. -\\<debian-bts-control-minor-mode-map> -\\[debian-bts-control]\t\tAdd a control command to the current message." - (interactive "P") - (set (make-local-variable 'debian-bts-control-minor-mode) - (if arg - (> (prefix-numeric-value arg) 0) - (not debian-bts-control-minor-mode))) - (cond - (debian-bts-control-minor-mode ;Setup the minor-mode - (if (fboundp 'font-lock-add-keywords) - (font-lock-add-keywords nil debian-bts-control-font-lock-keywords t)) - ))) - -;; Install ourselves: -(or (assq 'debian-bts-control-minor-mode minor-mode-alist) - (setq minor-mode-alist - (cons '(debian-bts-control-minor-mode " DBugC") minor-mode-alist))) -(or (assq 'debian-bts-control-minor-mode minor-mode-map-alist) - (setq minor-mode-map-alist - (cons (cons 'debian-bts-control-minor-mode - debian-bts-control-minor-mode-map) - minor-mode-map-alist))) - -(defvar debian-bts-control-alist - '(("reassign") ("severity") ("reopen") ("submitter") ("forwarded") - ("notforwarded") ("retitle") ("clone") ("merge") ("unmerge") - ("tags") ("package") ("owner") ("noowner") ("found") - ("notfound") ("fixed") ("notfixed") ("block") ("unblock") ("archive") - ("unarchive") ("affects") ("forcemerge") ("summary")) - "List of available commands at control@bugs.debian.org.") - -(defun debian-bts-bug-number-at-point () - "Read #NNNNNN from current point." - (let ((item (word-at-point))) - (if (and item - (string-match "^[0-9]+[0-9]$" item)) - item))) - -(defun debian-bts-control-prompt (prompt &optional number) - "Prompt for bug number using sensible default if found." - (let ((default-number number)) - (unless default-number - (save-excursion - (goto-char (point-min)) - (if (re-search-forward (concat "\\([0-9]+\\)@" debian-bts-emaildomain) - (mail-header-end) t) - (setq default-number (match-string-no-properties 1))))) - (if default-number - (read-string (format "%s [%s]: " prompt default-number) - nil nil default-number) - (read-string (format "%s: " prompt))))) - -;;;###autoload -(defun debian-bts-control (action &optional arg) - "Contruct a message with initial ACTION command for control@bugs.debian.org. -Contructs a new control command line if called from within the message -being constructed. - -If prefix arg is provided, use the current buffer instead instead of -creating a new outgoing email message buffer. -The current buffer is also used if the current major mode matches one listed -in `debian-bts-control-modes-to-reuse'." - (interactive (list (completing-read "Command: " - debian-bts-control-alist nil nil) - current-prefix-arg)) - (let ((number-default (debian-bts-bug-number-at-point))) - (cond - ((or arg - (and (car (memq t (mapcar '(lambda (item) (eq item major-mode)) - debian-bts-control-modes-to-reuse))) - (not debian-bts-control-minor-mode))) - (debian-bug--set-CC debian-bts-emailaddress - (concat - (symbol-name debian-bts-control-cc-or-bcc) ":")) - (goto-char (point-min)) - (if (re-search-forward (concat "\\([0-9]+\\)@" debian-bts-emaildomain) - (mail-header-end) t) - (setq number-default (match-string 1))) - (goto-char (mail-header-end)) - (forward-line 1) - (if (looking-at "^<#secure") ;Skip over mml directives - (forward-line 1)) - (insert "thanks\n\n") - (debian-bts-control-minor-mode 1)) - ((not debian-bts-control-minor-mode) - (reporter-compose-outgoing) - (if (and (equal mail-user-agent 'gnus-user-agent) - (string-equal " *nntpd*" (buffer-name))) - (set-buffer "*mail*")) ; Bug in emacs21.1? Moves to " *nntpd*" - (goto-char (point-min)) - (cond - ((re-search-forward "To: " nil t) - (insert debian-bts-emailaddress)) - ((re-search-forward "To:" nil t) - (insert " " debian-bts-emailaddress)) - (t - (insert "To: " debian-bts-emailaddress))) - (if debian-bug-use-From-address - (debian-bug--set-custom-From)) - (if debian-bug-always-CC-myself - (debian-bug--set-CC debian-bug-From-address "cc:")) - (goto-char (mail-header-end)) - (forward-line 1) - (if (looking-at "^<#secure") ;Skip over mml directives - (forward-line 1)) - (insert "thanks\n") - (debian-bts-control-minor-mode 1))) - (goto-char (mail-header-end)) - (if (re-search-forward "^thank" nil t) - (beginning-of-line) - (goto-char (point-max))) - (cond - ((string-equal "package" action) - (debian-bug-fill-packages-obarray) - (let* ((verbose (if debian-bts-control-verbose-prompts-flag - "package [ packagename ... ] - - Limits the following commands so that they will only apply to bugs - filed against the listed packages. You can list one or more - packages. If you don't list any packages, the following commands will - apply to all bugs. You're encouraged to use this as a safety feature - in case you accidentally use the wrong bug numbers. - -" - "")) - (package (completing-read - (concat verbose "Package list to limit to: ") - (debian-bug-fill-packages-obarray) nil nil))) - (insert (format "package %s\n" package)))) - ((string-equal "affects" action) - (debian-bug-fill-packages-obarray) - (let* ((verbose (if debian-bts-control-verbose-prompts-flag - "affects bugnumber [ + | - | = ] package [ package ... ] - - Indicates that a bug affects another package. In the case where - bugnumber causes breakage in package even though the bug is - actually present in the package to which it is assigned, this - causes the bug to be listed by default in the bug list of - package. This should generally be used where the bug is severe - enough to cause multiple reports from users to be assigned to - the wrong package. = sets the affects to the list of packages - given, and is the default action if no packages are given; - - removes the given packages from the affects list; + adds the - given packages to the affects list, and is the default if - packages are given. - -" - "")) - (bug-number (debian-bts-control-prompt - (concat verbose "Bug number") - number-default)) - (sign (completing-read - (concat verbose "[ + | - | = ] ") - '(("+") ("-") ("=")) nil nil)) - (package (completing-read - (concat verbose "Package affected: ") - (debian-bug-fill-packages-obarray) nil nil))) - (insert (format "affects %s %s %s \n" bug-number sign package)))) - ((string-equal "reassign" action) - (debian-bug-fill-packages-obarray) - (let* ((verbose (if debian-bts-control-verbose-prompts-flag - "reassign bugnumber package - - Records that bug #BUGNUMBER is a bug in PACKAGE. This can be used to - set the package if the user forgot the pseudo-header, or to change an - earlier assignment. No notifications are sent to anyone (other than the - usual information in the processing transcript). - -" - "Package to reassign to: ")) - (bug-number (debian-bts-control-prompt - (concat verbose "Bug number") - number-default)) - (package (completing-read - (concat verbose "Package to reassign to: ") - (debian-bug-fill-packages-obarray) nil nil))) - (insert (format "reassign %s %s\n" bug-number package)))) - ((string-equal "reopen" action) - (let* ((verbose (if debian-bts-control-verbose-prompts-flag - "reopen bugnumber [ originator-address | = | ! ] - - Reopens #BUGNUMBER if it is closed. - - By default, or if you specify =, the original submitter will remain the - originator of the report. - - The originator will be set to the optional address you supply. If you wish - to become the new originator of the reopened report you can use the ! - shorthand or specify your own email address. - - If the bug is not closed then \"reopen\" won't do anything, not even change - the originator. To change the originator of an open bug report, use the - \"submitter\" command; note that this will inform the original submitter of - the change. - -" - "")) - (bug-number (debian-bts-control-prompt - (concat verbose "Bug number") - number-default)) - (originator (read-string - (concat verbose "Originator-address (optional): ")))) - (insert (format "reopen %s %s\n" bug-number originator)))) - ((string-equal "submitter" action) - (let* ((verbose (if debian-bts-control-verbose-prompts-flag - "submitter bugnumber originator-address | ! - - Changes the originator of #BUGNUMBER to ORIGINATOR-ADDRESS. - - If you wish to become the new originator of the report you can use the - ! shorthand or specify your own email address. - - While the reopen command changes the originator of other bugs merged - with the one being reopened, submitter does not affect merged bugs. - -" - "")) - (bug-number (debian-bts-control-prompt - (concat verbose "Bug number") - number-default)) - (originator (read-string - (concat verbose "Originator-address (optional): ")))) - (insert (format "submitter %s %s\n" bug-number originator)))) - ((string-equal "owner" action) - (let* ((verbose (if debian-bts-control-verbose-prompts-flag - "owner bugnumber address | ! - - Sets address to be the \"owner\" of #bugnumber. The owner of a bug - claims responsibility for fixing it and will receive all mail - regarding it. This is useful to share out work in cases where a - package has a team of maintainers. - - If you wish to become the owner of the bug yourself, you can use the - ! shorthand or specify your own email address. - -" - "")) - (bug-number (debian-bts-control-prompt - (concat verbose "Bug number") - number-default)) - (address (read-string - (concat verbose "address (optional): ")))) - (insert (format "owner %s %s\n" bug-number address)))) - ((string-equal "noowner" action) - (let* ((verbose (if debian-bts-control-verbose-prompts-flag - "noowner bugnumber - - Forgets any idea that the bug has an owner other than the usual - maintainer. If the bug had no owner recorded then this will do - nothing. - -" - "")) - (bug-number (debian-bts-control-prompt - (concat verbose "Bug number") - number-default))) - (insert (format "noowner %s\n" bug-number)))) - ((string-equal "forwarded" action) - (let* ((verbose (if debian-bts-control-verbose-prompts-flag - "forwarded bugnumber address - - Notes that BUGNUMBER has been forwarded to the upstream maintainer at - ADDRESS. This does not actually forward the report. This can be used to - change an existing incorrect forwarded-to address, or to record a new - one for a bug that wasn't previously noted as having been forwarded. - -" - "")) - (bug-number (debian-bts-control-prompt - (concat verbose "Bug number") - number-default)) - (address (read-string - (concat verbose "Forwarded-address: ")))) - (insert (format "forwarded %s %s\n" bug-number address)))) - ((string-equal "notforwarded" action) - (let* ((verbose (if debian-bts-control-verbose-prompts-flag - "notforwarded bugnumber - - Forgets any idea that BUGNUMBER has been forwarded to any upstream - maintainer. If the bug was not recorded as having been forwarded then - this will do nothing. - -" - "")) - (bug-number (debian-bts-control-prompt - (concat verbose "Bug number") - number-default))) - (insert (format "notforwarded %s\n" bug-number)))) - ((string-equal "retitle" action) - (let* ((verbose (if debian-bts-control-verbose-prompts-flag - "retitle bugnumber new-title - - Changes the TITLE of a bug report to that specified (the default is the - Subject mail header from the original report). - - Unlike most of the other bug-manipulation commands, when used on one of - a set of merged reports this will change the title of only the - individual bug requested, and not all those with which it is merged. - -" - "")) - (bug-number (debian-bts-control-prompt - (concat verbose "Bug number") - number-default)) - (title (read-string - (concat verbose "New title: ")))) - (insert (format "retitle %s %s\n" bug-number title)))) - ((string-equal "summary" action) - (let* ((verbose (if debian-bts-control-verbose-prompts-flag - "summary bugnumber [message number | summary text] - - Selects a message to use as a summary of a bug. The first - non-pseudoheader/non-control paragraph of that message is parsed - and set as the summary of the bug which is displayed on the top - of the bug report page. This is useful in cases where the - original report doesn't correctly describe the problem or the - bug has many messages which make it difficult to identify the - actual problem. - - If message number is not given, clears the summary. message - number is the message number as listed in the bugreport cgi - script output; if a message number of 0 is given, the current - message is used (that is, the message which was sent to - control@bugs.debian.org which contains the summary control - command). - - If message number is not numerical and not the empty string, it - is assumed to be the text to set the summary to. - -" - "")) - (bug-number (debian-bts-control-prompt - (concat verbose "Bug number") - number-default)) - (title (read-string - (concat verbose "Summary: ")))) - (insert (format "summary %s %s\n" bug-number title)))) - ((string-equal "severity" action) - (let* ((verbose (if debian-bts-control-verbose-prompts-flag - "severity bugnumber severity - - Set the severity level for bug report #BUGNUMBER to SEVERITY. No - notification is sent to the user who reported the bug. - - Severities are critical, grave, serious, important, normal, minor, and - wishlist. - - For their meanings, consult the Control->Help->Severities menu. - -" - "")) - (bug-number (debian-bts-control-prompt - (concat verbose "Bug number") - number-default)) - (severity (completing-read "Severity: " debian-bug-severity-alist - nil t))) - (insert (format "severity %s %s\n" bug-number severity)))) - ((string-equal "clone" action) - (let* ((verbose (if debian-bts-control-verbose-prompts-flag - "clone bugnumber [ new IDs ] - - Duplicate a bug report. Useful when a single report indicates that - multiple distinct bugs have occured. \"New IDs\" are negative numbers, - separated by spaces, which may be used in subsequent control commands to - refer to the newly duplicated bugs. - Example usage: - clone 12345 -1 -2 - reassign -1 foo - retitle -1 foo: foo sucks - reassign -2 bar - retitle -2 bar: bar sucks when used with foo - severity -2 wishlist -" - "")) - (bug-number (debian-bts-control-prompt - (concat verbose "Bug number") - number-default)) - (ids (read-string (concat verbose "New IDs (e.g. -1 -2): ")))) - (insert (format "clone %s %s\n" bug-number ids)))) - ((string-equal "merge" action) - (let* ((verbose (if debian-bts-control-verbose-prompts-flag - "merge bugnumber bugnumber ... - - Merges two or more bug reports. When reports are merged, opening, closing, - marking or unmarking as forwarded and reassigning any of the bugs to a new - package will have an identical effect on all of the merged reports. - - Before bugs can be merged they must be in exactly the same state. - -" - "")) - (bug-numbers (read-string (concat verbose "All bug numbers: ")))) - (insert (format "merge %s\n" bug-numbers)))) - ((string-equal "forcemerge" action) - (let* ((verbose (if debian-bts-control-verbose-prompts-flag - "forcemerge bugnumber bugnumber ... - - Forcibly merges two or more bug reports. The settings of the - first bug listed which must be equal in a normal merge are - assigned to the bugs listed next. To avoid typos erroneously - merging bugs, bugs must be in the same package. See the text - above for a description of what merging means. - - Note that this makes it possible to close bugs by merging; you - are responsible for notifying submitters with an appropriate - close message if you do this. - -" - "")) - (bug-numbers (read-string (concat verbose "All bug numbers: ")))) - (insert (format "forcemerge %s\n" bug-numbers)))) - ((string-equal "unmerge" action) - (let* ((verbose (if debian-bts-control-verbose-prompts-flag - "unmerge bugnumber - - Disconnects a bug report from any other reports with which it may have - been merged. If the report listed is merged with several others then - they are all left merged with each other; only their associations with - the bug explicitly named are removed. - -" - "")) - (bug-number (debian-bts-control-prompt - (concat verbose "Bug number") - number-default))) - (insert (format "unmerge %s\n" bug-number)))) - ((string-equal "tags" action) - (let* ((verbose (if debian-bts-control-verbose-prompts-flag - "tags bugnumber [ + | - | = ] tag - - Sets a particular tag for the bug report #BUGNUMBER to tag. No - notification is sent to the user who reported the bug. + means adding, - - means subtracting, and = means ignoring the current tags and setting them - afresh. The default action is adding. - - Tags are patch, wontfix, moreinfo, unreproducible, help, pending, fixed, - fixed-in-experimental, fixed-upstream, security, upstream, confirmed, d-i, - ipv6, lfs, l10n, potato, woody, sarge, sarge-ignore, etch, etch-ignore, - sid, and experimental. - - For their meanings, consult the Control->Help->Tags menu. - -" - "")) - (bug-number (debian-bts-control-prompt - (concat verbose "Bug number") - number-default)) - (add (completing-read "+, -, = (default +): " - '(("+") ("-") ("=")) nil t nil nil "+")) - (tag (completing-read "Tag: " debian-bug-alltags-alist nil t))) - (insert (format "tags %s %s %s\n" bug-number add tag)))) - ((string-equal "close" action) - (if (yes-or-no-p - (concat "Deprecated in favor of #BUG-close@" - debian-bts-emaildomain ". Continue? ")) - (let* ((verbose (if debian-bts-control-verbose-prompts-flag - "close bugnumber - - Close bug report #BUGNUMBER. - - A notification is sent to the user who reported the bug, but (in contrast - to mailing bugnumber-done@bugs) the text of the mail which caused the bug - to be closed is not included in that notification. The maintainer who - closes a report needs to ensure, probably by sending a separate message, - that the user who reported the bug knows why it is being closed. The use of - this command is therefore deprecated. - -" - "")) - (bug-number (debian-bts-control-prompt - (concat verbose "Bug number") - number-default))) - (insert (format "close %s\n" bug-number))))) - ((string-equal "found" action) - (let* ((verbose (if debian-bts-control-verbose-prompts-flag - "found bugnumber [version] - - Record that #bugnumber has been encountered in the given - version of the package to which it is assigned. - - The BTS considers a bug to be open when it has no fixed - version, or when it has been found more recently than it has - been fixed. - - If no version is given, then the list of fixed versions for - the bug is cleared. This is identical to the behaviour of - reopen. - - This command will only cause a bug to be marked as not done - if no version is specified, or if the version being marked - found is equal to the version which was last marked - fixed. (If you are certain that you want the bug marked as - not done, use reopen in conjunction with found.) - -" - "")) - (bug-number (debian-bts-control-prompt - (concat verbose "Bug number") - number-default)) - (version (read-string (concat verbose "Version (if any): ")))) - (insert (format "found %s %s\n" bug-number version)))) - ((string-equal "notfound" action) - (let* ((verbose (if debian-bts-control-verbose-prompts-flag - "notfound bugnumber version - - Remove the record that #bugnumber was encountered in the - given version of the package to which it is assigned. - - This differs from closing the bug at that version in that the - bug is not listed as fixed in that version either; no - information about that version will be known. It is intended - for fixing mistakes in the record of when a bug was found. - -" - "")) - (bug-number (debian-bts-control-prompt - (concat verbose "Bug number") - number-default)) - (version (read-string (concat verbose "Version: ")))) - (insert (format "notfound %s %s\n" bug-number version)))) - ((string-equal "fixed" action) - (let* ((verbose (if debian-bts-control-verbose-prompts-flag - "fixed bugnumber version - - Indicate that bug #bugnumber was fixed in the given version - of the package to which it is assigned. - - This does not cause the bug to be marked as closed, it merely - adds another version in which the bug was fixed. Use the - bugnumber-done address to close a bug and mark it fixed in a - particular version. - -" - "")) - (bug-number (debian-bts-control-prompt - (concat verbose "Bug number") - number-default)) - (version (read-string (concat verbose "Version: ")))) - (insert (format "fixed %s %s\n" bug-number version)))) - ((string-equal "notfixed" action) - (let* ((verbose (if debian-bts-control-verbose-prompts-flag - "notfixed bugnumber version - - Remove the record that bug #bugnumber has been fixed in the - given version. - - This command is equivalent to found followed by notfound (the - found removes the fixed at a particular version, and notfound - removes the found.) - -" - "")) - (bug-number (debian-bts-control-prompt - (concat verbose "Bug number") - number-default)) - (version (read-string (concat verbose "Version: ")))) - (insert (format "notfixed %s %s\n" bug-number version)))) - ((string-equal "block" action) - (let* ((verbose (if debian-bts-control-verbose-prompts-flag - "block bugnumber by bug ... - - Note that the fix for the first bug is blocked by the other - listed bugs. - -" - "")) - (bug-number (debian-bts-control-prompt - (concat verbose "Bug number") - number-default)) - (by-bug (read-string (concat verbose "by bug number(s): ")))) - (insert (format "block %s by %s\n" bug-number by-bug)))) - ((string-equal "unblock" action) - (let* ((verbose (if debian-bts-control-verbose-prompts-flag - "nblock bugnumber by bug ... - Note that the fix for the first bug is no longer blocked by the other listed bugs. - -" - "")) - (bug-number (debian-bts-control-prompt - (concat verbose "Bug number") - number-default)) - (by-bug (read-string (concat verbose "by bug number(s): ")))) - (insert (format "unblock %s by %s\n" bug-number by-bug)))) - ((string-equal "archive" action) - (let* ((verbose (if debian-bts-control-verbose-prompts-flag - "archive bugnumber - - Archives a bug that had been archived at some point in the - past but is currently not archived if the bug fulfills the - requirements for archival, ignoring time. - -" - "")) - (bug-number (debian-bts-control-prompt - (concat verbose "Bug number") - number-default))) - (insert (format "archive %s\n" bug-number)))) - ((string-equal "unarchive" action) - (let* ((verbose (if debian-bts-control-verbose-prompts-flag - "unarchive bugnumber - - Unarchives a bug that was previously archived. Unarchival - should generally be coupled with reopen and found/fixed as - appropriate. Bugs that have been unarchived can be archived - using archive assuming the non-time based archival - requirements are met. - -" - "")) - (bug-number (debian-bts-control-prompt - (concat verbose "Bug number") - number-default))) - (insert (format "unarchive %s\n" bug-number)))) - ))) - - -(defun debian-bts-help-control () - (with-output-to-temp-buffer "*Help*" - (princ - "reassign bugnumber package - - Records that bug #bugnumber is a bug in package. This can be used to - set the package if the user forgot the pseudo-header, or to change an - earlier assignment. No notifications are sent to anyone (other than the - usual information in the processing transcript). - -reopen bugnumber [ originator-address | = | ! ] - - Reopens #bugnumber if it is closed. - - By default, or if you specify =, the original submitter is still as the - originator of the report, so that they will get the ack when it is - closed again. - - If you supply an originator-address the originator will be set to the - address you supply. If you wish to become the new originator of the - reopened report you can use the ! shorthand or specify your own email - address. - - It is usually a good idea to tell the person who is about to be - recorded as the originator that you're reopening the report, so that - they will know to expect the ack which they'll get when it is closed - again. - - If the bug is not closed then reopen won't do anything, not even change - the originator. To change the originator of an open bug report, use the - submitter command; note that this will inform the original submitter of - the change. - -found bugnumber [ version ] - - Record that #bugnumber has been encountered in the given - version of the package to which it is assigned. - - The bug tracking system uses this information, in conjunction - with fixed versions recorded when closing bugs, to display - lists of bugs open in various versions of each package. It - considers a bug to be open when it has no fixed version, or - when it has been found more recently than it has been fixed. - - If no version is given, then the list of fixed versions for - the bug is cleared. This is identical to the behaviour of - reopen. - - This command will only cause a bug to be marked as not done - if no version is specified, or if the version being marked - found is equal to the version which was last marked - fixed. (If you are certain that you want the bug marked as - not done, use reopen in conjunction with found.) - - This command was introduced in preference to reopen because - it was difficult to add a version to that command's syntax - without suffering ambiguity. - -notfound bugnumber version - - Remove the record that #bugnumber was encountered in the - given version of the package to which it is assigned. - - This differs from closing the bug at that version in that the - bug is not listed as fixed in that version either; no - information about that version will be known. It is intended - for fixing mistakes in the record of when a bug was found. - -fixed bugnumber version - - Indicate that bug #bugnumber was fixed in the given version - of the package to which it is assigned. - - This does not cause the bug to be marked as closed, it merely - adds another version in which the bug was fixed. Use the - bugnumber-done address to close a bug and mark it fixed in a - particular version. - -notfixed bugnumber version - - Remove the record that bug #bugnumber has been fixed in the given version. - - This command is equivalent to found followed by notfound (the found removes the fixed at a particular version, and notfound removes the found.) - -submitter bugnumber originator-address | ! - - Changes the originator of #bugnumber to originator-address. - - If you wish to become the new originator of the report you can use the - ! shorthand or specify your own email address. - - While the reopen command changes the originator of other bugs merged - with the one being reopened, submitter does not affect merged bugs. - -forwarded bugnumber address - - Notes that bugnumber has been forwarded to the upstream maintainer at - address. This does not actually forward the report. This can be used to - change an existing incorrect forwarded-to address, or to record a new - one for a bug that wasn't previously noted as having been forwarded. - -notforwarded bugnumber - - Forgets any idea that bugnumber has been forwarded to any upstream - maintainer. If the bug was not recorded as having been forwarded then - this will do nothing. - -retitle bugnumber new-title - - Changes the title of a bug report to that specified (the default is the - Subject mail header from the original report. - - Unlike most of the other bug-manipulation commands when used on one of - a set of merged reports this will change the title of only the - individual bug requested, and not all those with which it is merged. - -severity bugnumber severity - - Set the severity level for bug report #bugnumber to severity. No - notification is sent to the user who reported the bug. - - Severities are critical, grave, serious, important, normal, minor, and - wishlist. - - For their meanings please consult the general developers' documentation - for the bug system. - -clone bugnumber [ new IDs ] - - The clone control command allows you to duplicate a bug report. It is - useful in the case where a single report actually indicates that - multiple distinct bugs have occured. \"New IDs\" are negative numbers, - separated by spaces, which may be used in subsequent control commands - to refer to the newly duplicated bugs. A new report is generated for - each new ID. - - Example usage: - - clone 12345 -1 -2 - reassign -1 foo - retitle -1 foo: foo sucks - reassign -2 bar - retitle -2 bar: bar sucks when used with foo - severity -2 wishlist - clone 123456 -2 - reassign -2 foo - retitle -2 foo: foo sucks - merge -1 -2 - - -merge bugnumber bugnumber ... - - Merges two or more bug reports. When reports are merged, opening, - closing, marking or unmarking as forwarded and reassigning any of the - bugs to a new package will have an identical effect on all of the - merged reports. - - Before bugs can be merged they must be in exactly the same state: - either all open or all closed, with the same forwarded-to upstream - author address or all not marked as forwarded, all assigned to the same - package or package(s) (an exact string comparison is done on the - package to which the bug is assigned), and all of the same severity. If - they don't start out in the same state you should use reassign, reopen - and so forth to make sure that they are before using merge. - - If any of the bugs listed in a merge command is already merged with - another bug then all the reports merged with any of the ones listed - will all be merged together. Merger is like equality: it is reflexive, - transitive and symmetric. - - Merging reports causes a note to appear on each report's logs; on the - WWW pages this is includes links to the other bugs. - - Merged reports are all expired simultaneously, and only when all of the - reports each separately meet the criteria for expiry. - -unmerge bugnumber - - Disconnects a bug report from any other reports with which it may have - been merged. If the report listed is merged with several others then - they are all left merged with each other; only their associations with - the bug explicitly named are removed. - - If many bug reports are merged and you wish to split them into two - separate groups of merged reports you must unmerge each report in one - of the new groups separately and then merge them into the required new - group. - - You can only unmerge one report with each unmerge command; if you want - to disconnect more than one bug simply include several unmerge commands - in your message. - -tags bugnumber [ + | - | = ] tag - - Sets a particular tag for the bug report #bugnumber to tag. No - notification is sent to the user who reported the bug. + means adding, - - means subtracting, and = means ignoring the current tags and setting - them afresh. The default action is adding. - - Available tags currently include patch, wontfix, moreinfo, - unreproducible, help, pending, fixed, security, upstream, fixed-upstream, - potato, woody, sarge, sarge-ignore, sid and experimental. - - For their meanings, consult the Control->Help->Tags menu. - -block bugnumber by bug ... - - Note that the fix for the first bug is blocked by the other - listed bugs. - -unblock bugnumber by bug ... - - Note that the fix for the first bug is no longer blocked by - the other listed bugs. - -close bugnumber - - Close bug report #bugnumber. - - A notification is sent to the user who reported the bug, but (in - contrast to mailing bugnumber-done@bugs) the text of the mail which - caused the bug to be closed is not included in that notification. The - maintainer who closes a report needs to ensure, probably by sending a - separate message, that the user who reported the bug knows why it is - being closed. The use of this command is therefore deprecated. - -package [ packagename ... ] - - Limits the following commands so that they will only apply to bugs - filed against the listed packages. You can list one or more packages. If - you don't list any packages, the following commands will apply to all - bugs. You're encouraged to use this as a safety feature in case you - accidentally use the wrong bug numbers. - - Example usage: - - package foo - reassign 123456 bar - - package bar - retitle 123456 bar: bar sucks - severity 123456 normal - - package - severity 234567 wishlist - -owner bugnumber address | ! - - Sets address to be the \"owner\" of #bugnumber. The owner of a bug - claims responsibility for fixing it and will receive all mail - regarding it. This is useful to share out work in cases where a - package has a team of maintainers. - - If you wish to become the owner of the bug yourself, you can use - the ! shorthand or specify your own email address. - -noowner bugnumber - - Forgets any idea that the bug has an owner other than the usual - maintainer. If the bug had no owner recorded then this will do - nothing. - -archive bugnumber - - Archives a bug that had been archived at some point in the - past but is currently not archived if the bug fulfills the - requirements for archival, ignoring time. - -unarchive bugnumber - - Unarchives a bug that was previously archived. Unarchival - should generally be coupled with reopen and found/fixed as - appropriate. Bugs that have been unarchived can be archived - using archive assuming the non-time based archival - requirements are met. - -quit -stop -thank... ---... - - Tells the control server to stop processing the message; the remainder - of the message can include explanations, signatures or anything else, - none of it will be detected by the control server. - -#... - - One-line comment. The # must be at the start of the line. - -Help text from http://www.debian.org/Bugs/server-control, Apr 22nd 2003. -Copyright 1999 Darren O. Benham, 1994-1997 Ian Jackson, - 1997 nCipher Corporation Ltd."))) - -;;;###autoload -(defun emacs-bts-control (action &optional arg) - "Contruct a message with ACTION command for control@debbugs.gnu.org. -Contructs a new control command line if called from within the message -being constructed. - -If prefix arg is provided, use the current buffer instead instead of -creating a new outgoing email message buffer. -The current buffer is also used if the current major mode matches one listed -in `debian-bts-control-modes-to-reuse'." - (interactive (list (completing-read "Command: " - debian-bts-control-alist nil nil) - current-prefix-arg)) - (let ((debian-bts-emailaddress "control@debbugs.gnu.org") - (debian-bts-emaildomain "debbugs.gnu.org") - (debian-bts-control-for-emacs t)) - (debian-bts-control action arg))) - -(provide 'debian-bts-control) - -;;; debian-bts-control.el ends here diff --git a/elisp/dpkg-dev-el/debian-changelog-mode.el b/elisp/dpkg-dev-el/debian-changelog-mode.el deleted file mode 100755 index 4d51654..0000000 --- a/elisp/dpkg-dev-el/debian-changelog-mode.el +++ /dev/null @@ -1,1814 +0,0 @@ -;;; debian-changelog-mode.el --- major mode for Debian changelog files. - -;; Copyright (C) 1996 Ian Jackson -;; Copyright (C) 1997 Klee Dienes -;; Copyright (C) 1999 Chris Waters -;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005 Peter S Galbraith -;; Copyright (C) 2006, 2007, 2009, 2010 Peter S Galbraith -;; -;; This file 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. -;; -;; debian-changelog-mode.el 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 your Debian installation, in /usr/share/common-licenses/GPL -;; If not, write to the Free Software Foundation, 51 Franklin Street, -;; Suite 500 Boston, MA 02110-1335, USA - -;;; Commentary: -;; -;; This is a major mode for Debian changelog files. The main features -;; are: -;; -;; - fontification (varies with upload urgency, etc). -;; - create a entry for a new version (guessing the version number). -;; - finalize a version with proper timestamp and syntax. -;; - add an entry from another file in the source package. -;; - interface with `debian-bug' to fetch list of bugs from the web, -;; read a bug report via browse-url or as email, close a bug with -;; thanks. -;; - closed bugs are fontified and clickable to view them via browse-url. -;; -;; The mode is entered automatically when editing a debian/changelog file. -;; See the menus "Bugs" and "Changelog" for commands or do `C-h m' to get -;; the list of keybindings. -;; -;; From other files in unpacked sources, do `M-x debian-changelog-add-entry' -;; to add an entry for that file in the changelog file. - -;;; History -;; -;; V1.00 30aug00 Peter S Galbraith <psg@debian.org> -;; - Prior version had no changelogs; starting one now. -;; This is the potato version plus extensions by Chris Waters (easymenu; -;; better menus, font-lock support). -;; V1.01 30aug00 Peter S Galbraith <psg@debian.org> -;; - debian-changelog-finalise-last-version: Use XEmacs' (user-mail-address) -;; function if variable user-mail-address is undefined. -;; Thanks to Robert Bihlmeyer <robbe@orcus.priv.at>, closes Bug#61524 -;; - debian-changelog-finalise-last-version: Takes account of some env vars -;; Thanks to Rafael Laboissiere <rafael@icp.inpg.fr>, closes Bug#61226 -;; - debian-changelog-close-bug: new command. -;; V1.02 23Feb01 Peter S Galbraith <psg@debian.org> -;; - Added `debian-changelog-suggest-version', a mechanisn for guessing -;; what the new version number should be. -;; Closes half of Bug#85412 -;; V1.03 23Feb01 Peter S Galbraith <psg@debian.org> -;; - Fixed `fill-paragraph' by tweaks to paragraph-start and -;; paragraph-separate variables. -;; Closes second half of Bug#85412 -;; V1.04 23Feb01 Peter S Galbraith <psg@debian.org> -;; - Added `debian-changelog-web-bugs' `debian-changelog-web-packages' -;; `debian-changelog-web-package' -;; V1.05 23Feb01 Peter S Galbraith <psg@debian.org> -;; - made `debian-changelog-suggest-package-name' more picky about finding -;; an acceptable name. -;; V1.06 28Feb01 Peter S Galbraith <psg@debian.org> -;; - Create customizable variables debian-changelog-full-name and -;; debian-changelog-mailing-address. -;; - Make debian-changelog-finalise-last-version use them. -;; V1.07 28Feb01 Peter S Galbraith <psg@debian.org> -;; - debian-changelog-suggest-version: Handle epochs! -;; closes: Bug#87964: dpkg-dev-el: does wrong things with epochs -;; V1.08 07Mar01 Peter S Galbraith <psg@debian.org> -;; debian-changelog-suggest-version: Handle package names with hyphens! -;; closes: #88589 and #88245 -;; V1.09 09Mar01 Peter S Galbraith <psg@debian.org> -;; debian-changelog-suggest-version: better regexps for version numbers -;; Created debian-changelog-increment-version -;; V1.10 10Mar01 Peter S Galbraith <psg@debian.org> -;; tweaks docs for debian-changelog-mode function concerning -;; add-log-mailing-address (now obsolete). -;; V1.11 24Apr01 Peter S Galbraith <psg@debian.org> -;; Add stuff to try to trim out obsolete "Local Variables:" block from -;; changelog files. -;; V1.12 24Apr01 Peter S Galbraith <psg@debian.org> -;; Modify font-lock code. closes: #93243 -;; V1.13 27Apr01 Peter S Galbraith <psg@debian.org> -;; Move code concerning local variables near beginning of file such that -;; `hack-local-variables' doesn't complain. -;; V1.14 30Apr01 Peter S Galbraith <psg@debian.org> -;; Add `critical' bug severity (see http://bugs.debian.org/94475) -;; V1.15 30Apr01 Peter S Galbraith <psg@debian.org> -;; Tweak font-locking bug number regexp to match dpkg-parsechangelog 1.9.1 -;; V1.16 30Apr01 Peter S Galbraith <psg@debian.org> -;; Added debian-changelog-web-bug (will bound to a mouse button later) -;; V1.17 30Apr01 Peter S Galbraith <psg@debian.org> -;; debian-changelog-increment-version: Handle 3.5.4.0 case (single digits) -;; closes: #95831 -;; V1.18 30Apr01 Peter S Galbraith <psg@debian.org> -;; Add mouse interface to web-bug (with green highlight). -;; V1.19 01May01 Peter S Galbraith <psg@debian.org> -;; Add imenu support as `History'. Bug: The history menu is empty when -;; point is on the (mouse-highlighted) bug number (using emacs-20.7). -;; V1.20 02May01 Peter S Galbraith <psg@debian.org> -;; Leave `mode: debian-changelog-mode' alone for native packages. -;; V1.21 02May01 Peter S Galbraith <psg@debian.org> -;; Fix empty History menu when on bug numbers. -;; V1.22 02May01 Peter S Galbraith <psg@debian.org> -;; Fontify version number (e.g. NMU in warning-face) -;; V1.23 02May01 Peter S Galbraith <psg@debian.org> -;; Bypass imenu-progress-message because it breaks byte-compilation (?) -;; V1.24 03May01 Peter S Galbraith <psg@debian.org> -;; Correct fix for imenu-progress-message macro (can't rely on variable -;; defined here for loading of imenu during byte-compilation). -;; V1.25 04May01 Peter S Galbraith <psg@debian.org> -;; Add `experimental' distribution. -;; V1.26 04May01 Peter S Galbraith <psg@debian.org> -;; Web site changed the URL for package searches: -;; http://cgi.debian.org/cgi-bin -> http://packages.debian.org/cgi-bin -;; V1.27 04May01 Peter S Galbraith <psg@debian.org> -;; Set new version to `experimental' when last one was set to that. -;; closes: #96260: Default to the same distribution as the previous release -;; V1.28 04May01 Peter S Galbraith <psg@debian.org> -;; Make `set-distribution' and `set-urgency' unavailable when changelog -;; is finalised (error at command line and menu grayed-out). -;; V1.29 04May01 Peter S Galbraith <psg@debian.org> -;; Add-to auto-mode-alist in case not using dpkg-dev-el package. -;; V1.30 09May01 Peter S Galbraith <psg@debian.org> -;; Fixed brain-damaged auto-mode-alist added in V1.29 (*blush*). -;; V1.31 28May01 Peter S Galbraith <psg@debian.org> -;; Fix typo (closes: #98577). -;; Add a message display after each call to browse-url. -;; V1.32 28May01 Peter S Galbraith <psg@debian.org> -;; - XEmacs21's easy-menu-define doesn't like :active. -;; - XEmacs21 need easy-menu-add call in mode setup. -;; - debian-changelog-setheadervalue: check at this lower level if finalised. -;; V1.33 29May01 Peter S Galbraith <psg@debian.org> -;; Fix History IMenu for XEmacs21 (it doesn't autoload -;; match-string-no-properties). -;; V1.34 29May01 Peter S Galbraith <psg@debian.org> -;; - debian-changelog-fontify-version: allow version numbers with many hyphens -;; - debian-changelog-suggest-version: heavy changes to deal with many hyphens -;; V1.35 06Jun01 Peter S Galbraith <psg@debian.org> -;; - patch from Brian Warner <warner@lothar.com> to make -;; debian-changelog-local-variables-maybe-remove-done really buffer-local. -;; - Change another occurrence of make-local-variable. -;; V1.36 11Jun01 Peter S Galbraith <psg@debian.org> -;; changed urgency "critical" to "emergency". -;; See http://lists.debian.org/debian-policy-0106/msg00095.html -;; V1.37 11Jun01 Peter S Galbraith <psg@debian.org> -;; debian-changelog-suggest-version: another tweak when upstream version -;; number contains hyphens (closes: #100162). -;; V1.38 13Jun01 Peter S Galbraith <psg@debian.org> -;; debian-changelog-suggest-version: peppered regexp-quote at various places -;; to match package names and version that contain regexp characters. -;; V1.39 13Jun01 Peter S Galbraith <psg@debian.org> -;; change (provide 'debian-changelog) to (provide 'debian-changelog-mode) -;; (closes: #100639) Thanks *again* Yann Dirson! -;; V1.40 22Jun01 Peter S Galbraith <psg@debian.org> -;; Changed urgency "emergency" back to "critical" (!) -;; See http://lists.debian.org/debian-policy-0106/msg00240.html -;; V1.41 04Jul01 Peter S Galbraith <psg@debian.org> -;; debian-changelog-finalised-p updated by Tommi Virtanen <tv@debian.org> -;; (closes: #102088) -;; V1.42 10Jul01 Peter S Galbraith <psg@debian.org> -;; debian-changelog-finalised-p: tweak regexp (really closes: #102088) -;; V1.43 25Jul01 Peter S Galbraith <psg@debian.org> -;; font-lock enforces 2 space exactly between email and date. -;; V1.44 26Jul01 Peter S Galbraith <psg@debian.org> -;; No conditions left to keep variable block (See bug #105889) -;; - Removed debian-changelog-package-native-p function. -;; - Removed debian-changelog-local-variables-email-p function. -;; - Removed debian-changelog-local-variables-remove-address function. -;; - Removed debian-changelog-local-variables-remove-mode function. -;; - Created debian-changelog-local-variables-remove function. -;; V1.45 15Aug01 Peter S Galbraith <psg@debian.org> -;; Bug list menu added (via wget). -;; V1.46 15Aug01 Roland Mas <lolando@debian.org> -;; One-character tweak to package name font-lock regexp. -;; V1.47 15Aug01 Peter S Galbraith <psg@debian.org> -;; debian-changelog-web-bug: bug fix when called from menu -;; V1.48 19Sep01 Brian Warner <warner@lothar.com> -;; - move to end of file before prompting for removal of local variables. -;; - remove global def of debian-changelog-local-variables-maybe-remove-done. -;; V1.49 22Nov01 Roland Mas <lolando@debian.org> -;; debian-changelog-suggest-version: tweak regexp for case of upstream -;; version number with a single character. -;; V1.50 30Nov01 Roland Mas <lolando@debian.org> -;; replaced debian-changelog.el by debian-changelog-mode.el -;; V1.51 24Jan02 Peter S Galbraith <psg@debian.org> -;; debian-changelog-web-bugs: return all bugs for the source package. -;; V1.52 07Feb02 Peter S Galbraith <psg@debian.org> -;; debian-changelog-build-bug-menu: return all bugs for the source package. -;; V1.53 13May02 Peter S Galbraith <psg@debian.org> -;; debian-changelog-mode: Add call to hack-local-variables since the "Local -;; variables:" block wasn't parsed otherwise. Strange. -;; V1.54 29May02 Peter S Galbraith <psg@debian.org> -;; s/font-latex-warning-face/debian-changelog-warning-face/ -;; Now that was a weird leftover from cut/paste! -;; V1.55 03June02 Peter S Galbraith <psg@debian.org> -;; fontify woody-proposed-updates as frozen. -;; V1.56 25July02 Peter S Galbraith <psg@debian.org> -;; debian-changelog-mode: Remove call to hack-local-variables added in V1.53 -;; since a "mode: debian-changelog" setting created an infinite loop. -;; The bug I attemped to fix in V1.53 occurred when debian-changelog-mode -;; was invoked using the debian-changelog-find-file-hook mecanism in -;; 50dpkg-dev-el.el. This invoked debian-changelog-mode which called -;; kill-all-local-variables, deleting our settings. To get around this, I -;; no longer call 'text-mode' and copied whatever setting we need from it -;; (because it also kill-all-local-variables). -;; closes: #153982. -;; V1.57 29July02 Peter S Galbraith <psg@debian.org> -;; debian-changelog-mode: Reinsert kill-all-local-variables removed in -;; last version. It's used by font-lock-mode to turn on font-lock-mode -;; when global-font-lock-mode is used. Since this kills the Local -;; Variables, the mode can no longer be entered late in the game as was -;; done in 50dpkg-dev-el.el by a find-file-hooks. Instead, use a -;; change-log-mode-hook which is less intrusive anyway. -;; V1.58 29July02 Peter S Galbraith <psg@debian.org> -;; debian-changelog-greater-than: new function to determine if a version -;; number is greater than another. Used it to incorporate some logic -;; for for better guessing of new version numbers for native packages to -;; fix bug #113964. -;; V1.59 02Aug2002 Peter S Galbraith <psg@debian.org> -;; Remove a bunch of code duplicated in debian-bug.el and load that file -;; instead. -;; debian-changelog-web-bugs -> debian-bug-web-bugs -;; debian-changelog-web-bug -> debian-bug-web-bug -;; debian-changelog-web-packages -> debian-bug-web-packages -;; debian-changelog-web-package -> debian-bug-web-package -;; dpkg-dev-el package should depend on versioned debbugs-el. -;; V1.60 15Aug2002 Peter S Galbraith <psg@debian.org> -;; Update list of possible distributions to upload to from list given -;; from http://bugs.debian.org/150466 (Closes: #156762) -;; V1.61 20Aug2002 Peter S Galbraith <psg@debian.org> -;; Prompt for confirmation and give *big* warning if user wants to set -;; the upload distribution to a -security one. See discussion on -;; http://bugs.debian.org/150466 -;; V1.62 20Aug2002 Peter S Galbraith <psg@debian.org> -;; V1.63 05Sep2002 Peter S Galbraith <psg@debian.org> -;; Fontify bugs on multiple-line closes: statements. Patch from -;; Frédéric Bothamy. (Closes: #159041) -;; V1.64 05Sep2002 Peter S Galbraith <psg@debian.org> -;; debian-changelog-suggest-version fix (Closes: #159643) -;; V1.65 05Sep2002 Peter S Galbraith <psg@debian.org> -;; - Stupid bug fix. s/debian-bug-bug-alist/debian-bug-alist/. -;; - Bug closing regexp enhancement from Roland Mas. -;; V1.66 24Oct2002 Peter S Galbraith <psg@debian.org> -;; - Add UNRELEASED distribution, patch from Junichi Uekawa -;; <dancer@netfort.gr.jp> with additional menu entry (Closes: #166163). -;; See bug #164470 for relevance and usage of UNRELEASED distribution. -;; V1.67 14Apr2003 Peter S Galbraith <psg@debian.org> -;; - Use debian-bug.el's debian-bug-open-alist (needs emacs-goodies-el 19.4) -;; V1.68 21Apr2003 Peter S Galbraith <psg@debian.org> -;; Byte-compilation cleanup. -;; V1.69 27Apr2003 Peter S Galbraith <psg@debian.org> -;; - defcustom debian-changelog-mode-hook added. (Closes: #190853) -;; - debian-changelog-add-version creates new version in empty file -;; (Closes: #191285) -;; V1.70 28May2003 Peter S Galbraith <psg@debian.org> -;; - Define (really) match-string-no-properties for XEmacs (Closes: #195181) -;; V1.71 02Sep2003 Peter S Galbraith <psg@debian.org> -;; - When closing a bug, insert bug title and thanks if bug info was -;; downloaded from the web. -;; V1.72 17Sep2003 Peter S Galbraith <psg@debian.org> -;; - Added browse-url link to `Best Practices for debian/changelog' in menu. -;; V1.73 04Nov2003 Peter S Galbraith <psg@debian.org> -;; - checkdoc fixed (not complete!) -;; - Add autoload tag. -;; V1.74 22Nov2003 Peter S Galbraith <psg@debian.org> -;; - Make `debian-changelog-add-entry' works from files in unpacked sources. -;; Thanks to Junichi Uekawa for suggesting it (Closes: #220641) -;; V1.75 27Nov2003 Peter S Galbraith <psg@debian.org> -;; - Add menu entry for "Archived Bugs for This Package", for -;; "Developer Page for This Package" and -;; "Developer Page for This Maintainer". -;; - Added function `debian-changelog-maintainer' and interactive command -;; `debian-changelog-web-developer-page'. -;; V1.76 17Dec2003 Peter S Galbraith <psg@debian.org> -;; - debian-changelog-setdistribution: Use `should-use-dialog-box-p' on XEmacs -;; (Closes: #224187) -;; V1.77 19Feb2004 Peter S Galbraith <psg@debian.org> -;; - Add file NEWS.Debian to auto-mode-alist. Thanks to Chris Lawrence -;; for suggesting it. (Closes: #233310) -;; V1.78 14Apr2004 Peter S Galbraith <psg@debian.org> -;; - debian-changelog-setdistribution: Dismiss warning window when setting -;; distribution to security. Thanks to Martin Schulze (Closes: #234730) -;; - Should mark line beginning with a tab as invalid. Fontified in warning -;; face. Thanks to Michel Daenzer (Closes: #235310). -;; V1.79 07June2005 Jari Aalto <jari.aalto@cante.net> -;; - fix byte-compilation warning about -;; `(fboundp (quote imenu))' called for effect (Closes: #309788) -;; V1.80 15Sep2005 Rafael Laboissiere <rafael@debian.org> -;; - Add debian-changelog-add-version-hook defaulting to -;; debian-changelog-add-new-upstream-release (Closes: #296725) -;; V1.81 19Sep2005 Peter S Galbraith <psg@debian.org> -;; - Add outline-regexp and C-cC-n and C-cC-p movement commands as -;; suggested by Romain Francoise <rfrancoise@debian.org> (Closes: #322994) -;; V1.82 05Sep2006 Peter Samuelson <peter@p12n.org> -;; - Add tilde support for upstream version numbers (Closes: #382514) -;; V1.83 11Oct2006 Luca Capello <luca@pca.it> -;; - Rename `debian-changelog-maintainer' to `debian-changelog-last-maintainer', -;; this is what the function really work on -;; - `debian-changelog-last-maintainer' now returns a list of "(NAME EMAIL)" -;; and not only EMAIL -;; - Add `debian-changelog-comaintainer-insert', which actually inserts the -;; co-maintainer name in the form "[ NAME ]" -;; - Add `debian-changelog-comaintainer', which checks if we're in a -;; co-maintenance, calling `debian-changelog-comaintainer-insert' -;; - Add co-maintenance support to `debian-changelog-unfinalise-last-version' -;; V1.84 14May2007 Peter S Galbraith <psg@debian.org> -;; - Use "date -R" instead of deprecated "822-date" -;; (Closes: #423142, #423155, #423828) -;; - Tighter regexp for finalisation string -;; V1.85 25Jul2007 Peter S Galbraith <psg@debian.org> -;; - Adapt patch from Luca Capello <luca@pca.it> for bug #431091 -;; V1.86 08Aug2007 Peter S Galbraith <psg@debian.org> -;; - auto-mode-alist for "/debian/*NEWS" files (Closes: #424779) -;; V1.87 02Sep2007 Peter S Galbraith <psg@debian.org> -;; - Implement pacakge lookup on http://packages.debian.org/ -;; See http://bugs.debian.org/87725 -;; - Patch from Luca Capello <luca@pca.it> to add keys to generate the -;; open bug alist. -;; V1.88 12Apr2008 Trent W. Buck <trentbuck@gmail.com> -;; - Generalize auto-mode-alist entry. -;; See http://bugs.debian.org/457047 -;; V1.89 23Feb2009 Jari.aalto@cante.net -;; - finalize date in UTC (User configurable) (Closes: #503700) -;; V1.90 24Oct2009 Rafael Laboissiere <rafael@debian.org> -;; - debian-changelog-close-bug does not work properly under XEmacs 21.4.21 -;; because the arguments passed to replace-in-string in the inline function -;; debian-chagelog--rris are in the wrong order. Closes: #476271 -;; V1.91 12Nov2009 Peter S Galbraith <psg@debian.org> -;; Updated URL for "Best practices". -;; V1.92 27Apr2010 Peter S Galbraith <psg@debian.org> -;; Invoke `debian-bug-build-bug-menu' with SOURCE arg set to t. -;; Needs debian-el 33.2 -;; V1.93 10May2010 Peter S Galbraith <psg@debian.org> -;; Fix typo (Closes: #580818) -;; V1.94 28Jul2010 Kevin Ryde <user42@zip.com.au> -;; Simplify auto-mode-alist (Closes: #587924) -;; V1.95 01Dec2013 Matt Kraai <kraai@debian.org> -;; Change the default urgency to medium (Closes: #731105) -;; V1.96 06Nov2016 Guido Günther <agx@sigxcpu.org> -;; Bug fix: "improve handling of {old-, }stable-proposed-updates", thanks -;; to Guido Gunther (Closes: #818010). -;; V1.97 06Nov2016 Pierre Carrier (on 2013-07-04) -;; https://bugs.launchpad.net/ubuntu/+source/emacs-goodies-el/+bug/1197870 -;; Bug fix #803767 debian-changelog-mode: don't rely on external date -;; See also https://github.com/pcarrier/debian-changelog-mode/commit/285d4cc938468fd3d7d74584da7981705727fbab -;; V1.98 06Nov2016 Kumar Appaiah <a.kumar@alumni.iitm.ac.in> -;; highlight backports (Closes: #708317) - -;;; Acknowledgements: (These people have contributed) -;; Roland Rosenfeld <roland@debian.org> -;; James LewisMoss <dres@ioa.com> -;; Rafael Laboissiere <rafael@icp.inpg.fr> -;; Brian Warner <warner@lothar.com> -;; Yann Dirson <dirson@debian.org> - -;;; Code: - -(defgroup debian-changelog nil "Debian changelog maintenance" - :group 'tools - :prefix "debian-changelog-") - -(defgroup debian-changelog-faces nil - "Faces for fontifying text in debian-changelog." - :prefix "debian-changelog-" - :group 'debian-changelog) - -(defcustom debian-changelog-full-name (or (getenv "DEBFULLNAME") - (user-full-name)) - "*Full name of user, for inclusion in Debian changelog headers. -This defaults to the contents of environment variable DEBFULLNAME -or else to the value returned by the function `user-full-name'." - :group 'debian-changelog - :type 'string) - -(defcustom debian-changelog-mailing-address - (or (getenv "DEBEMAIL") - (getenv "EMAIL") - (and (boundp 'user-mail-address) user-mail-address) - (and (fboundp 'user-mail-address) (user-mail-address))) - "*Electronic mail address of user, for inclusion in Debian changelog headers. -This defaults to the value of (in order of precedence): - Contents of environment variable DEBEMAIL, - Contents of environment variable EMAIL, - Value of `user-mail-address' variable, - Value returned by the `user-mail-address' function." - :group 'debian-changelog - :type 'string) - -(defcustom debian-changelog-allowed-distributions - '("unstable" - "testing" - "testing-security" - "stable" - "stable-security" - "stable-proposed-updates" - "oldstable-security" - "oldstable-proposed-updates" - "experimental" - "UNRELEASED" ) - "*Allowed values for distribution." - :group 'debian-changelog - :type '(repeat string)) - -(defcustom debian-changelog-local-variables-maybe-remove t - "*Ask to remove obsolete \"Local Variables:\" block from changelog. -This is done only under certain conditions." - :group 'debian-changelog - :type 'boolean) - -(defcustom debian-changelog-highlight-mouse-t t - "*Use special overlay for bug numbers, defining mouse-3 to web interface." - :group 'debian-changelog - :type 'boolean) - -(defcustom debian-changelog-use-imenu (fboundp 'imenu-add-to-menubar) - "*Use imenu package for debian-changelog-mode? -If you do not wish this behaviour, reset it in your .emacs file like so: - - (setq debian-changelog-use-imenu nil)" - :group 'debian-changelog - :type 'boolean) - -;; This solves the consistency problem with `debian-changelog-close-bug' -;; as per bug #431091 -(defcustom debian-changelog-close-bug-statement "(Closes: #%s)." - "The text to be inserted to close a bug. `%s' is replaced by -the bug number." - :group 'debian-changelog - :type 'string) - -(defcustom debian-changelog-mode-hook nil - "Normal hook run when entering Debian Changelog mode." - :group 'debian-changelog - :type 'hook - :options '(turn-on-auto-fill flyspell-mode)) - -(defcustom debian-changelog-add-version-hook - (list 'debian-changelog-add-new-upstream-release) - "Hooks run just before inserting the signature separator \"--\" in a -new version in debian/changelog." - :group 'debian-changelog - :type 'hook) - -(defcustom debian-changelog-date-utc-flag nil - "If non-nil, return date string in UTC when finalizing entry. -See function `debian-changelog-date-string'." - :group 'debian-changelog - :type 'boolean) - -;; This function is from emacs/lisp/calendar/icalendar.el, -;; necessary to replace "%s" with the bug number in -;; `debian-changelog-close-bug-statement' -(defsubst debian-changelog--rris (&rest args) - "Replace regular expression in string. -Pass ARGS to `replace-regexp-in-string' (GNU Emacs) or to -`replace-in-string' (XEmacs)." - ;; XEmacs: - (if (fboundp 'replace-in-string) - (save-match-data ;; apparently XEmacs needs save-match-data - ;; and arguments are in different order. - ;; Patch from Rafael Laboissiere <rafael@debian.org> - ;; Closes: #476271 - (apply 'replace-in-string (list (nth 2 args) (nth 0 args) (nth 1 args)))) - ;; Emacs: - (apply 'replace-regexp-in-string args))) - -(defvar debian-changelog-local-variables-maybe-remove-done nil - "Internal flag so we prompt only once.") - -(autoload 'debian-bug-web-bug "debian-bug") -(autoload 'debian-bug-web-bugs "debian-bug") -(autoload 'debian-bug-web-packages "debian-bug") -(autoload 'debian-bug-web-package "debian-bug") -(autoload 'debian-bug-bug-menu-init "debian-bug") -(autoload 'debian-bug-web-this-bug-under-mouse "debian-bug") -(autoload 'debian-bug-web-developer-page "debian-bug") -(defvar debian-bug-open-alist) - - -(require 'add-log) -(require 'easymenu) -(eval-when-compile - (require 'cl)) - -;; XEmacs21.1 compatibility -- from XEmacs's apel/poe.el -(unless (fboundp 'match-string-no-properties) - (defun match-string-no-properties (num &optional string) - "Return string of text matched by last search, without text properties. -NUM specifies which parenthesized expression in the last regexp. - Value is nil if NUMth pair didn't match, or there were less than NUM pairs. -Zero means the entire text matched by the whole regexp or whole string. -STRING should be given if the last search was by `string-match' on STRING." - (if (match-beginning num) - (if string - (let ((result - (substring string (match-beginning num) (match-end num)))) - (set-text-properties 0 (length result) nil result) - result) - (buffer-substring-no-properties (match-beginning num) - (match-end num)))))) -;; -;; Clean up old "Local Variables:" entries -;; Peter Galbraith - -;; **Important note** -;; -;; If we get the following warning: -;; -;; File local-variables error: (error "Local variables entry is missing the prefix") -;; -;; when installing the dpkg-dev-el package, it's because the command -;; (hack-local-variables) from files.el is bailing on all the "Local -;; Variables:" strings in this file. The simplest solution is to keep all -;; occurrences of this string before the last 3000 characters of the file, -;; where `hack-local-variables' starts looking: - -;; First, I made the add-log-mailing-address variable obsolete but still -;; left the "mode:" line in the variable block for Debian native packages -;; because it was impossible to tell what they were from the installed -;; changelog.gz name. In bug #105889, I came up with code to stick in -;; /etc/emacs/site-start.d/50dpkg-dev-el.el to figure that out in a -;; find-file-hooks hook. So now the variable block is completely obsolete. -(defun debian-changelog-local-variables-maybe-remove () - "Ask to remove local variables block if buffer not read-only." - (interactive) - (if (or debian-changelog-local-variables-maybe-remove-done - buffer-read-only) - nil - (setq debian-changelog-local-variables-maybe-remove-done t) - (if (debian-changelog-local-variables-exists-p) - (save-excursion - (goto-char (point-max)) ; local vars are always at end - (if (yes-or-no-p - "Remove obsolete \"local variables:\" from changelog? ") - (debian-changelog-local-variables-remove)))))) - -(defun debian-changelog-local-variables-exists-p () - "Return t if package has a \"Local Variables:\" block." - (save-excursion - (let ((case-fold-search t)) - (goto-char (point-max)) - (and (re-search-backward "^local variables:" nil t) - (or (re-search-forward "add-log-mailing-address:" nil t) - (re-search-forward "mode: debian-changelog" nil t)))))) - -(defun debian-changelog-local-variables-remove () - "Remove `add-log-mailing-address' entry from local variables block." - (save-excursion - (let ((case-fold-search t)) - (goto-char (point-max)) - ;; Remove add-log-mailing-address: line if it exists - (if (and (re-search-backward "^local variables:" nil t) - (re-search-forward "add-log-mailing-address: .+\n" nil t)) - (delete-region (match-beginning 0)(match-end 0))) - (goto-char (point-max)) - ;; Remove "mode: debian-changelog" line if it exists - (if (and (re-search-backward "^local variables:" nil t) - (re-search-forward "mode: debian-changelog.*\n" nil t)) - (delete-region (match-beginning 0)(match-end 0))) - (goto-char (point-max)) - ;; Remove empty variable block if it exists - (if (re-search-backward "^local variables: *\nend:" nil t) - (delete-region (match-beginning 0)(match-end 0)))))) - -;; -;; internal functions: getheadervalue and setheadervalue both use a -;; regexp to probe the changelog entry for specific fields. - -;; warning: if used with a "re" that doesn't have at least one group, -;; the results will be unpredictable (to say the least). - -(defun debian-changelog-setheadervalue (re str) - (if (eq (debian-changelog-finalised-p) t) - (error (substitute-command-keys "most recent version has been finalised - use \\[debian-changelog-unfinalise-last-version] or \\[debian-changelog-add-version]"))) - (let ((lineend (save-excursion (end-of-line)(point)))) - (save-excursion - (goto-char (point-min)) - (if (re-search-forward re lineend t) - (let ((a (match-beginning 1)) - (b (match-end 1))) - (goto-char a) - (delete-region a b) - (insert str)))))) - -(defun debian-changelog-getheadervalue (re) - (let ((lineend (save-excursion (end-of-line) (point)))) - (save-excursion - (goto-char (point-min)) - (re-search-forward re lineend) - (buffer-substring-no-properties (match-beginning 1) (match-end 1))))) - -;; -;; some get/set functions for specific fields -;; (Chris Waters) - -(defun debian-changelog-seturgency (val) - (debian-changelog-setheadervalue "\\;[^\n]* urgency=\\(\\sw+\\)" val)) -(defun debian-changelog-geturgency () - (debian-changelog-getheadervalue "\\;[^\n]* urgency=\\(\\sw+\\)")) -(defun debian-changelog-getdistribution () - (debian-changelog-getheadervalue ") \\(.*\\)\\;")) -(defvar last-nonmenu-event) -(defun debian-changelog-setdistribution (val) - (if (not (string-match "^.*security" val)) - (debian-changelog-setheadervalue ") \\(.*\\)\\;" val) - (cond - ((or (and (fboundp 'should-use-dialog-box-p) - (should-use-dialog-box-p)) - (and window-system - (equal last-nonmenu-event '(menu-bar)) - use-dialog-box)) - (if (y-or-n-p - (concat - "Warning, although the {oldstable,stable,testing}-security -distribution exists it should not be used unless you are a -member of the security team. Please don't upload to it if you -are not 150% sure that your package is suitable. In case of -doubt, please send the files to team@security.debian.org via -mail instead. - -Upload to " val " anyway?")) - (debian-changelog-setheadervalue ") \\(.*\\)\\;" val))) - (t - (let ((window-config (current-window-configuration))) - (with-output-to-temp-buffer "*Help*" - (princ (concat - "Warning, although the {oldstable,stable,testing}-security -distribution exists it should not be used unless you are a -member of the security team. Please don't upload to it if you -are not 150% sure that your package is suitable. In case of -doubt, please send the files to team@security.debian.org via -mail instead. - -Upload to " val " anyway?"))) - (if (y-or-n-p (format "Upload to %s anyway? " val)) - (debian-changelog-setheadervalue ") \\(.*\\)\\;" val)) - (set-window-configuration window-config)))))) - -;; -;; keymap table definition -;; - -(autoload 'outline-next-visible-heading "outline") -(autoload 'outline-prev-visible-heading "outline") - -(defvar debian-changelog-mode-map nil - "Keymap for Debian changelog major mode.") -(if debian-changelog-mode-map - nil - (setq debian-changelog-mode-map (make-sparse-keymap)) - (define-key debian-changelog-mode-map "\C-c\C-a" - 'debian-changelog-add-entry) - (define-key debian-changelog-mode-map "\C-c\C-o" - 'debian-changelog-build-open-bug-list) - (define-key debian-changelog-mode-map "\C-c\C-b" - 'debian-changelog-close-bug) - (define-key debian-changelog-mode-map "\C-c\C-f" - 'debian-changelog-finalise-last-version) - (define-key debian-changelog-mode-map "\C-c\C-c" - 'debian-changelog-finalise-and-save) - (define-key debian-changelog-mode-map "\C-c\C-v" - 'debian-changelog-add-version) - (define-key debian-changelog-mode-map "\C-c\C-d" - 'debian-changelog-distribution) - (define-key debian-changelog-mode-map "\C-c\C-u" - 'debian-changelog-urgency) - (define-key debian-changelog-mode-map "\C-c\C-e" - 'debian-changelog-unfinalise-last-version) - (define-key debian-changelog-mode-map "\C-c\C-n" - 'outline-next-visible-heading) - (define-key debian-changelog-mode-map "\C-c\C-p" - 'outline-previous-visible-heading)) - - -;; -;; menu definition (Chris Waters) -;; - -(defvar debian-changelog-is-XEmacs - (and - (not (null (save-match-data (string-match "XEmacs\\|Lucid" emacs-version)))) - (= 21 emacs-major-version))) - -(cond - (debian-changelog-is-XEmacs -(easy-menu-define - debian-changelog-menu debian-changelog-mode-map "Debian Changelog Mode Menu" - '("Changelog" - ["New Version" debian-changelog-add-version (debian-changelog-finalised-p)] - ["Add Entry" debian-changelog-add-entry - (not (debian-changelog-finalised-p))] - ["Build Open Bug List" debian-changelog-build-open-bug-list] - ["Close Bug" debian-changelog-close-bug - (not (debian-changelog-finalised-p))] - "--" - ("Set Distribution" - ["unstable" (debian-changelog-setdistribution "unstable") t] - ("--") - ["testing" (debian-changelog-setdistribution "testing") t] - ["testing-security" (debian-changelog-setdistribution "testing-security") t] - ("--") - ["stable" (debian-changelog-setdistribution "stable") t] - ["stable-security" (debian-changelog-setdistribution "stable-security") t] - ["stable-proposed-updates" (debian-changelog-setdistribution "stable-proposed-updates") t] - ("--") - ["oldstable-security" (debian-changelog-setdistribution "oldstable-security") t] - ["oldstable-proposed-updates" (debian-changelog-setdistribution "oldstable-proposed-updates") t] - ("--") - ["experimental" (debian-changelog-setdistribution "experimental") t] - ["UNRELEASED" (debian-changelog-setdistribution "UNRELEASED") t]) - ("Set Urgency" - ["low" (debian-changelog-seturgency "low") t] - ["medium" (debian-changelog-seturgency "medium") t] - ["high" (debian-changelog-seturgency "high") t] - ["critical" (debian-changelog-seturgency "critical") t]) - "--" - ["Unfinalise" debian-changelog-unfinalise-last-version - (debian-changelog-finalised-p)] - ["Finalise" debian-changelog-finalise-last-version - (not (debian-changelog-finalised-p))] - ["Finalise+Save" debian-changelog-finalise-and-save - (not (debian-changelog-finalised-p))] - "--" - "Web View" - ["Best Practices" (browse-url "http://www.debian.org/doc/developers-reference/best-pkging-practices.html#bpp-debian-changelog") t] - ["Bugs for This Package" (debian-bug-web-bugs) t] - ["Archived Bugs for This Package" (debian-bug-web-bugs t) t] - ["Bug Number..." (debian-bug-web-bug) t] - ["Package Info" (debian-bug-web-packages) t] -;; ("Package web pages..." -;; ["stable" (debian-bug-web-package "stable") t] -;; ["testing" (debian-bug-web-package "testing") t] -;; ["unstable" (debian-bug-web-package "unstable") t]) - ["Developer Page for This Package" (debian-bug-web-developer-page) t] - ["Developer Page for This Maintainer" (debian-changelog-web-developer-page) - t] - "--" - ["Customize" (customize-group "debian-changelog") (fboundp 'customize-group)]))) - (t -(easy-menu-define - debian-changelog-menu debian-changelog-mode-map "Debian Changelog Mode Menu" - '("Changelog" - ["New Version" debian-changelog-add-version (debian-changelog-finalised-p)] - ["Add Entry" debian-changelog-add-entry - (not (debian-changelog-finalised-p))] - ["Build Open Bug List" debian-changelog-build-open-bug-list] - ["Close Bug" debian-changelog-close-bug - (not (debian-changelog-finalised-p))] - "--" - ("Set Distribution" :active (not (debian-changelog-finalised-p)) - ["unstable" (debian-changelog-setdistribution "unstable") t] - ("--") - ["testing" (debian-changelog-setdistribution "testing") t] - ["testing-security" (debian-changelog-setdistribution "testing-security") t] - ("--") - ["stable" (debian-changelog-setdistribution "stable") t] - ["stable-security" (debian-changelog-setdistribution "stable-security") t] - ["stable-proposed-updates" (debian-changelog-setdistribution "stable-proposed-updates") t] - ("--") - ["oldstable-security" (debian-changelog-setdistribution "oldstable-security") t] - ["oldstable-proposed-updates" (debian-changelog-setdistribution "oldstable-proposed-updates") t] - ("--") - ["experimental" (debian-changelog-setdistribution "experimental") t] - ["UNRELEASED" (debian-changelog-setdistribution "UNRELEASED") t]) - ("Set Urgency" :active (not (debian-changelog-finalised-p)) - ["low" (debian-changelog-seturgency "low") t] - ["medium" (debian-changelog-seturgency "medium") t] - ["high" (debian-changelog-seturgency "high") t] - ["critical" (debian-changelog-seturgency "critical") t]) - "--" - ["Unfinalise" debian-changelog-unfinalise-last-version - (debian-changelog-finalised-p)] - ["Finalise" debian-changelog-finalise-last-version - (not (debian-changelog-finalised-p))] - ["Finalise+Save" debian-changelog-finalise-and-save - (not (debian-changelog-finalised-p))] - "--" - "Web View" - ["Best Practices" (browse-url "http://www.debian.org/doc/developers-reference/ch-best-pkging-practices.en.html#s-bpp-debian-changelog") t] - ["Bugs for This Package" (debian-bug-web-bugs) t] - ["Archived Bugs for This Package" (debian-bug-web-bugs t) t] - ["Bug Number..." (debian-bug-web-bug) t] - ["Package Info" (debian-bug-web-packages) t] - ("Package web pages..." - ["stable" (debian-bug-web-package "stable") t] - ["testing" (debian-bug-web-package "testing") t] - ["unstable" (debian-bug-web-package "unstable") t]) - ["Developer Page for This Package" (debian-bug-web-developer-page) t] - ["Developer Page for This Maintainer" (debian-changelog-web-developer-page) - t] - "--" - ["Customize" (customize-group "debian-changelog") (fboundp 'customize-group)])))) - -;; -;; interactive function to add a new line to the changelog -;; - -;;;###autoload -(defun debian-changelog-add-entry () - "Add a new change entry to a debian-style changelog. -If called from buffer other than a debian/changelog, this will search -for the debian/changelog file to add the entry to." - (interactive) - (if (string-match ".*/debian/changelog" (buffer-file-name)) - (debian-changelog-add-entry-plain) - (debian-changelog-add-entry-file))) - -(defun debian-changelog-add-entry-plain () - "Add a new change entry to a debian-style changelog." - (if (eq (debian-changelog-finalised-p) t) - (error (substitute-command-keys "most recent version has been finalised - use \\[debian-changelog-unfinalise-last-version] or \\[debian-changelog-add-version]"))) - (goto-char (point-min)) - (re-search-forward "\n --") - (backward-char 5) - (if (prog1 (looking-at "\n") (forward-char 1)) - nil - (insert "\n")) - (insert " * ") - (save-excursion (insert "\n"))) - -(defun debian-changelog-add-entry-file () - "Add an entry for current file in debian/changelog." - (let* ((this-file (buffer-file-name)) - (directory (if (not this-file) - (error "This buffer has no file associated to it") - (directory-file-name (file-name-directory this-file)))) - (filename (file-name-nondirectory this-file)) - (success)) - (while directory - (let ((changelog (expand-file-name "debian/changelog" directory))) - (cond - ((file-readable-p changelog) - (debian-changelog-add-entry-file-specified changelog filename) - (setq directory nil - success t)) - (t - (if (not (string-match "\\(.*\\)/\\([^/]+\\)$" directory)) - (setq directory nil) - (setq filename (concat (match-string 2 directory) "/" filename) - directory (match-string 1 directory))))))) - (if (not success) - (error "debian directory not found")))) - -(defun debian-changelog-add-entry-file-specified (changelog filename) - "Insert an entry in debian CHANGELOG file for FILENAME." - (interactive) - (find-file changelog) - (if (eq (debian-changelog-finalised-p) t) - (let ((action (capitalize - (read-string - "Most recent version is finalised, [u]nfinalize or [a]dd new version? ")))) - (if (not (string-match "^[uU]" action)) - (debian-changelog-add-version) - (debian-changelog-unfinalise-last-version) - (debian-changelog-add-entry-plain))) - (debian-changelog-add-entry-plain)) - (insert filename ": ")) - -;; -;; interactive function to close bugs by number. (Peter Galbraith) -;; - -(defvar debian-changelog-close-bug-takes-arg t - "A compatibility flag for debian-bug.el.") - -(defun debian-changelog-build-open-bug-list () - "Generate open bugs list, i.e. `debian-bug-open-alist'." - (interactive) - (debian-bug-build-bug-menu (debian-changelog-suggest-package-name) t)) - -(defun debian-changelog-close-bug (bug-number) - "Add a new change entry to close a BUG-NUMBER." - (interactive - (progn - (if (eq (debian-changelog-finalised-p) t) - (error (substitute-command-keys "most recent version has been finalised - use \\[debian-changelog-unfinalise-last-version] or \\[debian-changelog-add-version]"))) - (list (completing-read "Bug number to close: " - debian-bug-open-alist nil nil)))) - (if (not (string-match "^[0-9]+$" bug-number)) - (error "The bug number should consists of only digits")) - (debian-changelog-add-entry) - (cond - ((and debian-bug-open-alist - (assoc bug-number debian-bug-open-alist)) - (insert (cadr (assoc bug-number debian-bug-open-alist))) - (fill-paragraph nil)) - (t - (save-excursion - (insert " " (debian-changelog--rris - "%s" bug-number debian-changelog-close-bug-statement))) - (message "Enter a brief description of what was done here.")))) - -;; -;; interactive functions to set urgency and distribution -;; - -(defun debian-changelog-distribution () - "Delete the current distribution and prompt for a new one." - (interactive) - (if (eq (debian-changelog-finalised-p) t) - (error (substitute-command-keys "most recent version has been finalised - use \\[debian-changelog-unfinalise-last-version] or \\[debian-changelog-add-version]"))) - (let ((str (completing-read - "Select distribution: " - debian-changelog-allowed-distributions - nil t nil))) - (if (not (equal str "")) - (debian-changelog-setdistribution str)))) - -(defun debian-changelog-urgency () - "Delete the current urgency and prompt for a new one." - (interactive) - (if (eq (debian-changelog-finalised-p) t) - (error (substitute-command-keys "most recent version has been finalised - use \\[debian-changelog-unfinalise-last-version] or \\[debian-changelog-add-version]"))) - (let ((str (completing-read - "Select urgency: " - '(("low" 1) ("medium" 2) ("high" 3) ("critical" 4)) - nil t nil))) - (if (not (equal str "")) - (debian-changelog-seturgency str)))) - -;; -;; internal function: test if changelog has been finalized or not -;; New version by Tommi Virtanen <tv@debian.org> -;; Sun, 24 Jun 2001 16:03:01 UTC; Debian bug #102088 -;; - -;; regexp tweaked by psg, Tue Jul 10 15:29:54 EDT 2001 - -(defun debian-changelog-finalised-p () - "Check whether the most recent debian-style changelog entry is finalised yet. -\(ie, has a maintainer name and email address and a release date." - (save-excursion - (goto-char (point-min)) - (or (re-search-forward "\n\\S-" (point-max) t) - (goto-char (point-max))) - (if (re-search-backward "\n --" (point-min) t) - (forward-char 4) - ;;(beginning-of-line) - ;;(insert " --\n\n") - ;;(backward-char 2) - ) - (cond - ((looking-at - "[ \n]+\\S-[^\n\t]+\\S- <[^ \t\n<>]+> +\\S-[^\t\n]+\\S-[ \t]*\n") - t) - ((looking-at "[ \t]*\n") - nil) - (t - "finalisation line has bad format (not ` -- maintainer <email> date')")))) -;; -;; interactive functions to add new versions (whole new sections) -;; to changelog. -;; - -(defvar debian-changelog-new-upstream-release-p nil) - -(defun debian-changelog-add-new-upstream-release () - "Normal hook for adding \"new upstream release\" entry to changelog." - (when debian-changelog-new-upstream-release-p - (insert "New upstream release") - (setq debian-changelog-new-upstream-release-p nil))) - -(defun debian-changelog-add-version () - "Add a new version section to a debian-style changelog file. -If file is empty, create initial entry." - (interactive) - (if (not (= (point-min)(point-max))) - (let ((f (debian-changelog-finalised-p))) - (and (stringp f) (error f)) - (or f (error "Previous version not yet finalised")))) - (goto-char (point-min)) - (let ((pkg-name (or (debian-changelog-suggest-package-name) - (read-string "Package name: "))) - (version (or (debian-changelog-suggest-version) - (read-string "New version (including any revision): ")))) - (if (debian-changelog-experimental-p) - (insert pkg-name " (" version ") experimental; urgency=medium\n\n * ") - (insert pkg-name " (" version ") " (car debian-changelog-allowed-distributions) "; urgency=medium\n\n * ")) - (run-hooks 'debian-changelog-add-version-hook) - (save-excursion (insert "\n\n --\n\n")))) - -(defun debian-changelog-experimental-p () -;; Peter S Galbraith, 04 May 2001 - "Return t if last upload is to experimental." - (save-excursion - (goto-char (point-min)) - (looking-at "\\sw.* (.+).* \\(experimental\\)"))) - -(defun debian-changelog-suggest-package-name () -;; Peter S Galbraith, 23 Feb 2001 - "Return package name from first line of the changelog, or nil." - (save-excursion - (goto-char (point-min)) - (if (looking-at - "\\(\\S-+\\) +(\\([^()\n\t-]+\\)\\(-\\([^()]+\\)\\)?\\() +[^\n]*\\)") - (match-string-no-properties 1)))) - -(defun debian-changelog-greater-than (vsn1 vsn2) - "Return t if VSN1 is greater than VSN2." - (save-excursion - (let ((tmp-buffer (get-buffer-create - " *debian-changelog-mode-temp-buffer*"))) - (set-buffer tmp-buffer) - (unwind-protect - (progn - (let ((mesg (call-process "dpkg" nil '(t nil) nil - "--compare-versions" vsn1 "gt" vsn2))) - (if (equal mesg 0) - t - nil))) - (kill-buffer tmp-buffer))))) - -(defun debian-changelog-suggest-version () -;; Peter S Galbraith, 23 Feb 2001 - "Return a suggested new version number to use for this changelog, or nil." - (save-excursion - (goto-char (point-min)) - (let ((findmatch t)) - (cond - ((looking-at -;;; The following is not strictly correct. The upstream version may actually -;;; contain a hyphen if a debian version number also exists, making two hyphens -;;; I'm also assuming it begins with a digit, which is not enforced - "\\(\\S-+\\) +(\\([0-9]:\\)?\\([0-9][0-9a-zA-Z.+:~]*\\)\\(-\\([0-9a-zA-Z.+~]+\\)\\)?\\() +[^\n]*\\)")) - - ;; No match... - ;; Check again for multiple hyphens, and adjust match-data if found - ;; to leave only the bit past the last hyphen as the debian version - ;; number. - ((looking-at - "\\(\\S-+\\) +(\\([0-9]:\\)?\\([0-9][0-9a-zA-Z.+:~]*\\)\\(-\\([0-9a-zA-Z.+~]+\\)\\)*\\() +[^\n]*\\)") - ;; We have a hit. Adjust match-data... - (goto-char (match-end 5)) - (skip-chars-backward "0-9a-zA-Z.+~") - (let ((deb-vsn-beg (point)) - (ups-vsn-end (1- (point)))) - (store-match-data - (list - (match-beginning 0)(match-end 0) - (match-beginning 1)(match-end 1) - (match-beginning 2)(match-end 2) - (match-beginning 3) ups-vsn-end - (match-beginning 4)(match-end 4) - deb-vsn-beg (match-end 5) - (match-beginning 6)(match-end 6))))) - (t - (setq findmatch nil))) - - -;;; match 1: package name -;;; match 2: epoch, if it exists -;;; match 3: upstream version number -;;; match 4: debian version number exists if matched -;;; match 5: debian version number -;;; match 6: rest of string - (if (not findmatch) - nil - (let ((pkg-name (match-string-no-properties 1)) - (epoch (or (match-string-no-properties 2) "")) - (upstream-vsn (match-string-no-properties 3)) - (debian-vsn (match-string-no-properties 5))) - ;;debug (message "name: %s epoch: %s version: %s debian: %s" pkg-name epoch upstream-vsn debian-vsn)))) - - (cond - ;; Debian vsn exists + Old upstream version matches current one. - ;; -> Increment Debian version... - ((and debian-vsn - (string-match - (regexp-quote (concat "/" pkg-name "-" upstream-vsn "/debian/changelog")) - buffer-file-name)) - (concat epoch upstream-vsn "-" - (debian-changelog-increment-version debian-vsn))) - - ;; Same as above, but more general in case directory name doesn't - ;; match package name. -> Increment Debian version... - ((and debian-vsn - (string-match - (concat "-" (regexp-quote upstream-vsn) "/debian/changelog") - buffer-file-name)) - (concat epoch upstream-vsn "-" - (debian-changelog-increment-version debian-vsn))) - - ;; Debian vsn exists but old upstream version doesn't match new one. - ;; -> Use new upstream version with "-1" debian version. -;;;FIXME: I should perhaps check that the directory name version is higher -;;;than that currently in changelog. - ((and debian-vsn - (string-match (concat - "/" - (regexp-quote pkg-name) - "-\\([0-9][0-9a-zA-Z.+~-]+\\)/debian/changelog") - buffer-file-name)) - (setq debian-changelog-new-upstream-release-p t) - (concat epoch (match-string 1 buffer-file-name) "-1")) - - ;; Same as above, but more general in case directory name doesn't - ;; match package name. - ;; -> Use new upstream version with "-1" debian version. - ((and debian-vsn - (string-match - (concat "-\\([0-9][0-9a-zA-Z.+~-]+\\)/debian/changelog") - buffer-file-name)) - (setq debian-changelog-new-upstream-release-p t) - (concat epoch (match-string 1 buffer-file-name) "-1")) - - ;; Debian vsn exists, but directory name has no version - ;; -> increment Debian vsn (no better guess) - (debian-vsn - (concat epoch upstream-vsn "-" - (debian-changelog-increment-version debian-vsn))) - - ;;; No Debian version number... - - ;; No debian version number and version number from changelog - ;; already greater than from directory name. - ((and (not debian-vsn) - (not (string-match - (concat "/" (regexp-quote pkg-name) "-" - (regexp-quote upstream-vsn) "/debian/changelog") - buffer-file-name)) - (string-match (concat "/" (regexp-quote pkg-name) - "-\\([0-9a-zA-Z.+~]+\\)/debian/changelog") - buffer-file-name) - (debian-changelog-greater-than - upstream-vsn (match-string 1 buffer-file-name))) - (concat epoch (debian-changelog-increment-version upstream-vsn))) - - ;; No debian version number (Debian native) and old upstream - ;; version matches new one (e.g. 'dpk-source -x package' without - ;; then bumping up the version in the directory name. - ((and (not debian-vsn) - (string-match (concat "/" (regexp-quote pkg-name) "-" - (regexp-quote upstream-vsn) - "/debian/changelog") - buffer-file-name) - (concat epoch - (debian-changelog-increment-version upstream-vsn)))) - - ;; No debian version number and version number from changelog - ;; less than from directory name. - ((and (not debian-vsn) - (not (string-match - (concat "/" (regexp-quote pkg-name) "-" - (regexp-quote upstream-vsn) "/debian/changelog") - buffer-file-name)) - (string-match (concat - "/" (regexp-quote pkg-name) - "-\\([0-9a-zA-Z.+~]+\\)/debian/changelog") - buffer-file-name) - (debian-changelog-greater-than - (match-string 1 buffer-file-name) upstream-vsn)) - (concat epoch (match-string 1 buffer-file-name))) - - ((string-match (concat "/" (regexp-quote pkg-name) - "-\\([0-9a-zA-Z.+~]+\\)/debian/changelog") - buffer-file-name) - ;;Hmmm.. return version number from directory if we get this far - (concat epoch (match-string 1 buffer-file-name))) - ((string-match - (concat "-\\([0-9][0-9a-zA-Z.+~]+\\)/debian/changelog") - buffer-file-name) - ;;Hmmm.. return version number from directory if we get this far - (concat epoch (match-string 1 buffer-file-name))) - - ;; Directory name has no version -> increment what we have. - (t - (concat epoch - (debian-changelog-increment-version upstream-vsn))))))))) - -(defun debian-changelog-increment-version (version) -;; Peter S Galbraith, 09 Mar 2001 - "Increment the last numeric portion of a VERSION number. -1 -> 2 -0potato1 -> 0potato2 -1.01 -> 1.02" - (cond - ((string-match "[1-9][0-9]*$" version) - (let ((first-part (substring version 0 (match-beginning 0))) - (snd-part (match-string 0 version))) - (concat - first-part (number-to-string (+ 1 (string-to-number snd-part)))))) - ((string-match "[0-9]*$" version) - ;; 3.5.4.0 -> 3.5.4.1 - (let ((first-part (substring version 0 (match-beginning 0))) - (snd-part (match-string 0 version))) - (concat - first-part (number-to-string (+ 1 (string-to-number snd-part)))))) - (t - ;; Safety net only - first condition should catch all - (number-to-string (+ 1 (string-to-number version)))))) - -(defun debian-changelog-finalise-and-save () - "Finalise, if necessary, and then save a debian-style changelog file." - (interactive) - (let ((f (debian-changelog-finalised-p))) - (and (stringp f) (error f)) - (or f (debian-changelog-finalise-last-version))) - (save-buffer)) - -;; -;; internal function to get date as string (used by finalising routines) -;; - -(defun debian-changelog-date-string () - "Return RFC-822 format date string. -Use UTC if `debian-changelog-date-utc-flag' is non-nil." - (let ((system-time-locale "C")) - (format-time-string "%a, %d %b %Y %T %z" nil - debian-changelog-date-utc-flag))) -;; -;; interactive functions to finalize entry -;; - -;;; Use debian-changelog-full-name and debian-changelog-mailing-address instead -;; (make-local-variable 'add-log-full-name) -;; (make-local-variable 'add-log-mailing-address) - -(defun debian-changelog-finalise-last-version () - "Finalise maintainer's name and email and release date." - (interactive) - (and (debian-changelog-finalised-p) - (debian-changelog-unfinalise-last-version)) - (if debian-changelog-local-variables-maybe-remove - (debian-changelog-local-variables-maybe-remove)) - (save-excursion - (goto-char (point-min)) - (re-search-forward "\n --\\([ \t]*\\)") - (delete-region (match-beginning 1) (match-end 1)) - (insert " " debian-changelog-full-name - " <" debian-changelog-mailing-address "> " - (debian-changelog-date-string)))) - -(defun debian-changelog-last-maintainer () - "Return maintainer name and e-mail of the last changelog entry as -a list in the form (NAME EMAIL)." - (save-excursion - (goto-char (point-min)) - (let ((string - (if (re-search-forward "^ -- \\(.*\\)>" nil t) - (if (fboundp 'match-string-no-properties) - (match-string-no-properties 1) - (match-string 1)) - (error "Maintainer name and email not found.")))) - (split-string string " <")))) - -(defun debian-changelog-web-developer-page () - "Browse the BTS for the last upload maintainer's developer summary page." - (interactive) - (if (not (featurep 'browse-url)) - (progn - (load "browse-url" nil t) - (if (not (featurep 'browse-url)) - (error "This function requires the browse-url elisp package")))) - (let ((email (cadr (debian-changelog-last-maintainer)))) - (browse-url (concat "http://qa.debian.org/developer.php?login=" email)) - (message "Looking up developer summary page for %s via browse-url" email))) - -;; co-maintenance as per bug #352957 by Luca Capello 2006 -(defun debian-changelog-comaintainer-insert (name separator) - "In the line before SEPARATOR, insert the co-maintainer name as for -the form [ NAME ]." - (goto-char (point-min)) - (re-search-forward (concat "\n " separator)) - (previous-line 1) - (insert "\n [ " name " ]") - (when (string= "--" separator) - (insert "\n"))) - -(defun debian-changelog-comaintainer () - "If the last maintainer is different from the current one, create a -co-maintained changelog entry." - (let ((name (car (debian-changelog-last-maintainer)))) - (unless (string= name debian-changelog-full-name) - (let ((maintainers-found) - (debian-changelog-last-entry-end - (progn (goto-char (point-min)) - (re-search-forward "\n --")))) - (mapc (lambda (x) - (goto-char (point-min)) - (when (search-forward x debian-changelog-last-entry-end t) - (add-to-list 'maintainers-found x))) - (list name debian-changelog-full-name)) - ;; set the co-maintenance if any - (if maintainers-found - ;; co-maintenance, debian-changelog-full-name is not present - (if (and (member name maintainers-found) - (not (member debian-changelog-full-name - maintainers-found))) - (debian-changelog-comaintainer-insert - debian-changelog-full-name "--")) - ;; no co-maintenance - (mapc (lambda (x) - (debian-changelog-comaintainer-insert (car x) (cadr x))) - `((,name " *") (,debian-changelog-full-name "--")))))))) - -;; -;; interactive function to unfinalise changelog (so modifications can be made) -;; - -(defun debian-changelog-unfinalise-last-version () - "Remove the `finalisation' information. -Removes maintainer's name, email address and release date so that new entries -can be made." - (interactive) - (if (debian-changelog-finalised-p) nil - (error "Most recent version is not finalised")) - (save-excursion - (debian-changelog-comaintainer) - (goto-char (point-min)) - (re-search-forward "\n --") - (let ((dels (point))) - (end-of-line) - (delete-region dels (point))))) - -;; -;; top level interactive function to activate mode -;; - -(defvar imenu-create-index-function) -;;;###autoload -(defun debian-changelog-mode () - "Major mode for editing Debian-style change logs. -Runs `debian-changelog-mode-hook' if it exists. - -Key bindings: - -\\{debian-changelog-mode-map} - -If you want to use your debian.org email address for debian/changelog -entries without using it for the rest of your email, use the `customize` -interface to set it, or simply set the variable -`debian-changelog-mailing-address' in your ~/.emacs file, e.g. - - (setq debian-changelog-mailing-address \"myname@debian.org\"))" - - (interactive) - (kill-all-local-variables) - (setq major-mode 'debian-changelog-mode - mode-name "Debian changelog" - left-margin 2 - fill-prefix " " - fill-column 74) - ;;(hack-local-variables) - ;; Can't hack-local-varibles because a "mode: " creates an infinite loop. - ;; It doesn't matter anyway. The Local Variable block is parsed after - ;; the mode is run when visited by find-file. That's the only time it's - ;; done. - (use-local-map debian-changelog-mode-map) - ;; Let each entry behave as one paragraph: -; (set (make-local-variable 'paragraph-start) "\\*") -; (set (make-local-variable 'paragraph-separate) "\\*\\|\\s-*$|\\S-") - ;; PSG: The following appears to get fill-paragraph to finally work! - (set (make-local-variable 'paragraph-start) "\\*\\|\\s *$\\|\f\\|^\\<") - (set (make-local-variable 'paragraph-separate) "\\s *$\\|\f\\|^\\<") - ;; Let each version behave as one page. - ;; Match null string on the heading line so that the heading line - ;; is grouped with what follows. - (set (make-local-variable 'page-delimiter) "^\\<") - (set (make-local-variable 'version-control) 'never) - (set (make-local-variable 'adaptive-fill-regexp) "\\s *") - (set (make-local-variable 'font-lock-defaults) - '((debian-changelog-font-lock-keywords - debian-changelog-font-lock-keywords-1 - debian-changelog-font-lock-keywords-2) t t)) - (set (make-local-variable - 'debian-changelog-local-variables-maybe-remove-done) nil) - (set (make-local-variable 'indent-line-function) 'indent-relative-maybe) - (set (make-local-variable 'outline-regexp) "^[a-z]") - (setq local-abbrev-table text-mode-abbrev-table) - (set-syntax-table text-mode-syntax-table) - (debian-bug-bug-menu-init debian-changelog-mode-map) - (easy-menu-add debian-changelog-menu) - (cond - (debian-changelog-use-imenu - (require 'imenu) - (setq imenu-create-index-function 'imenu--create-debian-changelog-index) - (if (or window-system - (fboundp 'tmm-menubar)) - (progn - (imenu-add-to-menubar "History") - ;(imenu-update-menubar) - )))) - (cond - (debian-changelog-highlight-mouse-t - (debian-changelog-setup-highlight-mouse-keymap) - (debian-changelog-highlight-mouse))) - (run-hooks 'debian-changelog-mode-hook)) -;;(easy-menu-add debian-changelog-menu)) - -;; -;; font-lock face defs by Peter Galbraith - -(defvar debian-changelog-warning-face 'debian-changelog-warning-face - "Face to use for important keywords.") - -(cond - ((and (fboundp 'facep) - (facep 'font-lock-warning-face)) - (copy-face 'font-lock-warning-face 'debian-changelog-warning-face)) - ((fboundp 'defface) - (defface debian-changelog-warning-face - '((((class grayscale)(background light))(:foreground "DimGray" :bold t)) - (((class grayscale)(background dark))(:foreground "LightGray" :bold t)) - (((class color)(background light))(:foreground "red" :bold t )) - (((class color)(background dark))(:foreground "red" :bold t )) - (t (:bold t))) - "Face for debian-changelog important strings." - :group 'debian-changelog-faces)) - (t - ;;; XEmacs19: - (make-face 'debian-changelog-warning-face - "Face to use for important keywords.in debian-changelog-mode") - (make-face-bold 'debian-changelog-warning-face) - ;; XEmacs uses a tag-list thingy to determine if we are using color - ;; or mono (and I assume a dark background). - (set-face-foreground 'debian-changelog-warning-face - "red" 'global nil 'append))) - -;; -;; font-lock definition by Chris Waters, -;; revisited by Peter Galbraith (Apr 2001) - -;; Available faces: -;; keyword-face, type-face, string-face, comment-face, -;; variable-name-face, function-name-face -;; in emacs only: builtin-face, constant-face, warning-face -;; in xemacs only: reference-face, doc-string-face, preprocessor-face - -;; the mappings I've done below only use faces available in both emacsen. -;; this is somewhat limiting; I may consider adding my own faces later. - -(defvar debian-changelog-font-lock-keywords-1 - (list - ;; package name line: pkg (1.0-1) unstable; urgency=medium - '(debian-changelog-fontify-version - (1 font-lock-function-name-face) - (2 font-lock-type-face nil t) - (3 font-lock-string-face nil t) - (4 debian-changelog-warning-face nil t)) - '(debian-changelog-fontify-stable . debian-changelog-warning-face) - '(debian-changelog-fontify-backports . debian-changelog-warning-face) - '(debian-changelog-fontify-frozen . font-lock-type-face) - '(debian-changelog-fontify-unstable . font-lock-string-face) - '(debian-changelog-fontify-experimental . debian-changelog-warning-face) - '(debian-changelog-fontify-unreleased . debian-changelog-warning-face) - '(debian-changelog-fontify-urgency-crit . debian-changelog-warning-face) - '(debian-changelog-fontify-urgency-high . debian-changelog-warning-face) - '(debian-changelog-fontify-urgency-med . font-lock-type-face) - '(debian-changelog-fontify-urgency-low . font-lock-string-face) - ;; bug closers - '(;"\\(closes:\\) *\\(\\(bug\\)?#? *[0-9]+\\(, *\\(bug\\)?#? *[0-9]+\\)*\\)" - ;; Process lines that continue on multiple lines - Fred Bothamy - "\\(closes:\\)[ \t\n]*\\(\\(bug\\)?#? *[0-9]+\\(,[ \t\n]*\\(bug\\)?#? *[0-9]+\\)*\\)" - (1 font-lock-keyword-face) - (2 debian-changelog-warning-face)) - '("^\t.*$" . debian-changelog-warning-face) - ;; maintainer line (enforce 2 space exactly between email and date) - '("^ -- \\(.+\\) <\\(.+@.+\\)> \\([^ ].+\\)$" - (1 font-lock-variable-name-face) - (2 font-lock-variable-name-face) - (3 font-lock-string-face))) - "First level highlighting for `debian-changelog-mode'.") - -(defvar debian-changelog-font-lock-keywords-2 - (append - debian-changelog-font-lock-keywords-1 - ;; bullet lines - '(("^ +\\(\\*\\)" 1 font-lock-comment-face))) - "High level highlighting for `debian-changelog-mode'.") - -(defvar debian-changelog-font-lock-keywords - debian-changelog-font-lock-keywords-1 - "Default expressions to highlight in `debian-changelog-mode'.") - -;; Fontifier function by Peter Galbraith, Apr 24 2001 - -(defun debian-changelog-fontify-version (limit) - "Return match for package name and version number up to LIMIT. -match 1 -> package name - 2 -> native vsn number - 3 -> non-native vsn number - 4 -> non-native NMU vsn number" - (when (re-search-forward -;;; The following is not strictly correct. The upstream version may actually -;;; contain a hyphen if a debian version number also exists, making two hyphens -;;; I'm assuming it begins with a digit, which is not enforced - "^\\(\\S-+\\) (\\([0-9]:\\)?\\([0-9][0-9a-zA-Z.+:~]*\\)\\(-\\([0-9a-zA-Z.+~]+\\)\\)*)" nil t) -;; ^ -;; Note the asterix above, allowing more than one hyphen in the version -;; number, but wrongly assuming that all of it is the Debian version -;; instead of only the bit past the last hyphen. I might get NMUs wrongly -;; for version numbers with multiple hyphens. - -;; match 1: package name -;; match 2: epoch, if it exists -;; match 3: upstream version number -;; match 4: debian version number exists if matched -;; match 5: debian version number - (cond - ((not (match-string 4)) - ;; No Debian version number -> Debian native package - (store-match-data - (list (match-beginning 1)(match-end 3) - (match-beginning 1)(match-end 1) - (match-beginning 3)(match-end 3) - nil nil - nil nil))) - ((match-string 4) - ;; Debian version number -> Let's see if NMU... - (let* ((deb-vsn (match-string 5)) - (is-NMU (save-match-data (string-match "\\." deb-vsn)))) - (cond - (is-NMU - (store-match-data - (list (match-beginning 1)(match-end 5) - (match-beginning 1)(match-end 1) - nil nil - nil nil - (match-beginning 3)(match-end 5)))) - (t - (store-match-data - (list (match-beginning 1)(match-end 5) - (match-beginning 1)(match-end 1) - nil nil - (match-beginning 3)(match-end 5) - nil nil))))))) - t)) - -(defun debian-changelog-fontify-urgency-crit (limit) - (when (re-search-forward "^\\sw.* (.+).*; \\(urgency=critical\\)" limit t) - (store-match-data - (list (match-beginning 1)(match-end 1))) - t)) - -(defun debian-changelog-fontify-urgency-high (limit) - (when (re-search-forward "^\\sw.* (.+).*; \\(urgency=high\\)" limit t) - (store-match-data - (list (match-beginning 1)(match-end 1))) - t)) - -(defun debian-changelog-fontify-urgency-med (limit) - (when (re-search-forward "^\\sw.* (.+).*; \\(urgency=medium\\)" limit t) - (store-match-data - (list (match-beginning 1)(match-end 1))) - t)) - -(defun debian-changelog-fontify-urgency-low (limit) - (when (re-search-forward "^\\sw.* (.+).*; \\(urgency=low\\)" limit t) - (store-match-data - (list (match-beginning 1)(match-end 1))) - t)) - -(defun debian-changelog-fontify-stable (limit) - (when (re-search-forward "^\\sw.* (.+).* \\(\\(old\\)?stable\\(-security\\|-proposed-updates\\)?\\)" limit t) - (store-match-data - (list (match-beginning 1)(match-end 1))) - t)) - -(defun debian-changelog-fontify-frozen (limit) - (when (re-search-forward "^\\sw.* (.+).* \\(testing\\(-security\\)?\\|frozen\\|woody-proposed-updates\\)" limit t) - (store-match-data - (list (match-beginning 1)(match-end 1))) - t)) - -(defun debian-changelog-fontify-unstable (limit) - (when (re-search-forward "^\\sw.* (.+).* \\(unstable\\)" limit t) - (store-match-data - (list (match-beginning 1)(match-end 1))) - t)) - -(defun debian-changelog-fontify-experimental (limit) - (when (re-search-forward "^\\sw.* (.+).* \\(experimental\\)" limit t) - (store-match-data - (list (match-beginning 1)(match-end 1))) - t)) - -(defun debian-changelog-fontify-unreleased (limit) - (when (re-search-forward "^\\sw.* (.+).* \\(UNRELEASED\\)" limit t) - (store-match-data - (list (match-beginning 1)(match-end 1))) - t)) - -(defun debian-changelog-fontify-backports (limit) - (when (re-search-forward "^\\sw.* (.+).* \\([a-z][a-z]*-backports\\)" limit t) - (store-match-data - (list (match-beginning 1)(match-end 1))) - t)) - -;; -;; browse-url interfaces, by Peter Galbraith, Feb 23 2001 -;; - -(defvar debian-changelog-is-XEmacs - (not (null (save-match-data (string-match "XEmacs\\|Lucid" emacs-version))))) - -(defvar debian-changelog-mouse-keymap nil - "Keymap for mouse commands.") - -(defun debian-changelog-setup-highlight-mouse-keymap () - (setq debian-changelog-mouse-keymap - ;;; First, copy the local keymap so we don't have `disappearing' menus - ;;; when the mouse is moved over a bug number. - - ;;; FIXME: Check out (mouse-major-mode-menu) to see how it grabs the local - ;;; menus to display. - (let ((m (copy-keymap (current-local-map)))) -;; (cond -;; ((and debian-changelog-use-imenu -;; (or window-system (fboundp 'tmm-menubar))) -;; (imenu-add-to-menubar "History"))) - (cond - (debian-changelog-is-XEmacs - (set-keymap-name m 'debian-changelog-mouse-keymap) - (define-key m [button3] - 'debian-bug-web-this-bug-under-mouse)) - (t - (define-key m [down-mouse-3] - 'debian-bug-web-this-bug-under-mouse))) - m))) - -(defvar debian-changelog-ext-list nil - "XEmacs buffer-local list of debian-changelog-cite extents.") -(make-variable-buffer-local 'debian-changelog-ext-list) -(put 'debian-changelog-ext-list 'permanent-local t) - -(defun debian-changelog-highlight-mouse () - "Make that nice green highlight when the mouse is over a bug number. -Also set keymap." - (interactive) - (save-excursion - (let ((s)(e)(extent)(local-extent-list debian-changelog-ext-list) - (inhibit-read-only t) - (modified (buffer-modified-p))) ;put-text-property changing this? - ;; Remove the mouse face properties first. - (setq debian-changelog-ext-list nil) ;Reconstructed below... - (if (string-match "XEmacs\\|Lucid" emacs-version) - (while local-extent-list - (setq extent (car local-extent-list)) - (if (or (extent-detached-p extent) - (and (<= (point-min)(extent-start-position extent)) - (>= (point-max)(extent-end-position extent)))) - (delete-extent extent) - (setq debian-changelog-ext-list - (cons extent debian-changelog-ext-list))) - (setq local-extent-list (cdr local-extent-list))) - ;; Remove properties for regular emacs - ;; FIXME This detroys all mouse-faces and local-maps! - (let ((before-change-functions) (after-change-functions)) - (remove-text-properties (point-min) (point-max) - '(mouse-face t local-map t)))) - (goto-char (point-min)) - ;; FIXME: Ideally, I want to hightlight _only_ the digit parts - ;; (skipping the coma, and the word "bug". - (while - (re-search-forward -;;; "\\(closes:\\) *\\(\\(bug\\)?#? *[0-9]+\\(, *\\(bug\\)?#? *[0-9]+\\)*\\)" - ;; Same deal as for font-lock - patch from Fred Bothamy. - "\\(closes:\\)[ \t\n]*\\(\\(bug\\)?#? *[0-9]+\\(,[ \t\n]*\\(bug\\)?#? *[0-9]+\\)*\\)" - nil t) - (setq s (match-beginning 2)) - (setq e (match-end 2)) - (cond - ((string-match "XEmacs\\|Lucid" emacs-version) - (setq extent (make-extent s e)) - (setq debian-changelog-ext-list - (cons extent debian-changelog-ext-list)) - (set-extent-property extent 'highlight t) - (set-extent-property extent 'start-open t) -; (set-extent-property extent 'balloon-help 'debian-changelog-label-help) -; (set-extent-property extent 'help-echo 'debian-changelog-label-help-echo) - (set-extent-property extent 'keymap debian-changelog-mouse-keymap)) - (t - (let ((before-change-functions) (after-change-functions)) - (put-text-property s e 'local-map - debian-changelog-mouse-keymap) - (put-text-property s e 'mouse-face 'highlight))))) - (set-buffer-modified-p modified)))) - -;;;------------- -;;; imenu stuff - Peter Galbraith, May 2001 - -(eval-when-compile - (require 'cl) - (if (fboundp 'imenu) ;Make sure auto-load is loaded - (require 'imenu))) - -(defvar debian-changelog-imenu-doing-closebug nil - "Internal flag set when imenu is processing many bug closings.") -(make-variable-buffer-local 'debian-changelog-imenu-doing-closebug) - -(defun debian-changelog-imenu-prev-index-position-function () - (cond - (debian-changelog-imenu-doing-closebug - (if (not (posix-search-backward - "\\(closes:\\)\\|[^0-9]\\([0-9]+\\)" nil t)) - nil ; No match - ;; match 1 -> "closes:" - ;; match 2 -> a bug number - (cond - ((match-string 1) - (setq debian-changelog-imenu-doing-closebug nil) - (debian-changelog-imenu-prev-index-position-function)) - (t - ;; Return the bug number match - t)))) - (t - (if (not (re-search-backward - "\\(closes: *\\(bug\\)?#? *[0-9]+\\)\\|\\(^\\sw.* (\\(.+\\))\\)" - nil t)) - nil ; No match - ;; match 1 -> "closes:" - ;; match 4 -> a version number - (cond - ((match-string 1) - (setq debian-changelog-imenu-doing-closebug t) - (forward-char -1) - (re-search-forward - "\\(closes:\\) *\\(\\(bug\\)?#? *[0-9]+\\(, *\\(bug\\)?#? *[0-9]+\\)*\\)" - nil t) - (forward-char 1) - (debian-changelog-imenu-prev-index-position-function)) - (t - ;; Return the version number match - t)))))) - -(defvar debian-changelog-imenu-counter nil - "Debian-changelog-mode internal variable for imenu support.") - -(defun imenu--create-debian-changelog-index () - (save-match-data - (save-excursion - (let ((index-alist '()) - (index-bug-alist '()) - (index-bugsorted-alist '()) - (prev-pos 0) - (imenu-scanning-message "Scanning changelog for History (%3d%%)") - ) - (setq debian-changelog-imenu-counter -99) - (goto-char (point-max)) - (imenu-progress-message prev-pos 0 t) -;;; (message "Scanning changelog history...") - (setq debian-changelog-imenu-doing-closebug nil) - (while (debian-changelog-imenu-prev-index-position-function) - (imenu-progress-message prev-pos nil t) - (let ((marker (make-marker))) - (set-marker marker (point)) - (cond - ((match-beginning 2) ;bug number - (push (cons (match-string-no-properties 2) marker) - index-bug-alist)) - ((match-beginning 4) ;version number - (push (cons (match-string-no-properties 4) marker) - index-alist))))) - (imenu-progress-message prev-pos 100 t) -;;; (message "Scanning changelog history... done.") - (cond - (index-bug-alist - (push (cons "Closed Bugs (chrono)" - index-bug-alist) - index-alist) - (setq index-bugsorted-alist (copy-alist index-bug-alist)) - (push (cons "Closed Bugs (sorted)" - (sort index-bugsorted-alist - 'debian-changelog-imenu-sort)) - index-alist))) - index-alist)))) - -(defun debian-changelog-imenu-sort (el1 el2) - "Predicate to compare labels in lists." - (string< (car el2) (car el1) )) - -;;; end of imenu stuff -;;;------------- - -;;; Setup auto-mode-alist -;; (in case /etc/emacs/site-start.d/50dpkg-dev.el not used) -;; -;; Crib note: no need for "NEWS.Debian.gz" or "changelog.Debian.gz" entries -;; since jka-compr.el dispatches using the basename after uncompressing. - -(add-to-list 'auto-mode-alist '("/debian/*NEWS" . debian-changelog-mode)) -(add-to-list 'auto-mode-alist '("NEWS.Debian" . debian-changelog-mode)) - -;;(add-to-list 'auto-mode-alist '("/debian/changelog\\'" . debian-changelog-mode)) -;;; Instead use this. See http://bugs.debian.org/457047 by Trent W. Buck -;;; Valid package names spec is Debian Policy section 5.6.7 -(add-to-list - 'auto-mode-alist - '("/debian/\\([[:lower:][:digit:]][[:lower:][:digit:].+-]+\\.\\)?changelog\\'" - . debian-changelog-mode)) - -(add-to-list 'auto-mode-alist '("changelog.Debian" . debian-changelog-mode)) - ;; For debchange -(add-to-list 'auto-mode-alist '("changelog.dch" . debian-changelog-mode)) - -;;;###autoload(add-to-list 'auto-mode-alist '("/debian/*NEWS" . debian-changelog-mode)) -;;;###autoload(add-to-list 'auto-mode-alist '("NEWS.Debian" . debian-changelog-mode)) -;;;###autoload(add-to-list 'auto-mode-alist '("/debian/\\([[:lower:][:digit:]][[:lower:][:digit:].+-]+\\.\\)?changelog\\'" . debian-changelog-mode)) -;;;###autoload(add-to-list 'auto-mode-alist '("changelog.Debian" . debian-changelog-mode)) -;;;###autoload(add-to-list 'auto-mode-alist '("changelog.dch" . debian-changelog-mode)) - -(provide 'debian-changelog-mode) - -;;; debian-changelog-mode.el ends here diff --git a/elisp/dpkg-dev-el/debian-control-mode.el b/elisp/dpkg-dev-el/debian-control-mode.el deleted file mode 100755 index d3936fe..0000000 --- a/elisp/dpkg-dev-el/debian-control-mode.el +++ /dev/null @@ -1,525 +0,0 @@ -;;; debian-control-mode.el --- major mode for Debian control files - -;; Copyright (C) 2001, 2003 Free Software Foundation, Inc. -;; Copyright (C) 2003-2005, 2007-2011 Peter S Galbraith <psg@debian.org> - -;; Author: Colin Walters <walters@debian.org> -;; Maintainer: Peter S Galbraith <psg@debian.org> -;; Created: 29 Nov 2001 -;; Version: 1.5 -;; X-RCS: $Id: debian-control-mode.el,v 1.19 2013/10/15 17:22:44 psg Exp $ -;; Keywords: convenience - -;; This file 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. -;; -;; debian-control-mode.el 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 your Debian installation, in /usr/share/common-licenses/GPL -;; If not, write to the Free Software Foundation, 675 Mass Ave, -;; Cambridge, MA 02139, USA. - -;;; Commentary: - -;; debian-control-mode.el is developed under Emacs 21, and is targeted -;; for use in Emacs 21 and relatively recent versions of XEmacs. - -;;; Change Log: - -;; V1.5 (2011-08-16) Added "Multi-Arch:" (Closes #634162) - -;; V1.4 (2011-06-24) Added "XS-Python-Version" to debian-control-source-fields -;; (Closes #591697) - -;; V1.3 (2010-05-07) Added "Breaks" to debian-control-binary-fields -;; (Closes #580501) - -;; V1.2a (2009-02-23) Applied patch from Morten Kjeldgaard changing -;; Dm-Upload-Allowed to DM-Upload-Allowed (Closes: #508748) - -;; V1.2 (2008-01-17) Cyril Brulebois <cyril.brulebois@enst-bretagne.fr> -;; - Add "Dm-Upload-Allowed" field to source fields. - -;; V1.1 (2007-10-18) Cyril Brulebois <cyril.brulebois@enst-bretagne.fr> -;; - Renamed "XS-Vcs-*" fields into "Vcs-*", officially supported since -;; dpkg/1.14.7. - -;; V1.0 (2007-10-01) Cyril Brulebois <cyril.brulebois@enst-bretagne.fr> -;; - Add "Homepage" field to source fields. -;; - Add "XS-Vcs-*" fields to source fields, patch contributed by -;; Rafael Laboissiere <rafael@debian.org> (Closes: #422491). - -;; V0.9 (2005-11-22) Peter S Galbraith <psg@debian.org> -;; - Make # the comment character. (Closes: #339868) - -;; V0.8 (2005-02-07) Peter S Galbraith <psg@debian.org> -;; - Change mouse-2 binding to C-mouse-2 (Closes: #293629) -;; - Fix debian-control-mode-bugs-mouse-click to create correct -;; text-properties of package names. - -;; V0.7 (2004-03-27) Peter S Galbraith <psg@debian.org> -;; -;; * Apply patch from Jhair Tocancipa Triana <jhair_tocancipa@gmx.net> -;; in http://bugs.debian.org/226770. Fixes an after-change-functions race. - -;; V0.6 (2003-11-27) Peter S Galbraith <psg@debian.org> -;; -;; * Only fontify known fields (to better catch misspellings) (Closes: #213779) -;; * Add "Uploaders" field; Add "Section" and "Priority" also to binary fields. -;; * Call `goto-address' in major-mode to clickify URLs. -;; * http://cvs.verbum.org/debian/debian-control-mode link removed. - -;; V0.5 (2003/10/16) Peter S Galbraith <psg@debian.org> -;; -;; * Add "View upgrading-checklist" to control menu. -;; * Added debian-control-find-file to make this work on XEmacs. - -;; Changes from 0.3 to 0.4: -;; -;; * Don't depend on face properties to find names of packages. -;; * Use an after-change-function to put special text properties on, -;; instead of using font-lock to do it. That way they'll be added -;; regardless of the value of `font-lock-mode'. -;; * Fix up portable definition of `with-auto-compression-mode'. - -;; Changes from 0.2 to 0.3: -;; -;; * Fix bug in filling description lines. -;; * Clicking on a source or binary package name shows bugs for that -;; package. -;; * New function `debian-control-mode-add-field', bound to 'C-c C-a' -;; by default. -;; * New function `debian-control-visit-policy', bound to 'C-c C-p' -;; by default. -;; * New function `debian-control-view-package-bugs', bound to 'C-c C-b' -;; by default. -;; * Initial menu support. -;; * Initial customize support. -;; * Imenu support. -;; * Initial attempts at XEmacs support. -;; * Use the term "field" instead of "header". - -;; Changes from 0.1 to 0.2: -;; -;; * Tighten up regexps; whitespace before and after a field value is -;; insignificant. Also, package names may contain '+' and '.'. -;; * Add more comments for compliance with Emacs Lisp coding standards. -;; * Allow filling of a regular field to work. -;; * Provide `debian-control-mode'. - -;;; Bugs: - -;; Filling doesn't work on XEmacs. I have no idea why. -;; Mouse stuff doesn't work on XEmacs. -;; Emacs 20 isn't supported. - -;;; Code: - -(require 'easymenu) -(require 'font-lock) -(eval-when-compile - (require 'cl)) - -;; XEmacs compatibility -(eval-and-compile - (unless (fboundp 'line-beginning-position) - (defun line-beginning-position () - (save-excursion - (beginning-of-line) - (point)))) - (unless (fboundp 'line-end-position) - (defun line-end-position () - (save-excursion - (end-of-line) - (point)))) - (unless (fboundp 'match-string-no-properties) - (defalias 'match-string-no-properties 'match-string))) - -(defgroup debian-control nil "Debian control file maintenance" - :group 'tools) - -(defcustom debian-control-source-package-face 'font-lock-type-face - "The face to use for highlighting source package names." - :type 'face - :group 'debian-control) - -(defcustom debian-control-binary-package-face 'font-lock-variable-name-face - "The face to use for highlighting binary package names." - :type 'face - :group 'debian-control) - -(defvar debian-control-syntax-table nil - "Syntax table used in debian-control-mode buffers.") - -(if debian-control-syntax-table - () - (setq debian-control-syntax-table (make-syntax-table)) - ;; Support # style comments - (modify-syntax-entry ?# "<" debian-control-syntax-table) - (modify-syntax-entry ?\n "> " debian-control-syntax-table)) - -;; FIXME: As of policy 3.5.6.0, the allowed characters in a field name -;; are not specified. So we just go with "word constituent" or '-' -;; characters before a colon. -(defvar debian-control-field-regexp "^\\(\\(\\sw\\|-\\)+:\\)") -(defvar debian-control-package-name-regexp "\\([-a-zA-Z0-9+.]+?\\)") - -(defvar debian-control-mode-package-name-keymap (make-sparse-keymap)) - -;; An uptodate list can be found at: -;; http://svn.debian.org/wsvn/qa/trunk/pts/www/bin/common.py?op=file -(defvar debian-control-vcs-names - '("Arch" "Bzr" "Cvs" "Darcs" "Git" "Hg" "Mtn" "Svn") - "Valid VCS names for the Vcs-* field.") - -(defvar debian-control-source-fields - (append - '("Section" "Priority" "Maintainer" "Build-Depends" "Build-Depends-Indep" - "Build-Conflicts" "Build-Conflicts-Indep" "Standards-Version" "Uploaders" - "DM-Upload-Allowed" "Homepage" "Vcs-Browser" "XS-Python-Version") - (mapcar (lambda (elt) (concat "Vcs-" elt)) - debian-control-vcs-names)) - "Valid source package field names, collected from several policy sections.") - -(defvar debian-control-binary-fields - '("Section" "Priority" "Architecture" "Depends" "Conflicts" "Pre-Depends" - "Essential" "Provides" "Recommends" "Suggests" "Replaces" "Enhances" - "Description" "Breaks") - "Valid binary package field names, collected from several policy sections.") - -(defvar debian-control-source-fields-regexp - (concat - "^\\(" - (let ((max-specpdl-size 1000)) - (regexp-opt debian-control-source-fields t)) - "\\):") - "font-lock regexp matching known fields in the source section.") - -(defvar debian-control-binary-fields-regexp - (concat - "^\\(" - (let ((max-specpdl-size 1000)) - (regexp-opt debian-control-binary-fields t)) - "\\):") - "font-lock regexp matching known fields in the binary section.") - -(defvar debian-control-font-lock-keywords - `((,(concat "^\\(Source:\\)\\s-*" - debian-control-package-name-regexp - "\\s-*$") - (1 font-lock-keyword-face) - ,(list 2 - (if (featurep 'xemacs) - '(symbol-value debian-control-source-package-face) - '(list 'face debian-control-source-package-face)) - nil nil)) - ("^\\(Multi-Arch:\\)\\s-*\\(same\\|foreign\\|allowed\\)" - (1 font-lock-function-name-face) - (2 font-lock-keyword-face)) - (,debian-control-source-fields-regexp - (1 font-lock-keyword-face)) - (,debian-control-binary-fields-regexp - (1 font-lock-function-name-face)))) - -(defvar debian-control-mode-menu nil) - -;;;###autoload -(define-derived-mode debian-control-mode fundamental-mode "Debian Control" - "A major mode for editing Debian control files (i.e. debian/control)." - (if (< emacs-major-version 21) - (message "debian-control-mode only supports emacsen version >= 21; disabling features") - (progn - (set-syntax-table debian-control-syntax-table) - ;; Comments - (make-local-variable 'comment-start-skip) ;Need this for font-lock... - (setq comment-start-skip "\\(^\\|\\s-\\);?#+ *") ;;From perl-mode - (make-local-variable 'comment-start) - (make-local-variable 'comment-end) - (setq comment-start "#" - comment-end "") - - (make-local-variable 'font-lock-defaults) - (setq font-lock-defaults - '(debian-control-font-lock-keywords - nil ;;; Keywords only? No, let it do syntax via table. - nil ;;; case-fold? - nil ;;; Local syntax table. - nil ;;; Use `backward-paragraph' ? No - )) - (set (make-local-variable 'fill-paragraph-function) - #'debian-control-mode-fill-paragraph) - (make-local-variable 'after-change-functions) - (push 'debian-control-mode-after-change-function after-change-functions) - (set (make-local-variable 'imenu-generic-expression) - '((nil "^\\(Package\\|Source\\):\\s-*\\([-a-zA-Z0-9+.]+?\\)\\s-*$" 2))) - - (define-key debian-control-mode-map (kbd "C-c C-b") 'debian-control-view-package-bugs) - (define-key debian-control-mode-map (kbd "C-c C-p") 'debian-control-visit-policy) - (define-key debian-control-mode-map (kbd "C-c C-a") 'debian-control-mode-add-field) - (define-key debian-control-mode-package-name-keymap (if (featurep 'xemacs) - [(control down-mouse-2)] - [(C-mouse-2)]) - 'debian-control-mode-bugs-mouse-click) - (easy-menu-add debian-control-mode-menu) - (if (and (featurep 'goto-addr) goto-address-highlight-p) - (goto-address)) - (let ((after-change-functions nil)) - (debian-control-mode-after-change-function (point-min) (point-max) 0))))) - -(defun debian-control-mode-after-change-function (beg end len) - (save-excursion - (let ((modified (buffer-modified-p)) - (buffer-read-only nil) - (data (match-data))) - (unwind-protect - (progn - (goto-char beg) - (beginning-of-line) - (while (< (point) end) - (cond ((looking-at (concat "^\\(Source:\\)\\s-*" - debian-control-package-name-regexp - "\\s-*$")) - (add-text-properties - (match-beginning 2) (match-end 2) - `(mouse-face - highlight - debian-control-mode-package ,(match-string 2) - help-echo "C-mouse-2: View bugs for this source package" - keymap ,debian-control-mode-package-name-keymap))) - ((looking-at (concat "^\\(Package:\\)\\s-*" - debian-control-package-name-regexp - "\\s-*$")) - (add-text-properties - (match-beginning 2) (match-end 2) - `(mouse-face - highlight - debian-control-mode-package ,(match-string 2) - help-echo "C-mouse-2: View bugs for this binary package" - keymap ,debian-control-mode-package-name-keymap))) - (t nil)) - (forward-line 1))) - (set-match-data data) - (set-buffer-modified-p modified))))) - -(easy-menu-define - debian-control-mode-menu debian-control-mode-map "Debian Control Mode Menu" - '("Control" - ["Add field at point" debian-control-mode-add-field t] - "--" - "Policy" - ["View upgrading-checklist" (debian-control-visit-policy 'checklist) - (file-exists-p "/usr/share/doc/debian-policy/upgrading-checklist.txt.gz")] - ["View policy (text)" (debian-control-visit-policy 'text) - (file-exists-p "/usr/share/doc/debian-policy/policy.txt.gz")] - ["View policy (HTML)" (debian-control-visit-policy 'html) t] - "--" - "Access www.debian.org" - ["Bugs for package" debian-control-view-package-bugs t] - ["Specific bug number" (debian-changelog-web-bug) nil] -;; ["Package list (all archives)" (debian-changelog-web-packages) t] -;; ("Package web pages..." -;; ["stable" (debian-changelog-web-package "stable") t] -;; ["testing" (debian-changelog-web-package "testing") t] -;; ["unstable" (debian-changelog-web-package "unstable") t]) - "--" - ["Customize" (customize-group "debian-control") t])) - -(defun debian-control-mode-fill-paragraph (&rest args) - (let (beg end) - (save-excursion - ;; Are we looking at a field? - (if (save-excursion - (beginning-of-line) - (looking-at debian-control-field-regexp)) - (setq beg (match-end 0) - end (line-end-position)) - ;; Otherwise, we're looking at a description; handle filling - ;; areas separated with "." specially - (setq beg (save-excursion - (beginning-of-line) - (while (not (or (bobp) - (looking-at "^\\sw-*$") - (looking-at "^ \\.") - (looking-at debian-control-field-regexp))) - (forward-line -1)) - (unless (eobp) - (forward-line 1)) - (point)) - end (save-excursion - (beginning-of-line) - (while (not (or (eobp) - (looking-at "^\\sw-*$") - (looking-at debian-control-field-regexp) - (looking-at "^ \\."))) - (forward-line 1)) - (unless (bobp) - (forward-line -1) - (end-of-line)) - (point)))) - (let ((fill-prefix " ")) - (apply #'fill-region beg end args))))) - -(defun debian-control-mode-add-field (binary field) - "Add a field FIELD to the current package; BINARY means a binary package." - (interactive - (let* ((binary-p (if (or (save-excursion - (beginning-of-line) - (looking-at "^\\(Package\\|Source\\)")) - (re-search-backward "^\\(Package\\|Source\\)" nil t)) - (not (not (string-match "Package" (match-string 0)))) - (error "Couldn't find Package or Source field"))) - (fields (if binary-p - debian-control-binary-fields - debian-control-source-fields)) - (completion-ignore-case t)) - (list - binary-p - (completing-read (format "Add %s package field: " (if binary-p "binary" "source")) - (mapcar #'(lambda (x) (cons x nil)) fields))))) - (require 'cl) - (let ((fields (if binary - debian-control-binary-fields - debian-control-source-fields)) - (beg (save-excursion - (beginning-of-line) - (while (not (or (bobp) - (looking-at "^\\s-*$"))) - (forward-line -1)) - (forward-line 1) - (point))) - (end (save-excursion - (beginning-of-line) - (while (not (or (eobp) - (looking-at "^\\s-*$"))) - (forward-line 1)) - (point)))) - (save-restriction - (narrow-to-region beg end) - (let ((curfields (let ((result nil)) - (goto-char (point-min)) - (while (not (eobp)) - (when (looking-at debian-control-field-regexp) - (push (cons (subseq - ;; Text properties are evil - (match-string-no-properties 1) - 0 - ;; Strip off the ':' - (- (match-end 1) - (match-beginning 1) - 1)) - (match-beginning 0)) - result)) - (forward-line 1)) - result)) - (x nil)) - ;; If the field is already present, just jump to it - (if (setq x (assoc field curfields)) - (goto-char (cdr x)) - (let* ((pos (or (position field fields :test #'string-equal) - -1)) - (prevfields (reverse (subseq fields 0 pos))) - (nextfields (subseq fields (1+ pos)))) - (if (not (wholenump pos)) - (goto-char (cdar curfields)) - (when prevfields - (while (and (car prevfields) - (not (assoc (car prevfields) curfields))) - (pop prevfields)) - (goto-char (cdr (assoc (car prevfields) curfields))) - (setq prevfields nil nextfields nil)) - (when nextfields - (while (and (car nextfields) - (not (assoc (car nextfields) curfields))) - (pop nextfields)) - (goto-char (cdr (assoc (car nextfields) curfields))) - (setq prevfields nil nextfields nil))) - ;; Hack: we don't want to add fields after Description - (beginning-of-line) - (when (looking-at "^Description") - (forward-line -1)) - (end-of-line) - (insert "\n" (upcase-initials field) ": "))))))) - -(defun debian-control-visit-policy (format) - "Visit the Debian Policy manual in format FORMAT. -Currently valid FORMATs are `html', `text' and `checklist'. -The last one is not strictly a format, but visits the upgrading-checklist.txt -text file." - (interactive - (list (intern - (completing-read "Policy format: " - (mapcar #'(lambda (x) (cons x 0)) - '("html" "text" "checklist")) - nil t)))) - (case format - (text - (debian-control-find-file "/usr/share/doc/debian-policy/policy.txt.gz")) - (checklist - (debian-control-find-file - "/usr/share/doc/debian-policy/upgrading-checklist.txt.gz")) - (html - (require 'browse-url) - (browse-url - (if (file-exists-p "/usr/share/doc/debian-policy/policy.html/index.html") - "file:///usr/share/doc/debian-policy/policy.html/index.html" - (prog1 - "http://www.debian.org/doc/debian-policy" - (message "Note: package `debian-policy' not installed, using web version"))))) - (t - (error "Unknown format %s for policy" format)))) - -(defun debian-control-find-file (file) - "Find-file a possibly compressed FILE" - (require 'jka-compr) - (let ((installed (jka-compr-installed-p))) - (if (not installed) - (auto-compression-mode t)) - (find-file file) - (if (not installed) - (auto-compression-mode -1)))) - -(defun debian-control-mode-bugs-mouse-click (event) - "Display the bugs for the package name clicked on." - (interactive "e") - (mouse-set-point event) - (let ((prop (get-text-property (point) 'debian-control-mode-package))) - (unless prop - (error "Couldn't determine package name at point")) - (debian-control-view-package-bugs prop))) - -(defun debian-control-mode-bug-package-names () - (let ((result nil)) - (save-excursion - (goto-char (point-min)) - (while (not (eobp)) - (when (looking-at "^\\(Package\\|Source\\):\\s-*\\([-a-zA-Z0-9+.]+?\\)\\s-*$") - (push (concat - (if (save-match-data (string-match "Source" (match-string 1))) - "src:" - "") - (match-string-no-properties 2)) result)) - (forward-line 1))) - result)) - -(defun debian-control-view-package-bugs (package) - "View bugs for package PACKAGE via http://bugs.debian.org." - (interactive - (list - (completing-read "View bugs for package: " - (mapcar #'(lambda (x) (cons x 0)) - (debian-control-mode-bug-package-names)) - nil t))) - (browse-url (concat "http://bugs.debian.org/" package))) - -(add-to-list 'auto-mode-alist '("/debian/control\\'" . debian-control-mode)) -;;;###autoload(add-to-list 'auto-mode-alist '("/debian/control\\'" . debian-control-mode)) - -(provide 'debian-control-mode) - -;;; debian-control-mode.el ends here diff --git a/elisp/dpkg-dev-el/debian-copyright.el b/elisp/dpkg-dev-el/debian-copyright.el deleted file mode 100755 index 4de8a98..0000000 --- a/elisp/dpkg-dev-el/debian-copyright.el +++ /dev/null @@ -1,97 +0,0 @@ -;;; debian-copyright.el --- Major mode for Debian package copyright files - -;; Copyright 2002, 2003 Junichi Uekawa. - -;; This file 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. -;; -;; debian-copyright.el 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 your Debian installation, in /usr/share/common-licenses/GPL -;; If not, write to the Free Software Foundation, 675 Mass Ave, -;; Cambridge, MA 02139, USA. - - -(require 'debian-changelog-mode) - -;;; Code: - -(defgroup debian-copyright nil "Debian copyright mode" - :group 'tools - :prefix "debian-copyright-") - -(defcustom debian-copyright-mode-load-hook nil - "*Hooks that are run when `debian-copyright-mode' is loaded." - :group 'debian-copyright - :type 'hook) - -(defcustom debian-copyright-mode-hook nil - "Normal hook run when entering Debian Copyright mode." - :group 'debian-copyright - :type 'hook - :options '(turn-on-auto-fill flyspell-mode)) - -(defconst debian-copyright-mode-version "$Id: debian-copyright.el,v 1.5 2010-07-28 15:33:45 psg Exp $" "Version of debian copyright mode.") - -(defvar debian-copyright-mode-map nil - "Keymap for debian/copyright mode.") -(defvar debian-copyright-mode-syntax-table nil - "Syntax table for debian/copyright mode.") - -(defvar debian-copyright-font-lock-keywords nil - "Regexps to highlight in font-lock.") - -(if debian-copyright-mode-syntax-table - () ; Do not change the table if it is already set up. - (setq debian-copyright-mode-syntax-table (make-syntax-table)) - (modify-syntax-entry ?\" ". " debian-copyright-mode-syntax-table) - (modify-syntax-entry ?\\ ". " debian-copyright-mode-syntax-table) - (modify-syntax-entry ?' "w " debian-copyright-mode-syntax-table)) - -;;;###autoload -(defun debian-copyright-mode () - "Mode to edit and read debian/copyright. -\\{debian-copyright-mode-map}" - (interactive) - (kill-all-local-variables) - (setq major-mode 'debian-copyright-mode) - (setq mode-name "debian/copyright") - (mapcar 'make-local-variable '(font-lock-defaults write-file-hooks)) - (use-local-map debian-copyright-mode-map) - (set-syntax-table debian-copyright-mode-syntax-table) - (if (or (not (featurep 'goto-addr)) - (not goto-address-highlight-p)) - (setq debian-copyright-font-lock-keywords - '(("http:.*$" . font-lock-function-name-face) - ("ftp:.*$" . font-lock-function-name-face) - ("^Copyright:$" . font-lock-keyword-face))) - (setq debian-copyright-font-lock-keywords - '(("^Copyright:$" . font-lock-keyword-face))) - (goto-address)) - (setq font-lock-defaults - '(debian-copyright-font-lock-keywords - nil ;keywords-only - nil ;case-fold - () ;syntax-alist - )) - (run-hooks 'debian-copyright-mode-hook)) - - -;;;###autoload -(add-to-list 'auto-mode-alist - '("debian/.*copyright\\'" . debian-copyright-mode)) -;;;###autoload -(add-to-list 'auto-mode-alist - '("\\`/usr/share/doc/.*/copyright" . debian-copyright-mode)) - -(run-hooks 'debian-copyright-mode-load-hook) - -(provide 'debian-copyright) - -;;; debian-copyright.el ends here diff --git a/elisp/dpkg-dev-el/dpkg-dev-el-loaddefs.el b/elisp/dpkg-dev-el/dpkg-dev-el-loaddefs.el deleted file mode 100755 index 40ccb19..0000000 --- a/elisp/dpkg-dev-el/dpkg-dev-el-loaddefs.el +++ /dev/null @@ -1,116 +0,0 @@ -;;; dpkg-dev-el-loaddefs.el --- automatically extracted autoloads -;; -;;; Code: - -(provide 'dpkg-dev-el-loaddefs) - -;;;### (autoloads (emacs-bts-control debian-bts-control) "debian-bts-control" -;;;;;; "debian-bts-control.el" (19331 13289)) -;;; Generated autoloads from debian-bts-control.el - -(autoload 'debian-bts-control "debian-bts-control" "\ -Contruct a message with initial ACTION command for control@bugs.debian.org. -Contructs a new control command line if called from within the message -being constructed. - -If prefix arg is provided, use the current buffer instead instead of -creating a new outgoing email message buffer. -The current buffer is also used if the current major mode matches one listed -in `debian-bts-control-modes-to-reuse'. - -\(fn ACTION &optional ARG)" t nil) - -(autoload 'emacs-bts-control "debian-bts-control" "\ -Contruct a message with ACTION command for control@debbugs.gnu.org. -Contructs a new control command line if called from within the message -being constructed. - -If prefix arg is provided, use the current buffer instead instead of -creating a new outgoing email message buffer. -The current buffer is also used if the current major mode matches one listed -in `debian-bts-control-modes-to-reuse'. - -\(fn ACTION &optional ARG)" t nil) - -;;;*** - -;;;### (autoloads (debian-changelog-mode debian-changelog-add-entry) -;;;;;; "debian-changelog-mode" "debian-changelog-mode.el" (19196 -;;;;;; 33072)) -;;; Generated autoloads from debian-changelog-mode.el - -(autoload 'debian-changelog-add-entry "debian-changelog-mode" "\ -Add a new change entry to a debian-style changelog. -If called from buffer other than a debian/changelog, this will search -for the debian/changelog file to add the entry to. - -\(fn)" t nil) - -(autoload 'debian-changelog-mode "debian-changelog-mode" "\ -Major mode for editing Debian-style change logs. -Runs `debian-changelog-mode-hook' if it exists. - -Key bindings: - -\\{debian-changelog-mode-map} - -If you want to use your debian.org email address for debian/changelog -entries without using it for the rest of your email, use the `customize` -interface to set it, or simply set the variable -`debian-changelog-mailing-address' in your ~/.emacs file, e.g. - - (setq debian-changelog-mailing-address \"myname@debian.org\")) - -\(fn)" t nil) -(add-to-list 'auto-mode-alist '("/debian/*NEWS" . debian-changelog-mode)) -(add-to-list 'auto-mode-alist '("NEWS.Debian" . debian-changelog-mode)) -(add-to-list 'auto-mode-alist '("NEWS.Debian.gz" . debian-changelog-mode)) -(add-to-list 'auto-mode-alist '("/debian/\\([[:lower:][:digit:]][[:lower:][:digit:].+-]+\\.\\)?changelog\\'" . debian-changelog-mode)) -(add-to-list 'auto-mode-alist '("changelog.Debian" . debian-changelog-mode)) -(add-to-list 'auto-mode-alist '("changelog.Debian.gz" . debian-changelog-mode)) -(add-to-list 'auto-mode-alist '("changelog.dch" . debian-changelog-mode)) - -;;;*** - -;;;### (autoloads (debian-control-mode) "debian-control-mode" "debian-control-mode.el" -;;;;;; (18850 58753)) -;;; Generated autoloads from debian-control-mode.el - -(autoload 'debian-control-mode "debian-control-mode" "\ -A major mode for editing Debian control files (i.e. debian/control). - -\(fn)" t nil) -(add-to-list 'auto-mode-alist '("/debian/control\\'" . debian-control-mode)) - -;;;*** - -;;;### (autoloads (debian-copyright-mode) "debian-copyright" "debian-copyright.el" -;;;;;; (16295 49413)) -;;; Generated autoloads from debian-copyright.el - -(autoload (quote debian-copyright-mode) "debian-copyright" "\ -Mode to edit and read debian/copyright. -\\{debian-copyright-mode-map}" t nil) -(add-to-list 'auto-mode-alist '("debian/.*copyright$" . debian-copyright-mode)) -(add-to-list 'auto-mode-alist '("^/usr/share/doc/.*/copyright" . debian-copyright-mode)) - -;;;*** - -;;;### (autoloads nil nil ("dpkg-dev-el.el") (19331 13614 16291)) - -;;;*** - -;;;### (autoloads (readme-debian-mode) "readme-debian" "readme-debian.el" -;;;;;; (17503 21939)) -;;; Generated autoloads from readme-debian.el - -(autoload (quote readme-debian-mode) "readme-debian" "\ -Mode for reading and editing README.Debian files. -Upon saving the visited README.Debian file, the timestamp at the bottom -will be updated. - -\\{readme-debian-mode-map}" t nil) -(add-to-list 'auto-mode-alist '("debian/.*README.*Debian$" . readme-debian-mode)) -(add-to-list 'auto-mode-alist '("^/usr/share/doc/.*/README.*Debian.*$" . readme-debian-mode)) - -;;;*** diff --git a/elisp/dpkg-dev-el/dpkg-dev-el-loaddefs.make b/elisp/dpkg-dev-el/dpkg-dev-el-loaddefs.make deleted file mode 100755 index fffbdcd..0000000 --- a/elisp/dpkg-dev-el/dpkg-dev-el-loaddefs.make +++ /dev/null @@ -1 +0,0 @@ -emacs -batch --no-site-file --multibyte --eval '(setq load-path (cons "." load-path))' -l autoload --eval '(setq generated-autoload-file (expand-file-name "dpkg-dev-el-loaddefs.el"))' --eval '(setq make-backup-files nil)' -f batch-update-autoloads . diff --git a/elisp/dpkg-dev-el/dpkg-dev-el.el b/elisp/dpkg-dev-el/dpkg-dev-el.el deleted file mode 100755 index b465cfc..0000000 --- a/elisp/dpkg-dev-el/dpkg-dev-el.el +++ /dev/null @@ -1,106 +0,0 @@ -;;; dpkg-dev-el.el --- startup file for the debian-el package - -;;; Commentary: -;; -;; This file is loaded from /etc/emacs/site-start.d/50dpkg-dev-el.el - -;;; History: -;; -;; 2003-11-03 - Peter Galbraith -;; - Created. - -;;; Code: - -(defgroup dpkg-dev-el nil - "Emacs helpers specific to Debian development." - :group 'convenience) - -(require 'dpkg-dev-el-loaddefs) - -;; debian-bts-control -(defgroup debian-bts-control nil - "Create messages for Debian BTS control interface" - :group 'debian-bug -;;:link '(custom-manual "(dpkg-dev-el)debian-bts-control") - :load 'debian-bts-control - :group 'dpkg-dev-el) - -;; debian-changelog-mode -(defgroup debian-changelog nil "Debian changelog maintenance" - :group 'tools - :prefix "debian-changelog-" -;;:link '(custom-manual "(dpkg-dev-el)debian-changelog-mode") - :load 'debian-changelog-mode - :group 'dpkg-dev-el) - -;; debian-control-mode -(defgroup debian-control nil "Debian control file maintenance" - :link '(url-link "http://cvs.verbum.org/debian/debian-control-mode") - :group 'tools -;;:link '(custom-manual "(dpkg-dev-el)debian-control-mode") - :load 'debian-control-mode - :group 'dpkg-dev-el) - -;; debian-copyright -(defgroup debian-copyright nil "Debian copyright mode" - :group 'tools - :prefix "debian-copyright-" -;;:link '(custom-manual "(dpkg-dev-el)debian-copyright") - :load 'debian-copyright - :group 'dpkg-dev-el) - -;; readme-debian -(defgroup readme-debian nil "Readme Debian (mode)" - :group 'tools - :prefix "readme-debian-" -;;:link '(custom-manual "(dpkg-dev-el)readme-debian") - :load 'readme-debian - :group 'dpkg-dev-el) - - - - -;; other useful automode -(add-to-list 'auto-mode-alist - '("/debian/[^/]*emacsen-startup\\'" . emacs-lisp-mode)) -;; Closes #490292 -(add-to-list 'auto-mode-alist '("README.source" . readme-debian-mode)) - -(when (member 'utf-8 (coding-system-list)) - ;; default to utf-8 for debian changelog files - (modify-coding-system-alist 'file "/changelog\\.Debian\\'" 'utf-8) - (modify-coding-system-alist 'file "/debian/control\\'" 'utf-8) - -;;; (modify-coding-system-alist 'file "/debian/changelog\\'" 'utf-8) -;;; - -;;; Kevin Ryde <user42@zip.com.au> (Closes: #587921) -;;; -;;; Instead use this for dh_installchangelog debian/packagename.changelog -;;; files too. See http://bugs.debian.org/457047 by Trent W. Buck -;;; But not [:lower:][:digit:] since those forms are not available in xemacs21. -;;; xemacs21 can have utf-8 at startup if you use mule-ucs with -;;; DEB_MULEUCS_UNICODE=yes - (modify-coding-system-alist 'file "/debian/\\([a-z0-9.+-]+\\.\\)?changelog\\'" 'utf-8) - - ;; Handle Debian native package, from Kevin Ryde in bug #317597 and #416218 - (defun debian-changelog-coding-system (args) - "Return the coding system for a /usr/share/doc/[package]/changelog file. -If [package] is a debian native (no separate changelog.Debian) then answer -`utf-8', otherwise remove ourselves from `file-coding-system-alist' and see -what other rules say." - (let ((filename (if (consp (cadr args)) - (car (cadr args)) ;; ("filename" . buffer) in emacs 22 - (cadr args))) ;; "filename" in emacs 21 - (dirname (file-name-directory filename))) - (if (file-exists-p (concat dirname "changelog.Debian.gz")) - (let ((file-coding-system-alist - (remove '("/usr/share/doc/[^/]+/changelog\\'" - . debian-changelog-coding-system) - file-coding-system-alist))) - (apply 'find-operation-coding-system args)) - 'utf-8)))) - - -(provide 'dpkg-dev-el) - -;;; dpkg-dev-el.el ends here diff --git a/elisp/dpkg-dev-el/readme-debian.el b/elisp/dpkg-dev-el/readme-debian.el deleted file mode 100755 index f400028..0000000 --- a/elisp/dpkg-dev-el/readme-debian.el +++ /dev/null @@ -1,126 +0,0 @@ -;;; readme-debian.el --- a simple mode for README.Debian files - -;; Copyright 2002, 2003, 2006 Junichi Uekawa. -;; -;; This file 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. -;; -;; readme-debian.el 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 your Debian installation, in /usr/share/common-licenses/GPL -;; If not, write to the Free Software Foundation, 675 Mass Ave, -;; Cambridge, MA 02139, USA. - -;;; Code: -(require 'debian-changelog-mode) -(defgroup readme-debian nil "Readme Debian (mode)" - :group 'tools - :prefix "readme-debian-") - -(defcustom readme-debian-mode-load-hook nil "*Hooks that are run when `readme-debian-mode' is loaded." - :type 'hook - :group 'readme-debian) -(defcustom readme-debian-mode-hook nil "*Hooks that are run when `readme-debian-mode' is entered." - :type 'hook - :group 'readme-debian) - -(defvar readme-debian-font-lock-keywords - '(("^\\(.*\\) for \\(Debian\\)$" - (1 font-lock-keyword-face) - (2 font-lock-string-face)) - ("^[-=]+$" 0 font-lock-string-face) - ("^ -- \\([^<]*\\)\\(<[^>]*>\\)\\(, \\(.*\\)\\)?$" - (1 font-lock-keyword-face) - (2 font-lock-function-name-face) - (3 font-lock-string-face))) - "Regexp keywords used to fontify README.Debian buffers.") - -(defun readme-debian-date-string () - "Return RFC-822 format date string." - ;; this function could be simpler if xemacs supported %z, but - ;; it doesn't, so we're shelling out to invoke date -R to obtain - ;; Debian-policy-compliant date string. - (let* ((date-program "date -R") - (system-time-locale "C")) - (if (featurep 'xemacs) - (replace-in-string (exec-to-string date-program) "\n" "") - ;; if it's not xemacs, just use format-time-string - (format-time-string "%a, %e %b %Y %T %z" (current-time))))) - -(defun readme-debian-update-timestamp () - "Function to update timestamp in README.Debian files, automatically invoked when saving file." - (save-excursion - (goto-line 1) - (if (re-search-forward "^ -- " nil t) - (delete-region (progn (beginning-of-line) (point)) (progn (end-of-line) (point))) - (goto-char (point-max)) - (if (bolp) - (insert "\n") - (insert "\n\n"))) - (insert (concat - " -- " - debian-changelog-full-name - " <" debian-changelog-mailing-address ">, " - (readme-debian-date-string))) - (if (and (= (point)(point-max)) (not (bolp))) - (insert "\n")))) - -(defvar readme-debian-mode-map nil "Keymap for README.Debian mode.") -(if readme-debian-mode-map - () - (setq readme-debian-mode-map (make-sparse-keymap))) -(defvar readme-debian-mode-syntax-table nil "Syntax table for README.Debian mode.") -(if readme-debian-mode-syntax-table - () ; Do not change the table if it is already set up. - (setq readme-debian-mode-syntax-table (make-syntax-table)) - (modify-syntax-entry ?\" ". " readme-debian-mode-syntax-table) - (modify-syntax-entry ?\\ ". " readme-debian-mode-syntax-table) - (modify-syntax-entry ?' "w " readme-debian-mode-syntax-table)) - -(defvar font-lock-defaults) ;For XEmacs byte-compilation -;;;###autoload -(defun readme-debian-mode () - "Mode for reading and editing README.Debian files. -Upon saving the visited README.Debian file, the timestamp at the bottom -will be updated. - -\\{readme-debian-mode-map}" - (interactive) - (kill-all-local-variables) - (setq major-mode 'readme-debian-mode) - (setq mode-name "README.Debian") - (make-local-variable 'font-lock-defaults) - (use-local-map readme-debian-mode-map) - (set-syntax-table readme-debian-mode-syntax-table) - (setq font-lock-defaults - '(readme-debian-font-lock-keywords - nil ;; keywords-only? No, let it do syntax via table. - nil ;; case-fold? - nil ;; Local syntax table. - )) - ;; add timestamp update func to write-contents-hooks - (if (or (= emacs-major-version 20) - (string-match "XEmacs" emacs-version)) - (make-local-hook 'write-contents-hooks)) - (add-hook 'write-contents-hooks 'readme-debian-update-timestamp - nil t) - (run-hooks 'readme-debian-mode-hook)) - -(add-to-list 'auto-mode-alist - '("debian/.*README.*Debian$" . readme-debian-mode)) -(add-to-list 'auto-mode-alist - '("^/usr/share/doc/.*/README.*Debian.*$" . readme-debian-mode)) -;;;###autoload(add-to-list 'auto-mode-alist '("debian/.*README.*Debian$" . readme-debian-mode)) -;;;###autoload(add-to-list 'auto-mode-alist '("^/usr/share/doc/.*/README.*Debian.*$" . readme-debian-mode)) - -(run-hooks 'readme-debian-mode-load-hook) - -(provide 'readme-debian) - -;;; readme-debian.el ends here diff --git a/elisp/emacs-goodies-el/align-string.el b/elisp/emacs-goodies-el/align-string.el index c06ba41..c06ba41 100755..100644 --- a/elisp/emacs-goodies-el/align-string.el +++ b/elisp/emacs-goodies-el/align-string.el diff --git a/elisp/emacs-goodies-el/all.el b/elisp/emacs-goodies-el/all.el index f9d1aa0..f9d1aa0 100755..100644 --- a/elisp/emacs-goodies-el/all.el +++ b/elisp/emacs-goodies-el/all.el diff --git a/elisp/emacs-goodies-el/auto-fill-inhibit.el b/elisp/emacs-goodies-el/auto-fill-inhibit.el deleted file mode 100755 index a2b5f81..0000000 --- a/elisp/emacs-goodies-el/auto-fill-inhibit.el +++ /dev/null @@ -1,89 +0,0 @@ -;;; auto-fill-mode-inhibit -- finer grained control over -;;; auto-fill-mode (de)activation -;;; Copyright (c) 2003 Michael Weber <michaelw@debian.org> -;; - -;;; Version: 20030509 -;; - -;;; License: -;; -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License -;; version 2 as published by the Free Software Foundation. -;; -;; This program 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 this program; if not, write to the Free Software -;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA -;; 02111-1307 USA -;; -;; NO-VIRUS CLAUSE: -;; The intent of this license is to protect free redistribution and -;; reuse of the source of the licensed distribution, not to prejudice -;; the authorship rights of programmers of other code to control -;; their original inventions. -;; -;; No portion of this license is to be interpreted as forbidding the -;; reuse of this code or its constituent parts, algorithms, or -;; inventions in commercial products. -;; -;; Nor shall such inclusion be construed to require the GPLing or -;; disclosure of any portions of said commercial products other than -;; those falling under the copyright of the licensed distribution. -;; - -;;; Commentary: -;; -;; To activate auto-fill-mode, add the following line to your Emacs -;; initialization: -;; (add-hook 'text-mode-hook 'turn-on-auto-fill) - -;;; History: -;; -;; 20030509: -;; * activate advice through `defadvice' instead of call to -;; `ad-activate' -;; * emit message if `auto-fill-mode' gets inhibited -;; * add (provide) line -;; * make `auto-fill-inhibit-list' a `defcustom' -;; * fixed docstrings to make M-x checkdoc happy -;; (thanks to psg@debian.org for hints) -;; -;; 20011114: -;; * Initial Version - -;;; Code: -(defcustom auto-fill-inhibit-list nil - "regexep LIST to match against buffer-name to inhibit auto-fill-mode. -An empty list of regexps (the default) retains the original -`auto-fill-mode' behaviour." - :require 'auto-fill-inhibit - :type '(repeat (regexp :tag "Buffer name regexp"))) - -(defadvice auto-fill-mode (before auto-fill-mode-inhibit activate) - "Turn off `auto-fill-mode' on matching buffers. -Buffers which have their names `string-match' on any one regexp in -`auto-fill-inhibit-list'. Unless something is put into this variable, -it behaves transparently to default auto-fill functionality." - - (let ((bufname (buffer-name))) - (if (catch 'match - (mapcar (function (lambda (s) - (if (string-match s bufname) - (throw 'match t)))) - auto-fill-inhibit-list) - nil) - (progn - (message "auto-fill-mode inhibited for this buffer through auto-fill-inhibit-list") - ;;; turn off auto-fill-mode (setting arg0 to `0') - (ad-set-arg 0 0))))) - - -(provide 'auto-fill-inhibit) - -;;; auto-fill-inhibit.el ends here diff --git a/elisp/emacs-goodies-el/bar-cursor.el b/elisp/emacs-goodies-el/bar-cursor.el index 698c671..698c671 100755..100644 --- a/elisp/emacs-goodies-el/bar-cursor.el +++ b/elisp/emacs-goodies-el/bar-cursor.el diff --git a/elisp/emacs-goodies-el/bm.el b/elisp/emacs-goodies-el/bm.el deleted file mode 100755 index c5a4818..0000000 --- a/elisp/emacs-goodies-el/bm.el +++ /dev/null @@ -1,1342 +0,0 @@ -;;; bm.el --- Visible bookmarks in buffer. - -;; Copyrigth (C) 2000-2010 Jo Odland - -;; Author: Jo Odland <jo.odland(at)gmail.com> -;; Version: $Id: bm.el,v 1.2 2010-05-05 13:27:50 psg Exp $ -;; Keywords; bookmark, highlight, faces, persistent -;; URL: http://www.nongnu.org/bm/ -;; Project page: https://savannah.nongnu.org/projects/bm/ - -;; Portions Copyright (C) 2002 by Ben Key -;; Updated by Ben Key <bkey1(at)tampabay.rr.com> on 2002-12-05 -;; to add support for XEmacs - - -;; This file is *NOT* part of GNU Emacs. - -;; This program 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. - -;; This program 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - - -;;; Commentary: - -;;; Description: -;; -;; This package was created because I missed the bookmarks from M$ -;; Visual Studio. I find that they provide an easy way to navigate -;; in a buffer. -;; -;; bm.el provides visible, buffer local, bookmarks and the ability -;; to jump forward and backward to the next bookmark. -;; -;; Features: -;; - Toggle bookmarks with `bm-toggle' and navigate forward and -;; backward in buffer with `bm-next' and `bm-previous'. -;; -;; - Different wrapping modes, see `bm-wrap-search' and `bm-wrap-immediately'. -;; Use `bm-toggle-wrapping' to turn wrapping on/off. Wrapping is only available -;; when `bm-cycle-all-buffers' is nil. -;; -;; - Navigate between bookmarks only in current buffer or cycle through all buffers. -;; Use `bm-cycle-all-buffers' to enable looking for bookmarks across all open buffers. -;; When cycling through bookmarks in all open buffers, the search will always wrap around. -;; -;; - Setting bookmarks based on a regexp, see `bm-bookmark-regexp' and -;; `bm-bookmark-regexp-region'. -;; -;; - Setting bookmark based on line number, see `bm-bookmark-line'. -;; -;; - Goto line position or start of line, see `bm-goto-position'. -;; -;; - Persistent bookmarks (see below). Use `bm-toggle-buffer-persistence' -;; to enable/disable persistent bookmarks (buffer local). -;; -;; - List bookmarks with annotations and context in a separate buffer, -;; see `bm-show' (current buffer) and `bm-show-all' (all buffers). -;; -;; - Remove all bookmarks in current buffer with `bm-remove-all-current-buffer' and -;; all bookmarks in all open buffers with `bm-remove-all-all-buffers'. -;; -;; - Annotate bookmarks, see `bm-bookmark-annotate' and `bm-bookmark-show-annotation'. -;; The annotation is displayed in the messsage area when navigating to a bookmark. -;; Set the variable `bm-annotate-on-create' to t to be prompted for an annotation -;; when bookmark is created. -;; -;; - Different bookmark styles, fringe-only, line-only or both, -;; see `bm-highlight-style'. It is possible to have fringe-markers on left or right side. -;; - - -;;; Known limitations: -;; -;; This package is developed and testet on GNU Emacs 22.x. It should -;; work on all GNU Emacs 21.x, GNU Emacs 23.x and also on XEmacs -;; 21.x with some limitations. -;; -;; There are some incompabilities with lazy-lock when using -;; fill-paragraph. All bookmark below the paragraph being filled -;; will be lost. This issue can be resolved using the `jit-lock-mode' -;; introduced in GNU Emacs 21.1 -;; - - -;;; Installation: -;; -;; To use bm.el, put it in your load-path and add -;; the following to your .emacs -;; -;; (require 'bm) -;; -;; or -;; -;; (autoload 'bm-toggle "bm" "Toggle bookmark in current buffer." t) -;; (autoload 'bm-next "bm" "Goto bookmark." t) -;; (autoload 'bm-previous "bm" "Goto previous bookmark." t) -;; - - -;;; Configuration: -;; -;; To make it easier to use, assign the commands to some keys. -;; -;; M$ Visual Studio key setup. -;; (global-set-key (kbd "<C-f2>") 'bm-toggle) -;; (global-set-key (kbd "<f2>") 'bm-next) -;; (global-set-key (kbd "<S-f2>") 'bm-previous) -;; -;; Click on fringe to toggle bookmarks, and use mouse wheel to move -;; between them. -;; (global-set-key (kbd "<left-fringe> <mouse-5>") 'bm-next-mouse) -;; (global-set-key (kbd "<left-fringe> <mouse-4>") 'bm-previous-mouse) -;; (global-set-key (kbd "<left-fringe> <mouse-1>") 'bm-toggle-mouse) -;; -;; If you would like the markers on the right fringe instead of the -;; left, add the following to line: -;; -;; (setq bm-marker 'bm-marker-right) -;; - - - -;;; Persistence: -;; -;; Bookmark persistence is achieved by storing bookmark data in a -;; repository when a buffer is killed. The repository is saved to -;; disk on exit. See `bm-repository-file'. The maximum size of the -;; repository is controlled by `bm-repository-size'. -;; -;; The buffer local variable `bm-buffer-persistence' decides if -;; bookmarks in a buffer is persistent or not. Non-file buffers -;; can't have persistent bookmarks, except for *info* and -;; indirect buffers. -;; -;; Bookmarks are non-persistent as default. To have bookmarks -;; persistent as default add the following line to .emacs. -;; -;; ;; make bookmarks persistent as default -;; (setq-default bm-buffer-persistence t) - -;; Use the function `bm-toggle-buffer-persistence' to toggle -;; bookmark persistence. -;; -;; To have automagic bookmark persistence we need to add some -;; functions to the following hooks. Insert the following code -;; into your .emacs file: -;; -;; If you are using desktop or other packages that restore buffers -;; on start up, bookmarks will not be restored. When using -;; `after-init-hook' to restore the repository, it will be restored -;; *after* .emacs is finished. To load the repository when bm is -;; loaded set the variable `bm-restore-repository-on-load' to t, -;; *before* loading bm (and don't use the `after-init-hook'). -;; -;; ;; Make sure the repository is loaded as early as possible -;; (setq bm-restore-repository-on-load t) -;; (require 'bm) -;; -;; ;; Loading the repository from file when on start up. -;; (add-hook' after-init-hook 'bm-repository-load) -;; -;; ;; Restoring bookmarks when on file find. -;; (add-hook 'find-file-hooks 'bm-buffer-restore) -;; -;; ;; Saving bookmark data on killing a buffer -;; (add-hook 'kill-buffer-hook 'bm-buffer-save) -;; -;; ;; Saving the repository to file when on exit. -;; ;; kill-buffer-hook is not called when Emacs is killed, so we -;; ;; must save all bookmarks first. -;; (add-hook 'kill-emacs-hook '(lambda nil -;; (bm-buffer-save-all) -;; (bm-repository-save))) -;; -;; ;; Update bookmark repository when saving the file. -;; (add-hook 'after-save-hook 'bm-buffer-save) -;; -;; ;; Restore bookmarks when buffer is reverted. -;; (add-hook 'after-revert-hook 'bm-buffer-restore) -;; -;; -;; The `after-save-hook' and `after-revert-hook' is not necessary to -;; use to achieve persistence, but it makes the bookmark data in -;; repository more in sync with the file state. -;; -;; The `after-revert-hook' might cause trouble when using packages -;; that automatically reverts the buffer (like vc after a check-in). -;; This can easily be avoided if the package provides a hook that is -;; called before the buffer is reverted (like `vc-before-checkin-hook'). -;; Then new bookmarks can be saved before the buffer is reverted. -;; -;; ;; make sure bookmarks is saved before check-in (and revert-buffer) -;; (add-hook 'vc-before-checkin-hook 'bm-buffer-save) - - - -;;; Acknowledgements: -;; -;; - The use of overlays for bookmarks was inspired by highline.el by -;; Vinicius Jose Latorre <vinicius(at)cpqd.com.br>. -;; - Thanks to Ben Key for XEmacs support. -;; - Thanks to Peter Heslin for notifying me on the incompability with -;; lazy-lock. -;; - Thanks to Christoph Conrad for adding support for goto line position -;; in bookmarks and simpler wrapping. -;; - Thanks to Jan Rehders for adding support for different bookmark styles. -;; - Thanks to Dan McKinley <mcfunley(at)gmail.com> for inspiration to add support -;; for listing bookmarks in all buffers, `bm-show-all'. -;; (http://www.emacswiki.org/cgi-bin/wiki/bm-ext.el) -;; - Thanks to Jonathan Kotta <jpkotta(at)gmail.com> for mouse support and fringe -;; markers on left or right side. - - -;;; Change log: - -;; Changes in 1.43 -;; - Fixed spelling. Thanks to Juanma Barranquero <lekktu(at)gmail.com> for patch. -;; -;; Changes in 1.42 -;; - Fixed bug(#29536) - Next/previous does not wrap when `bm-cycle-all-buffers' t -;; and only bookmarks in one buffer. -;; -;; Changes in 1.41 -;; - Updated documentation to satisfy `checkdoc'. -;; -;; Changes in 1.38 -;; - Added support for bookmark search across buffers. See `bm-cycle-all-buffers'. -;; - Added support for mouse navigation (#28863). See `bm-toggle-mouse', `bm-next-mouse' -;; and `bm-previous-mouse'. -;; - Added support for markers on the right fringe (#28863). -;; -;; Changes in 1.36 -;; - Added support for persistent bookmarks in non-file buffers (Info buffers, indirect-buffers). -;; - Fixed bug(#26077) - bm asks for annotation when restoring bookmarks for bookmarks which -;; already have an annotation. -;; -;; Changes in 1.35 -;; - Added utf-8 encoding on `bm-repository-file' -;; - Removed compile check on fringe support. -;; -;; Changes in 1.34 -;; - Added support for bookmarks in fringe (Patch from Jan Rehders <cmdkeen(at)gmx.de>) -;; - Fixed bugs with `bm-next', `bm-previous' and `bm-goto'. -;; - Removed line format variables, `bm-show-header-string' and `bm-show-format-string'. -;; - Added `bm-show-all' for displaying bookmarks in all buffers. -;; -;; Changes in 1.32 -;; - Added change log. -;; -;; Changes in 1.31 -;; - Renamed function `bm-extract' to `bm-show' -;; - Fixed annotation bug in `bm-bookmark-regexp-region'. -;; -;; Changes in 1.30 -;; - New format on file repository. -;; - Support for annotation of bookmarks. See variable `bm-annotate-on-create', -;; `bm-bookmark-annotate' and `bm-bookmark-show-annotation'. -;; - Added context to help restoring bookmarks correctly, -;; see `bm-bookmark-context-size'. -;; - Renamed function `bm-repository-empty' to `bm-repositoty-clear'. -;; - - -;;; Todo: -;; -;; - Prevent the bookmark (overlay) from being extended when -;; inserting (before, inside or after) the bookmark in XEmacs. This -;; is due to the missing support for overlay hooks i XEmacs. -;; - - -;;; Code: -;; - -(eval-and-compile - ;; avoid compile waring on unbound variable - (require 'info) - - ;; xemacs needs overlay emulation package - (unless (fboundp 'overlay-lists) - (require 'overlay))) - - -(defconst bm-version "$Id: bm.el,v 1.2 2010-05-05 13:27:50 psg Exp $" - "CVS version of bm.el.") - -(defconst bm-bookmark-repository-version 2 - "The repository version.") - -(defgroup bm nil - "Visible, buffer local bookmarks." - :link '(emacs-library-link :tag "Source Lisp File" "bm.el") - :group 'faces - :group 'editing - :prefix "bm-") - -(defcustom bm-highlight-style 'bm-highlight-only-line - "*Specify how bookmars are highlighted." - :type '(choice (const bm-highlight-only-line) - (const bm-highlight-only-fringe) - (const bm-highlight-line-and-fringe)) - :group 'bm) - -(defcustom bm-face 'bm-face - "*Specify face used to highlight the current line." - :type 'face - :group 'bm) - - -(defcustom bm-persistent-face 'bm-persistent-face - "*Specify face used to highlight the current line for persistent bookmarks." - :type 'face - :group 'bm) - -(defcustom bm-priority 0 - "*Specify bm overlay priority. - -Higher integer means higher priority, so bm overlay will have precedence -over overlays with lower priority. *Don't* use negative number." - :type 'integer - :group 'bm) - - -(defface bm-face - '((((class grayscale) - (background light)) (:background "DimGray")) - (((class grayscale) - (background dark)) (:background "LightGray")) - (((class color) - (background light)) (:foreground "White" :background "DarkOrange1")) - (((class color) - (background dark)) (:foreground "Black" :background "DarkOrange1"))) - "Face used to highlight current line." - :group 'bm) - - -(defface bm-persistent-face - '((((class grayscale) - (background light)) (:background "DimGray")) - (((class grayscale) - (background dark)) (:background "LightGray")) - (((class color) - (background light)) (:foreground "White" :background "DarkBlue")) - (((class color) - (background dark)) (:foreground "White" :background "DarkBlue"))) - "Face used to highlight current line if bookmark is persistent." - :group 'bm) - - -(defcustom bm-fringe-face 'bm-fringe-face - "*Specify face used to highlight the fringe." - :type 'face - :group 'bm) - -(defcustom bm-fringe-persistent-face 'bm-fringe-persistent-face - "*Specify face used to highlight the fringe for persistent bookmarks." - :type 'face - :group 'bm) - -(defface bm-fringe-face - '((((class grayscale) - (background light)) (:background "DimGray")) - (((class grayscale) - (background dark)) (:background "LightGray")) - (((class color) - (background light)) (:foreground "White" :background "DarkOrange1")) - (((class color) - (background dark)) (:foreground "Black" :background "DarkOrange1"))) - "Face used to highlight bookmarks in the fringe." - :group 'bm) - -(defface bm-fringe-persistent-face - '((((class grayscale) - (background light)) (:background "DimGray")) - (((class grayscale) - (background dark)) (:background "LightGray")) - (((class color) - (background light)) (:foreground "White" :background "DarkBlue")) - (((class color) - (background dark)) (:foreground "White" :background "DarkBlue"))) - "Face used to highlight bookmarks in the fringe if bookmark is persistent." - :group 'bm) - - -(defcustom bm-annotate-on-create nil - "*Specify if bookmarks must be annotated when created. - -nil, don't ask for an annotation when creating a bookmark. -t, always ask for annotation when creating a bookmark." - :type 'boolean - :group 'bm) - - -(defcustom bm-wrap-search t - "*Specify if bookmark search should wrap. - -nil, don't wrap when there are no more bookmarks. -t, wrap." - :type 'boolean - :group 'bm) - - -(defcustom bm-wrap-immediately t - "*Specify if a wrap should be announced or not. -Only has effect when `bm-wrap-search' is t. - -nil, announce before wrapping. -t, don't announce." - :type 'boolean - :group 'bm) - -(defcustom bm-cycle-all-buffers nil - "*Specify if bookmark search is done across buffers. -This will ignore the `bm-wrap-search' setting. - -nil, only search in current buffer. -t, search in all open buffers." - :type 'boolean - :group 'bm) - -(defcustom bm-recenter nil - "*Specify if the buffer should be recentered after jumping to a bookmark." - :type 'boolean - :group 'bm) - - -(defcustom bm-goto-position t - "*Specify the position, on line, to go to when jumping to a bookmark. - -nil, goto start of line. -t, goto position on the line where the bookmark was set." - :type 'boolean - :group 'bm) - - -(defcustom bm-repository-file (expand-file-name "~/.bm-repository") - "*Filename to store persistent bookmarks across sessions. - -nil, the repository will not be persistent." - :type 'string - :group 'bm) - - -(defcustom bm-repository-size 100 - "*Size of persistent repository. If nil then there if no limit." - :type 'integer - :group 'bm) - - -(defcustom bm-buffer-persistence nil - "*Specify if bookmarks in a buffer should be persistent. -Buffer local variable. - -nil, don't save bookmarks. -t, save bookmarks." - :type 'boolean - :group 'bm) -(make-variable-buffer-local 'bm-buffer-persistence) - - -(defcustom bm-restore-on-mismatch nil - "*Specify if bookmarks should be restored if there is a buffer size mismatch. -DEPRECATED: Only in use for version 1 of repository. - -nil, don't restore. -t, restore if possible." - :type 'boolean - :group 'bm) - - -(defvar bm-restore-repository-on-load nil - "Specify if repository should be restored when loading bm. - -nil, don't restore repository on load. -t, restore repository when this file is loaded. This must be set -before bm is loaded.") - -(defvar bm-repository nil - "Alist with all persistent bookmark data.") - -(defvar bm-regexp-history nil - "Bookmark regexp history.") - -(defvar bm-annotation-history nil - "Bookmark annotation history.") - -(defvar bm-bookmark-context-size 16 - "The size of context stored, before and after, for each bookmark.") - -(defvar bm-wrapped nil - "State variable to support wrapping.") -(make-variable-buffer-local 'bm-wrapped) - -(defvar bm-marker 'bm-marker-left - "Fringe marker side. Left of right.") - -(define-fringe-bitmap 'bm-marker-left [#x00 #x00 #xFC #xFE #x0F #xFE #xFC #x00]) -(define-fringe-bitmap 'bm-marker-right [#x00 #x00 #x3F #x7F #xF0 #x7F #x3F #x00]) - - -(defun bm-customize nil - "Customize bm group." - (interactive) - (customize-group 'bm)) - - -(defun bm-bookmark-annotate (&optional bookmark annotation) - "Annotate bookmark at point or the BOOKMARK specified as parameter. - -If ANNOTATION is provided use this, and not prompt for input." - (interactive) - (if (null bookmark) - (setq bookmark (bm-bookmark-at (point)))) - - (if (bm-bookmarkp bookmark) - (progn - (if (null annotation) - (setq annotation (read-from-minibuffer "Annotation: " nil nil nil 'bm-annotation-history))) - (overlay-put bookmark 'annotation annotation)) (if (interactive-p) (message "No bookmark at point")))) - - -(defun bm-bookmark-show-annotation (&optional bookmark) - "Show annotation for bookmark. -Either the bookmark at point or the BOOKMARK specified as parameter." - (interactive) - (if (null bookmark) - (setq bookmark (bm-bookmark-at (point)))) - - (if (bm-bookmarkp bookmark) - (progn - (let ((annotation (overlay-get bookmark 'annotation))) - (if annotation - (message annotation) - (message "No annotation for current bookmark.")))) - (message "No bookmark at current line."))) - -(defun bm-line-highlighted () - "Test if line is highlighted." - (or (equal bm-highlight-style 'bm-highlight-only-line) - (equal bm-highlight-style 'bm-highlight-line-and-fringe))) - -(defun bm-fringe-highlighted () - "Test if fringe is highlighted." - (or (equal bm-highlight-style 'bm-highlight-only-fringe) - (equal bm-highlight-style 'bm-highlight-line-and-fringe))) - -(defun bm-bookmark-add (&optional annotation) - "Add bookmark at current line. - -If ANNOTATION is provided use this, and do not prompt for input. -Only used if `bm-annotate-on-create' is true. - -Do nothing if bookmark is present." - (if (bm-bookmark-at (point)) - nil ; bookmark exists - (let ((bookmark (make-overlay (bm-start-position) (bm-end-position))) - (hlface (if bm-buffer-persistence bm-persistent-face bm-face)) - (hlface-fringe (if bm-buffer-persistence bm-fringe-persistent-face bm-fringe-face))) - ;; set market - (overlay-put bookmark 'position (point-marker)) - ;; select bookmark face - (when (bm-line-highlighted) - (overlay-put bookmark 'face hlface)) - (overlay-put bookmark 'evaporate t) - (overlay-put bookmark 'category 'bm) - (when (bm-fringe-highlighted) - (let* ((marker-string "*fringe-dummy*") - (marker-length (length marker-string))) - (put-text-property 0 marker-length 'display - (list (if (eq bm-marker 'bm-marker-left) - 'left-fringe - 'right-fringe) - bm-marker hlface-fringe) - marker-string) - (overlay-put bookmark 'before-string marker-string))) - (if (or bm-annotate-on-create annotation) - (bm-bookmark-annotate bookmark annotation)) - (unless (featurep 'xemacs) - ;; gnu emacs specific features - (overlay-put bookmark 'priority bm-priority) - (overlay-put bookmark 'modification-hooks '(bm-freeze)) - (overlay-put bookmark 'insert-in-front-hooks '(bm-freeze-in-front)) - (overlay-put bookmark 'insert-behind-hooks '(bm-freeze))) - bookmark))) - - -(defun bm-bookmark-remove (&optional bookmark) - "Remove bookmark at point or the BOOKMARK specified as parameter." - (if (null bookmark) - (setq bookmark (bm-bookmark-at (point)))) - - (if (bm-bookmarkp bookmark) - (delete-overlay bookmark))) - - -;;;###autoload -(defun bm-toggle nil - "Toggle bookmark at point." - (interactive) - (let ((bookmark (bm-bookmark-at (point)))) - (if bookmark - (bm-bookmark-remove bookmark) - (bm-bookmark-add)))) - - -;;;###autoload -(defun bm-toggle-mouse (ev) - "Toggle a bookmark with a mouse click. -EV is the mouse event." - (interactive "e") - (save-excursion - (mouse-set-point ev) - (bm-toggle))) - - -(defun bm-count nil - "Count the number of bookmarks in buffer." - (let ((bookmarks (bm-lists))) - (+ (length (car bookmarks)) (length (cdr bookmarks))))) - - -(defun bm-start-position nil - "Return the bookmark start position." - (point-at-bol)) - - -(defun bm-end-position nil - "Return the bookmark end position." - (min (point-max) (+ 1 (point-at-eol)))) - - -(defun bm-freeze-in-front (overlay after begin end &optional len) - "Prevent overlay from being extended to multiple lines. -When inserting in front of overlay move overlay forward. - -OVERLAY the overlay being modified. -AFTER nil when called before, t when called after modification. -BEGIN the beginning of the text being modified. -END the end of the text being modified. -When called after, the length of the modification is passed as LEN. - -See Overlay Properties in the Emacs manual for more information: -http://www.gnu.org/s/emacs/manual/html_node/elisp/Overlay-Properties.html" - (if after - (move-overlay overlay (bm-start-position) (bm-end-position)))) - - -(defun bm-freeze (overlay after begin end &optional len) - "Prevent OVERLAY from being extended to multiple lines. -When inserting inside or behind the overlay, keep the original start postion. - -OVERLAY the overlay being modified. -AFTER nil when called before, t when called after modification. -BEGIN the beginning of the text being modified. -END the end of the text being modified. -When called after, the length of the modification is passed as LEN. - -See Overlay Properties in the Emacs manual for more information: -http://www.gnu.org/s/emacs/manual/html_node/elisp/Overlay-Properties.html" - (if after - (let ((bm-start (overlay-start overlay))) - (if bm-start - (move-overlay overlay - bm-start - (save-excursion - (goto-char bm-start) - (bm-end-position))))))) - - -(defun bm-equal (first second) - "Compare two bookmarks. Return t if FIRST is equal to SECOND." - (if (and (bm-bookmarkp first) (bm-bookmarkp second)) - (= (overlay-start first) (overlay-start second)) - nil)) - - -(defun bm-bookmarkp (bookmark) - "Return the BOOKMARK if overlay is a bookmark." - (if (and (overlayp bookmark) - (string= (overlay-get bookmark 'category) "bm")) - bookmark - nil)) - - -(defun bm-bookmark-at (point) - "Get bookmark at POINT." - (let ((overlays (overlays-at point)) - (bookmark nil)) - (while (and (not bookmark) overlays) - (if (bm-bookmarkp (car overlays)) - (setq bookmark (car overlays)) - (setq overlays (cdr overlays)))) - bookmark)) - - -(defun bm-lists (&optional direction) - "Return a pair of lists giving all the bookmarks of the current buffer. -The car has all the bookmarks before the overlay center; -the cdr has all the bookmarks after the overlay center. -A bookmark implementation of `overlay-list'. - -If optional argument DIRECTION is provided, only return bookmarks -in the specified direction." - (overlay-recenter (point)) - (cond ((equal 'forward direction) - (cons nil (remq nil (mapcar 'bm-bookmarkp (cdr (overlay-lists)))))) - ((equal 'backward direction) - (cons (remq nil (mapcar 'bm-bookmarkp (car (overlay-lists)))) nil)) - (t - (cons (remq nil (mapcar 'bm-bookmarkp (car (overlay-lists)))) - (remq nil (mapcar 'bm-bookmarkp (cdr (overlay-lists)))))))) - - -;;;###autoload -(defun bm-next nil - "Goto next bookmark." - (interactive) - (if (= (bm-count) 0) - (if bm-cycle-all-buffers - (bm-first-in-next-buffer) - (message "No bookmarks defined.")) - (let ((bm-list-forward (cdr (bm-lists 'forward)))) - ;; remove bookmark at point - (if (bm-equal (bm-bookmark-at (point)) (car bm-list-forward)) - (setq bm-list-forward (cdr bm-list-forward))) - - (if bm-list-forward - (bm-goto (car bm-list-forward)) - (cond (bm-cycle-all-buffers (bm-first-in-next-buffer)) - (bm-wrap-search (bm-wrap-forward)) - (t (message "No next bookmark."))))))) - -(defun bm-wrap-forward nil - "Goto next bookmark, wrapping." - (if (or bm-wrapped bm-wrap-immediately) - (progn - (bm-first) - (message "Wrapped.")) - (setq bm-wrapped t) ; wrap on next goto - (message "Failed: No next bookmark."))) - - -;;;###autoload -(defun bm-next-mouse (ev) - "Go to the next bookmark with the scroll wheel. -EV is the mouse event." - (interactive "e") - (let ((old-selected-window (selected-window))) - (select-window (posn-window (event-start ev))) - (bm-next) - (select-window old-selected-window))) - - -;;;###autoload -(defun bm-previous nil - "Goto previous bookmark." - (interactive) - (if (= (bm-count) 0) - (if bm-cycle-all-buffers - (bm-last-in-previous-buffer) - (message "No bookmarks defined.")) - (let ((bm-list-backward (car (bm-lists 'backward)))) - ;; remove bookmark at point - (if (bm-equal (bm-bookmark-at (point)) (car bm-list-backward)) - (setq bm-list-backward (cdr bm-list-backward))) - - (if bm-list-backward - (bm-goto (car bm-list-backward)) - - (cond (bm-cycle-all-buffers (bm-last-in-previous-buffer)) - (bm-wrap-search (bm-wrap-backward)) - (t (message "No previous bookmark."))))))) - -(defun bm-wrap-backward nil - "Goto previous bookmark, wrapping." - (if (or bm-wrapped bm-wrap-immediately) - (progn - (bm-last) - (message "Wrapped.")) - (setq bm-wrapped t) ; wrap on next goto - (message "Failed: No previous bookmark."))) - - -;;;###autoload -(defun bm-previous-mouse (ev) - "Go to the previous bookmark with the scroll wheel. -EV is the mouse event." - (interactive "e") - (let ((old-selected-window (selected-window))) - (select-window (posn-window (event-start ev))) - (bm-previous) - (select-window old-selected-window))) - - -(defun bm-first-in-next-buffer nil - "Goto first bookmark in next buffer." - (interactive) - (let ((buffers - (save-excursion - (remq nil (mapcar '(lambda (buffer) - (set-buffer buffer) - (if (> (bm-count) 0) - buffer - nil)) - ;; drop current buffer from list - (cdr (buffer-list))))))) - - (if buffers - (progn - (switch-to-buffer (car buffers)) - (message "Switched to '%s'" (car buffers)) - (bm-first)) - ;; no bookmarks found in other open buffers, - ;; wrap in current buffer? - (if bm-wrap-search - (bm-wrap-forward) - (message "No bookmarks found in other open buffers."))))) - - - -(defun bm-last-in-previous-buffer nil - "Goto last bookmark in previous buffer." - (interactive) - (let ((buffers - (save-excursion - (remq nil (mapcar '(lambda (buffer) - (set-buffer buffer) - (if (> (bm-count) 0) - buffer - nil)) - ;; drop current buffer from list - (reverse (cdr (buffer-list)))))))) - - (if buffers - (progn - (switch-to-buffer (car buffers)) - (message "Switched to '%s'" (car buffers)) - (bm-last)) - ;; no bookmarks found in other open buffers, - ;; wrap in current buffer? - (if bm-wrap-search - (bm-wrap-backward) - (message "No bookmarks found in other open buffers."))))) - - -(defun bm-first nil - "Goto first bookmark in buffer." - (goto-char (point-min)) - (if (bm-bookmark-at (point)) - ;; bookmark at beginning of buffer, stop looking - nil - (bm-next))) - - -(defun bm-last nil - "Goto first bookmark in buffer." - (goto-char (point-max)) - (if (bm-bookmark-at (point)) - ;; bookmark at end of buffer, stop looking - nil - (bm-previous))) - - -(defun bm-remove-all-all-buffers nil - "Delete all visible bookmarks in all open buffers." - (interactive) - (save-excursion - (mapcar '(lambda (buffer) - (set-buffer buffer) - (bm-remove-all-current-buffer)) - (buffer-list)))) - - -(defun bm-remove-all-current-buffer nil - "Delete all visible bookmarks in current buffer." - (interactive) - (let ((bookmarks (bm-lists))) - (mapc 'bm-bookmark-remove (append (car bookmarks) (cdr bookmarks))))) - - -(defun bm-toggle-wrapping nil - "Toggle wrapping on/off, when searching for next/previous bookmark." - (interactive) - (setq bm-wrap-search (not bm-wrap-search)) - (if bm-wrap-search - (message "Wrapping on.") - (message "Wrapping off."))) - - -(defun bm-toggle-cycle-all-buffers nil - "Toggle searching across all buffers." - (interactive) - (setq bm-cycle-all-buffers (not bm-cycle-all-buffers)) - (if bm-cycle-all-buffers - (message "Cycle all buffers on") - (message "Cycle all buffers off"))) - - -(defun bm-goto (bookmark) - "Goto specified BOOKMARK." - (if (bm-bookmarkp bookmark) - (progn - (if bm-goto-position - (goto-char (marker-position (overlay-get bookmark 'position))) - (goto-char (overlay-start bookmark))) - (setq bm-wrapped nil) ; turn off wrapped state - (if bm-recenter - (recenter)) - (let ((annotation (overlay-get bookmark 'annotation))) - (if annotation - (message annotation)))) - (message "Bookmark not found."))) - - -(defun bm-bookmark-regexp nil - "Set bookmark on lines that match regexp." - (interactive) - (bm-bookmark-regexp-region (point-min) (point-max))) - - -(defun bm-bookmark-regexp-region (beg end) - "Set bookmark on lines that match regexp in region. -Region defined by BEG and END." - (interactive "r") - (let ((regexp (read-from-minibuffer - "regexp: " nil nil nil 'bm-regexp-history)) - (annotation nil) - (count 0)) - (save-excursion - (if bm-annotate-on-create - (setq annotation (read-from-minibuffer - "Annotation: " nil nil nil 'bm-annotation-history))) - - (goto-char beg) - (while (re-search-forward regexp end t) - (bm-bookmark-add annotation) - (setq count (1+ count)) - (forward-line 1))) - (message "%d bookmark(s) created." count))) - - -(defun bm-bookmark-line (line) - "Set a bookmark on the specified LINE." - (interactive "nSet a bookmark on line: ") - (let ((lines (count-lines (point-min) (point-max)))) - (if (> line lines) - (message "Unable to set bookmark at line %d. Only %d lines in buffer." - line lines) - (goto-line line) - (bm-bookmark-add)))) - - -(defun bm-show-all nil - "Show bookmarked lines in all buffers." - (interactive) - (let ((lines - (save-excursion - (mapconcat '(lambda (buffer) - (set-buffer buffer) - (bm-show-extract-bookmarks)) - (buffer-list) "")))) - (bm-show-display-lines lines))) - - -(defun bm-show nil - "Show bookmarked lines in current buffer." - (interactive) - (bm-show-display-lines (bm-show-extract-bookmarks))) - - -(defun bm-show-extract-bookmarks nil - "Extract bookmarks from current buffer." - (let ((bookmarks (bm-lists))) - (mapconcat - '(lambda (bm) - (let ((string - (format "%-20s %-20s %s" - (format "%s:%d" (buffer-name) (count-lines (point-min) (overlay-start bm))) - (let ((annotation (overlay-get bm 'annotation))) - (if (null annotation) "" annotation)) - (buffer-substring (overlay-start bm) (overlay-end bm))))) - (put-text-property 0 (length string) 'bm-buffer (buffer-name) string) - (put-text-property 0 (length string) 'bm-bookmark bm string) - string)) - (append - ;; xemacs has the list sorted after buffer position, while - ;; gnu emacs list is sorted relative to current position. - (if (featurep 'xemacs) - (car bookmarks) - (reverse (car bookmarks))) - (cdr bookmarks)) ""))) - - -(defun bm-show-display-lines (lines) - "Show bookmarked LINES to the *bm-bookmarks* buffer." - (if (= (length lines) 0) - (message "No bookmarks defined.") - (with-output-to-temp-buffer "*bm-bookmarks*" - (set-buffer standard-output) - (insert lines) - (bm-show-mode) - (setq buffer-read-only t)))) - - -(defun bm-show-goto-bookmark nil - "Goto the bookmark on current line in the *bm-bookmarks* buffer." - (interactive) - (let ((buffer-name (get-text-property (point) 'bm-buffer)) - (bookmark (get-text-property (point) 'bm-bookmark))) - (if (null buffer-name) - (message "No bookmark at this line.") - (pop-to-buffer (get-buffer buffer-name)) - (bm-goto bookmark)))) - - -(defun bm-show-bookmark nil - "Show the bookmark on current line in the *bm-bookmarks* buffer." - (interactive) - (let ((buffer-name (get-text-property (point) 'bm-buffer)) - (bookmark (get-text-property (point) 'bm-bookmark))) - (if (null buffer-name) - (message "No bookmark at this line.") - (let ((current-buffer (current-buffer))) - (pop-to-buffer (get-buffer buffer-name)) - (bm-goto bookmark) - (pop-to-buffer current-buffer))))) - - -(defvar bm-show-mode-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "RET") 'bm-show-goto-bookmark) - (define-key map (kbd "SPC") 'bm-show-bookmark) - map) - "Keymap for `bm-show-mode'.") - - -(defun bm-show-mode nil - "Major mode for `bm-show' buffers." - (interactive) - (kill-all-local-variables) - (setq major-mode 'bm-show-mode) - (setq mode-name "bm-bookmarks") - (use-local-map bm-show-mode-map)) - - -(defun bm-toggle-buffer-persistence nil - "Toggle if a buffer has persistent bookmarks or not." - (interactive) - (if bm-buffer-persistence - ;; turn off - (progn - (setq bm-buffer-persistence nil) - (bm-repository-remove (bm-buffer-file-name)) ; remove from repository - (message "Bookmarks in buffer are not persistent.")) - ;; turn on - (if (not (null (bm-buffer-file-name))) - (progn - (setq bm-buffer-persistence (not bm-buffer-persistence)) - (bm-buffer-save) ; add to repository - (message "Bookmarks in buffer are persistent.")) - (message "Unable to set persistent mode on a non-file buffer."))) - - ;; change color on bookmarks - (let ((bookmarks (bm-lists))) - (mapc '(lambda (bookmark) - (if bm-buffer-persistence - (overlay-put bookmark 'face bm-persistent-face) - (overlay-put bookmark 'face bm-face))) - (append (car bookmarks) (cdr bookmarks))))) - - -(defun bm-get-position-from-context (bookmark) - "Get position of BOOKMARK based on context. -If we find the context before the old bookmark we use it, -otherwise we use the context after." - (save-excursion - (let ((point nil) - (before (cdr (assoc 'before-context-string bookmark))) - (after (cdr (assoc 'after-context-string bookmark)))) - - ;; search forward for context - (if (and after (search-forward after (point-max) t)) - (progn - (goto-char (match-beginning 0)) - (setq point (point)))) - - ;; search backward for context - (if (and before (search-backward before (point-min) t)) - (progn - (goto-char (match-end 0)) - (setq point (point)))) - point))) - - -(defun bm-buffer-restore nil - "Restore bookmarks saved in the repository for the current buffer." - (interactive) - (let ((buffer-data (assoc (bm-buffer-file-name) bm-repository))) - (if buffer-data - (let ((version (cdr (assoc 'version buffer-data)))) - (cond ((= version 2) - (bm-buffer-restore-2 buffer-data)) - (t - (bm-buffer-restore-1 buffer-data)))) - (if (interactive-p) (message "No bookmarks in repository."))))) - - -(defun bm-buffer-restore-all nil - "Restore bookmarks in all buffers." - (save-current-buffer - (mapc '(lambda (buffer) - (set-buffer buffer) - (bm-buffer-restore)) - (buffer-list)))) - -(defun bm-buffer-restore-1 (buffer-data) - "Restore bookmarks from version 1 format. -BUFFER-DATA is the content of `bm-repository-file'." - (let ((buffer-size-match (equal (point-max) (cdr (assoc 'size buffer-data)))) - (positions (cdr (assoc 'positions buffer-data)))) - - ;; validate buffer size - (if (or buffer-size-match - bm-restore-on-mismatch) - ;; restore bookmarks - (let ((pos nil) - (count 0)) - - (setq bm-buffer-persistence t) ; enable persistence - (save-excursion - (while positions - (setq pos (car positions)) - - (if (and (< pos (point-min)) - (> (point-max) pos)) - nil ; outside buffer, skip bookmark - (goto-char pos) - (bm-bookmark-add) - (setq count (1+ count)) - (setq positions (cdr positions))))) - - (if buffer-size-match - (message "%d bookmark(s) restored." count) - (message "Buffersize mismatch. %d bookmarks restored." count))) - - ;; size mismatch - (bm-repository-remove (buffer-file-name)) - (message "Buffersize mismatch. No bookmarks restored.")))) - - -(defun bm-buffer-restore-2 (buffer-data) - "Restore bookmarks from version 2 format. -BUFFER-DATA is the content of `bm-repository-file'." - (let ((buffer-size-match (equal (point-max) (cdr (assoc 'size buffer-data)))) - (bookmarks (cdr (assoc 'bookmarks buffer-data)))) - - ;; restore bookmarks - (let ((pos nil) - (count 0)) - - (setq bm-buffer-persistence t) ; enable persistence - (save-excursion - (while bookmarks - (let ((pos - (if buffer-size-match - (cdr (assoc 'position (car bookmarks))) - (bm-get-position-from-context (car bookmarks)))) - (bm nil) - (annotation (cdr (assoc 'annotation (car bookmarks))))) - - (if (and (< pos (point-min)) - (> (point-max) pos)) - nil ; outside buffer, skip bookmark - (goto-char pos) - (setq bm (bm-bookmark-add annotation)) - (setq count (1+ count)) - (setq bookmarks (cdr bookmarks)))))) - - (if buffer-size-match - (message "%d bookmark(s) restored." count) - (message "%d bookmark(s) restored based on context." count))))) - - -(defun bm-buffer-save nil - "Save all bookmarks to repository." - (interactive) - (if (not (null (bm-buffer-file-name))) - (if bm-buffer-persistence - (let ((buffer-data - (list - (bm-buffer-file-name) - (cons 'version bm-bookmark-repository-version) - (cons 'size (point-max)) - (cons 'timestamp (current-time)) - (cons 'bookmarks - (let ((bookmarks (bm-lists))) - (mapcar - '(lambda (bm) - (let ((position (marker-position (overlay-get bm 'position)))) - (list - (cons 'position position) - (cons 'annotation (overlay-get bm 'annotation)) - (cons 'before-context-string - (if (>= (point-min) (- position bm-bookmark-context-size)) - nil - (buffer-substring-no-properties - (- position bm-bookmark-context-size) position))) - (cons 'after-context-string - (if (>= (+ position bm-bookmark-context-size) (point-max)) - nil - (buffer-substring-no-properties - position (+ position bm-bookmark-context-size)))) - ))) - (append (car bookmarks) (cdr bookmarks)))))))) - - ;; remove if exists - (bm-repository-remove (car buffer-data)) - - ;; add if there exists bookmarks - (let ((count (length (cdr (assoc 'bookmarks buffer-data))))) - (if (> count 0) - (bm-repository-add buffer-data)) - (if (interactive-p) - (message "%d bookmark(s) saved to repository." count)))) - - (if (interactive-p) - (message "No bookmarks saved. Buffer is not persistent."))) - - (if (interactive-p) - (message "Unable to save bookmarks in non-file buffers.")))) - - -(defun bm-buffer-save-all nil - "Save bookmarks in all buffers." - (save-current-buffer - (mapc '(lambda (buffer) - (set-buffer buffer) - (bm-buffer-save)) - (buffer-list)))) - - -(defun bm-repository-add (data) - "Add DATA for a buffer to the repository." - ;; appending to list, makes the list sorted by time - (setq bm-repository (append bm-repository (list data))) - - ;; remove oldest element if repository is too large - (while (and bm-repository-size - (> (length bm-repository) bm-repository-size)) - (setq bm-repository (cdr bm-repository)))) - - -(defun bm-repository-remove (key) - "Remove data for a buffer from the repository identified by KEY." - (let ((repository nil)) - (if (not (assoc key bm-repository)) - ;; don't exist in repository, do nothing - nil - ;; remove all occurances - (while bm-repository - (if (not (equal key (car (car bm-repository)))) - (setq repository (append repository (list (car bm-repository))))) - (setq bm-repository (cdr bm-repository))) - (setq bm-repository repository)))) - - -(defun bm-repository-load (&optional file) - "Load the repository from the FILE specified or to `bm-repository-file'." - (if (null file) - (setq file bm-repository-file)) - (if (and file - (file-readable-p file)) - (let ((repository-buffer (find-file-noselect file))) - (setq bm-repository (with-current-buffer repository-buffer - (goto-char (point-min)) - (read (current-buffer)))) - (kill-buffer repository-buffer)))) - - -(defun bm-repository-save (&optional file) - "Save the repository to the FILE specified or to `bm-repository-file'." - (if (null file) - (setq file bm-repository-file)) - (if (and file - (file-writable-p file)) - (let ((repository-buffer (find-file-noselect file))) - (with-current-buffer repository-buffer - (erase-buffer) - (set-buffer-file-coding-system 'utf-8) - (insert ";; bm.el -- persistent bookmarks. ") - (insert "Do not edit this file.\n") - (prin1 bm-repository (current-buffer)) - (save-buffer)) - (kill-buffer repository-buffer)))) - - -(defun bm-repository-clear nil - "Clear the repository." - (interactive) - (setq bm-repository nil)) - - -(defun bm-load-and-restore nil - "Load bookmarks from persistent repository and restore them." - (interactive) - (bm-repository-load) - (bm-buffer-restore-all)) - - -(defun bm-save nil - "Save bookmarks to persistent repository." - (interactive) - (bm-buffer-save-all) - (bm-repository-save)) - - -(defun bm-buffer-file-name nil - "Get a unique key for the repository, even for non-file buffers." - (cond ((equal 'Info-mode major-mode) - (concat "[info:" Info-current-file "]")) - ((not (null (buffer-base-buffer))) - (concat "[indirect:" (buffer-name) ":" (buffer-file-name (buffer-base-buffer)) "]")) - (t (buffer-file-name)))) - - -;; restore repository on load -(if bm-restore-repository-on-load - (bm-repository-load)) - - -(provide 'bm) -;;; bm.el ends here diff --git a/elisp/emacs-goodies-el/boxquote.el b/elisp/emacs-goodies-el/boxquote.el index 9d69a6f..9d69a6f 100755..100644 --- a/elisp/emacs-goodies-el/boxquote.el +++ b/elisp/emacs-goodies-el/boxquote.el diff --git a/elisp/emacs-goodies-el/browse-huge-tar.el b/elisp/emacs-goodies-el/browse-huge-tar.el index f0ce385..f0ce385 100755..100644 --- a/elisp/emacs-goodies-el/browse-huge-tar.el +++ b/elisp/emacs-goodies-el/browse-huge-tar.el diff --git a/elisp/emacs-goodies-el/browse-kill-ring.el b/elisp/emacs-goodies-el/browse-kill-ring.el deleted file mode 100755 index f4ca6da..0000000 --- a/elisp/emacs-goodies-el/browse-kill-ring.el +++ /dev/null @@ -1,1050 +0,0 @@ -;;; browse-kill-ring.el --- interactively insert items from kill-ring -*- coding: utf-8 -*- - -;; Copyright (C) 2001, 2002 Colin Walters <walters@verbum.org> - -;; Author: Colin Walters <walters@verbum.org> -;; Maintainer: Nick Hurley <hurley@cis.ohio-state.edu> -;; Created: 7 Apr 2001 -;; Version: 1.3a (CVS) -;; X-RCS: $Id: browse-kill-ring.el,v 1.4 2013/12/04 22:32:10 psg Exp $ -;; URL: http://freedom.cis.ohio-state.edu/~hurley/ -;; URL-ja: http://www.fan.gr.jp/~ring/doc/browse-kill-ring.html -;; Keywords: convenience - -;; This file is not currently part of GNU Emacs. - -;; This program 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. - -;; This program 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 this program ; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; Ever feel that 'C-y M-y M-y M-y ...' is not a great way of trying -;; to find that piece of text you know you killed a while back? Then -;; browse-kill-ring.el is for you. - -;; This package is simple to install; add (require 'browse-kill-ring) -;; to your ~/.emacs file, after placing this file somewhere in your -;; `load-path'. If you want to use 'M-y' to invoke -;; `browse-kill-ring', also add (browse-kill-ring-default-keybindings) -;; to your ~/.emacs file. Alternatively, you can bind it to another -;; key such as "C-c k", with: -;; (global-set-key (kbd "C-c k") 'browse-kill-ring) - -;; Note that the command keeps track of the last window displayed to -;; handle insertion of chosen text; this might have unexpected -;; consequences if you do 'M-x browse-kill-ring', then switch your -;; window configuration, and try to use the same *Kill Ring* buffer -;; again. - -;;; Change Log: - -;; Changes from 1.3 to 1.3a: - -;; * Sneak update by Benjamin Andresen <bandresen@gmail.com> -;; * Added the read-only bugfix (http://bugs.debian.org/225082) from -;; the emacs-goodies-el package - -;; Changes from 1.2 to 1.3: - -;; * New maintainer, Nick Hurley <hurley@cis.ohio-state.edu> -;; * New functions `browse-kill-ring-prepend-insert', and -;; `browse-kill-ring-append-insert', bound to 'b' and 'a' by -;; default. There are also the unbound functions -;; `browse-kill-ring-prepend-insert-and-quit', -;; `browse-kill-ring-prepend-insert-and-move', -;; `browse-kill-ring-prepend-insert-move-and-quit', -;; `browse-kill-ring-append-insert-and-quit', -;; `browse-kill-ring-append-insert-and-move', -;; `browse-kill-ring-append-insert-move-and-quit'. - -;; Changes from 1.1 to 1.2: - -;; * New variable `browse-kill-ring-resize-window', which controls -;; whether or not the browse-kill-ring window will try to resize -;; itself to fit the buffer. Implementation from Juanma Barranquero -;; <lektu@terra.es>. -;; * New variable `browse-kill-ring-highlight-inserted-item'. -;; Implementation from Yasutaka SHINDOH <ring-pub@fan.gr.jp>. -;; * `browse-kill-ring-mouse-insert' (normally bound to mouse-2) now -;; calls `browse-kill-ring-quit'. -;; * Some non-user-visible code cleanup. -;; * New variable `browse-kill-ring-recenter', implementation from -;; René Kyllingstad <kyllingstad@users.sourceforge.net>. -;; * Patch from Michal MarÅ¡uka <mmc@maruska.dyndns.org> which handles -;; read-only text better. -;; * New ability to move unkilled entries back to the beginning of the -;; ring; patch from Yasutaka SHINDOH <ring-pub@fan.gr.jp>. -;; * Do nothing if the user invokes `browse-kill-ring' when we're -;; already in a *Kill Ring* buffer (initial patch from Juanma -;; Barranquero <lektu@terra.es>). - -;; Changes from 1.0 to 1.1: - -;; * Important keybinding change! The default bindings of RET and 'i' -;; have switched; this means typing RET now by default inserts the -;; text and calls `browse-kill-ring-quit'; 'i' just inserts. -;; * The variable `browse-kill-ring-use-fontification' is gone; -;; browse-kill-ring.el has been rewritten to use font-lock. XEmacs -;; users who want fontification will have to do: -;; (add-hook 'browse-kill-ring-hook 'font-lock-mode) -;; * Integrated code from Michael Slass <mikesl@wrq.com> into -;; `browse-kill-ring-default-keybindings'. -;; * New Japanese homepage for browse-kill-ring.el, thanks to -;; Yasutaka SHINDOH <ring-pub@fan.gr.jp>. -;; * Correctly restore window configuration after editing an entry. -;; * New command `browse-kill-ring-insert-and-delete'. -;; * Bug reports and patches from Michael Slass <mikesl@wrq.com> and -;; Juanma Barranquero <lektu@terra.es>. - -;; Changes from 0.9b to 1.0: - -;; * Add autoload cookie to `browse-kill-ring'; suggestion from -;; D. Goel <deego@glue.umd.edu> and Dave Pearson <davep@davep.org>. -;; * Add keybinding tip from Michael Slass <mikesl@wrq.com>. - -;; Changes from 0.9a to 0.9b: - -;; * Remove extra parenthesis. Duh. - -;; Changes from 0.9 to 0.9a: - -;; * Fix bug making `browse-kill-ring-quit-action' uncustomizable. -;; Patch from Henrik Enberg <henrik@enberg.org>. -;; * Add `url-link' and `group' attributes to main Customization -;; group. - -;; Changes from 0.8 to 0.9: - -;; * Add new function `browse-kill-ring-insert-and-quit', bound to 'i' -;; by default (idea from Yasutaka Shindoh). -;; * Make default `browse-kill-ring-quit-action' be -;; `bury-and-delete-window', which handles the case of a single window -;; more nicely. -;; * Note change of home page and author address. - -;; Changes from 0.7 to 0.8: - -;; * Fix silly bug in `browse-kill-ring-edit' which made it impossible -;; to edit entries. -;; * New variable `browse-kill-ring-quit-action'. -;; * `browse-kill-ring-restore' renamed to `browse-kill-ring-quit'. -;; * Describe the keymaps in mode documentation. Patch from -;; Marko Slyz <mslyz@eecs.umich.edu>. -;; * Fix advice documentation for `browse-kill-ring-no-duplicates'. - -;; Changes from 0.6 to 0.7: - -;; * New functions `browse-kill-ring-search-forward' and -;; `browse-kill-ring-search-backward', bound to "s" and "r" by -;; default, respectively. -;; * New function `browse-kill-ring-edit' bound to "e" by default, and -;; a associated new major mode. -;; * New function `browse-kill-ring-occur', bound to "l" by default. - -;; Changes from 0.5 to 0.6: - -;; * Fix bug in `browse-kill-ring-forward' which sometimes would cause -;; a message "Wrong type argument: overlayp, nil" to appear. -;; * New function `browse-kill-ring-update'. -;; * New variable `browse-kill-ring-highlight-current-entry'. -;; * New variable `browse-kill-ring-display-duplicates'. -;; * New optional advice `browse-kill-ring-no-kill-new-duplicates', -;; and associated variable `browse-kill-ring-no-duplicates'. Code -;; from Klaus Berndl <Klaus.Berndl@sdm.de>. -;; * Bind "?" to `describe-mode'. Patch from Dave Pearson -;; <dave@davep.org>. -;; * Fix typo in `browse-kill-ring-display-style' defcustom form. -;; Thanks "Kahlil (Kal) HODGSON" <kahlil@discus.anu.edu.au>. - -;; Changes from 0.4 to 0.5: - -;; * New function `browse-kill-ring-delete', bound to "d" by default. -;; * New function `browse-kill-ring-undo', bound to "U" by default. -;; * New variable `browse-kill-ring-maximum-display-length'. -;; * New variable `browse-kill-ring-use-fontification'. -;; * New variable `browse-kill-ring-hook', called after the -;; "*Kill Ring*" buffer is created. - -;; Changes from 0.3 to 0.4: - -;; * New functions `browse-kill-ring-forward' and -;; `browse-kill-ring-previous', bound to "n" and "p" by default, -;; respectively. -;; * Change the default `browse-kill-ring-display-style' to -;; `separated'. -;; * Removed `browse-kill-ring-original-window-config'; Now -;; `browse-kill-ring-restore' just buries the "*Kill Ring*" buffer -;; and deletes its window, which is simpler and more intuitive. -;; * New variable `browse-kill-ring-separator-face'. - -;;; Bugs: - -;; * Sometimes, in Emacs 21, the cursor will jump to the end of an -;; entry when moving backwards using `browse-kill-ring-previous'. -;; This doesn't seem to occur in Emacs 20 or XEmacs. - -;;; Code: - -(eval-when-compile - (require 'cl) - (require 'derived)) - -(when (featurep 'xemacs) - (require 'overlay)) - -(defun browse-kill-ring-depropertize-string (str) - "Return a copy of STR with text properties removed." - (let ((str (copy-sequence str))) - (set-text-properties 0 (length str) nil str) - str)) - -(cond ((fboundp 'propertize) - (defalias 'browse-kill-ring-propertize 'propertize)) - ;; Maybe save some memory :) - ((fboundp 'ibuffer-propertize) - (defalias 'browse-kill-ring-propertize 'ibuffer-propertize)) - (t - (defun browse-kill-ring-propertize (string &rest properties) - "Return a copy of STRING with text properties added. - - [Note: this docstring has been copied from the Emacs 21 version] - -First argument is the string to copy. -Remaining arguments form a sequence of PROPERTY VALUE pairs for text -properties to add to the result." - (let ((str (copy-sequence string))) - (add-text-properties 0 (length str) - properties - str) - str)))) - -(defgroup browse-kill-ring nil - "A package for browsing and inserting the items in `kill-ring'." - :link '(url-link "http://freedom.cis.ohio-state.edu/~hurley/") - :group 'convenience) - -(defvar browse-kill-ring-display-styles - '((separated . browse-kill-ring-insert-as-separated) - (one-line . browse-kill-ring-insert-as-one-line))) - -(defcustom browse-kill-ring-display-style 'separated - "How to display the kill ring items. - -If `one-line', then replace newlines with \"\\n\" for display. - -If `separated', then display `browse-kill-ring-separator' between -entries." - :type '(choice (const :tag "One line" one-line) - (const :tag "Separated" separated)) - :group 'browse-kill-ring) - -(defcustom browse-kill-ring-quit-action 'bury-and-delete-window - "What action to take when `browse-kill-ring-quit' is called. - -If `bury-buffer', then simply bury the *Kill Ring* buffer, but keep -the window. - -If `bury-and-delete-window', then bury the buffer, and (if there is -more than one window) delete the window. This is the default. - -If `save-and-restore', then save the window configuration when -`browse-kill-ring' is called, and restore it at quit. - -If `kill-and-delete-window', then kill the *Kill Ring* buffer, and -delete the window on close. - -Otherwise, it should be a function to call." - :type '(choice (const :tag "Bury buffer" :value bury-buffer) - (const :tag "Delete window" :value delete-window) - (const :tag "Save and restore" :value save-and-restore) - (const :tag "Bury buffer and delete window" :value bury-and-delete-window) - (const :tag "Kill buffer and delete window" :value kill-and-delete-window) - function) - :group 'browse-kill-ring) - -(defcustom browse-kill-ring-resize-window nil - "Whether to resize the `browse-kill-ring' window to fit its contents. -Value is either t, meaning yes, or a cons pair of integers, - (MAXIMUM . MINIMUM) for the size of the window. MAXIMUM defaults to -the window size chosen by `pop-to-buffer'; MINIMUM defaults to -`window-min-height'." - :type '(choice (const :tag "No" nil) - (const :tag "Yes" t) - (cons (integer :tag "Maximum") (integer :tag "Minimum"))) - :group 'browse-kill-ring) - -(defcustom browse-kill-ring-separator "-------" - "The string separating entries in the `separated' style. -See `browse-kill-ring-display-style'." - :type 'string - :group 'browse-kill-ring) - -(defcustom browse-kill-ring-recenter nil - "If non-nil, then always keep the current entry at the top of the window." - :type 'boolean - :group 'browse-kill-ring) - -(defcustom browse-kill-ring-highlight-current-entry nil - "If non-nil, highlight the currently selected `kill-ring' entry." - :type 'boolean - :group 'browse-kill-ring) - -(defcustom browse-kill-ring-highlight-inserted-item browse-kill-ring-highlight-current-entry - "If non-nil, temporarily highlight the inserted `kill-ring' entry." - :type 'boolean - :group 'browse-kill-ring) - -(defcustom browse-kill-ring-separator-face 'bold - "The face in which to highlight the `browse-kill-ring-separator'." - :type 'face - :group 'browse-kill-ring) - -(defcustom browse-kill-ring-maximum-display-length nil - "Whether or not to limit the length of displayed items. - -If this variable is an integer, the display of `kill-ring' will be -limited to that many characters. -Setting this variable to nil means no limit." - :type '(choice (const :tag "None" nil) - integer) - :group 'browse-kill-ring) - -(defcustom browse-kill-ring-display-duplicates t - "If non-nil, then display duplicate items in `kill-ring'." - :type 'boolean - :group 'browse-kill-ring) - -(defadvice kill-new (around browse-kill-ring-no-kill-new-duplicates) - "An advice for not adding duplicate elements to `kill-ring'. -Even after being \"activated\", this advice will only modify the -behavior of `kill-new' when `browse-kill-ring-no-duplicates' -is non-nil." - (if browse-kill-ring-no-duplicates - (setq kill-ring (delete (ad-get-arg 0) kill-ring))) - ad-do-it) - -(defcustom browse-kill-ring-no-duplicates nil - "If non-nil, then the `b-k-r-no-kill-new-duplicates' advice will operate. -This means that duplicate entries won't be added to the `kill-ring' -when you call `kill-new'. - -If you set this variable via customize, the advice will be activated -or deactivated automatically. Otherwise, to enable the advice, add - - (ad-enable-advice 'kill-new 'around 'browse-kill-ring-no-kill-new-duplicates) - (ad-activate 'kill-new) - -to your init file." - :type 'boolean - :set (lambda (symbol value) - (set symbol value) - (if value - (ad-enable-advice 'kill-new 'around - 'browse-kill-ring-no-kill-new-duplicates) - (ad-disable-advice 'kill-new 'around - 'browse-kill-ring-no-kill-new-duplicates)) - (ad-activate 'kill-new)) - :group 'browse-kill-ring) - -(defcustom browse-kill-ring-depropertize nil - "If non-nil, remove text properties from `kill-ring' items. -This only changes the items for display and insertion from -`browse-kill-ring'; if you call `yank' directly, the items will be -inserted with properties." - :type 'boolean - :group 'browse-kill-ring) - -(defcustom browse-kill-ring-hook nil - "A list of functions to call after `browse-kill-ring'." - :type 'hook - :group 'browse-kill-ring) - -(defvar browse-kill-ring-original-window-config nil - "The window configuration to restore for `browse-kill-ring-quit'.") -(make-variable-buffer-local 'browse-kill-ring-original-window-config) - -(defvar browse-kill-ring-original-window nil - "The window in which chosen kill ring data will be inserted. -It is probably not a good idea to set this variable directly; simply -call `browse-kill-ring' again.") - -(defun browse-kill-ring-mouse-insert (e) - "Insert the chosen text, and close the *Kill Ring* buffer afterwards." - (interactive "e") - (let* ((data (save-excursion - (mouse-set-point e) - (cons (current-buffer) (point)))) - (buf (car data)) - (pt (cdr data))) - (browse-kill-ring-do-insert buf pt)) - (browse-kill-ring-quit)) - -(if (fboundp 'fit-window-to-buffer) - (defalias 'browse-kill-ring-fit-window 'fit-window-to-buffer) - (defun browse-kill-ring-fit-window (window max-height min-height) - (setq min-height (or min-height window-min-height)) - (setq max-height (or max-height (- (frame-height) (window-height) 1))) - (let* ((window-min-height min-height) - (windows (count-windows)) - (config (current-window-configuration))) - (enlarge-window (- max-height (window-height))) - (when (> windows (count-windows)) - (set-window-configuration config)) - (if (/= (point-min) (point-max)) - (shrink-window-if-larger-than-buffer window) - (shrink-window (- (window-height) window-min-height)))))) - -(defun browse-kill-ring-resize-window () - (when browse-kill-ring-resize-window - (apply #'browse-kill-ring-fit-window (selected-window) - (if (consp browse-kill-ring-resize-window) - (list (car browse-kill-ring-resize-window) - (or (cdr browse-kill-ring-resize-window) - window-min-height)) - (list nil window-min-height))))) - -(defun browse-kill-ring-undo-other-window () - "Undo the most recent change in the other window's buffer. -You most likely want to use this command for undoing an insertion of -yanked text from the *Kill Ring* buffer." - (interactive) - (with-current-buffer (window-buffer browse-kill-ring-original-window) - (undo))) - -(defun browse-kill-ring-insert (&optional quit) - "Insert the kill ring item at point into the last selected buffer. -If optional argument QUIT is non-nil, close the *Kill Ring* buffer as -well." - (interactive "P") - (browse-kill-ring-do-insert (current-buffer) - (point)) - (when quit - (browse-kill-ring-quit))) - -(defun browse-kill-ring-insert-and-delete (&optional quit) - "Insert the kill ring item at point, and remove it from the kill ring. -If optional argument QUIT is non-nil, close the *Kill Ring* buffer as -well." - (interactive "P") - (browse-kill-ring-do-insert (current-buffer) - (point)) - (browse-kill-ring-delete) - (when quit - (browse-kill-ring-quit))) - -(defun browse-kill-ring-insert-and-quit () - "Like `browse-kill-ring-insert', but close the *Kill Ring* buffer afterwards." - (interactive) - (browse-kill-ring-insert t)) - -(defun browse-kill-ring-insert-and-move (&optional quit) - "Like `browse-kill-ring-insert', but move the entry to the front." - (interactive "P") - (let ((buf (current-buffer)) - (pt (point))) - (browse-kill-ring-do-insert buf pt) - (let ((str (browse-kill-ring-current-string buf pt))) - (browse-kill-ring-delete) - (kill-new str))) - (if quit - (browse-kill-ring-quit) - (browse-kill-ring-update))) - -(defun browse-kill-ring-insert-move-and-quit () - "Like `browse-kill-ring-insert-and-move', but close the *Kill Ring* buffer." - (interactive) - (browse-kill-ring-insert-and-move t)) - -(defun browse-kill-ring-prepend-insert (&optional quit) - "Like `browse-kill-ring-insert', but it places the entry at the beginning -of the buffer as opposed to point." - (interactive "P") - (browse-kill-ring-do-prepend-insert (current-buffer) - (point)) - (when quit - (browse-kill-ring-quit))) - -(defun browse-kill-ring-prepend-insert-and-quit () - "Like `browse-kill-ring-prepend-insert', but close the *Kill Ring* buffer." - (interactive) - (browse-kill-ring-prepend-insert t)) - -(defun browse-kill-ring-prepend-insert-and-move (&optional quit) - "Like `browse-kill-ring-prepend-insert', but move the entry to the front -of the *Kill Ring*." - (interactive "P") - (let ((buf (current-buffer)) - (pt (point))) - (browse-kill-ring-do-prepend-insert buf pt) - (let ((str (browse-kill-ring-current-string buf pt))) - (browse-kill-ring-delete) - (kill-new str))) - (if quit - (browse-kill-ring-quit) - (browse-kill-ring-update))) - -(defun browse-kill-ring-prepend-insert-move-and-quit () - "Like `browse-kill-ring-prepend-insert-and-move', but close the -*Kill Ring* buffer." - (interactive) - (browse-kill-ring-prepend-insert-and-move t)) - -(defun browse-kill-ring-do-prepend-insert (buf pt) - (let ((str (browse-kill-ring-current-string buf pt))) - (let ((orig (current-buffer))) - (unwind-protect - (progn - (unless (window-live-p browse-kill-ring-original-window) - (error "Window %s has been deleted; Try calling `browse-kill-ring' again" - browse-kill-ring-original-window)) - (set-buffer (window-buffer browse-kill-ring-original-window)) - (save-excursion - (let ((pt (point))) - (goto-char (point-min)) - (insert (if browse-kill-ring-depropertize - (browse-kill-ring-depropertize-string str) - str)) - (when browse-kill-ring-highlight-inserted-item - (let ((o (make-overlay (point-min) (point)))) - (overlay-put o 'face 'highlight) - (sit-for 0.5) - (delete-overlay o))) - (goto-char pt)))) - (set-buffer orig))))) - -(defun browse-kill-ring-append-insert (&optional quit) - "Like `browse-kill-ring-insert', but places the entry at the end of the -buffer as opposed to point." - (interactive "P") - (browse-kill-ring-do-append-insert (current-buffer) - (point)) - (when quit - (browse-kill-ring-quit))) - -(defun browse-kill-ring-append-insert-and-quit () - "Like `browse-kill-ring-append-insert', but close the *Kill Ring* buffer." - (interactive) - (browse-kill-ring-append-insert t)) - -(defun browse-kill-ring-append-insert-and-move (&optional quit) - "Like `browse-kill-ring-append-insert', but move the entry to the front -of the *Kill Ring*." - (interactive "P") - (let ((buf (current-buffer)) - (pt (point))) - (browse-kill-ring-do-append-insert buf pt) - (let ((str (browse-kill-ring-current-string buf pt))) - (browse-kill-ring-delete) - (kill-new str))) - (if quit - (browse-kill-ring-quit) - (browse-kill-ring-update))) - -(defun browse-kill-ring-append-insert-move-and-quit () - "Like `browse-kill-ring-append-insert-and-move', but close the -*Kill Ring* buffer." - (interactive) - (browse-kill-ring-append-insert-and-move t)) - -(defun browse-kill-ring-do-append-insert (buf pt) - (let ((str (browse-kill-ring-current-string buf pt))) - (let ((orig (current-buffer))) - (unwind-protect - (progn - (unless (window-live-p browse-kill-ring-original-window) - (error "Window %s has been deleted; Try calling `browse-kill-ring' again" - browse-kill-ring-original-window)) - (set-buffer (window-buffer browse-kill-ring-original-window)) - (save-excursion - (let ((pt (point)) - (begin-pt (point-max))) - (goto-char begin-pt) - (insert (if browse-kill-ring-depropertize - (browse-kill-ring-depropertize-string str) - str)) - (when browse-kill-ring-highlight-inserted-item - (let ((o (make-overlay begin-pt (point-max)))) - (overlay-put o 'face 'highlight) - (sit-for 0.5) - (delete-overlay o))) - (goto-char pt)))) - (set-buffer orig))))) - -(defun browse-kill-ring-delete () - "Remove the item at point from the `kill-ring'." - (interactive) - (let ((over (car (overlays-at (point))))) - (unless (overlayp over) - (error "No kill ring item here")) - (unwind-protect - (progn - (setq buffer-read-only nil) - (let ((target (overlay-get over 'browse-kill-ring-target))) - (delete-region (overlay-start over) - (1+ (overlay-end over))) - (setq kill-ring (delete target kill-ring))) - (when (get-text-property (point) 'browse-kill-ring-extra) - (let ((prev (previous-single-property-change (point) - 'browse-kill-ring-extra)) - (next (next-single-property-change (point) - 'browse-kill-ring-extra))) - ;; This is some voodoo. - (when prev - (incf prev)) - (when next - (incf next)) - (delete-region (or prev (point-min)) - (or next (point-max)))))) - (setq buffer-read-only t))) - (browse-kill-ring-resize-window) - (browse-kill-ring-forward 0)) - -(defun browse-kill-ring-current-string (buf pt) - (with-current-buffer buf - (let ((overs (overlays-at pt))) - (or (and overs - (overlay-get (car overs) 'browse-kill-ring-target)) - (error "No kill ring item here"))))) - -(defun browse-kill-ring-do-insert (buf pt) - (let ((str (browse-kill-ring-current-string buf pt))) - (let ((orig (current-buffer))) - (unwind-protect - (progn - (unless (window-live-p browse-kill-ring-original-window) - (error "Window %s has been deleted; Try calling `browse-kill-ring' again" - browse-kill-ring-original-window)) - (set-buffer (window-buffer browse-kill-ring-original-window)) - (save-excursion - (let ((pt (point))) - (insert (if browse-kill-ring-depropertize - (browse-kill-ring-depropertize-string str) - str)) - (when browse-kill-ring-highlight-inserted-item - (let ((o (make-overlay pt (point)))) - (overlay-put o 'face 'highlight) - (sit-for 0.5) - (delete-overlay o)))))) - (set-buffer orig))))) - -(defun browse-kill-ring-forward (&optional arg) - "Move forward by ARG `kill-ring' entries." - (interactive "p") - (beginning-of-line) - (while (not (zerop arg)) - (if (< arg 0) - (progn - (incf arg) - (if (overlays-at (point)) - (progn - (goto-char (overlay-start (car (overlays-at (point))))) - (goto-char (previous-overlay-change (point))) - (goto-char (previous-overlay-change (point)))) - (progn - (goto-char (1- (previous-overlay-change (point)))) - (unless (bobp) - (goto-char (overlay-start (car (overlays-at (point))))))))) - (progn - (decf arg) - (if (overlays-at (point)) - (progn - (goto-char (overlay-end (car (overlays-at (point))))) - (goto-char (next-overlay-change (point)))) - (goto-char (next-overlay-change (point))) - (unless (eobp) - (goto-char (overlay-start (car (overlays-at (point)))))))))) - ;; This could probably be implemented in a more intelligent manner. - ;; Perhaps keep track over the overlay we started from? That would - ;; break when the user moved manually, though. - (when (and browse-kill-ring-highlight-current-entry - (overlays-at (point))) - (let ((overs (overlay-lists)) - (current-overlay (car (overlays-at (point))))) - (mapcar #'(lambda (o) - (overlay-put o 'face nil)) - (nconc (car overs) (cdr overs))) - (overlay-put current-overlay 'face 'highlight))) - (when browse-kill-ring-recenter - (recenter 1))) - -(defun browse-kill-ring-previous (&optional arg) - "Move backward by ARG `kill-ring' entries." - (interactive "p") - (browse-kill-ring-forward (- arg))) - -(defun browse-kill-ring-read-regexp (msg) - (let* ((default (car regexp-history)) - (input - (read-from-minibuffer - (if default - (format "%s for regexp (default `%s'): " - msg - default) - (format "%s (regexp): " msg)) - nil - nil - nil - 'regexp-history))) - (if (equal input "") - default - input))) - -(defun browse-kill-ring-search-forward (regexp &optional backwards) - "Move to the next `kill-ring' entry matching REGEXP from point. -If optional arg BACKWARDS is non-nil, move to the previous matching -entry." - (interactive - (list (browse-kill-ring-read-regexp "Search forward") - current-prefix-arg)) - (let ((orig (point))) - (browse-kill-ring-forward (if backwards -1 1)) - (let ((overs (overlays-at (point)))) - (while (and overs - (not (if backwards (bobp) (eobp))) - (not (string-match regexp - (overlay-get (car overs) - 'browse-kill-ring-target)))) - (browse-kill-ring-forward (if backwards -1 1)) - (setq overs (overlays-at (point)))) - (unless (and overs - (string-match regexp - (overlay-get (car overs) - 'browse-kill-ring-target))) - (progn - (goto-char orig) - (message "No more `kill-ring' entries matching %s" regexp)))))) - -(defun browse-kill-ring-search-backward (regexp) - "Move to the previous `kill-ring' entry matching REGEXP from point." - (interactive - (list (browse-kill-ring-read-regexp "Search backward"))) - (browse-kill-ring-search-forward regexp t)) - -(defun browse-kill-ring-quit () - "Take the action specified by `browse-kill-ring-quit-action'." - (interactive) - (case browse-kill-ring-quit-action - (save-and-restore - (let (buf (current-buffer)) - (set-window-configuration browse-kill-ring-original-window-config) - (kill-buffer buf))) - (kill-and-delete-window - (kill-buffer (current-buffer)) - (unless (= (count-windows) 1) - (delete-window))) - (bury-and-delete-window - (bury-buffer) - (unless (= (count-windows) 1) - (delete-window))) - (t - (funcall browse-kill-ring-quit-action)))) - -(put 'browse-kill-ring-mode 'mode-class 'special) -(define-derived-mode browse-kill-ring-mode fundamental-mode - "Kill Ring" - "A major mode for browsing the `kill-ring'. -You most likely do not want to call `browse-kill-ring-mode' directly; use -`browse-kill-ring' instead. - -\\{browse-kill-ring-mode-map}" - (set (make-local-variable 'font-lock-defaults) - '(nil t nil nil nil - (font-lock-fontify-region-function . browse-kill-ring-fontify-region))) - (define-key browse-kill-ring-mode-map (kbd "q") 'browse-kill-ring-quit) - (define-key browse-kill-ring-mode-map (kbd "U") 'browse-kill-ring-undo-other-window) - (define-key browse-kill-ring-mode-map (kbd "d") 'browse-kill-ring-delete) - (define-key browse-kill-ring-mode-map (kbd "s") 'browse-kill-ring-search-forward) - (define-key browse-kill-ring-mode-map (kbd "r") 'browse-kill-ring-search-backward) - (define-key browse-kill-ring-mode-map (kbd "g") 'browse-kill-ring-update) - (define-key browse-kill-ring-mode-map (kbd "l") 'browse-kill-ring-occur) - (define-key browse-kill-ring-mode-map (kbd "e") 'browse-kill-ring-edit) - (define-key browse-kill-ring-mode-map (kbd "n") 'browse-kill-ring-forward) - (define-key browse-kill-ring-mode-map (kbd "p") 'browse-kill-ring-previous) - (define-key browse-kill-ring-mode-map [(mouse-2)] 'browse-kill-ring-mouse-insert) - (define-key browse-kill-ring-mode-map (kbd "?") 'describe-mode) - (define-key browse-kill-ring-mode-map (kbd "h") 'describe-mode) - (define-key browse-kill-ring-mode-map (kbd "y") 'browse-kill-ring-insert) - (define-key browse-kill-ring-mode-map (kbd "u") 'browse-kill-ring-insert-move-and-quit) - (define-key browse-kill-ring-mode-map (kbd "i") 'browse-kill-ring-insert) - (define-key browse-kill-ring-mode-map (kbd "o") 'browse-kill-ring-insert-and-move) - (define-key browse-kill-ring-mode-map (kbd "x") 'browse-kill-ring-insert-and-delete) - (define-key browse-kill-ring-mode-map (kbd "RET") 'browse-kill-ring-insert-and-quit) - (define-key browse-kill-ring-mode-map (kbd "b") 'browse-kill-ring-prepend-insert) - (define-key browse-kill-ring-mode-map (kbd "a") 'browse-kill-ring-append-insert)) - -;;;###autoload -(defun browse-kill-ring-default-keybindings () - "Set up M-y (`yank-pop') so that it can invoke `browse-kill-ring'. -Normally, if M-y was not preceeded by C-y, then it has no useful -behavior. This function sets things up so that M-y will invoke -`browse-kill-ring'." - (interactive) - (defadvice yank-pop (around kill-ring-browse-maybe (arg)) - "If last action was not a yank, run `browse-kill-ring' instead." - ;; yank-pop has an (interactive "*p") form which does not allow - ;; it to run in a read-only buffer. We want browse-kill-ring to - ;; be allowed to run in a read only buffer, so we change the - ;; interactive form here. In that case, we need to - ;; barf-if-buffer-read-only if we're going to call yank-pop with - ;; ad-do-it - (interactive "p") - (if (not (eq last-command 'yank)) - (browse-kill-ring) - (barf-if-buffer-read-only) - ad-do-it)) - (ad-activate 'yank-pop)) - -(define-derived-mode browse-kill-ring-edit-mode fundamental-mode - "Kill Ring Edit" - "A major mode for editing a `kill-ring' entry. -You most likely do not want to call `browse-kill-ring-edit-mode' -directly; use `browse-kill-ring' instead. - -\\{browse-kill-ring-edit-mode-map}" - (define-key browse-kill-ring-edit-mode-map (kbd "C-c C-c") - 'browse-kill-ring-edit-finish)) - -(defvar browse-kill-ring-edit-target nil) -(make-variable-buffer-local 'browse-kill-ring-edit-target) - -(defun browse-kill-ring-edit () - "Edit the `kill-ring' entry at point." - (interactive) - (let ((overs (overlays-at (point)))) - (unless overs - (error "No kill ring entry here")) - (let* ((target (overlay-get (car overs) - 'browse-kill-ring-target)) - (target-cell (member target kill-ring))) - (unless target-cell - (error "Item deleted from the kill-ring")) - (switch-to-buffer (get-buffer-create "*Kill Ring Edit*")) - (setq buffer-read-only nil) - (erase-buffer) - (insert target) - (goto-char (point-min)) - (browse-kill-ring-resize-window) - (browse-kill-ring-edit-mode) - (message "%s" - (substitute-command-keys - "Use \\[browse-kill-ring-edit-finish] to finish editing.")) - (setq browse-kill-ring-edit-target target-cell)))) - -(defun browse-kill-ring-edit-finish () - "Commit the changes to the `kill-ring'." - (interactive) - (if browse-kill-ring-edit-target - (setcar browse-kill-ring-edit-target (buffer-string)) - (when (y-or-n-p "The item has been deleted; add to front? ") - (push (buffer-string) kill-ring))) - (bury-buffer) - ;; The user might have rearranged the windows - (when (eq major-mode 'browse-kill-ring-mode) - (browse-kill-ring-setup (current-buffer) - browse-kill-ring-original-window - nil - browse-kill-ring-original-window-config) - (browse-kill-ring-resize-window))) - -(defmacro browse-kill-ring-add-overlays-for (item &rest body) - (let ((beg (gensym "browse-kill-ring-add-overlays-")) - (end (gensym "browse-kill-ring-add-overlays-"))) - `(let ((,beg (point)) - (,end - (progn - ,@body - (point)))) - (let ((o (make-overlay ,beg ,end))) - (overlay-put o 'browse-kill-ring-target ,item) - (overlay-put o 'mouse-face 'highlight))))) -;; (put 'browse-kill-ring-add-overlays-for 'lisp-indent-function 1) - -(defun browse-kill-ring-elide (str) - (if (and browse-kill-ring-maximum-display-length - (> (length str) - browse-kill-ring-maximum-display-length)) - (concat (substring str 0 (- browse-kill-ring-maximum-display-length 3)) - (browse-kill-ring-propertize "..." 'browse-kill-ring-extra t)) - str)) - -(defun browse-kill-ring-insert-as-one-line (items) - (dolist (item items) - (browse-kill-ring-add-overlays-for item - (let* ((item (browse-kill-ring-elide item)) - (len (length item)) - (start 0) - (newl (browse-kill-ring-propertize "\\n" 'browse-kill-ring-extra t))) - (while (and (< start len) - (string-match "\n" item start)) - (insert (substring item start (match-beginning 0)) - newl) - (setq start (match-end 0))) - (insert (substring item start len)))) - (insert "\n"))) - -(defun browse-kill-ring-insert-as-separated (items) - (while (cdr items) - (browse-kill-ring-insert-as-separated-1 (car items) t) - (setq items (cdr items))) - (when items - (browse-kill-ring-insert-as-separated-1 (car items) nil))) - -(defun browse-kill-ring-insert-as-separated-1 (origitem separatep) - (let* ((item (browse-kill-ring-elide origitem)) - (len (length item))) - (browse-kill-ring-add-overlays-for origitem - (insert item)) - ;; When the kill-ring has items with read-only text property at - ;; **the end of** string, browse-kill-ring-setup fails with error - ;; `Text is read-only'. So inhibit-read-only here. - ;; See http://bugs.debian.org/225082 - ;; - INOUE Hiroyuki <dombly@kc4.so-net.ne.jp> - (let ((inhibit-read-only t)) - (insert "\n") - (when separatep - (insert (browse-kill-ring-propertize browse-kill-ring-separator - 'browse-kill-ring-extra t - 'browse-kill-ring-separator t)) - (insert "\n"))))) - -(defun browse-kill-ring-occur (regexp) - "Display all `kill-ring' entries matching REGEXP." - (interactive - (list - (browse-kill-ring-read-regexp "Display kill ring entries matching"))) - (assert (eq major-mode 'browse-kill-ring-mode)) - (browse-kill-ring-setup (current-buffer) - browse-kill-ring-original-window - regexp) - (browse-kill-ring-resize-window)) - -(defun browse-kill-ring-fontify-on-property (prop face beg end) - (save-excursion - (goto-char beg) - (let ((prop-end nil)) - (while - (setq prop-end - (let ((prop-beg (or (and (get-text-property (point) prop) (point)) - (next-single-property-change (point) prop nil end)))) - (when (and prop-beg (not (= prop-beg end))) - (let ((prop-end (next-single-property-change prop-beg prop nil end))) - (when (and prop-end (not (= prop-end end))) - (put-text-property prop-beg prop-end 'face face) - prop-end))))) - (goto-char prop-end))))) - -(defun browse-kill-ring-fontify-region (beg end &optional verbose) - (when verbose (message "Fontifying...")) - (let ((buffer-read-only nil)) - (browse-kill-ring-fontify-on-property 'browse-kill-ring-extra 'bold beg end) - (browse-kill-ring-fontify-on-property 'browse-kill-ring-separator - browse-kill-ring-separator-face beg end)) - (when verbose (message "Fontifying...done"))) - -(defun browse-kill-ring-update () - "Update the buffer to reflect outside changes to `kill-ring'." - (interactive) - (assert (eq major-mode 'browse-kill-ring-mode)) - (browse-kill-ring-setup (current-buffer) - browse-kill-ring-original-window) - (browse-kill-ring-resize-window)) - -(defun browse-kill-ring-setup (buf window &optional regexp window-config) - (with-current-buffer buf - (unwind-protect - (progn - (browse-kill-ring-mode) - (setq buffer-read-only nil) - (when (eq browse-kill-ring-display-style - 'one-line) - (setq truncate-lines t)) - (let ((inhibit-read-only t)) - (erase-buffer)) - (setq browse-kill-ring-original-window window - browse-kill-ring-original-window-config - (or window-config - (current-window-configuration))) - (let ((browse-kill-ring-maximum-display-length - (if (and browse-kill-ring-maximum-display-length - (<= browse-kill-ring-maximum-display-length 3)) - 4 - browse-kill-ring-maximum-display-length)) - (items (mapcar - (if browse-kill-ring-depropertize - #'browse-kill-ring-depropertize-string - #'copy-sequence) - kill-ring))) - (when (not browse-kill-ring-display-duplicates) - ;; I'm not going to rewrite `delete-duplicates'. If - ;; someone really wants to rewrite it here, send me a - ;; patch. - (require 'cl) - (setq items (delete-duplicates items :test #'equal))) - (when (stringp regexp) - (setq items (delq nil - (mapcar - #'(lambda (item) - (when (string-match regexp item) - item)) - items)))) - (funcall (or (cdr (assq browse-kill-ring-display-style - browse-kill-ring-display-styles)) - (error "Invalid `browse-kill-ring-display-style': %s" - browse-kill-ring-display-style)) - items) -;; Code from Michael Slass <mikesl@wrq.com> - (message - (let ((entry (if (= 1 (length kill-ring)) "entry" "entries"))) - (concat - (if (and (not regexp) - browse-kill-ring-display-duplicates) - (format "%s %s in the kill ring." - (length kill-ring) entry) - (format "%s (of %s) %s in the kill ring shown." - (length items) (length kill-ring) entry)) - (substitute-command-keys - (concat " Type \\[browse-kill-ring-quit] to quit. " - "\\[describe-mode] for help."))))) -;; End code from Michael Slass <mikesl@wrq.com> - (set-buffer-modified-p nil) - (goto-char (point-min)) - (browse-kill-ring-forward 0) - (when regexp - (setq mode-name (concat "Kill Ring [" regexp "]"))) - (run-hooks 'browse-kill-ring-hook) - ;; I will be very glad when I can get rid of this gross - ;; hack, which solely exists for XEmacs users. - (when (and (featurep 'xemacs) - font-lock-mode) - (browse-kill-ring-fontify-region (point-min) (point-max))))) - (progn - (setq buffer-read-only t))))) - -;;;###autoload -(defun browse-kill-ring () - "Display items in the `kill-ring' in another buffer." - (interactive) - (if (eq major-mode 'browse-kill-ring-mode) - (message "Already viewing the kill ring") - (let ((orig-buf (current-buffer)) - (buf (get-buffer-create "*Kill Ring*"))) - (browse-kill-ring-setup buf (selected-window)) - (pop-to-buffer buf) - (browse-kill-ring-resize-window) - nil))) - -(provide 'browse-kill-ring) - -;;; browse-kill-ring.el ends here diff --git a/elisp/emacs-goodies-el/clipper.el b/elisp/emacs-goodies-el/clipper.el index ace60b8..ace60b8 100755..100644 --- a/elisp/emacs-goodies-el/clipper.el +++ b/elisp/emacs-goodies-el/clipper.el diff --git a/elisp/emacs-goodies-el/coffee.el b/elisp/emacs-goodies-el/coffee.el index b9a9f06..b9a9f06 100755..100644 --- a/elisp/emacs-goodies-el/coffee.el +++ b/elisp/emacs-goodies-el/coffee.el diff --git a/elisp/emacs-goodies-el/color-theme-library.el b/elisp/emacs-goodies-el/color-theme-library.el index d194708..d194708 100755..100644 --- a/elisp/emacs-goodies-el/color-theme-library.el +++ b/elisp/emacs-goodies-el/color-theme-library.el diff --git a/elisp/emacs-goodies-el/color-theme.el b/elisp/emacs-goodies-el/color-theme.el index 3b33942..3b33942 100755..100644 --- a/elisp/emacs-goodies-el/color-theme.el +++ b/elisp/emacs-goodies-el/color-theme.el diff --git a/elisp/emacs-goodies-el/color-theme_seldefcustom.el b/elisp/emacs-goodies-el/color-theme_seldefcustom.el index 2cf097d..2cf097d 100755..100644 --- a/elisp/emacs-goodies-el/color-theme_seldefcustom.el +++ b/elisp/emacs-goodies-el/color-theme_seldefcustom.el diff --git a/elisp/emacs-goodies-el/csv-mode.el b/elisp/emacs-goodies-el/csv-mode.el deleted file mode 100755 index 8a44619..0000000 --- a/elisp/emacs-goodies-el/csv-mode.el +++ /dev/null @@ -1,1286 +0,0 @@ -;;; csv-mode.el --- major mode for editing comma-separated value files - -;; Copyright (C) 2003, 2004 Francis J. Wright - -;; Author: Francis J. Wright <F.J.Wright at qmul.ac.uk> -;; Time-stamp: <23 August 2004> -;; URL: http://centaur.maths.qmul.ac.uk/Emacs/ -;; Version: $Id: csv-mode.el,v 1.1 2005-09-28 01:52:41 psg Exp $ -;; Keywords: convenience - -;; This file is not part of GNU Emacs. - -;; This package 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. - -;; This package 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; This package is intended for use with GNU Emacs 21 (only) and -;; implements the following commands to process records of CSV -;; (comma-separated value) type: `csv-sort-fields' and -;; `csv-sort-numeric-fields' sort respectively lexicographically and -;; numerically on a specified field or column; `csv-reverse-region' -;; reverses the order. They are based closely on, and use, code in -;; `sort.el'. `csv-kill-fields' and `csv-yank-fields' respectively -;; kill and yank fields or columns, although they do not use the -;; normal kill ring. `csv-kill-fields' can kill more than one field -;; at once, but multiple killed fields can be yanked only as a fixed -;; group equivalent to a single field. `csv-align-fields' aligns -;; fields into columns; `csv-unalign-fields' undoes such alignment; -;; separators can be hidden within aligned records. `csv-transpose' -;; interchanges rows and columns. For details, see the documentation -;; for the individual commands. - -;; CSV mode supports a generalised comma-separated values format -;; (character-separated values) in which the fields can be separated -;; by any of several single characters, specified by the value of the -;; customizable user option `csv-separators'. CSV data fields can be -;; delimited by quote characters (and must if they contain separator -;; characters). This implementation supports quoted fields, where the -;; quote characters allowed are specified by the value of the -;; customizable user option `csv-field-quotes'. By default, the only -;; separator is a comma and the only field quote is a double quote. -;; These user options can be changed ONLY by CUSTOMIZING them, -;; e.g. via the command `customize-variable'. - -;; CSV mode commands ignore blank lines and comment lines beginning -;; with the value of the buffer local variable `csv-comment-start', -;; which by default is #. The user interface is similar to that of -;; the standard commands `sort-fields' and `sort-numeric-fields', but -;; see the major mode documentation below. - -;; The global minor mode `csv-field-index-mode' provides display of -;; the current field index in the mode line, cf. `line-number-mode' -;; and `column-number-mode'. It is on by default. - -;;; Installation: - -;; Put this file somewhere that Emacs can find it (i.e. in one of the -;; directories in your `load-path' such as `site-lisp'), optionally -;; byte-compile it (recommended), and put this in your .emacs file: -;; -;; (add-to-list 'auto-mode-alist '("\\.[Cc][Ss][Vv]\\'" . csv-mode)) -;; (autoload 'csv-mode "csv-mode" -;; "Major mode for editing comma-separated value files." t) - -;;; History: - -;; Begun on 15 November 2003 to provide lexicographic sorting of -;; simple CSV data by field and released as csv.el. Facilities to -;; kill multiple fields and customize separator added on 9 April 2004. -;; Converted to a major mode and renamed csv-mode.el on 10 April 2004, -;; partly at the suggestion of Stefan Monnier <monnier at -;; IRO.UMontreal.CA> to avoid conflict with csv.el by Ulf Jasper. -;; Field alignment, comment support and CSV mode customization group -;; added on 1 May 2004. Support for index ranges added on 6 June -;; 2004. Multiple field separators added on 12 June 2004. -;; Transposition added on 22 June 2004. Separator invisibility added -;; on 23 June 2004. - -;;; See also: - -;; the standard GNU Emacs 21 packages align.el, which will align -;; columns within a region, and delim-col.el, which helps to prettify -;; columns in a text region or rectangle; - -;; csv.el by Ulf Jasper <ulf.jasper at web.de>, which provides -;; functions for reading/parsing comma-separated value files and is -;; available at http://de.geocities.com/ulf_jasper/emacs.html (and in -;; the gnu.emacs.sources archives). - -;;; To do (maybe): - -;; Make separators and quotes buffer-local and locally settable. -;; Support (La)TeX tables: set separator and comment; support record -;; end string. -;; Convert comma-separated to space- or tab-separated. - -;;; Code: - -(defgroup CSV nil - "Major mode for editing files of comma-separated value type." - :group 'convenience) - -(defvar csv-separator-chars nil - "Field separators as a list of character. -Set by customizing `csv-separators' -- do not set directly!") - -(defvar csv-separator-regexp nil - "Regexp to match a field separator. -Set by customizing `csv-separators' -- do not set directly!") - -(defvar csv-skip-regexp nil - "Regexp used by `skip-chars-forward' etc. to skip fields. -Set by customizing `csv-separators' -- do not set directly!") - -(defvar csv-font-lock-keywords nil - "Font lock keywords to highlight the field separators in CSV mode. -Set by customizing `csv-separators' -- do not set directly!") - -(defcustom csv-separators '(",") - "Field separators: a list of *single-character* strings. -For example: (\",\"), the default, or (\",\" \";\" \":\"). -Neighbouring fields may be separated by any one of these characters. -The first is used when inserting a field separator into the buffer. -All must be different from the field quote characters, `csv-field-quotes'." - ;; Suggested by Eckhard Neber <neber@mwt.e-technik.uni-ulm.de> - :group 'CSV - :type '(repeat string) - ;; Character would be better, but in Emacs 21.3 does not display - ;; correctly in a customization buffer. - :set (lambda (variable value) - (mapc (lambda (x) - (if (or (/= (length x) 1) - (and (boundp 'csv-field-quotes) - (member x csv-field-quotes))) - (error))) - value) - (custom-set-default variable value) - (setq csv-separator-chars (mapcar 'string-to-char value) - csv-skip-regexp (apply 'concat "^\n" csv-separators) - csv-separator-regexp (apply 'concat `("[" ,@value "]")) - csv-font-lock-keywords - ;; NB: csv-separator-face variable evaluates to itself. - `((,csv-separator-regexp . csv-separator-face))))) - -(defcustom csv-field-quotes '("\"") - "Field quotes: a list of *single-character* strings. -For example: (\"\\\"\"), the default, or (\"\\\"\" \"'\" \"`\"). -A field can be delimited by a pair of any of these characters. -All must be different from the field separators, `csv-separators'." - :group 'CSV - :type '(repeat string) - ;; Character would be better, but in Emacs 21 does not display - ;; correctly in a customization buffer. - :set (lambda (variable value) - (mapc (lambda (x) - (if (or (/= (length x) 1) - (member x csv-separators)) - (error))) - value) - (when (boundp 'csv-mode-syntax-table) - ;; FIRST remove old quote syntax: - (with-syntax-table text-mode-syntax-table - (mapc (lambda (x) - (modify-syntax-entry - (string-to-char x) - (string (char-syntax (string-to-char x))) - ;; symbol-value to avoid compiler warning: - (symbol-value 'csv-mode-syntax-table))) - csv-field-quotes)) - ;; THEN set new quote syntax: - (csv-set-quote-syntax value)) - ;; BEFORE setting new value of `csv-field-quotes': - (custom-set-default variable value))) - -(defun csv-set-quote-syntax (field-quotes) - "Set syntax for field quote characters FIELD-QUOTES to be \"string\". -FIELD-QUOTES should be a list of single-character strings." - (mapc (lambda (x) - (modify-syntax-entry - (string-to-char x) "\"" - ;; symbol-value to avoid compiler warning: - (symbol-value 'csv-mode-syntax-table))) - field-quotes)) - -(defvar csv-comment-start nil - "String that starts a comment line, or nil if no comment syntax. -Such comment lines are ignored by CSV mode commands. -This variable is buffer local\; its default value is that of -`csv-comment-start-default'. It is set by the function -`csv-set-comment-start' -- do not set it directly!") - -(make-variable-buffer-local 'csv-comment-start) - -(defcustom csv-comment-start-default "#" - "String that starts a comment line, or nil if no comment syntax. -Such comment lines are ignored by CSV mode commands. -Default value of buffer-local variable `csv-comment-start'. -Changing this variable does not affect any existing CSV mode buffer." - :group 'CSV - :type '(choice (const :tag "None" nil) string) - :set (lambda (variable value) - (custom-set-default variable value) - (set-default 'csv-comment-start value))) - -(defcustom csv-align-style 'left - "Aligned field style: one of 'left, 'centre, 'right or 'auto. -Alignment style used by `csv-align-fields'. -Auto-alignment means left align text and right align numbers." - :group 'CSV - :type '(choice (const left) (const centre) - (const right) (const auto))) - -(defcustom csv-align-padding 1 - "Aligned field spacing: must be a positive integer. -Number of spaces used by `csv-align-fields' after separators." - :group 'CSV - :type 'integer) - -(defcustom csv-header-lines 0 - "Header lines to skip when setting region automatically." - :group 'CSV - :type 'integer) - -(defcustom csv-invisibility-default nil - "If non-nil, make separators in aligned records invisible." - :group 'CSV - :type 'boolean) - -(defface csv-separator-face - '((((class color)) (:foreground "red")) - (t (:weight bold))) - "CSV mode face used to highlight separators." - :group 'CSV) - -;; This mechanism seems to keep XEmacs happy: -(defvar csv-separator-face 'csv-separator-face - "Face name to use to highlight separators.") - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Mode definition, key bindings and menu -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defconst csv-mode-line-help-echo - ;; See bindings.el for details of `mode-line-format' construction. - (get-text-property 0 'help-echo (car default-mode-line-format)) - "Primary default mode line help echo text.") - -(defconst csv-mode-line-format - ;; See bindings.el for details of `mode-line-format' construction. - (append (butlast default-mode-line-format 2) - (cons `(csv-field-index-string - ("" csv-field-index-string - ,(propertize "--" 'help-echo csv-mode-line-help-echo))) - (last default-mode-line-format 2))) - "Mode line format string for CSV mode.") - -(define-derived-mode csv-mode text-mode "CSV" - "Major mode for editing files of comma-separated value type. - -CSV mode is derived from `text-mode', and runs `text-mode-hook' before -running `csv-mode-hook'. It turns `auto-fill-mode' off by default. -CSV mode can be customized by user options in the CSV customization -group. The separators are specified by the value of `csv-separators'. - -CSV mode commands ignore blank lines and comment lines beginning with -the value of `csv-comment-start', which delimit \"paragraphs\". -\"Sexp\" is re-interpreted to mean \"field\", so that `forward-sexp' -\(\\[forward-sexp]), `kill-sexp' (\\[kill-sexp]), etc. all apply to fields. -Standard comment commands apply, such as `comment-dwim' (\\[comment-dwim]). - -If `font-lock-mode' is enabled then separators, quoted values and -comment lines are highlighted using respectively `csv-separator-face', -`font-lock-string-face' and `font-lock-comment-face'. - -The user interface (UI) for CSV mode commands is similar to that of -the standard commands `sort-fields' and `sort-numeric-fields', except -that if there is no prefix argument then the UI prompts for the field -index or indices. In `transient-mark-mode' only: if the region is not -set then the UI attempts to set it to include all consecutive CSV -records around point, and prompts for confirmation; if there is no -prefix argument then the UI prompts for it, offering as a default the -index of the field containing point if the region was not set -explicitly. The region set automatically is delimited by blank lines -and comment lines, and the number of header lines at the beginning of -the region given by the value of `csv-header-lines' are skipped. - -Sort order is controlled by `csv-descending'. - -CSV mode provides the following specific keyboard key bindings: - -\\{csv-mode-map}" - (turn-off-auto-fill) - ;; Set syntax for field quotes: - (csv-set-quote-syntax csv-field-quotes) - ;; Make sexp functions apply to fields: - (set (make-local-variable 'forward-sexp-function) 'csv-forward-field) - ;; Paragraph means a group of contiguous records: - (make-local-variable 'paragraph-separate) - (make-local-variable 'paragraph-start) - ;; Comment support: - (make-local-variable 'comment-start) - (csv-set-comment-start csv-comment-start) - (setq - ;; Font locking -- separator plus syntactic: - font-lock-defaults '(csv-font-lock-keywords) - buffer-invisibility-spec csv-invisibility-default - ;; Mode line to support `csv-field-index-mode': - mode-line-format csv-mode-line-format) - ;; Enable or disable `csv-field-index-mode' (could probably do this - ;; a bit more efficiently): - (csv-field-index-mode (symbol-value 'csv-field-index-mode))) - -(defun csv-set-comment-start (string) - "Set comment start for this CSV mode buffer to STRING. -It must be either a string or nil." - (interactive - (list (edit-and-eval-command - "Comment start (string or nil): " csv-comment-start))) - (setq csv-comment-start string - paragraph-separate "[:space:]*$" ; white space - paragraph-start "\n") ; must include \n explicitly! - (if string - (progn - (setq paragraph-separate (concat paragraph-separate "\\|" string) - paragraph-start (concat paragraph-start "\\|" string) - comment-start string) - (modify-syntax-entry - (string-to-char string) "<" csv-mode-syntax-table) - (modify-syntax-entry ?\n ">" csv-mode-syntax-table)) - (with-syntax-table text-mode-syntax-table - (modify-syntax-entry (string-to-char string) - (string (char-syntax (string-to-char string))) - csv-mode-syntax-table) - (modify-syntax-entry ?\n - (string (char-syntax ?\n)) - csv-mode-syntax-table)))) - -(add-to-list 'auto-mode-alist '("\\.[Cc][Ss][Vv]\\'" . csv-mode)) - -(define-key csv-mode-map [(control ?c) (control ?v)] 'csv-toggle-invisibility) -(define-key csv-mode-map [(control ?c) (control ?t)] 'csv-transpose) -(define-key csv-mode-map [(control ?c) (control ?c)] 'csv-set-comment-start) -(define-key csv-mode-map [(control ?c) (control ?u)] 'csv-unalign-fields) -(define-key csv-mode-map [(control ?c) (control ?a)] 'csv-align-fields) -(define-key csv-mode-map [(control ?c) (control ?z)] 'csv-yank-as-new-table) -(define-key csv-mode-map [(control ?c) (control ?y)] 'csv-yank-fields) -(define-key csv-mode-map [(control ?c) (control ?k)] 'csv-kill-fields) -(define-key csv-mode-map [(control ?c) (control ?d)] 'csv-toggle-descending) -(define-key csv-mode-map [(control ?c) (control ?r)] 'csv-reverse-region) -(define-key csv-mode-map [(control ?c) (control ?n)] 'csv-sort-numeric-fields) -(define-key csv-mode-map [(control ?c) (control ?s)] 'csv-sort-fields) - -(defvar csv-descending nil - "If non-nil, CSV mode sort functions sort in order of descending sort key. -Usually they sort in order of ascending sort key.") - -(defun csv-toggle-descending () - "Toggle `csv-descending'." - (interactive) - (setq csv-descending (not csv-descending)) - (message "Sort order is %sscending" (if csv-descending "de" "a"))) - -(defun csv-toggle-invisibility () - "Toggle `buffer-invisibility-spec'." - (interactive) - (setq buffer-invisibility-spec (not buffer-invisibility-spec)) - (message "Separators in aligned records will be %svisible \ -\(after re-aligning if soft\)" - (if buffer-invisibility-spec "in" "")) - (redraw-frame (selected-frame))) - -(easy-menu-define - csv-menu - csv-mode-map - "CSV major mode menu keymap" - '("CSV" - ["Sort By Field Lexicographically" csv-sort-fields :active t - :help "Sort lines in region lexicographically by the specified field"] - ["Sort By Field Numerically" csv-sort-numeric-fields :active t - :help "Sort lines in region numerically by the specified field"] - ["Reverse Order of Lines" csv-reverse-region :active t - :help "Reverse the order of the lines in the region"] - ["Use Descending Sort Order" csv-toggle-descending :active t - :style toggle :selected csv-descending - :help "If selected, use descending order when sorting"] - "--" - ["Kill Fields (Columns)" csv-kill-fields :active t - :help "Kill specified fields of each line in the region"] - ["Yank Fields (Columns)" csv-yank-fields :active t - :help "Yank killed fields as specified field of each line in region"] - ["Yank As New Table" csv-yank-as-new-table :active t - :help "Yank killed fields as a new table at point"] - ["Align Fields into Columns" csv-align-fields :active t - :help "Align the start of every field of each line in the region"] - ["Unalign Columns into Fields" csv-unalign-fields :active t - :help "Undo soft alignment and optionally remove redundant white space"] - ["Transpose Rows and Columns" csv-transpose :active t - :help "Rewrite rows (which may have different lengths) as columns"] - "--" - ["Forward Field" forward-sexp :active t - :help "Move forward across one field\; with ARG, do it that many times"] - ["Backward Field" backward-sexp :active t - :help "Move backward across one field\; with ARG, do it that many times"] - ["Kill Field Forward" kill-sexp :active t - :help "Kill field following cursor\; with ARG, do it that many times"] - ["Kill Field Backward" backward-kill-sexp :active t - :help "Kill field preceding cursor\; with ARG, do it that many times"] - "--" - ("Alignment Style" - ["Left" (setq csv-align-style 'left) :active t - :style radio :selected (eq csv-align-style 'left) - :help "If selected, `csv-align-fields' left aligns fields"] - ["Centre" (setq csv-align-style 'centre) :active t - :style radio :selected (eq csv-align-style 'centre) - :help "If selected, `csv-align-fields' centres fields"] - ["Right" (setq csv-align-style 'right) :active t - :style radio :selected (eq csv-align-style 'right) - :help "If selected, `csv-align-fields' right aligns fields"] - ["Auto" (setq csv-align-style 'auto) :active t - :style radio :selected (eq csv-align-style 'auto) - :help "\ -If selected, `csv-align-fields' left aligns text and right aligns numbers"] - ) - ["Show Current Field Index" csv-field-index-mode :active t - :style toggle :selected csv-field-index-mode - :help "If selected, display current field index in mode line"] - ["Make Separators Invisible" csv-toggle-invisibility :active t - :style toggle :selected buffer-invisibility-spec - :help "If selected, separators in aligned records are invisible"] - ["Set Buffer's Comment Start" csv-set-comment-start :active t - :help "Set comment start string for this buffer"] - ["Customize CSV Mode" (customize-group 'CSV) :active t - :help "Open a customization buffer to change CSV mode options"] - )) - -(require 'sort) - -(defsubst csv-not-looking-at-record () - "Return t if looking at blank or comment line, nil otherwise. -Assumes point is at beginning of line." - (looking-at paragraph-separate)) - -(defun csv-interactive-args (&optional type) - "Get arg or field(s) and region interactively, offering sensible defaults. -Signal an error if the buffer is read-only. -If TYPE is noarg then return a list `(beg end)'. -Otherwise, return a list `(arg beg end)', where arg is: - the raw prefix argument by default\; - a single field index if TYPE is single\; - a list of field indices or index ranges if TYPE is multiple. -Field defaults to the current prefix arg\; if not set, prompt user. - -A field index list consists of positive or negative integers or ranges, -separated by any non-integer characters. A range has the form m-n, -where m and n are positive or negative integers, m < n, and n defaults -to the last field index if omitted. - -In transient mark mode, if the mark is not active then automatically -select and highlight CSV records around point, and query user. -The default field when read interactively is the current field." - ;; Must be run interactively to activate mark! - (let* ((arg current-prefix-arg) (default-field 1) - (region - (if (and transient-mark-mode (not mark-active)) - ;; Set region automatically: - (save-excursion - (let (startline lbp) - (if arg - (beginning-of-line) - (setq lbp (line-beginning-position)) - (while (re-search-backward csv-separator-regexp lbp 1) - ;; Move as far as possible, i.e. to beginning of line. - (setq default-field (1+ default-field)))) - (if (csv-not-looking-at-record) - (error "Point may not be within CSV records")) - (setq startline (point)) - ;; Set mark at beginning of region: - (while (not (or (bobp) (csv-not-looking-at-record))) - (forward-line -1)) - (if (csv-not-looking-at-record) (forward-line 1)) - ;; Skip header lines: - (forward-line csv-header-lines) - (set-mark (point)) ; OK since in save-excursion - ;; Move point to end of region: - (goto-char startline) - (beginning-of-line) - (while (not (or (eobp) (csv-not-looking-at-record))) - (forward-line 1)) - ;; Show mark briefly if necessary: - (unless (and (pos-visible-in-window-p) - (pos-visible-in-window-p (mark))) - (exchange-point-and-mark) - (sit-for 1) - (exchange-point-and-mark)) - (or (y-or-n-p "Region OK? ") - (error "Action aborted by user")) - (message nil) ; clear y-or-n-p message - (list (region-beginning) (region-end)))) - ;; Use region set by user: - (list (region-beginning) (region-end))))) - (setq default-field (number-to-string default-field)) - (cond - ((eq type 'multiple) - (if arg - ;; Ensure that field is a list: - (or (consp arg) - (setq arg (list (prefix-numeric-value arg)))) - ;; Read field interactively, ignoring non-integers: - (setq arg - (mapcar - (lambda (x) - (if (string-match "-" x 1) ; not first character - ;; Return a range as a pair - the cdr may be nil: - (let ((m (substring x 0 (match-beginning 0))) - (n (substring x (match-end 0)))) - (cons (car (read-from-string m)) - (and (not (string= n "")) - (car (read-from-string n))))) - ;; Return a number as a number: - (car (read-from-string x)))) - (split-string - (read-string - "Fields (sequence of integers or ranges): " default-field) - "[^-+0-9]+"))))) - ((eq type 'single) - (if arg - (setq arg (prefix-numeric-value arg)) - (while (not (integerp arg)) - (setq arg (eval-minibuffer "Field (integer): " default-field)))))) - (if (eq type 'noarg) region (cons arg region)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Sorting by field -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun csv-nextrecfun () - "Called by `csv-sort-fields-1' with point at end of previous record. -It moves point to the start of the next record. -It should move point to the end of the buffer if there are no more records." - (forward-line) - (while (and (not (eobp)) (csv-not-looking-at-record)) - (forward-line))) - -(defun csv-sort-fields-1 (field beg end startkeyfun endkeyfun) - "Modified version of `sort-fields-1' that skips blank or comment lines. - -FIELD is a single field index, and BEG and END specify the region to -sort. - -STARTKEYFUN moves from the start of the record to the start of the key. -It may return either a non-nil value to be used as the key, or -else the key is the substring between the values of point after -STARTKEYFUN and ENDKEYFUN are called. If STARTKEYFUN is nil, the key -starts at the beginning of the record. - -ENDKEYFUN moves from the start of the sort key to the end of the sort key. -ENDKEYFUN may be nil if STARTKEYFUN returns a value or if it would be the -same as ENDRECFUN." - (let ((tbl (syntax-table))) - (if (zerop field) (setq field 1)) - (unwind-protect - (save-excursion - (save-restriction - (narrow-to-region beg end) - (goto-char (point-min)) - (set-syntax-table sort-fields-syntax-table) - (sort-subr csv-descending - 'csv-nextrecfun 'end-of-line - startkeyfun endkeyfun))) - (set-syntax-table tbl)))) - -(defun csv-sort-fields (field beg end) - "Sort lines in region lexicographically by the ARGth field of each line. -If not set, the region defaults to the CSV records around point. -Fields are separated by `csv-separators' and null fields are allowed anywhere. -Field indices increase from 1 on the left or decrease from -1 on the right. -A prefix argument specifies a single field, otherwise prompt for field index. -Ignore blank and comment lines. The variable `sort-fold-case' -determines whether alphabetic case affects the sort order. -When called non-interactively, FIELD is a single field index\; -BEG and END specify the region to sort." - ;; (interactive "*P\nr") - (interactive (csv-interactive-args 'single)) - (barf-if-buffer-read-only) - (csv-sort-fields-1 field beg end - (lambda () (csv-sort-skip-fields field) nil) - (lambda () (skip-chars-forward csv-skip-regexp)))) - -(defun csv-sort-numeric-fields (field beg end) - "Sort lines in region numerically by the ARGth field of each line. -If not set, the region defaults to the CSV records around point. -Fields are separated by `csv-separators'. -Null fields are allowed anywhere and sort as zeros. -Field indices increase from 1 on the left or decrease from -1 on the right. -A prefix argument specifies a single field, otherwise prompt for field index. -Specified non-null field must contain a number in each line of the region, -which may begin with \"0x\" or \"0\" for hexadecimal and octal values. -Otherwise, the number is interpreted according to sort-numeric-base. -Ignore blank and comment lines. -When called non-interactively, FIELD is a single field index\; -BEG and END specify the region to sort." - ;; (interactive "*P\nr") - (interactive (csv-interactive-args 'single)) - (barf-if-buffer-read-only) - (csv-sort-fields-1 field beg end - (lambda () - (csv-sort-skip-fields field) - (let* ((case-fold-search t) - (base - (if (looking-at "\\(0x\\)[0-9a-f]\\|\\(0\\)[0-7]") - (cond ((match-beginning 1) - (goto-char (match-end 1)) - 16) - ((match-beginning 2) - (goto-char (match-end 2)) - 8) - (t nil))))) - (string-to-number (buffer-substring (point) - (save-excursion - (forward-sexp 1) - (point))) - (or base sort-numeric-base)))) - nil)) - -(defun csv-reverse-region (beg end) - "Reverse the order of the lines in the region. -This is just a CSV-mode style interface to `reverse-region', which is -the function that should be used non-interactively. It takes two -point or marker arguments, BEG and END, delimiting the region." - ;; (interactive "*P\nr") - (interactive (csv-interactive-args 'noarg)) - (barf-if-buffer-read-only) - (reverse-region beg end)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Moving by field -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defsubst csv-end-of-field () - "Skip forward over one field." - (skip-syntax-forward " ") - (if (eq (char-syntax (following-char)) ?\") - (goto-char (scan-sexps (point) 1))) - (skip-chars-forward csv-skip-regexp)) - -(defsubst csv-beginning-of-field () - "Skip backward over one field." - (skip-syntax-backward " ") - (if (eq (char-syntax (preceding-char)) ?\") - (goto-char (scan-sexps (point) -1))) - (skip-chars-backward csv-skip-regexp)) - -(defun csv-forward-field (arg) - "Move forward across one field, cf. `forward-sexp'. -With ARG, do it that many times. Negative arg -N means -move backward across N fields." - (interactive "p") - (if (< arg 0) - (csv-backward-field (- arg)) - (while (>= (setq arg (1- arg)) 0) - (if (or (bolp) - (when (and (not (eobp)) (eolp)) (forward-char) t)) - (while (and (not (eobp)) (csv-not-looking-at-record)) - (forward-line 1))) - (if (memq (following-char) csv-separator-chars) (forward-char)) - (csv-end-of-field)))) - -(defun csv-backward-field (arg) - "Move backward across one field, cf. `backward-sexp'. -With ARG, do it that many times. Negative arg -N means -move forward across N fields." - (interactive "p") - (if (< arg 0) - (csv-forward-field (- arg)) - (while (>= (setq arg (1- arg)) 0) - (when (or (eolp) - (when (and (not (bobp)) (bolp)) (backward-char) t)) - (while (progn - (beginning-of-line) - (csv-not-looking-at-record)) - (backward-char)) - (end-of-line)) - (if (memq (preceding-char) csv-separator-chars) (backward-char)) - (csv-beginning-of-field)))) - -(defun csv-sort-skip-fields (n &optional yank) - "Position point at the beginning of field N on the current line. -Fields are separated by `csv-separators'\; null terminal field allowed. -Assumes point is initially at the beginning of the line. -YANK non-nil allows N to be greater than the number of fields, in -which case extend the record as necessary." - (if (> n 0) - ;; Skip across N - 1 fields. - (let ((i (1- n))) - (while (> i 0) - (csv-end-of-field) - (if (eolp) - (if yank - (if (> i 1) (insert (car csv-separators))) - (error "Line has too few fields: %s" - (buffer-substring - (save-excursion (beginning-of-line) (point)) - (save-excursion (end-of-line) (point))))) - (forward-char)) ; skip separator - (setq i (1- i)))) - (end-of-line) - ;; Skip back across -N - 1 fields. - (let ((i (1- (- n)))) - (while (> i 0) - (csv-beginning-of-field) - (if (bolp) - (error "Line has too few fields: %s" - (buffer-substring - (save-excursion (beginning-of-line) (point)) - (save-excursion (end-of-line) (point))))) - (backward-char) ; skip separator - (setq i (1- i))) - ;; Position at the front of the field - ;; even if moving backwards. - (csv-beginning-of-field)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Field index mode -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; Based partly on paren.el - -(defcustom csv-field-index-delay 0.125 - "Time in seconds to delay before updating field index display." - :group 'CSV - :type '(number :tag "seconds")) - -(defvar csv-field-index-idle-timer nil) - -(defvar csv-field-index-string nil) -(make-variable-buffer-local 'csv-field-index-string) - -(defvar csv-field-index-old nil) -(make-variable-buffer-local 'csv-field-index-old) - -(define-minor-mode csv-field-index-mode - "Toggle CSV-Field-Index mode. -With prefix ARG, turn CSV-Field-Index mode on if and only if ARG is positive. -Returns the new status of CSV-Field-Index mode (non-nil means on). -When CSV-Field-Index mode is enabled, the current field index appears in -the mode line after `csv-field-index-delay' seconds of Emacs idle time." - :group 'CSV - :global t - :init-value t ; for documentation, since default is t - ;; This macro generates a function that first sets the mode - ;; variable, then runs the following code, runs the mode hooks, - ;; displays a message if interactive, updates the mode line and - ;; finally returns the variable value. - - ;; First, always disable the mechanism (to avoid having two timers): - (when csv-field-index-idle-timer - (cancel-timer csv-field-index-idle-timer) - (setq csv-field-index-idle-timer nil)) - ;; Now, if the mode is on and any buffer is in CSV mode then - ;; re-initialize and enable the mechanism by setting up a new timer: - (if csv-field-index-mode - (if (memq t (mapcar (lambda (buffer) - (with-current-buffer buffer - (when (eq major-mode 'csv-mode) - (setq csv-field-index-string nil - csv-field-index-old nil) - t))) - (buffer-list))) - (setq csv-field-index-idle-timer - (run-with-idle-timer csv-field-index-delay t - 'csv-field-index))) - ;; but if the mode is off then remove the display from the mode - ;; lines of all CSV buffers: - (mapc (lambda (buffer) - (with-current-buffer buffer - (when (eq major-mode 'csv-mode) - (setq csv-field-index-string nil - csv-field-index-old nil) - (force-mode-line-update)))) - (buffer-list)))) - -(defun csv-field-index () - "Construct `csv-field-index-string' to display in mode line. -Called by `csv-field-index-idle-timer'." - (if (eq major-mode 'csv-mode) - (save-excursion - (let ((lbp (line-beginning-position)) (field 1)) - (while (re-search-backward csv-separator-regexp lbp 1) - ;; Move as far as possible, i.e. to beginning of line. - (setq field (1+ field))) - (if (csv-not-looking-at-record) (setq field nil)) - (when (not (eq field csv-field-index-old)) - (setq csv-field-index-old field - csv-field-index-string - (and field (propertize (format "F%d" field) - 'help-echo csv-mode-line-help-echo))) - (force-mode-line-update)))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Killing and yanking fields -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defvar csv-killed-fields nil - "A list of the fields or sub-records last killed by `csv-kill-fields'.") - -(defun csv-kill-fields (fields beg end) - "Kill specified fields of each line in the region. -If not set, the region defaults to the CSV records around point. -Fields are separated by `csv-separators' and null fields are allowed anywhere. -Field indices increase from 1 on the left or decrease from -1 on the right. -The fields are stored for use by `csv-yank-fields'. Fields can be -specified in any order but are saved in increasing index order. -Ignore blank and comment lines. - -When called interactively, a prefix argument specifies a single field, -otherwise prompt for a field list, which may include ranges in the form -m-n, where m < n and n defaults to the last field index if omitted. - -When called non-interactively, FIELDS is a single field index or a -list of field indices, with ranges specified as (m.n) or (m), and BEG -and END specify the region to process." - ;; (interactive "*P\nr") - (interactive (csv-interactive-args 'multiple)) - (barf-if-buffer-read-only) - ;; Kill the field(s): - (setq csv-killed-fields nil) - (save-excursion - (save-restriction - (narrow-to-region beg end) - (goto-char (point-min)) - (if (or (cdr fields) (consp (car fields))) - (csv-kill-many-columns fields) - (csv-kill-one-column (car fields))))) - (setq csv-killed-fields (nreverse csv-killed-fields))) - -(defmacro csv-kill-one-field (field killed-fields) - "Kill field with index FIELD in current line. -Save killed field by `push'ing onto KILLED-FIELDS. -Assumes point is at beginning of line. -Called by `csv-kill-one-column' and `csv-kill-many-columns'." - `(progn - ;; Move to start of field to kill: - (csv-sort-skip-fields ,field) - ;; Kill to end of field (cf. `kill-region'): - (push (delete-and-extract-region - (point) - (progn (csv-end-of-field) (point))) - ,killed-fields) - (if (eolp) (delete-char -1) ; delete trailing separator at eol - (delete-char 1)))) ; or following separator otherwise - -(defun csv-kill-one-column (field) - "Kill field with index FIELD in all lines in (narrowed) buffer. -Save killed fields in `csv-killed-fields'. -Assumes point is at `point-min'. Called by `csv-kill-fields'. -Ignore blank and comment lines." - (while (not (eobp)) - (or (csv-not-looking-at-record) - (csv-kill-one-field field csv-killed-fields)) - (forward-line))) - -(defun csv-kill-many-columns (fields) - "Kill several fields in all lines in (narrowed) buffer. -FIELDS is an unordered list of field indices. -Save killed fields in increasing index order in `csv-killed-fields'. -Assumes point is at `point-min'. Called by `csv-kill-fields'. -Ignore blank and comment lines." - (if (eolp) (error "First record is empty")) - ;; Convert non-positive to positive field numbers: - (let ((last 1) (f fields)) - (csv-end-of-field) - (while (not (eolp)) - (forward-char) ; skip separator - (csv-end-of-field) - (setq last (1+ last))) ; last = # fields in first record - (while f - (cond ((consp (car f)) - ;; Expand a field range: (m.n) -> m m+1 ... n-1 n. - ;; If n is nil then it defaults to the number of fields. - (let* ((range (car f)) (cdrf (cdr f)) - (m (car range)) (n (cdr range))) - (if (< m 0) (setq m (+ m last 1))) - (if n - (if (< n 0) (setq n (+ n last 1))) - (setq n last)) - (setq range (list n)) - (while (> n m) (push (setq n (1- n)) range)) - (setcar f (car range)) - (setcdr f (cdr range)) - (setcdr (setq f (last range)) cdrf))) - ((zerop (car f)) (setcar f 1)) - ((< (car f) 0) (setcar f (+ f last 1)))) - (setq f (cdr f)))) - (goto-char (point-min)) - ;; Kill from right to avoid miscounting: - (setq fields (sort fields '>)) - (while (not (eobp)) - (or (csv-not-looking-at-record) - (let ((fields fields) killed-fields field) - (while fields - (setq field (car fields) - fields (cdr fields)) - (beginning-of-line) - (csv-kill-one-field field killed-fields)) - (push (mapconcat 'identity killed-fields (car csv-separators)) - csv-killed-fields))) - (forward-line))) - -(defun csv-yank-fields (field beg end) - "Yank fields as the ARGth field of each line in the region. -ARG may be arbitrarily large and records are extended as necessary. -If not set, the region defaults to the CSV records around point\; -if point is not in a CSV record then offer to yank as a new table. -The fields yanked are those last killed by `csv-kill-fields'. -Fields are separated by `csv-separators' and null fields are allowed anywhere. -Field indices increase from 1 on the left or decrease from -1 on the right. -A prefix argument specifies a single field, otherwise prompt for field index. -Ignore blank and comment lines. When called non-interactively, FIELD -is a single field index\; BEG and END specify the region to process." - ;; (interactive "*P\nr") - (interactive (condition-case err - (csv-interactive-args 'single) - (error (list nil nil err)))) - (barf-if-buffer-read-only) - (if (null beg) - (if (y-or-n-p (concat (error-message-string end) - ". Yank as a new table? ")) - (csv-yank-as-new-table) - (error (error-message-string end))) - (if (<= field 0) (setq field (1+ field))) - (save-excursion - (save-restriction - (narrow-to-region beg end) - (goto-char (point-min)) - (let ((fields csv-killed-fields)) - (while (not (eobp)) - (unless (csv-not-looking-at-record) - ;; Yank at start of specified field if possible, - ;; otherwise yank at end of record: - (if (zerop field) - (end-of-line) - (csv-sort-skip-fields field 'yank)) - (and (eolp) (insert (car csv-separators))) - (when fields - (insert (car fields)) - (setq fields (cdr fields))) - (or (eolp) (insert (car csv-separators)))) - (forward-line))))))) - -(defun csv-yank-as-new-table () - "Yank fields as a new table starting at point. -The fields yanked are those last killed by `csv-kill-fields'." - (interactive "*") - (let ((fields csv-killed-fields)) - (while fields - (insert (car fields) ?\n) - (setq fields (cdr fields))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Aligning fields -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun csv-align-fields (hard beg end) - "Align all the fields in the region to form columns. -The alignment style is specified by `csv-align-style'. The number of -spaces specified by `csv-align-fields' appears after each separator. -Use soft alignment done by displaying virtual white space after the -separators unless invoked with an argument, in which case insert real -space characters into the buffer after the separators. -Unalign first (see `csv-unalign-fields'). Ignore blank and comment lines. - -In hard-aligned records, separators become invisible whenever -`buffer-invisibility-spec' is non-nil. In soft-aligned records, make -separators invisible if and only if `buffer-invisibility-spec' is -non-nil when the records are aligned\; this can be changed only by -re-aligning. \(Unaligning always makes separators visible.) - -When called non-interactively, use hard alignment if HARD is non-nil\; -BEG and END specify the region to align." - (interactive (csv-interactive-args)) - (setq end (set-marker (make-marker) end)) - (csv-unalign-fields hard beg end) ; if hard then barfs if buffer read only - (save-excursion - (save-restriction - (narrow-to-region beg end) - (set-marker end nil) - (goto-char (point-min)) - (let (widths) - ;; Construct list of column widths: - (while (not (eobp)) ; for each record... - (or (csv-not-looking-at-record) - (let ((w widths) x) - (setq beg (point)) ; beginning of current field - (while (not (eolp)) - (csv-end-of-field) - (setq x (- (point) beg)) ; field width - (if w - (if (> x (car w)) (setcar w x)) - (setq w (list x) - widths (nconc widths w))) - (or (eolp) (forward-char)) ; skip separator - (setq w (cdr w) - beg (point))))) - (forward-line)) - - ;; Align fields: - (goto-char (point-min)) - (while (not (eobp)) ; for each record... - (or (csv-not-looking-at-record) - (let ((w widths) (padding 0) x) - (setq beg (point)) ; beginning of current field - (while (and w (not (eolp))) - (let ((left-padding 0) (right-padding 0) overlay) - (csv-end-of-field) - (set-marker end (point)) ; end of current field - (setq x (- (point) beg) ; field width - x (- (car w) x)) ; required padding - - ;; beg = beginning of current field - ;; end = (point) = end of current field - - ;; Compute required padding: - (cond - ((eq csv-align-style 'left) - ;; Left align -- pad on the right: - (setq left-padding csv-align-padding - right-padding x)) - ((eq csv-align-style 'right) - ;; Right align -- pad on the left: - (setq left-padding (+ csv-align-padding x))) - ((eq csv-align-style 'auto) - ;; Auto align -- left align text, right align numbers: - (if (string-match "\\`[-+.[:digit:]]+\\'" - (buffer-substring beg (point))) - ;; Right align -- pad on the left: - (setq left-padding (+ csv-align-padding x)) - ;; Left align -- pad on the right: - (setq left-padding csv-align-padding - right-padding x))) - ((eq csv-align-style 'centre) - ;; Centre -- pad on both left and right: - (let ((y (/ x 2))) ; truncated integer quotient - (setq left-padding (+ csv-align-padding y) - right-padding (- x y))))) - - (if hard - ;; Hard alignment... - (progn - (when (> left-padding 0) ; pad on the left - ;; Insert spaces before field: - (if (= beg end) ; null field - (insert (make-string left-padding ?\ )) - (goto-char beg) ; beginning of current field - (insert (make-string left-padding ?\ )) - (goto-char end))) ; end of current field - (unless (eolp) - (if (> right-padding 0) ; pad on the right - ;; Insert spaces after field: - (insert (make-string right-padding ?\ ))) - ;; Make separator (potentially) invisible; - ;; in Emacs 21.3, neighbouring overlays - ;; conflict, so use the following only - ;; with hard alignment: - (overlay-put (make-overlay (point) (1+ (point))) - ;; 'face 'secondary-selection) ; test - 'invisible t) - (forward-char))) ; skip separator - - ;; Soft alignment... - - (if buffer-invisibility-spec ; csv-hide-separators - - ;; Hide separators... - (progn - ;; Merge right-padding from previous field - ;; with left-padding from this field: - (setq padding (+ padding left-padding)) - (when (> padding 0) - (goto-char beg) ; beginning of current field - (if (bolp) - ;; Display spaces before first field - ;; by overlaying first character: - (overlay-put - (make-overlay (point) (1+ (point))) - 'before-string - (make-string padding ?\ )) - ;; Display separator as spaces: - (overlay-put - (make-overlay (1- (point)) (point)) - ;; 'face 'secondary-selection)) ; test - ;; 'display (make-string padding ?\ ))) - ;; Above 'display mangles buffer - ;; horribly if any string is empty! - 'display `(space :width ,padding))) - (goto-char end)) ; end of current field - (unless (eolp) - (setq padding right-padding) - (forward-char))) ; skip separator - - ;; Do not hide separators... - (when (> left-padding 0) ; pad on the left - ;; Display spaces before field: - (setq overlay (make-overlay beg (point))) - (overlay-put overlay 'before-string - (make-string left-padding ?\ ))) - (unless (eolp) - (if (> right-padding 0) ; pad on the right - ;; Display spaces after field: - (overlay-put - (or overlay - (make-overlay beg (point))) - 'after-string (make-string right-padding ?\ ))) - (forward-char))) ; skip separator - - )) - - (setq w (cdr w) - beg (point))))) - (forward-line))))) - (set-marker end nil)) - -(defun csv-unalign-fields (hard beg end) - "Undo soft alignment and optionally remove redundant white space. -Undo soft alignment introduced by `csv-align-fields'. If invoked with -an argument then also remove all spaces and tabs around separators. -Also make all invisible separators visible again. -Ignore blank and comment lines. When called non-interactively, remove -spaces and tabs if HARD non-nil\; BEG and END specify region to unalign." - (interactive (csv-interactive-args)) - ;; Remove any soft alignment: - (mapc 'delete-overlay (overlays-in beg end)) - (when hard - (barf-if-buffer-read-only) - ;; Remove any white-space padding around separators: - (save-excursion - (save-restriction - (narrow-to-region beg end) - (goto-char (point-min)) - (while (not (eobp)) - (or (csv-not-looking-at-record) - (while (not (eolp)) - ;; Delete horizontal white space forward: - ;; (delete-horizontal-space) - ;; This relies on left-to-right argument evaluation; - ;; see info node (elisp) Function Forms. - (delete-region (point) - (+ (point) (skip-chars-forward " \t"))) - (csv-end-of-field) - ;; Delete horizontal white space backward: - ;; (delete-horizontal-space t) - (delete-region (point) - (+ (point) (skip-chars-backward " \t"))) - (or (eolp) (forward-char)))) - (forward-line)))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Transposing rows and columns -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun csv-transpose (beg end) - "Rewrite rows (which may have different lengths) as columns. -Null fields are introduced as necessary within records but are -stripped from the ends of records. Preserve soft alignment. -This function is its own inverse. Ignore blank and comment lines. -When called non-interactively, BEG and END specify region to process." - ;; (interactive "*P\nr") - (interactive (csv-interactive-args 'noarg)) - (barf-if-buffer-read-only) - (save-excursion - (save-restriction - (narrow-to-region beg end) - (goto-char (point-min)) - ;; Delete rows and collect them as a reversed list of lists of - ;; fields, skipping comment and blank lines: - (let ((sep (car csv-separators)) - (align (overlays-in beg end)) - rows columns) - ;; Remove soft alignment if necessary: - (when align - (mapc 'delete-overlay align) - (setq align t)) - (while (not (eobp)) - (if (csv-not-looking-at-record) - ;; Skip blank and comment lines: - (forward-line) - (let ((lep (line-end-position))) - (push - (csv-split-string - (buffer-substring-no-properties (point) lep) - csv-separator-regexp nil t) - rows) - (delete-region (point) lep) - (or (eobp) (delete-char 1))))) - ;; Rows must have monotonic decreasing lengths to be - ;; transposable, so ensure this by padding with null fields. - ;; rows is currently a reversed list of field lists, which - ;; must therefore have monotonic increasing lengths. - (let ((oldlen (length (car rows))) newlen - (r (cdr rows))) - (while r - (setq newlen (length (car r))) - (if (< newlen oldlen) - (nconc (car r) (make-list (- oldlen newlen) nil)) - (setq oldlen newlen)) - (setq r (cdr r)))) - ;; Collect columns as a reversed list of lists of fields: - (while rows - (let (column (r rows) row) - (while r - (setq row (car r)) - ;; Provided it would not be a trailing null field, push - ;; field onto column: - (if (or column (string< "" (car row))) - (push (car row) column)) - ;; Pop field off row: - (setcar r (cdr row)) - ;; If row is now empty then remove it: - (or (car r) (setq rows (cdr rows))) - (setq r (cdr r))) - (push column columns))) - ;; Insert columns into buffer as rows: - (setq columns (nreverse columns)) - (while columns - (insert (mapconcat 'identity (car columns) sep) ?\n) - (setq columns (cdr columns))) - ;; Re-do soft alignment if necessary: - (if align (csv-align-fields nil (point-min) (point-max))))))) - -;; The following generalised version of `split-string' is taken from -;; the development version of WoMan and should probably replace the -;; standard version in subr.el. However, CSV mode (currently) needs -;; only the `allowbeg' option. - -(defun csv-split-string - (string &optional separators subexp allowbeg allowend) - "Splits STRING into substrings where there are matches for SEPARATORS. -Each match for SEPARATORS is a splitting point. -The substrings between the splitting points are made into a list -which is returned. -If SEPARATORS is absent, it defaults to \"[ \\f\\t\\n\\r\\v]+\". -SUBEXP specifies a subexpression of SEPARATORS to be the splitting -point\; it defaults to 0. - -If there is a match for SEPARATORS at the beginning of STRING, we do -not include a null substring for that, unless ALLOWBEG is non-nil. -Likewise, if there is a match at the end of STRING, we do not include -a null substring for that, unless ALLOWEND is non-nil. - -Modifies the match data; use `save-match-data' if necessary." - (or subexp (setq subexp 0)) - (let ((rexp (or separators "[ \f\t\n\r\v]+")) - (start 0) - notfirst - (list nil)) - (while (and (string-match rexp string - (if (and notfirst - (= start (match-beginning subexp)) - (< start (length string))) - (1+ start) start)) - (< (match-beginning subexp) (length string))) - (setq notfirst t) - (or (and (not allowbeg) (eq (match-beginning subexp) 0)) - (and (eq (match-beginning subexp) (match-end subexp)) - (eq (match-beginning subexp) start)) - (push (substring string start (match-beginning subexp)) list)) - (setq start (match-end subexp))) - (or (and (not allowend) (eq start (length string))) - (push (substring string start) list)) - (nreverse list))) - -(provide 'csv-mode) - -;;; csv-mode.el ends here diff --git a/elisp/emacs-goodies-el/ctypes.el b/elisp/emacs-goodies-el/ctypes.el index 0b24122..0b24122 100755..100644 --- a/elisp/emacs-goodies-el/ctypes.el +++ b/elisp/emacs-goodies-el/ctypes.el diff --git a/elisp/emacs-goodies-el/dedicated.el b/elisp/emacs-goodies-el/dedicated.el index 0db9d2c..0db9d2c 100755..100644 --- a/elisp/emacs-goodies-el/dedicated.el +++ b/elisp/emacs-goodies-el/dedicated.el diff --git a/elisp/emacs-goodies-el/df.el b/elisp/emacs-goodies-el/df.el index 7196ca9..7196ca9 100755..100644 --- a/elisp/emacs-goodies-el/df.el +++ b/elisp/emacs-goodies-el/df.el diff --git a/elisp/emacs-goodies-el/diminish.el b/elisp/emacs-goodies-el/diminish.el deleted file mode 100755 index 6461e12..0000000 --- a/elisp/emacs-goodies-el/diminish.el +++ /dev/null @@ -1,293 +0,0 @@ -;;; diminish.el --- Diminished modes are minor modes with no modeline display - -;; Copyright (C) 1998 Free Software Foundation, Inc. - -;; Author: Will Mengarini <seldon@eskimo.com> -;; URL: <http://www.eskimo.com/~seldon> -;; Created: Th 19 Feb 98 -;; Version: 0.44, Sa 23 Jan 99 -;; Keywords: extensions, diminish, minor, codeprose - -;; This file is part of GNU Emacs. - -;; This program 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. - -;; This program 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; Minor modes each put a word on the mode line to signify that they're -;; active. This can cause other displays, such as % of file that point is -;; at, to run off the right side of the screen. For some minor modes, such -;; as mouse-avoidance-mode, the display is a waste of space, since users -;; typically set the mode in their .emacs & never change it. For other -;; modes, such as my jiggle-mode, it's a waste because there's already a -;; visual indication of whether the mode is in effect. - -;; A diminished mode is a minor mode that has had its mode line -;; display diminished, usually to nothing, although diminishing to a -;; shorter word or a single letter is also supported. This package -;; implements diminished modes. - -;; You can use this package either interactively or from your .emacs file. -;; In either case, first you'll need to copy this file to a directory that -;; appears in your load-path. `load-path' is the name of a variable that -;; contains a list of directories Emacs searches for files to load. -;; To prepend another directory to load-path, put a line like -;; (add-to-list 'load-path "c:/My_Directory") in your .emacs file. - -;; To create diminished modes interactively, type -;; M-x load-library -;; to get a prompt like -;; Load library: -;; and respond `diminish' (unquoted). Then type -;; M-x diminish -;; to get a prompt like -;; Diminish what minor mode: -;; and respond with the name of some minor mode, like mouse-avoidance-mode. -;; You'll then get this prompt: -;; To what mode-line display: -;; Respond by just hitting <Enter> if you want the name of the mode -;; completely removed from the mode line. If you prefer, you can abbreviate -;; the name. If your abbreviation is 2 characters or more, such as "Av", -;; it'll be displayed as a separate word on the mode line, just like minor -;; modes' names. If it's a single character, such as "V", it'll be scrunched -;; up against the previous word, so for example if the undiminished mode line -;; display had been "Abbrev Fill Avoid", it would become "Abbrev FillV". -;; Multiple single-letter diminished modes will all be scrunched together. -;; The display of undiminished modes will not be affected. - -;; To find out what the mode line would look like if all diminished modes -;; were still minor, type M-x diminished-modes. This displays in the echo -;; area the complete list of minor or diminished modes now active, but -;; displays them all as minor. They remain diminished on the mode line. - -;; To convert a diminished mode back to a minor mode, type M-x diminish-undo -;; to get a prompt like -;; Restore what diminished mode: -;; Respond with the name of some diminished mode. To convert all -;; diminished modes back to minor modes, respond to that prompt -;; with `diminished-modes' (unquoted, & note the hyphen). - -;; When you're responding to the prompts for mode names, you can use -;; completion to avoid extra typing; for example, m o u SPC SPC SPC -;; is usually enough to specify mouse-avoidance-mode. Mode names -;; typically end in "-mode", but for historical reasons -;; auto-fill-mode is named by "auto-fill-function". - -;; To create diminished modes noninteractively in your .emacs file, put -;; code like -;; (require 'diminish) -;; (diminish 'abbrev-mode "Abv") -;; (diminish 'jiggle-mode) -;; (diminish 'mouse-avoidance-mode "M") -;; near the end of your .emacs file. It should be near the end so that any -;; minor modes your .emacs loads will already have been loaded by the time -;; they're to be converted to diminished modes. - -;; To diminish a major mode, (setq mode-name "whatever") in the mode hook. - -;;; Epigraph: - -;; "The quality of our thoughts is bordered on all sides -;; by our facility with language." -;; --J. Michael Straczynski - -;;; Code: - -(eval-when-compile (require 'cl)) - -(defvar diminish-must-not-copy-minor-mode-alist nil - "Non-nil means loading diminish.el won't (copy-alist minor-mode-alist). -Normally `minor-mode-alist' is setq to that copy on loading diminish because -at least one of its cons cells, that for abbrev-mode, is read-only (see -ELisp Info on \"pure storage\"). If you setq this variable to t & then -try to diminish abbrev-mode under GNU Emacs 19.34, you'll get the error -message \"Attempt to modify read-only object\".") - -(or diminish-must-not-copy-minor-mode-alist - (callf copy-alist minor-mode-alist)) - -(defvar diminished-mode-alist nil - "The original `minor-mode-alist' value of all (diminish)ed modes.") - -(defvar diminish-history-symbols nil - "Command history for symbols of diminished modes.") - -(defvar diminish-history-names nil - "Command history for names of diminished modes.") - -;; When we diminish a mode, we are saying we want it to continue doing its -;; work for us, but we no longer want to be reminded of it. It becomes a -;; night worker, like a janitor; it becomes an invisible man; it remains a -;; component, perhaps an important one, sometimes an indispensable one, of -;; the mechanism that maintains the day-people's world, but its place in -;; their thoughts is diminished, usually to nothing. As we grow old we -;; diminish more and more such thoughts, such people, usually to nothing. - -;; "The wise man knows that to keep under is to endure." The diminished -;; often come to value their invisibility. We speak--speak--of "the strong -;; silent type", but only as a superficiality; a stereotype in a movie, -;; perhaps, but even if an acquaintance, necessarily, by hypothesis, a -;; distant one. The strong silent type is actually a process. It begins -;; with introspection, continues with judgment, and is shaped by the -;; discovery that these judgments are impractical to share; there is no -;; appetite for the wisdom of the self-critical among the creatures of -;; material appetite who dominate our world. Their dominance's Darwinian -;; implications reinforce the self-doubt that is the germ of higher wisdom. -;; The thoughtful contemplate the evolutionary triumph of the predator. -;; Gnostics deny the cosmos could be so evil; this must all be a prank; the -;; thoughtful remain silent, invisible, self-diminished, and discover, -;; perhaps at first in surprise, the freedom they thus gain, and grow strong. - -;;;###autoload -(defun diminish (mode &optional to-what) - "Diminish mode-line display of minor mode MODE to TO-WHAT (default \"\"). - -Interactively, enter (with completion) the name of any minor mode, followed -on the next line by what you want it diminished to (default empty string). -The response to neither prompt should be quoted. However, in Lisp code, -both args must be quoted, the first as a symbol, the second as a string, -as in (diminish 'jiggle-mode \" Jgl\"). - -The mode-line displays of minor modes usually begin with a space, so -the modes' names appear as separate words on the mode line. However, if -you're having problems with a cramped mode line, you may choose to use single -letters for some modes, without leading spaces. Capitalizing them works -best; if you then diminish some mode to \"X\" but have abbrev-mode enabled as -well, you'll get a display like \"AbbrevX\". This function prepends a space -to TO-WHAT if it's > 1 char long & doesn't already begin with a space." - (interactive (list (read (completing-read - "Diminish what minor mode: " - (mapcar (lambda (x) (list (symbol-name (car x)))) - minor-mode-alist) - nil t nil 'diminish-history-symbols)) - (read-from-minibuffer - "To what mode-line display: " - nil nil nil 'diminish-history-names))) - (let ((minor (assq mode minor-mode-alist))) - (or minor (error "%S is not currently registered as a minor mode" mode)) - (callf or to-what "") - (when (> (length to-what) 1) - (or (= (string-to-char to-what) ?\ ) - (callf2 concat " " to-what))) - (or (assq mode diminished-mode-alist) - (push (copy-sequence minor) diminished-mode-alist)) - (setcdr minor (list to-what)))) - -;; But an image comes to me, vivid in its unreality, of a loon alone on his -;; forest lake, shrieking his soul out into a canopy of stars. Alone this -;; afternoon in my warm city apartment, I can feel the bite of his night air, -;; and smell his conifers. In him there is no acceptance of diminishment. - -;; "I have a benevolent habit of pouring out myself to everybody, -;; and would even pay for a listener, and I am afraid -;; that the Athenians may think me too talkative." -;; --Socrates, in the /Euthyphro/ - -;; I remember a news story about a retired plumber who had somehow managed to -;; steal a military tank. He rode it down city streets, rode over a parked -;; car--no one was hurt--rode onto a freeway, that concrete symbol of the -;; American spirit, or so we fancy it, shouting "Plumber Bob! Plumber Bob!". -;; He was shot dead by police. - -;;;###autoload -(defun diminish-undo (mode) - "Restore mode-line display of diminished mode MODE to its minor-mode value. -Do nothing if the arg is a minor mode that hasn't been diminished. - -Interactively, enter (with completion) the name of any diminished mode (a -mode that was formerly a minor mode on which you invoked M-x diminish). -To restore all diminished modes to minor status, answer `diminished-modes'. -The response to the prompt shouldn't be quoted. However, in Lisp code, -the arg must be quoted as a symbol, as in (diminish-undo 'diminished-modes)." - (interactive - (list (read (completing-read - "Restore what diminished mode: " - (cons (list "diminished-modes") - (mapcar (lambda (x) (list (symbol-name (car x)))) - diminished-mode-alist)) - nil t nil 'diminish-history-symbols)))) - (if (eq mode 'diminished-modes) - (let ((diminished-modes diminished-mode-alist)) - (while diminished-modes - (diminish-undo (caar diminished-modes)) - (callf cdr diminished-modes))) - (let ((minor (assq mode minor-mode-alist)) - (diminished (assq mode diminished-mode-alist))) - (or minor - (error "%S is not currently registered as a minor mode" mode)) - (when diminished - (setcdr minor (cdr diminished)))))) - -;; Plumber Bob was not from Seattle, my grey city, for rainy Seattle is a -;; city of interiors, a city of the self-diminished. When I moved here one -;; sunny June I was delighted to find that ducks and geese were common in -;; the streets. But I hoped to find a loon or two, and all I found were -;; ducks and geese. I wondered about this; I wondered why there were no -;; loons in Seattle; but my confusion resulted from my ignorance of the -;; psychology of rain, which is to say my ignorance of diminished modes. -;; What I needed, and lacked, was a way to discover they were there. - -;;;###autoload -(defun diminished-modes () - "Echo all active diminished or minor modes as if they were minor. -The display goes in the echo area; if it's too long even for that, -you can see the whole thing in the *Messages* buffer. -This doesn't change the status of any modes; it just lets you see -what diminished modes would be on the mode-line if they were still minor." - (interactive) - (let ((minor-modes minor-mode-alist) - message) - (while minor-modes - (when (symbol-value (caar minor-modes)) - ;; This minor mode is active in this buffer - (let* ((mode-pair (car minor-modes)) - (mode (car mode-pair)) - (minor-pair (or (assq mode diminished-mode-alist) mode-pair)) - (minor-name (cadr minor-pair))) - (when (symbolp minor-name) - ;; This minor mode uses symbol indirection in the cdr - (let ((symbols-seen (list minor-name))) - (while (and (symbolp (callf symbol-value minor-name)) - (not (memq minor-name symbols-seen))) - (push minor-name symbols-seen)))) - (push minor-name message))) - (callf cdr minor-modes)) - (setq message (mapconcat 'identity (nreverse message) "")) - (when (= (string-to-char message) ?\ ) - (callf substring message 1)) - (message "%s" message))) - -;; A human mind is a Black Forest of diminished modes. Some are dangerous; -;; most of the mind of an intimate is a secret stranger, and these diminished -;; modes are rendered more unpredictable by their long isolation from the -;; corrective influence of interaction with reality. The student of history -;; learns that this description applies to whole societies as well. In some -;; ways the self-diminished are better able to discern the night worker. -;; They are rendered safer by their heightened awareness of others' -;; diminished modes, and more congenial by the spare blandness of their own -;; mode lines. To some people rain is truly depressing, but others it just -;; makes pensive, and, forcing them indoors where they may not have the -;; luxury of solitude, teaches them to self-diminish. That was what I had -;; not understood when I was searching for loons among the ducks and geese. -;; Loons come to Seattle all the time, but the ones that like it learn to be -;; silent, learn to self-diminish, and take on the colors of ducks and geese. -;; Now, here a dozen years, I can recognize them everywhere, standing quietly -;; in line with the ducks and geese at the espresso counter, gazing placidly -;; out on the world through loon-red eyes, thinking secret thoughts. - -(provide 'diminish) - -;;; diminish.el ends here
\ No newline at end of file diff --git a/elisp/emacs-goodies-el/dir-locals.el b/elisp/emacs-goodies-el/dir-locals.el index 7ff1380..7ff1380 100755..100644 --- a/elisp/emacs-goodies-el/dir-locals.el +++ b/elisp/emacs-goodies-el/dir-locals.el diff --git a/elisp/emacs-goodies-el/edit-env.el b/elisp/emacs-goodies-el/edit-env.el index 8f2bcd1..8f2bcd1 100755..100644 --- a/elisp/emacs-goodies-el/edit-env.el +++ b/elisp/emacs-goodies-el/edit-env.el diff --git a/elisp/emacs-goodies-el/egocentric.el b/elisp/emacs-goodies-el/egocentric.el index 61eca80..61eca80 100755..100644 --- a/elisp/emacs-goodies-el/egocentric.el +++ b/elisp/emacs-goodies-el/egocentric.el diff --git a/elisp/emacs-goodies-el/emacs-goodies-build.el b/elisp/emacs-goodies-el/emacs-goodies-build.el index 248e5bc..248e5bc 100755..100644 --- a/elisp/emacs-goodies-el/emacs-goodies-build.el +++ b/elisp/emacs-goodies-el/emacs-goodies-build.el diff --git a/elisp/emacs-goodies-el/emacs-goodies-custom.el b/elisp/emacs-goodies-el/emacs-goodies-custom.el index c902385..2068b50 100755..100644 --- a/elisp/emacs-goodies-el/emacs-goodies-custom.el +++ b/elisp/emacs-goodies-el/emacs-goodies-custom.el @@ -22,13 +22,6 @@ :load 'ascii :group 'emacs-goodies-el) -;; auto-fill-inhibit.el -(defgroup auto-fill-inhibit '((auto-fill-inhibit-list custom-variable)) - "Finer grained control over auto-fill-mode (de)activation." - :load 'auto-fill-inhibit - :link '(custom-manual "(emacs-goodies-el)auto-fill-inhibit") - :group 'emacs-goodies-el) - ;; bar-cursor (defgroup bar-cursor nil "switch block cursor to a bar." @@ -38,16 +31,6 @@ ;;:require 'bar-cursor :group 'emacs-goodies-el) -(defgroup bm nil - "Visible, buffer local bookmarks." - :link '(emacs-library-link :tag "Source Lisp File" "bm.el") - :group 'faces - :group 'editing - :prefix "bm-" - :link '(custom-manual "(emacs-goodies-el)bm") - :load 'bm - :group 'emacs-goodies-el) - ;; boxquote (defgroup boxquote nil "Mark regions of text with a half-box." @@ -58,16 +41,6 @@ ;;:require 'boxquote :group 'emacs-goodies-el) -;; browse-kill-ring -(defgroup browse-kill-ring nil - "A package for browsing and inserting the items in `kill-ring'." - :link '(url-link "http://web.verbum.org/~walters") - :group 'convenience - :link '(custom-manual "(emacs-goodies-el)browse-kill-ring") - :load 'browse-kill-ring -;;:require 'browse-kill-ring - :group 'emacs-goodies-el) - ;; color-theme (defgroup color-theme nil "Color Themes for Emacs. @@ -79,14 +52,6 @@ and face definitions." :load 'color-theme_seldefcustom :group 'emacs-goodies-el) -;; csv-mode -(defgroup CSV nil - "Major mode for editing files of comma-separated value type." - :group 'convenience - :link '(custom-manual "(emacs-goodies-el)csv-mode") - :load 'csv-mode - :group 'emacs-goodies-el) - ;; ctypes (defgroup ctypes nil "Enhanced Font lock support for custom defined types." @@ -104,15 +69,6 @@ and face definitions." ;;:require 'df :group 'emacs-goodies-el) -;; diminish -(defgroup diminish nil - "Diminished modes are minor modes with no modeline display." - :group 'convenience - :link '(custom-manual "(emacs-goodies-el)diminish") - :load 'diminish -;;:require 'diminish - :group 'emacs-goodies-el) - ;; dir-locals (defgroup dir-locals () "Directory-wide file-local variables" @@ -132,17 +88,6 @@ and face definitions." ;;:require 'egocentric :group 'emacs-goodies-el) -;; eproject -(defgroup eproject nil - "Eproject; provide support for grouping files and buffers into projects" - :prefix "eproject-" - :group 'convenience - :link '(emacs-commentary-link :tag "Commentary" "eproject.el") - :link '(emacs-library-link :tag "Optional extras" "eproject-extras.el") - :link '(url-link :tag "Github wiki" "http://wiki.github.com/jrockway/eproject") - :load 'eproject - :group 'emacs-goodies-el) - ;; ff-paths (defgroup ff-paths nil "Find file using paths." @@ -154,15 +99,6 @@ and face definitions." ;;:require 'ff-paths :group 'emacs-goodies-el) -;; filladapt -(defgroup filladapt nil - "Enhanced filling" - :group 'fill - :link '(custom-manual "(emacs-goodies-el)filladapt") - :load 'filladapt -;;:require 'filladapt - :group 'emacs-goodies-el) - ;; floatbg (defgroup floatbg nil "Slowly modify background color by moving through an HSV color model." @@ -174,72 +110,6 @@ and face definitions." ;;:require 'floatbg :group 'emacs-goodies-el) -;; folding -(defgroup folding nil - "Managing buffers with Folds." - :group 'tools - :link '(custom-manual "(emacs-goodies-el)folding") - :load 'folding -;;:require 'folding - :group 'emacs-goodies-el) - -;; framepop -(defgroup framepop nil - "Display temporary buffers in a dedicated frame." - :group 'frames - :link '(custom-manual "(emacs-goodies-el)framepop") - :load 'framepop -;;:require 'framepop - :group 'emacs-goodies-el) - -;; graphviz-dot-mode.el -(defgroup graphviz nil - "Major mode for editing Graphviz Dot files" - :group 'tools - :link '(custom-manual "(emacs-goodies-el)graphviz-dot-mode") - :load 'graphviz-dot-mode - :group 'emacs-goodies-el) - -;; highlight-beyond-fill-column -(defgroup highlight-beyond-fill-column nil - "Fontify beyond the fill-column." - :group 'fill - :link '(custom-manual "(emacs-goodies-el)highlight-beyond-fill-column") - :load 'highlight-beyond-fill-column -;;:require 'highlight-beyond-fill-column - :group 'emacs-goodies-el) - -;; highlight-completion -(defgroup highlight-completion nil - "Highlight completion mode: display completion as highlighted text." - :tag "Highlight completion" - :prefix "hc" - :link '(url-link :tag "Home Page" "http://www.math.washington.edu/~palmieri/Emacs/hlc.html") - :group 'abbrev - :link '(custom-manual "(emacs-goodies-el)highlight-completion") - :load 'highlight-completion -;;:require 'highlight-completion - :group 'emacs-goodies-el) - -;; highlight-current-line -(defgroup highlight-current-line nil - "Highlight line where the cursor is." - :load 'highlight-current-line - :group 'faces - :link '(custom-manual "(emacs-goodies-el)highlight-current-line") - :load 'highlight-current-line -;;:require 'highlight-current-line - :group 'emacs-goodies-el) - -;; htmlize -(defgroup htmlize nil - "HTMLize font-locked buffers." - :group 'hypermedia - :link '(custom-manual "(emacs-goodies-el)htmlize") - :load 'htmlize -;;:require 'htmlize - :group 'emacs-goodies-el) - ;; initsplit (defgroup initsplit nil "Code to split customizations into different files." @@ -291,24 +161,6 @@ and face definitions." :load 'maplev :group 'emacs-goodies-el) -;; matlab -(defgroup matlab nil - "Matlab mode." - :prefix "matlab-" - :group 'languages - :link '(custom-manual "(emacs-goodies-el)matlab") - :load 'matlab - :group 'emacs-goodies-el) - -;; minibuffer-complete-cycle -(defgroup minibuffer-complete-cycle nil - "Cycle through the *Completions* buffer." - :group 'completion - :link '(custom-manual "(emacs-goodies-el)minibuffer-complete-cycle") - :load 'minibuffer-complete-cycle -;;:require 'minibuffer-complete-cycle - :group 'emacs-goodies-el) - (defgroup miniedit nil "Miniedit" :group 'applications @@ -402,16 +254,6 @@ Don't forget to mention your Emacs and library versions.")) ;;:require 'protbuf :group 'emacs-goodies-el) -;; quack -(defgroup quack nil - "Enhanced support for editing and running Scheme code." - :group 'scheme - :prefix "quack-" - :link '(url-link "http://www.neilvandyke.org/quack/") - :load 'quack - :link '(custom-manual "(emacs-goodies-el)quack") - :group 'emacs-goodies-el) - (defcustom quack-install nil "Whether to setup quack for use." :type 'boolean @@ -422,27 +264,6 @@ Don't forget to mention your Emacs and library versions.")) :require 'quack :group 'quack) -;; rfcview -(defgroup rfcview nil - "View IETF RFC files with formatting." - :group 'hypermedia - :prefix "rfcview-" - :link '(custom-manual "(emacs-goodies-el)rfcview") - :load 'rfcview - :group 'emacs-goodies-el) - -;; session -(defgroup session nil - "Use variables, registers and buffer places across sessions." - :group 'data - :link '(emacs-commentary-link "session.el") - :link '(url-link "http://emacs-session.sourceforge.net/") - :prefix "session-" - :link '(custom-manual "(emacs-goodies-el)session") - :load 'session -;;:require 'session - :group 'emacs-goodies-el) - ;; setnu (defgroup setnu nil "vi-style line number mode for Emacs." @@ -458,27 +279,6 @@ Don't forget to mention your Emacs and library versions.")) :load 'shell-command :group 'emacs-goodies-el) -;; show-wspace -(defgroup Show-Whitespace nil - "Highlight whitespace of various kinds." - :prefix "show-ws-" - :group 'convenience :group 'matching - :link `(url-link :tag "Send Bug Report" - ,(concat "mailto:" "drew.adams" "@" "oracle" ".com?subject=\ -show-wspace.el bug: \ -&body=Describe bug here, starting with `emacs -q'. \ -Don't forget to mention your Emacs and library versions.")) - :link '(url-link :tag "Other Libraries by Drew" - "http://www.emacswiki.org/cgi-bin/wiki/DrewsElispLibraries") - :link '(url-link :tag "Download" - "http://www.emacswiki.org/cgi-bin/wiki/show-wspace.el") - :link '(url-link :tag "Description" - "http://www.emacswiki.org/cgi-bin/wiki/ShowWhiteSpace#ShowWspace") - :link '(emacs-commentary-link :tag "Commentary" "show-wspace") - :load 'show-wspace - :group 'emacs-goodies-el - ) - ;; slang-mode (defgroup slang nil "Major mode for editing slang code." @@ -497,23 +297,6 @@ Don't forget to mention your Emacs and library versions.")) :load 'silly-mail :group 'emacs-goodies-el) -(defgroup tabbar nil - "Display a tab bar in the header line." - :group 'convenience - :link '(custom-manual "(emacs-goodies-el)tabbar") - :load 'tabbar - :group 'emacs-goodies-el) - -;; tail -(defgroup tail nil - "Tail files or commands into Emacs buffers." - :prefix "tail-" - :group 'environment - :link '(custom-manual "(emacs-goodies-el)tail") - :load 'tail -;;:require 'tail - :group 'emacs-goodies-el) - ;; tc (defgroup tc nil "Insert cited text in a nice manner" ;;:link '(custom-manual "(emacs-goodies-el)tc") @@ -521,16 +304,6 @@ Don't forget to mention your Emacs and library versions.")) ;;:require 'tc :group 'emacs-goodies-el) -;; thinks -(defgroup thinks nil - "Insert text in a think bubble." - :group 'editing - :prefix "thinks-" - :link '(custom-manual "(emacs-goodies-el)thinks") - :load 'thinks -;;:require 'thinks - :group 'emacs-goodies-el) - ;;tlc (defgroup tlc nil "Major mode for editing tlc files." diff --git a/elisp/emacs-goodies-el/emacs-goodies-el.el b/elisp/emacs-goodies-el/emacs-goodies-el.el index 2df98f1..f86ef10 100755..100644 --- a/elisp/emacs-goodies-el/emacs-goodies-el.el +++ b/elisp/emacs-goodies-el/emacs-goodies-el.el @@ -91,71 +91,6 @@ find-file-using-paths searches certain paths to find files." :group 'emacs-goodies-el :group 'ff-paths) -;; filladapt -(autoload 'turn-on-filladapt-mode "filladapt" - "Unconditionally turn on Filladapt mode in the current buffer." - t) - -(defcustom filladapt-turn-on-mode-hooks nil - "*List of hooks for which to turn-on filladapt. -Filladapt works well with any language that uses comments that -start with some character sequence and terminate at end of line. -So it is good for Postscript, Lisp, Perl, C++ and shell modes. -It's not good for C mode because C's comments are multiline." - :type '(set (const text-mode-hook) - (const awk-mode-hook) - (const lisp-mode-hook) - (const emacs-lisp-mode-hook) - (const perl-mode-hook)) - :set (lambda (symbol value) - ;; Remove old values since user may have deleted entries - (if (and (boundp 'filladapt-mode-hooks) filladapt-mode-hooks) - (mapcar (lambda (hook) (remove-hook hook 'turn-on-filladapt-mode)) - filladapt-mode-hooks)) - (set-default symbol value) - ;; Set entries selected by the user. - (mapcar (lambda (hook) (add-hook hook 'turn-on-filladapt-mode)) - value)) - :load 'filladapt - :group 'emacs-goodies-el - :group 'filladapt) - -;; highlight-completion.el -(autoload 'highlight-completion-mode "highlight-completion" - "Activate highlight-completion." - t) - -;; highlight-current-line.el - compatibility -(autoload 'highlight-current-line-on "highlight-current-line" - "Switch highlighting of cursor-line on/off globally." - t) - -;; home-end.el -(defvar home-end-end-enable nil - "Whether `home-end-enable' was activated. -Stores the value of the prior `end' keybinding.") -(defvar home-end-home-enable nil - "Whether `home-end-enable' was activated. -Stores the value of the prior `home' keybinding.") -(defcustom home-end-enable emacs-goodies-el-defaults - "*Define [home] and [end] keys to act differently when hit 1, 2 or 3 times." - :type 'boolean - :set (lambda (symbol value) - (set-default symbol value) - (cond - (value - (setq home-end-end-enable (key-binding [end]) - home-end-home-enable (key-binding [home])) - (global-set-key [end] 'home-end-end) - (global-set-key [home] 'home-end-home)) - (t - (if home-end-end-enable - (global-set-key [end] home-end-end-enable)) - (if home-end-home-enable - (global-set-key [home] home-end-home-enable))))) - :load 'home-end - :group 'emacs-goodies-el) - ;; keydef.el (autoload 'keydef "keydef" "Define the key sequence SEQ, written in kbd form, to run CMD." @@ -176,32 +111,6 @@ Stores the value of the prior `home' keybinding.") (autoload 'cmaple "maplev" "Start maple process" t) (add-to-list 'auto-mode-alist '("\\.mpl\\'" . maplev-mode)) -;; matlab -(defcustom matlab-auto-mode nil - "*Enter matlab-mode when editing .m files. -Technically, this adjusts the `auto-mode-list' when set. -To unset, you will have to restart Emacs." - :type 'boolean - :set (lambda (symbol value) - (set-default symbol value) - (cond - (value - (add-to-list 'auto-mode-alist '("\\.m\\'" . matlab-mode))))) - :load 'matlab - :group 'emacs-goodies-el - :require 'matlab) - -;; minibuf-electric.el -(defcustom minibuffer-electric-file-name-behavior nil - "*If non-nil, slash and tilde in certain places cause immediate deletion. -These are the same places where this behavior would occur later on anyway, -in `substitute-in-file-name'." - :type 'boolean - :require 'minibuf-electric - :load 'minibuf-electric - :group 'emacs-goodies-el - :group 'minibuffer) - ;; mutt-alias.el (autoload 'mutt-alias-insert "mutt-alias" "Insert the expansion for ALIAS into the current buffer." @@ -213,22 +122,6 @@ in `substitute-in-file-name'." ;; muttrc-mode.el (add-to-list 'auto-mode-alist '("muttrc\\'" . muttrc-mode)) - -;; pod-mode.el -(add-to-list 'auto-mode-alist '("\\.pod\\'" . pod-mode)) - -;; rfcview -(add-to-list 'auto-mode-alist - '("/rfc[0-9]+\\.txt\\(\\.gz\\)?\\'" . rfcview-mode)) - -;; session.el -(autoload 'session-initialize "session" - "Initialize package session and read previous session file. -Setup hooks and load `session-save-file', see `session-initialize'. At -best, this function is called at the end of the Emacs startup, i.e., add -this function to `after-init-hook'." - t) - ;; setnu.el (autoload 'setnu-mode "setnu" "Toggle setnu-mode." @@ -256,13 +149,6 @@ this function to `after-init-hook'." "Easily toggle frequently toggled options." t) -;; upstart-mode.el -(when (not (featurep 'xemacs)) - (autoload 'upstart-mode "upstart-mode" - "major mode for .upstart files." - t) - (add-to-list 'auto-mode-alist '("\\.upstart\\'" . upstart-mode))) - ;; xrdb-mode.el (defun xrdb-mode-setup-auto-mode-alist () diff --git a/elisp/emacs-goodies-el/emacs-goodies-el.texi b/elisp/emacs-goodies-el/emacs-goodies-el.texi index e7ecaaa..c9138c8 100644 --- a/elisp/emacs-goodies-el/emacs-goodies-el.texi +++ b/elisp/emacs-goodies-el/emacs-goodies-el.texi @@ -1386,8 +1386,8 @@ to have Filladapt always enabled in Text mode, or customize the variable @code{filladapt-turn-on-mode-hooks}. In C mode, @code{c-setup-filladapt} arranges for filling of block -style comments (@pxref{Text Filling and Line Breaking,,, ccmode, CC -Mode}). +style comments (@pxref{Custom Filling and Breaking,, Customizing +Filling and Line Breaking, ccmode, CC Mode}). @example (add-hook 'c-mode-hook 'turn-on-filladapt-mode) diff --git a/elisp/emacs-goodies-el/eproject-extras.el b/elisp/emacs-goodies-el/eproject-extras.el deleted file mode 100644 index 6177517..0000000 --- a/elisp/emacs-goodies-el/eproject-extras.el +++ /dev/null @@ -1,308 +0,0 @@ -;;; eproject-extras.el --- various utilities that make eproject more enjoyable - -;; Copyright (C) 2009 Jonathan Rockway - -;; Author: Jonathan Rockway <jon@jrock.us> -;; Keywords: eproject - -;; This program 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 3 of the License, or -;; (at your option) any later version. - -;; This program 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 this program. If not, see <http://www.gnu.org/licenses/>. - -;;; Commentary: - -;; Some of this stuff used to be in eproject "core", but it is a bit -;; bloated, and not strictly necessary. So now it lives here, leaving -;; the eproject core pristine and minimal. - -;;; Code: - -(require 'eproject) -(require 'cl) -(require 'iswitchb) -(require 'ibuffer) -(require 'ibuf-ext) - -;; support for visiting other project files -(defalias 'eproject-ifind-file 'eproject-find-file) ;; ifind is deperecated - -(defun eproject--shorten-filename (filename) - "Shorten FILENAME in the context of the current project. -Uses the function provided by the `:file-name-map' project attribute. - -The default implementation just makes the filename relative to -the project root." - (cons (funcall (eproject-attribute :file-name-map) - (eproject-root) - (file-relative-name filename (eproject-root))) - filename)) - -;;;###autoload -(defun eproject-find-file () - "Present the user with a list of files in the current project. -to select from, open file when selected." - (interactive) - (find-file (eproject--icomplete-read-with-alist - "Project file: " - (mapcar #'eproject--shorten-filename (eproject-list-project-files))))) - -(defun eproject--completing-read (prompt choices) - "Use completing-read to do a completing read." - (completing-read prompt choices nil t)) - -(defun eproject--icompleting-read (prompt choices) - "Use iswitchb to do a completing read." - (let ((iswitchb-make-buflist-hook - (lambda () - (setq iswitchb-temp-buflist choices)))) - (unwind-protect - (progn - (when (not iswitchb-mode) - (add-hook 'minibuffer-setup-hook 'iswitchb-minibuffer-setup)) - (iswitchb-read-buffer prompt nil t)) - (when (not iswitchb-mode) - (remove-hook 'minibuffer-setup-hook 'iswitchb-minibuffer-setup))))) - -(defun eproject--ido-completing-read (prompt choices) - "Use ido to do a completing read." - (ido-completing-read prompt choices nil t)) - -(defcustom eproject-completing-read-function - #'eproject--icompleting-read - "Ask the user select a single file from a list of files. -Used by `eproject-find-file'." - :group 'eproject - :type '(radio (function-item :doc "Use emacs' standard completing-read function." - eproject--completing-read) - (function-item :doc "Use iswitchb's completing-read function." - eproject--icompleting-read) - (function-item :doc "Use ido's completing-read function." - eproject--ido-completing-read) - (function))) - -(defun eproject--do-completing-read (&rest args) - "Do a completing read with the user's favorite completing read function." - (apply eproject-completing-read-function args)) - -(defun eproject--icomplete-read-with-alist (prompt alist) - (let ((show (mapcar (lambda (x) (car x)) alist))) - (cdr (assoc (eproject--do-completing-read prompt show) alist)))) - -(defun eproject--project-buffers () - "Return an alist mapping each project root to its open buffers. - -Does not list the project if it doesn't have any buffers." - (let ((hash (make-hash-table :test 'equal))) - (loop for x in - (mapcar (lambda (b) (ignore-errors (cons (eproject-root b) b))) - (buffer-list)) - when (not (null x)) - do (puthash (car x) - (cons (cdr x) (gethash (car x) hash)) hash)) - (loop for key being the hash-keys of hash - collect (cons key (gethash key hash))))) - -(defun* eproject--get-name-root-alist (&key live-only) - (let ((all-projects (eproject-projects)) - (buffers (eproject--project-buffers))) - - (when (null all-projects) - (error "No projects yet")) - - (if live-only - (remove-if #'null (mapcar (lambda (x) (rassoc (car x) all-projects)) buffers)) - all-projects))) - -(defun* eproject--read-project-name (&key live-only) - (eproject--icomplete-read-with-alist - "Project name: " (eproject--get-name-root-alist :live-only live-only))) - -(defun* eproject--handle-root-prefix-arg (prefix &key live-only) - (if (= prefix 4) - (eproject--read-project-name :live-only live-only) - (eproject-root))) - -;; ibuffer support - -(define-ibuffer-filter eproject-root - "Filter buffers that have the provided eproject root" - (:reader (read-directory-name "Project root: " (ignore-errors (eproject-root))) - :description "project root") - (with-current-buffer buf - (equal (file-name-as-directory (expand-file-name qualifier)) - (ignore-errors (eproject-root))))) - -(define-ibuffer-filter eproject - "Filter buffers that have the provided eproject name" - (:reader (eproject--do-completing-read "Project name: " (eproject-project-names)) - :description "project name") - (with-current-buffer buf - (equal qualifier - (ignore-errors (eproject-name))))) - -(define-ibuffer-column eproject (:name "Project" :inline t) - (ignore-errors (eproject-name))) - -;;;###autoload -(defun eproject-ibuffer (prefix) - "Open an IBuffer window showing all buffers in the current project, or named project if PREFIX arg is supplied." - (interactive "p") - (if (= prefix 4) - (call-interactively #'eproject--ibuffer-byname) - (ibuffer nil "*Project Buffers*" - (list (cons 'eproject-root (eproject-root)))))) - -(defun eproject--ibuffer-byname (project-name) - "Open an IBuffer window showing all buffers in the project named PROJECT-NAME." - (interactive (list - (eproject--do-completing-read - "Project name: " (eproject-project-names)))) - (ibuffer nil (format "*%s Buffers*" project-name) - (list (cons 'eproject project-name)))) - -;; extra macros - -(defmacro* with-each-buffer-in-project - ((binding &optional project-root) - &body body) - "Given a project root PROJECT-ROOT, finds each buffer visiting a file in that project, and executes BODY with each buffer bound to BINDING (and made current)." - (declare (indent 2)) - `(progn - (loop for ,binding in (cdr (assoc (or ,project-root (eproject-root)) - (eproject--project-buffers))) - do - (with-current-buffer ,binding - ,@body)))) - -;; bulk management utils -;;;###autoload -(defun eproject-kill-project-buffers (prefix) - "Kill every buffer in the current project, including the current buffer. - -If PREFIX is specified, prompt for a project name and kill those -buffers instead." - (interactive "p") - (with-each-buffer-in-project - (buf (eproject--handle-root-prefix-arg prefix :live-only t)) - (kill-buffer buf))) - -(defun eproject-open-all-project-files (prefix) - "Open every file in the same project. - -If PREFIX arg is supplied, prompt for a project. Otherwise, -assume the project of the current buffer." - (interactive "p") - (let ((total 0) - (root (eproject--handle-root-prefix-arg prefix))) - (message "Opening files...") - (save-window-excursion - (loop for file in (eproject-list-project-files root) - do (progn (find-file file) (incf total)))) - (message "Opened %d files" total))) - -;; project management - -(defun eproject-project-root (project) - "Given a PROJECT name, return the root directory." - (let ((projects (eproject--get-name-root-alist))) - (cdr (assoc project projects)))) - -;;;###autoload -(defun eproject-revisit-project (prefix) - "Given a project name, visit the root directory. - -If PREFIX arg is supplied, run `eproject-find-file'." - (interactive "p") - (let ((eproject-root (eproject--read-project-name)) - (eproject-mode t)) ;; XXX: very messy, needs rewrite - (if (= prefix 4) - (eproject-find-file) - (find-file eproject-root)))) - -;; grep project files (contributed by Julian Snitow) - -;; TODO: make the grep command customizable; to use "Ack", for example -;;;###autoload -(defun eproject-grep (regexp) - "Search all files in the current project for REGEXP." - (interactive "sRegexp grep: ") - (let* ((root (eproject-root)) - (default-directory root) - (files (eproject-list-project-files-relative root))) - (grep-compute-defaults) - (lgrep regexp (combine-and-quote-strings files) root))) - -(defcustom eproject-todo-expressions - '("TODO" "XXX" "FIXME") - "A list of tags for `eproject-todo' to search for when generating the project's TODO list." - :group 'eproject - :type '(repeat string)) - -;;;###autoload -(defun eproject-todo () - "Display a project TODO list. - -Customize `eproject-todo-expressions' to control what this function looks for." - (interactive) - ;; TODO: display output in a buffer called *<project>-TODO* instead of *grep*. - (eproject-grep (regexp-opt eproject-todo-expressions))) - -;;;###autoload -(defun eproject-multi-isearch-buffers () - "Do a `multi-isearch' on opened buffers in the current project. - -Run `eproject-open-all-project-files' first or just -`eproject-grep' if you want to search all project files." - (interactive) - (multi-isearch-buffers - (cdr (assoc (eproject-root) (eproject--project-buffers))))) - -;;;###autoload -(defun eproject-eshell-cd-here (&optional look-in-invisible-buffers) - "If there is an EShell buffer, cd to the project root in that buffer. - -With the prefix arg LOOK-IN-INVISIBLE-BUFFERS looks in buffers that are not currently displayed." - (interactive "p") - (setq look-in-invisible-buffers (cond ((= look-in-invisible-buffers 4) t))) - (let* ((root (eproject-root)) - (eshell-p (lambda (buf) - (with-current-buffer buf (eq major-mode 'eshell-mode)))) - (eshell-buffer (find-if eshell-p - (if look-in-invisible-buffers - (buffer-list) - (mapcar (lambda (w) (window-buffer w)) - (window-list)))))) - - (cond ((and (not eshell-buffer) look-in-invisible-buffers) - (error "No EShell buffer!")) - ((and (not eshell-buffer) (not look-in-invisible-buffers)) - (error "No visible EShell buffer; try re-running with the prefix arg")) - (eshell-buffer - (with-current-buffer eshell-buffer - (goto-char (point-max)) - (eshell/cd root) - (eshell-send-input nil t) - eshell-buffer))))) ;; returns eshell-buf so you can focus - ;; the window if you want - -;;;###autoload -(defun eproject-compile () - "Run `compile-command' in the project root." - (interactive) - (let ((default-directory (eproject-root))) - (call-interactively #'compile))) - -(define-key eproject-mode-map (kbd "C-c C-f") #'eproject-find-file) -(define-key eproject-mode-map (kbd "C-c C-b") #'eproject-ibuffer) - -(provide 'eproject-extras) -;;; eproject-extras.el ends here diff --git a/elisp/emacs-goodies-el/eproject.el b/elisp/emacs-goodies-el/eproject.el deleted file mode 100644 index ca680b9..0000000 --- a/elisp/emacs-goodies-el/eproject.el +++ /dev/null @@ -1,679 +0,0 @@ -;;; eproject.el --- assign files to projects, programatically -;; -;; Copyright (C) 2008, 2009 Jonathan Rockway <jon@jrock.us> -;; -;; Author: Jonathan Rockway <jon@jrock.us> -;; Maintainer: Jonathan Rockway <jon@jrock.us> -;; Created: 20 Nov 2008 -;; Version: 1.5 -;; Keywords: programming, projects -;; -;; This file is not a part of GNU Emacs. -;; -;; This program 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 of -;; the License, or (at your option) any later version. -;; -;; This program 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 this program; if not, write to the Free -;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, -;; MA 02111-1307, USA. -;; -;;; Commentary: -;; -;; Eproject is an extension that lets you group related files together -;; as projects. It aims to be as unobtrusive as possible -- no new -;; files are created (or required to exist) on disk, and buffers that -;; aren't a member of a project are not affected in any way. -;; -;; The main starting point for eproject is defining project types. -;; There is a macro for this, define-project-type, that accepts four -;; arguments, the type name (a symbol), a list of supertypes (for -;; inheriting properties), a form that is executed to determine -;; whether a file is a member of a project, and then a free-form -;; property list. An example will clear things up. -;; -;; Let's create a "perl" project type, for Perl projects that have a -;; Makefile.PL. -;; -;; (define-project-type perl (generic) -;; (look-for "Makefile.PL") -;; :relevant-files ("\\.pm$" "\\.t$")) -;; -;; Now when you open a file and somewhere above in the directory tree -;; there is a Makefile.PL, it will be a "perl project". -;; -;; There are a few things you get with this. A hook called -;; perl-project-file-visit-hook will be run, and the buffer will have -;; the "eproject-mode" minor-mode turned on. You can also read and -;; set metadata via the eproject-attribute and -;; eproject-add-project-metadatum calls. -;; -;; (This is mostly helpful to Lisp programmers rather than end-users; -;; if you want tools for visiting and managing projects (and ibuffer -;; integration), load `eproject-extras'. These extras are great -;; examples of the eproject API in action, so please take a look even -;; if you don't want those exact features.) -;; -;; Let's look at the mechanics of the define-project-type call. The -;; first argument is the name of the project type -- it can be any -;; symbol. The next argument is a list of other projects types that -;; this project will inherit from. That means that if you call -;; eproject-get-project-metadatum and the current project doesn't -;; define a value, we'll look at the supertypes until we get something -;; non-nil. Usually you will want to set this to (generic), which -;; will make your type work correctly even if you don't define any of -;; your own metadata. -;; -;; The next argument is a form that will be executed with the filename -;; that was just opened bound to FILE. It is expected to return the -;; project root, or nil if FILE is not in a project of this type. The -;; look-for function will look up the directory tree for a file that -;; is named the same as its argument (see the docstring for -;; `eproject--look-for-impl' for all the details). You can write any -;; Lisp here you like; we'll see some more examples later. (You only -;; get one form, so if you need to execute more than one, just wrap it -;; in a progn.) -;; -;; The final (&rest-style) argument is a property list of initial project -;; metadata. You can put anything you want here, as long as it is in the -;; form of a property list (keyword, value, keyword, value, ...). -;; -;; After this form runs, eproject will be able to recognize files in -;; the type of the project you defined. It also creates a hook named -;; <type>-project-file-visit-hook. You can do anything you want here, -;; including access (eproject-type) and (eproject-root). -;; -;; As an example, in my perl-project-file-visit-hook, I do this: -;; -;; (lambda () -;; (ignore-errors -;; (stylish-repl-eval-perl -;; (format "use lib '%s'" (car (perl-project-includes))))))) -;; -;; This will add the library directory of this project to my current -;; stylish-repl session, so that I can use my project in the REPL -;; immediately. (I do something similar for Lisp + SLIME projects) -;; -;; That's basically all there is. eproject is designed to be minimal and -;; extensible, so I hope it meets your needs. -;; -;; Please e-mail me or find me on #emacs (jrockway) if you have -;; questions. If you'd like to send a patch (always appreciated), -;; please diff against the latest git version, available by running: -;; -;; $ git clone git://github.com/jrockway/eproject -;; -;; Share and enjoy. - -;;; Public API: - -;; eproject-root (&optional buffer) -;; -;; - returns the project root for the project that buffer is a member -;; of. defaults to the current buffer - -;; eproject-attribute (key &optional root) -;; -;; - returns the value of key for the project that buffer is a member -;; of. root defaults to the current buffer's eproject-root - -;; eproject-list-project-files - -;; define-project-type - -;; define-project-attribute - -;; eproject-projects - -;; Everything else is mostly used internally, and may change. - -;;; Public commands: - -;; eproject-maybe-turn-on -;; -;; - turn on eproject for the current buffer, if possible -;; (if it's turned on, the hooks will be run) - -;; eproject-reinitialize-project -;; -;; - re-read config for the current project, then run -;; eproject-maybe-turn-on -;; -;; this is bound to C-c C-c when editing .eproject files, which is -;; very convenient for testing. - -;; See eproject-extras.el for more interesting / useful commands. -;; This file is mostly "plumbing". - -;;; Bugs: -;; -;; You can't forward reference supertypes -- this will mess things up -;; internally, but you won't get a warning. This can be easily fixed -;; by using a smarter algorithm for eproject--all-types. -;; -;; The "linearized isa" (i.e. "class precedence list") is computed -;; with a depth-first search. This is bad; we should really use the -;; C3 ordering. - -;;; Website: -;; -;; The latest version is on github at -;; http://github.com/jrockway/eproject/tree/master -;; -;; The wiki has lots more documentation: -;; http://wiki.github.com/jrockway/eproject -;; - -;;; The Changelog section documents major changes. Minor non-breaking -;;; updates are regularly committed to git. - -;;; Changelog: -;; -;; 1.6 (Sat Aug 28 22:21:39 CDT 2010) -;; -;; * Remove eproject-project-names variable and add some proper -;; introspection for project sets. -;; -;; 1.5 (Thu May 28 21:38:08 MST 2009) -;; -;; * Split out the non-core stuff into eproject-extras.el. -;; (slime-contrib style) -;; -;; 1.4 (Thu May 28 02:21:40 MST 2009) -;; -;; * Add support for "instance" metadata, instead of "class" (project) -;; metadata -;; -;; 1.3 (Wed May 27 20:47:48 MST 2009) -;; -;; * Officially support w32 -;; -;; 1.2 (Thu May 7 02:18:01 CDT 2009) -;; -;; * Add ibuffer support -;; -;; 1.1 (Sat Jan 31 20:03:56 CST 2009) -;; -;; * Make the completing-read function customizable -;; -;; 1.0 (Nov 28 2008) -;; -;; * Initial release -;; - -;;; Code: - -(require 'cl) -(require 'eshell) ;; For portable path handling - -(defgroup eproject nil - "Eproject; provide support for grouping files and buffers into projects" - :prefix "eproject-" - :group 'convenience - :link '(emacs-commentary-link :tag "Commentary" "eproject.el") - :link '(emacs-library-link :tag "Optional extras" "eproject-extras.el") - :link '(url-link :tag "Github wiki" "http://wiki.github.com/jrockway/eproject")) - -(defvar eproject-root nil - "A buffer-local variable set to the root of its eproject - project. NIL if it isn't in an eproject. Your code should - call the function `eproject-root` instead of accessing this - variable directly. It should also not set it; only - `eproject-maybe-turn-on' can do that.") - -(make-variable-buffer-local 'eproject-root) - -(defvar eproject-project-types nil - "An alist of project type name to (supertypes selector metadata-plist) pairs.") - -(defvar eproject-extra-attributes nil - "A list of pairs used to assign attributes to projects. - -Each entry can be in the form of `(FUNCTION (ATTRIBUTES))' -or `((KEY . TYPE) (ATTRIBUTES))'. - -If FUNCTION is specified, it will be evaluated for each project -root. If it returns a non-nil value, ATTRIBUTES will be added to -the project attributes. - -If `(KEY . TYPE)' is specified, then TYPE is either -`:root-regexp' or `:project-name' and KEY is interpreted -accordingly. If KEY matches a project root, its ATTRIBUTES are -applied. - -ATTRIBUTES is a plist of attributes.") - -(defvar eproject-attributes-alist nil - "An alist of project root -> plist of project metadata.") - -(defvar eproject-first-buffer-hook nil - "Hook to run when the first buffer in a new project is opened. - Called after the project is initialized, so it's safe to call - eproject functions.") - -(defvar eproject-projects-hook nil - "Hook that's run when a list of projects is requested. Hook may return a list of new (name . root) pairs to be added to eproject's internal list.") - -(defvar eproject-project-change-hook nil - "Hook that's run when a project is changed; currently this means when a file in the project is saved.") - -(defun define-project-attribute (key attributes) - "Define extra attributes to be applied to projects. - -See `eproject-extra-attributes' for details on the format of KEY -and ATTRIBUTES." - (check-type key (or function cons)) - (check-type attributes list) - (add-to-list 'eproject-extra-attributes (list key attributes))) - -(defmacro define-project-type (type supertypes selector &rest metadata) - "Define a new project type TYPE that inherits from SUPERTYPES. - -SELECTOR is a form that is given a filename FILE and returns the -project root if it is of this type of project, or NIL otherwise. - -Optional argument METADATA is a plist of metadata that will -become project attributes." - `(progn - (defvar ,(intern (format "%s-project-file-visit-hook" type)) nil - ,(format "Hooks that will be run when a file in a %s project is opened." type)) - (setq eproject-project-types - (nconc (assq-delete-all ',type eproject-project-types) - (list - (list ',type ',supertypes - (lambda (file) ,selector) - ',metadata)))))) - -(defun eproject--build-parent-candidates (start-at) - "Given directory START-AT, return a list of parent directories, including START-AT." - (loop for x on (reverse (eshell-split-path start-at)) by #'cdr - ;; i think eshell-split-path guarantees the - ;; file-name-as-directory application, but i don't want to - ;; debug it if it doesn't :) - collect (file-name-as-directory (apply #'concat (reverse x))))) - -(defun eproject--scan-parents-for (start-at predicate) - "Call PREDICATE with each parent directory of START-AT, returning the path to the first directory where PREDICATE returns T." - (find-if predicate (eproject--build-parent-candidates - (file-name-as-directory start-at)))) - -(defun eproject--find-file-named (start-at filename) - "Starting in directory START-AT, recursively check parent directories for a file named FILENAME. Return the directory where the file is first found; return NIL otherwise." - (eproject--scan-parents-for start-at - (lambda (directory) ; note that directory always has the path separator on the end - (file-exists-p (concat directory filename))))) - -;; TODO: sugar around lambda/lambda, which is ugly -(define-project-type generic () nil - :relevant-files (".*") - :irrelevant-files ("^[.]" "^[#]") - :file-name-map (lambda (root) (lambda (root file) file)) - :local-variables (lambda (root) (lambda (root file) nil)) - :config-file ".eproject") - -(define-project-type generic-eproject (generic) (look-for ".eproject")) - -(define-project-type generic-git (generic) (look-for ".git") - :irrelevant-files ("^[.]" "^[#]" ".git/")) - -(defun eproject--type-info (type) - (or - (assoc type eproject-project-types) - (error "No type %s" type))) - -(defun eproject--project-supertypes (type) - (nth 1 (eproject--type-info type))) - -(defun eproject--project-selector (type) - (nth 2 (eproject--type-info type))) - -(defun* eproject--look-for-impl (file expression &optional (type :filename)) - "Implements the LOOK-FOR function that is flet-bound during -`eproject--run-project-selector'. EXPRESSION and TYPE specify -what to look for. Some examples: - - (look-for \"Makefile.PL\") ; look up the directory tree for a file called Makefile.PL - (look-for \"*.PL\" :glob) ; look for a file matching *.PL -" - (case type - (:filename (eproject--find-file-named file expression)) - (:glob (eproject--scan-parents-for (file-name-directory file) - (lambda (current-directory) - (let ((default-directory current-directory)) - (and (not (equal file current-directory)) - (> (length (file-expand-wildcards expression)) 0)))))) - (otherwise (error "Don't know how to handle %s in LOOK-FOR!" type)))) - -(defun eproject--buffer-file-name () - (or (buffer-file-name) (and (eq major-mode 'dired-mode) - (expand-file-name (if (consp dired-directory) - (car dired-directory) - dired-directory))))) - -(defun* eproject--run-project-selector (type &optional (file (eproject--buffer-file-name))) - "Run the selector associated with project type TYPE." - (when (not file) - (error "Buffer '%s' has no file name" (current-buffer))) - (flet ((look-for (expr &optional (expr-type :filename)) - (funcall #'eproject--look-for-impl file expr expr-type))) - (funcall (eproject--project-selector type) file))) - -(defun eproject--linearized-isa (type &optional include-self) - (delete-duplicates - (nconc - (if include-self (list type)) - (eproject--project-supertypes type) - (loop for stype in (eproject--project-supertypes type) - nconc (eproject--linearized-isa stype))))) - -(defun eproject--all-types () - ;; this should be most specific to least specific, as long as nothing - ;; is forward-referenced. - (reverse (mapcar #'car eproject-project-types))) - -;; metadata vs. attributes: -;; * metadata is per-project-type -;; * attributes are per-project-root (and includes the project-type metadata) -(defun eproject--compute-all-applicable-metadata (type) - (loop for next-type in (eproject--linearized-isa type t) - append (nth 3 (eproject--type-info next-type)))) - -(defun eproject-get-project-metadatum (type key) - (getf (eproject--compute-all-applicable-metadata type) key)) - -(defun eproject-add-project-metadatum (type key value) - (setf (getf (nth 3 (assoc type eproject-project-types)) key) value)) - -(defmacro* eproject--do-in-buffer ((buffer) &body forms) - `(with-current-buffer ,buffer - (when (not eproject-mode) - (error "Buffer is not an eproject buffer!")) - ,@forms)) - -(defun* eproject-root (&optional (buffer (current-buffer))) - "Return the value of the eproject variable root. -BUFFER defaults to the current buffer" - (eproject--do-in-buffer (buffer) eproject-root)) - -(defun* eproject-attribute (key &optional (root (eproject-root))) - "Lookup the attribute KEY for the eproject ROOT -ROOT defaults to the current buffer's project-root." - (getf (cdr (assoc root eproject-attributes-alist)) key)) - -(defun eproject--known-project-roots () - "Return a list of projects roots that have been visisted this session." - (loop for (key . value) in eproject-attributes-alist collect key)) - -(defmacro define-eproject-accessor (variable) - "Create a function named eproject-VARIABLE that return the value of VARIABLE in the context of the current project." - (let ((sym (intern (format "eproject-%s" variable)))) - `(defun* ,sym - (&optional (buffer (current-buffer))) - ,(format "Return the value of the eproject variable %s. BUFFER defaults to the current buffer." variable) - (eproject-attribute ,(intern (format ":%s" variable)))))) - -(define-eproject-accessor type) -(define-eproject-accessor name) - -(defun eproject-reinitialize-project () - "Forget all project settings for the current eproject, then reload them." - (interactive) - (let ((root (eproject-root))) - (setf eproject-attributes-alist - (delete-if (lambda (x) (equal (car x) root)) - eproject-attributes-alist))) - (eproject-maybe-turn-on) - (if (ignore-errors (eproject-root)) - (message "Project `%s' reinitialized successfully." (eproject-name)) - (message "Error reinitializing project!"))) - -(defun eproject--maybe-reinitialize () - "Run by `eproject-project-change-hook' to reinit the project after .eproject is modified." - (when (and (eq major-mode 'dot-eproject-mode) - (boundp 'eproject-root) eproject-root) - (eproject-reinitialize-project))) - -(defun eproject--eval-user-data (project-name root) - "Interpret EPROJECT-EXTRA-ATTRIBUTES for PROJECT-NAME (in ROOT)." - (loop for (key attributes) in eproject-extra-attributes append - (cond ((functionp key) - (if (funcall key root) attributes nil)) - ((not (listp key)) - (error "Bad eproject user data (%s %s), %s must be a list/function" - key attributes key)) - ((and (eq (cdr key) :project-name) - (equal (car key) project-name)) - attributes) - ((and (eq (cdr key) :root-regexp) - (string-match (car key) root)) - attributes) - (t nil)))) - -(defun eproject--interpret-metadata (data root) - "Interpret DATA with respect to ROOT. - -This mostly means evaluating functions and passing everything -else through unchanged." - (loop for i in data collect (if (functionp i) (funcall i root) i))) - -(defun eproject--init-attributes (root type) - "Update the EPROJECT-ATTRIBUTES-ALIST for the project rooted at ROOT (of TYPE)." - (let ((project-data (assoc root eproject-attributes-alist))) - (when (null project-data) - (let* ((class-data (eproject--interpret-metadata - (eproject--compute-all-applicable-metadata type) - root)) - - ;; read the .eproject (or whatever) file - (config-file - (concat root (getf class-data :config-file ".eproject"))) - (config-file-contents - (with-temp-buffer - (ignore-errors (insert-file-contents config-file nil nil nil t)) - (buffer-substring-no-properties (point-min) (point-max)))) - (config-file-sexp - (read (format "(list %s)" config-file-contents))) - (data-is-unsafe (unsafep config-file-sexp)) - (config-file-data - (cond (data-is-unsafe - (warn "Config file %s contains unsafe data (%s), ignoring!" - config-file data-is-unsafe) - nil) - (t (let ((data (eval config-file-sexp))) - (if data (nconc - (list :loaded-from-config-file config-file) - data) - nil))))) - - ;; combine class and config data; config overriding class - (class-and-config-data (cond - ;; ensure that the config-file-data is really a plist - ((evenp (length config-file-data)) - (nconc config-file-data class-data)) - (t class-data))) - - ;; calculate the project name, as it's used by "user - ;; data" - - ;; backcompat note: not sure why i looked in - ;; :project-name for the value to set the :name attribute - ;; to. so now we look in both, preferring the new way. - (name (or (getf class-and-config-data :name) - (getf class-and-config-data :project-name) - (directory-file-name - (elt (reverse (eshell-split-path root)) 0)))) - - ;; finally, merge in the "user data" - (user-data - (eproject--interpret-metadata - (eproject--eval-user-data name root) root)) - - ;; now compute the final list of attributes - (data (nconc user-data class-and-config-data))) - - (add-to-list 'eproject-attributes-alist - (cons root (nconc (list :type type :name name) data))))))) - -(defvar eproject-mode-map (make-sparse-keymap) - "Keybindings while in eproject-mode") - -(define-minor-mode eproject-mode - "A minor mode for buffers that are a member of an eproject project." - nil " Project" eproject-mode-map - (when (null eproject-root) - (error "Please do not use this directly. Call eproject-maybe-turn-on instead."))) - -(defun eproject-maybe-turn-on () - "Turn on eproject for the current buffer, if it is in a project." - (interactive) - (let (bestroot besttype (set-before (mapcar #'car eproject-attributes-alist))) - (loop for type in (eproject--all-types) - do (let ((root (eproject--run-project-selector type))) - (when (and root - (or (not bestroot) - ;; longest filename == best match (XXX: - ;; need to canonicalize?) - (> (length root) (length bestroot)))) - (setq bestroot root) - (setq besttype type)))) - (when bestroot - (setq eproject-root (file-name-as-directory bestroot)) - - ;; read .eproject file (etc.) and initialize at least :name and - ;; :type - (condition-case e - (eproject--init-attributes eproject-root besttype) - (error (display-warning 'warning - (format "There was a problem setting up the eproject attributes for this project: %s" e)))) - - ;; with :name and :type set, it's now safe to turn on eproject - (eproject-mode 1) - - ;; initialize buffer-local variables that the project defines - ;; (called after we turn on eproject-mode, so we can call - ;; eproject-* functions cleanly) - (condition-case e - (eproject--setup-local-variables) - (error (display-warning 'warning - (format "Problem initializing project-specific local-variables in %s: %s" - (eproject--buffer-file-name) e)))) - - ;; run the first-buffer hooks if this is the first time we've - ;; seen this particular project root. - (when (not (member eproject-root set-before)) - (run-hooks 'eproject-first-buffer-hook)) - - ;; run project-type hooks, which may also call into eproject-* - ;; functions - (run-hooks (intern (format "%s-project-file-visit-hook" besttype))) - - ;; return the project root; it's occasionally useful for the caller - bestroot))) - -(defun eproject--setup-local-variables () - "Setup local variables as specified by the project attribute :local-variables." - (let* ((var-maker (eproject-attribute :local-variables)) - (vars (cond ((functionp var-maker) - (funcall var-maker - (eproject-root) - (file-relative-name (eproject--buffer-file-name) - (eproject-root)))) - ((listp var-maker) var-maker)))) - (loop for (name val) on vars by #'cddr do - (set (make-local-variable name) val)))) - -(defun eproject--search-directory-tree (directory file-regexp ignore-regexp) - (loop for file in (directory-files (file-name-as-directory directory) t "^[^.]" t) - when (and (not (file-directory-p file)) - (not (string-match ignore-regexp file)) - (not (string-match ignore-regexp (file-name-nondirectory file))) - (string-match file-regexp file)) - collect file into files - when (file-directory-p file) - collect file into directories - finally return - (nconc files - (loop for dir in directories - nconc (eproject--search-directory-tree dir file-regexp - ignore-regexp))))) -(defun eproject-assert-type (type) - "Assert that the current buffer is in a project of type TYPE." - (when (not (memq type (eproject--linearized-isa (eproject-type) t))) - (error (format "%s is not in a project of type %s!" - (current-buffer) type)))) - -(defun eproject--combine-regexps (regexp-list) - "Combine regexps like `regexp-opt', but without quoting anything. -Argument REGEXP-LIST is a list of regexps to combine." - (format "\\(?:%s\\)" - (reduce (lambda (a b) (concat a "\\|" b)) - (mapcar (lambda (f) (format "\\(?:%s\\)" f)) regexp-list)))) - -(defun* eproject-list-project-files (&optional (root (eproject-root))) - "Return a list of all project files in PROJECT-ROOT." - (let ((matcher (eproject--combine-regexps - (eproject-attribute :relevant-files root))) - (ignore (eproject--combine-regexps (cons - (concat (regexp-opt completion-ignored-extensions t) "$") - (eproject-attribute :irrelevant-files root))))) - (eproject--search-directory-tree root matcher ignore))) - -(defun* eproject-list-project-files-relative (&optional (root (eproject-root))) - (mapcar (lambda (file) - (file-relative-name file root)) - (eproject-list-project-files root))) - -(define-derived-mode dot-eproject-mode emacs-lisp-mode "dot-eproject" - "Major mode for editing .eproject files." - (define-key dot-eproject-mode-map (kbd "C-c C-c") #'eproject-reinitialize-project)) - -;; introspect sets of projects -(defun eproject-projects () - "Return a list of (name . root) pairs of all known eproject projects." - (let ((hash (make-hash-table :test 'equal))) - (loop for f in eproject-projects-hook do - (loop for (name . root) in (funcall f) - do (puthash name root hash))) - (loop for (root . rest) - in eproject-attributes-alist - do (puthash (or (getf rest :name) (getf rest :project-name)) - root hash)) - (loop for name being each hash-key in hash - collect (cons name (gethash name hash))))) - -(defun eproject-project-names () - "Return a list of project names known to eproject." - (mapcar #'car (eproject-projects))) - -;; Finish up -(defun eproject--after-change-major-mode-hook () - (when (and (buffer-file-name) - (not eproject-root)) - (eproject-maybe-turn-on))) - -(defun eproject--after-save-hook () - ;; TODO: perhaps check against relevant-files or irrelevant-files - ;; regex? I'm avoiding this now because I'd rather not force the - ;; speed hit -- if the user wants to do something slow after save, - ;; fine... but I'd rather not make the decision for him. - (when (and (boundp 'eproject-root) eproject-root) - (run-hooks 'eproject-project-change-hook))) - -(add-hook 'find-file-hook #'eproject-maybe-turn-on) -(add-hook 'dired-mode-hook #'eproject-maybe-turn-on) -(add-hook 'after-change-major-mode-hook #'eproject--after-change-major-mode-hook) -(add-hook 'after-save-hook #'eproject--after-save-hook) - -(add-hook 'eproject-project-change-hook #'eproject--maybe-reinitialize) - -(add-to-list 'auto-mode-alist '("\\.eproject$" . dot-eproject-mode)) - -(provide 'eproject) -;;; eproject.el ends here diff --git a/elisp/emacs-goodies-el/ff-paths.el b/elisp/emacs-goodies-el/ff-paths.el index ec18f7c..ec18f7c 100755..100644 --- a/elisp/emacs-goodies-el/ff-paths.el +++ b/elisp/emacs-goodies-el/ff-paths.el diff --git a/elisp/emacs-goodies-el/filladapt.el b/elisp/emacs-goodies-el/filladapt.el deleted file mode 100755 index 4ae63ab..0000000 --- a/elisp/emacs-goodies-el/filladapt.el +++ /dev/null @@ -1,981 +0,0 @@ -;;; Adaptive fill -;;; Copyright (C) 1989, 1995-1998 Kyle E. Jones -;;; -;;; This program 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. -;;; -;;; This program 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. -;;; -;;; A copy of the GNU General Public License can be obtained from this -;;; program's author (send electronic mail to kyle@uunet.uu.net) or from -;;; the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA -;;; 02139, USA. -;;; -;;; Send bug reports to kyle_jones@wonderworks.com - -;; LCD Archive Entry: -;; filladapt|Kyle Jones|kyle_jones@wonderworks.com| -;; Minor mode to adaptively set fill-prefix and overload filling functions| -;; 28-February-1998|2.12|~/packages/filladapt.el| - -;; These functions enhance the default behavior of Emacs' Auto Fill -;; mode and the commands fill-paragraph, lisp-fill-paragraph, -;; fill-region-as-paragraph and fill-region. -;; -;; The chief improvement is that the beginning of a line to be -;; filled is examined and, based on information gathered, an -;; appropriate value for fill-prefix is constructed. Also the -;; boundaries of the current paragraph are located. This occurs -;; only if the fill prefix is not already non-nil. -;; -;; The net result of this is that blurbs of text that are offset -;; from left margin by asterisks, dashes, and/or spaces, numbered -;; examples, included text from USENET news articles, etc. are -;; generally filled correctly with no fuss. -;; -;; Since this package replaces existing Emacs functions, it cannot -;; be autoloaded. Save this in a file named filladapt.el in a -;; Lisp directory that Emacs knows about, byte-compile it and put -;; (require 'filladapt) -;; in your .emacs file. -;; -;; Note that in this release Filladapt mode is a minor mode and it is -;; _off_ by default. If you want it to be on by default, use -;; (setq-default filladapt-mode t) -;; -;; M-x filladapt-mode toggles Filladapt mode on/off in the current -;; buffer. -;; -;; Use -;; (add-hook 'text-mode-hook 'turn-on-filladapt-mode) -;; to have Filladapt always enabled in Text mode. -;; -;; Use -;; (add-hook 'c-mode-hook 'turn-off-filladapt-mode) -;; to have Filladapt always disabled in C mode. -;; -;; In many cases, you can extend Filladapt by adding appropriate -;; entries to the following three `defvar's. See `postscript-comment' -;; or `texinfo-comment' as a sample of what needs to be done. -;; -;; filladapt-token-table -;; filladapt-token-match-table -;; filladapt-token-conversion-table - -(and (featurep 'filladapt) - (error "filladapt cannot be loaded twice in the same Emacs session.")) - -(provide 'filladapt) - -(defvar filladapt-version "2.12" - "Version string for filladapt.") - -;; BLOB to make custom stuff work even without customize -(eval-and-compile - (condition-case () - (require 'custom) - (error nil)) - (if (and (featurep 'custom) (fboundp 'custom-declare-variable)) - nil ;; We've got what we needed - ;; We have the old custom-library, hack around it! - (defmacro defgroup (&rest args) - nil) - (defmacro defcustom (var value doc &rest args) - (` (defvar (, var) (, value) (, doc)))))) - -(defgroup filladapt nil - "Enhanced filling" - :group 'fill) - -(defvar filladapt-mode nil - "Non-nil means that Filladapt minor mode is enabled. -Use the filladapt-mode command to toggle the mode on/off.") -(make-variable-buffer-local 'filladapt-mode) - -(defcustom filladapt-mode-line-string " Filladapt" - "*String to display in the modeline when Filladapt mode is active. -Set this to nil if you don't want a modeline indicator for Filladapt." - :type 'string - :group 'filladapt) - -(defcustom filladapt-fill-column-tolerance nil - "*Tolerate filled paragraph lines ending this far from the fill column. -If any lines other than the last paragraph line end at a column -less than fill-column - filladapt-fill-column-tolerance, fill-column will -be adjusted using the filladapt-fill-column-*-fuzz variables and -the paragraph will be re-filled until the tolerance is achieved -or filladapt runs out of fuzz values to try. - -A nil value means behave normally, that is, don't try refilling -paragraphs to make filled line lengths fit within any particular -range." - :type '(choice (const nil) - integer) - :group 'filladapt) - -(defcustom filladapt-fill-column-forward-fuzz 5 - "*Try values from fill-column to fill-column plus this variable -when trying to make filled paragraph lines fall with the tolerance -range specified by filladapt-fill-column-tolerance." - :type 'integer - :group 'filladapt) - -(defcustom filladapt-fill-column-backward-fuzz 5 - "*Try values from fill-column to fill-column minus this variable -when trying to make filled paragraph lines fall with the tolerance -range specified by filladapt-fill-column-tolerance." - :type 'integer - :group 'filladapt) - -;; install on minor-mode-alist -(or (assq 'filladapt-mode minor-mode-alist) - (setq minor-mode-alist (cons (list 'filladapt-mode - 'filladapt-mode-line-string) - minor-mode-alist))) - -(defcustom filladapt-token-table - '( - ;; this must be first - ("^" beginning-of-line) - ;; Included text in news or mail replies - (">+" citation->) - ;; Included text generated by SUPERCITE. We can't hope to match all - ;; the possible variations, your mileage may vary. - ("\\(\\w\\|[0-9]\\)[^'`\"< \t\n]*>[ \t]*" supercite-citation) - ;; Lisp comments - (";+" lisp-comment) - ;; UNIX shell comments - ("#+" sh-comment) - ;; Postscript comments - ("%+" postscript-comment) - ;; C++ comments - ("///*" c++-comment) - ;; Texinfo comments - ("@c[ \t]" texinfo-comment) - ("@comment[ \t]" texinfo-comment) - ;; Bullet types. - ;; - ;; LaTex \item - ;; - ("\\\\item[ \t]" bullet) - ;; - ;; 1. xxxxx - ;; xxxxx - ;; - ("[0-9]+\\.[ \t]" bullet) - ;; - ;; 2.1.3 xxxxx xx x xx x - ;; xxx - ;; - ("[0-9]+\\(\\.[0-9]+\\)+[ \t]" bullet) - ;; - ;; a. xxxxxx xx - ;; xxx xxx - ;; - ("[A-Za-z]\\.[ \t]" bullet) - ;; - ;; 1) xxxx x xx x xx or (1) xx xx x x xx xx - ;; xx xx xxxx xxx xx x x xx x - ;; - ("(?[0-9]+)[ \t]" bullet) - ;; - ;; a) xxxx x xx x xx or (a) xx xx x x xx xx - ;; xx xx xxxx xxx xx x x xx x - ;; - ("(?[A-Za-z])[ \t]" bullet) - ;; - ;; 2a. xx x xxx x x xxx - ;; xxx xx x xx x - ;; - ("[0-9]+[A-Za-z]\\.[ \t]" bullet) - ;; - ;; 1a) xxxx x xx x xx or (1a) xx xx x x xx xx - ;; xx xx xxxx xxx xx x x xx x - ;; - ("(?[0-9]+[A-Za-z])[ \t]" bullet) - ;; - ;; - xx xxx xxxx or * xx xx x xxx xxx - ;; xxx xx xx x xxx x xx x x x - ;; - ("[-~*+]+[ \t]" bullet) - ;; - ;; o xx xxx xxxx xx x xx xxx x xxx xx x xxx - ;; xxx xx xx - ;; - ("o[ \t]" bullet) - ;; don't touch - ("[ \t]+" space) - ("$" end-of-line) - ) - "Table of tokens filladapt knows about. -Format is - - ((REGEXP SYM) ...) - -filladapt uses this table to build a tokenized representation of -the beginning of the current line. Each REGEXP is matched -against the beginning of the line until a match is found. -Matching is done case-sensitively. The corresponding SYM is -added to the list, point is moved to (match-end 0) and the -process is repeated. The process ends when there is no REGEXP in -the table that matches what is at point." - :type '(repeat (list regexp symbol)) - :group 'filladapt) - -(defcustom filladapt-not-token-table - '( - "[Ee]\\.g\\.[ \t,]" - "[Ii]\\.e\\.[ \t,]" - ;; end-of-line isn't a token if whole line is empty - "^$" - ) - "List of regexps that can never be a token. -Before trying the regular expressions in filladapt-token-table, -the regexps in this list are tried. If any regexp in this list -matches what is at point then the token generator gives up and -doesn't try any of the regexps in filladapt-token-table. - -Regexp matching is done case-sensitively." - :type '(repeat regexp) - :group 'filladapt) - -(defcustom filladapt-token-match-table - '( - (citation-> citation->) - (supercite-citation supercite-citation) - (lisp-comment lisp-comment) - (sh-comment sh-comment) - (postscript-comment postscript-comment) - (c++-comment c++-comment) - (texinfo-comment texinfo-comment) - (bullet) - (space bullet space) - (beginning-of-line beginning-of-line) - ) - "Table describing what tokens a certain token will match. - -To decide whether a line belongs in the current paragraph, -filladapt creates a token list for the fill prefix of both lines. -Tokens and the columns where tokens end are compared. This table -specifies what a certain token will match. - -Table format is - - (SYM [SYM1 [SYM2 ...]]) - -The first symbol SYM is the token, subsequent symbols are the -tokens that SYM will match." - :type '(repeat (repeat symbol)) - :group 'filladapt) - -(defcustom filladapt-token-match-many-table - '( - space - ) - "List of tokens that can match multiple tokens. -If one of these tokens appears in a token list, it will eat all -matching tokens in a token list being matched against it until it -encounters a token that doesn't match or a token that ends on -a greater column number." - :type '(repeat symbol) - :group 'filladapt) - -(defcustom filladapt-token-paragraph-start-table - '( - bullet - ) - "List of tokens that indicate the start of a paragraph. -If parsing a line generates a token list containing one of -these tokens, then the line is considered to be the start of a -paragraph." - :type '(repeat symbol) - :group 'filladapt) - -(defcustom filladapt-token-conversion-table - '( - (citation-> . exact) - (supercite-citation . exact) - (lisp-comment . exact) - (sh-comment . exact) - (postscript-comment . exact) - (c++-comment . exact) - (texinfo-comment . exact) - (bullet . spaces) - (space . exact) - (end-of-line . exact) - ) - "Table that specifies how to convert a token into a fill prefix. -Table format is - - ((SYM . HOWTO) ...) - -SYM is the symbol naming the token to be converted. -HOWTO specifies how to do the conversion. - `exact' means copy the token's string directly into the fill prefix. - `spaces' means convert all characters in the token string that are - not a TAB or a space into spaces and copy the resulting string into - the fill prefix." - :type '(repeat (cons symbol (choice (const exact) - (const spaces)))) - :group 'filladapt) - -(defvar filladapt-function-table - (let ((assoc-list - (list (cons 'fill-paragraph (symbol-function 'fill-paragraph)) - (cons 'fill-region (symbol-function 'fill-region)) - (cons 'fill-region-as-paragraph - (symbol-function 'fill-region-as-paragraph)) - (cons 'do-auto-fill (symbol-function 'do-auto-fill))))) - ;; v18 Emacs doesn't have lisp-fill-paragraph - (if (fboundp 'lisp-fill-paragraph) - (nconc assoc-list - (list (cons 'lisp-fill-paragraph - (symbol-function 'lisp-fill-paragraph))))) - assoc-list ) - "Table containing the old function definitions that filladapt usurps.") - -(defcustom filladapt-fill-paragraph-post-hook nil - "Hooks run after filladapt runs fill-paragraph." - :type 'hook - :group 'filladapt) - -(defvar filladapt-inside-filladapt nil - "Non-nil if the filladapt version of a fill function executing. -Currently this is only checked by the filladapt version of -fill-region-as-paragraph to avoid this infinite recursion: - - fill-region-as-paragraph -> fill-paragraph -> fill-region-as-paragraph ...") - -(defcustom filladapt-debug nil - "Non-nil means filladapt debugging is enabled. -Use the filladapt-debug command to turn on debugging. - -With debugging enabled, filladapt will - - a. display the proposed indentation with the tokens highlighted - using filladapt-debug-indentation-face-1 and - filladapt-debug-indentation-face-2. - b. display the current paragraph using the face specified by - filladapt-debug-paragraph-face." - :type 'boolean - :group 'filladapt) - -(if filladapt-debug - (add-hook 'post-command-hook 'filladapt-display-debug-info-maybe)) - -(defvar filladapt-debug-indentation-face-1 'highlight - "Face used to display the indentation when debugging is enabled.") - -(defvar filladapt-debug-indentation-face-2 'secondary-selection - "Another face used to display the indentation when debugging is enabled.") - -(defvar filladapt-debug-paragraph-face 'bold - "Face used to display the current paragraph when debugging is enabled.") - -(defvar filladapt-debug-indentation-extents nil) -(make-variable-buffer-local 'filladapt-debug-indentation-extents) -(defvar filladapt-debug-paragraph-extent nil) -(make-variable-buffer-local 'filladapt-debug-paragraph-extent) - -;; kludge city, see references in code. -(defvar filladapt-old-line-prefix) - -(defun do-auto-fill () - (catch 'done - (if (and filladapt-mode (null fill-prefix)) - (save-restriction - (let ((paragraph-ignore-fill-prefix nil) - ;; if the user wanted this stuff, they probably - ;; wouldn't be using filladapt-mode. - (adaptive-fill-mode nil) - (adaptive-fill-regexp nil) - ;; need this or Emacs 19 ignores fill-prefix when - ;; inside a comment. - (comment-multi-line t) - (filladapt-inside-filladapt t) - fill-prefix retval) - (if (filladapt-adapt nil nil) - (progn - (setq retval (filladapt-funcall 'do-auto-fill)) - (throw 'done retval)))))) - (filladapt-funcall 'do-auto-fill))) - -(defun filladapt-fill-paragraph (function arg) - (catch 'done - (if (and filladapt-mode (null fill-prefix)) - (save-restriction - (let ((paragraph-ignore-fill-prefix nil) - ;; if the user wanted this stuff, they probably - ;; wouldn't be using filladapt-mode. - (adaptive-fill-mode nil) - (adaptive-fill-regexp nil) - ;; need this or Emacs 19 ignores fill-prefix when - ;; inside a comment. - (comment-multi-line t) - fill-prefix retval) - (if (filladapt-adapt t nil) - (progn - (if filladapt-fill-column-tolerance - (let* ((low (- fill-column - filladapt-fill-column-backward-fuzz)) - (high (+ fill-column - filladapt-fill-column-forward-fuzz)) - (old-fill-column fill-column) - (fill-column fill-column) - (lim (- high low)) - (done nil) - (sign 1) - (delta 0)) - (while (not done) - (setq retval (filladapt-funcall function arg)) - (if (filladapt-paragraph-within-fill-tolerance) - (setq done 'success) - (setq delta (1+ delta) - sign (* sign -1) - fill-column (+ fill-column (* delta sign))) - (while (and (<= delta lim) - (or (< fill-column low) - (> fill-column high))) - (setq delta (1+ delta) - sign (* sign -1) - fill-column (+ fill-column - (* delta sign)))) - (setq done (> delta lim)))) - ;; if the paragraph lines never fell - ;; within the tolerances, refill using - ;; the old fill-column. - (if (not (eq done 'success)) - (let ((fill-column old-fill-column)) - (setq retval (filladapt-funcall function arg))))) - (setq retval (filladapt-funcall function arg))) - (run-hooks 'filladapt-fill-paragraph-post-hook) - (throw 'done retval)))))) - ;; filladapt-adapt failed, so do fill-paragraph normally. - (filladapt-funcall function arg))) - -(defun fill-paragraph (arg) - "Fill paragraph at or after point. Prefix arg means justify as well. - -(This function has been overloaded with the `filladapt' version.) - -If `sentence-end-double-space' is non-nil, then period followed by one -space does not end a sentence, so don't break a line there. - -If `fill-paragraph-function' is non-nil, we call it (passing our -argument to it), and if it returns non-nil, we simply return its value." - (interactive "*P") - (let ((filladapt-inside-filladapt t)) - (filladapt-fill-paragraph 'fill-paragraph arg))) - -(defun lisp-fill-paragraph (&optional arg) - "Like \\[fill-paragraph], but handle Emacs Lisp comments. - -(This function has been overloaded with the `filladapt' version.) - -If any of the current line is a comment, fill the comment or the -paragraph of it that point is in, preserving the comment's indentation -and initial semicolons." - (interactive "*P") - (let ((filladapt-inside-filladapt t)) - (filladapt-fill-paragraph 'lisp-fill-paragraph arg))) - -(defun fill-region-as-paragraph (beg end &optional justify - nosqueeze squeeze-after) - "Fill the region as one paragraph. - -(This function has been overloaded with the `filladapt' version.) - -It removes any paragraph breaks in the region and extra newlines at the end, -indents and fills lines between the margins given by the -`current-left-margin' and `current-fill-column' functions. -It leaves point at the beginning of the line following the paragraph. - -Normally performs justification according to the `current-justification' -function, but with a prefix arg, does full justification instead. - -From a program, optional third arg JUSTIFY can specify any type of -justification. Fourth arg NOSQUEEZE non-nil means not to make spaces -between words canonical before filling. Fifth arg SQUEEZE-AFTER, if non-nil, -means don't canonicalize spaces before that position. - -If `sentence-end-double-space' is non-nil, then period followed by one -space does not end a sentence, so don't break a line there." - (interactive "*r\nP") - (if (and filladapt-mode (not filladapt-inside-filladapt)) - (save-restriction - (narrow-to-region beg end) - (let ((filladapt-inside-filladapt t) - line-start last-token) - (goto-char beg) - (while (equal (char-after (point)) ?\n) - (delete-char 1)) - (end-of-line) - (while (zerop (forward-line)) - (if (setq last-token - (car (filladapt-tail (filladapt-parse-prefixes)))) - (progn - (setq line-start (point)) - (move-to-column (nth 1 last-token)) - (delete-region line-start (point)))) - ;; Dance... - ;; - ;; Do this instead of (delete-char -1) to keep - ;; markers on the correct side of the whitespace. - (goto-char (1- (point))) - (insert " ") - (delete-char 1) - - (end-of-line)) - (goto-char beg) - (fill-paragraph justify)) - ;; In XEmacs 19.12 and Emacs 18.59 fill-region relies on - ;; fill-region-as-paragraph to do this. If we don't do - ;; it, fill-region will spin in an endless loop. - (goto-char (point-max))) - (condition-case nil - ;; five args for Emacs 19.31 - (filladapt-funcall 'fill-region-as-paragraph beg end - justify nosqueeze squeeze-after) - (wrong-number-of-arguments - (condition-case nil - ;; four args for Emacs 19.29 - (filladapt-funcall 'fill-region-as-paragraph beg end - justify nosqueeze) - ;; three args for the rest of the world. - (wrong-number-of-arguments - (filladapt-funcall 'fill-region-as-paragraph beg end justify))))))) - -(defun fill-region (beg end &optional justify nosqueeze to-eop) - "Fill each of the paragraphs in the region. - -(This function has been overloaded with the `filladapt' version.) - -Prefix arg (non-nil third arg, if called from program) means justify as well. - -Noninteractively, fourth arg NOSQUEEZE non-nil means to leave -whitespace other than line breaks untouched, and fifth arg TO-EOP -non-nil means to keep filling to the end of the paragraph (or next -hard newline, if `use-hard-newlines' is on). - -If `sentence-end-double-space' is non-nil, then period followed by one -space does not end a sentence, so don't break a line there." - (interactive "*r\nP") - (if (and filladapt-mode (not filladapt-inside-filladapt)) - (save-restriction - (narrow-to-region beg end) - (let ((filladapt-inside-filladapt t) - start) - (goto-char beg) - (while (not (eobp)) - (setq start (point)) - (while (and (not (eobp)) (not (filladapt-parse-prefixes))) - (forward-line 1)) - (if (not (equal start (point))) - (progn - (save-restriction - (narrow-to-region start (point)) - (fill-region start (point) justify nosqueeze to-eop) - (goto-char (point-max))) - (if (and (not (bolp)) (not (eobp))) - (forward-line 1)))) - (if (filladapt-parse-prefixes) - (progn - (save-restriction - ;; for the clipping region - (filladapt-adapt t t) - (fill-paragraph justify) - (goto-char (point-max))) - (if (and (not (bolp)) (not (eobp))) - (forward-line 1))))))) - (condition-case nil - (filladapt-funcall 'fill-region beg end justify nosqueeze to-eop) - (wrong-number-of-arguments - (condition-case nil - (filladapt-funcall 'fill-region beg end justify nosqueeze) - (wrong-number-of-arguments - (filladapt-funcall 'fill-region beg end justify))))))) - -(defvar zmacs-region-stays) ; for XEmacs - -(defun filladapt-mode (&optional arg) - "Toggle Filladapt minor mode. -With arg, turn Filladapt mode on iff arg is positive. When -Filladapt mode is enabled, auto-fill-mode and the fill-paragraph -command are both smarter about guessing a proper fill-prefix and -finding paragraph boundaries when bulleted and indented lines and -paragraphs are used." - (interactive "P") - ;; don't deactivate the region. - (setq zmacs-region-stays t) - (setq filladapt-mode (or (and arg (> (prefix-numeric-value arg) 0)) - (and (null arg) (null filladapt-mode)))) - (if (fboundp 'force-mode-line-update) - (force-mode-line-update) - (set-buffer-modified-p (buffer-modified-p)))) - -(defun turn-on-filladapt-mode () - "Unconditionally turn on Filladapt mode in the current buffer." - (filladapt-mode 1)) - -(defun turn-off-filladapt-mode () - "Unconditionally turn off Filladapt mode in the current buffer." - (filladapt-mode -1)) - -(defun filladapt-funcall (function &rest args) - "Call the old definition of a function that filladapt has usurped." - (apply (cdr (assoc function filladapt-function-table)) args)) - -(defun filladapt-paragraph-start (list) - "Returns non-nil if LIST contains a paragraph starting token. -LIST should be a token list as returned by filladapt-parse-prefixes." - (catch 'done - (while list - (if (memq (car (car list)) filladapt-token-paragraph-start-table) - (throw 'done t)) - (setq list (cdr list))))) - -(defun filladapt-parse-prefixes () - "Parse all the tokens after point and return a list of them. -The tokens regular expressions are specified in -filladapt-token-table. The list returned is of this form - - ((SYM COL STRING) ...) - -SYM is a token symbol as found in filladapt-token-table. -COL is the column at which the token ended. -STRING is the token's text." - (save-excursion - (let ((token-list nil) - (done nil) - (old-point (point)) - (case-fold-search nil) - token-table not-token-table moved) - (catch 'done - (while (not done) - (setq not-token-table filladapt-not-token-table) - (while not-token-table - (if (looking-at (car not-token-table)) - (throw 'done t)) - (setq not-token-table (cdr not-token-table))) - (setq token-table filladapt-token-table - done t) - (while token-table - (if (null (looking-at (car (car token-table)))) - (setq token-table (cdr token-table)) - (goto-char (match-end 0)) - (setq token-list (cons (list (nth 1 (car token-table)) - (current-column) - (buffer-substring - (match-beginning 0) - (match-end 0))) - token-list) - moved (not (eq (point) old-point)) - token-table (if moved nil (cdr token-table)) - done (not moved) - old-point (point)))))) - (nreverse token-list)))) - -(defun filladapt-tokens-match-p (list1 list2) - "Compare two token lists and return non-nil if they match, nil otherwise. -The lists are walked through in lockstep, comparing tokens. - -When two tokens A and B are compared, they are considered to -match if - - 1. A appears in B's list of matching tokens or - B appears in A's list of matching tokens -and - 2. A and B both end at the same column - or - A can match multiple tokens and ends at a column > than B - or - B can match multiple tokens and ends at a column > than A - -In the case where the end columns differ the list pointer for the -token with the greater end column is not moved forward, which -allows its current token to be matched against the next token in -the other list in the next iteration of the matching loop. - -All tokens must be matched in order for the lists to be considered -matching." - (let ((matched t) - (done nil)) - (while (and (not done) list1 list2) - (let* ((token1 (car (car list1))) - (token1-matches-many-p - (memq token1 filladapt-token-match-many-table)) - (token1-matches (cdr (assq token1 filladapt-token-match-table))) - (token1-endcol (nth 1 (car list1))) - (token2 (car (car list2))) - (token2-matches-many-p - (memq token2 filladapt-token-match-many-table)) - (token2-matches (cdr (assq token2 filladapt-token-match-table))) - (token2-endcol (nth 1 (car list2))) - (tokens-match (or (memq token1 token2-matches) - (memq token2 token1-matches)))) - (cond ((not tokens-match) - (setq matched nil - done t)) - ((and token1-matches-many-p token2-matches-many-p) - (cond ((= token1-endcol token2-endcol) - (setq list1 (cdr list1) - list2 (cdr list2))) - ((< token1-endcol token2-endcol) - (setq list1 (cdr list1))) - (t - (setq list2 (cdr list2))))) - (token1-matches-many-p - (cond ((= token1-endcol token2-endcol) - (setq list1 (cdr list1) - list2 (cdr list2))) - ((< token1-endcol token2-endcol) - (setq matched nil - done t)) - (t - (setq list2 (cdr list2))))) - (token2-matches-many-p - (cond ((= token1-endcol token2-endcol) - (setq list1 (cdr list1) - list2 (cdr list2))) - ((< token2-endcol token1-endcol) - (setq matched nil - done t)) - (t - (setq list1 (cdr list1))))) - ((= token1-endcol token2-endcol) - (setq list1 (cdr list1) - list2 (cdr list2))) - (t - (setq matched nil - done t))))) - (and matched (null list1) (null list2)) )) - -(defun filladapt-make-fill-prefix (list) - "Build a fill-prefix for a token LIST. -filladapt-token-conversion-table specifies how this is done." - (let ((prefix-list nil) - (conversion-spec nil)) - (while list - (setq conversion-spec (cdr (assq (car (car list)) - filladapt-token-conversion-table))) - (cond ((eq conversion-spec 'spaces) - (setq prefix-list - (cons - (filladapt-convert-to-spaces (nth 2 (car list))) - prefix-list))) - ((eq conversion-spec 'exact) - (setq prefix-list - (cons - (nth 2 (car list)) - prefix-list)))) - (setq list (cdr list))) - (apply (function concat) (nreverse prefix-list)) )) - -(defun filladapt-paragraph-within-fill-tolerance () - (catch 'done - (save-excursion - (let ((low (- fill-column filladapt-fill-column-tolerance)) - (shortline nil)) - (goto-char (point-min)) - (while (not (eobp)) - (if shortline - (throw 'done nil) - (end-of-line) - (setq shortline (< (current-column) low)) - (forward-line 1))) - t )))) - -(defun filladapt-convert-to-spaces (string) - "Return a copy of STRING, with all non-tabs and non-space changed to spaces." - (let ((i 0) - (space-list '(?\ ?\t)) - (space ?\ ) - (lim (length string))) - (setq string (copy-sequence string)) - (while (< i lim) - (if (not (memq (aref string i) space-list)) - (aset string i space)) - (setq i (1+ i))) - string )) - -(defun filladapt-adapt (paragraph debugging) - "Set fill-prefix based on the contents of the current line. - -If the first arg PARAGRAPH is non-nil, also set a clipping region -around the current paragraph. - -If the second arg DEBUGGING is non-nil, don't do the kludge that's -necessary to make certain paragraph fills work properly." - (save-excursion - (beginning-of-line) - (let ((token-list (filladapt-parse-prefixes)) - curr-list done) - (if (null token-list) - nil - (setq fill-prefix (filladapt-make-fill-prefix token-list)) - (if paragraph - (let (beg end) - (if (filladapt-paragraph-start token-list) - (setq beg (point)) - (save-excursion - (setq done nil) - (while (not done) - (cond ((not (= 0 (forward-line -1))) - (setq done t - beg (point))) - ((not (filladapt-tokens-match-p - token-list - (setq curr-list (filladapt-parse-prefixes)))) - (forward-line 1) - (setq done t - beg (point))) - ((filladapt-paragraph-start curr-list) - (setq done t - beg (point))))))) - (save-excursion - (setq done nil) - (while (not done) - (cond ((not (= 0 (progn (end-of-line) (forward-line 1)))) - (setq done t - end (point))) - ((not (filladapt-tokens-match-p - token-list - (setq curr-list (filladapt-parse-prefixes)))) - (setq done t - end (point))) - ((filladapt-paragraph-start curr-list) - (setq done t - end (point)))))) - (narrow-to-region beg end) - ;; Multiple spaces after the bullet at the start of - ;; a hanging list paragraph get squashed by - ;; fill-paragraph. We kludge around this by - ;; replacing the line prefix with the fill-prefix - ;; used by the rest of the lines in the paragraph. - ;; fill-paragraph will not alter the fill prefix so - ;; we win. The post hook restores the old line prefix - ;; after fill-paragraph has been called. - (if (and paragraph (not debugging)) - (let (col) - (setq col (nth 1 (car (filladapt-tail token-list)))) - (goto-char (point-min)) - (move-to-column col) - (setq filladapt-old-line-prefix - (buffer-substring (point-min) (point))) - (delete-region (point-min) (point)) - (insert fill-prefix) - (add-hook 'filladapt-fill-paragraph-post-hook - 'filladapt-cleanup-kludge-at-point-min))))) - t )))) - -(defun filladapt-cleanup-kludge-at-point-min () - "Cleanup the paragraph fill kludge. -See filladapt-adapt." - (save-excursion - (goto-char (point-min)) - (insert filladapt-old-line-prefix) - (delete-char (length fill-prefix)) - (remove-hook 'filladapt-fill-paragraph-post-hook - 'filladapt-cleanup-kludge-at-point-min))) - -(defun filladapt-tail (list) - "Returns the last cons in LIST." - (if (null list) - nil - (while (consp (cdr list)) - (setq list (cdr list))) - list )) - -(defun filladapt-delete-extent (e) - (if (fboundp 'delete-extent) - (delete-extent e) - (delete-overlay e))) - -(defun filladapt-make-extent (beg end) - (if (fboundp 'make-extent) - (make-extent beg end) - (make-overlay beg end))) - -(defun filladapt-set-extent-endpoints (e beg end) - (if (fboundp 'set-extent-endpoints) - (set-extent-endpoints e beg end) - (move-overlay e beg end))) - -(defun filladapt-set-extent-property (e prop val) - (if (fboundp 'set-extent-property) - (set-extent-property e prop val) - (overlay-put e prop val))) - -(defun filladapt-debug () - "Toggle filladapt debugging on/off in the current buffer." -;; (interactive) - (make-local-variable 'filladapt-debug) - (setq filladapt-debug (not filladapt-debug)) - (if (null filladapt-debug) - (progn - (mapcar (function (lambda (e) (filladapt-set-extent-endpoints e 1 1))) - filladapt-debug-indentation-extents) - (if filladapt-debug-paragraph-extent - (progn - (filladapt-delete-extent filladapt-debug-paragraph-extent) - (setq filladapt-debug-paragraph-extent nil))))) - (add-hook 'post-command-hook 'filladapt-display-debug-info-maybe)) - -(defun filladapt-display-debug-info-maybe () - (cond ((null filladapt-debug) nil) - (fill-prefix nil) - (t - (if (null filladapt-debug-paragraph-extent) - (let ((e (filladapt-make-extent 1 1))) - (filladapt-set-extent-property e 'detachable nil) - (filladapt-set-extent-property e 'evaporate nil) - (filladapt-set-extent-property e 'face - filladapt-debug-paragraph-face) - (setq filladapt-debug-paragraph-extent e))) - (save-excursion - (save-restriction - (let ((ei-list filladapt-debug-indentation-extents) - (ep filladapt-debug-paragraph-extent) - (face filladapt-debug-indentation-face-1) - fill-prefix token-list) - (if (null (filladapt-adapt t t)) - (progn - (filladapt-set-extent-endpoints ep 1 1) - (while ei-list - (filladapt-set-extent-endpoints (car ei-list) 1 1) - (setq ei-list (cdr ei-list)))) - (filladapt-set-extent-endpoints ep (point-min) (point-max)) - (beginning-of-line) - (setq token-list (filladapt-parse-prefixes)) - (message "(%s)" (mapconcat (function - (lambda (q) (symbol-name (car q)))) - token-list - " ")) - (while token-list - (if ei-list - (setq e (car ei-list) - ei-list (cdr ei-list)) - (setq e (filladapt-make-extent 1 1)) - (filladapt-set-extent-property e 'detachable nil) - (filladapt-set-extent-property e 'evaporate nil) - (setq filladapt-debug-indentation-extents - (cons e filladapt-debug-indentation-extents))) - (filladapt-set-extent-property e 'face face) - (filladapt-set-extent-endpoints e (point) - (progn - (move-to-column - (nth 1 - (car token-list))) - (point))) - (if (eq face filladapt-debug-indentation-face-1) - (setq face filladapt-debug-indentation-face-2) - (setq face filladapt-debug-indentation-face-1)) - (setq token-list (cdr token-list))) - (while ei-list - (filladapt-set-extent-endpoints (car ei-list) 1 1) - (setq ei-list (cdr ei-list)))))))))) diff --git a/elisp/emacs-goodies-el/floatbg.el b/elisp/emacs-goodies-el/floatbg.el index ef6b23b..ef6b23b 100755..100644 --- a/elisp/emacs-goodies-el/floatbg.el +++ b/elisp/emacs-goodies-el/floatbg.el diff --git a/elisp/emacs-goodies-el/folding.el b/elisp/emacs-goodies-el/folding.el deleted file mode 100755 index fce5c59..0000000 --- a/elisp/emacs-goodies-el/folding.el +++ /dev/null @@ -1,5413 +0,0 @@ -;;; folding.el --- A folding-editor-like minor mode. - -;; This file is not part of Emacs - -;; Copyright (C) 2000-2013 Jari Aalto -;; Copyright (C) 1995, 1996, 1997, 1998, 1999 Jari Aalto, Anders Lindgren. -;; Copyright (C) 1994 Jari Aalto -;; Copyright (C) 1992, 1993 Jamie Lokier, All rights reserved. -;; -;; Authors: Jamie Lokier <jamie A T imbolc.ucc dt ie> -;; Jari Aalto <jari aalto A T cante dt net> -;; Anders Lindgren <andersl A T csd.uu dt se> -;; Maintainer: Jari Aalto <jari aalto A T cante dt net> -;; Created: 1992 -;; Keywords: tools -;; -;; [Latest devel version] -;; Vcs-URL: http://savannah.nongnu.org/projects/emacs-tiny-tools - -(defconst folding-version-time "2013.0613.1821" - "Last edit time in format YYYY.MMDD.HHMM.") - -;;{{{ GPL - -;; This program 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, -;; or (at your option) any later version. -;; -;; GNU Emacs 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 this program. If not, see <http://www.gnu.org/licenses/>. -;; -;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information - -;;}}} - -;;; Commentary: - -;;{{{ Introduction - -;; Preface -;; -;; This package provides a minor mode, compatible with all major -;; editing modes, for folding (hiding) parts of the edited text or -;; program. -;; -;; Folding mode handles a document as a tree, where each branch -;; is bounded by special markers `{{{' and `}}}'. A branch can be -;; placed inside another branch, creating a complete hierarchical -;; structure. -;; -;; Folding mode can CLOSE a fold, leaving only the initial `{{{' -;; and possibly a comment visible. -;; -;; It can also ENTER a fold, which means that only the current -;; fold will be visible, all text above `{{{' and below `}}}' -;; will be invisible. -;; -;; Please note, that the maintainers do not recommend to use only -;; folding for you your code layout and navigation. Folding.el is -;; on its best when it can "chunk" large sections of code inside -;; folds. The larger the chunks, the more the usability of -;; folding will increase. Folding.el is not meant to hide -;; individual functions: you may be better served by hideshow.el -;; or imenu.el (which can parse the function indexes) - -;;}}} -;;{{{ Installation - -;; Installation -;; -;; To install Folding mode, put this file (folding.el) on your -;; Emacs `load-path' (or extend the load path to include the -;; directory containing this file) and optionally byte compile it. -;; -;; The best way to install folding is the autoload installation, -;; so that folding is loaded into your emacs only when you turn on -;; `folding-mode'. This statement speeds up loading your .emacs -;; -;; (autoload 'folding-mode "folding" "Folding mode" t) -;; (autoload 'turn-off-folding-mode "folding" "Folding mode" t) -;; (autoload 'turn-on-folding-mode "folding" "Folding mode" t) -;; -;; But if you always use folding, then perhaps you want more -;; traditional installation. Here Folding mode starts -;; automatically when you load a folded file. -;; -;; ;; (setq folding-default-keys-function -;; ;; 'folding-bind-backward-compatible-keys) -;; -;; (if (load "folding" 'nomessage 'noerror) -;; (folding-mode-add-find-file-hook)) -;; -;; Folding uses a keymap which conforms with the new Emacs -;; (started 19.29) style. The key bindings are prefixed with -;; "C-c@" instead of old "C-c". To use the old keyboard bindings, -;; uncomment the lines in the the above installation example -;; -;; The same folding marks can be used in `vim' editor command -;; "set fdm=marker". -;; -;; Uninstallation -;; -;; To remove folding, call `M-x' `folding-uninstall'. -;; -;; To read the manual -;; -;; At any point you can reach the manual with `M-x' -;; `finder-commentary' RET folding RET. - -;;}}} -;;{{{ DOCUMENTATION - -;; Compatibility -;; -;; Folding supports following Emacs flavors: -;; -;; Unix Emacs 19.28+ and Win32 Emacs 19.34+ -;; Unix XEmacs 19.14+ and Win32 XEmacs 21.0+ -;; -;; Compatibility not for old NT Emacs releases -;; -;; NOTE: folding version starting from 2.47 gets around this bug -;; by using adviced kill/yank functions. The advice functions are -;; only instantiated under problematic NT Emacs versions. -;; -;; Windows NT/9x 19.34 - 20.3.1 (i386-*-nt4.0) versions contained -;; a bug which affected using folding. At the time the bug was -;; reported by Trey Jackson <trey A T cs berkeley edu> -;; -;; If you kill folded area and yank it back, the ^M marks are -;; removed for some reason. -;; -;; Before kill -;; ;;{{{ fold... -;; -;; After yank -;; ;;{{{ fold all lines together }}} -;; -;; Relates packages or modes -;; -;; Folding.el was designed to be a content organizer and it is most -;; suitable for big files. Sometimes people misunderstand the -;; package's capabilities and try to use folding.el in wrong places, -;; where some other package would do a better job. Trying to wrap -;; individual functions inside fold-marks is not where folding is -;; it's best. Grouping several functions inside a logical fold-block -;; in the other is. So, to choose a best tool for your need, -;; here are some suggestions,: -;; -;; o Navigating between or hiding individual functions - -;; use combination of imenu.el, speedbar.el and -;; hideshow.el -;; o Organizing large blocks - use folding.el -;; o For text, `outline-mode' is more non-intrusive than folding. -;; Look at Emacs NEWS file (`C-x' `n') and you can see beatifully -;; laid content. -;; -;; Tutorial -;; -;; To start folding mode, give the command: `M-x' `folding-mode' -;; `RET'. The mode line should contain the string "Fld" indicating -;; that folding mode is activated. -;; -;; When loading a document containing fold marks, Folding mode is -;; automatically started and all folds are closed. For example when -;; loading my init file, only the following lines (plus a few lines -;; of comments) are visible: -;; -;; ;;{{{ General... -;; ;;{{{ Keyboard... -;; ;;{{{ Packages... -;; ;;{{{ Major modes... -;; ;;{{{ Minor modes... -;; ;;{{{ Debug... -;; -;; To enter a fold, use `C-c @ >'. To show it without entering, -;; use `C-c @ C-s', which produces this display: -;; -;; ;;{{{ Minor modes -;; -;; ;;{{{ Follow mode... -;; ;;{{{ Font-lock mode... -;; ;;{{{ Folding... -;; -;; ;;}}} -;; -;; To show everything, just as the file would look like if -;; Folding mode hadn't been activated, give the command `M-x' -;; `folding-open-buffer' `RET', normally bound to `C-c' `@' -;; `C-o'. To close all folds and go to the top level, the -;; command `folding-whole-buffer' could be used. -;; -;; Mouse support -;; -;; Folding mode v2.0 introduced mouse support. Folds can be shown -;; or hidden by simply clicking on a fold mark using mouse button -;; 3. The mouse routines have been designed to call the original -;; function bound to button 3 when the user didn't click on a -;; fold mark. -;; -;; The menu -;; -;; A menu is placed in the "Tools" menu. Should no Tools menu exist -;; (Emacs 19.28) the menu will be placed in the menu bar. -;; -;; ISearch -;; -;; When searching using the incremental search (C-s) facilities, -;; folds will be automagically entered and closed. -;; -;; Problems -;; -;; Uneven fold marks -;; -;; Oops, I just deleted some text, and a fold mark got deleted! -;; What should I do? Trust me, you will eventually do this -;; sometime. the easiest way is to open the buffer using -;; `folding-open-buffer' (C-c @ C-o) and add the fold mark by -;; hand. To find mismatching fold marks, the package `occur' is -;; useful. The command: -;; -;; M-x occur RET {{{\|}}} RET -;; -;; will extract all lines containing folding marks and present -;; them in a separate buffer. -;; -;; Even though all folding marks are correct, Folding mode -;; sometimes gets confused, especially when entering and leaving -;; folds very often. To get it back on track, press C-g a few -;; times and give the command `folding-open-buffer' (C-c @ C-o). -;; -;; Fold must have a label -;; -;; When you make a fold, be sure to write some text for the name -;; of the fold, otherwise there may be an error "extraneous fold -;; mark..." Write like this: -;; -;; ;;{{{ Note -;; ;;}}} -;; -;; instead of -;; -;; ;;{{{ -;; ;;}}} -;; -;; folding-whole-buffer doesn't fold whole buffer -;; -;; If you call commands `folding-open-buffer' and -;; `folding-whole-buffer' and notice that there are open fold -;; sections in the buffer, then you have mismatch of folds -;; somewhere. Run ` M-x' `occur' and type regexp `{{{\|}}}' to -;; check where is the extra open or closing fold mark. -;; -;; Folding and outline modes -;; -;; Folding mode is not the same as Outline mode, a major and -;; minor mode which is part of the Emacs distribution. The two -;; packages do, however, resemble each other very much. The main -;; differences between the two packages are: -;; -;; o Folding mode uses explicit marks, `{{{' and `}}}', to -;; mark the beginning and the end of a branch. -;; Outline, on the other other hand, tries to use already -;; existing marks, like the `\section' string in a TeX -;; document. -;; -;; o Outline mode has no end marker which means that it is -;; impossible for text to follow a sub-branch. -;; -;; o Folding mode use the same markers for branches on all depths, -;; Outline mode requires that marks should be longer the -;; further, down in the tree you go, e.g `\chap', \section', -;; `\subsection', `\subsubsection'. This is needed to -;; distinguish the next mark at the current or higher levels -;; from a sub-branch, a problem caused by the lack of -;; end-markers. -;; -;; o Folding mode has mouse support, you can navigate through a -;; folded document by clicking on fold marks. (The XEmacs version -;; of Outline mode has mouse support.) -;; -;; o The Isearch facilities of Folding is capable of -;; automatically to open folds. Under Outline, the the entire -;; document must be opened prior isearch. -;; -;; In conclusion, Outline mode is useful when the document being -;; edited contains natural markers, like LaTeX. When writing code -;; natural markers are hard to find, except if you're happy with -;; one function per fold. -;; -;; Future development ideas -;; -;; The plan was from the beginning to rewrite the entire package. -;; Including replacing the core of the program, written using -;; old Emacs technology (selective display), and replace it with -;; modern equivalences, like overlays or text-properties for -;; Emacs and extents for XEmacs. -;; -;; It is not likely that any of this will come true considering -;; the time required to rewrite the core of the package. Since -;; the package, in it's current state, is much more powerful than -;; the original, it would be appropriate to write such package -;; from scratch instead of doing surgery on this one. - -;;}}} - -;;{{{ Customization - -;; Customization: general -;; -;; The behavior of Folding mode is controlled mainly by a set of -;; Emacs Lisp variables. This section will discuss the most -;; useful ones, for more details please see the code. The -;; descriptions below assumes that you know a bit about how to -;; use simple Emacs Lisp and knows how to edit ~/.emacs, your -;; init file. -;; -;; Customization: hooks -;; -;; The normal procedure when customizing a package is to write a -;; function doing the customization. The function is then added -;; to a hook which is called at an appropriate time. (Please see -;; the example section below.) The following hooks are -;; available: -;; -;; o `folding-mode-hook' -;; Called when folding mode is activated. -;; o `<major mode>-folding-hook' -;; Called when starting folding mode in a buffer with major -;; mode set to <major mode>. (e.g. When editing C code -;; the hook `c-mode-folding-hook' is called.) -;; o `folding-load-hook' -;; Called when folding mode is loaded into Emacs. -;; -;; Customization: The Mouse -;; -;; The variable `folding-behave-table' contains the actions which -;; should be performed when the user clicks on an open fold, a -;; closed fold etc. For example, if you prefer to `enter' a fold -;; rather than `open' it you should rebind this variable. -;; -;; The variable `folding-default-mouse-keys-function' contains -;; the name of the function used to bind your mouse keys. To use -;; your own mouse bindings, create a function, say -;; `my-folding-bind-mouse', and set this variable to it. -;; -;; Customization: Keymaps -;; -;; When Emacs 19.29 was released, the keymap was divided into -;; strict parts. (This division existed before, but a lot of -;; packages, even the ones delivered with Emacs, ignored them.) -;; -;; C-c <letter> -- Reserved for the users private keymap. -;; C-c C-<letter> -- Major mode. (Some other keys are -;; reserved as well.) -;; C-c <Punctuation Char> <Whatever> -;; -- Reserved for minor modes. -;; -;; The reason why `C-c@' was chosen as the default prefix is that -;; it is used by outline-minor-mode. It is not likely that few -;; people will try to use folding and outline at the same time. -;; -;; However, old key bindings have been kept if possible. The -;; variable `folding-default-keys-function' specifies which -;; function should be called to bind the keys. There are various -;; function to choose from how user can select the keybindings. -;; To use the old key bindings, add the following line to your -;; init file: -;; -;; (setq folding-default-keys-function -;; 'folding-bind-backward-compatible-keys) -;; -;; To define keys similar to the keys used by Outline mode, use: -;; -;; (setq folding-default-keys-function -;; 'folding-bind-outline-compatible-keys) -;; -;; Customization: adding new major modes -;; -;; To add fold marks for a new major mode, use the function -;; `folding-add-to-marks-list'. The command also replaces -;; existing marks. An example: -;; -;; (folding-add-to-marks-list -;; 'c-mode "/* {{{ " "/* }}} */" " */" t) -;; -;; Customization: ISearch -;; -;; If you don't like the extension folding.el applies to isearch, -;; set the variable `folding-isearch-install' to nil before -;; loading this package. - -;;}}} -;;{{{ Examples - -;; Example: personal setup -;; -;; To define your own key binding instead of using the standard -;; ones, you can do like this: -;; -;; (setq folding-mode-prefix-key "\C-c") -;; ;; -;; (setq folding-default-keys-function -;; '(folding-bind-backward-compatible-keys)) -;; ;; -;; (setq folding-load-hook 'my-folding-load-hook) -;; -;; -;; (defun my-folding-load-hook () -;; "Folding setup." -;; -;; (folding-install) ;; just to be sure -;; -;; ;; ............................................... markers ... -;; -;; ;; Change text-mode fold marks. Handy for quick -;; ;; sh/perl/awk code -;; -;; (defvar folding-mode-marks-alist nil) -;; -;; (let* ((ptr (assq 'text-mode folding-mode-marks-alist))) -;; (setcdr ptr (list "# {{{" "# }}}"))) -;; -;; ;; ........................................ bindings ... -;; -;; ;; Put `folding-whole-buffer' and `folding-open-buffer' -;; ;; close together. -;; -;; (defvar folding-mode-prefix-map nil) -;; -;; (define-key folding-mode-prefix-map "\C-w" nil) -;; (define-key folding-mode-prefix-map "\C-s" -;; 'folding-show-current-entry) -;; (define-key folding-mode-prefix-map "\C-p" -;; 'folding-whole-buffer)) -;; -;; Example: changing default fold marks -;; -;; In case you're not happy with the default folding marks, you -;; can change them easily. Here is an example -;; -;; (setq folding-load-hook 'my-folding-load-hook) -;; -;; (defun my-folding-load-hook () -;; "Folding vars setup." -;; ;; Change marks for 'text-mode' -;; (let* ((ptr (assq 'text-mode folding-mode-marks-alist))) -;; (setcdr ptr (list "# {{{" "# }}}")))) -;; -;; Example: choosing different fold marks for mode -;; -;; Suppose you sometimes want to use different fold marks for the -;; major mode: e.g. to alternate between "# {{{" and "{{{" in -;; `text-mode' Call `M-x' `my-folding-text-mode-setup' to change -;; the marks. -;; -;; (defun my-folding-text-mode-setup (&optional use-custom-folding-marks) -;; (interactive -;; (list (y-or-n-p "Use Custom fold marks now? "))) -;; (let* ((ptr (assq major-mode folding-mode-marks-alist)) -;; (default-begin "# {{{") -;; (default-end "# }}}") -;; (begin "{{{") -;; (end "}}}")) -;; (when (eq major-mode 'text-mode) -;; (unless use-custom-folding-marks -;; (setq begin default-begin end default-end))) -;; (setcdr ptr (list begin end)) -;; (folding-set-marks begin end))) -;; -;; Example: AucTex setup -;; -;; Suppose you're using comment.sty with AucTeX for editing -;; LaTeX2e documents and you have these comment types. You would -;; like to be able to set which of these 3 is to be folded at any -;; one time, using a simple key sequence: move back and forth -;; easily between the different comment types, e.g., "unfold -;; everything then fold on \x". -;; -;; \O ... \endO -;; \L ... \endL -;; \B ... \endB -;; -;; (setq folding-load-hook 'my-folding-load-hook) -;; -;; (defun my-folding-load-hook () -;; "Folding vars setup." -;; (let ((ptr (assq 'text-mode folding-mode-marks-alist))) -;; (setcdr ptr (list "\\O" "\\endO")) -;; (define-key folding-mode-prefix-map "C" -;; 'my-folding-marks-change))) -;; -;; (defun my-folding-marks-change (&optional selection) -;; "Select folding marks: prefixes nil, C-u and C-u C-u." -;; (interactive "P") -;; (let ((ptr (assq major-mode folding-mode-marks-alist)) -;; input) -;; (when (string-match "^\\(plain-\\|la\\|auc\\)?tex-" -;; (symbol-name major-mode)) -;; (setq input -;; (read-string "Latex \\end(X) Marker (default O): " -;; nil nil "O" nil)) -;; (setq input (upcase input)) -;; (turn-off-folding-mode) -;; (folding-add-to-marks-list -;; major-mode -;; (concat "\\" input) (concat "\\end" input) nil nil t) -;; ;; (setcdr ptr (list (concat "\\" input) (concat "\\end" input))) -;; (turn-on-folding-mode)))) -;; ;; End of example -;; -;; Bugs: Lazy-shot.el conflict in XEmacs -;; -;; [XEmacs 20.4 lazy-shot-mode] -;; 1998-05-28 Reported by Solofo Ramangalahy <solofo A T mpi-sb mpg de> -;; -;; % xemacs -q folding.el -;; M-x eval-buffer -;; M-x folding-mode -;; M-x font-lock-mode -;; M-x lazy-shot-mode -;; C-s mouse -;; -;; then search for mouse again and again. At some point you will -;; see "Deleting extent" in the minibuffer and XEmacs freezes. -;; -;; The strange point is that I have this bug only under Solaris -;; 2.5 sparc (binaries from ftp.xemacs.org) but not under Solaris -;; 2.6 x86. (XEmacs 20.4, folding 2.35). I will try to access -;; more machines to see if it's the same. -;; -;; I suspect that the culprit is lazy-shot as it is beta, but -;; maybe you will be able to describe the bug more precisely to -;; the XEmacs people I you can reproduce it. - -;;}}} -;;{{{ Old Documentation - -;; Old documentation -;; -;; The following text was written by Jamie Lokier for the release -;; of Folding V1.6. It is included here for no particular reason: -;; -;; Emacs 18: -;; Folding mode has been tested with versions 18.55 and -;; 18.58 of Emacs. -;; -;; Epoch: -;; Folding mode has been tested on Epoch 4.0p2. -;; -;; [X]Emacs: -;; There is code in here to handle some aspects of XEmacs. -;; However, up to version 19.6, there appears to be no way to -;; display folds. Selective-display does not work, and neither do -;; invisible extents, so Folding mode has no chance of -;; working. This is likely to change in future versions of -;; XEmacs. -;; -;; Emacs 19: -;; Tested on version 19.8, appears to be fine. Minor bug: -;; display the buffer in several different frames, then move in -;; and out of folds in the buffer. The frames are automatically -;; moved to the top of the stacking order. -;; -;; Some of the code is quite horrible, generally in order to -;; avoid some Emacs display "features". Some of it is specific to -;; certain versions of Emacs. By the time Emacs 19 is around and -;; everyone is using it, hopefully most of it won't be necessary. -;; -;; More known bugs -;; -;; *** Needs folding-fold-region to be more intelligent about -;; finding a good region. Check folding a whole current fold. -;; -;; *** Now works with 19! But check out what happens when you -;; exit a fold with the file displayed in two frames. Both -;; windows get fronted. Better fix that sometime. -;; -;; Future features -;; -;; *** I will add a `folding-next-error' sometime. It will only -;; work with Emacs versions later than 18.58, because compile.el -;; in earlier versions does not count line-numbers in the right -;; way, when selective display is active. -;; -;; *** Fold titles should be optionally allowed on the closing -;; fold marks, and `folding-tidy-inside' should check that the -;; opening title matches the closing title. -;; -;; *** `folded-file' set in the local variables at the end of a -;; file could encode the type of fold marks used in that file, -;; and other things, like the margins inside folds. -;; -;; *** I can see a lot of use for the newer features of Emacs 19: -;; -;; Using invisible text-properties (I hope they are intended to -;; make text invisible; it isn't implemented like that yet), it -;; will be possible to hide folded text without affecting the -;; text of the buffer. At the moment, Folding mode uses selective -;; display to hide text, which involves substituting -;; carriage-returns for line-feeds in the buffer. This isn't such -;; a good way. It may also be possible to display different folds -;; in different windows in Emacs 19. -;; -;; Using even more text-properties, it may be possible to track -;; pointer movements in and out of folds, and have Folding mode -;; automatically enter or exit folds as necessary to maintain a -;; sensible display. Because the text itself is not modified (if -;; overlays are used to hide text), this is quite safe. It would -;; make it unnecessary to provide functions like -;; `folding-forward-char', `folding-goto-line' or -;; `folding-next-error', and things like I-search would -;; automatically move in and out of folds as necessary. -;; -;; Yet more text-properties/overlays might make it possible to -;; avoid using narrowing. This might allow some major modes to -;; indent text properly, e.g., C++ mode. - -;;}}} - -;;; Change Log: - -;;{{{ History - -;; [person version] = developer and his revision tree number. -;; NOTE: History records were stopped in 2009 when code was moved under -;; version control. See VCS logs. -;; -;; Sep 20 2009 23.1 [jari git a80c2d6] -;; - Remove 'defmacro custom' for very old Emacs version that did -;; not have custom. -;; - Modernize all macros to use new backquote syntax, -;; - Move `folding-narrow-by-default' variable -;; definition before `folding-advice-instantiate' which -;; refers to it. -;; -;; Feb 20 2009 22.2.1 [jari git 51ada03..56b3089] -;; - Make XEmacs CVS and Savannah git revisions at header more clear -;; - Unify html-mode folds as in other modes: change [[[ ]]] to {{{ }}} -;; -;; Feb 09 2009 22.2.1 [jari git e0c2e92..6a3cff7] -;; - Minor documentaton fixes. -;; - Add new `python-mode' using `folding-add-to-marks-list'. -;; - Add new variable `folding-version-time' to record edit time. -;; Value is automatically updated by developer's Emacs setup. -;; -;; May 06 2007 21.4 [jari 3.38-3.41 2007.0506] -;; - Cleanup. Eol whitespaces removed, extra newlines cleaned. -;; Paren positions corrected. -;; - 'Personal reflections by Anders Lindgren' topic -;; rephrased 'Future development ideas' -;; - (folding-show-current-entry): Run `font-lock-fontify-region' -;; after opening the fold. Font-lock.el treated all closed folds -;; as comments. -;; -;; Nov 16 2006 21.4 [jari 3.36-3.37 2006.1118] -;; - Jeremy Hankins <nowan A T nowan org> sent a patch, which -;; adds variable `folding-narrow-by-default'. The patch affects -;; mostly `folding-shift-in'. This makes it possible to -;; advise viper-search to open folds. Thanks. -;; - Added VCS URL header to the beginning for canonnical location. -;; Updated maintainer section. -;; - Fixed Copyright years. -;; -;; Nov 25 2004 21.3 [jari 3.35 2004.1125] -;; - non-ascii character removed from bibtex-mode. -;; Changed bib-mode '@comment' => '%'. Closes Debian -;; Bug#282388 -;; -;; Sep 10 2004 21.3 [jari 2.116 2004.0910] -;; - (folding-fold-region): caused to indent bottom fold -;; some 50 spaces forward in auctex:latex-mode. Disabled -;; running `indent-according-to-mode' while in latex-mode. -;; Bug reported by Uwe Brauer; oub A T mat dot ucm dot es -;; - Removed extra newlines from whole buffer. -;; - Changed version scheme to date based YYYY.MMDD -;; - Removed unnecessary 'all rights reserved'. -;; - (folding-check-folded): Added check for \r character, which -;; - protected all email addresses by removing AT-signs. -;; -;; Apr 01 2004 21.3 [jari 2.111-2.115] -;; - Merged in changes made by 2003-11-12 Adrian Aichner -;; from XEmacs tree 1.15; Typo fixes for docstrings and comments. -;; - Returned to old bug and solved it in a better way (preserve region) by -;; using different expansion macros for XEmacs and Emacs. -;; See See http://list-archive.xemacs.org/xemacs-beta/199810/msg00039.html -;; - (folding-forward-char-1): 2.112 Renamed. -;; Was `folding-forward-char'. -;; (folding-backward-char-1): 2.112 Renamed. -;; Was `folding-backward-char'. -;; (folding-forward-char-macro): 2.112 New. Fix XEmacs -;; region preservation with '_p' interactive spec. -;; (folding-backward-char-macro): 2.112 New. Fix XEmacs -;; region preservation with '_p' interactive spec. -;; (folding-interactive-spec-p): 2.112 New. -;; -;; Sep 11 2003 21.2 [jari 2.107-2.111] -;; - Added new sections "Uninstallation" and "To read the manual". -;; M-x finder can invoke folding too provided that patch to -;; lisp-mnt.el and finder.el is installed. Sent patch to XEmacs and -;; Emacs developers. -;; - Moved fold-mark ";;{{{ Introduction" after the Commentary: -;; tag to have it included in M-x finder-commentary. -;; - If called like this: `folding-uninstall' and immediately -;; `folding-mode', the keybindings were not there any more. Added -;; call to `folding-install' in `folding-mode'. -;; - Completely rewrote `folding-install'. It's now divided into -;; `folding-install-keymaps' and `folding-uninstall-keymaps' -;; - Added support for `php-mode', `javascript-mode', -;; `change-log-mode' and `finder-mode'. -;; - Documentation changes (fit all to 80 characters). -;; -;; Aug 21 2002 21.2 [jari 2.105-2.106] -;; - Added user function `folding-uninstall'. -;; - Removed `interactive' status: `folding-install-hooks' and -;; `folding-uninstall-hooks' -;; -;; Aug 02 2002 20.7 [jari 2.101-2.104] -;; - Added font lock support. Now beginning and end markers are -;; highlighted with user variables `folding-font-lock-begin-mark' -;; `folding-font-lock-end-mark'. Feature suggested by -;; <Claude BOUCHER A T astrium-space com> -;; - Removed LCD entry - unnecessary. -;; -;; Jan 24 2002 20.7 [jari 2.100] -;; - (folding-context-next-action):New user function. -;; Code by Scott Evans <gse A T antisleep com> -;; - (folding-bind-default-keys): Added -;; C-x . to run `folding-context-next-action' -;; - (folding-mouse-call-original): Added `car-safe' to read -;; EVENT, which may be nil. -;; -;; Jul 31 2001 20.7 [jari 2.98-2.99] -;; - Gleb Arshinov <gleb A T barsook com> fixed the broken XEmacs -;; isearch support and sent nice patch. -;; -;; Jul 19 2001 20.7 [jari 2.92-2.97] -;; - Beautified lisp code by removing parens that were alone. -;; - XEmacs latex-mode fix. The folds were strangely indented too -;; far right. The cause was `indent-according-to-mode' which is -;; now disabled in latex. bug reported by -;; Uwe Brauer; oub A T maraton sim ucm es -;; - 2.96 Erroneous `:' in `folding-mode-write-file' -;; when it should have been `;'. Bug reported by -;; Brand Michael; michael brand A T siemens com -;; -;; Apr 04 2001 20.7 [jari 2.89-2.91] -;; - Small corrections to find-func.el::find-function-search-for-symbol -;; implementation. -;; -;; Mar 08 2001 20.6 [jari 2.88] -;; - Dave Masterson <dmasters A T rational com> reported that jumping to a -;; url displayed by the C-h f FUNCTION which told where the function -;; was located died. The reason was that the buffer was folded and -;; find-func.el::find-function-search-for-symbol used regexps that -;; do not take into account folded buffers. The regexps used there -;; rely on syntax tables. -;; - Added two new advices to catch find-func.el and unfold the buffer -;; prior searching: (advice find-file-noselect after) and (advice -;; find-function-search-for-symbol around) -;; -;; Mar 04 2001 20.6 [jari 2.83-2.87] -;; - Added ###autoload statements, tidied up empty lines and lisp syntax. -;; - Run checkdoc.el 0.6.1 and corrected errors. -;; -;; Jan 04 2001 20.6 [jari 2.82] -;; - Added FOLD highlight feature for XEmacs: -;; `folding-mode-motion-highlight-fold' -;; and package `mode-motion' Suggested by -;; Thomas Ruhnau <thomas ruhnau A T intermetall de> -;; - (folding-bind-default-keys): 2.81 New binding C-k -;; `folding-marks-kill' -;; (fold-marks-kill): 2.81 New. -;; -;; Jan 03 2001 20.6 [jari 2.81] -;; - (folding-folding-region): 2.80 Renamed to `folding-fold-region' -;; - (folding-mark-look-at-top-mark-p): 2.80 New. -;; - (folding-mark-look-at-bottom-mark-p): 2.80 New. -;; - (folding-tidy-inside): 2.80 Use `folding-mark-look-at-top-mark-p' -;; and `folding-mark-look-at-bottom-mark-p'. -;; - Didn't accept spaces in front of fold markers. -;; - (folding-fold-region): 2.80 Added `indent-according-to-mode' -;; to indent folds as needed. -;; -;; Dec 16 2000 20.6 [jari 2.79-2.80] -;; - `folding-xemacs-p' now test (featurep 'xemacs) -;; - Added missing folding functions to the menubar -;; - `folding-package-url-location' new variable used by function -;; `folding-insert-advertise-folding-mode' -;; - `folding-keep-hooked' was commented out in `folding-mode'. Added -;; back. -;; -;; Jul 25 2000 20.6 [jari 2.76-2.78] -;; - 2.75 Added support for modes: -;; xrdb-mode, ksh-mode and sql-mode contributed by -;; Juhapekka Tolvanen <juhtolv A T st jyu fi>. Scanned systematically -;; all modes under Emacs 20.6 progmodes and added support for: -;; ada-mode, asm-mode, awk-mode, cperl-mode, fortran-mode, f90-mode, -;; icon-mode, m4-mode, meta-mode, pascal-mode, prolog-mode, -;; simula-mode, vhdl-mode, bibtex-mode, nroff-mode, scribe-mode(*), -;; sgml-mode -;; - Mode marked with (*) was not added. -;; - (folding-insert-advertise-folding-mode): 2.76 New. Suggested by -;; Juhapekka Tolvanen <juhtolv A T st jyu fi> -;; - (folding-bind-default-keys): 2.76 -;; folding-insert-advertise-folding-mode Bound to key "I" -;; -;; Apr 24 1999 20.4 [jari 2.73-2.75] -;; - (folding-bind-terminal-keys): 2.74 New. Bind C-f and C-b only at -;; non-window system where they are really needed. Someone may use -;; C-f for `isearch-forward' in windowed Emacs. -;; - (folding-bind-default-keys): 2.74 Use `folding-bind-terminal-keys' -;; - (folding-bind-outline-compatible-keys): 2.74 -;; Use `folding-bind-terminal-keys' -;; -;; Feb 13 1999 20.4 [jari 2.71-2.72] -;; - (folding-event-posn): 2.70 Wrong -;; place of paren and the following was malformed call: -;; (let* ((el (funcall (symbol-function 'event-start) event))) -;; -;; Jan 13 1999 20.4 [jari 2.70] -;; - 2.69 The `looking-at' is now smarter with -;; fold beginning marks. The tradition has been the the fold always -;; has a name, so the requirement to search fold is "{{{ ". Now -;; the " " is searched as " *", not requiring a space --> not requiring -;; a fold name. -;; - (folding-skip-folds): >>feature not not enabled<< -;; 2.69 Do not require trailing " " any more.' -;; (folding-tidy-inside): >>feature not not enabled<< -;; 2.69 Do not require trailing " " any more. -;; - (folding-install): 2.69 Fixed indentation. -;; - (folding-mark-look-at): 2.69 The "em" missed "*" and thus pressing -;; mouse-3 at the end-fold didn't collapse the whole fold. -;; -;; Jan 12 1999 20.4 [jari 2.69] -;; (folding-bind-default-mouse): 2.68 -;; XEmacs and Emacs Mouse binding was different. Now use common -;; bindings: The S-mouse-2 was superfluous, because mouse-3 already -;; did that, so the binding was removed. -;; mouse-3 folding-mouse-context-sensitive -;; S-mouse-2 folding-hide-current-entry -;; C-S-mouse-2 folding-mouse-pick-move -;; -;;;; Jan 09 1999 20.4 [jari 2.67-2.68] -;; - (folding-event-posn): 2.66 Hide `event-start' From XEmacs -;; (byte compile silencer) -;; -;; Jan 07 1999 20.4 [jari 2.65-2.66] -;; - The Folding begin and AND mark was not case sensitive; -;; that's why a latex styles "\B" and "\endB" fold marks couldn't -;; be used. Added relevant `case-fold-search' settings. Not tested -;; very well, though. -;; - Added standard "turn-on" "turn-off" functions. -;; - (folding-whole-buffer): 2.65 Better -;; Error message. Show used folding-mark on error. -;; - (folding-skip-folds): 2.65 Moved docs in function. -;; - (turn-off-folding-mode): 2.65 New. -;; - (turn-on-folding-mode): 2.65 New. -;; - (folding-mark-look-at): 2.65 `case-fold-search' -;; - (folding-next-visible-heading): 2.65 `case-fold-search' -;; - (folding-find-folding-mark): 2.65 `case-fold-search' -;; - (folding-pick-move): 2.65 `case-fold-search' -;; - (folding-skip-folds): 2.65 `case-fold-search' -;; - (folding-tidy-inside): 2.65 `case-fold-search' -;; - (folding-convert-to-major-folds): 2.65 `case-fold-search' -;; -;; Jan 04 1999 20.4 [jari 2.62-2.64] -;; - (folding-set-local-variables): 2.61 New. Now it is possible to -;; change the folding marks dynamically. -;; - (folding-mode): 2.61 Call `folding-set-local-variables' -;; (folding-mode-marks-alist): 2.61 mention -;; - `folding-set-local-variables' -;; Added documentation section: "Example: AucTex setup" -;; - NT Emacs fix wrapped inside `eval-and-compile'. hs-discard-overlays -;; are now hidden from byte compiler (since the code is not -;; executed anyway) -;; -;; May 24 1999 19.34 [jari 2.59-2.61] -;; - New function `folding-all-comment-blocks-in-region'. Requested by -;; Uwe Brauer <oub A T eucmos sim ucm es>. Bound under "/" key. -;; - (folding-all-comment-blocks-in-region): -;; Check non-whitespace `comment-end'. Added `matlab-mode' to -;; fold list -;; - (folding-event-posn): 2.63 Got rid of the XEmacs/Emacs -;; posn-/event- byte compiler warnings -;; - (folding-mouse-call-original): 2.63 Got rid of the XEmacs -;; `event-button' byte compiler warning. -;; -;; Apr 15 1999 19.34 [jari 2.57] -;; - (folding-mouse-call-original): Samuel Mikes -;; <smikes A T alumni hmc edu> reported that the `concat' function was -;; used to add an integer to "button" event. Applied patch to use -;; `format' instead. -;; -;; Mar 03 1999 19.34 [andersl] -;; - (folding-install): had extra paren. Removed. -;; -;; Feb 22 1999 19.34 [jari 2.56] -;; - folding-install): -;; Check if `folding-mode-prefix-map' is nil and call -;; -;; Feb 19 1999 19.34 [jari 2.55] -;; - (folding-mode-hook-no-re): -;; Renamed to `folding-mode-hook-no-regexp' -;; - (fold-inside-mode-name): Renames to `folding-inside-mode-name' -;; (fold-mode-string): Renamed to `folding-mode-string' -;; - Renamed all `fold-' prefixes to `folding-' -;; - Rewrote chapter `Example: personal setup' -;; -;; Jan 01 1999 19.34 [jari 2.54] -;; - Byte compiler error fix: (folding-bind-outline-compatible-keys): -;; 'folding-show-all lacked the quote. -;; -;; Dec 30 1998 19.34 [jari 2.53] -;; - Jesper Pedersen <blackie A T imada ou dk> reported bug that hiding -;; subtree was broken. This turned out to be a bigger problem in fold -;; handling in general. This release has big relatively big error -;; fixes. -;; - Many of the folding functions were also renamed to mimic Emacs 20.3 -;; allout.el names. Outline keybindings were rewritten too. -;; - folding.el (folding-mouse-yank-at-point): Renamed from -;; `folding-mouse-operate-at-point'. The name is similar to Emacs -;; standard variable name. The default value changed from nil --> t -;; according to suggestion by Jesper Pedersen <blackie A T imada ou dk> -;; Message "Info, Ignore [X]Emacs specific..." is now displayed only -;; while byte compiling file. -;; (folding-bind-outline-compatible-keys): -;; Checked the Emacs 20.3 allout.el outline bindings and made -;; folding mimic them -;; (folding-show-subtree): Renamed to `folding-show-current-subtree' -;; according to allout.el -;; (folding-hide-subtree): Renamed to `folding-hide-current-subtree' -;; according to allout.el -;; (folding-enter): Renamed to `folding-shift-in' -;; according to allout.el -;; (folding-exit): Renamed to `folding-shift-out' -;; according to allout.el -;; (folding-move-up): Renamed to `folding-previous-visible-heading' -;; according to allout.el -;; (folding-move): Renamed to `folding-next-visible-heading' -;; according to allout.el -;; (folding-top-level): Renamed to `folding-show-all' -;; according to allout.el -;; (folding-show): Renamed to `folding-show-current-entry' -;; according to allout.el -;; (folding-hide): Renamed to `folding-hide-current-entry' -;; according to allout.el -;; (folding-region-open-close): While loop rewritten so that if user -;; is already on a fold mark, then close current fold. This also -;; fixed the show/hide subtree problem. -;; (folding-hide-current-subtree): If use hide subtree that only had -;; one fold, then calling this function caused error. The reason was -;; error in `folding-pick-move' (folding-pick-move): Test that -;; `moved' variable is integer and only then move point. This is the -;; status indicator from `folding-find-folding-mark' -;; (folding-find-folding-mark): Fixed. mistakenly moved point when -;; checking TOP level marker, status 11. the point was permanently -;; moved to point-min. -;; -;; Dec 29 1998 19.34 [jari 2.51] -;; - Jesper Pedersen <blackie A T imada ou dk> reported that prefix key -;; cannot take vector notation [(key)]. This required changing the way -;; how folding maps the keys. Now uses intermediate keymap -;; `folding-mode-prefix-map' -;; - `folding-kbd' is new. -;; - `folding-mode' function description has better layout. -;; - `folding-get-mode-marks' is now defsubst. -;; -;; Dec 13 1998 19.34 [jari 2.49-2.50] -;; - Gleb Arshinov <gleb A T CS Stanford EDU> reported that the XEmacs 21.0 -;; `concat' function won't accept integer argument any more and -;; provided patch for `folding-set-mode-line'. -;; -;; Nov 28 1998 19.34 [jari 2.49-2.50] -;; - Gleb Arshinov <gleb A T CS Stanford EDU> reported that the -;; zmacs-region-stays must not be set globally but in the functions -;; that need it. He tested the change on tested on XEmacs 21.0 beta -;; and FSF Emacs 19.34.6 on NT and sent a patch . Thank you. -;; - (folding-preserve-active-region): New macro to set -;; `zmacs-region-stays' to t in XEmacs. -;; - (folding-forward-char): Use `folding-preserve-active-region' -;; - (folding-backward-char): Use `folding-preserve-active-region' -;; - (folding-end-of-line): Use `folding-preserve-active-region' -;; - (folding-isearch-general): Variables `is-fold' and -;; `is narrowed' removed, because they were not used. (Byte -;; Compilation fix) -;; - Later: interestingly using `defmacro' -;; folding-preserve-active-region does not work in XEmacs 21.0 beta, -;; but `defsubst' does. Reported and corrected by Gleb. -;; -;; Oct 22 1998 19.34 [jari 2.47-2.48] -;; - NT Emacs has had long time a bug where it strips away ^M when -;; closed fold is copied to kill ring. When pasted, then ^M are -;; gone. This cover NT Emacs releases 19.34 - 20.3. Bug report has -;; been filed. -;; - to cope with the situation I added new advice functions that -;; get instantiated only for these versions of NT Emacs. See -;; `kill-new' and `current-kill' -;; -;; Oct 21 1998 19.34 [jari 2.46] -;; - `folding-isearch-general' now enters folds as usual with isearch. -;; The only test needed was to check `quit-isearch' before calling -;; `folding-goto-char', because the narrow case was already taken -;; cared of in the condition case. -;; -;; Oct 19 1998 19.34 [jari 2.44] -;; - 1998-10-19 Uwe Brauer <oub A T sunma4 mat ucm es> reported that -;; In Netscape version > 4 the {{{ marks cannot be used. For IE they -;; were fine, but not for Netscape. Some bug there. -;; --> Marks changed to [[[ ]]] -;; -;; Oct 5 1998 19.34 [jari 2.43] -;; - The "_p" flag does not exist in Emacs 19.34, so the previous patch -;; was removed. <greg A T alphatech com> (Greg Klanderman) suggested using -;; `zmacs-region-stays'. Added to the beginning of file. -;; - todo: folding does not seem to open folds any more with Isearch. -;; -;; Oct 5 1998 19.34 [jari 2.42] -;; - Gleb Arshinov <gleb A T cs stanford edu> reported (and supplied patch): -;; I am using the latest beta of folding.el with XEmacs 21.0 "Finnish -;; Landrace" [Lucid] (i386-pc-win32) (same bug is present with folding.el -;; included with XEmacs). Being a big fan of zmacs-region, I was -;; disappointed to find that folding mode caused my usual way of -;; selecting regions (e.g. to select a line C-space, C-a, C-e) to break -;; :( I discovered that the following 3 functions would unset my mark. -;; Upon reading some documentation, this seems to be caused by an -;; argument to interactive used by these functions. With the following -;; tiny patch, the undesirable behaviour is gone. -;; - Patch was applied as is. Function affected: -;; `folding-forward-char' `folding-backward-char' -;; `folding-end-of-line'. Interactive spec changed from "p" to "_p" -;; -;; Sep 28 1998 19.34 [jari 2.41] -;; - Wrote section "folding-whole-buffer doesn't fold whole buffer" to -;; Problems topic. Fixed some indentation in documentation so that -;; command ripdoc.pl folding.el | t2html.pl --simple > folding.html -;; works properly. -;; -;; Sep 24 1998 19.34 [jari 2.40] -;; - Stephen Smith <steve A T fmrib ox ac uk> wished that the -;; `folding-comment-fold' should handle modes that have comment-start -;; and comment-end too. That lead to rewriting the comment function so -;; that it can be adapted to new modes. -;; - `folding-pick-move' didn't work in C-mode. Fixed. -;; (folding-find-folding-mark): -;; m and re must be protected with `regexp-quote'. This -;; corrected error eg. in C-mode where `folding-pick-move' -;; didn't move at all. -;; (folding-comment-fold): Added support for major modes that -;; have `comment-start' and `comment-end'. Use -;; `folding-comment-folding-table' -;; (folding-comment-c-mode): New. -;; (folding-uncomment-c-mode): New. -;; (folding-comment-folding-table): New. To adapt to any major-mode. -;; (folding-uncomment-mode-generic): New. -;; (folding-comment-mode-generic): New. -;; -;; Aug 08 1998 19.34 [jari 2.39] -;; - Andrew Maccormack <andrewm A T bristol st com> reported that the -;; `em' end marker that was defined in the `let' should also have -;; `[ \t\n]' which is in par with the `bm'. This way fold markers do -;; not need to be parked to the left any more. -;; -;; Jun 05 1998 19.34 [jari 2.37-2.38] -;; - Alf-Ivar Holm <affi A T osc no> send functions -;; `folding-toggle-enter-exit' and `folding-toggle-show-hide' which -;; were integrated. Alf also suggested that Fold marks should now -;; necessarily be located at the beginning of line, but allow spaces -;; at front. The patch was applied to `folding-mark-look-at' -;; -;; Mar 17 1998 19.34 [Anders] -;; - Anders: This patch fixes one problem that was reported in the -;; beginning of May by Ryszard Kubiak <R Kubia A T ipipan gda pl>. -;; - Finally, I think that I have gotten mouse-context-sensitive -;; right. Now, when you click on a fold that fold rather than the -;; one the cursor is on is used, while still not breaking commands -;; like `mouse-save-then-kill' which assumes that the point hasn't -;; been moved. -;; - Jari: Added topic "Fold must have a label" to the Problem section. -;; as reported by Solofo Ramangalahy <solofo A T mpi-sb mpg de> -;; - 1998-05-04 Ryszard Kubiak <R Kubiak A T ipipan gda pl> reported: I am -;; just curious if it is possible to make Emacs' cursor -;; automatically follow a mouse-click on the {{{ and }}} lines. I -;; mean by this that a [S-mouse-3] (as defined in my settings below -;; --- I keep not liking overloading [mouse-3]) first moves the -;; cursor to where the click happened and then hides or shows a -;; folded area. I presume that i can write a two-lines long -;; interactive function to do this. Still, may be this kind of mouse -;; behaviour is already available. -;; -;; Mar 17 1998 19.34 [Jari 2.34-2.35] -;; - Added "Example: choosing different fold marks for mode" -;; - corrected `my-folding-text-mode-setup' example. -;; -;; Mar 10 1998 19.34 [Jari 2.32-2.33] -;; - [Anders] responds to mouse-3 handling problem: I have found the -;; cause of the problem, and I have a suggestion for a fix. -;; -;; The problem is caused by two things: -;; * The "mouse-save-then-kill" checks that the previous command also -;; was "mouse-save-then-kill". -;; -;; * The second (more severe) problem is that -;; "folding-mouse-context-sensitive" sets the point to the -;; location of the click, effectively making -;; "mouse-save-then-kill" mark the area between the point and the -;; point! (This is why no region appears.) -;; -;; The first problem can be easily fixed by setting "this-command" -;; in "folding-mouse-call-original": -;; -;; - Now the good old mouse-3 binding is back again. -;; - (folding-mouse-context-sensitive): Added `save-excursion' as -;; Anders suggested before setting `state'. -;; (folding-mouse-call-original): commented out experimental code and -;; used (setq this-command orig-func) as Anders suggested. -;; -;; Mar 10 1998 19.34 [Jari 2.31] -;; - (folding-act): Added `event' to `folding-behave-table' calls. -;; Input argument takes now `event' too -;; - (folding-mouse-context-sensitive): Added argument `event' -;; - (folding-mouse-call-original): Added (this-command orig-func) -;; when calling original command. -;; - (folding-bind-default-mouse): Changed mouse bindings. The -;; button-3 can't be mapped by folding, because folding is unable to -;; call the original function `mouse-save-then-kill'. Passing simple -;; element to `mouse-save-then-kill' won't do the job. Eg if I -;; (clicked mouse-1) moved mouse pointer to place X and pressed -;; mouse-3, the area was not highlighted in folding mode. If folding -;; mode was off the are was highlighted. I traced the -;; `folding-mouse-call-original' and it was passing exactly the same -;; event as without folding mode. I have no clue what to do about -;; it...That's why I removed default mouse-3 binding and left it to -;; emacs. This bug was reported by Ryszard Kubiak" -;; <R Kubiak A T ipipan gda pl> -;; -;; Feb 12 1998 19.34 [Jari 2.30] -;; - (html-mode): New mode added to `folding-mode-marks-alist' -;; - (folding-get-mode-marks): Rewritten, now return 3rd element too. -;; - (folding-comment-fold): Added note that function with `comment-end' -;; is not supported. Function will flag error in those cases. -;; - (folding-convert-to-major-folds): Conversion failed if eg; you -;; switched between modes that has 2 and 1 comments, like -;; /* */ (C) and //(C++). Now the conversion is bit smarter, but it's -;; impossible to convert from /* */ to // directly because we don't -;; know how to remove */ mark, you see: -;; -;; Original mode was C -;; -;; /* {{{ */ -;; -;; And now used changed it to C++ mode, and ran command -;; `folding-convert-to-major-folds'. We no longer have information -;; about old mode's beginning or end comment markers, so we only -;; can convert the folds to format -;; -;; // {{{ */ -;; -;; Where the ending comment mark from old mode is left there. -;; This is slightly imperfect situation, but at least the fold -;; conversion works. -;; -;; Jan 28 1998 19.34 [Jari 2.25-2.29] -;; - Added `generic-mode' to fold list, suggested by Wayne Adams -;; <wadams A T galaxy sps mot com> -;; - Finally rewrote the awesome menu-bar code: now uses standard -;; easy-menu Which works in both XEmacs and Emacs. The menu is no -;; longer under "Tools", but appear when minor mode is turned on. -;; - Radical changes: Decided to remove all old lucid and epoch -;; dependencies. Lot of code removed and reprogrammed. -;; - I also got rid of the `folding-has-minor-mode-map-alist-p' variable -;; and old 18.xx function `folding-merge-keymaps'. -;; - Symbol's value as variable is void ((folding-xemacs-p)) error fixed. -;; - Optimized 60 `folding-use-overlays-p' calls to only 4 within -;; `folding-subst-regions'. (Used elp.el). It seems that half of the -;; time is spent in the function `folding-narrow-to-region' -;; function. Could it be optimized somehow? -;; - Changed "lucid" tests to `folding-xemacs-p' variable tests. -;; - Removed `folding-hack' and print message 'Info, ignore missing -;; functions.." instead. It's better that we see the missing -;; functions and not define dummy hacks for them. -;; -;; Nov 13 1997 19.34 [Jari 2.18-2.24] -;; - Added tcl-mode fold marks, suggested by Petteri Kettunen -;; <Petteri Kettunen A T oulu fi> -;; - Removed some old code and modified the hook functions a bit. -;; - Added new user function `folding-convert-to-major-folds', key "%". -;; - Added missing items to Emacs menubar, didn't dare to touch the -;; XEmacs part. -;; - `folding-comment-fold': Small fix. commenting didn't work on -;; closed folds. or if point was on topmost fold. -;; - Added `folding-advice-instantiate' And corrected byte compiler -;; message: Warning: variable oldposn bound but not referenced -;; Warning: reference to free variable folding-stack -;; - updated (require 'custom) code -;; -;; Nov 6 1997 19.34 [Jari 2.17] -;; - Uwe Brauer <oub A T sunma4 mat ucm es> used folding for Latex files -;; and he wished a feature that would allow him to comment away ext -;; that was inside fold; when compiling the TeX file. -;; - Added new user function `folding-comment-fold'. And new -;; keybinding ";". -;; -;; Oct 8 1997 19.34 [Jari 2.16] -;; - Now the minor mode map is always re-installed when this file is -;; loaded. If user accidentally made mistake in -;; `folding-default-keys-function', he can simply try again and -;; reload this file to have the new key definitions. -;; - Previously user had to manually go and delete the previous map -;; from the `minor-mode-map-alist' before he could try again. -;; -;; Sep 29 1997 19.34 [Jari 2.14-2.15] -;; - Robert Marshall <rxmarsha A T bechtel com> Sent enhancement to goto-line -;; code. Now M-g works more intuitively. -;; - Reformatted totally the documentation so that it can be ripped to -;; html with jari's ema-doc.pls and t2html.pls Perl scripts. -;; - Run through checkdoc.el 1.55 and Elint 1.10 and corrected code. -;; - Added defcustom support. (not tested) -;; -;; Sep 19 1997 19.28 [Jari 2.13] -;; - Robert Marshall <rxmarsha A T bechtel com> Sent small correction to -;; overlay code, where the 'owner tag was set wrong. -;; -;; Aug 14 1997 19.28 [Jari 2.12 ] -;; - A small regexp bug (extra whitespace was required after closing -;; fold) cause failing of folding-convert-buffer-for-printing in the -;; following situation -;; - Reported by Guide. Fixed now. -;; -;; {{{ Main topic -;; {{{ Subsection -;; }}} << no space or end tag here! -;; }}} Main topic -;; -;; Aug 14 1997 19.28 [Jari 2.11] -;; - Guide Van Hoecke <Guido Van Hoecke A T bigfoot com> reported that -;; he was using closing text for fold like: -;; -;; {{{ Main topic -;; {{{ Subsection -;; }}} Subsection -;; }}} Main topic -;; -;; And when he did folding-convert-buffer-for-printing, it couldn't -;; remove those closing marks but threw an error. I modified the -;; function so that the regexp accepts anything after closing fold. -;; -;; Apr 18 1997 19.28 [Jari 2.10] -;; - Corrected function folding-show-current-subtree, which didn't -;; find the correct end region, because folding-pick-move needed -;; point at the top of beginning fold. Bug was reported by Uwe -;; Brauer <oub A T sunma4 mat ucm es> Also changed folding-mark-look-at, -;; which now has new call parameter 'move. -;; -;; Mar 22 1997 19.28 [Jari 2.9] -;; - Made the XEmacs20 match more stricter, so that -;; folding-emacs-version gets value 'XEmacs19. Also added note about -;; folding in WinNT in the compatibility section. -;; - Added sh-script-mode indented-text-mode folding marks. -;; - Moved the version from branch to the root, because the extra -;; overlay code added, seems to be behaving well and it didn't break -;; the existing functionality. -;; -;; Feb 17 1997 19.28 [Jari 2.8.1.2] -;; - Cleaned up Dan's changes. First: we must not replace the -;; selective display code, but offer these two choices: Added -;; folding-use-overlays-p function which looks variable -;; folding-allow-overlays. -;; - Dan uses function from another Emacs specific (19.34+?) package -;; hs-discard-overlays. This is not available in 19.28. it should -;; be replaced with some new function... I didn't do that yet. -;; - The overlays don't exist in XEmacs. XE19.15 has promises: at least -;; I have heard that they have overlay.el library to mimic Emacs -;; functions. -;; - Now the overlay support can be turned on by setting -;; folding-allow-overlays to non-nil. The default is to use selective -;; display. Overlay Code is not tested! -;; -;; Feb 17 1997 19.28 [Dan 2.8.1.1] -;; - Dan Nicolaescu <done A T ece arizona edu> sent patch that replaced -;; selective display code with overlays. -;; -;; Feb 10 1997 19.28 [jari 2.8] -;; - Ricardo Marek <ricky A T ornet co il> Kindly sent patch that -;; makes code XEmacs 20.0 compatible. Thank you. -;; -;; Nov 7 1996 19.28 [jari 2.7] -;; - When I was on picture-mode and turned on folding, and started -;; isearch (I don't remember how I got fold mode on exactly) it -;; gave error that the fold marks were not defined and emacs -;; locked up due to simultaneous isearch-loop -;; - Added few fixes to the isearch handling function to avoid -;; infinite error loops. -;; -;; Nov 6 1996 19.28 [jari 2.5 - 2.6] -;; - Situation: have folded buffer, manually _narrow_ somewhere, C-x n n -;; - Then try searching --> folding breaks. Now it checks if the -;; region is true narrow and not folding-narrow before trying -;; to go outside of region and open a fold -;; - If it's true narrow, then we stay in that narrowed region. -;; -;; folding-isearch-general :+ -;; folding-region-has-folding-marks-p :+ -;; -;; Oct 23 1996 19.28 [jari 2.4] -;; folding-display-name :+ new user cmd "C-n" -;; folding-find-folding-mark :+ new -;; folding-pick-move :! rewritten, full of bugs -;; folding-region-open-close :! rewritten, full of bugs -;; -;; Oct 22 1996 19.28 [jari 2.3] -;; - folding-pick-move :! rewritten -;; folding-region-open-close :+ new user cmd "#" -;; folding-show-current-subtree :+ new user cmd "C-s", hides too -;; -;; Aug 01 1996 19.31 [andersl] -;; - folding-subst-regions, variable `font-lock-mode' set to nil. -;; Thanks to <stig A T hackvan com> -;; -;; Jun 19 1996 19.31 [andersl] -;; - The code has proven itself stable through the beta testing phase -;; which has lasted the past six months. -;; - A lot of comments written. -;; - The package `folding-isearch' integrated. -;; - Some code cleanup: -;; BOLP -> folding-BOL :! renamed -;; folding-behave-table :! field `down' removed. -;; -;; -;; Mar 14 1996 19.28 [jari 1.27] -;; - No code changes. Only some textual corrections/additions. -;; - Section "about keymaps" added. -;; -;; Mar 14 1996 19.28 [jackr 1.26] -;; - spell-check run over code. -;; -;; Mar 14 1996 19.28 [davidm 1.25] -;; - David Masterson <davidm A T prism kla com> This patch makes the menubar in -;; XEmacs work better. After I made this patch, the Hyperbole menus -;; starting working as expected again. I believe the use of -;; set-buffer-menubar has a problem, so the recommendation in XEmacs -;; 19.13 is to use set-menubar-dirty-flag. -;; -;; Mar 13 1996 19.28 [andersl 1.24] -;; - Corrected one minor bug in folding-check-if-folding-allowed -;; -;; Mar 12 1996 19.28 [jari 1.23] -;; - Renamed all -func variables to -function. -;; -;; mar 12 1996 19.28 [jari 1.22] -;; - Added new example how to change the fold marks. The automatic folding -;; was reported to cause unnecessary delays for big files (eg. when using -;; ediff) Now there is new function variable which can totally disable -;; automatic folding if the return value is nil. -;; -;; folding-check-allow-folding-function :+ new variable -;; folding-check-if-folding-allowed :+ new func -;; folding-mode-find-file :! modified -;; folding-mode-write-file :! better docs -;; folding-goto-line :! arg "n" --> "N" due to XEmacs 19.13 -;; -;; Mar 11 1996 19.28 [jari 1.21] -;; - Integrated changes made by Anders' to v1.19 [folding in beta dir] -;; -;; Jan 25 1996 19.28 [jari 1.20] -;; - ** Mainly cosmetic changes ** -;; - Added some 'Section' codes that can be used with lisp-mnt.el -;; - Deleted all code in 'special section' because it was never used. -;; - Moved some old "-v-" named variables to better names. -;; - Removed folding-mode-flag that was never used. -;; -;; Jan 25 1996 19.28 [jari 1.19] -;; - Put Anders' latest version into RCS tree. -;; -;; Jan 03 1996 19.30 [andersl] -;; - `folding-mouse-call-original' uses `call-interactively'. -;; `folding-mouse-context-sensitive' doesn't do `save-excursion'. -;; (More changes will come later.) -;; `folding-mouse-yank-at-p' macro corrected (quote added). -;; Error for `epoch::version' removed. -;; `folding-mark-look-at' Regexp change .* -> [^\n\r]* to avoid error. -;; -;; Nov 24 1995 19.28 [andersl] -;; - (sequencep ) added to the code which checks for the existence -;; of a tools menu. -;; -;; Aug 27 1995 19.28 19.12 [andersl] -;; - Keybindings restructured. They now conforms with the -;; new 19.29 styleguide. Old keybindings are still available. -;; - Menus new goes into the "Tools" menu, if present. -;; - `folding-mouse-open-close' renamed to -;; `folding-mouse-context-sensitive'. -;; - New entry `other' in `folding-behave-table' which defaults to -;; `folding-calling-original'. -;; - `folding-calling-original' now gets the event from `last-input-event' -;; if called without arguments (i.e. the way `folding-act' calls it.) -;; - XEmacs mouse support added. -;; - `folding-mouse-call-original' can call functions with or without -;; the Event argument. -;; - Byte compiler generates no errors neither for Emacs 19 and XEmacs. -;; -;; Aug 24 1995 19.28 [jari 1.17] -;; - To prevent infinite back calling loop, Anders suggested smart way -;; to detect that func call chain is started only once. -;; folding-calling-original :+ v, call chain terminator -;; "Internal" :! v, all private vars have this string -;; folding-mouse-call-original :! v, stricter chain check. -;; "copyright" :! t, newer notice -;; "commentary" :! t, ripped non-supported emacsen -;; -;; Aug 24 1995 19.28 [jari 1.16] -;; ** mouse interface rewritten -;; - Anders gave many valuable comments about simplifying the mouse usage, -;; he suggested that every mouse function should accept standard event, -;; and it should be called directly. -;; folding-global :- v, not needed -;; folding-mode-off-hook :- v, not needed -;; folding-mouse-action-table :- v, not needed any more -;; folding-default-keys-function :+ v, key settings -;; folding-default-mouse-keys-function:+ v, key settings -;; folding-mouse :- f, unnecessary -;; 'all mouse funcs' :! f, now accept "e" parameter -;; folding-default-keys :+ f, defines keys -;; folding-mouse-call-original :+ f, call orig mouse func -;; "examples" :! t, radical rewrote, only one left -;; -;; Aug 24 1995 19.28 [jari 1.15] -;; - some minor changes. If we're inside a fold, Mouse-3 will go one -;; level up if it points END or BEG marker. -;; folding-mouse-yank-at-point:! v, added 'up 'down -;; folding-mark-look-at :! f, more return values: '11 and 'end-in -;; folding-open-close :! f, bug, didn't exit if inside fold -;; PMIN, PMAX, NEXTP, add-l :+ more macros fom tinylibm.el -;; -;; Aug 23 1995 19.28 [andersl 1.14] -;; - Added `eval-when-compile' around 1.13 byte-compiler fix -;; to avoid code to be executed when using a byte-compiled version -;; of folding.el. -;; - Binds mode keys via `minor-mode-map-alist' -;; (i.e. `folding-merge-keymaps' is not used in modern Emacsen.) -;; This means that the user can not bind `folding-mode-map' to a new -;; keymap, \\(s\\|\\)he must modify the existing one. -;; - `defvars' for global feature test variables `folding-*-p'. -;; - `folding-mouse-open-close' now detects when the current fold was been -;; pressed. (The "current" is the fold around which the buffer is -;; narrowed.) -;; -;; Aug 23 1995 19.28 [jari 1.13] -;; - 19.28 Byte compile doesn't handle fboundp, boundp well. That's a bug. -;; Set some dummy functions to get cleaner output. -;; - The folding-mode-off doesn't seem very useful, because it -;; is never run when another major-mode is turned on ... maybe we should -;; utilize kill-all-local-variables-hooks with defadvice around -;; kill-all-local-variables ... -;; -;; folding-emacs-version :+ added. it was in the docs, but not defined -;; kill-all-local-variables-hooks :! v, moved to variable section -;; list-buffers-mode-alist :! v, --''-- -;; "compiler hacks" :+ section added -;; "special" :+ section added -;; "Compatibility" :! moved at the beginning -;; -;; Aug 22 1995 19.28 [jari 1.12] -;; - Only minor changes -;; BOLP, BOLPP, EOLP, EOLPP :+ f, macros added from tinylibm.el -;; folding-mouse-pick-move :! f, when cursor at beolp, move always up -;; "bindings" :+ added C-cv and C-cC-v -;; -;; Aug 22 1995 19.28 [jari 1.11] -;; - Inspired by mouse so much, that this revision contain substantial -;; changes and enhancements. Mouse is now powered! -;; - Anders wanted mouse to operate according to 'mouse cursor', not -;; current 'point'. -;; folding-mouse-yank-at-point: controls it. Phwew, I like this -;; one a lot. -;; -;; examples :! t, totally changed, now 2 choices -;; folding-mode-off-hook :+ v, when folding ends -;; folding-global :+ v, global store value -;; folding-mouse-action-table :! v, changed -;; folding-mouse :! f, stores event to global -;; folding-mouse-open-close :! f, renamed, mouse activated open -;; folding-mode :! f, added 'off' hook -;; folding-event-posn :+ f, handles FSF mouse event -;; folding-mouse-yank-at-p :+ f, check which mouse mode is on -;; folding-mouse-point :+ f, return working point -;; folding-mouse-move :+ f, mouse moving down , obsolete ?? -;; folding-mouse-pick-move :+ f, mouse move accord. fold mark -;; folding-next-visible-heading :+ f, from tinyfold.el -;; folding-previous-visible-heading :+ f, from tinyfold.el -;; folding-pick-move :+ f, from tinyfold.el -;; -;; -;; Aug 22 1995 19.28 [jari 1.10] -;; - Minor typing errors corrected : fol-open-close 'hide --> 'close -;; This caused error when trying to close open fold with mouse -;; when cursor was sitting on fold marker. -;; -;; Aug 22 1995 19.28 [jari 1.9] -;; - Having heard good suggestions from Anders...! -;; "install" : add-hook for folding missed -;; folding-open-close : generalized -;; folding-behave-table : NEW, logical behavior control -;; folding-:mouse-action-table : now folding-mouse-action-table -;; -;; - The mouse function seems to work with FSF emacs only, because -;; XEmacs doesn't know about double or triple clicks. We're working -;; on the problem... -;; -;; Aug 21 1995 19.28 [jari 1.8] -;; - Rearranged the file structure so that all variables are at the -;; beginning of file. With new functions, it easy to open-close -;; fold. Added word "code:" or "setup:" to the front of code folds, -;; so that the toplevel folds can be recognized more easily. -;; - Added example hook to install section for easy mouse use. -;; - Added new functions. -;; folding-get-mode-marks : return folding marks -;; folding-mark-look-at : status of current line, fold mark in it? -;; folding-mark-mouse : execute action on fold mark -;; -;; -;; Aug 17 1995 19.28/X19.12 [andersl 1.7] -;; - Failed when loaded into XEmacs, when `folding-mode-map' was -;; undefined. Folding marks for three new major modes added: -;; rexx-mode, erlang-mode and xerl-mode. -;; -;; Aug 14 1995 19.28 [jari 1.6] -;; - After I met Anders we exchanged some thoughts about usage philosophy -;; of error and signal commands. I was annoyed by the fact that they -;; couldn't be suppressed, when the error was "minor". Later Anders -;; developed fdb.el, which will be integrated to FSF 19.30. It -;; offers by-passing error/signal interference. -;; --> I changed back all the error commands that were taken away. -;; -;; Jun 02 1995 19.28 [andersl] -;; - "Narrow" not present in mode-line when in folding-mode. -;; -;; May 12 1995 19.28 [jari 1.5] -;; - Installation text cleaned: reference to 'install-it' removed, -;; because such function doesn't exist any more. The installation is -;; now automatic: it's done when user calls folding mode first time. -;; - Added 'private vars' section. made 'outside all folds' message -;; informational, not an error. -;; -;; May 12 1995 19.28 [jackr x.x] -;; - Corrected 'broken menu bar' problem. -;; - Even though make-sparse-keymap claims its argument (a string to -;; name the menu) is optional, it's not. Lucid has other -;; arrangements for the same thing.. -;; -;; May 10 1995 19.28 [jari 1.2] -;; - Moved provide to the end of file. -;; - Rearranged code so that the common functions are at the beginning. -;; Reprogrammed the whole installation with hooks. Added Write file -;; hook that makes sure you don't write in 'binary' while folding were -;; accidentally off. -;; - Added regexp text for certain files which are not allowed to -;; 'auto fold' when loaded. -;; - changed some 'error' commands to 'messages', this prevent screen -;; mixup when debug-on-error is set to t -;; + folding-list-delete , folding-msg , folding-mode-find-file , -;; folding-mode-write-file , folding-check-folded , folding-keep-hooked -;; -;; 1.7.4 May 04 1995 19.28 [jackr 1.11] -;; - Some compatibility changes: -;; v.18 doesn't allow an arg to make-sparse-keymap -;; testing epoch::version is trickier than that -;; free-variable reference cleanup -;; -;; 1.7.3 May 04 1995 19.28 [jari] -;; - Corrected folding-mode-find-file-hook , so that it has more -;; 'mode turn on' capabilities through user function -;; + folding-mode-write-file-hook: Makes sure your file is saved -;; properly, so that you don't end up saving in 'binary'. -;; + folding-check-folded: func, default checker provided -;; + folding-check-folded-file-function variable added, User can put his -;; 'detect folding.el file' methods here. -;; + folding-mode-install-it: func, Automatic installation with it -;; -;; 1.7.2 Apr 01 1995 19.28 [jackr] , Design support by [jari] -;; - Added folding to FSF & XEmacs menus -;; -;; 1.7.1 Apr 28 1995 19.28 [jackr] -;; - The folding editor's merge-keymap couldn't handle FSF menu-bar, -;; so some minor changes were made, previous is '>' and enhancements -;; are '>' -;; -;; < (buffer-disable-undo new-buffer) -;; --- -;; > (buffer-flush-undo new-buffer) -;; 1510,1512c1510 -;; < key (if (symbolp keycode) -;; < (vector keycode) -;; < (char-to-string keycode)) -;; --- -;; > key (char-to-string keycode) -;; 1802,1808d1799 -;; < ;;{{{ Compatibility hacks for various Emacs versions -;; < -;; < (or (fboundp 'buffer-disable-undo) -;; < (fset 'buffer-disable-undo (symbol-function 'buffer-flush-undo))) -;; < -;; < ;;}}} -;; -;; -;; X.x Dec 1 1994 19.28 [jari] -;; - Only minor change. Made the folding mode string user configurable. -;; Added these variables: -;; folding-mode-string, folding-inside-string,folding-inside-mode-name -;; - Changed revision number from 1.6.2 to 1.7 , so that people know -;; this package has changed. - -;;}}} - -;;; Code: - -;;{{{ setup: require packages - -;;; ......................................................... &require ... - -(eval-when-compile - (require 'cl)) - -(eval-and-compile - (autoload 'font-lock-fontify-region "font-lock") - ;; Forward declaration - (defvar global-font-lock-mode)) - -(require 'easymenu) - -(defvar folding-package-url-location - "Latest folding is available at http://cvs.xemacs.org/viewcvs.cgi/XEmacs/packages/xemacs-packages/text-modes/") - -;;}}} -;;{{{ setup: byte compiler hacks - -;;; ............................................. &byte-compiler-hacks ... -;;; - This really only should be evaluated in case we're about to byte -;;; compile this file. Since `eval-when-compile' is evaluated when -;;; the uncompiled version is used (great!) we test if the -;;; byte-compiler is loaded. - -;; Make sure `advice' is loaded when compiling the code. - -(eval-and-compile - (require 'advice) - (defvar folding-xemacs-p (or (boundp 'xemacs-logo) - (featurep 'xemacs)) - "Folding determines which emacs version it is running. t if Xemacs.") - ;; loading overlay.el package removes some byte compiler whinings. - ;; By default folding does not use overlay code. - (if folding-xemacs-p - (or (fboundp 'overlay-start) ;; Already loaded - (load "overlay" 'noerr) ;; No? Try loading it. - (message "\ -** folding.el: XEmacs 19.15+ has package overlay.el, try to get it. - This is only warning. Folding does not use overlays by - default. You can safely ignore possible overlay byte - compilation error - messages.")))) - -(eval-when-compile - - (when nil ;; Disabled 2000-01-05 - ;; While byte compiling - (if (string= (buffer-name) " *Compiler Input*") - (progn - (message "** folding.el:\ - Info, Ignore [X]Emacs's missing motion/event/posn functions calls")))) - - ;; ARGS: (symbol variable-p library) - (defadvice find-function-search-for-symbol (around folding act) - "Set folding flag for `find-file-noselect' to open all folds." - (let ((file (ad-get-arg 2))) - (when file - (message "FILE %s" file) - (put 'find-file-noselect 'folding file))) - ad-do-it - (put 'find-file-noselect 'folding nil)) - - (defun folding-find-file-noselect () - (let* ((file (get 'find-file-noselect 'folding)) - (buffer (and file - ;; It may be absolute path name, file.el, - ;; or just "file". - (or (find-buffer-visiting file) - (get-buffer file) - (get-buffer (concat file ".el")))))) - (when buffer - (with-current-buffer buffer - (when (symbol-value 'folding-mode) ;; Byte compiler silencer - (turn-off-folding-mode)))))) - - ;; See find.func.el find-function-search-for-symbol - ;; Make C-h f and mouse-click work to jump to a file. Folding mode - ;; Must be turned off due to regexps in find.func.el that can't - ;; search ^M lines. - - (defadvice find-file-noselect (after folding act) - "When called by `find-function-search-for-symbol', turn folding off." - (folding-find-file-noselect)) - - (defadvice make-sparse-keymap - (before - make-sparse-keymap-with-optional-argument - (&optional byte-compiler-happyfier) - activate) - "This advice does nothing except adding an optional argument -to keep the byte compiler happy when compiling Emacs specific code -with XEmacs.") - - ;; XEmacs and Emacs 19 differs when it comes to obsolete functions. - ;; We're using the Emacs 19 versions, and this simply makes the - ;; byte-compiler stop wining. (Why isn't there a warning flag which - ;; could have turned off?) - - (and (boundp 'mode-line-format) - (put 'mode-line-format 'byte-obsolete-variable nil)) - - (and (fboundp 'byte-code-function-p) - (put 'byte-code-function-p 'byte-compile nil)) - - (and (fboundp 'eval-current-buffer) - (put 'eval-current-buffer 'byte-compile nil))) - -(defsubst folding-preserve-active-region () - "In XEmacs keep the region alive. In Emacs do nothing." - (if (boundp 'zmacs-region-stays) ;Keep regions alive - (set 'zmacs-region-stays t))) ;use `set' to Quiet Emacs Byte Compiler - -;; Work around the NT Emacs Cut'n paste bug in selective-display which -;; doesn't preserve C-m's. Only installed in problematic Emacs and -;; in other cases these lines are no-op. - -(eval-and-compile - (when (and (not folding-xemacs-p) - (memq (symbol-value 'window-system) '(win32 w32)) ; NT Emacs - (string< emacs-version "20.4")) ;at least in 19.34 .. 20.3.1 - - (unless (fboundp 'char-equal) - (defalias 'char-equal 'equal)) - - (unless (fboundp 'subst-char) - (defun subst-char (str char to-char) - "Replace in STR every CHAR with TO-CHAR." - (let ((len (length str)) - (ret (copy-sequence str))) ;because 'aset' is destructive - (while (> len 0) - (if (char-equal (aref str (1- len)) char) - (aset ret (1- len) to-char)) - (decf len)) - ret))) - - (defadvice kill-new (around folding-win32-fix-selective-display act) - "In selective display, convert each C-m to C-a. See `current-kill'." - (let* ((string (ad-get-arg 0))) - (when (and selective-display (string-match "\C-m" (or string ""))) - (setq string (subst-char string ?\C-m ?\C-a))) - ad-do-it)) - - (defadvice current-kill (around folding-win32-fix-selective-display act) - "In selective display, convert each C-a back to C-m. See `kill-new'." - ad-do-it - (let* ((string ad-return-value)) - (when (and selective-display (string-match "\C-a" (or string ""))) - (setq string (subst-char string ?\C-a ?\C-m)) - (setq ad-return-value string)))))) - -(defvar folding-mode) ;; Byte Compiler silencer - -(when (locate-library "mode-motion") ;; XEmacs - (defun folding-mode-motion-highlight-fold (event) - "Highlight line under mouse if it has a foldmark." - (when folding-mode - (funcall - ;; Emacs Byte Compiler Shutup fix - (symbol-function 'mode-motion-highlight-internal) - event - (function - (lambda () - (beginning-of-line) - (if (folding-mark-look-at) - (search-forward-regexp "^[ \t]*")))) - (function - (lambda () - (if (folding-mark-look-at) - (end-of-line))))))) - (require 'mode-motion) - (add-hook 'mode-motion-hook 'folding-mode-motion-highlight-fold 'at-end)) - -;;}}} - -;;{{{ setup: some variable - -;;; .................................................. &some-variables ... - -;; This is a list of structures which keep track of folds being entered -;; and exited. It is a list of (MARKER . MARKER) pairs, followed by the -;; symbol `folded'. The first of these represents the fold containing -;; the current one. If the view is currently outside all folds, this -;; variable has value nil. - -(defvar folding-stack nil - "Internal. A list of marker pairs representing folds entered so far.") - -(defvar folding-version (substring "$Revision: 1.5 $" 11 15) - "Version number of folding.el.") - -;;}}} -;;{{{ setup: bind - -;;; .......................................................... &v-bind ... - -(defgroup folding nil - "Managing buffers with Folds." - :group 'tools) - -(defcustom folding-mode-prefix-key "\C-c@" - "*Prefix key to use for Folding commands in Folding mode." - :type 'string - :group 'folding) - -(defcustom folding-goto-key "\M-g" - "*Key to be bound to `folding-goto-line' in folding mode. -The default value is M - g, but you probably don't want folding to -occupy it if you have used M - g got `goto-line'." - :type 'string - :group 'folding) - -(defcustom folding-font-lock-begin-mark 'font-lock-reference-face - "Face to highlight beginning fold mark." - :type 'face - :group 'folding) - -(defcustom folding-font-lock-end-mark 'font-lock-reference-face - "Face to highlight end fold mark." - :type 'face - :group 'folding) - -(defvar folding-mode-map nil - "Keymap used in Folding mode (a minor mode).") - -(defvar folding-mode-prefix-map nil - "Keymap used in Folding mode keys sans `folding-mode-prefix-key'.") - -;;;###autoload -(defvar folding-mode nil - "When Non nil, Folding mode is active in the current buffer.") - -(make-variable-buffer-local 'folding-mode) -(set-default 'folding-mode nil) - -(defmacro folding-kbd (key function) - "Folding: define KEY with FUNCTION to `folding-mode-prefix-map'. -This is used when assigning keybindings to `folding-mode-map'. -See also `folding-mode-prefix-key'." - `(define-key - folding-mode-prefix-map - ,key ,function)) - -(defun folding-bind-default-mouse () - "Bind default mouse keys used by Folding mode." - (interactive) - (cond - (folding-xemacs-p - (define-key folding-mode-map [(button3)] - 'folding-mouse-context-sensitive) - ;; (define-key folding-mode-map '(double button3) 'folding-hide-current-entry) - (define-key folding-mode-map [(control shift button2)] - 'folding-mouse-pick-move)) - (t - (define-key folding-mode-map [mouse-3] 'folding-mouse-context-sensitive) - (define-key folding-mode-map [C-S-mouse-2] 'folding-mouse-pick-move)))) - -(defun folding-bind-terminal-keys () - "In non-window system, rebind C - f and C - b as folding-{forward,backward}-char." - (unless (or (and (boundp 'window-system) ;; Emacs - (symbol-value 'window-system)) ;; Byte compiler silencer - (and (fboundp 'console-type) ;; XEmacs - (let ((val (fboundp 'console-type))) - (not (eq 'tty val))))) - (define-key folding-mode-map "\C-f" 'folding-forward-char) - (define-key folding-mode-map "\C-b" 'folding-backward-char))) - -(defun folding-bind-default-keys () - "Bind the default keys used the `folding-mode'. - -The variable `folding-mode-prefix-key' contains the prefix keys, -the default is C - c @. - -For the good ol' key bindings, please use the function -`folding-bind-backward-compatible-keys' instead." - (interactive) - (define-key folding-mode-map folding-goto-key 'folding-goto-line) - (folding-bind-terminal-keys) - (define-key folding-mode-map "\C-e" 'folding-end-of-line) - (folding-kbd "\C-f" 'folding-fold-region) - (folding-kbd ">" 'folding-shift-in) - (folding-kbd "<" 'folding-shift-out) - (folding-kbd "\C-t" 'folding-show-all) - (folding-kbd "\C-s" 'folding-show-current-entry) - (folding-kbd "\C-x" 'folding-hide-current-entry) - (folding-kbd "\C-o" 'folding-open-buffer) - (folding-kbd "\C-w" 'folding-whole-buffer) - (folding-kbd "\C-r" 'folding-convert-buffer-for-printing) - (folding-kbd "\C-k" 'folding-marks-kill) - (folding-kbd "\C-v" 'folding-pick-move) - (folding-kbd "v" 'folding-previous-visible-heading) - (folding-kbd " " 'folding-next-visible-heading) - (folding-kbd "." 'folding-context-next-action) - ;; C-u: kinda "up" -- "down" - (folding-kbd "\C-u" 'folding-toggle-enter-exit) - (folding-kbd "\C-q" 'folding-toggle-show-hide) - ;; Think "#" as a 'fence' - (folding-kbd "#" 'folding-region-open-close) - ;; Esc-; is the standard emacs commend add key. - (folding-kbd ";" 'folding-comment-fold) - (folding-kbd "%" 'folding-convert-to-major-folds) - (folding-kbd "/" 'folding-all-comment-blocks-in-region) - (folding-kbd "\C-y" 'folding-show-current-subtree) - (folding-kbd "\C-z" 'folding-hide-current-subtree) - (folding-kbd "\C-n" 'folding-display-name) - (folding-kbd "I" 'folding-insert-advertise-folding-mode)) - -(defun folding-bind-backward-compatible-keys () - "Bind keys traditionally used by Folding mode. -For bindings which follow newer Emacs minor mode conventions, please -use the function `folding-bind-default-keys'. - -This function sets `folding-mode-prefix-key' to `C-c'." - (interactive) - (setq folding-mode-prefix-key "\C-c") - (folding-bind-default-keys)) - -(defun folding-bind-outline-compatible-keys () - "Bind keys used by the minor mode `folding-mode'. -The keys used are as much as possible compatible with -bindings used by Outline mode. - -Currently, some outline mode functions doesn't have a corresponding -folding function. - -The variable `folding-mode-prefix-key' contains the prefix keys, -the default is C - c @. - -For the good ol' key bindings, please use the function -`folding-bind-backward-compatible-keys' instead." - (interactive) - ;; Traditional keys: - (folding-bind-terminal-keys) - (define-key folding-mode-map "\C-e" 'folding-end-of-line) - ;; Mimic Emacs 20.3 allout.el bindings - (folding-kbd ">" 'folding-shift-in) - (folding-kbd "<" 'folding-shift-out) - (folding-kbd "\C-n" 'folding-next-visible-heading) - (folding-kbd "\C-p" 'folding-previous-visible-heading) - ;; ("\C-u" outline-up-current-level) - ;; ("\C-f" outline-forward-current-level) - ;; ("\C-b" outline-backward-current-level) - ;; (folding-kbd "\C-i" 'folding-show-current-subtree) - (folding-kbd "\C-s" 'folding-show-current-subtree) - (folding-kbd "\C-h" 'folding-hide-current-subtree) - (folding-kbd "\C-k" 'folding-marks-kill) - (folding-kbd "!" 'folding-show-all) - (folding-kbd "\C-d" 'folding-hide-current-entry) - (folding-kbd "\C-o" 'folding-show-current-entry) - ;; (" " outline-open-sibtopic) - ;; ("." outline-open-subtopic) - ;; ("," outline-open-supertopic) - ;; Other bindings not in allout.el - (folding-kbd "\C-a" 'folding-open-buffer) - (folding-kbd "\C-q" 'folding-whole-buffer) - (folding-kbd "\C-r" 'folding-convert-buffer-for-printing) - (folding-kbd "\C-w" 'folding-fold-region) - (folding-kbd "I" 'folding-insert-advertise-folding-mode)) - -;;{{{ goto-line (advice) - -(defcustom folding-advice-instantiate t - "*In non-nil install advice code. Eg for `goto-line'." - :type 'boolean - :group 'folding) - -(defcustom folding-shift-in-on-goto t - "*Flag in folding adviced function `goto-line'. -If non-nil, folds are entered when going to a given line. -Otherwise the buffer is unfolded. Can also be set to 'show. -This variable is used only if `folding-advice-instantiate' was -non-nil when folding was loaded. - -See also `folding-goto-key'." - :type 'boolean - :group 'folding) - -(defvar folding-narrow-by-default t - "If t (default) things like isearch will enter folds. If nil the -folds will be opened, but not entered.") - -(when folding-advice-instantiate - (eval-when-compile (require 'advice)) - ;; By Robert Marshall <rxmarsha A T bechtel com> - (defadvice goto-line (around folding-goto-line first activate) - "Go to line ARG, entering folds if `folding-shift-in-on-goto' is t. -It attempts to keep the buffer in the same visibility state as before." - (let () ;; (oldposn (point)) - ad-do-it - (if (and folding-mode - (or (folding-point-folded-p (point)) - (<= (point) (point-min-marker)) - (>= (point) (point-max-marker)))) - (let ((line (ad-get-arg 0))) - (if folding-shift-in-on-goto - (progn - (folding-show-all) - (goto-char 1) - (and (< 1 line) - (not (folding-use-overlays-p)) - (re-search-forward "[\n\C-m]" nil 0 (1- line))) - (let ((goal (point))) - (while (prog2 (beginning-of-line) - (if folding-shift-in-on-goto - (progn - (folding-show-current-entry t t) - (folding-point-folded-p goal)) - (folding-shift-in t)) - (goto-char goal))) - (folding-narrow-to-region - (and folding-narrow-by-default (point-min)) - (point-max) t))) - (if (or folding-stack (folding-point-folded-p (point))) - (folding-open-buffer)))))))) - -;;}}} - -(defun folding-bind-foldout-compatible-keys () - "Bind keys for `folding-mode' compatible with Foldout mode. - -The variable `folding-mode-prefix-key' contains the prefix keys, -the default is C - c @." - (interactive) - (folding-kbd "\C-z" 'folding-shift-in) - (folding-kbd "\C-x" 'folding-shift-out)) - -;;; This function is here, just in case we ever would like to add -;;; `hideif' support to folding mode. Currently, it is only used to -;;; which keys shouldn't be used. - -;;(defun folding-bind-hideif-compatible-keys () -;; "Bind keys for `folding-mode' compatible with Hideif mode. -;; -;;The variable `folding-mode-prefix-key' contains the prefix keys, -;;the default is C-c@." -;; (interactive) -;; ;; Keys defined by `hideif' -;; ;; (folding-kbd "d" 'hide-ifdef-define) -;; ;; (folding-kbd "u" 'hide-ifdef-undef) -;; ;; (folding-kbd "D" 'hide-ifdef-set-define-alist) -;; ;; (folding-kbd "U" 'hide-ifdef-use-define-alist) -;; -;; ;; (folding-kbd "h") 'hide-ifdefs) -;; ;; (folding-kbd "s") 'show-ifdefs) -;; ;; (folding-kbd "\C-d") 'hide-ifdef-block) -;; ;; (folding-kbd "\C-s") 'show-ifdef-block) -;; -;; ;; (folding-kbd "\C-q" 'hide-ifdef-toggle-read-only) -;; ) - -;;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. . - -;; Not used for modern Emacsen. -(defvar folding-saved-local-keymap nil - "Keymap used to save non-folding keymap. -(so it can be restored when folding mode is turned off.)") - -;;;###autoload -(defcustom folding-default-keys-function 'folding-bind-default-keys - "*Function or list of functions used to define keys for Folding mode. -Possible values are: - folding-bind-default-key - The standard keymap. - - `folding-bind-backward-compatible-keys' - Keys used by older versions of Folding mode. This function - does not conform to Emacs 19.29 style conversions concerning - key bindings. The prefix key is C - c - - `folding-bind-outline-compatible-keys' - Define keys compatible with Outline mode. - - `folding-bind-foldout-compatible-keys' - Define some extra keys compatible with Foldout. - -All except `folding-bind-backward-compatible-keys' used the value of -the variable `folding-mode-prefix-key' as prefix the key. -The default is C - c @" - :type 'function - :group 'folding) - -;; Not yet implemented: -;; folding-bind-hideif-compatible-keys -;; Define some extra keys compatible with hideif. - -;;;###autoload -(defcustom folding-default-mouse-keys-function 'folding-bind-default-mouse - "*Function to bind default mouse keys to `folding-mode-map'." - :type 'function - :group 'folding) - -(defvar folding-mode-menu nil - "Keymap containing the menu for Folding mode.") - -(defvar folding-mode-menu-name "Fld" ;; Short menu name - "Name of pull down menu.") - -;;}}} -;;{{{ setup: hooks - -;;; ......................................................... &v-hooks ... - -(defcustom folding-mode-hook nil - "*Hook called when Folding mode is entered. - -A hook named `<major-mode>-folding-hook' is also called, if it -exists. Eg., `c-mode-folding-hook' is called whenever Folding mode is -started in C mode." - :type 'hook - :group 'folding) - -(defcustom folding-load-hook nil - "*Hook run when file is loaded." - :type 'hook - :group 'folding) - -;;}}} -;;{{{ setup: user config - -;;; ........................................................ &v-Config ... - -;; Q: should this inherit mouse-yank-at-point's value? maybe not. -(defvar folding-mouse-yank-at-point t - "If non-nil, mouse activities are done at point instead of 'mouse cursor'. -Behaves like `mouse-yank-at-point'.") - -(defcustom folding-folding-on-startup t - "*If non-nil, buffers are folded when starting Folding mode." - :type 'boolean - :group 'folding) - -(defcustom folding-internal-margins 1 - "*Number of blank lines left next to fold mark when tidying folds. - -This variable is local to each buffer. To set the default value for all -buffers, use `set-default'. - -When exiting a fold, and at other times, `folding-tidy-inside' is invoked -to ensure that the fold is in the correct form before leaving it. This -variable specifies the number of blank lines to leave between the -enclosing fold marks and the enclosed text. - -If this value is nil or negative, no blank lines are added or removed -inside the fold marks. A value of 0 (zero) is valid, meaning leave no -blank lines. - -See also `folding-tidy-inside'." - :type 'boolean - :group 'folding) - -(make-variable-buffer-local 'folding-internal-margins) - -(defvar folding-mode-string " Fld" - "Buffer-local variable that hold the fold depth description.") - -(set-default 'folding-mode-string " Fld") - -;; Sets `folding-mode-string' appropriately. This allows the Folding mode -;; description in the mode line to reflect the current fold depth. - -(defconst folding-inside-string " " ; was ' inside ', - "Mode line addition to show 'inside' levels of fold.") - -;;;###autoload -(defcustom folding-inside-mode-name "Fld" - "*Mode line addition to show inside levels of 'fold' ." - :type 'string - :group 'folding) - -(defcustom folding-check-folded-file-function - 'folding-check-folded - "*Function that return t or nil after examining if the file is folded." - :type 'function - :group 'folding) - -(defcustom folding-check-allow-folding-function - 'folding-check-if-folding-allowed - "*Function that return t or nil after deciding if automatic folding." - :type 'function - :group 'folding) - -;;;###autoload -(defcustom folding-mode-string "Fld" - "*The minor mode string displayed when mode is on." - :type 'string - :group 'folding) - -;;;###autoload -(defcustom folding-mode-hook-no-regexp "RMAIL" - "*Regexp which disable automatic folding mode turn on for certain files." - :type 'string - :group 'folding) - -;;; ... ... ... ... ... ... ... ... ... ... ... ... ... .... &v-tables ... - -(defcustom folding-behave-table - '((close folding-hide-current-entry) - (open folding-show-current-entry) ; Could also be `folding-shift-in'. - (up folding-shift-out) - (other folding-mouse-call-original)) - "*Table of of logical commands and their associated functions. -If you want fold to behave like `folding-shift-in', when it 'open' -a fold, you just change the function entry in this table. - -Table form: - '( (LOGICAL-ACTION CMD) (..) ..)" - :type '(repeat - (symbol :tag "logical action") - (function :tag "callback")) - :group 'folding) - -;;; ... ... ... ... ... ... ... ... ... ... ... ... ... ..... &v-marks ... - -;;;###autoload -(defvar folding-mode-marks-alist nil - "List of (major-mode . fold mark) default combinations to use. -When Folding mode is started, the major mode is checked, and if there -are fold marks for that major mode stored in `folding-mode-marks-alist', -those marks are used by default. If none are found, the default values -of \"{{{ \" and \"}}}\" are used. - -Use function `folding-add-to-marks-list' to add more fold marks. The function -also explains the alist use in details. - -Use function `folding-set-local-variables' if you change the current mode's -folding marks during the session.") - -;;}}} -;;{{{ setup: private - -;;; ....................................................... &v-private ... - -(defvar folding-narrow-placeholder nil - "Internal. Mark where \"%n\" used to be in `mode-line-format'. -Must be nil.") - -(defvar folding-bottom-mark nil - "Internal marker of the true bottom of a fold.") - -(defvar folding-bottom-regexp nil - "Internal. Regexp marking the bottom of a fold.") - -(defvar folding-regexp nil - "Internal. Regexp for hunting down the `folding-top-mark' even in comments.") - -(defvar folding-secondary-top-mark nil - "Internal. Additional stuff that can be inserted as part of a top marker.") - -(defvar folding-top-mark nil - "Internal. The actual string marking the top of a fold.") - -(defvar folding-top-regexp nil - "Internal. -Regexp describing the string beginning a fold, possible with -leading comment thingies and like that.") - -(defvar folded-file nil - "Enter folding mode when this file is loaded. -(buffer local, use from a local variables list).") - -(defvar folding-calling-original nil - "Internal. Non-nil when original mouse binding is executed.") - -(defvar folding-narrow-overlays nil - "Internal. Keep the list of overlays.") -(make-variable-buffer-local 'folding-narrow-overlays) - -(defcustom folding-allow-overlays nil - "*If non-nil use overlay code. If nil, then selective display is used. -Note, that this code is highly experimental and will not most likely do what -you expect. using value t will not change folding to use overlays -completely. This variable was introduced to experiment with the overlay -interface, but the work never finished and it is unlikely that it -will continued any later time. Folding at present state is designed -too highly for selective display to make the change worthwhile." - :type 'boolean - :group 'folding) - -;;}}} -;;{{{ Folding install - -(defun folding-easy-menu-define () - "Define folding easy menu." - (interactive) - (easy-menu-define - folding-mode-menu - (if folding-xemacs-p - nil - (list folding-mode-map)) - "Folding menu" - (list - folding-mode-menu-name - ["Enter Fold" folding-shift-in t] - ["Exit Fold" folding-shift-out t] - ["Show Fold" folding-show-current-entry t] - ["Hide Fold" folding-hide-current-entry t] - "----" - ["Show Whole Buffer" folding-open-buffer t] - ["Fold Whole Buffer" folding-whole-buffer t] - ["Show subtree" folding-show-current-subtree t] - ["Hide subtree" folding-hide-current-subtree t] - ["Display fold name" folding-display-name t] - "----" - ["Move previous" folding-previous-visible-heading t] - ["Move next" folding-next-visible-heading t] - ["Pick fold" folding-pick-move t] - ["Next action (context)" folding-context-next-action t] - "----" - ["Foldify region" folding-fold-region t] - ["Open or close folds in region" folding-region-open-close t] - ["Open folds to top level" folding-show-all t] - "----" - ["Comment text in fold" folding-comment-fold t] - ["Convert for printing(temp buffer)" - folding-convert-buffer-for-printing t] - ["Convert to major-mode folds" folding-convert-to-major-folds t] - ["Move comments inside folds in region" - folding-all-comment-blocks-in-region t] - ["Delete fold marks in this fold" folding-marks-kill t] - ["Insert folding URL reference" - folding-insert-advertise-folding-mode t] - "----" - ["Toggle enter and exit mode" folding-toggle-enter-exit t] - ["Toggle show and hide" folding-toggle-show-hide t] - "----" - ["Folding mode off" folding-mode t]))) - -(defun folding-install-keymaps () - "Install keymaps." - (unless folding-mode-map - (setq folding-mode-map (make-sparse-keymap))) - (unless folding-mode-prefix-map - (setq folding-mode-prefix-map (make-sparse-keymap))) - (if (listp folding-default-keys-function) - (mapc 'funcall folding-default-keys-function) - (funcall folding-default-keys-function)) - (funcall folding-default-mouse-keys-function) - (folding-easy-menu-define) - (define-key folding-mode-map - folding-mode-prefix-key folding-mode-prefix-map) - ;; Install the keymap into `minor-mode-map-alist'. The keymap will - ;; be activated as soon as the variable `folding-mode' is set to - ;; non-nil. - (let ((elt (assq 'folding-mode minor-mode-map-alist))) - ;; Always remove old map before adding new definitions. - (if elt - (setq minor-mode-map-alist - (delete elt minor-mode-map-alist))) - (push (cons 'folding-mode folding-mode-map) minor-mode-map-alist)) - ;; Update minor-mode-alist - (or (assq 'folding-mode minor-mode-alist) - (push '(folding-mode folding-mode-string) minor-mode-alist)) - ;; Needed for XEmacs - (or (fboundp 'buffer-disable-undo) - (fset 'buffer-disable-undo (symbol-function 'buffer-flush-undo)))) - -(defun folding-uninstall-keymaps () - "Uninstall keymaps." - (let ((elt (assq 'folding-mode minor-mode-map-alist))) - (if elt - (setq minor-mode-map-alist - (delete elt minor-mode-map-alist))) - (if (setq elt (assq 'folding-mode minor-mode-alist)) - (setq minor-mode-alist - (delete elt minor-mode-alist))) - (folding-uninstall-hooks))) - -(defun folding-install (&optional uninstall) - "Install or UNINSTALL folding." - (interactive "P") - (cond - (uninstall - (folding-uninstall-keymaps) - (folding-uninstall-hooks)) - (t - (folding-install-keymaps)))) - -(defun folding-uninstall () - "Uninstall folding." - (interactive) - (folding-install 'uninstall) - ;; Unwrap all buffers. - (dolist (buffer (buffer-list)) - (with-current-buffer buffer - (goto-char (point-min)) - (when (or folding-mode - ;; To be sure, check this at the same time - ;; Somebody may have just done - ;; (setq folding-mode nil), which is bad thing. - ;; Setting variable won't restore the buffer. - (re-search-forward "{{{" nil t)) - (turn-off-folding-mode))))) - -;;}}} -;;{{{ code: misc - -(defsubst folding-get-mode-marks (&optional mode) - "Return fold markers for MODE. default is for current `major-mode'. - -Return: - \(beg-marker end-marker\)" - (interactive) - (let* (elt) - (unless (setq elt (assq (or mode major-mode) - folding-mode-marks-alist)) - (error "Folding error: mode is not in `folding-mode-marks-alist'")) - (list (nth 1 elt) (nth 2 elt) (nth 3 elt)))) - -(defun folding-region-has-folding-marks-p (beg end) - "Check is there is fold mark in region BEG END." - (save-excursion - (goto-char beg) - (when (memq (folding-mark-look-at) '(1 11)) - (goto-char end) - (memq (folding-mark-look-at) '(end end-in))))) - -;;; - Thumb rule: because "{{{" if more meaningful, all returns values -;;; are of type integerp if it is found. -;;; -(defun folding-mark-look-at (&optional mode) - "Check status of current line. Does it contain a fold mark?. - -MODE - - 'move move over fold mark - -Return: - - 0 1 numberp, line has fold begin mark - 0 = closed, 1 = open, - 11 = open, we're inside fold, and this is top marker - - 'end end mark - - 'end-in end mark, inside fold, floor marker - - nil no fold marks .." - (let* (case-fold-search - (marks (folding-get-mode-marks)) - (stack folding-stack) - (bm (regexp-quote (nth 0 marks))) ;begin mark - (em (concat "^[ \t\n]*" (regexp-quote (nth 1 marks)))) - (bm-re (concat - (concat "^[ \t\n]*" bm) - (if (and nil - (string= - " " (substring (nth 0 marks) - (length (nth 1 marks))))) - ;; Like "}}} *" - "*" - ""))) - ret - point) - (save-excursion - (beginning-of-line) - (cond - ((looking-at bm-re) - (setq point (point)) - (cond - ((looking-at (concat "^[ \t\n]*" bm "[^\r\n]*\r")) ;; closed - (setq ret 0)) - (t ;; open fold marker - (goto-char (point-min)) - (cond - ((and stack ;; we're inside fold - ;; allow spaces - (looking-at (concat "[ \t\n]*" bm))) - (setq ret 11)) - (t - (setq ret 1)))))) - ((looking-at em) - (setq point (point)) - ;; - The stack is a list if we've entered inside fold. There - ;; is no text after fold END mark - ;; - At bol ".*\n[^\n]*" doesn't work but "\n[^\n]*" at eol does?? - (cond - ((progn - (end-of-line) - (or (and stack (eobp)) ;normal ending - (and stack ;empty newlines only, no text ? - (not (looking-at "\n[^ \t\n]*"))))) - (setq ret 'end-in)) - (t ;all rest are newlines - (setq ret 'end)))))) - (cond - ((and mode point) - (goto-char point) - ;; This call breaks if there is no marks on the point, - ;; because there is no parameter 'nil t' in call. - ;; --> there is error in this function if that happens. - (beginning-of-line) - (re-search-forward (concat bm "\\|" em)) - (backward-char 1))) - ret)) - -(defsubst folding-mark-look-at-top-mark-p () - "Check if line contain folding top marker." - (integerp (folding-mark-look-at))) - -(defsubst folding-mark-look-at-bottom-mark-p () - "Check if line contain folding bottom marker." - (symbolp (folding-mark-look-at))) - -(defun folding-act (action &optional event) - "Execute logical ACTION based on EVENT. - -References: - `folding-behave-table'" - (let* ((elt (assoc action folding-behave-table))) - (if elt - (funcall (nth 1 elt) event) - (error "Folding mode (folding-act): Unknown action %s" action)))) - -(defun folding-region-open-close (beg end &optional close) - "Open all folds inside region BEG END. Close if optional CLOSE is non-nil." - (interactive "r\nP") - (let* ((func (if (null close) - 'folding-show-current-entry - 'folding-hide-current-entry)) - tmp) - (save-excursion - ;; make sure the beg is first. - (if (> beg end) ;swap order - (setq tmp beg beg end end tmp)) - (goto-char beg) - (while (and - ;; the folding-show-current-entry/hide will move point - ;; to beg-of-line So we must move to the end of - ;; line to continue search. - (if (and close - (eq 0 (folding-mark-look-at))) ;already closed ? - t - (funcall func) - (end-of-line) - t) - (folding-next-visible-heading) - (< (point) end)))))) - -(defun fold-marks-kill () - "If over fold, open fold and kill beginning and end fold marker. -Return t ot nil if marks were removed." - (interactive) - (if (not (folding-mark-look-at)) - (when (called-interactively-p 'interactive) - (message "Folding: Cursor not over fold. Can't remove fold marks.") - nil) - (destructuring-bind (beg end) - (folding-show-current-entry) - (let ((kill-whole-line t)) - ;; must be done in this order, because point moves after kill. - (goto-char end) - (beginning-of-line) - (kill-line) - (goto-char beg) - (beginning-of-line) - (kill-line) - ;; Return status - t)))) - -(defun folding-hide-current-subtree () - "Call `folding-show-current-subtree' with argument 'hide." - (interactive) - (folding-show-current-subtree 'hide)) - -(defun folding-show-current-subtree (&optional hide) - "Show or HIDE all folds inside current fold. -Point must be over beginning fold mark." - (interactive "P") - (let* ((stat (folding-mark-look-at 'move)) - (beg (point)) - end) - (cond - ((memq stat '(0 1 11)) ;It's BEG fold - (when (eq 0 stat) ;it was closed - (folding-show-current-entry) - (goto-char beg)) ;folding-pick-move needs point at fold - (save-excursion - (if (folding-pick-move) - (setq end (point)))) - (if (and beg end) - (folding-region-open-close beg end hide))) - (t - (if (called-interactively-p 'interactive) - (message "point is not at fold beginning.")))))) - -(defun folding-display-name () - "Show current active fold name." - (interactive) - (let* ((pos (folding-find-folding-mark)) - name) - (when pos - (save-excursion - (goto-char pos) - (if (looking-at ".*[{]+") ;Drop "{" mark away. - (setq pos (match-end 0))) - (setq name (buffer-substring - pos - (progn - (end-of-line) - (point)))))) - (if name - (message (format "fold:%s" name))))) - -;;}}} -;;{{{ code: events - -(defun folding-event-posn (act event) - "According to ACT read mouse EVENT struct and return data from it. -Event must be simple click, no dragging. - -ACT - 'mouse-point return the 'mouse cursor' point - 'window return window pointer - 'col-row return list (col row)" - (cond - ((not folding-xemacs-p) - ;; short Description of FSF mouse event - ;; - ;; EVENT : (mouse-3 (#<window 34 on *scratch*> 128 (20 . 104) -23723628)) - ;; event-start : (#<window 34 on *scratch*> 128 (20 . 104) -23723628)) - ;; ^^^MP - ;; mp = mouse point - (let* ((el (funcall (symbol-function 'event-start) event))) - (cond - ((eq act 'mouse-point) - (nth 1 el)) ;is there macro for this ? - ((eq act 'window) - (funcall (symbol-function 'posn-window) el)) - ((eq act 'col-row) - (funcall (symbol-function 'posn-col-row) el)) - (t - (error "Unknown request %s" act))))) - (folding-xemacs-p - (cond - ((eq act 'mouse-point) - (funcall (symbol-function 'event-point) event)) - ((eq act 'window) - (funcall (symbol-function 'event-window) event)) - ;; Must be tested! (However, it's not used...) - ((eq act 'col-row) - (list (funcall (symbol-function 'event-x) event) - (funcall (symbol-function 'event-y) event))) - (t - (error "Unknown request %s" act)))) - (t - (error "This version of Emacs can't handle events.")))) - -(defmacro folding-interactive-spec-p () - "Preserve region during `interactive'. -In XEmacs user could also set `zmacs-region-stays'." - (if folding-xemacs-p - ;; preserve selected region - `'(interactive "_p") - `'(interactive "p"))) - -(defmacro folding-mouse-yank-at-p () - "Check if user use \"yank at mouse point\" feature. - -Please see the variable `folding-mouse-yank-at-point'." - 'folding-mouse-yank-at-point) - -(defun folding-mouse-point (&optional event) - "Return mouse's working point. Optional EVENT is mouse click. -When used on XEmacs, return nil if no character was under the mouse." - (if (or (folding-mouse-yank-at-p) - (null event)) - (point) - (folding-event-posn 'mouse-point event))) - -;;}}} - -;;{{{ code: hook - -(defmacro folding-find-file-hook () - "Return hook symbol for current version." - `(if (boundp 'find-file-hook) - 'find-file-hook - 'find-file-hooks)) - -(defmacro folding-write-file-hook () - "Return hook symbol for current version." - `(if (boundp 'write-file-functions) - 'write-file-functions - 'write-file-hooks)) - -(defun folding-is-hooked () - "Check if folding hooks are installed." - (and (memq 'folding-mode-write-file - (symbol-value (folding-write-file-hook))) - (memq 'folding-mode-find-file - (symbol-value (folding-find-file-hook))))) - -;;;###autoload -(defun folding-uninstall-hooks () - "Remove hooks set by folding." - (turn-off-folding-mode) - (remove-hook 'finder-mode-hook 'folding-mode) - (remove-hook 'write-file-hooks 'folding-mode-write-file) - (remove-hook 'find-file-hooks 'folding-mode-find-file)) - -;;;###autoload -(defun folding-install-hooks () - "Install folding hooks." - (folding-mode-add-find-file-hook) - (add-hook 'finder-mode-hook 'folding-mode) - (or (memq 'folding-mode-write-file (symbol-value (folding-write-file-hook))) - (add-hook (folding-write-file-hook) 'folding-mode-write-file 'end))) - -;;;###autoload -(defun folding-keep-hooked () - "Make sure hooks are in their places." - (unless (folding-is-hooked) - (folding-uninstall-hooks) - (folding-install-hooks))) - -;;}}} -;;{{{ code: Mouse handling - -(defun folding-mouse-call-original (&optional event) - "Execute original mouse function using mouse EVENT. - -Do nothing if original function does not exist. - -Does nothing when called by a function which has earlier been called -by us. - -Sets global: - `folding-calling-original'" - (interactive "@e") ;; Was "e" - ;; Without the following test we could easily end up in a endless - ;; loop in case we would call a function which would call us. - ;; - ;; (An easy constructed example is to bind the function - ;; `folding-mouse-context-sensitive' to the same mouse button both in - ;; `folding-mode-map' and in the global map.) - (if folding-calling-original - nil - ;; `folding-calling-original' is global - (setq folding-calling-original t) - (unwind-protect - (progn - (or event - (setq event last-input-event)) - (let (mouse-key) - (cond - ((not folding-xemacs-p) - (setq mouse-key (make-vector 1 (car-safe event)))) - (folding-xemacs-p - (setq mouse-key - (vector - (append - (event-modifiers event) - (list (intern - (format "button%d" - (funcall - (symbol-function 'event-button) - event)))))))) - (t - (error "This version of Emacs can't handle events."))) - ;; Test string: http://www.csd.uu.se/~andersl - ;; andersl A T csd uu se - ;; (I have `ark-goto-url' bound to the same key as - ;; this function.) - ;; - ;; turn off folding, so that we can see the real - ;; function behind it. - ;; - ;; We have to restore the current buffer, otherwise the - ;; let* won't be able to restore the old value of - ;; folding-mode. In my environment, I have bound a - ;; function which starts mail when I click on an e-mail - ;; address. When returning, the current buffer has - ;; changed. - (let* ((folding-mode nil) - (orig-buf (current-buffer)) - (orig-func (key-binding mouse-key))) - ;; call only if exist - (when orig-func - ;; Check if the original function has arguments. If - ;; it does, call it with the event as argument. - (unwind-protect - (progn - (setq this-command orig-func) - (call-interactively orig-func)) -;;; #untested, but included here for further reference -;;; (cond -;;; ((not (string-match "mouse" (symbol-name orig-func))) -;;; (call-interactively orig-func)) -;;; ((string-match "^mouse" (symbol-name orig-func)) -;;; (funcall orig-func event)) -;;; (t -;;; ;; Some other package's mouse command, -;;; ;; should we do something special here for -;;; ;; somebody? -;;; (funcall orig-func event))) - (set-buffer orig-buf)))))) - ;; This is always executed, even if the above generates an error. - (setq folding-calling-original nil)))) - -(defun folding-mouse-context-sensitive (event) - "Perform some operation depending on the context of the mouse pointer. -EVENT is mouse event. - -The variable `folding-behave-table' contains a mapping between contexts and -operations to perform. - -The following contexts can be handled (They are named after the -natural operation to perform on them): - - open - A folded fold. - close - An open fold, which isn't the one current topmost one. - up - The topmost visible fold. - other - Anything else. - -Note that the `pointer' can be either the buffer point, or the mouse -pointer depending in the setting of the user option -`folding-mouse-yank-at-point'." - (interactive "e") - (let* ( ;; - Get mouse cursor point, or point - (point (folding-mouse-point event)) - state) - (if (null point) - ;; The user didn't click on any text. - (folding-act 'other event) - (save-excursion - (goto-char point) - (setq state (folding-mark-look-at))) - (cond - ((eq state 0) - (folding-act 'open event)) - ((eq state 1) - (folding-act 'close event)) - ((eq state 11) - (folding-act 'up event)) - ((eq 'end state) - (folding-act 'close)) - ((eq state 'end-in) - (folding-act 'up event)) - (t - (folding-act 'other event)))))) - -;;; FIXME: #not used, the pick move handles this too -(defun folding-mouse-move (event) - "Move down if sitting on fold mark using mouse EVENT. - -Original function behind the mouse is called if no FOLD action wasn't -taken." - (interactive "e") - (let* ( ;; - Get mouse cursor point, or point - (point (folding-mouse-point event)) - state) - (save-excursion - (goto-char point) - (beginning-of-line) - (setq state (folding-mark-look-at))) - (cond - ((not (null state)) - (goto-char point) - (folding-next-visible-heading) t) - (t - (folding-mouse-call-original event))))) - -(defun folding-mouse-pick-move (event) - "Pick movement if sitting on beg/end fold mark using mouse EVENT. -If mouse if at the `beginning-of-line' point, then always move up. - -Original function behind the mouse is called if no FOLD action wasn't -taken." - (interactive "e") - (let* ( ;; - Get mouse cursor point, or point - (point (folding-mouse-point event)) - state) - (save-excursion - (goto-char point) - (setq state (folding-mark-look-at))) - (cond - ((not (null state)) - (goto-char point) - (if (= point - (save-excursion (beginning-of-line) (point))) - (folding-previous-visible-heading) - (folding-pick-move))) - (t - (folding-mouse-call-original event))))) - -;;}}} -;;{{{ code: engine - -(defun folding-set-mode-line () - "Update modeline with fold level." - (if (null folding-stack) - (kill-local-variable 'folding-mode-string) - (make-local-variable 'folding-mode-string) - (setq folding-mode-string - (if (eq 'folded (car folding-stack)) - (concat - folding-inside-string "1" folding-inside-mode-name) - (concat - folding-inside-string - (int-to-string (length folding-stack)) - folding-inside-mode-name))))) - -(defun folding-clear-stack () - "Clear the fold stack, and release all the markers it refers to." - (let ((stack folding-stack)) - (setq folding-stack nil) - (while (and stack (not (eq 'folded (car stack)))) - (set-marker (car (car stack)) nil) - (set-marker (cdr (car stack)) nil) - (setq stack (cdr stack))))) - -(defun folding-check-if-folding-allowed () - "Return non-nil when buffer allowed to be folded automatically. -When buffer is loaded it may not be desirable to fold it immediately, -because the file may be too large, or it may contain fold marks, that -really are not _real_ folds. (Eg. RMAIL saved files may have the -marks) - -This function returns t, if it's okay to proceed checking the fold status -of file. Returning nil means that folding should not touch this file. - -The variable `folding-check-allow-folding-function' normally contains this -function. Change the variable to use your own scheme." - - (or (let ((file (get 'find-file-noselect 'folding))) - ;; When a file reference is "pushed" is a C-h v buffer that says: - ;; test is a Lisp function in `~/foo/tmp/test.el' A flag gets set - ;; (see adviced code) and we must not fold this buffer, because - ;; it will be immediately searched. - (and file - (not (string-match (regexp-quote file) - (or buffer-file-name ""))))) - ;; Do not fold these files - (null (string-match folding-mode-hook-no-regexp (buffer-name))))) - -(defun folding-mode-find-file () - "One of the funcs called whenever a `find-file' is successful. -It checks to see if `folded-file' has been set as a buffer-local -variable, and automatically starts Folding mode if it has. - -This allows folded files to be automatically folded when opened. - -To make this hook effective, the symbol `folding-mode-find-file-hook' -should be placed at the end of `find-file-hooks'. If you have -some other hook in the list, for example a hook to automatically -uncompress or decrypt a buffer, it should go earlier on in the list. - -See also `folding-mode-add-find-file-hook'." - (let* ((check-fold folding-check-folded-file-function) - (allow-fold folding-check-allow-folding-function)) - ;; Turn mode on only if it's allowed - (if (funcall allow-fold) - (or (and (and check-fold (funcall check-fold)) - (folding-mode 1)) - (and (assq 'folded-file (buffer-local-variables)) - folded-file - (folding-mode 1) - (kill-local-variable 'folded-file))) - ;; In all other cases, unfold buffer. - (if folding-mode - (folding-mode -1))))) - -;;;###autoload -(defun folding-mode-add-find-file-hook () - "Append `folding-mode-find-file-hook' to the list `find-file-hooks'. - -This has the effect that afterwards, when a folded file is visited, if -appropriate Emacs local variable entries are recognized at the end of -the file, Folding mode is started automatically. - -If `inhibit-local-variables' is non-nil, this will not happen regardless -of the setting of `find-file-hooks'. - -To declare a file to be folded, put `folded-file: t' in the file's -local variables. eg., at the end of a C source file, put: - -/* -Local variables: -folded-file: t -*/ - -The local variables can be inside a fold." - (interactive) - (or (memq 'folding-mode-find-file (symbol-value (folding-find-file-hook))) - (add-hook (folding-find-file-hook) 'folding-mode-find-file 'end))) - -(defun folding-mode-write-file () - "Folded files must be controlled by folding before saving. -This function turns on the folding mode if it is not activated. -It prevents 'binary pollution' upon save." - (let* ((check-func folding-check-folded-file-function) - (no-re folding-mode-hook-no-regexp) - (bn (or (buffer-name) ""))) - (if (and (not (string-match no-re bn)) - (boundp 'folding-mode) - (null folding-mode) - (and check-func (funcall check-func))) - (progn - ;; When folding mode is turned on it also 'folds' whole - ;; buffer... can't avoid that, since it's more important - ;; to save safely - (folding-mode 1))) - ;; hook returns nil, good habit - nil)) - -(defun folding-check-folded () - "Function to determine if this file is in folded form." - (let* ( ;; Could use folding-top-regexp , folding-bottom-regexp , - ;; folding-regexp But they are not available at load time. - (folding-re1 "^.?.?.?{{{") - (folding-re2 "[\r\n].*}}}")) - (save-excursion - (goto-char (point-min)) - ;; If we found both, we assume file is folded - (and (re-search-forward folding-re1 nil t) - ;; if file is folded, there are \r's - (search-forward "\r" nil t) - (re-search-forward folding-re2 nil t))))) - -;;}}} - -;;{{{ code: Folding mode - -(defun folding-font-lock-keywords (&optional mode) - "Return folding font-lock keywords for MODE." - ;; Add support mode-by-mode basis. Check if mode is already - ;; handled from the property list. - (destructuring-bind (beg end ignore) - (folding-get-mode-marks (or mode major-mode)) - ;; `ignore' is not used, add no-op for byte compiler - (or ignore - (setq ignore t)) - (setq beg (concat "^[ \t]*" (regexp-quote beg) "[^\r\n]+")) - (setq end (concat "^[ \t]*" (regexp-quote end))) - (list - ;; the `t' says to overwrite any previous highlight. - ;; => Needed because folding marks are in comments. - (list beg 0 folding-font-lock-begin-mark t) - (list end 0 folding-font-lock-end-mark t)))) - -(defun folding-font-lock-support-instantiate (&optional mode) - "Add fold marks with `font-lock-add-keywords'." - (or mode - (setq mode major-mode)) - ;; Hide function from Byte Compiler. - (let ((function 'font-lock-add-keywords)) - (when (fboundp function) - (funcall function - mode - (folding-font-lock-keywords mode)) - ;; In order to see new keywords font lock must be restarted. - (dolist (buffer (buffer-list)) - (with-current-buffer buffer - (when (and (eq major-mode mode) - (or font-lock-mode - (and (boundp 'global-font-lock-mode) - global-font-lock-mode))) - ;; FIXME: Crude fix. should we use font-lock-fontify-buffer instead? - (font-lock-mode -1) - (font-lock-mode 1))))))) - -(defun folding-font-lock-support () - "Add font lock support." - (let ((list (get 'folding-mode 'font-lock))) - (unless (memq major-mode list) - ;; Support added, update known list - (push major-mode list) - (put 'folding-mode 'font-lock list) - (folding-font-lock-support-instantiate major-mode)))) - -(defun folding-set-local-variables () - "Set local fold mark variables. -If you're going to change the beginning and end mark in -`folding-mode-marks-alist'; you must call this function." - (set (make-local-variable 'folding-stack) nil) - (make-local-variable 'folding-top-mark) - (make-local-variable 'folding-secondary-top-mark) - (make-local-variable 'folding-top-regexp) - (make-local-variable 'folding-bottom-mark) - (make-local-variable 'folding-bottom-regexp) - (make-local-variable 'folding-regexp) - (or (and (boundp 'folding-top-regexp) - folding-top-regexp - (boundp 'folding-bottom-regexp) - folding-bottom-regexp) - (let ((folding-marks (assq major-mode - folding-mode-marks-alist))) - (if folding-marks - (setq folding-marks (cdr folding-marks)) - (setq folding-marks '("{{{" "}}}"))) - (apply 'folding-set-marks folding-marks)))) - -;;;###autoload -(defun turn-off-folding-mode () - "Turn off folding." - (folding-mode -1)) - -;;;###autoload -(defun turn-on-folding-mode () - "Turn on folding." - (folding-mode 1)) - -;;;###autoload -(defun folding-mode (&optional arg inter) - "A folding-editor-like minor mode. ARG INTER. - -These are the basic commands that Folding mode provides: - -\\{folding-mode-map} - -Keys starting with `folding-mode-prefix-key' - -\\{folding-mode-prefix-map} - - folding-convert-buffer-for-printing: - `\\[folding-convert-buffer-for-printing]' - Makes a ready-to-print, formatted, unfolded copy in another buffer. - - Read the documentation for the above functions for more information. - -Overview - - Folds are a way of hierarchically organizing the text in a file, so - that the text can be viewed and edited at different levels. It is - similar to Outline mode in that parts of the text can be hidden from - view. A fold is a region of text, surrounded by special \"fold marks\", - which act like brackets, grouping the text. Fold mark pairs can be - nested, and they can have titles. When a fold is folded, the text is - hidden from view, except for the first line, which acts like a title - for the fold. - - Folding mode is a minor mode, designed to cooperate with many other - major modes, so that many types of text can be folded while they are - being edited (eg., plain text, program source code, Texinfo, etc.). - -Folding-mode function - - If Folding mode is not called interactively (`(called-interactively-p 'interactive)' is nil), - and it is called with two or less arguments, all of which are nil, then - the point will not be altered if `folding-folding-on-startup' is set - and `folding-whole-buffer' is called. This is generally not a good - thing, as it can leave the point inside a hidden region of a fold, but - it is required if the local variables set \"mode: folding\" when the - file is first read (see `hack-local-variables'). - - Not that you should ever want to, but to call Folding mode from a - program with the default behavior (toggling the mode), call it with - something like `(folding-mode nil t)'. - -Fold marks - - For most types of folded file, lines representing folds have \"{{{\" - near the beginning. To enter a fold, move the point to the folded line - and type `\\[folding-shift-in]'. You should no longer be able to see - the rest of the file, just the contents of the fold, which you couldn't - see before. You can use `\\[folding-shift-out]' to leave a fold, and - you can enter and exit folds to move around the structure of the file. - - All of the text is present in a folded file all of the time. It is just - hidden. Folded text shows up as a line (the top fold mark) with \"...\" - at the end. If you are in a fold, the mode line displays \"inside n - folds Narrow\", and because the buffer is narrowed you can't see outside - of the current fold's text. - - By arranging sections of a large file in folds, and maybe subsections - in sub-folds, you can move around a file quickly and easily, and only - have to scroll through a couple of pages at a time. If you pick the - titles for the folds carefully, they can be a useful form of - documentation, and make moving though the file a lot easier. In - general, searching through a folded file for a particular item is much - easier than without folds. - -Managing folds - - To make a new fold, set the mark at one end of the text you want in the - new fold, and move the point to the other end. Then type - `\\[folding-fold-region]'. The text you selected will be made into a - fold, and the fold will be entered. If you just want a new, empty fold, - set the mark where you want the fold, and then create a new fold there - without moving the point. Don't worry if the point is in the middle of - a line of text, `folding-fold-region' will not break text in the middle - of a line. After making a fold, the fold is entered and the point is - positioned ready to enter a title for the fold. Do not delete the fold - marks, which are usually something like \"{{{\" and \"}}}\". There may - also be a bit of fold mark which goes after the fold title. - - If the fold markers get messed up, or you just want to see the whole - unfolded file, use `\\[folding-open-buffer]' to unfolded the whole - file, so you can see all the text and all the marks. This is useful for - checking/correcting unbalanced fold markers, and for searching for - things. Use `\\[folding-whole-file]' to fold the buffer again. - - `folding-shift-out' will attempt to tidy the current fold just before - exiting it. It will remove any extra blank lines at the top and bottom, - \(outside the fold marks). It will then ensure that fold marks exists, - and if they are not, will add them (after asking). Finally, the number - of blank lines between the fold marks and the contents of the fold is - set to 1 (by default). - -Folding package customizations - - If the fold marks are not set on entry to Folding mode, they are set to - a default for current major mode, as defined by - `folding-mode-marks-alist' or to \"{{{ \" and \"}}}\" if none are - specified. - - To bind different commands to keys in Folding mode, set the bindings in - the keymap `folding-mode-map'. - - The hooks `folding-mode-hook' and `<major-mode-name>-folding-hook' are - called before folding the buffer and applying the key bindings in - `folding-mode-map'. This is a good hook to set extra or different key - bindings in `folding-mode-map'. Note that key bindings in - `folding-mode-map' are only examined just after calling these hooks; - new bindings in those maps only take effect when Folding mode is being - started. The hook `folding-load-hook' is called when Folding mode is - loaded into Emacs. - -Mouse behavior - - If you want folding to detect point of actual mouse click, please see - variable `folding-mouse-yank-at-p'. - - To customise the mouse actions, look at `folding-behave-table'." - (interactive) - - (let ((new-folding-mode - (if (not arg) - (not folding-mode) - (> (prefix-numeric-value arg) 0)))) - (or (eq new-folding-mode - folding-mode) - (if folding-mode - (progn - ;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ progn ^^^ - ;; turn off folding - (if (null (folding-use-overlays-p)) - (setq selective-display nil)) - (folding-clear-stack) - (folding-narrow-to-region nil nil) - (folding-subst-regions (list 1 (point-max)) ?\r ?\n) - - ;; Restore "%n" (Narrow) in the mode line - (setq mode-line-format - (mapcar - (function - (lambda (item) - (if (equal item 'folding-narrow-placeholder) - "%n" item))) - mode-line-format))) - ;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ else ^^^ - (cond - ((folding-use-overlays-p) - ;; This may be Emacs specific; how about XEmacs? - ;; - ;; make line-move-ignore-invisible buffer local, matches - ;; outline.el, and the 21 pre-release gets upset if this is - ;; defined globally in shell buffer... - (make-local-variable 'line-move-ignore-invisible) - (setq line-move-ignore-invisible t - buffer-invisibility-spec '((t . t)))) - (t - (setq selective-display t) - (setq selective-display-ellipses t))) - (unless (assq 'folding-mode minor-mode-alist) - ;; User has not run folding-install or he did call - ;; folding-uninstall which completely wiped package out. - ;; => anyway now he calls us, so be there for him - (folding-install)) - (folding-keep-hooked) ;set hooks if not there - (widen) - (setq folding-narrow-overlays nil) - (folding-set-local-variables) - (folding-font-lock-support) - (unwind-protect - (let ((hook-symbol (intern-soft - (concat - (symbol-name major-mode) - "-folding-hook")))) - (run-hooks 'folding-mode-hook) - (and hook-symbol - (run-hooks hook-symbol))) - (folding-set-mode-line)) - (and folding-folding-on-startup - (if (or (called-interactively-p 'interactive) - arg - inter) - (folding-whole-buffer) - (save-excursion - (folding-whole-buffer)))) - (folding-narrow-to-region nil nil t) - ;; Remove "%n" (Narrow) from the mode line - (setq mode-line-format - (mapcar - (function - (lambda (item) - (if (equal item "%n") - 'folding-narrow-placeholder item))) - mode-line-format)))) - (setq folding-mode new-folding-mode) - (if folding-mode - (easy-menu-add folding-mode-menu) - (easy-menu-remove folding-mode-menu)))) - -;;}}} -;;{{{ code: setting fold marks - -;; You think those "\\(\\)" pairs are peculiar? Me too. Emacs regexp -;; stuff has a bug; sometimes "\\(.*\\)" fails when ".*" succeeds, but -;; only in a folded file! Strange bug! Must check it out sometime. - -(defun folding-set-marks (top bottom &optional secondary) - "Set the folding top and bottom mark for the current buffer. - -Input: - - TOP The topmost fold mark. Comment start + fold begin string. - BOTTOM The bottom fold mark Comment end + fold end string. - SECONDARY Usually the comment end indicator for the mode. This - is inserted by `folding-fold-region' after the fold top mark, - and is presumed to be put after the title of the fold. - -Example: - - html-mode: - - top: \"<!-- [[[ \" - bot: \"<!-- ]]] -->\" - sec: \" -->\" - -Notice that the top marker needs to be closed with SECONDARY comment end string. - -Various regular expressions are set with this function, so don't set the -mark variables directly." - (set (make-local-variable 'folding-top-mark) - top) - (set (make-local-variable 'folding-bottom-mark) - bottom) - (set (make-local-variable 'folding-secondary-top-mark) - secondary) - (set (make-local-variable 'folding-top-regexp) - (concat "\\(^\\|\r+\\)[ \t]*" - (regexp-quote folding-top-mark))) - (set (make-local-variable 'folding-bottom-regexp) - (concat "\\(^\\|\r+\\)[ \t]*" - (regexp-quote folding-bottom-mark))) - (set (make-local-variable 'folding-regexp) - (concat "\\(^\\|\r\\)\\([ \t]*\\)\\(\\(" - (regexp-quote folding-top-mark) - "\\)\\|\\(" - (regexp-quote folding-bottom-mark) - "[ \t]*\\(\\)\\($\\|\r\\)\\)\\)"))) - -;;}}} -;;{{{ code: movement - -(defun folding-next-visible-heading (&optional direction) - "Move up/down fold headers. -Backward if DIRECTION is non-nil returns nil if not moved = no next marker." - (interactive) - (let* ((begin-mark (nth 0 (folding-get-mode-marks))) - case-fold-search) - (if direction - (re-search-backward (concat "^" (regexp-quote begin-mark)) nil t) - (re-search-forward (concat "^" (regexp-quote begin-mark)) nil t)))) - -(defun folding-previous-visible-heading () - "Move upward fold headers." - (interactive) - (beginning-of-line) - (folding-next-visible-heading 'backward)) - -(defun folding-find-folding-mark (&optional end-fold) - "Search backward to find beginning fold. Skips subfolds. -Optionally searches forward to find END-FOLD mark. - -Return: - - nil - point position of fold mark" - (let* (case-fold-search - (elt (folding-get-mode-marks)) - (bm (regexp-quote (nth 0 elt))) ; markers defined for mode - (em (regexp-quote (nth 1 elt))) ; markers defined for mode - (re (concat "^" bm "\\|^" em)) - (count 0) - stat - moved) - (save-excursion - (cond - (end-fold - (folding-end-of-line) - ;; We must skip over inner folds - (while (and (null moved) - (re-search-forward re nil t)) - (setq stat (folding-mark-look-at)) - (cond - ((symbolp stat) - (setq count (1- count)) - (if (< count 0) ;0 or less means no middle folds - (setq moved t))) - ((memq stat '(1 11)) ;BEG fold - (setq count (1+ count))))) ;; end while - (when moved - (forward-char -3) - (setq moved (point)))) - (t - (while (and (null moved) - (re-search-backward re nil t)) - (setq stat (folding-mark-look-at)) - (cond - ((memq stat '(1 11)) - (setq count (1- count)) - (if (< count 0) ;0 or less means no middle folds - (setq moved (point)))) - ((symbolp stat) - (setq count (1+ count))))) - (when moved ;What's the result - (forward-char 3) - (setq moved (point)))))) - moved)) - -(defun folding-pick-move () - "Pick the logical movement on fold mark. -If at the end of fold, then move to the beginning and vice versa. - -If placed over closed fold moves to the next fold. When no next -folds are visible, stops moving. - -Return: - t if moved" - (interactive) - (let* (case-fold-search - (elt (folding-get-mode-marks)) - (bm (nth 0 elt)) ; markers defined for mode - (stat (folding-mark-look-at)) - moved) - (cond - ((eq 0 stat) ;closed fold - (when (re-search-forward (concat "^" (regexp-quote bm)) nil t) - (setq moved t) - (forward-char 3))) - ((symbolp stat) ;End fold - (setq moved (folding-find-folding-mark))) - ((integerp stat) ;Beg fold - (setq moved (folding-find-folding-mark 'end-fold)))) - (if (integerp moved) - (goto-char moved)) - moved)) - -;;; Idea by Scott Evans <gse A T antisleep com> -(defun folding-context-next-action () - "Take next action according to point and context. -If point is at: - - Begin Fold : toggle open - close - End Fold : close - inside : fold current level." - (interactive) - (let ((state (folding-mark-look-at))) - (cond - ((eq state 0) - (folding-act 'open)) - ((eq state 1) - (folding-act 'close)) - ((eq state 11) - (folding-act 'up)) - ((eq 'end state) - (folding-act 'close)) - ((eq state 'end-in) - (folding-act 'up)) - (t - (folding-act 'other))))) - -(defun folding-forward-char-1 (&optional arg) - "See `folding-forward-char-1' for ARG." - (if (eq arg 1) - ;; Do it a faster way for arg = 1. - (if (eq (following-char) ?\r) - (let ((saved (point)) - (inhibit-quit t)) - (end-of-line) - (if (not (eobp)) - (forward-char) - (goto-char saved) - (error "End of buffer"))) - ;; `forward-char' here will do its own error if (eobp). - (forward-char)) - (if (> 0 (or arg (setq arg 1))) - (folding-backward-char (- arg)) - (let (goal saved) - (while (< 0 arg) - (skip-chars-forward "^\r" (setq goal (+ (point) arg))) - (if (eq goal (point)) - (setq arg 0) - (if (eobp) - (error "End of buffer") - (setq arg (- goal 1 (point)) - saved (point)) - (let ((inhibit-quit t)) - (end-of-line) - (if (not (eobp)) - (forward-char) - (goto-char saved) - (error "End of buffer")))))))))) - -(defmacro folding-forward-char-macro () - `(defun folding-forward-char (&optional arg) - "Move point right ARG characters, skipping hidden folded regions. -Moves left if ARG is negative. On reaching end of buffer, stop and -signal error." - ,(folding-interactive-spec-p) - ;; (folding-preserve-active-region) - (folding-forward-char-1 arg))) - -(folding-forward-char-macro) - -(defun folding-backward-char-1 (&optional arg) - "See `folding-backward-char-1' for ARG." - (if (eq arg 1) - ;; Do it a faster way for arg = 1. - ;; Catch the case where we are in a hidden region, and bump into a \r. - (if (or (eq (preceding-char) ?\n) - (eq (preceding-char) ?\r)) - (let ((pos (1- (point))) - (inhibit-quit t)) - (forward-char -1) - (beginning-of-line) - (skip-chars-forward "^\r" pos)) - (forward-char -1)) - (if (> 0 (or arg (setq arg 1))) - (folding-forward-char (- arg)) - (let (goal) - (while (< 0 arg) - (skip-chars-backward "^\r\n" (max (point-min) - (setq goal (- (point) arg)))) - (if (eq goal (point)) - (setq arg 0) - (if (bobp) - (error "Beginning of buffer") - (setq arg (- (point) 1 goal) - goal (point)) - (let ((inhibit-quit t)) - (forward-char -1) - (beginning-of-line) - (skip-chars-forward "^\r" goal))))))))) - -(defmacro folding-backward-char-macro () - `(defun folding-backward-char (&optional arg) - "Move point right ARG characters, skipping hidden folded regions. -Moves left if ARG is negative. On reaching end of buffer, stop and -signal error." - ,(folding-interactive-spec-p) - ;; (folding-preserve-active-region) - (folding-backward-char-1 arg))) - -(folding-backward-char-macro) - -(defmacro folding-end-of-line-macro () - `(defun folding-end-of-line (&optional arg) - "Move point to end of current line, but before hidden folded region. -ARG is line count. - -Has the same behavior as `end-of-line', except that if the current line -ends with some hidden folded text (represented by an ellipsis), the -point is positioned just before it. This prevents the point from being -placed inside the folded text, which is not normally useful." - ,(folding-interactive-spec-p) - ;;(interactive "p") - ;; (folding-preserve-active-region) - (if (or (eq arg 1) - (not arg)) - (beginning-of-line) - ;; `forward-line' also moves point to beginning of line. - (forward-line (1- arg))) - (skip-chars-forward "^\r\n"))) - -(folding-end-of-line-macro) - -(defun folding-skip-ellipsis-backward () - "Move the point backwards out of folded text. - -If the point is inside a folded region, the cursor is displayed at the -end of the ellipsis representing the folded part. This function checks -to see if this is the case, and if so, moves the point backwards until -it is just outside the hidden region, and just before the ellipsis. - -Returns t if the point was moved, nil otherwise." - (interactive) - (let ((pos (point)) - result) - (save-excursion - (beginning-of-line) - (skip-chars-forward "^\r" pos) - (or (eq pos (point)) - (setq pos (point) - result t))) - (goto-char pos) - result)) - -;;}}} - -;;{{{ code: Moving in and out of folds - -;;{{{ folding-shift-in - -(defun folding-shift-in (&optional noerror) - "Open and enter the fold at or around the point. - -Enters the fold that the point is inside, wherever the point is inside -the fold, provided it is a valid fold with balanced top and bottom -marks. Returns nil if the fold entered contains no sub-folds, t -otherwise. If an optional argument NOERROR is non-nil, returns nil if -there are no folds to enter, instead of causing an error. - -If the point is inside a folded, hidden region (as represented by an -ellipsis), the position of the point in the buffer is preserved, and as -many folds as necessary are entered to make the surrounding text -visible. This is useful after some commands eg., search commands." - (interactive) - (labels - ((open-fold nil - (let ((data (folding-show-current-entry noerror t))) - (and data - (progn - (when folding-narrow-by-default - (setq folding-stack - (if folding-stack - (cons (cons (point-min-marker) - (point-max-marker)) - folding-stack) - '(folded))) - (folding-set-mode-line)) - (folding-narrow-to-region - (car data) - (nth 1 data))))))) - (let ((goal (point))) - (while (folding-skip-ellipsis-backward) - (beginning-of-line) - (open-fold) - (goto-char goal)) - (if folding-narrow-by-default - (open-fold) - (widen))))) - -;;}}} -;;{{{ folding-shift-out - -(defun folding-shift-out (&optional event) - "Exits the current fold with EVENT." - (interactive) - (if folding-stack - (progn - (folding-tidy-inside) - (cond - ((folding-use-overlays-p) - (folding-subst-regions - (list (overlay-end (car folding-narrow-overlays)) - (overlay-start (cdr folding-narrow-overlays))) ?\n ?\r) - ;; So point is correct in other windows. - (goto-char (overlay-end (car folding-narrow-overlays)))) - (t - (folding-subst-regions (list (point-min) (point-max)) ?\n ?\r) - ;; So point is correct in other window - (goto-char (point-min)))) - - (if (eq (car folding-stack) 'folded) - (folding-narrow-to-region nil nil t) - (folding-narrow-to-region - (marker-position (car (car folding-stack))) - (marker-position (cdr (car folding-stack))) t)) - (and (consp (car folding-stack)) - (set-marker (car (car folding-stack)) nil) - (set-marker (cdr (car folding-stack)) nil)) - (setq folding-stack (cdr folding-stack))) - (error "Outside all folds")) - (folding-set-mode-line)) - -;;}}} -;;{{{ folding-show-current-entry - -(defun folding-show-current-entry (&optional event noerror noskip) - "Opens the fold that the point is on, but does not enter it. -EVENT and optional arg NOERROR means don't signal an error if there is -no fold, just return nil. NOSKIP means don't jump out of a hidden -region first. - -Returns ((START END SUBFOLDS-P). START and END indicate the extents of -the fold that was shown. If SUBFOLDS-P is non-nil, the fold contains -subfolds." - (interactive) - (or noskip - (folding-skip-ellipsis-backward)) - (let ((point (point)) - backward - forward - start - end - subfolds-not-p) - (unwind-protect - (or (and (integerp - (car-safe (setq backward (folding-skip-folds t)))) - (integerp - (car-safe (setq forward (folding-skip-folds nil)))) - (progn - (goto-char (car forward)) - (skip-chars-forward "^\r\n") - (setq end (point)) - (skip-chars-forward "\r\n") - (not (and folding-stack (eobp)))) - (progn - (goto-char (car backward)) - (skip-chars-backward "^\r\n") - (setq start (point)) - (skip-chars-backward "\r\n") - (not (and folding-stack (bobp)))) - (progn - (setq point start) - ;; Avoid holding the list through a GC. - (setq subfolds-not-p - (not (or (cdr backward) - (cdr forward)))) - (folding-subst-regions - (append backward (nreverse forward)) - ?\r ?\n) - ;; FIXME: this should be moved to font-lock: - ;; - When fold is closed, the whole line (with code) - ;; is treated as comment - ;; - Fon-lock changes all fonts to `font-lock-comment-face' - ;; - When you again open fold, all text is in color - ;; - ;; => Font lock should stop at \r, and not use ".*" - ;; which includes \r character - ;; This is a workaround, not an efficient one - (if (or (and (boundp 'global-font-lock-mode) - global-font-lock-mode) - font-lock-mode) - (font-lock-fontify-region start end)) - (list start end (not subfolds-not-p)))) - (if noerror - nil - (error "Not on a fold"))) - (goto-char point)))) - -;;}}} -;;{{{ folding-hide-current-entry - -(defun folding-toggle-enter-exit () - "Run `folding-shift-in' or `folding-shift-out'. -This depends on current line's contents." - (interactive) - (beginning-of-line) - (let ((current-line-mark (folding-mark-look-at))) - (if (and (numberp current-line-mark) - (= current-line-mark 0)) - (folding-shift-in) - (folding-shift-out)))) - -(defun folding-toggle-show-hide () - "Run folding-show-current-entry or folding-hide-current-entry depending on current line's contents." - (interactive) - (beginning-of-line) - (let ((current-line-mark (folding-mark-look-at))) - (if (and (numberp current-line-mark) - (= current-line-mark 0)) - (folding-show-current-entry) - (folding-hide-current-entry)))) - -(defun folding-hide-current-entry (&optional event) - "Close the fold around the point using EVENT. -Undo effect of `folding-show-current-entry'." - (interactive) - (folding-skip-ellipsis-backward) - (let (start end) - (if (and (integerp (setq start (car-safe (folding-skip-folds t)))) - (integerp (setq end (car-safe (folding-skip-folds nil))))) - (if (and folding-stack - (or (eq start (point-min)) - (eq end (point-max)))) - ;;(error "Cannot hide current fold") - (folding-shift-out) - (goto-char start) - (skip-chars-backward "^\r\n") - (folding-subst-regions (list start end) ?\n ?\r)) - (error "Not on a fold")))) - -;;}}} -;;{{{ folding-show-all - -(defun folding-show-all () - "Exits all folds, to the top level." - (interactive) - (while folding-stack - (folding-shift-out))) - -;;}}} -;;{{{ folding-goto-line - -(defun folding-goto-line (line) - "Go to LINE, entering as many folds as possible." - (interactive "NGoto line: ") - (folding-show-all) - (goto-char 1) - (and (< 1 line) - (re-search-forward "[\n\C-m]" nil 0 (1- line))) - (let ((goal (point))) - (while (prog2 (beginning-of-line) - (folding-shift-in t) - (goto-char goal)))) - (folding-narrow-to-region - (and folding-narrow-by-default (point-min)) - (point-max) t)) - -;;}}} - -;;}}} -;;{{{ code: Searching for fold boundaries - -;;{{{ folding-skip-folds - -(defun folding-skip-folds (backward &optional outside) - "Skips forward through the buffer (backward if BACKWARD is non-nil) -until it finds a closing fold mark or the end of the buffer. The -point is not moved. Jumps over balanced folding-mark pairs on the way. -Returns t if the end of buffer was found in an unmatched folding-mark -pair, otherwise a list. - -If the point is actually on an fold start mark, the mark is ignored; -if it is on an end mark, the mark is noted. This decision is -reversed if BACKWARD is non-nil. If optional OUTSIDE is non-nil and -BACKWARD is nil, either mark is noted. - -The first element of the list is a position in the end of the closing -fold mark if one was found, or nil. It is followed by (END START) -pairs (flattened, not a list of pairs). The pairs indicating the -positions of folds skipped over; they are positions in the fold -marks, not necessarily at the ends of the fold marks. They are in -the opposite order to that in which they were skipped. The point is -left in a meaningless place. If going backwards, the pairs are -\(START END) pairs, as the fold marks are scanned in the opposite -order. - -Works by maintaining the position of the top and bottom marks found -so far. They are found separately using a normal string search for -the fixed part of a fold mark (because it is faster than a regexp -search if the string does not occur often outside of fold marks), -checking that it really is a proper fold mark, then considering the -earliest one found. The position of the other (if found) is -maintained to avoid an unnecessary search at the next iteration." - (let ((first-mark (if backward folding-bottom-mark folding-top-mark)) - (last-mark (if backward folding-top-mark folding-bottom-mark)) - (top-re folding-top-regexp) - (depth 0) - pairs point - temp - start - first - last - case-fold-search) - ;; Ignore trailing space? - (when nil - (when (and (stringp first-mark) - (string-match "^\\(.*[^ ]+\\) +$" first-mark)) - (setq first-mark (match-string 1 first-mark))) - (when (and (stringp last-mark) - (string-match "^\\(.*[^ ]+\\) +$" last-mark)) - (setq last-mark (match-string 1 last-mark))) - (when (and (stringp top-re) - (string-match "^\\(.*[^ ]+\\) +$" top-re)) - (setq top-re (match-string 1 top-re)))) - (save-excursion - (skip-chars-backward "^\r\n") - (unless outside - (and (eq (preceding-char) ?\r) - (forward-char -1)) - (if (looking-at top-re) - (if backward - (setq last (match-end 1)) - (skip-chars-forward "^\r\n")))) - (while (progn - ;; Find last first, prevents unnecessary searching - ;; for first. - (setq point (point)) - (or last - (while (and (if backward - (search-backward last-mark first t) - (search-forward last-mark first t)) - (progn - (setq temp (point)) - (goto-char (match-beginning 0)) - (skip-chars-backward " \t") - (and (not - (setq last - (if (eq (preceding-char) ?\r) - temp - (and (bolp) temp)))) - (goto-char temp))))) - (goto-char point)) - (or first - (while (and (if backward - (search-backward first-mark last t) - (search-forward first-mark last t)) - (progn - (setq temp (point)) - (goto-char (match-beginning 0)) - (skip-chars-backward " \t") - (and (not - (setq first - (if (eq (preceding-char) ?\r) - temp - (and (bolp) temp)))) - (goto-char temp)))))) - ;; Return value of conditional says whether to - ;; iterate again. - (if (not last) - ;; Return from this with the result. - (not (setq pairs (if first t (cons nil pairs)))) - (if (and first - (if backward - (> first last) - (< first last))) - (progn - (goto-char first) - (if (eq 0 depth) - (setq start first - first nil - depth 1) ;; non-nil value, loop again. - (setq first nil - ;; non-nil value => loop again - depth (1+ depth)))) - (goto-char last) - (if (eq 0 depth) - (not (setq pairs (cons last pairs))) - (or (< 0 (setq depth (1- depth))) - (setq pairs (cons last (cons start pairs)))) - (setq last nil) - t))))) - pairs))) - -;;}}} - -;;}}} -;;{{{ code: Functions that actually modify the buffer - -;;{{{ folding-fold-region - -(defun folding-fold-region (start end) - "Places fold mark at the beginning and end of a specified region. -The region is specified by two arguments START and END. The point is -left at a suitable place ready to insert the title of the fold. - -The fold markers are intended according to mode." - (interactive "r") - (and (< end start) - (setq start (prog1 end - (setq end start)))) - (setq end (set-marker (make-marker) end)) - (goto-char start) - (beginning-of-line) - (setq start (point)) - (insert-before-markers folding-top-mark) - ;; XEmacs latex-mode, after (tex-site), indents the whole - ;; fold 50 characters right. Don't do that. - (unless (string-match "latex" (symbol-name major-mode)) - (indent-according-to-mode)) - (let ((saved-point (point))) - (and folding-secondary-top-mark - (insert-before-markers folding-secondary-top-mark)) - (insert-before-markers ?\n) - (goto-char (marker-position end)) - (set-marker end nil) - (and (not (bolp)) - (eq 0 (forward-line)) - (eobp) - (insert ?\n)) - (insert folding-bottom-mark) - (unless (string-match "latex" (symbol-name major-mode)) - (indent-according-to-mode)) - (insert ?\n) - (setq folding-stack (if folding-stack - (cons (cons (point-min-marker) - (point-max-marker)) - folding-stack) - '(folded))) - (folding-narrow-to-region start (1- (point))) - (goto-char saved-point) - (folding-set-mode-line)) - (save-excursion (folding-tidy-inside))) - -;;}}} -;;{{{ folding-tidy-inside - -;; Note to self: The long looking code for checking and modifying those -;; blank lines is to make sure the text isn't modified unnecessarily. -;; Don't remove it again! - -(defun folding-tidy-inside () - "Add or remove blank lines at the top and bottom of the current fold. -Also adds fold marks at the top and bottom (after asking), if they are not -there already. The amount of space left depends on the variable -`folding-internal-margins', which is one by default." - (interactive) - (if buffer-read-only nil - (let () -;;; (top-re (if (string-match "^\\(.*\\) $" folding-top-mark) -;;; (match-string 1 folding-top-mark) -;;; folding-top-mark)) - (if (folding-use-overlays-p) - (goto-char (- (overlay-end (car folding-narrow-overlays)) 1)) - (goto-char (point-min))) - (and (eolp) - (progn (skip-chars-forward "\n\t ") - (delete-region (point-min) (point)))) - (and (if (let (case-fold-search) (folding-mark-look-at-top-mark-p)) - (progn (forward-line 1) - (and (eobp) (insert ?\n)) - t) - (and (y-or-n-p "Insert missing folding-top-mark? ") - (progn (insert (concat folding-top-mark - "<Replaced missing fold top mark>" - (or folding-secondary-top-mark "") - "\n")) - t))) - folding-internal-margins - (<= 0 folding-internal-margins) - (let* ((p1 (point)) - (p2 (progn (skip-chars-forward "\n") (point))) - (p3 (progn (skip-chars-forward "\n\t ") - (skip-chars-backward "\t " p2) (point)))) - (if (eq p2 p3) - (or (eq p2 (setq p3 (+ p1 folding-internal-margins))) - (if (< p2 p3) - (newline (- p3 p2)) - (delete-region p3 p2))) - (delete-region p1 p3) - (or (eq 0 folding-internal-margins) - (newline folding-internal-margins))))) - (if (folding-use-overlays-p) - (goto-char (overlay-start (cdr folding-narrow-overlays))) - (goto-char (point-max))) - (and (bolp) - (progn (skip-chars-backward "\n") - (delete-region (point) (point-max)))) - (beginning-of-line) - (and (or (let (case-fold-search) (folding-mark-look-at-bottom-mark-p)) - (progn (goto-char (point-max)) nil) - (and (y-or-n-p "Insert missing folding-bottom-mark? ") - (progn - (insert (concat "\n" folding-bottom-mark)) - (beginning-of-line) - t))) - folding-internal-margins - (<= 0 folding-internal-margins) - (let* ((p1 (point)) - (p2 (progn (skip-chars-backward "\n") (point))) - (p3 (progn (skip-chars-backward "\n\t ") - (skip-chars-forward "\t " p2) (point)))) - (if (eq p2 p3) - (or (eq p2 (setq p3 (- p1 1 folding-internal-margins))) - (if (> p2 p3) - (newline (- p2 p3)) - (delete-region p2 p3))) - (delete-region p3 p1) - (newline (1+ folding-internal-margins)))))))) - -;;}}} - -;;}}} -;;{{{ code: Operations on the whole buffer - -;;{{{ folding-whole-buffer - -(defun folding-whole-buffer () - "Folds every fold in the current buffer. -Fails if the fold markers are not balanced correctly. - -If the buffer is being viewed in a fold, folds are repeatedly exited to -get to the top level first (this allows the folds to be tidied on the -way out). The buffer modification flag is not affected, and this -function will work on read-only buffers." - - (interactive) - (message "Folding buffer...") - (let ((narrow-min (point-min)) - (narrow-max (point-max)) - folding-list) - (save-excursion - (widen) - (goto-char 1) - (setq folding-list (folding-skip-folds nil t)) - (narrow-to-region narrow-min narrow-max) - (and (eq t folding-list) - (error - "Cannot fold whole buffer -- unmatched begin-fold mark `%s' `%s'" - (current-buffer) - folding-top-mark)) - (and (integerp (car folding-list)) - (error - "Cannot fold whole buffer -- extraneous end-fold mark `%s' `%s'" - (current-buffer) - folding-bottom-mark)) - (folding-show-all) - (widen) - (goto-char 1) - ;; Do the modifications forwards. - (folding-subst-regions (nreverse (cdr folding-list)) ?\n ?\r)) - (beginning-of-line) - (folding-narrow-to-region nil nil t) - (message "Folding buffer... done"))) - -;;}}} -;;{{{ folding-open-buffer - -(defun folding-open-buffer () - "Unfolds the entire buffer, leaving the point where it is. -Does not affect the buffer-modified flag, and can be used on read-only -buffers." - (interactive) - (message "Unfolding buffer...") - (folding-clear-stack) - (folding-set-mode-line) - (unwind-protect - (progn - (widen) - (folding-subst-regions (list 1 (point-max)) ?\r ?\n)) - (folding-narrow-to-region nil nil t)) - (message "Unfolding buffer... done")) - -;;}}} -;;{{{ folding-convert-buffer-for-printing - -(defun folding-convert-buffer-for-printing (&optional buffer pre-title post-title pad) - "Remove folds from a buffer, for printing. - -It copies the contents of the (hopefully) folded buffer BUFFER into a -buffer called `*Unfolded: <Original-name>*', removing all of the fold -marks. It keeps the titles of the folds, however, and numbers them. -Subfolds are numbered in the form 5.1, 5.2, 5.3 etc., and the titles are -indented to eleven characters. - -It accepts four arguments. BUFFER is the name of the buffer to be -operated on, or a buffer. nil means use the current buffer. PRE-TITLE -is the text to go before the replacement fold titles, POST-TITLE is the -text to go afterwards. Finally, if PAD is non-nil, the titles are all -indented to the same column, which is eleven plus the length of -PRE-TITLE. Otherwise just one space is placed between the number and -the title." - (interactive (list (read-buffer "Remove folds from buffer: " - (buffer-name) - t) - (read-string "String to go before enumerated titles: ") - (read-string "String to go after enumerated titles: ") - (y-or-n-p "Pad section numbers with spaces? "))) - (set-buffer (setq buffer (get-buffer buffer))) - (setq pre-title (or pre-title "") - post-title (or post-title "")) - (or folding-mode - (error "Must be in Folding mode before removing folds")) - (let* ((new-buffer (get-buffer-create (concat "*Unfolded: " - (buffer-name buffer) - "*"))) - (section-list '(1)) - (section-prefix-list '("")) - - (secondary-mark-length (length folding-secondary-top-mark)) - - (secondary-mark folding-secondary-top-mark) - (mode major-mode) - - ;; [jari] Aug 14 1997 - ;; Regexp doesn't allow "footer text" like, so we add one more - ;; regexp to loosen the end criteria - ;; - ;; {{{ Subsubsection 1 - ;; }}} Subsubsection 1 - ;; - ;; was: (regexp folding-regexp) - ;; - (regexp - (concat "\\(^\\|\r\\)\\([ \t]*\\)\\(\\(" - (regexp-quote folding-top-mark) - "\\)\\|\\(" - (regexp-quote folding-bottom-mark) - "[ \t]*.*\\(\\)\\($\\|\r\\)\\)\\)")) - title - prefix) - ;; was obsolete function: (buffer-flush-undo new-buffer) - (buffer-disable-undo new-buffer) - (save-excursion - (set-buffer new-buffer) - (delete-region (point-min) - (point-max))) - (save-restriction - (widen) - (copy-to-buffer new-buffer (point-min) (point-max))) - (display-buffer new-buffer t) - (set-buffer new-buffer) - (subst-char-in-region (point-min) (point-max) ?\r ?\n) - (funcall mode) - (while (re-search-forward regexp nil t) - (if (match-beginning 4) - (progn - (goto-char (match-end 4)) - - ;; - Move after start fold and read the title from there - ;; - Then move back and kill the fold mark - ;; - (setq title - (buffer-substring (point) - (progn (end-of-line) - (point)))) - (delete-region (save-excursion - (goto-char (match-beginning 4)) - (skip-chars-backward "\n\r") - (point)) - (progn - (skip-chars-forward "\n\r") - (point))) - (and (<= secondary-mark-length - (length title)) - (string-equal secondary-mark - (substring title - (- secondary-mark-length))) - (setq title (substring title - 0 - (- secondary-mark-length)))) - (setq section-prefix-list - (cons (setq prefix (concat (car section-prefix-list) - (int-to-string (car section-list)) - ".")) - section-prefix-list)) - (or (cdr section-list) - (insert ?\n)) - (setq section-list (cons 1 - (cons (1+ (car section-list)) - (cdr section-list)))) - (setq title (concat prefix - (if pad - (make-string - (max 2 (- 8 (length prefix))) ? ) - " ") - title)) - (message "Reformatting: %s%s%s" - pre-title - title - post-title) - (insert "\n\n" - pre-title - title - post-title - "\n\n")) - (goto-char (match-beginning 5)) - (or (setq section-list (cdr section-list)) - (error "Too many bottom-of-fold marks")) - - (setq section-prefix-list (cdr section-prefix-list)) - (delete-region (point) - (progn - (forward-line 1) - (point))))) - (and (cdr section-list) - (error - "Too many top-of-fold marks -- reached end of file prematurely")) - (goto-char (point-min)) - (buffer-enable-undo) - (set-buffer-modified-p nil) - (message "All folds reformatted."))) - -;;}}} -;;}}} - -;;{{{ code: Standard fold marks for various major modes - -;;{{{ A function to set default marks, `folding-add-to-marks-list' - -(defun folding-add-to-marks-list (mode top bottom - &optional secondary noforce message) - "Add/set fold mark list for a particular major mode. -When called interactively, asks for a `major-mode' name, and for -fold marks to be used in that mode. It adds the new set to -`folding-mode-marks-alist', and if the mode name is the same as the current -major mode for the current buffer, the marks in use are also changed. - -If called non-interactively, arguments are MODE, TOP, BOTTOM and -SECONDARY. MODE is the symbol for the major mode for which marks are -being set. TOP, BOTTOM and SECONDARY are strings, the three fold marks -to be used. SECONDARY may be nil (as opposed to the empty string), but -the other two must be non-empty strings, and is an optional argument. - -Two other optional arguments are NOFORCE, meaning do not change the -marks if marks are already set for the specified mode if non-nil, and -MESSAGE, which causes a message to be displayed if it is non-nil. This -is also the message displayed if the function is called interactively. - -To set default fold marks for a particular mode, put something like the -following in your .emacs: - -\(folding-add-to-marks-list 'major-mode \"(** {{{ \" \"(** }}} **)\" \" **)\") - -Look at the variable `folding-mode-marks-alist' to see what default settings -already apply. - -`folding-set-marks' can be used to set the fold marks in use in the current -buffer without affecting the default value for a particular mode." - (interactive - (let* ((mode (completing-read - (concat "Add fold marks for major mode (" - (symbol-name major-mode) - "): ") - obarray - (function - (lambda (arg) - (and (commandp arg) - (string-match "-mode\\'" - (symbol-name arg))))) - t)) - (mode (if (equal mode "") - major-mode - (intern mode))) - (object (assq mode folding-mode-marks-alist)) - (old-top (and object - (nth 1 object))) - top - (old-bottom (and object - (nth 2 object))) - bottom - (secondary (and object - (nth 3 object))) - (prompt "Top fold marker: ")) - (and (equal secondary "") - (setq secondary nil)) - (while (not top) - (setq top (read-string prompt (or old-top "{{{ "))) - (and (equal top "") - (setq top nil))) - (setq prompt (concat prompt - top - ", Bottom marker: ")) - (while (not bottom) - (setq bottom (read-string prompt (or old-bottom "}}}"))) - (and (equal bottom "") - (setq bottom nil))) - (setq prompt (concat prompt - bottom - (if secondary - ", Secondary marker: " - ", Secondary marker (none): ")) - secondary (read-string prompt secondary)) - (and (equal secondary "") - (setq secondary nil)) - (list mode top bottom secondary nil t))) - (let ((object (assq mode folding-mode-marks-alist))) - (if (and object - noforce - message) - (message "Fold markers for `%s' are already set." - (symbol-name mode)) - (if object - (or noforce - (setcdr object (if secondary - (list top bottom secondary) - (list top bottom)))) - (setq folding-mode-marks-alist - (cons (if secondary - (list mode top bottom secondary) - (list mode top bottom)) - folding-mode-marks-alist))) - (and message - (message "Set fold marks for `%s' to \"%s\" and \"%s\"." - (symbol-name mode) - (if secondary - (concat top "name" secondary) - (concat top "name")) - bottom) - (and (eq major-mode mode) - (folding-set-marks top bottom secondary)))))) - -;;}}} -;;{{{ Set some useful default fold marks - -(folding-add-to-marks-list 'ada-mode "-- {{{" "-- }}}" nil t) -(folding-add-to-marks-list 'asm-mode "; {{{" "; }}}" nil t) -(folding-add-to-marks-list 'awk-mode "# {{{" "# }}}" nil t) -(folding-add-to-marks-list 'Bison-mode "/* {{{" "/* }}} */" " */" t) -(folding-add-to-marks-list 'LaTeX-mode "%{{{" "%}}}" nil t) -(folding-add-to-marks-list 'TeX-mode "%{{{" "%}}}" nil t) -(folding-add-to-marks-list 'bibtex-mode "%{{{" "%}}} */" nil t) -(folding-add-to-marks-list 'bison-mode "/* {{{" "/* }}} */" " */" t) -(folding-add-to-marks-list 'c++-mode "// {{{" "// }}}" nil t) -(folding-add-to-marks-list 'c-mode "/* {{{" "/* }}} */" " */" t) -(folding-add-to-marks-list 'dcl-mode "! {{{" "! }}}" nil t) -(folding-add-to-marks-list 'change-log-mode "{{{" "}}}" nil t) -(folding-add-to-marks-list 'cperl-mode "# {{{" "# }}}" nil t) -(folding-add-to-marks-list 'emacs-lisp-mode ";;{{{" ";;}}}" nil t) -(folding-add-to-marks-list 'erlang-mode "%%{{{" "%%}}}" nil t) -(folding-add-to-marks-list 'finder-mode "{{{" "}}}" nil t) -(folding-add-to-marks-list 'fortran-mode "! {{{" "! }}}" nil t) -(folding-add-to-marks-list 'f90-mode "! {{{" "! }}}" nil t) -(folding-add-to-marks-list 'generic-mode ";# " ";\$" nil t) -(folding-add-to-marks-list 'gofer-mode "-- {{{" "-- }}}" nil t) -(folding-add-to-marks-list 'html-mode "<!-- {{{ " "<!-- }}} -->" " -->" t) -(folding-add-to-marks-list 'icon-mode "# {{{" "# }}}" nil t) -(folding-add-to-marks-list 'indented-text-mode "{{{" "}}}" nil t) -(folding-add-to-marks-list 'java-mode "// {{{" "// }}}" nil t) -(folding-add-to-marks-list 'javascript-mode "// {{{" "// }}}" nil t) -(folding-add-to-marks-list 'jde-mode "// {{{" "// }}}" nil t) -(folding-add-to-marks-list 'ksh-mode "# {{{" "# }}}" nil t) -(folding-add-to-marks-list 'latex-mode "%{{{" "%}}}" nil t) -(folding-add-to-marks-list 'lisp-interaction-mode ";;{{{" ";;}}}" nil t) -(folding-add-to-marks-list 'lisp-mode ";;{{{" ";;}}}" nil t) -(folding-add-to-marks-list 'm4-mode "# {{{" "# }}}" nil t) -(folding-add-to-marks-list 'makefile-mode "# {{{" "# }}}" nil t) -(folding-add-to-marks-list 'matlab-mode "%%%{{{" "%%%}}}" nil t) -(folding-add-to-marks-list 'meta-mode "% {{{" "% }}}" nil t) -(folding-add-to-marks-list 'ml-mode "(* {{{" "(* }}} *)" " *)" t) -(folding-add-to-marks-list 'modula-2-mode "(* {{{" "(* }}} *)" " *)" t) -(folding-add-to-marks-list 'nroff-mode "\\\\ {{{" "\\\\ }}}" nil t) -(folding-add-to-marks-list 'occam-mode "-- {{{" "-- }}}" nil t) -(folding-add-to-marks-list 'orwell-mode "{{{" "}}}" nil t) -(folding-add-to-marks-list 'pascal-mode "{ ((( " "{ ))) }" " }" t) -(folding-add-to-marks-list 'php-mode "// {{{" "// }}}" nil t) -(folding-add-to-marks-list 'perl-mode "# {{{" "# }}}" nil t) -(folding-add-to-marks-list 'plain-TeX-mode "%{{{" "%}}}" nil t) -(folding-add-to-marks-list 'plain-tex-mode "%{{{" "%}}}" nil t) -(folding-add-to-marks-list 'prolog-mode "% {{{" "% }}}" nil t) -(folding-add-to-marks-list 'python-mode "# {{{" "# }}}" nil t) -(folding-add-to-marks-list 'rexx-mode "/* {{{" "/* }}} */" " */" t) -(folding-add-to-marks-list 'sh-mode "# {{{" "# }}}" nil t) -(folding-add-to-marks-list 'sh-script-mode "# {{{" "# }}}" nil t) -(folding-add-to-marks-list 'shellscript-mode "# {{{" "# }}}" nil t) -(folding-add-to-marks-list 'sgml-mode "<!-- [[[ " "<!-- ]]] -->" " -->" t) -(folding-add-to-marks-list 'simula-mode "! {{{" "! }}}" nil t) -(folding-add-to-marks-list 'sml-mode "(* {{{" "(* }}} *)" " *)" t) -(folding-add-to-marks-list 'sql-mode "-- {{{" "-- }}}" nil t) -(folding-add-to-marks-list 'tcl-mode "#{{{" "#}}}" nil t) -(folding-add-to-marks-list 'tex-mode "%{{{" "%}}}" nil t) -(folding-add-to-marks-list 'texinfo-mode "@c {{{" "@c {{{endfold}}}" " }}}" t) -(folding-add-to-marks-list 'text-mode "{{{" "}}}" nil t) -(folding-add-to-marks-list 'vhdl-mode "# {{{" "# }}}" nil t) -(folding-add-to-marks-list 'xerl-mode "%%{{{" "%%}}}" nil t) -(folding-add-to-marks-list 'xrdb-mode "! {{{" "! }}}" nil t) - -;; heavy shell-perl-awk programmer in fundamental-mode need # prefix... - -(folding-add-to-marks-list 'fundamental-mode "# {{{" "# }}}" nil t) - -;;}}} - -;;}}} - -;;{{{ code: Gross, crufty hacks that seem necessary - -;; ---------------------------------------------------------------------- -;; The functions here have been tested with Emacs 18.55, Emacs 18.58, -;; Epoch 4.0p2 (based on Emacs 18.58) and XEmacs 19.6. - -;; Note that XEmacs 19.6 can't do selective-display, and its -;; "invisible extents" don't work either, so Folding mode just won't -;; work with that version. - -;; They shouldn't do the wrong thing with later versions of Emacs, but -;; they might not have the special effects either. They may appear to -;; be excessive; that is not the case. All of the peculiar things these -;; functions do is done to avoid some side-effect of Emacs' internal -;; logic that I have met. Some of them work around bugs or unfortunate -;; (lack of) features in Emacs. In most cases, it would be better to -;; move this into the Emacs C code. - -;; Folding mode is designed to be simple to cooperate with as many -;; things as possible. These functions go against that principle at the -;; coding level, but make life for the user bearable. - -;;{{{ folding-subst-regions - -;; Substitute newlines for carriage returns or vice versa. -;; Avoid excessive file locking. - -;; Substitutes characters in the buffer, even in a read-only buffer. -;; Takes LIST, a list of regions specified as sequence in the form -;; (START1 END1 START2 END2 ...). In every region specified by each -;; pair, substitutes each occurence of character FIND by REPLACE. - -;; The buffer-modified flag is not affected, undo information is not -;; kept for the change, and the function works on read-only files. This -;; function is much more efficient called with a long sequence than -;; called for each region in the sequence. - -;; If the buffer is not modified when the function is called, the -;; modified-flag is set before performing all the substitutions, and -;; locking is temporarily disabled. This prevents Emacs from trying to -;; make then delete a lock file for *every* substitution, which slows -;; folding considerably, especially on a slow networked filesystem. -;; Without this, on my system, folding files on startup (and reading -;; other peoples' folded files) takes about five times longer. Emacs -;; still locks the file once for this call under those circumstances; I -;; can't think of a way around that, but it isn't really a problem. - -;; I consider these problems to be a bug in `subst-char-in-region'. - -(defun folding-subst-regions (list find replace) - "Substitute \\r and \\n using LIST FIND REPLACE." - (let ((buffer-read-only buffer-read-only) ;; Protect read-only flag. - (modified (buffer-modified-p)) - (font-lock-mode nil) - (lazy-lock-mode nil) - (overlay-p (folding-use-overlays-p)) - (ask1 (symbol-function 'ask-user-about-supersession-threat)) - (ask2 (symbol-function 'ask-user-about-lock))) - (if lazy-lock-mode ;; no-op: Byte compiler silencer - (setq lazy-lock-mode t)) - (unwind-protect - (progn - (setq buffer-read-only nil) - (or modified - (progn - (fset 'ask-user-about-supersession-threat - '(lambda (&rest x) nil)) - (fset 'ask-user-about-lock - '(lambda (&rest x) nil)) - (set-buffer-modified-p t))) ; Prevent file locking in the loop - (while list - (if overlay-p - (folding-flag-region (car list) (nth 1 list) (eq find ?\n)) - (subst-char-in-region (car list) (nth 1 list) find replace t)) - (setq list (cdr (cdr list))))) - ;; buffer-read-only is restored by the let. - ;; Don't want to change MODIFF time if it was modified before. - (or modified - (unwind-protect - (set-buffer-modified-p nil) - (fset 'ask-user-about-supersession-threat ask1) - (fset 'ask-user-about-lock ask2)))))) - -;;}}} -;;{{{ folding-narrow-to-region - -;; Narrow to region, without surprising displays. - -;; Similar to `narrow-to-region', but also adjusts window-start to be -;; the start of the narrowed region. If an optional argument CENTRE is -;; non-nil, the window-start is positioned to leave the point at the -;; centre of the window, like `recenter'. START may be nil, in which -;; case the function acts more like `widen'. - -;; Actually, all the window-starts for every window displaying the -;; buffer, as well as the last_window_start for the buffer are set. The -;; points in every window are set to the point in the current buffer. -;; All this logic is necessary to prevent the display getting really -;; weird occasionally, even if there is only one window. Try making -;; this function like normal `narrow-to-region' with a touch of -;; `recenter', then moving around lots of folds in a buffer displayed in -;; several windows. You'll see what I mean. - -;; last_window_start is set by making sure that the selected window is -;; displaying the current buffer, then setting the window-start, then -;; making the selected window display another buffer (which sets -;; last_window_start), then setting the selected window to redisplay the -;; buffer it displayed originally. - -;; Note that whenever window-start is set, the point cannot be moved -;; outside the displayed area until after a proper redisplay. If this -;; is possible, centre the display on the point. - -;; In Emacs 19; Epoch or XEmacs, searches all screens for all -;; windows. In Emacs 19, they are called "frames". - -(defun folding-narrow-to-region (&optional start end centre) - "Narrow to region START END, possibly CENTRE." - (let* ((the-window (selected-window)) - (selected-buffer (window-buffer the-window)) - (window-ring the-window) - (window the-window) - (point (point)) - (buffer (current-buffer)) - temp) - (unwind-protect - (progn - (unwind-protect - (progn - (if (folding-use-overlays-p) - (if start - (folding-narrow-aux start end t) - (folding-narrow-aux nil nil nil)) - (if start - (narrow-to-region start end) - (widen))) - - (setq point (point)) - (set-window-buffer window buffer) - - (while (progn - (and (eq buffer (window-buffer window)) - (if centre - (progn - (select-window window) - (goto-char point) - (vertical-motion - (- (lsh (window-height window) -1))) - (set-window-start window (point)) - (set-window-point window point)) - (set-window-start window (or start 1)) - (set-window-point window point))) - - (not (eq (setq window (next-window window nil t)) - window-ring))))) - nil ;; epoch screen - (select-window the-window)) ;; unwind-protect INNER - ;; Set last_window_start. - (unwind-protect - (if (not (eq buffer selected-buffer)) - (set-window-buffer the-window selected-buffer) - (if (get-buffer "*scratch*") - (set-window-buffer the-window (get-buffer "*scratch*")) - (set-window-buffer - the-window (setq temp (generate-new-buffer " *temp*")))) - (set-window-buffer the-window buffer)) - (and temp - (kill-buffer temp)))) - ;; Undo this side-effect of set-window-buffer. - (set-buffer buffer) - (goto-char (point))))) - -;;}}} - -;;}}} - -;;{{{ code: folding-end-mode-quickly - -(defun folding-end-mode-quickly () - "Replace all ^M's with linefeeds and widen a folded buffer. -Only has any effect if Folding mode is active. - -This should not in general be used for anything. It is used when changing -major modes, by being placed in kill-mode-tidy-alist, to tidy the buffer -slightly. It is similar to `(folding-mode 0)', except that it does not -restore saved keymaps etc. Repeat: Do not use this function. Its -behaviour is liable to change." - (and (boundp 'folding-mode) - (assq 'folding-mode - (buffer-local-variables)) - folding-mode - (progn - (if (folding-use-overlays-p) - (folding-narrow-to-region nil nil) - (widen)) - (folding-clear-stack) - (folding-subst-regions (list 1 (point-max)) ?\r ?\n)))) - -;;{{{ folding-eval-current-buffer-open-folds - -(defun folding-eval-current-buffer-open-folds (&optional printflag) - "Evaluate all of a folded buffer as Lisp code. -Unlike `eval-current-buffer', this function will evaluate all of a -buffer, even if it is folded. It will also work correctly on non-folded -buffers, so is a good candidate for being bound to a key if you program -in Emacs-Lisp. - -It works by making a copy of the current buffer in another buffer, -unfolding it and evaluating it. It then deletes the copy. - -Programs can pass argument PRINTFLAG which controls printing of output: -nil means discard it; anything else is stream for print." - (interactive) - (if (or (and (boundp 'folding-mode) - folding-mode)) - (let ((temp-buffer - (generate-new-buffer (buffer-name)))) - (message "Evaluating unfolded buffer...") - (save-restriction - (widen) - (copy-to-buffer temp-buffer 1 (point-max))) - (set-buffer temp-buffer) - (subst-char-in-region 1 (point-max) ?\r ?\n) - (let ((real-message-def (symbol-function 'message)) - (suppress-eval-message)) - (fset 'message - (function - (lambda (&rest args) - (setq suppress-eval-message t) - (fset 'message real-message-def) - (apply 'message args)))) - (unwind-protect - (eval-current-buffer printflag) - (fset 'message real-message-def) - (kill-buffer temp-buffer)) - (or suppress-eval-message - (message "Evaluating unfolded buffer... Done")))) - (eval-current-buffer printflag))) - -;;}}} - -;;}}} - -;;{{{ code: ISearch support, walks in and out of folds - -;; This used to be a package of it's own. -;; Requires Emacs 19 or XEmacs. Does not work under Emacs 18. - -;;{{{ Variables - -(defcustom folding-isearch-install t - "*When non-nil, the isearch commands will handle folds." - :type 'boolean - :group 'folding) - -(defvar folding-isearch-stack nil - "Temporary storage for `folding-stack' during isearch.") - -;; Lists of isearch commands to replace - -;; These do normal searching. - -(defvar folding-isearch-normal-cmds - '(isearch-repeat-forward - isearch-repeat-backward - isearch-toggle-regexp - isearch-toggle-case-fold - isearch-delete-char - isearch-abort - isearch-quote-char - isearch-other-control-char - isearch-other-meta-char - isearch-return-char - isearch-exit - isearch-printing-char - isearch-whitespace-chars - isearch-yank-word - isearch-yank-line - isearch-yank-kill - isearch-*-char - isearch-\|-char - isearch-mode-help - isearch-yank-x-selection - isearch-yank-x-clipboard) - "List if isearch commands doing normal search.") - -;; Enables the user to edit the search string - -;; Missing, present in XEmacs isearch-mode.el. Not necessary? -;; isearch-ring-advance-edit, isearch-ring-retreat-edit, isearch-complete-edit -;; isearch-nonincremental-exit-minibuffer, isearch-yank-x-selection, -;; isearch-yank-x-clipboard - -(defvar folding-isearch-edit-enter-cmds - '(isearch-edit-string - isearch-ring-advance - isearch-ring-retreat - isearch-complete) ; (Could also stay in search mode!) - "List of isearch commands which enters search string edit.") - -;; Continues searching after editing. - -(defvar folding-isearch-edit-exit-cmds - '(isearch-forward-exit-minibuffer ; Exits edit - isearch-reverse-exit-minibuffer - isearch-nonincremental-exit-minibuffer) - "List of isearch commands which exits search string edit.") - -;;}}} -;;{{{ Keymaps (an Isearch hook) - -(defvar folding-isearch-mode-map nil - "Modified copy of the isearch keymap.") - -;; Create local copies of the keymaps. The `isearch-mode-map' is -;; copied to `folding-isearch-mode-map' while `minibuffer-local-isearch-map' -;; is made local. (Its name is used explicitly.) -;; -;; Note: This is called every time the search is started. - -(defun folding-isearch-hook-function () - "Update the isearch keymaps for usage with folding mode." - (if (and (boundp 'folding-mode) folding-mode) - (let ((cmds (append folding-isearch-normal-cmds - folding-isearch-edit-enter-cmds - folding-isearch-edit-exit-cmds))) - (setq folding-isearch-mode-map (copy-keymap isearch-mode-map)) - (make-local-variable 'minibuffer-local-isearch-map) - ;; Make sure the destructive operations below doesn't alter - ;; the global instance of the map. - (setq minibuffer-local-isearch-map - (copy-keymap minibuffer-local-isearch-map)) - (setq folding-isearch-stack folding-stack) - (while cmds - (substitute-key-definition - (car cmds) - (intern (concat "folding-" (symbol-name (car cmds)))) - folding-isearch-mode-map) - (substitute-key-definition - (car cmds) - (intern (concat "folding-" (symbol-name (car cmds)))) - minibuffer-local-isearch-map) - (setq cmds (cdr cmds))) - ;; Install our keymap - (cond - (folding-xemacs-p - (let ((f 'set-keymap-name)) - (funcall f folding-isearch-mode-map 'folding-isearch-mode-map)) - ;; Later version of XEmacs (21.2+) use overriding-local-map - ;; for isearch keymap rather than fiddling with - ;; minor-mode-map-alist. This is so isearch keymaps take - ;; precedence over extent-local keymaps. We will support - ;; both ways here. Keymaps will be restored as side-effect - ;; of isearch-abort and isearch-quit - (cond - ;; if overriding-local-map is in use - ((and (boundp 'overriding-local-map) overriding-local-map) - (set-keymap-parent folding-isearch-mode-map overriding-local-map) - (setq overriding-local-map folding-isearch-mode-map)) - ;; otherwise fiddle with minor-mode-map-alist - (t - (setq minor-mode-map-alist - (cons (cons 'isearch-mode folding-isearch-mode-map) - (delq (assoc 'isearch-mode minor-mode-map-alist) - minor-mode-map-alist)))))) - ((boundp 'overriding-terminal-local-map) - (funcall (symbol-function 'set) - 'overriding-terminal-local-map folding-isearch-mode-map)) - ((boundp 'overriding-local-map) - (setq overriding-local-map folding-isearch-mode-map)))))) - -;; Undoes the `folding-isearch-hook-function' function. - -(defun folding-isearch-end-hook-function () - "Actions to perform at the end of isearch in folding mode." - (when (and (boundp 'folding-mode) folding-mode) - (kill-local-variable 'minibuffer-local-isearch-map) - (setq folding-stack folding-isearch-stack))) - -(when folding-isearch-install - (add-hook 'isearch-mode-hook 'folding-isearch-hook-function) - (add-hook 'isearch-mode-end-hook 'folding-isearch-end-hook-function)) - -;;}}} -;;{{{ Normal search routines - -;; Generate the replacement functions of the form: -;; (defun folding-isearch-repeat-forward () -;; (interactive) -;; (folding-isearch-general 'isearch-repeat-forward)) - -(let ((cmds folding-isearch-normal-cmds)) - (while cmds - (eval - `(defun ,(intern (concat "folding-" (symbol-name (car cmds)))) - nil - "Automatically generated" - (interactive) - (folding-isearch-general (quote ,(car cmds))))) - (setq cmds (cdr cmds)))) - -;; The HEART! Executes command and updates the foldings. -;; This is capable of detecting a `quit'. - -(defun folding-isearch-general (function) - "Execute isearch command FUNCTION and adjusts the folding." - (let* ((quit-isearch nil) - (area-beg (point-min)) - (area-end (point-max)) - pos) - (cond - (t - (save-restriction - (widen) - (condition-case nil - (funcall function) - (quit (setq quit-isearch t))) - (setq pos (point))) - ;; Situation - ;; o user has folded buffer - ;; o He manually narrows, say to function ! - ;; --> there is no fold marks at the beg/end --> this is not a fold - (condition-case nil - ;; "current mode has no fold marks..." - (folding-region-has-folding-marks-p area-beg area-end) - (error (setq quit-isearch t))) - (folding-goto-char pos))) - (if quit-isearch - (signal 'quit '(isearch))))) - -;;}}} -;;{{{ Edit search string support - -(defvar folding-isearch-current-buffer nil - "The buffer we are editing, so we can widen it when in minibuffer.") - -;; Functions which enters edit mode. - -(defun folding-isearch-edit-string () - "Replace `isearch-edit-string' when in `folding-mode'." - (interactive) - (folding-isearch-start-edit 'isearch-edit-string)) - -(defun folding-isearch-ring-advance () - "Replace `isearch-ring-advance' when in `folding-mode'." - (interactive) - (folding-isearch-start-edit 'isearch-ring-advance)) - -(defun folding-isearch-ring-retreat () - "Replace `isearch-ring-retreat' when in `folding-mode'." - (interactive) - (folding-isearch-start-edit 'isearch-ring-retreat)) - -(defun folding-isearch-complete () - "Replace `isearch-complete' when in `folding-mode'." - (interactive) - (folding-isearch-start-edit 'isearch-complete)) - -;; Start and wait for editing. When (funcall fnk) returns -;; we are back in interactive search mode. -;; -;; Store match data! - -(defun folding-isearch-start-edit (function) - "Edit with function FUNCTION." - (let (pos) - (setq folding-isearch-current-buffer (current-buffer)) - (save-restriction - (funcall function) - ;; Here, we are widened, by folding-isearch-*-exit-minibuffer. - (setq pos (point))) - (folding-goto-char pos))) - -;; Functions which exits edit mode. - -;; The `widen' below will be caught by the `save-restriction' above, thus -;; this will not cripple `folding-stack'. - -(defun folding-isearch-forward-exit-minibuffer () - "Replace `isearch-forward-exit-minibuffer' when in `folding-mode'." - (interactive) - ;; Make sure we can continue searching outside narrowing. - (save-excursion - (set-buffer folding-isearch-current-buffer) - (widen)) - (isearch-forward-exit-minibuffer)) - -(defun folding-isearch-reverse-exit-minibuffer () - "Replace `isearch-reverse-exit-minibuffer' when in `folding-mode'." - (interactive) - ;; Make sure we can continue searching outside narrowing. - (save-excursion - (set-buffer folding-isearch-current-buffer) - (widen)) - (isearch-reverse-exit-minibuffer)) - -(defun folding-isearch-nonincremental-exit-minibuffer () - "Replace `isearch-reverse-exit-minibuffer' when in `folding-mode'." - (interactive) - ;; Make sure we can continue searching outside narrowing. - (save-excursion - (set-buffer folding-isearch-current-buffer) - (widen)) - (isearch-nonincremental-exit-minibuffer)) - -;;}}} -;;{{{ Special XEmacs support - -;; In XEmacs, all isearch commands must have the property `isearch-command'. - -(if folding-xemacs-p - (let ((cmds (append folding-isearch-normal-cmds - folding-isearch-edit-enter-cmds - folding-isearch-edit-exit-cmds))) - (while cmds - (put (intern (concat "folding-" (symbol-name (car cmds)))) - 'isearch-command t) - (setq cmds (cdr cmds))))) - -;;}}} -;;{{{ General purpose function. - -(defun folding-goto-char (pos) - "Goto character POS, changing fold if necessary." - ;; Make sure POS is inside the visible area of the buffer. - (goto-char pos) - (if (eq pos (point)) ; Point inside narrowed area? - nil - (folding-show-all) ; Fold everything and goto top. - (goto-char pos)) - ;; Enter if point is folded. - (if (folding-point-folded-p pos) - (progn - (folding-shift-in) ; folding-shift-in can change the pos. - (setq folding-isearch-stack folding-stack) - (setq folding-stack '(folded)) - (goto-char pos)))) - -(defun folding-point-folded-p (pos) - "Non-nil when POS is not visible." - (if (folding-use-overlays-p) - (let ((overlays (overlays-at (point))) - (found nil)) - (while (and (not found) (overlayp (car overlays))) - (setq found (overlay-get (car overlays) 'fold) - overlays (cdr overlays))) - found) - (save-excursion - (goto-char pos) - (beginning-of-line) - (skip-chars-forward "^\r" pos) - (not (eq pos (point)))))) - -;;}}} - -;;}}} -;;{{{ code: Additional functions - -(defvar folding-comment-folding-table - '((c-mode - folding-comment-c-mode - folding-uncomment-c-mode)) - "Table of functions to comment and uncomment folds. -Function is called with two arguments: - - number start of fold mark - marker end of fold mark - -Function must return: - - (beg . end) start of fold, end of fold - -Table Format: - '((MAJOR-MODE COMMENT-FUNCTION UNCOMMENT-FUNCTION) ..)") - -(defun folding-insert-advertise-folding-mode () - "Insert Small text describing where to the get the folding at point. -This may be useful 'banner' to inform other people why your code -is formatted like it is and how to view it correctly." - (interactive) - (let* ((prefix "") - (re (or comment-start-skip - (and comment-start - (concat "^[ \t]*" comment-start "+[ \t]*"))))) - - (when re - (save-excursion - (beginning-of-line) - (when (or (re-search-forward re nil t) - (progn - (goto-char (point-min)) - (re-search-forward re nil t))) - (setq prefix (match-string 0))))) - - (beginning-of-line) - (dolist (line - (list - "File layout controlled by Emacs folding.el available at: " - folding-package-url-location)) - (insert "\n" prefix line)))) - -(defun folding-uncomment-mode-generic (beg end tag) - "In region (BEG . END) remove two TAG lines." - (re-search-forward tag (marker-position end)) - (beginning-of-line) - (kill-line 1) - (re-search-forward tag (marker-position end)) - (beginning-of-line) - (kill-line 1) - (cons beg end)) - -(defun folding-comment-mode-generic (beg end tag1 &optional tag2) - "Return (BEG . END) and Add two TAG1 and TAG2 lines." - (insert tag1) - (goto-char (marker-position end)) - (insert (or tag2 tag1)) - (cons beg end)) - -(defun folding-uncomment-c-mode (beg end) - "Uncomment region BEG END." - (folding-uncomment-mode-generic - beg end (regexp-quote " comment /* FOLDING -COM- */"))) - -(defun folding-comment-c-mode (beg end) - "Comment region BEG END." - (let* ((tag " /* FOLDING -COM- */")) - (folding-comment-mode-generic - beg end - (concat "#if comment" tag "\n") - (concat "#endif comment" tag "\n")))) - -(defun folding-comment-fold (&optional uncomment) - "Comment or UNCOMMENT all text inside single fold. -If there are subfolds this function won't work as expected. -User must know that there are no subfolds. - -The heading has -COM- at the end when the fold is commented. -Point must be over fold heading {{{ when function is called. - -Note: - - You can use this function only in modes that do _not_ have - `comment-end'. Ie. don't use this function in modes like C (/* */), because - nested comments are not allowed. See this: - - /* {{{ fold */ - code /* comment of the code */ - /* }}} */ - - Fold can't know how to comment the `code' inside fold, because comments - do not nest. - -Implementation detail: - - {{{ FoldHeader-COM- - - If the fold header has -COM- at the end, then the fold is supposed to - be commented. And if there is no -COM- then fold will be considered - as normal fold. Do not loose or add the -COM- yourself or it will - confuse the state of the fold. - -References: - - `folding-comment-folding-table'" - (interactive "P") - (let* ((state (folding-mark-look-at 'move)) - (closed (eq 0 state)) - (id "-COM-") - (opoint (point)) - (mode-elt (assq major-mode folding-comment-folding-table)) - comment - ret - beg - end) - (unless mode-elt - (if (stringp (nth 2 (folding-get-mode-marks major-mode))) - (error "\ -Folding: function usage error, mode with `comment-end' is not supported."))) - (when (or (null comment-start) - (not (string-match "[^ \t\n]" comment-start))) - (error "Empty comment-start.")) - (unless (memq state '( 0 1 11)) - (error "Incorrect fold state. Point must be over {{{.")) - ;; There is nothing to do if this fold heading does not have - ;; the ID when uncommenting the fold. - (setq state (looking-at (concat ".*" id))) - (when (or (and uncomment state) - (and (null uncomment) (null state))) - (when closed (save-excursion (folding-show-current-entry))) - (folding-pick-move) ;Go to end - (beginning-of-line) - (setq end (point-marker)) - (goto-char opoint) ;And off the fold heading - (forward-line 1) - (setq beg (point)) - (setq comment (concat comment-start id)) - (cond - (mode-elt - (setq ret - (if uncomment - (funcall (nth 2 mode-elt) (point) end) - (funcall (nth 1 mode-elt) (point) end))) - (goto-char (cdr ret))) - (uncomment - (while (< (point) (marker-position end)) - (if (looking-at comment) - (delete-region (point) (match-end 0))) - (forward-line 1))) - (t - (while (< (point) (marker-position end)) - (if (not (looking-at comment)) - (insert comment)) - (forward-line 1)))) - (setq end nil) ;kill marker - ;; Remove the possible tag from the fold name line - (goto-char opoint) - (setq id (concat (or comment-start "") id (or comment-end ""))) - (if (re-search-forward (regexp-quote id) beg t) - (delete-region (match-beginning 0) (match-end 0))) - (when (null uncomment) - (end-of-line) - (insert id)) - (if closed - (folding-hide-current-entry)) - (goto-char opoint)))) - -(defun folding-convert-to-major-folds () - "Convert fold mark items according to `major-mode'. -This function replaces all fold markings }}} and {{{ -with major mode's fold marks. - -As a side effect also corrects all foldings to standard notation. -Eg. following, where correct folding-beg should be \"#{{{ \" -Note that /// marks foldings. - - /// ;wrong fold - # /// ;too many spaces, fold format error - # ///title ;ok, but title too close - - produces - - #/// - #/// - #/// title - -You must 'unfold' whole buffer before using this function." - (interactive) - (let (case-fold-search - (bm "{{{") ; begin match mark - (em "}}}") ; - el ; element - b ; begin - e ; end - e2 ; end2 - pp) - (catch 'out ; is folding active/loaded ?? - (unless (setq el (folding-get-mode-marks major-mode)) - (throw 'out t)) ; ** no mode found - ;; ok , we're in business. Search whole buffer and replace. - (setq b (elt el 0) - e (elt el 1) - e2 (or (elt el 2) "")) - (save-excursion - (goto-char (point-min)) ; start from the beginning of buffer - (while (re-search-forward (regexp-quote bm) nil t) - ;; set the end position for fold marker - (setq pp (point)) - (beginning-of-line) - (if (looking-at (regexp-quote b)) ; should be mode-marked; ok, ignore - (goto-char pp) ; note that beg-of-l cmd, move rexp - (delete-region (point) pp) - (insert b) - (when (not (string= "" e2)) - (unless (looking-at (concat ".*" (regexp-quote e2))) - ;; replace with right fold mark - (end-of-line) - (insert e2))))) - ;; handle end marks , identical func compared to prev. - (goto-char (point-min)) - (while (re-search-forward (regexp-quote em)nil t) - (setq pp (point)) - (beginning-of-line) - (if (looking-at (regexp-quote e)) - (goto-char pp) - (delete-region (point) (progn (end-of-line) (point))) - (insert e))))))) - -(defun folding-all-comment-blocks-in-region (beg end) - "Put all comments in folds inside BEG END. -Notice: Make sure there is no interfering folds inside the area, -because the results may and up corrupted. - -This only works for modes that DO NOT have `comment-end'. -The `comment-start' must be left flushed in order to counted in. - -After this - - ;; comment - ;; comment - - code - - ;; comment - ;; comment - - code - -The result will be: - - ;; {{{ 1 - - ;; comment - ;; comment - - ;; }}} - - code - - ;; {{{ 2 - - ;; comment - ;; comment - - ;; }}} - - code" - (interactive "*r") - - (unless comment-start - (error "Folding: Mode does not define `comment-start'")) - - (when (and (stringp comment-end) - (string-match "[^ \t]" comment-end)) - (error "Folding: Mode defines non-empty `comment-end'.")) - (let* ((count 0) - (comment-regexp (concat "^" comment-start)) - (marker (point-marker)) - done) - (destructuring-bind (left right ignore) - (folding-get-mode-marks) - ;; Bytecomp silencer: variable ignore bound but not referenced - (if ignore (setq ignore ignore)) - ;; %%%{{{ --> "%%%" - (string-match (concat (regexp-quote comment-start) "+") left) - (save-excursion - (goto-char beg) - (beginning-of-line) - (while (re-search-forward comment-regexp nil t) - (move-marker marker (point)) - (setq done nil) - (beginning-of-line) - (forward-line -1) - ;; 2 previous lines Must not contain FOLD beginning already - (unless (looking-at (regexp-quote left)) - (forward-line -1) - (unless (looking-at (regexp-quote left)) - (goto-char (marker-position marker)) - (beginning-of-line) - (insert left " " (int-to-string count) "\n\n") - (incf count) - (setq done t))) - (goto-char (marker-position marker)) - (when done - ;; Try finding pat of the comment block - (if (not (re-search-forward "^[ \t]*$" nil t)) - (goto-char end)) - (open-line 1) - (forward-line 1) - (insert right "\n"))))))) - -;;}}} -;;{{{ code: Overlay support - -(defun folding-use-overlays-p () - "Should folding use overlays?." - (if folding-allow-overlays - (if folding-xemacs-p - ;; See if we can load overlay.el library that comes in 19.15 - ;; This call returns t or nil if load was successful - ;; Note: is there provide statement? Load is so radical - ;; - (load "overlay" 'noerr) - t))) - -(defun folding-flag-region (from to flag) - "Hide or show lines from FROM to TO, according to FLAG. -If FLAG is nil then text is shown, while if FLAG is t the text is hidden." - (let ((inhibit-read-only t) - overlay) - (save-excursion - (goto-char from) - (end-of-line) - (cond - (flag - (setq overlay (make-overlay (point) to)) - (folding-make-overlay-hidden overlay)) - (t - (if (fboundp 'hs-discard-overlays) - (funcall (symbol-function 'hs-discard-overlays) - (point) to 'invisible t))))))) - -(defun folding-make-overlay-hidden (overlay) - "Make OVERLAY hidden." - (overlay-put overlay 'fold t) - ;; (overlay-put overlay 'intangible t) - (overlay-put overlay 'invisible t) - (overlay-put overlay 'owner 'folding)) - -(defun folding-narrow-aux (start end arg) - "Narrow. Make overlay from `point-min' to START. -And from END t `point-min'. If ARG is nil, delete overlays." - (if (null arg) - (cond - (folding-narrow-overlays - (delete-overlay (car folding-narrow-overlays)) - (delete-overlay (cdr folding-narrow-overlays)) - (setq folding-narrow-overlays nil))) - (let ((overlay-beg (make-overlay (point-min) start)) - (overlay-end (make-overlay end (point-max)))) - (overlay-put overlay-beg 'folding-narrow t) - (overlay-put overlay-beg 'invisible t) - (overlay-put overlay-beg 'owner 'folding) - (overlay-put overlay-end 'folding-narrow t) - (overlay-put overlay-end 'invisible t) - (overlay-put overlay-end 'owner 'folding) - (setq folding-narrow-overlays (cons overlay-beg overlay-end))))) - -;;}}} -;;{{{ code: end of file tag, provide - -(folding-install) - -(provide 'folding) -(provide 'folding-isearch) ;; This used to be a separate package. - -(run-hooks 'folding-load-hook) - -;;}}} - -;;; folding.el ends here diff --git a/elisp/emacs-goodies-el/framepop.el b/elisp/emacs-goodies-el/framepop.el deleted file mode 100755 index 0a8c73d..0000000 --- a/elisp/emacs-goodies-el/framepop.el +++ /dev/null @@ -1,939 +0,0 @@ -;;; framepop.el --- display temporary buffers in a dedicated frame - -;; Copyright (C) 1993, 1995 Free Software Foundation, Inc. -;; Copyright (C) 2003 Peter S Galbraith - -;; Author: David Smith <D.M.Smith@lancaster.ac.uk> -;; Maintainer: Peter S Galbraith <psg@debian.org> -;; (I'll assign copyright to the FSF if requested. Send patches only if -;; you are willing to do the same. Contact me if you want to *actively* -;; maintain this file.) -;; Created: 8 Oct 1993 by David Smith -;; Modified: $Date: 2003-10-15 14:16:54 $ -;; Version: $Revision: 1.11 $ -;; RCS-Id: $Id: framepop.el,v 1.11 2003-10-15 14:16:54 psg Exp $ - -;; This file 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. - -;; This file 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 GNU Emacs; see the file COPYING. If not, write to -;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; Commentary: - -;; 1. PURPOSE - -;; Defines temp-buffer-show-function to display buffers in a dedicated -;; temporary frame (and so requires a display which can accomodate -;; separate frames). The frame is automatically shrink-wrapped to just -;; contain the buffer (restricted to a maximum and minimum -;; size). Buffers thus affected include *Help*, completion buffers and -;; buffer listings. -;; -;; Commands are provided for manipulating the FramePop frame: -;; scrolling, resizing, window manager functions, and also a facility -;; for copying the displayed buffer. You need never lose that handy -;; *Help* buffer again! -;; -;; Framepop is orthogonal to the Emacs' special-display-buffers feature; -;; you can use both at the same time if you so desire. You can make -;; special-display buffers appear in the FramePop frame as well, if you -;; wish; see below. - -;; 2. INSTALLATION - -;; To make use of this package, place this file in your load-path, -;; byte-compile it *before* loading it (or do M-x ad-deactivate-all -;; first), and add the following line to your .emacs: -;; -;; (when window-system -;; (require 'framepop) -;; (framepop-enable)) -;; -;; or, alternatively, load the file once, customize the variable -;; `framepop-enable' and save the setting. The file will then be loaded -;; automatically and enabled on startup. - -;; Several user functions are defined and stored in framepop-map. You -;; will probably want to bind these to keys. See `M-x customize-variable RET -;; framepop-enable-keybinding RET' -;; -;; Type M-x framepop-display-help (bound to `?' in framepop-map) for -;; more information. - -;; 3. CUSTOMIZATION - -;; See `M-x customize-group RET framepop'. - -;; The maximum and minimum height of the framepop buffer are -;; determined by the user options `framepop-max-frame-size' and -;; `framepop-min-frame-size'. - -;; The variable `framepop-frame-parameters' holds the FramePop frame -;; parameters. You can define colours, fonts and positions for the -;; FramePop frame here. For example: -;; -;; (setq framepop-frame-parameters -;; '((name . nil) ; use buffer name -;; (unsplittable . t) ; always include this -;; (menu-bar-lines . 0) ; no menu bar -;; (minibuffer . nil) ; or minubuffer -;; (left . -1) ; top left corner of screen, -;; (top . 30) ; away from my main frame -;; (width . 71) ; narrower, so it fits nicely -;; (background-color . "orchid4") ; I like purple. So sue me. -;; (foreground-color . "cornsilk") -;; (font . "-*-courier-bold-o-*-*-12-*-*-*-m-*-*-*"))) -;; -;; But you may use the customize interface to edit `framepop-frame-parameters'. - -;; By default, only temporary buffers (which call -;; `temp-buffer-show-function') are displayed in the FramePop frame. To -;; make other buffers also appear in the selected frame, the easiest thing -;; to do is make buffers listed in special-display-buffer-names or -;; special-display-regexps appear in the framepop frame by adding the -;; following to your .emacs file: -;; -;; (setq special-display-function 'framepop-special-display) -;; -;; Here's a suggestion for some buffers to use this feature on: -;; -;; (setq special-display-buffer-names '("*Shell Command Output*" -;; "*grep*" "*compilation*")) - -;; Alternatively (if you want to keep the special-display feature -;; separate from framepop) you can use the function `framepop-wrap'. - -;; There are lots of nifty things that can be done with the advice -;; package to make FramePop work that much better. Many such things -;; will be done for you automatically if you -;; -;; (require 'advice) -;; -;; before loading the framepop package (or customize the variable -;; `framepop-use-advice'. See the end of this file ("Customizations using -;; advice") for more details. - -;; Buffer names listed in the variable framepop-do-not-display-list -;; will not be displayed in the framepop-frame by default. -;; -;; You may set the variable `framepop-auto-resize' to t to have the -;; FramePop frame automatically resize to accomodate buffers which -;; change size. If you do not, initially empty buffers (which are -;; likely to grow) get a FramePop frame of full size. - -;; For elisp hackers: -;; -;; Alternatively, for greater control over the behaviour of the -;; framepop frame, you can redefine the variable `framepop-lines' to a -;; lambda expression which will return the desired height of a buffer -;; to be displayed in the framepop frame. It may also return nil, -;; meaning that the buffer should not be displayed in the FramePop -;; frame, but in an ordinary window instead. The default value of this -;; lambda expression is the number of lines in the buffer, except that -;; empty buffers and compilation buffers (both of which are likely to -;; grow) get full size. You may wish to disable this feature, or -;; perhaps make other constraints based on buffer mode, etc. For -;; example, placing the following in your .emacs will force the -;; framepop frame to have as many lines as the buffer being displayed -;; provided it is not the *Completions* buffer (which will not be -;; displayed in the FramePop frame at all): -;; -;; (setq framepop-lines -;; '(lambda (buf) -;; (if (string= (buffer-name buf) "*Completions*") nil -;; (save-excursion -;; (set-buffer buf) -;; (+ (count-lines (point-min) (point-max)) 1))))) -;; -;; This will cause empty buffers to have the minimum height, because -;; the maximum and minimum frame sizes (as specified in -;; `framepop-max-frame-size' and `framepop-min-frame-size') are enforced -;; independently of `framepop-lines'. To get around this, define advice -;; around the function `framepop-frame-height'. -;; -;; The default value of `framepop-lines' is framepop-default-lines. - -;; BUGS: -;; -;; 1. Completion in comint buffers doesn't work very well unless -;; comint-dynamic-show-completions is given a lobotomy. NB: this -;; happens by default if advice is loaded. -;; 2. I'd like to redefine framepop-wrap so that it saves the window -;; configuration, displays the requested buffer in the -;; framepop-frame, and then restores the window configuration. But -;; the job of framepop-wrap is better done by -;; special-display-buffer-names, so I shan't bother. - -;;; History: -;; -;; October 2003 - Peter S Galbraith -;; Since David Smith no longer uses Emacs, I have decided to do a bit of -;; work to update the file before packaging it for Debian. This involved -;; mostly switching to the customize interface. It's still very much -;; David's work. - -;;; Code: - -(defconst framepop-version (substring "$Revision: 1.11 $" 11 -2) - "The revision number of the framepop package. - -The complete RCS ID is: -$Id: framepop.el,v 1.11 2003-10-15 14:16:54 psg Exp $") - -;;; Customizable variables at end - -(defgroup framepop nil - "Display temporary buffers in a dedicated frame." - :group 'frames) - -;;;###autoload -(defun framepop-disable nil - "Disable automatic pop-up temporary windows." - (interactive) - (setq temp-buffer-show-function nil)) - -;;;###autoload -(defun framepop-enable nil - "Enable automatic pop-up temporary windows." - (interactive) - (if (and temp-buffer-show-function - (not (eq temp-buffer-show-function 'framepop-display-buffer))) - (message "Warning: framepop.el has redefined temp-buffer-show-function")) - (setq temp-buffer-show-function 'framepop-display-buffer)) - -(defcustom framepop-enable nil - "Whether to enable and use FramePop for temporary buffers." - :group 'framepop - :type 'boolean - :require 'framepop - :set (lambda (symbol value) - (set-default symbol value) - (if (and value window-system) - (framepop-enable) - (framepop-disable)))) - -(defvar framepop-map nil) -(if framepop-map nil - (setq framepop-map (make-sparse-keymap)) - (define-key framepop-map "?" 'framepop-display-help) - (define-key framepop-map "s" 'framepop-show-frame) - (define-key framepop-map "k" 'framepop-kill-buffer) - (define-key framepop-map "d" 'framepop-delete-frame) - (define-key framepop-map "i" 'framepop-make-invisible-frame) - (define-key framepop-map "w" 'framepop-resize-frame) - (define-key framepop-map "g" 'framepop-grow) - (define-key framepop-map "c" 'framepop-copy-frame) - (define-key framepop-map "/" 'framepop-pull-down) - (define-key framepop-map ">" 'framepop-eob) - (define-key framepop-map "<" 'framepop-bob) - (define-key framepop-map "v" 'framepop-scroll-frame) - (define-key framepop-map "l" 'framepop-lower-frame) - (define-key framepop-map "r" 'framepop-raise-frame) - (define-key framepop-map [f2] 'framepop-iconify-frame) - (define-key framepop-map "x" 'framepop-iconify-frame) - (define-key framepop-map "z" 'framepop-toggle-frame) - (define-key framepop-map "b" 'framepop-display-buffer)) -(defcustom framepop-enable-keybinding nil - "Global key binding for FramePop keymap. -The key F2 is suggested." - :group 'framepop - :type '(choice (const :tag "Not enabled" nil) - (const "<f2>") - (string :tag "key sequence (string)")) - :set (lambda (symbol value) - (set-default symbol value) - (if value - (define-key global-map (read-kbd-macro value) framepop-map)))) - -(defcustom framepop-use-advice 'automatic - "Whether to use `advice' to extend Framepop functionality" - :group 'framepop - :type '(radio (const :tag "Yes" t) - (const :tag "No" nil) - (const :tag "Automatically if `advice' is already loaded" - :value automatic))) - -(defcustom framepop-max-frame-size 35 - "*Maximum height of the FramePop frame." - :group 'framepop - :type 'integer) - -(defcustom framepop-min-frame-size 5 - "*Minimum height of the FramePop frame." - :group 'framepop - :type 'integer) - -(defcustom framepop-auto-resize nil - "Whether to dynamically resize for changing buffers." - :group 'framepop - :type 'boolean) - -(defcustom framepop-resize-increment 4 - "*When auto-resizing, frame height is forced to a multiple of this value. -This prevents excessive frame recreations on slow displays." - :group 'framepop - :type 'integer) - -;; FIXME: Make this a list or regexp to build a single \\| expression from? -(defcustom framepop-buffer-names-that-grow - "^\\\\*grep\\\\*$\\|\\\\*[Cc]ompilation\\\\*$" - "Regexp matching buffer names that are likely to grow from empty. -When `framepop-auto-resize' is nil, buffers with names matching this regexp -are given a framepop frame of maximal size, to accomodate the data which -is soon to appear." - :group 'framepop - :type 'regexp) - -;; If you want the title of the FramePop frame to be *Help* or -;; *Completions* or whatever, remove the (name . "FRAMEPOP") parameter -;; in framepop-frame-parameters below. -;; -;; If you want the FramePop frame to autoraise when selected, -;; uncomment the approprate line below -;; -;; Colours and positions are also good things to set here. There -;; should be no "height" parameter. - -(defcustom framepop-frame-parameters - '((name . "FRAMEPOP") - (unsplittable . t) ; always include this - (width . 80) ; this parameter is needed - (menu-bar-lines . 0) - (tool-bar-lines . 0) - (minibuffer . nil)) - "Default parameters used in with the FramePop frame." - :type '(set (cons :tag "Constant frame name (optional)" - (const name) string) - (cons :tag "Cannot be split" - (const unsplittable) - (boolean :tag "Boolean (Should be on)" )) - (cons :tag "Width of the Frame" - (const width :tag "width (required parameter)") integer) - (cons :tag "Auto-raise" - (const auto-raise) boolean) - (cons :tag "Frame Position" - (const left) number) - (cons :tag "Frame Position" - (const top) number) - (cons :tag "Frame Position" - (const user-position) boolean) - (cons :tag "Background Color" - (const background-color) color) - (cons :tag "Foreground Color" - (const foreground-color) color) - (cons :tag "Disable menubar" - (const menu-bar-lines) - (integer :tag "Integer (Should be 0)")) - (cons :tag "Disable Tool-bar" - (const tool-bar-lines) - (integer :tag "Integer (Should be 0)")) - (cons :tag "Disable Minibuffer" - (const minibuffer) - (boolean :tag "Boolean (Should be off)"))) - :tag "FramePop Frame Parameters" - :group 'framepop) - -(defcustom framepop-do-not-display-list '("*Buffer List*") - "List of buffer names which will not appear in the FramePop frame. -This behaviour is implemented by the function `framepop-lines-default -'" - :group 'framepop - :type '(repeat (string :tag "Buffer name"))) - -;;; Variables controlling gross hacks - -(defcustom framepop-hack-help-buffer-title t - "Try and produce sensible names for copied help buffers." - :group 'framepop - :type 'boolean) - -;;; System variables - -(defvar framepop-lines - 'framepop-lines-default - "Lambda expression of one argument BUF. -It returns the number of lines the framepop frame should have to display -BUF. If nil is returned, BUF is not displayed in the framepop frame.") - -(defvar framepop-in-wrap nil - "Flag set to t during the execution of commands wrapped with `framepop-wrap'.") - -(defvar framepop-last-displayed-buffer "" - "Name of last buffer displayed in temp frame.") - -(defvar framepop-frame nil) - -;; Is it XEmacs? -(defconst framepop-xemacs-p - (string-match "\\(Lucid\\|XEmacs\\)" emacs-version)) - -;;; Shut up the byte compiler - -(eval-when-compile - (require 'compile) - (require 'advice) - (require 'reporter)) - -;;; System functions - -(defun framepop-frame-height (buf) - "Return the desired height of a FramePop frame showing buffer BUF. -Enforces the limits set by `framepop-max-frame-size' and -`framepop-min-frame-size'" - (let ((lines (funcall framepop-lines buf))) - (if lines - (max (min framepop-max-frame-size - (funcall framepop-lines buf)) - framepop-min-frame-size)))) - -(defun framepop-buffer nil - "Return the buffer the framepop window is showing, or nil." - (if (frame-live-p framepop-frame) - (window-buffer (frame-root-window framepop-frame)))) - -(defun framepop-last-non-newline-char () - "Return the position of the last non-newline character in the current buffer." - (save-excursion - (goto-char (point-max)) - (save-match-data - (re-search-backward "[^\n]" nil t)) - (point))) - -(defun framepop-count-visual-lines (buf &optional max frame) - "Return the number of visual lines in BUF as opposed to the actual lines. -If MAX is supplied, counting stops after MAX lines. MAX defaults to -`framepop-max-frame-size'. The maximum size of a visual line is determined -by the width of frame FRAME \(defaults to `framepop-frame')." - (if framepop-xemacs-p - ;; This is inaccurate by one line, if a line that has 79 characters - ;; generates 2 visual lines. - (let* ((count 0) - (max (or max framepop-max-frame-size)) - (frame (or frame framepop-frame)) - (width (- (or (frame-width frame) - (cdr (assq 'width framepop-frame-parameters)) - (frame-width (selected-frame))) 1)) - col) - (save-excursion - (set-buffer buf) - (if truncate-lines - (min max (count-lines (point-min) (point-max))) - (save-excursion - (goto-char (point-min)) - (while (and (not (eobp)) (< count max)) - ;; Add one for this logical line - (setq count (1+ count)) - (while (not (eolp)) - ;; Add on the extra screen lines it generates - (setq col (+ (current-column) width)) - (move-to-column col) - (if (and (eq (current-column) col) (not (eolp))) - (setq count (1+ count)))) - ;; move to the next line, if possible - (if (not (eobp)) (forward-char 1))) - ;; Add one for a terminating newline - (if (and (eobp) (eq (preceding-char) ?\n)) - (setq count (1+ count))) - count)))) - ;; FSF GNU Emacs has a nice function for doing this :) - (save-excursion - (set-buffer buf) - (1+ (nth 2 - (compute-motion - 1 ; FROM - '(0 . 0) ; FROMPOS - (framepop-last-non-newline-char) ; TO - (cons 0 ; TOPOS horizontal - (1- (or max framepop-max-frame-size))) ; TOPOS vertical - (1- (cdr (assq 'width framepop-frame-parameters))) ; WIDTH - nil ; OFFSET - (if (frame-live-p framepop-frame) ; WINDOW - (frame-root-window framepop-frame) - (selected-window)))))) - )) - -(defun framepop-lines-default (buf) - "The default value for `framepop-lines'. -Ensures that the FramePop frame will be big enough to display all of BUF. -However, returns nil for buffers in `framepop-do-not-display-list'." - (save-excursion - (set-buffer buf) - (if (member (buffer-name) framepop-do-not-display-list) nil - (+ - (if (and (not framepop-auto-resize) - (or - ;; likely to grow - (eq (buffer-size) 0) - (string-match framepop-buffer-names-that-grow (buffer-name)))) - framepop-max-frame-size - (framepop-count-visual-lines buf)) - (if (cdr (assq 'minibuffer (frame-parameters framepop-frame))) - 1 0) - 1 ;; for the mode line - )))) - -;;; User commands - -(defun framepop-resize-frame (&optional buf height) - "Resize the framepop frame to accomodate buffer BUF. -BUF defaults to the buffer displayed in the framepop frame -If HEIGHT is non-nil, BUF is ignored and the frame is given height." - (interactive) - (let* ((win (frame-root-window framepop-frame)) - (buf (or buf (window-buffer win)))) - (modify-frame-parameters framepop-frame - (list (cons 'height - (or height (framepop-frame-height buf))))))) - -(defun framepop-pull-down nil - "If last line of framepop buffer is visible, place it on last window line." - (interactive) - (let* ((win (frame-root-window framepop-frame)) - (buf (window-buffer win)) - (pmax (save-excursion - (set-buffer buf) - (point-max)))) - (if (= (window-end win) pmax) - (let ((oldwin (selected-window))) - (select-window win) - (save-excursion - (goto-char pmax) - (recenter -1)) - (select-window oldwin))))) - -(defun framepop-grow (lines) - "Increase the height of the framepop frame by LINES lines. -When called interactively, LINES is the numeric prefix argument" - (interactive "p") - (modify-frame-parameters - framepop-frame - (list (cons 'height - (max 2 (+ lines - (cdr (assoc 'height - (frame-parameters framepop-frame))))))))) -(defun framepop-display-help nil - "Display help for the framepop commands." - (interactive) - (describe-function 'framepop-display-buffer) - (save-excursion - (set-buffer (framepop-buffer)) ; *Help* - (save-excursion - (goto-char (point-min)) - (let ((framepop-resize-increment 1)) - (delete-region (point) - (progn - ;; Delete the framepop-display-buffer-specific stuff - (forward-line 7) - (point))) - (insert "Framepop help:\n\n")))) - (if framepop-auto-resize nil - (framepop-resize-frame))) - -;;;###autoload -(defun framepop-display-buffer (buf) - ;; Note: the fifth line of this docstring should begin general help: - ;; see framepop-display-help - "Display-buffer for FramePop. -Displays BUF in a separate frame -- the FramePop frame. -BUF bay be a buffer or a buffer name. - -You can display a buffer in the FramePop frame with \\[framepop-display-buffer]. - -Several commands are available for manipulating the FramePop frame after -typing the keymap prefix (default F2). - -\\{framepop-map} -" - (interactive "bDisplay buffer: ") - (and (stringp buf) (setq buf (get-buffer buf))) - (let ((oframe (selected-frame)) - ;;(omouse (mouse-position)) - (lines (framepop-frame-height buf))) - (if (not lines) - ;; framepop-lines should return nil for buffers which - ;; shouldn't be displayed in the framepop frame - (display-buffer buf) - (if (frame-live-p framepop-frame) nil - ;; No existing framepop frame - (setq framepop-frame - (make-frame (cons (cons 'height lines) - framepop-frame-parameters)))) - ;; For XEmacs, kill toolbars - ;; Can't kill frame menubar in XEmacs til 19.13 comes out - (if framepop-xemacs-p - (progn - (set-specifier top-toolbar-height (list framepop-frame 0)) - (set-specifier bottom-toolbar-height (list framepop-frame 0)) - (set-specifier left-toolbar-width (list framepop-frame 0)) - (set-specifier right-toolbar-width (list framepop-frame 0)))) - (delete-other-windows (frame-selected-window framepop-frame)) - (set-window-dedicated-p (frame-selected-window framepop-frame) nil) - (set-window-buffer (frame-selected-window framepop-frame) buf) - (set-window-dedicated-p (frame-selected-window framepop-frame) t) - (framepop-resize-frame) - ;; (framepop-bob) - (setq framepop-last-displayed-buffer (buffer-name buf)) - (if framepop-auto-resize - (save-excursion - (set-buffer buf) - (make-local-variable 'after-change-functions) - ;; Some functions (e.g. grep) display the temporary buffer - ;; before setting its mode (which wipes buffer-local - ;; variables). Prevent that happening. - (put 'after-change-functions 'permanent-local t) - (add-hook 'after-change-functions 'framepop-resizer t))) - (raise-frame framepop-frame) - (if (minibuffer-window-active-p (minibuffer-window)) nil - ;; Replace the default message with something more suitable - (let ((message-log-max nil)) ; don't log this message - (message (substitute-command-keys - "Type \\[framepop-scroll-frame] to scroll, \\[framepop-iconify-frame] to iconify")))) - - ;; PSG - Let minibuffer [TAB] scroll *completions* buffer - ;; There is probably a better (less-generic) way of setting this up. - (setq minibuffer-scroll-window (frame-root-window framepop-frame)) - - ;; Set focus on the original frame - (if framepop-xemacs-p - (let ((wind (frame-lowest-window oframe))) - ;; XEmacs doesn't have a function that redirects focus - (select-frame oframe) - (set-mouse-position - wind (1- (window-width wind)) (1- (window-height wind)))) - (redirect-frame-focus framepop-frame oframe))))) - -(defun framepop-resizer (beg end pre-change-length) - "Bound to after-change-function to automatically resize the framepop frame." - ;; If a after-change-buffer has somehow escaped being reset, do it now - (if (and framepop-auto-resize (eq (framepop-buffer) (current-buffer))) - (let ((bufheight (framepop-frame-height (current-buffer)))) - (framepop-resize-frame nil - ;; round up to framepop-resize-increment - (if (zerop (mod bufheight framepop-resize-increment)) bufheight - (* (1+ (/ bufheight framepop-resize-increment)) - framepop-resize-increment)))) - ;; otherwise... - (remove-hook 'after-change-functions 'framepop-resizer))) - -(defun framepop-iconify-frame nil - "Iconify the FramePop frame." - (interactive) - (if (frame-live-p framepop-frame) - (iconify-frame framepop-frame) - (message "FramePop frame deleted"))) - -(defun framepop-make-invisible-frame nil - "Make the FramePop frame invisible." - (interactive) - (if (frame-live-p framepop-frame) - (make-frame-invisible framepop-frame) - (message "FramePop frame deleted"))) - -(defun framepop-show-frame nil - "Force the FramePop frame to be visible." - (interactive) - (if (frame-live-p framepop-frame) - (raise-frame framepop-frame) - (let ((buf (or - (get-buffer framepop-last-displayed-buffer) - (get-buffer "*Help*")))) - (if buf - (framepop-display-buffer buf) - (message "Last displayed temporary buffer has been killed."))))) - -(defun framepop-delete-frame nil - "Delete (destroy) the FramePop frame." - (interactive) - (delete-frame framepop-frame)) - -(defun framepop-kill-buffer nil - "Delete (destroy) the FramePop frame and its kill the buffer it was showing." - (interactive) - (kill-buffer (framepop-buffer)) - (delete-frame framepop-frame)) - -(defun framepop-toggle-frame nil - "Iconify or deiconify the FramePop frame." - (interactive) - (if (frame-live-p framepop-frame) - (let ((oframe (selected-frame))) - (if framepop-xemacs-p - (progn - (select-frame framepop-frame) ; XEmacs takes only one arg - (if (frame-iconified-p framepop-frame) - (deiconify-frame framepop-frame) - (iconify-frame framepop-frame))) - (select-frame framepop-frame t) - (iconify-or-deiconify-frame)) - ;; (bury-buffer (framepop-buffer)) - (select-frame oframe)) - (message "No active FramePop frame"))) - -(defun framepop-scroll-frame (n) - "Like `scroll-other-window', but scrolls the window in the FramePop frame. -Scroll-up N lines." - (interactive "P") - (framepop-show-frame) - (save-window-excursion - (select-window (frame-root-window framepop-frame)) - (scroll-up n))) - -(defun framepop-bob nil - "Go to the beginning of the framepop buffer." - (interactive) - (framepop-show-frame) - (let* ((win (frame-root-window framepop-frame)) - (buf (window-buffer win)) - (min (save-excursion - (set-buffer buf) - (point-min)))) - (set-window-point win min))) - -(defun framepop-eob nil - "Go to the end of the framepop buffer, and resize the framepoop frame. -Useful for buffers (e.g. compilations) which grow" - (interactive) - (framepop-show-frame) - (sit-for 0) - (let* ((win (frame-root-window framepop-frame)) - (buf (window-buffer win))) - (set-window-point win (save-excursion - (set-buffer buf) - (point-max)))) - (sit-for 0) ; redisplay - (framepop-pull-down)) - -(defun framepop-lower-frame nil - "Lower the FramePop frame." - (interactive) - (if (frame-live-p framepop-frame) - (lower-frame framepop-frame) - (message "No active FramePop frame"))) - -(defun framepop-raise-frame nil - "Raise the FramePop frame." - (interactive) - (if (frame-live-p framepop-frame) - (raise-frame framepop-frame) - (message "No active FramePop frame"))) - -(defun framepop-copy-frame (copy-buffer) - "Duplicate the FramePop frame, and maybe the displayed buffer as well. -With a prefix arg (COPY-BUFFER), the buffer is also copied and given a -unique name. This is useful for *Help*, *Completions* etc." - (interactive "P") - (let ((oframe (selected-frame)) - new-frame - buf - contents - pos) - (select-frame framepop-frame) - (setq pos (point)) - (setq new-frame (make-frame (frame-parameters framepop-frame))) - (modify-frame-parameters new-frame '((name . nil))) - (if copy-buffer - (progn - (let ((helpobj)) - (setq buf (if (and framepop-hack-help-buffer-title - (string= (buffer-name) "*Help*") - (progn - (condition-case () - (save-excursion - (goto-char (point-min)) - (search-forward ":" (min - (save-excursion - (end-of-line) - (point)) - (+ (point-min) 50))) - (setq helpobj (buffer-substring - (point-min) - (match-beginning 0)))) - (error nil)) - ;; (intern-soft helpobj) - )) - (generate-new-buffer (format "*Help* on %s" helpobj)) - (generate-new-buffer (buffer-name))))) - (select-frame new-frame) - (setq contents (buffer-string)) - (save-excursion - (set-buffer buf) - (insert contents) - (goto-char pos) - (switch-to-buffer buf)))) - (select-frame oframe))) - -(defun framepop-wrap (function buffer) - "Define a wrapper on FUNCTION so that BUFFER will appear in a FramePop frame. -BUFFER may be a buffer, a buffer name, or a sexp evaluating to a buffer or -buffer name. The function is advised with around advice named -framepop-display-buffer-in-framepop-frame. - -WARNING: this will not work on autoloaded functions unless forward -advice has been enabled. You must use `ad-activate' to activate the advice -after the package has been loaded. See advice.el for details." - (require 'advice) - (require 'backquote) - (ad-add-advice - function - (ad-make-advice - 'framepop-display-buffer-in-framepop-frame - t - t - (` (advice lambda nil - ;; docstring: - (, (format "Displays %s buffer in a FramePop frame" - (if (stringp buffer) buffer "output"))) - ;; body - (let ((framepop-in-wrap t)) - ad-do-it - (let* ((arg (, buffer)) - (buf (if (stringp arg) (get-buffer arg) arg))) - (cond ((bufferp buf) - (delete-windows-on buf) - (framepop-display-buffer buf)))))))) - - 'around - 'last) - (ad-activate function)) - -(defun framepop-submit-feedback () - "Sumbit feedback on the FramePop package by electronic mail." - (interactive) - (require 'reporter) - (reporter-submit-bug-report - "Peter S Galbraith <psg@debian.org>" - (concat "framepop.el; version " framepop-version) - '(framepop-lines framepop-auto-resize framepop-frame-parameters))) - -;;; Special display -;;; --------------- - -(defun framepop-special-display (buffer &optional args) - "Display BUF in the FramePop frame. -Pass it BUFFER as first arg, and (cdr ARGS) gives the rest of the args. -If ARGS is a list whose car is a symbol, use (car ARGS) as a function -to do the work. -Otherwise, ARGS is ignored." - (if (and args (symbolp (car args))) - (apply (car args) buffer (cdr args)) - (framepop-display-buffer buffer) - (frame-selected-window framepop-frame))) - -;;; Customizations using advice -;;; --------------------------- - -;;; There are lots of useful things we can do with advice, but I -;;; really want to avoid forcing everyone to load the advice package -;;; just for framepop (advice is BIG). So here's a compromise: If -;;; advice has been loaded, the customizations below will be made. - -(if (or (equal framepop-use-advice t) - (and (equal framepop-use-advice 'automatic) - (featurep 'advice))) - (progn - - ;; (setq ad-activate-on-definition t) ; allow forward advice - ;; (ad-start-advice) ; make forward advice work - -;;; Without the following advice, any completions generated by comint -;;; will leave the focus in the framepop frame (ugh) - - (defadvice comint-dynamic-list-completions (around framepop-simple-complete activate) - "Just display the completions buffer; no fancy tricks, OK?" - (with-output-to-temp-buffer "*Completions*" - (display-completion-list (sort completions 'string-lessp)))) - -;;; You may use the function framepop-wrap to force buffers which do -;;; not normally appear in a FramePop frame to do so automatically. For -;;; example, the following commands force *Shell Command Output* -;;; buffers to appear in the FramePop frame: - -;; This is better done with special-display-buffer-names, so I've disabled it -;; (framepop-wrap 'shell-command "*Shell Command Output*") -;; (framepop-wrap 'shell-command-on-region "*Shell Command Output*") - -;;; You can also do this for the compile function, as shown below. In -;;; addition we also add the following advice to work around the -;;; strange way compile displays its windows: - -;; This is better done with special-display-buffer-names, so I've disabled it -;; (framepop-wrap 'compile "*compilation*") -;; (framepop-wrap 'grep "*grep*") - -;;; The above advised functions are part of compile.el, which is -;;; autoloaded. We need to activate these advices after compile.el has -;;; loaded. - -;; (eval-after-load "compile" -;; '(progn -;; (ad-activate 'compile) -;; (ad-activate 'grep) -;; (ad-activate 'compile-internal) -;; (ad-activate 'compile-goto-error))) - -;;; Under normal (i.e. without framepop) circumstances, completion -;;; buffers disappear after use. The following advice similarly -;;; arranges for a framepop frame displaying completions to get out of -;;; the way after use. Other choices here include -;;; framepop-make-invisible-frame or framepop-lower-frame - - (defun framepop-completions-buffer-p nil - ;; Return non-nil if the framepop buffer is a completions buffer - (let ((buf (framepop-buffer))) - (and buf - (string-match "[cC]ompletions" (buffer-name buf))))) - - (defvar framepop-go-away-function 'framepop-iconify-frame - "*Function called to make the framepop frame go away") - - (defun framepop-maybe-go-away (&optional force) - ;; Get rid of the framepop frame if it shows completions buffer - (if (or force (framepop-completions-buffer-p)) - (funcall framepop-go-away-function))) - - (defadvice completing-read (after framepop-go-away protect activate) - "Get rid of the FramePop frame showing the completions" - (framepop-maybe-go-away)) - - ;; It would seem we only need protected advice for - ;; completing-read, but that subr is often called from other - ;; subrs and advice won't work. The following advices get around - ;; some of the cases where this happens, but unfortunately in - ;; such cases C-g won't lower the framepop frame, as desired. - - (defadvice minibuffer-complete-and-exit (before framepop-go-away - activate) - "Get rid of the FramePop frame showing the completions" - (framepop-maybe-go-away)) - - (defadvice exit-minibuffer (before framepop-go-away activate) - "Get rid of the FramePop frame showing the completions" - (framepop-maybe-go-away)) - - (defadvice mouse-choose-completion (after framepop-go-away activate) - "Get rid of the FramePop frame showing the completions" - (framepop-maybe-go-away t)) - - (defadvice keyboard-quit (before framepop-go-away activate) - "Get rid of the FramePop frame showing the completions" - (framepop-maybe-go-away)) - - (defadvice abort-recursive-edit (before framepop-go-away activate) - "Get rid of the FramePop frame showing the completions" - (framepop-maybe-go-away)) - -;;; End of advice customizations - )) - -(provide 'framepop) - -;;; framepop.el ends here diff --git a/elisp/emacs-goodies-el/graphviz-dot-mode.el b/elisp/emacs-goodies-el/graphviz-dot-mode.el deleted file mode 100755 index 6044810..0000000 --- a/elisp/emacs-goodies-el/graphviz-dot-mode.el +++ /dev/null @@ -1,944 +0,0 @@ -;;; graphviz-dot-mode.el --- Mode for the dot-language used by graphviz (att). - -;; Copyright (C) 2002 - 2010 Pieter Pareit <pieter.pareit@gmail.com> - -;; This program 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 of -;; the License, or (at your option) any later version. - -;; This program 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 this program; if not, write to the Free -;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, -;; MA 02111-1307 USA - -;; Authors: Pieter Pareit <pieter.pareit@gmail.com> -;; Rubens Ramos <rubensr AT users.sourceforge.net> -;; Eric Anderson http://www.ece.cmu.edu/~andersoe/ -;; Maintainer: Pieter Pareit <pieter.pareit@gmail.com> -;; Homepage: http://users.skynet.be/ppareit/projects/graphviz-dot-mode/graphviz-dot-mode.html -;; Created: 28 Oct 2002 -;; Last modified: 19 feb 2011 -;; Version: 0.3.6 -;; Keywords: mode dot dot-language dotlanguage graphviz graphs att - -;;; Commentary: -;; Use this mode for editing files in the dot-language (www.graphviz.org and -;; http://www.research.att.com/sw/tools/graphviz/). -;; -;; To use graphviz-dot-mode, add -;; (load-file "PATH_TO_FILE/graphviz-dot-mode.el") -;; to your ~/.emacs(.el) or ~/.xemacs/init.el -;; -;; The graphviz-dot-mode will do font locking, indentation, preview of graphs -;; and eases compilation/error location. There is support for both GNU Emacs -;; and XEmacs. -;; -;; Font locking is automatic, indentation uses the same commands as -;; other modes, tab, M-j and C-M-q. Insertion of comments uses the -;; same commands as other modes, M-; . You can compile a file using -;; M-x compile or C-c c, after that M-x next-error will also work. -;; There is support for viewing an generated image with C-c p. - -;;; Todo: -;; * cleanup the mess of graphviz-dot-compilation-parse-errors. -;; * electric indentation is fundamentally broken, because -;; {...} are also used for record nodes. You could argue, I suppose, that -;; many diagrams don't need those, but it would be worth having a note (and -;; it makes sense that the default is now for electric indentation to be -;; off). -;; * lines that start with # are comments, lines that start with one or more -;; whitespaces and then a # should give an error. - -;;; History: - -;; Version 0.3.6 maintaince -;; 19/02/2011: * .gv is the new extension (Pander) -;; * comments can start with # (Pander) -;; * highlight of new keywords (Pander) -;; Version 0.3.5 bug (or at least feature I dislike) fix -;; 11/11/2010: Eric Anderson http://www.ece.cmu.edu/~andersoe/ -;; * Preserve indentation across blank (whitespace-only) lines -;; Version 0.3.4 bug fixes -;; 24/02/2005: * fixed a bug in graphviz-dot-preview -;; Version 0.3.3 bug fixes -;; 13/02/2005: Reuben Thomas <rrt AT sc3d.org> -;; * add graphviz-dot-indent-width -;; Version 0.3.2 bug fixes -;; 25/03/2004: Rubens Ramos <rubensr AT users.sourceforge.net> -;; * semi-colons and brackets are added when electric -;; behaviour is disabled. -;; * electric characters do not behave electrically inside -;; comments or strings. -;; * default for electric-braces is disabled now (makes more -;; sense I guess). -;; * using read-from-minibuffer instead of read-shell-command -;; for emacs. -;; * Fixed test for easymenu, so that it works on older -;; versions of XEmacs. -;; * Fixed indentation error when trying to indent last brace -;; of an empty graph. -;; * region-active-p does not exist in emacs (21.2 at least), -;; so removed from code -;; * Added uncomment menu option -;; Version 0.3.1 bug fixes -;; 03/03/2004: * backward-word needs argument for older emacs -;; Version 0.3 added features and fixed bugs -;; 10/01/2004: fixed a bug in graphviz-dot-indent-graph -;; 08/01/2004: Rubens Ramos <rubensr AT users.sourceforge.net> -;; * added customization support -;; * Now it works on XEmacs and Emacs -;; * Added support to use an external Viewer -;; * Now things do not break when dot mode is entered -;; when there is no buffer name, but the side effect is -;; that in this case, the compilation command is not -;; correct. -;; * Preview works on XEmacs and emacs. -;; * Electric indentation on newline -;; * Minor changes to indentation -;; * Added keyword completion (but could be A LOT better) -;; * There are still a couple of ugly hacks. Look for 'RR'. -;; Version 0.2 added features -;; 11/11/2002: added preview support. -;; 10/11/2002: indent a graph or subgraph at once with C-M-q. -;; 08/11/2002: relaxed rules for indentation, the may now be extra chars -;; after beginning of graph (comment's for example). -;; Version 0.1.2 bug fixes and naming issues -;; 06/11/2002: renamed dot-font-lock-defaults to dot-font-lock-keywords. -;; added some documentation to dot-colors. -;; provided a much better way to handle my max-specpdl-size -;; problem. -;; added an extra autoload cookie (hope this helps, as I don't -;; yet use autoload myself) -;; Version 0.1.1 bug fixes -;; 06/11/2002: added an missing attribute, for font-locking to work. -;; fixed the regex generating, so that it only recognizes -;; whole words -;; 05/11/2002: there can now be extra white space chars after an '{'. -;; 04/11/2002: Why I use max-specpdl-size is now documented, and old value -;; gets restored. -;; Version 0.1 initial release -;; 02/11/2002: implemented parser for *compilation* of a .dot file. -;; 01/11/2002: implemented compilation of an .dot file. -;; 31/10/2002: added syntax-table to the mode. -;; 30/10/2002: implemented indentation code. -;; 29/10/2002: implemented all of font-lock. -;; 28/10/2002: derived graphviz-dot-mode from fundamental-mode, started -;; implementing font-lock. - -;;; Code: - -(defconst graphviz-dot-mode-version "0.3.6" - "Version of `graphviz-dot-mode.el'.") - -(defgroup graphviz nil - "Major mode for editing Graphviz Dot files" - :group 'tools) - -(defun graphviz-dot-customize () - "Run \\[customize-group] for the `graphviz' group." - (interactive) - (customize-group 'graphviz)) - -(defvar graphviz-dot-mode-abbrev-table nil - "Abbrev table in use in Graphviz Dot mode buffers.") -(define-abbrev-table 'graphviz-dot-mode-abbrev-table ()) - -(defcustom graphviz-dot-dot-program "dot" - "*Location of the dot program. This is used by `compile'." - :type 'string - :group 'graphviz) - -(defcustom graphviz-dot-view-command "doted %s" - "*External program to run on the buffer. You can use `%s' in this string, -and it will be substituted by the buffer name." - :type 'string - :group 'graphviz) - -(defcustom graphviz-dot-view-edit-command nil - "*Whether to allow the user to edit the command to run an external -viewer." - :type 'boolean - :group 'graphviz) - -(defcustom graphviz-dot-save-before-view t - "*If not nil, M-x graphviz-dot-view saves the current buffer before running -the command." - :type 'boolean - :group 'graphviz) - -(defcustom graphviz-dot-auto-indent-on-newline t - "*If not nil, `electric-graphviz-dot-terminate-line' is executed in a line is terminated." - :type 'boolean - :group 'graphviz) - -(defcustom graphviz-dot-indent-width default-tab-width - "*Indentation width in Graphviz Dot mode buffers." - :type 'integer - :group 'graphviz) - -(defcustom graphviz-dot-auto-indent-on-braces nil - "*If not nil, `electric-graphviz-dot-open-brace' and `electric-graphviz-dot-close-brace' are executed when { or } are typed" - :type 'boolean - :group 'graphviz) - -(defcustom graphviz-dot-auto-indent-on-semi t - "*If not nil, `electric-graphviz-dot-semi' is executed when semicolon is typed" - :type 'boolean - :group 'graphviz) - -(defcustom graphviz-dot-preview-extension "png" - "*The extension to use for the compilation and preview commands. The format -for the compilation command is -`dot -T<extension> file.dot > file.<extension>'." - :type 'string - :group 'graphviz) - -(defcustom graphviz-dot-toggle-completions nil - "*Non-nil means that repeated use of \ -\\<graphviz-dot-mode-map>\\[graphviz-dot-complete-word] will toggle the possible -completions in the minibuffer. Normally, when there is more than one possible -completion, a buffer will display all completions." - :type 'boolean - :group 'graphviz) - -(defcustom graphviz-dot-delete-completions nil - "*Non-nil means that the completion buffer is automatically deleted when a -key is pressed." - :type 'boolean - :group 'graphviz) - -(defcustom graphviz-dot-attr-keywords - '("graph" "digraph" "subgraph" "node" "edge" "strict" "rankdir" - "size" "page" "Damping" "Epsilon" "URL" "arrowhead" "arrowsize" - "arrowtail" "bb" "bgcolor" "bottomlabel" "center" "clusterrank" - "color" "comment" "compound" "concentrate" "constraint" "decorate" - "dim" "dir" "distortion" "fillcolor" "fixedsize" "fontcolor" - "fontname" "fontpath" "fontsize" "group" "headURL" "headlabel" - "headport" "height" "label" "labelangle" "labeldistance" "labelfloat" - "labelfontcolor" "labelfontname" "labelfontsize" "labeljust" - "labelloc" "layer" "layers" "len" "lhead" "lp" "ltail" "margin" - "maxiter" "mclimit" "minlen" "model" "nodesep" "normalize" "nslimit" - "nslimit1" "ordering" "orientation" "overlap" "pack" "pagedir" - "pencolor" "peripheries" "pin" "pos" "quantum" "rank" "ranksep" - "ratio" "rects" "regular" "remincross" "rotate" "samehead" "sametail" - "samplepoint" "searchsize" "sep" "shape" "shapefile" "showboxes" - "sides" "skew" "splines" "start" "style" "stylesheet" "tailURL" - "taillabel" "tailport" "toplabel" "vertices" "voro_margin" "weight" - "z" "width" "penwidth" "mindist" "scale" "patch" "root") - "*Keywords for attribute names in a graph. This is used by the auto -completion code. The actual completion tables are built when the mode -is loaded, so changes to this are not immediately visible. -Check http://www.graphviz.org/doc/schema/attributes.xml on new releases." - :type '(repeat (string :tag "Keyword")) - :group 'graphviz) - -(defcustom graphviz-dot-value-keywords - '("true" "false" "normal" "inv" "dot" "invdot" "odot" "invodot" - "none" "tee" "empty" "invempty" "diamond" "odiamond" "box" "obox" - "open" "crow" "halfopen" "local" "global" "none" "forward" "back" - "both" "none" "BL" "BR" "TL" "TR" "RB" "RT" "LB" "LT" ":n" ":ne" ":e" - ":se" ":s" ":sw" ":w" ":nw" "same" "min" "source" "max" "sink" "LR" - "box" "polygon" "ellipse" "circle" "point" "egg" "triangle" - "plaintext" "diamond" "trapezium" "parallelogram" "house" "hexagon" - "octagon" "doublecircle" "doubleoctagon" "tripleoctagon" "invtriangle" - "invtrapezium" "invhouse" "Mdiamond" "Msquare" "Mcircle" "record" - "Mrecord" "dashed" "dotted" "solid" "invis" "bold" "filled" - "diagonals" "rounded" ) - "*Keywords for attribute values. This is used by the auto completion -code. The actual completion tables are built when the mode is loaded, -so changes to this are not immediately visible." - :type '(repeat (string :tag "Keyword")) - :group 'graphviz) - -;;; Font-locking: -(defvar graphviz-dot-colors-list - '(aliceblue antiquewhite antiquewhite1 antiquewhite2 - antiquewhite3 antiquewhite4 aquamarine aquamarine1 - aquamarine2 aquamarine3 aquamarine4 azure azure1 - azure2 azure3 azure4 beige bisque bisque1 bisque2 - bisque3 bisque4 black blanchedalmond blue blue1 - blue2 blue3 blue4 blueviolet brown brown1 brown2 - brown3 brown4 burlywood burlywood1 burlywood2 - burlywood3 burlywood4 cadetblue cadetblue1 - cadetblue2 cadetblue3 cadetblue4 chartreuse - chartreuse1 chartreuse2 chartreuse3 chartreuse4 - chocolate chocolate1 chocolate2 chocolate3 chocolate4 - coral coral1 coral2 coral3 coral4 cornflowerblue - cornsilk cornsilk1 cornsilk2 cornsilk3 cornsilk4 - crimson cyan cyan1 cyan2 cyan3 cyan4 darkgoldenrod - darkgoldenrod1 darkgoldenrod2 darkgoldenrod3 - darkgoldenrod4 darkgreen darkkhaki darkolivegreen - darkolivegreen1 darkolivegreen2 darkolivegreen3 - darkolivegreen4 darkorange darkorange1 darkorange2 - darkorange3 darkorange4 darkorchid darkorchid1 - darkorchid2 darkorchid3 darkorchid4 darksalmon - darkseagreen darkseagreen1 darkseagreen2 - darkseagreen3 darkseagreen4 darkslateblue - darkslategray darkslategray1 darkslategray2 - darkslategray3 darkslategray4 darkslategrey - darkturquoise darkviolet deeppink deeppink1 - deeppink2 deeppink3 deeppink4 deepskyblue - deepskyblue1 deepskyblue2 deepskyblue3 deepskyblue4 - dimgray dimgrey dodgerblue dodgerblue1 dodgerblue2 - dodgerblue3 dodgerblue4 firebrick firebrick1 - firebrick2 firebrick3 firebrick4 floralwhite - forestgreen gainsboro ghostwhite gold gold1 gold2 - gold3 gold4 goldenrod goldenrod1 goldenrod2 - goldenrod3 goldenrod4 gray gray0 gray1 gray10 gray100 - gray11 gray12 gray13 gray14 gray15 gray16 gray17 - gray18 gray19 gray2 gray20 gray21 gray22 gray23 - gray24 gray25 gray26 gray27 gray28 gray29 gray3 - gray30 gray31 gray32 gray33 gray34 gray35 gray36 - gray37 gray38 gray39 gray4 gray40 gray41 gray42 - gray43 gray44 gray45 gray46 gray47 gray48 gray49 - gray5 gray50 gray51 gray52 gray53 gray54 gray55 - gray56 gray57 gray58 gray59 gray6 gray60 gray61 - gray62 gray63 gray64 gray65 gray66 gray67 gray68 - gray69 gray7 gray70 gray71 gray72 gray73 gray74 - gray75 gray76 gray77 gray78 gray79 gray8 gray80 - gray81 gray82 gray83 gray84 gray85 gray86 gray87 - gray88 gray89 gray9 gray90 gray91 gray92 gray93 - gray94 gray95 gray96 gray97 gray98 gray99 green - green1 green2 green3 green4 greenyellow grey grey0 - grey1 grey10 grey100 grey11 grey12 grey13 grey14 - grey15 grey16 grey17 grey18 grey19 grey2 grey20 - grey21 grey22 grey23 grey24 grey25 grey26 grey27 - grey28 grey29 grey3 grey30 grey31 grey32 grey33 - grey34 grey35 grey36 grey37 grey38 grey39 grey4 - grey40 grey41 grey42 grey43 grey44 grey45 grey46 - grey47 grey48 grey49 grey5 grey50 grey51 grey52 - grey53 grey54 grey55 grey56 grey57 grey58 grey59 - grey6 grey60 grey61 grey62 grey63 grey64 grey65 - grey66 grey67 grey68 grey69 grey7 grey70 grey71 - grey72 grey73 grey74 grey75 grey76 grey77 grey78 - grey79 grey8 grey80 grey81 grey82 grey83 grey84 - grey85 grey86 grey87 grey88 grey89 grey9 grey90 - grey91 grey92 grey93 grey94 grey95 grey96 grey97 - grey98 grey99 honeydew honeydew1 honeydew2 honeydew3 - honeydew4 hotpink hotpink1 hotpink2 hotpink3 hotpink4 - indianred indianred1 indianred2 indianred3 indianred4 - indigo ivory ivory1 ivory2 ivory3 ivory4 khaki khaki1 - khaki2 khaki3 khaki4 lavender lavenderblush - lavenderblush1 lavenderblush2 lavenderblush3 - lavenderblush4 lawngreen lemonchiffon lemonchiffon1 - lemonchiffon2 lemonchiffon3 lemonchiffon4 lightblue - lightblue1 lightblue2 lightblue3 lightblue4 - lightcoral lightcyan lightcyan1 lightcyan2 lightcyan3 - lightcyan4 lightgoldenrod lightgoldenrod1 - lightgoldenrod2 lightgoldenrod3 lightgoldenrod4 - lightgoldenrodyellow lightgray lightgrey lightpink - lightpink1 lightpink2 lightpink3 lightpink4 - lightsalmon lightsalmon1 lightsalmon2 lightsalmon3 - lightsalmon4 lightseagreen lightskyblue lightskyblue1 - lightskyblue2 lightskyblue3 lightskyblue4 - lightslateblue lightslategray lightslategrey - lightsteelblue lightsteelblue1 lightsteelblue2 - lightsteelblue3 lightsteelblue4 lightyellow - lightyellow1 lightyellow2 lightyellow3 lightyellow4 - limegreen linen magenta magenta1 magenta2 magenta3 - magenta4 maroon maroon1 maroon2 maroon3 maroon4 - mediumaquamarine mediumblue mediumorchid - mediumorchid1 mediumorchid2 mediumorchid3 - mediumorchid4 mediumpurple mediumpurple1 - mediumpurple2 mediumpurple3 mediumpurple4 - mediumseagreen mediumslateblue mediumspringgreen - mediumturquoise mediumvioletred midnightblue - mintcream mistyrose mistyrose1 mistyrose2 mistyrose3 - mistyrose4 moccasin navajowhite navajowhite1 - navajowhite2 navajowhite3 navajowhite4 navy navyblue - oldlace olivedrab olivedrap olivedrab1 olivedrab2 - olivedrap3 oragne palegoldenrod palegreen palegreen1 - palegreen2 palegreen3 palegreen4 paleturquoise - paleturquoise1 paleturquoise2 paleturquoise3 - paleturquoise4 palevioletred palevioletred1 - palevioletred2 palevioletred3 palevioletred4 - papayawhip peachpuff peachpuff1 peachpuff2 - peachpuff3 peachpuff4 peru pink pink1 pink2 pink3 - pink4 plum plum1 plum2 plum3 plum4 powderblue - purple purple1 purple2 purple3 purple4 red red1 red2 - red3 red4 rosybrown rosybrown1 rosybrown2 rosybrown3 - rosybrown4 royalblue royalblue1 royalblue2 royalblue3 - royalblue4 saddlebrown salmon salmon1 salmon2 salmon3 - salmon4 sandybrown seagreen seagreen1 seagreen2 - seagreen3 seagreen4 seashell seashell1 seashell2 - seashell3 seashell4 sienna sienna1 sienna2 sienna3 - sienna4 skyblue skyblue1 skyblue2 skyblue3 skyblue4 - slateblue slateblue1 slateblue2 slateblue3 slateblue4 - slategray slategray1 slategray2 slategray3 slategray4 - slategrey snow snow1 snow2 snow3 snow4 springgreen - springgreen1 springgreen2 springgreen3 springgreen4 - steelblue steelblue1 steelblue2 steelblue3 steelblue4 - tan tan1 tan2 tan3 tan4 thistle thistle1 thistle2 - thistle3 thistle4 tomato tomato1 tomato2 tomato3 - tomato4 transparent turquoise turquoise1 turquoise2 - turquoise3 turquoise4 violet violetred violetred1 - violetred2 violetred3 violetred4 wheat wheat1 wheat2 - wheat3 wheat4 white whitesmoke yellow yellow1 yellow2 - yellow3 yellow4 yellowgreen) - "Possible color constants in the dot language. -The list of constant is available at http://www.research.att.com/~erg/graphviz\ -/info/colors.html") - - -(defvar graphviz-dot-color-keywords - (mapcar 'symbol-name graphviz-dot-colors-list)) - -(defvar graphviz-attr-keywords - (mapcar '(lambda (elm) (cons elm 0)) graphviz-dot-attr-keywords)) - -(defvar graphviz-value-keywords - (mapcar '(lambda (elm) (cons elm 0)) graphviz-dot-value-keywords)) - -(defvar graphviz-color-keywords - (mapcar '(lambda (elm) (cons elm 0)) graphviz-dot-color-keywords)) - -;;; Key map -(defvar graphviz-dot-mode-map () - "Keymap used in Graphviz Dot mode.") - -(if graphviz-dot-mode-map - () - (let ((map (make-sparse-keymap))) - (define-key map "\r" 'electric-graphviz-dot-terminate-line) - (define-key map "{" 'electric-graphviz-dot-open-brace) - (define-key map "}" 'electric-graphviz-dot-close-brace) - (define-key map ";" 'electric-graphviz-dot-semi) - (define-key map "\M-\t" 'graphviz-dot-complete-word) - (define-key map "\C-\M-q" 'graphviz-dot-indent-graph) - (define-key map "\C-cp" 'graphviz-dot-preview) - (define-key map "\C-cc" 'compile) - (define-key map "\C-cv" 'graphviz-dot-view) - (define-key map "\C-c\C-c" 'comment-region) - (define-key map "\C-c\C-u" 'graphviz-dot-uncomment-region) - (setq graphviz-dot-mode-map map) - )) - -;;; Syntax table -(defvar graphviz-dot-mode-syntax-table nil - "Syntax table for `graphviz-dot-mode'.") - -(if graphviz-dot-mode-syntax-table - () - (let ((st (make-syntax-table))) - (modify-syntax-entry ?/ ". 124b" st) - (modify-syntax-entry ?* ". 23" st) - (modify-syntax-entry ?\n "> b" st) - (modify-syntax-entry ?= "." st) - (modify-syntax-entry ?_ "_" st) - (modify-syntax-entry ?- "_" st) - (modify-syntax-entry ?> "." st) - (modify-syntax-entry ?[ "(" st) - (modify-syntax-entry ?] ")" st) - (modify-syntax-entry ?\" "\"" st) - (setq graphviz-dot-mode-syntax-table st) - )) - -(defvar graphviz-dot-font-lock-keywords - `(("\\(:?di\\|sub\\)?graph \\(\\sw+\\)" - (2 font-lock-function-name-face)) - (,(regexp-opt graphviz-dot-value-keywords 'words) - . font-lock-reference-face) - ;; to build the font-locking for the colors, - ;; we need more room for max-specpdl-size, - ;; after that we take the list of symbols, - ;; convert them to a list of strings, and make - ;; an optimized regexp from them - (,(let ((max-specpdl-size (max max-specpdl-size 1200))) - (regexp-opt graphviz-dot-color-keywords)) - . font-lock-string-face) - (,(concat - (regexp-opt graphviz-dot-attr-keywords 'words) - "[ \\t\\n]*=") - ;; RR - ugly, really, but I dont know why xemacs does not work - ;; if I change the next car to "1"... - (0 font-lock-variable-name-face))) - "Keyword highlighting specification for `graphviz-dot-mode'.") - -;;;###autoload -(defun graphviz-dot-mode () - "Major mode for the dot language. \\<graphviz-dot-mode-map> -TAB indents for graph lines. - -\\[graphviz-dot-indent-graph]\t- Indentaion function. -\\[graphviz-dot-preview]\t- Previews graph in a buffer. -\\[graphviz-dot-view]\t- Views graph in an external viewer. -\\[graphviz-dot-indent-line]\t- Indents current line of code. -\\[graphviz-dot-complete-word]\t- Completes the current word. -\\[electric-graphviz-dot-terminate-line]\t- Electric newline. -\\[electric-graphviz-dot-open-brace]\t- Electric open braces. -\\[electric-graphviz-dot-close-brace]\t- Electric close braces. -\\[electric-graphviz-dot-semi]\t- Electric semi colons. - -Variables specific to this mode: - - graphviz-dot-dot-program (default `dot') - Location of the dot program. - graphviz-dot-view-command (default `doted %s') - Command to run when `graphviz-dot-view' is executed. - graphviz-dot-view-edit-command (default nil) - If the user should be asked to edit the view command. - graphviz-dot-save-before-view (default t) - Automatically save current buffer berore `graphviz-dot-view'. - graphviz-dot-preview-extension (default `png') - File type to use for `graphviz-dot-preview'. - graphviz-dot-auto-indent-on-newline (default t) - Whether to run `electric-graphviz-dot-terminate-line' when - newline is entered. - graphviz-dot-auto-indent-on-braces (default t) - Whether to run `electric-graphviz-dot-open-brace' and - `electric-graphviz-dot-close-brace' when braces are - entered. - graphviz-dot-auto-indent-on-semi (default t) - Whether to run `electric-graphviz-dot-semi' when semi colon - is typed. - graphviz-dot-toggle-completions (default nil) - If completions should be displayed in the buffer instead of a - completion buffer when \\[graphviz-dot-complete-word] is - pressed repeatedly. - -This mode can be customized by running \\[graphviz-dot-customize]. - -Turning on Graphviz Dot mode calls the value of the variable -`graphviz-dot-mode-hook' with no args, if that value is non-nil." - (interactive) - (kill-all-local-variables) - (use-local-map graphviz-dot-mode-map) - (setq major-mode 'graphviz-dot-mode) - (setq mode-name "dot") - (setq local-abbrev-table graphviz-dot-mode-abbrev-table) - (set-syntax-table graphviz-dot-mode-syntax-table) - (set (make-local-variable 'indent-line-function) 'graphviz-dot-indent-line) - (set (make-local-variable 'comment-start) "//") - (set (make-local-variable 'comment-start-skip) "/\\*+ *\\|//+ *") - (modify-syntax-entry ?# "< b" graphviz-dot-mode-syntax-table) - (modify-syntax-entry ?\n "> b" graphviz-dot-mode-syntax-table) - (set (make-local-variable 'font-lock-defaults) - '(graphviz-dot-font-lock-keywords)) - ;; RR - If user is running this in the scratch buffer, there is no - ;; buffer file name... - (if (buffer-file-name) - (set (make-local-variable 'compile-command) - (concat graphviz-dot-dot-program - " -T" graphviz-dot-preview-extension " " - buffer-file-name - " > " - (file-name-sans-extension - buffer-file-name) - "." graphviz-dot-preview-extension))) - (set (make-local-variable 'compilation-parse-errors-function) - 'graphviz-dot-compilation-parse-errors) - (if dot-menu - (easy-menu-add dot-menu)) - (run-hooks 'graphviz-dot-mode-hook) - ) - -;;;; Menu definitions - -(defvar dot-menu nil - "Menu for Graphviz Dot Mode. -This menu will get created automatically if you have the `easymenu' -package. Note that the latest X/Emacs releases contain this package.") - -(and (condition-case nil - (require 'easymenu) - (error nil)) - (easy-menu-define - dot-menu graphviz-dot-mode-map "Graphviz Mode menu" - '("Graphviz" - ["Indent Graph" graphviz-dot-indent-graph t] - ["Comment Out Region" comment-region (mark)] - ["Uncomment Region" graphviz-dot-uncomment-region (mark)] - "-" - ["Compile" compile t] - ["Preview" graphviz-dot-preview - (and (buffer-file-name) - (not (buffer-modified-p)))] - ["External Viewer" graphviz-dot-view (buffer-file-name)] - "-" - ["Customize..." graphviz-dot-customize t] - ))) - -;;;; Compilation - -;; note on graphviz-dot-compilation-parse-errors: -;; It would nicer if we could just use compilation-error-regexp-alist -;; to do that, 3 options: -;; - still write dot-compilation-parse-errors, don't build -;; a return list, but modify the *compilation* buffer -;; in a way compilation-error-regexp-alist recognizes the -;; format. -;; to do that, I should globally change compilation-parse-function -;; to this function, and call the old value of comp..-parse-fun.. -;; to provide the return value. -;; two drawbacks are that, every compilation would be run through -;; this function (performance) and that in autoload there would -;; be a chance that this function would not yet be known. -;; - let the compilation run through a filter that would -;; modify the output of dot or neato: -;; dot -Tpng input.dot | filter -;; drawback: ugly, extra work for user, extra decency ... -;; no-option -;; - modify dot and neato !!! (PP:15/02/2005 seems to have happend, -;; so version 0.4.0 should clean this mess up!) -(defun graphviz-dot-compilation-parse-errors (limit-search find-at-least) - "Parse the current buffer for dot errors. -See variable `compilation-parse-errors-functions' for interface." - (interactive) - (save-excursion - (set-buffer "*compilation*") - (goto-char (point-min)) - (setq compilation-error-list nil) - (let (buffer-of-error) - (while (not (eobp)) - (cond - ((looking-at "^dot\\( -[^ ]+\\)* \\(.*\\)") - (setq buffer-of-error (find-file-noselect - (buffer-substring-no-properties - (nth 4 (match-data t)) - (nth 5 (match-data t)))))) - ((looking-at ".*:.*line \\([0-9]+\\)") - (let ((line-of-error - (string-to-number (buffer-substring-no-properties - (nth 2 (match-data t)) - (nth 3 (match-data t)))))) - (setq compilation-error-list - (cons - (cons - (point-marker) - (save-excursion - (set-buffer buffer-of-error) - (goto-line line-of-error) - (beginning-of-line) - (point-marker))) - compilation-error-list)))) - (t t)) - (forward-line 1)) ))) - -;;;; -;;;; Indentation -;;;; -(defun graphviz-dot-uncomment-region (begin end) - "Uncomments a region of code." - (interactive "r") - (comment-region begin end '(4))) - -(defun graphviz-dot-indent-line () - "Indent current line of dot code." - (interactive) - (if (bolp) - (graphviz-dot-real-indent-line) - (save-excursion - (graphviz-dot-real-indent-line)))) - -(defun graphviz-dot-get-indendation() - "Return current line's indentation" - (interactive) - (message "Current indentation is %d." - (current-indentation)) - (current-indentation)) - -(defun graphviz-dot-real-indent-line () - "Indent current line of dot code." - (beginning-of-line) - (cond - ((bobp) - ;; simple case, indent to 0 - (indent-line-to 0)) - ((looking-at "^[ \t]*}[ \t]*$") - ;; block closing, deindent relative to previous line - (indent-line-to (save-excursion - (forward-line -1) - (max 0 (- (current-indentation) graphviz-dot-indent-width))))) - ;; other cases need to look at previous lines - (t - (indent-line-to (save-excursion - (forward-line -1) - (cond - ((looking-at "\\(^.*{[^}]*$\\)") - ;; previous line opened a block - ;; indent to that line - (+ (current-indentation) graphviz-dot-indent-width)) - ((and (not (looking-at ".*\\[.*\\].*")) - (looking-at ".*\\[.*")) ; TODO:PP : can be 1 regex - ;; previous line started filling - ;; attributes, intend to that start - (search-forward "[") - (current-column)) - ((and (not (looking-at ".*\\[.*\\].*")) - (looking-at ".*\\].*")) ; TODO:PP : " - ;; previous line stopped filling - ;; attributes, find the line that started - ;; filling them and indent to that line - (while (or (looking-at ".*\\[.*\\].*") - (not (looking-at ".*\\[.*"))) ; TODO:PP : " - (forward-line -1)) - (current-indentation)) - (t - ;; default case, indent the - ;; same as previous NON-BLANK line - ;; (or the first line, if there are no previous non-blank lines) - (while (and (< (point-min) (point)) - (looking-at "^\[ \t\]*$")) - (forward-line -1)) - (current-indentation)) ))) ))) - -(defun graphviz-dot-indent-graph () - "Indent the graph/digraph/subgraph where point is at. -This will first teach the beginning of the graph were point is at, and -then indent this and each subgraph in it." - (interactive) - (save-excursion - ;; position point at start of graph - (while (not (or (looking-at "\\(^.*{[^}]*$\\)") (bobp))) - (forward-line -1)) - ;; bracket { one +; bracket } one - - (let ((bracket-count 0)) - (while - (progn - (cond - ;; update bracket-count - ((looking-at "\\(^.*{[^}]*$\\)") - (setq bracket-count (+ bracket-count 1))) - ;; update bracket-count - ((looking-at "^[ \t]*}[ \t]*$") - (setq bracket-count (- bracket-count 1)))) - ;; indent this line and move on - (graphviz-dot-indent-line) - (forward-line 1) - ;; as long as we are not completed or at end of buffer - (and (> bracket-count 0) (not (eobp)))))))) - -;;;; -;;;; Electric indentation -;;;; -(defun graphviz-dot-comment-or-string-p () - (let ((state (parse-partial-sexp (point-min) (point)))) - (or (nth 4 state) (nth 3 state)))) - -(defun graphviz-dot-newline-and-indent () - (save-excursion - (beginning-of-line) - (skip-chars-forward " \t") - (graphviz-dot-indent-line)) - (delete-horizontal-space) - (newline) - (graphviz-dot-indent-line)) - -(defun electric-graphviz-dot-terminate-line () - "Terminate line and indent next line." - (interactive) - (if graphviz-dot-auto-indent-on-newline - (graphviz-dot-newline-and-indent) - (newline))) - -(defun electric-graphviz-dot-open-brace () - "Terminate line and indent next line." - (interactive) - (insert "{") - (if (and graphviz-dot-auto-indent-on-braces - (not (graphviz-dot-comment-or-string-p))) - (graphviz-dot-newline-and-indent))) - -(defun electric-graphviz-dot-close-brace () - "Terminate line and indent next line." - (interactive) - (insert "}") - (if (and graphviz-dot-auto-indent-on-braces - (not (graphviz-dot-comment-or-string-p))) - (progn - (save-excursion - (beginning-of-line) - (skip-chars-forward " \t") - (graphviz-dot-indent-line)) - (newline) - (graphviz-dot-indent-line)))) - -(defun electric-graphviz-dot-semi () - "Terminate line and indent next line." - (interactive) - (insert ";") - (if (and graphviz-dot-auto-indent-on-semi - (not (graphviz-dot-comment-or-string-p))) - (graphviz-dot-newline-and-indent))) - -;;;; -;;;; Preview -;;;; -(defun graphviz-dot-preview () - "Shows an example of the current dot file in an emacs buffer. -This assumes that we are running GNU Emacs or XEmacs under a windowing system. -See `image-file-name-extensions' for customizing the files that can be -loaded in GNU Emacs, and `image-formats-alist' for XEmacs." - (interactive) - ;; unsafe to compile ourself, ask it to the user - (if (buffer-modified-p) - (message "Buffer needs to be compiled.") - (if (string-match "XEmacs" emacs-version) - ;; things are easier in XEmacs... - (find-file-other-window (concat (file-name-sans-extension - buffer-file-name) - "." graphviz-dot-preview-extension)) - ;; run through all the extensions for images - (let ((l image-file-name-extensions)) - (while - (let ((f (concat (file-name-sans-extension (buffer-file-name)) - "." - (car l)))) - ;; see if a file matches, might be best also to check - ;; if file is up to date TODO:PP - (if (file-exists-p f) - (progn (auto-image-file-mode 1) - ;; OK, this is ugly, I would need to - ;; know how I can reload a file in an existing buffer - (if (get-buffer "*preview*") - (kill-buffer "*preview*")) - (set-buffer (find-file-noselect f)) - (rename-buffer "*preview*") - (display-buffer (get-buffer "*preview*")) - ;; stop iterating - '()) - ;; will stop iterating when l is nil - (setq l (cdr l))))) - ;; each extension tested and nothing found, let user know - (when (eq l '()) - (message "No image found.")))))) - -;;;; -;;;; View -;;;; -(defun graphviz-dot-view () - "Runs an external viewer. This creates an external process every time it -is executed. If `graphviz-dot-save-before-view' is set, the current -buffer is saved before the command is executed." - (interactive) - (let ((cmd (if graphviz-dot-view-edit-command - (if (string-match "XEmacs" emacs-version) - (read-shell-command "View command: " - (format graphviz-dot-view-command - (buffer-file-name))) - (read-from-minibuffer "View command: " - (format graphviz-dot-view-command - (buffer-file-name)))) - (format graphviz-dot-view-command (buffer-file-name))))) - (if graphviz-dot-save-before-view - (save-buffer)) - (setq novaproc (start-process-shell-command - (downcase mode-name) nil cmd)) - (message (format "Executing `%s'..." cmd)))) - -;;;; -;;;; Completion -;;;; -(defvar graphviz-dot-str nil) -(defvar graphviz-dot-all nil) -(defvar graphviz-dot-pred nil) -(defvar graphviz-dot-buffer-to-use nil) -(defvar graphviz-dot-flag nil) - -(defun graphviz-dot-get-state () - "Returns the syntax state of the current point." - (let ((state (parse-partial-sexp (point-min) (point)))) - (cond - ((nth 4 state) 'comment) - ((nth 3 state) 'string) - ((not (nth 1 state)) 'out) - (t (save-excursion - (skip-chars-backward "^[,=\\[]{};") - (backward-char) - (cond - ((looking-at "[\\[,]{};") 'attribute) - ((looking-at "=") (progn - (backward-word 1) - (if (looking-at "[a-zA-Z]*color") - 'color - 'value))) - (t 'other))))))) - -(defun graphviz-dot-get-keywords () - "Return possible completions for a word" - (let ((state (graphviz-dot-get-state))) - (cond - ((equal state 'comment) ()) - ((equal state 'string) ()) - ((equal state 'out) graphviz-attr-keywords) - ((equal state 'value) graphviz-value-keywords) - ((equal state 'color) graphviz-color-keywords) - ((equal state 'attribute) graphviz-attr-keywords) - (t graphviz-attr-keywords)))) - -(defvar graphviz-dot-last-word-numb 0) -(defvar graphviz-dot-last-word-shown nil) -(defvar graphviz-dot-last-completions nil) - -(defun graphviz-dot-complete-word () - "Complete word at current point." - (interactive) - (let* ((b (save-excursion (skip-chars-backward "a-zA-Z0-9_") (point))) - (e (save-excursion (skip-chars-forward "a-zA-Z0-9_") (point))) - (graphviz-dot-str (buffer-substring b e)) - (allcomp (if (and graphviz-dot-toggle-completions - (string= graphviz-dot-last-word-shown - graphviz-dot-str)) - graphviz-dot-last-completions - (all-completions graphviz-dot-str - (graphviz-dot-get-keywords)))) - (match (if graphviz-dot-toggle-completions - "" (try-completion - graphviz-dot-str (mapcar '(lambda (elm) - (cons elm 0)) allcomp))))) - ;; Delete old string - (delete-region b e) - - ;; Toggle-completions inserts whole labels - (if graphviz-dot-toggle-completions - (progn - ;; Update entry number in list - (setq graphviz-dot-last-completions allcomp - graphviz-dot-last-word-numb - (if (>= graphviz-dot-last-word-numb (1- (length allcomp))) - 0 - (1+ graphviz-dot-last-word-numb))) - (setq graphviz-dot-last-word-shown - (elt allcomp graphviz-dot-last-word-numb)) - ;; Display next match or same string if no match was found - (if (not (null allcomp)) - (insert "" graphviz-dot-last-word-shown) - (insert "" graphviz-dot-str) - (message "(No match)"))) - ;; The other form of completion does not necessarily do that. - - ;; Insert match if found, or the original string if no match - (if (or (null match) (equal match 't)) - (progn (insert "" graphviz-dot-str) - (message "(No match)")) - (insert "" match)) - ;; Give message about current status of completion - (cond ((equal match 't) - (if (not (null (cdr allcomp))) - (message "(Complete but not unique)") - (message "(Sole completion)"))) - ;; Display buffer if the current completion didn't help - ;; on completing the label. - ((and (not (null (cdr allcomp))) (= (length graphviz-dot-str) - (length match))) - (with-output-to-temp-buffer "*Completions*" - (display-completion-list allcomp)) - ;; Wait for a keypress. Then delete *Completion* window - (momentary-string-display "" (point)) - (if graphviz-dot-delete-completions - (delete-window - (get-buffer-window (get-buffer "*Completions*")))) - ))))) - -;;;###autoload -(add-to-list 'auto-mode-alist '("\\.dot\\'" . graphviz-dot-mode)) -(add-to-list 'auto-mode-alist '("\\.gv\\'" . graphviz-dot-mode)) - -;;; graphviz-dot-mode.el ends here - diff --git a/elisp/emacs-goodies-el/highlight-beyond-fill-column.el b/elisp/emacs-goodies-el/highlight-beyond-fill-column.el deleted file mode 100755 index fcc01e9..0000000 --- a/elisp/emacs-goodies-el/highlight-beyond-fill-column.el +++ /dev/null @@ -1,125 +0,0 @@ -;;; highlight-beyond-fill-column.el --- font-lock-add-keywords aid for Emacs - -;; Copyright (C) 1985, 1986, 1987, 1992 Free Software Foundation, Inc. - -;; Author: Sandip Chitale (sandip.chitale@blazesoft.com) -;; Keywords: programming decipline convenience - -;; Keywords: -;; Time-stamp: Aug 23 2001 8:56 PM Pacific Daylight Time -;; Version: 1.1 - -;; This file is *NOT* (yet?) part of GNU Emacs. - -;; This program 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. - -;; This program 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;; Commentary: - -;; This defines a function that can be used by `font-lock-add-keywords' to find the columns -;; that are beyond `fill-column'. -;; -;; Installation: -;; Put the following in your .emacs -;; -;; (require 'highlight-beyond-fill-column) -;; -;; Example usage: -;; -;; Customize the `highlight-beyond-fill-column-in-modes' variable to -;; setup the list of modes in which to highlight-beyond-fill-column -;; -;; Customize the `highlight-beyond-fill-column-face' variable to -;; to setup the face used for highlight-beyond-fill-column -;; -;; Acknowledgement: -;; -;; This is based on initial code provided by Jim Janney (jjanney@xmission.com) -;; - -;;; Code: -(defcustom highlight-beyond-fill-column-in-modes nil - "The list of modes in which to highlight-beyond-fill-column." - :group 'fill - :type '(repeat string) - ) - -(defcustom highlight-beyond-fill-column-face 'underline - "The face to use with highlight-beyond-fill-column." - :group 'fill - :type 'face - ) - -(defun find-after-fill-column (limit) - "A function that can be used by `font-lock-add-keywords' to find columns that are -beyond the `fill-column'." - (let ( - ; remember the point - (original-point (point)) - ) - ; if already past the fill column start on next line - (if (> (current-column) fill-column) - (forward-line 1) - ) - (while (and (< (point) limit) ; still within limit - (or (< (move-to-column fill-column) fill-column) ; the line has less than `fill-column' columns - (= (point) (line-end-position)) ; end of line - ) - ) - ; goto next line - (forward-line 1) - ) - - (if (>= (point) limit) ; beyond limit - (progn - (goto-char original-point) ; restore point - nil ; return nil - ) - (set-match-data (list (point-marker) ; set match data - (progn - (end-of-line) - (forward-char) ; this gives the highlight till the end of the window - (point-marker) - ) - ) - ) - t) ; return t indicating that the match data was set - ) - ) - -(defun init-highlight-beyond-fill-column () - "" - (let ( - (modelist highlight-beyond-fill-column-in-modes) - mode - ) - (while modelist - (setq mode (intern (car modelist))) - (if (and mode - (functionp mode)) - (font-lock-add-keywords mode - '( - (find-after-fill-column 0 highlight-beyond-fill-column-face prepend) - ) - ) - ) - (setq modelist (cdr modelist)) - ) - ) - ) - -(add-hook 'after-init-hook 'init-highlight-beyond-fill-column) - -(provide 'highlight-beyond-fill-column) diff --git a/elisp/emacs-goodies-el/highlight-completion.el b/elisp/emacs-goodies-el/highlight-completion.el deleted file mode 100755 index b14358b..0000000 --- a/elisp/emacs-goodies-el/highlight-completion.el +++ /dev/null @@ -1,1614 +0,0 @@ -;;; highlight-completion.el --- completion with highlighted provisional text -;; Copyright (c) 1991-1996 Mark Haiman, Nick Reingold, John Palmieri -;; Copyright (c) 1997-2001 John Palmieri -;; -;; Author: John Palmieri <palmieri@math.washington.edu> -;; URL: http://www.math.washington.edu/~palmieri/Emacs/hlc.html -;; Keywords: completion -;; Version: 0.08 of Fri Sep 30 12:59:03 PDT 2005 -;; -;; This file is not part of GNU Emacs. -;; -;; This package 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. -;; -;; This package 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; This package is based on the lightning completion package, -;; written by Mark Haiman and Nick Reingold, then modified by me. I -;; am the author of this package, so any problems are completely -;; my fault. All the good parts probably came from Mark and Nick's -;; original code... -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Description: -;; -;; This package modified how Emacs performs completions. Ordinarily, -;; if you are typing a file name into the minibuffer (after hitting -;; C-x C-f, say), if you type a few letters and hit the TAB key, then -;; Emacs completes as far as possible. For example, suppose the -;; directory contains only these files: -;; filbert filibuster frank grunge.tex -;; If you type 'g' followed by TAB, then 'runge.tex' is inserted. If -;; you hit 'fi' then TAB, an 'l' is inserted. If you hit 'f' then TAB, -;; there is no unique continuation of the file name, so Emacs opens up -;; a new window displaying the list of possible completions. -;; -;; That's the old system. This package provides a variant: if you -;; type 'g', then 'runge.tex' is automatically inserted as highlighted -;; text, to indicate that it's only provisional. The point remains -;; immediately after the 'g'. If you hit TAB, the point jumps to the -;; end, and the added text is no longer highlighted. (So if you -;; weren't looking at the screen, you wouldn't know that anything -;; different had happened.) If after hitting 'g', you typed 'a' -;; (because you wanted to find a new file 'gaptooth.el') the -;; highlighted text would disappear. The effects of various keys: -;; TAB: jump forward to the end of the highlighted text. If no -;; text is highlighted, open up a window showing possible -;; completions. -;; SPC: jump forward a word (so 'g' followed by SPC would yield -;; 'grunge.tex', with the point after the '.', and with 'tex' -;; highlighted). If no text is highlighted, open up a window -;; showing possible completions. -;; ?: open up a window showing possible completions. -;; RET: open the named file (so 'g' followed by RET would open -;; 'grunge.tex'). -;; C-g: delete the highlighted text and stop this modified -;; completion process (and exit the minibuffer, if you're in the -;; minibuffer). -;; C-c: delete the highlighted text and stop this modified -;; completion process. -;; character: if consistent with completion, unhighlight it and -;; move the point forward. if inconsistent, insert the -;; character and delete the highlighted text, stopping this -;; completion process. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; How to use: -;; -;; 1. Put this file (i.e., "highlight-completion.el") in your load-path. -;; 2. Put -;; (require 'highlight-completion) -;; in your .emacs file (or your .xemacs/init.el file) -;; 3. Turn on highlight completion by either running -;; M-x highlight-completion-mode -;; or putting this in your .emacs file: -;; (highlight-completion-mode 1) -;; or customizing variables: -;; M-x customize-group highlight-completion -;; Then turn on "Highlight completion mode". -;; You may want to modify some of the entries in "Highlight completion list". -;; 4. You can also run the functions -;; hc-complete-file-name to complete file names -;; hc-complete-lisp-function lisp functions -;; hc-complete-lisp-variable lisp variables -;; hc-complete-kill-ring contents of kill ring -;; hc-complete-buffer-contents buffer contents -;; hc-complete-word words, using ispell -;; These functions can be used anywhere, not just in the -;; minibuffer. If the variable hc-ctrl-x-c-is-completion is -;; non-nil, then these functions are bound to keys, with prefix -;; `C-x c' (not to be confused with `C-x C-c', of course). See the -;; documentation of that customizable variable for more -;; information. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; In case you want to write a function that uses highlight completion -;; in some other setting, you will want to base your function on the -;; all-purpose completion function -;; -;; hc-completing-insert -;; -;; See its documentation string for a description. The function -;; hc-ispell-complete-word provides a good example of how to use -;; this when there is an easily available list of possible -;; completions. The ispell package provides the function lookup-words -;; which does this. To use this with lightning completion, one only -;; has to write a function that acts as a wrapper for lookup-words and -;; is suitable for use as the TABLE argument in hc-completing-insert. -;; -;; Completion on buffer contents is another, more involved, example. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Lightning completion, on which this is based, works with a package -;; called Ultra-TeX to provide dynamic completion of TeX commands. I -;; will work on adding highlight completion as an option for -;; Ultra-TeX mode. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Version history -;; -;; 0.01 (30-May-2001) first version. -;; 0.02 (30-May-2001) tinkering. -;; 0.03 (31-May-2001) tinkering. -;; 0.04 (31-May-2001) use overlays instead of text-properties in GNU Emacs. -;; 0.05 (21-Jun-2001) add function hc-ispell-complete-word -;; 0.06 (21-Jun-2001) new customization procedure. see above. some -;; bug fixes, too. -;; 0.07 (22-Jun-2001) renamed `hc-completing-insert-BLAH' to `hc-complete-BLAH'. -;; also added a bit more documentation. -;; 0.08 (30-Sep-2005) bug fix for GNU Emacs version 22. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defconst hc-version-string "0.07" - "Version of highlighting completion package.") - -(defconst hc-version hc-version-string - "Version of highlighting completion package.") - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Customization -;; - -(defgroup highlight-completion nil - "Highlight completion mode: display completion as highlighted text." - :tag "Highlight completion" - :prefix "hc" - :link '(url-link :tag "Home Page" "http://www.math.washington.edu/~palmieri/Emacs/hlc.html") - :group 'abbrev) - -(defconst hc-xemacs-p - (string-match "XEmacs\\|Lucid" emacs-version) - "Non-nil if using XEmacs.") - -(defconst hc-emacs-20-p - (and (boundp 'emacs-major-version) - (= emacs-major-version 20)) - "Non-nil if using Emacs 20.") - -(defconst hc-emacs-21-p - (and (boundp 'emacs-major-version) - (not hc-xemacs-p) - (>= emacs-major-version 21)) - "Non-nil if using GNU Emacs 21 or later.") - -(defcustom highlight-completion-mode nil - "Toggle whether `highlighting' is on. -If on, you may want to customize highlight-completion-list to specify -contexts in which to use highlighting. If off, you can still -run functions like hc-complete-file-name or -hc-complete-a-la-mode to use this completion." - :type '(boolean) - :set (lambda (symbol value) - (highlight-completion-mode (if value 1 -1))) - :initialize 'custom-initialize-default - :require 'highlight-completion - :group 'highlight-completion) - -(defun highlight-completion-mode (&optional prefix) - "Activate highlight-completion. Deactivates with negative universal -argument." - (interactive "p") - (or prefix (setq prefix 0)) - (cond ((>= prefix 0) - (setq highlight-completion-mode t) - (add-hook 'minibuffer-setup-hook 'highlight-completion-setup)) - (t (setq highlight-completion-mode nil)))) - -(defconst highlight-completion-list-default - '((files . t) - (functions . t) - (commands . t) - (variables . t) - (user-variables . t) - (lisp-objects . t) - (info-menu-items . t) - (buffers . t) - (query . nil) - (misc . nil)) - "default value of highlight-completion-list") - -(defun hc-convert-completion-list (list) - "Convert LIST (which should be highlight-completion-list-external) -to a list of (symbol . boolean) pairs." - (let ((hc-list highlight-completion-list-default) - (temp list) - answer) - (if (< (length temp) (length hc-list)) - (setq temp (append temp (make-list - (- (length hc-list) (length temp)) - nil)))) - (while hc-list - (setq answer (cons (cons (caar hc-list) (car temp)) answer) - hc-list (cdr hc-list) - temp (cdr temp))) - (reverse answer))) - -(defun hc-unconvert-completion-list (list) - "Convert LIST (which should be highlight-completion-list) -to a list of boolean values." - (mapcar 'cdr list)) - -(defcustom highlight-completion-list-external - (hc-unconvert-completion-list highlight-completion-list-default) - "Enable highlighting completion in specific contexts. -If nil, turn off completion in that context. If t, turn on -completion. The contexts are reasonably self-explanatory: - `Files' means file name completion (e.g., after `C-x C-f'). - `Functions' means lisp function completion (e.g., after `C-h f'). - `Commands' means command completion (e.g., after `M-x'). - `Variables' means lisp variable completion (e.g., after `C-h v'). - `User variables' means completion on `user variables'--see the - documentation for the function `user-variable-p', for instance, - to see what this means. - `Lisp objects' means both funtions and variables. - `Info menu items' is what it says (e.g., after hitting `m' in info mode). - `Buffer names' is what it says (e.g., after hitting `C-x C-b'). - `Query replace' means: complete on contents of the current buffer - when asking for a string to replace when running query-replace (`M-%'). - `Miscellany' means: complete on whatever seems appropriate when - Emacs knows how to complete (e.g., in gnus, if you hit `j' to run - `gnus-jump-to-group', this will complete on group names)." - :tag "Highlight completion list" - :type '(list (boolean :tag "Files ") - (boolean :tag "Functions ") - (boolean :tag "Commands ") - (boolean :tag "Variables ") - (boolean :tag "User variables ") - (boolean :tag "Lisp objects ") - (boolean :tag "Info menu items") - (boolean :tag "Buffer names ") - (boolean :tag "Query replace ") - (boolean :tag "Miscellany ")) - :set (lambda (symbol value) - (setq highlight-completion-list - (hc-convert-completion-list value)) - (set symbol value)) - :group 'highlight-completion) - -(defvar highlight-completion-list - (hc-convert-completion-list highlight-completion-list-external) - "List of things on which to complete. -This is a list, each element of which looks like (SITUATION) -or (SITUATION . t). In the former case, highlighting completion is off -in SITUATION, and in the latter case, highlighting completion is on in -SITUATION. You can modify this list directly, but it is better -customize it.") - -(defcustom hc-ignored-file-extensions-external - completion-ignored-extensions - "File extensions to ignore when doing highlight completion" - :type '(repeat string) - :tag "Hc Ignored File Extensions" - :set (lambda (symbol value) - (setq hc-ignored-file-extensions - (concat "\\(" - (mapconcat 'regexp-quote value "\\|") - "\\)$")) - (set symbol value)) - :group 'highlight-completion) - -(defvar hc-ignored-file-extensions - (concat "\\(" - (mapconcat 'regexp-quote - hc-ignored-file-extensions-external - "\\|") - "\\)$") - "Regular expression of file extensions to ignore when doing -highlight completion.") - -(defcustom hc-word-connectors-external '("." "-" "/") - "Characters which will be added automatically when completing a word." - :type '(repeat string) - :tag "Hc Word Connectors" - :set (lambda (symbol value) - (setq hc-word-connectors - (concat "\\(" - (mapconcat 'regexp-quote value "\\|") - "\\)")) - (set symbol value)) - :group 'highlight-completion) - -(defvar hc-word-connectors - (concat "\\(" - (mapconcat 'regexp-quote - hc-word-connectors-external - "\\|") - "\\)$") - "Regular expression of characters to be added to the end when completing a word.") - -(defvar hc-completions-map (make-sparse-keymap) - "Key map for highlight completion functions.") - -(defcustom hc-ctrl-x-c-is-completion nil - "Toggle whether `C-x c' is the prefix key for the various highlight -completion commands. If on, - - C-x c b runs hc-complete-buffer-name - C-x c f runs hc-complete-lisp-function - C-x c F runs hc-complete-file-name - C-x c i runs hc-complete-word - C-x c k runs hc-complete-kill-ring - C-x c u runs hc-complete-a-la-mode - C-x c v runs hc-complete-lisp-variable - C-x c y runs hc-complete-buffer-contents - C-x c C-h lists all of the key bindings starting with C-x c - -These functions do completion on the appropriate thing in any buffer, -not just the minibuffer. This is useful for typing file names or lisp -functions or whatever. -If turned off, `C-x c' does nothing." - :type '(boolean) - :set (lambda (symbol value) - (if value - (define-key ctl-x-map "c" hc-completions-map) - (define-key ctl-x-map "c" nil)) - (set symbol value)) - :group 'highlight-completion) - -(define-key hc-completions-map "f" 'hc-complete-lisp-function) -(define-key hc-completions-map "v" 'hc-complete-lisp-variable) -(define-key hc-completions-map "o" 'hc-complete-lisp-object) -(define-key hc-completions-map "F" 'hc-complete-file-name) -(define-key hc-completions-map "u" 'hc-complete-a-la-mode) -(define-key hc-completions-map "b" 'hc-complete-buffer-name) -(define-key hc-completions-map "k" 'hc-complete-kill-ring) -(define-key hc-completions-map "y" 'hc-complete-buffer-contents) -(define-key hc-completions-map "i" 'hc-complete-word) - -(defcustom hc-ctrl-backslash-completes-a-la-mode nil - "Toggle whether `C-\\' runs the `hc-complete-a-la-mode'. -If turned on, `C-\\' runs this function, which turns on highlighting -completion. This is helpful in the minibuffer, for instance, if the -completion process has stopped and you want to start it up -again---just hit `C-\\'. -If turned off, `C-\\' does nothing." - :type '(boolean) - :set (lambda (symbol value) - (if value - (global-set-key "\C-\\" 'hc-complete-a-la-mode) - (global-set-key "\C-\\" nil)) - (set symbol value)) - :group 'highlight-completion) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Set up hc-mode, hc-mode-map, etc. -;; - -(defvar hc-mode nil - "Non-nil if using Highlight mode as a minor mode") -(make-variable-buffer-local 'hc-mode) -(or (assq 'hc-mode minor-mode-alist) - (setq minor-mode-alist (cons '(hc-mode " Highlight") - minor-mode-alist))) - -(defvar hc-mode-map nil - "Minor mode map for highlighting completion.") -(if hc-mode-map - nil - (let ((i 31) - (map (copy-keymap minibuffer-local-completion-map)) - (meta-map (make-keymap))) - (set-keymap-parent map nil) - (substitute-key-definition 'switch-to-completions - 'hc-switch-to-completions - map) - (substitute-key-definition 'switch-to-completions - 'hc-switch-to-completions - map - minibuffer-local-map) - (substitute-key-definition 'advertised-switch-to-completions - 'hc-advertised-switch-to-completions - map) - (substitute-key-definition 'advertised-switch-to-completions - 'hc-advertised-switch-to-completions - map - minibuffer-local-map) - (defalias 'hc-advertised-switch-to-completions - 'hc-switch-to-completions) - (substitute-key-definition 'exit-minibuffer - 'hc-exit-and-then - map) - (substitute-key-definition 'exit-minibuffer - 'hc-exit-and-then - map - minibuffer-local-map) - (substitute-key-definition 'keyboard-quit - 'hc-keyboard-quit - map) - (substitute-key-definition 'keyboard-quit - 'hc-keyboard-quit - map - minibuffer-local-map) - (substitute-key-definition 'abort-recursive-edit - 'hc-exit-and-then - map) - (substitute-key-definition 'abort-recursive-edit - 'hc-exit-and-then - map - minibuffer-local-map) - (substitute-key-definition 'minibuffer-keyboard-quit - 'hc-keyboard-quit - map) - (substitute-key-definition 'minibuffer-keyboard-quit - 'hc-keyboard-quit - map - minibuffer-local-map) - (substitute-key-definition 'next-history-element - 'hc-exit-and-then - map) - (substitute-key-definition 'next-history-element - 'hc-exit-and-then - map - minibuffer-local-map) - (substitute-key-definition 'previous-history-element - 'hc-exit-and-then - map) - (substitute-key-definition 'previous-history-element - 'hc-exit-and-then - map - minibuffer-local-map) - (substitute-key-definition 'minibuffer-complete - 'hc-try-to-complete - map) - (substitute-key-definition 'minibuffer-completion-help - 'hc-display-completions - map) - (if (keymapp (lookup-key map [menu-bar minibuf])) - (progn - (define-key map [menu-bar highlight] - (cons "Highlight" (make-sparse-keymap "Highlight"))) - (define-key map [menu-bar highlight tab] - '("List Completions" . hc-display-completions)) - (defalias 'hc-exit-and-then-alias 'hc-exit-and-then) - (define-key map [menu-bar highlight quit] - '("Quit" . hc-exit-and-then-alias)) - (define-key map [menu-bar highlight return] - '("Enter" . hc-exit-and-then-alias)) - (define-key map [menu-bar minibuf] 'undefined))) - (define-key map [escape] meta-map) - (while (<= (setq i (1+ i)) 126) - (or (lookup-key map (vector (list 'control i))) - (define-key map (vector (list 'control i)) - 'hc-exit-and-then)) - (or (lookup-key map (vector (list 'meta i))) - (progn - (define-key meta-map (char-to-string i) 'hc-exit-and-then) - (define-key map (vector (list 'meta i)) - 'hc-exit-and-then))) - (unless (string= (char-to-string i) "?") - (define-key map (char-to-string i) 'hc-self-insert-char))) - (define-key map [return] 'hc-exit-and-then) - (define-key map [linefeed] 'hc-exit-and-then) - (define-key map [(control j)] 'hc-exit-and-then) - (define-key map [(control g)] 'hc-keyboard-quit) - (define-key map [(control m)] 'hc-exit-and-then) - (define-key map (char-to-string 127) 'hc-exit-and-then) - (define-key map " " 'hc-keep-if-complete) - (define-key map [space] 'hc-keep-if-complete) - (define-key map [backspace] 'hc-delete) - (substitute-key-definition 'delete-backward-char - 'hc-delete - map) - (substitute-key-definition 'delete-backward-char - 'hc-delete - map - global-map) - (define-key map [tab] 'hc-try-to-complete) - (define-key map [(control c)] 'hc-quit) - (setq hc-mode-map map))) - -(defvar hc-completion-list-mode-map nil - "Local map for completion list buffers (for use with highlighting completion).") -(or hc-completion-list-mode-map - (let ((map (make-sparse-keymap))) - (define-key map [mouse-2] 'hc-mouse-choose-completion) - (define-key map [down-mouse-2] nil) - (define-key map "\C-m" 'hc-choose-completion) - (define-key map "\e\e\e" 'delete-completion-window) - (define-key map [left] 'previous-completion) - (define-key map [right] 'next-completion) - (setq hc-completion-list-mode-map map))) - -(and (boundp 'minor-mode-map-alist) - (or (assq 'hc-mode minor-mode-map-alist) - (setq minor-mode-map-alist - (cons (cons 'hc-mode hc-mode-map) - minor-mode-map-alist)))) -(make-variable-buffer-local 'hc-mode-map) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; miscellaneous variables -;; - -(defvar hc-stack nil) -(make-variable-buffer-local 'hc-stack) -(defvar hc-original-text nil) -(make-variable-buffer-local 'hc-original-text) -(defvar hc-highlighted-text nil) -(make-variable-buffer-local 'hc-highlighted-text) -(defvar hc-table nil) -(make-variable-buffer-local 'hc-table) -(defvar hc-predicate nil) -(make-variable-buffer-local 'hc-predicate) -(defvar hc-hook nil) -(make-variable-buffer-local 'hc-hook) -(defvar hc-prev-windows nil) ; state before completions window -(defvar hc-display-filter nil) -(make-variable-buffer-local 'hc-display-filter) -(defvar hc-last-display-time nil) ; "time" measured by stack top eq-ness - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; main functions -;; - -(defun hc-completing-insert (table pred init &optional hook message display) - "Highlight-complete string before point in the buffer, relative to -completion TABLE; allowing only completions that satisfy PRED. These -are used exactly as they are by `completing-read', which means this: - TABLE may be an alist, an obarray, or a function-symbol. For an -alist, PRED applies to the entries (conses). For an obarray, PRED -applies to the symbols. A function symbol will be called with a -STRING as first arg, PRED as second arg and third arg nil, t, or -`lambda'; according to third arg, the function is supposed to return -the common completion of STRING, all its completions, or the -truth-value of its completeness. In particular the function can be -like 'read-file-name-internal, with PRED the name of a directory. - Third arg INIT is the number of characters before point to complete -as the initial string. Barf immediately if this is no match. If -negative, we are resuming, so return nil unless situation at last quit -agrees with buffer before point; then restore that situation. - Optional arg HOOK is run on successful completion; gets same kind of -argument as PRED, or the complete string if TABLE is a function symbol. - On entering, message \"Completing <optional arg MESSAGE>...\" is -displayed. - Optional arg DISPLAY is a function to call on each possible -completion before displaying. If the DISPLAY function returns nil, -that string is NOT displayed." - (condition-case nil - (if (not - (or - (and (>= init 0) ; starting fresh - (prog1 ; if so, reset things and be t - t - (setq hc-stack nil) - (let ((grab (buffer-substring-no-properties - (- (point) init) (point))) - (n 0)) - (if (eq table 'hc-read-file-name-internal) - (setq hc-original-text grab - grab (hc-expand-file-name grab) - init (length grab))) - (while (<= n init) - (setq hc-stack (cons (substring grab 0 n) hc-stack)) - (setq n (1+ n)))) ; completions=part grabs - (setq hc-table table - hc-predicate pred - hc-hook hook - hc-display-filter display))) - ;; see if resuming state is consistent: - (and - hc-stack - (and - (>= (point) - (+ (point-min) (length (car hc-stack)))) - (string= (car hc-stack) - (buffer-substring-no-properties - (- (point) (length (car hc-stack))) - (point)))) - (eq table hc-table) - (equal pred hc-predicate) - (equal hook hc-hook) - (equal display hc-display-filter)))) - nil ; trying to resume inconsistently - (setq hc-mode t) - (add-hook 'mouse-leave-buffer-hook - (function (lambda nil (hc-quit 'mouse)))) - (set-buffer-modified-p (buffer-modified-p)) ; update mode line - (setq hc-prev-windows (current-window-configuration)) - (if (or (> 0 init) - (string= (car hc-stack) "") ; don't try to complete "" - (let ((stat (hc-complete-stack-top ""))) - (or (stringp stat) (prog1 nil (hc-quit stat))))) - (progn - (while nil))) ; no-op - t) ; return t except for bad resume - (quit (setq unread-command-events - (list (hc-character-to-event ?\C-g)))))) - -;; bound to [(control c)], and also called by other functions -(defun hc-quit (arg &optional quick) - "Exit highlight completion mode. -ARG nil means because of error. ARG t means because successful. ARG -other means intentional quit without being complete. Interactively, -you get the last." - (interactive '(lambda)) - (remove-hook 'mouse-leave-buffer-hook - (function (lambda nil (hc-quit 'mouse)))) - (set-buffer-modified-p (buffer-modified-p)) ; update mode line - (add-hook 'minibuffer-setup-hook 'highlight-completion-setup) - (setq hc-mode nil) - (or arg (ding)) ; yell if an error - (or (eq arg 'mouse) - (and hc-prev-windows - (or (null hc-xemacs-p) - (null (minibuffer-window-active-p (minibuffer-window)))) - (progn - (set-window-configuration hc-prev-windows) - (setq hc-prev-windows nil)))) - (and (eq arg 'choose) - (looking-at (regexp-quote (car hc-stack))) - (forward-char (length (car hc-stack)))) - (if (or (eq arg t) (eq arg 'choose)) - (let ((name (car hc-stack))) - (setq hc-stack nil) ; no resume after success - (if hc-hook ; on success, call possible hook - (funcall hc-hook - (cond ((vectorp hc-table) ; table is an obarray - (intern-soft name hc-table)) - ((listp hc-table) ; table is an alist - (assoc name hc-table)) - (t name)))) ; table is a function - (if (> (current-column) fill-column) (run-hooks 'auto-fill-hook))) - ;; unsuccessful quit: - (setq hc-last-display-time nil)) - (unless (eq arg 'keep) - (delete-char (length hc-highlighted-text))) - (hc-unhighlight) - (setq hc-stack nil) - (setq hc-highlighted-text nil)) - -(defun hc-switch-stack-top (str &optional char) - "Replace top of stack with STR, fixing buffer. If optional arg CHAR -is 't, then modify highlighting etc as though a printable character -were hit: add just a single character to the stack and re-highlight. -If CHAR is a string, then add all of STR to the stack and highlight -CHAR--this is used by hc-complete-word." - (let ((inhibit-quit t)) - (hc-unhighlight) - (if hc-original-text - (delete-backward-char (length hc-original-text)) - (delete-backward-char (length (car hc-stack)))) - (setq hc-original-text nil) - (insert str) - (if hc-highlighted-text - (delete-char (length hc-highlighted-text))) - (if char - (progn - (if (stringp char) - (progn - (setq hc-highlighted-text char) - (save-excursion (insert hc-highlighted-text)) - (hc-highlight (point) (+ (point) (length - hc-highlighted-text))) - (setcar hc-stack str)) - (if (< (length (car hc-stack)) (length str)) - (progn - (forward-char - (- (length (car hc-stack)) - (length str))) - (if (< (point) (point-max)) - (progn - (setq hc-highlighted-text - (substring str (length (car hc-stack)))) - (hc-highlight (point) (+ (point) (length hc-highlighted-text)))) - (setq hc-highlighted-text nil)) - (setcar hc-stack (substring str 0 - (min - (length (car hc-stack)) - (length str))))) - (setq hc-highlighted-text nil) - (setcar hc-stack str)))) - (setq hc-highlighted-text nil) - (setcar hc-stack str)))) - -(defvar hc-highlight-face - (if hc-xemacs-p - 'zmacs-region - 'region)) - -(defvar hc-extent nil - "In XEmacs, extent for the highlighted text. In GNU Emacs, -overlay for the highlighted text.") - -(defun hc-highlight (start end) - "Highlight text from position START to END in the current buffer." - (if hc-xemacs-p - (progn - (setq hc-extent (make-extent start end (current-buffer))) - (set-extent-face hc-extent hc-highlight-face)) - (setq hc-extent (make-overlay start end)) - (overlay-put hc-extent 'face hc-highlight-face))) - -(defun hc-unhighlight nil - "Turn off highlighting, if it's on." - (if hc-xemacs-p - (progn - (if (extent-live-p hc-extent) - (delete-extent hc-extent))) - (if hc-extent - (delete-overlay hc-extent)))) - -(defun hc-pop-stack nil - "Pop the stack, fixing buffer." - (let ((inhibit-quit t) - (old-str (cadr hc-stack)) - (new-str (car hc-stack)) - str) - (setq str (hc-complete-stack-top nil t)) - (cond ((eq str t) - (setq str hc-highlighted-text) - (hc-switch-stack-top old-str) - (if (eq (hc-complete-stack-top nil t) t) - (hc-switch-stack-top - old-str - (concat (substring new-str (length old-str)) str)))) - ((stringp str) - (hc-switch-stack-top old-str) - (if (and (hc-complete-stack-top "") - (null (string= old-str (hc-complete-stack-top nil t)))) - (hc-switch-stack-top - old-str - (substring str (length old-str))))) - (t - (hc-switch-stack-top old-str))) - (setcdr hc-stack (cddr hc-stack)))) - -(defun hc-complete-stack-top (more &optional no-modify char) - "If possible, replace what's on top of stack, and before point, with -the common completion of that extended by MORE, returning that. Return -nil if no match. If result is complete and unique, return t. If -optional arg NO-MODIFY is non-nil, don't modify the stack--just see if -it would be complete. If optional arg CHAR is non-nil, this was -called after hitting a character (which may affect the placement of -the point when done)." - (let* ((str (concat (car hc-stack) more)) - ;; t:use real table. nil:truly no completions. alist:the completions - (all (or (symbolp hc-table) - (and (> (length str) 0) (= (aref str 0) ? )) - (mapcar 'list (all-completions str hc-table hc-predicate)))) - (try (and all (try-completion - str - (if (eq all t) hc-table all) - (if (eq all t) hc-predicate)))) - (str (if (eq try t) str try))) - (and try - (progn - (or no-modify - (hc-switch-stack-top str char)) - (or (eq try t) - (try-completion str - (if (eq all t) hc-table all) - (if (eq all t) hc-predicate))))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; functions bound to keys (see also hc-quit above) -;; - -;; bound to control characters -(defun hc-exit-and-then nil - "Intentional unsuccessful quit, then put back char to be read again." - (interactive) - (setq unread-command-events (list last-command-event)) - (hc-quit 'keep)) - -(defun hc-keyboard-quit nil - "Intentional unsuccessful quit, then put back char to be read again." - (interactive) - (setq unread-command-events (list last-command-event)) - (hc-quit 'quit)) - -;; bound to printing characters -(defun hc-self-insert-char nil - "Update hc-stack, insert this char, and run hc-complete." - (interactive) - (setq hc-stack (cons (concat - (car hc-stack) - (char-to-string last-command-char)) - hc-stack)) - (insert last-command-char) - (hc-complete)) - -(defun hc-complete nil - "Complete as far as possible. If no valid completions, quit. -If no valid completions and the customizable variable hc-clean-up is -non-nil, then delete characters until a valid string remains." - (interactive) - (let ((top (hc-complete-stack-top "" nil t))) - (cond ((eq top t) - (if (string= top (car hc-stack)) - (hc-quit t))) - ((null top) - (hc-unhighlight) - (delete-char (length hc-highlighted-text)) - (setq hc-highlighted-text nil) - (hc-quit 'quit))))) - -;; bound to [space] -(defun hc-keep-if-complete nil - "Quit with success if current stack top is complete. Otherwise -insert a space." - (interactive) - (if hc-highlighted-text - (hc-complete-word) - (let (top) - (if (setq top (hc-complete-stack-top " " nil t)) - (hc-switch-stack-top (concat (car hc-stack) " ") - (substring hc-highlighted-text 1)) - (setq top (hc-complete-stack-top "" nil t)) - (if (eq top t) - (hc-quit t) - (hc-try-to-complete)))))) - -(defun hc-complete-word nil - "Complete at most one word. After one word is completed, a space or -hyphen is added, provided that matches some possible completion." - (let ((old (car hc-stack)) - (top (hc-complete-stack-top "" t)) - (old-point (point)) - diff) - (if (string= old top) - (hc-try-to-complete) - (save-excursion - (goto-char old-point) - (forward-word 1) - (if (looking-at hc-word-connectors) - (forward-char 1)) - (setq diff (- (point) old-point))) - (if (and (eq top t) - (<= (+ (length (concat old hc-highlighted-text)) - (hc-minibuffer-prompt-width)) - (+ diff old-point))) - (progn - (if hc-highlighted-text - (forward-char (length hc-highlighted-text))) - (hc-quit 'keep)) - (setq top (concat old hc-highlighted-text)) - (if (< diff (length hc-highlighted-text)) - (hc-switch-stack-top (substring top 0 (+ (length old) diff)) - (substring top (+ (length old) diff))) - (hc-switch-stack-top top)))))) - -;; bound to [backspace] -(defun hc-delete nil - "Go back one completion unit. If there is no previous unit, quit quietly." - (interactive) - (if (null (cdr hc-stack)) (hc-quit 'keep) - (hc-pop-stack))) - -;; bound to [tab] -(defun hc-try-to-complete nil - "Try to complete. Complete as far as possible. -If there are choices, pop up buffer with list. If there are no valid -completions, ding." - (interactive) - (let ((old (car hc-stack)) - (top (hc-complete-stack-top "" t))) - (cond ((string= old top) - (hc-display-completions)) - ((eq top t) - (hc-complete-stack-top "" nil nil) - (hc-quit t)) - ((null top) - (ding)) - (t - (hc-switch-stack-top top) - (if (eq t (hc-complete-stack-top "" t)) - (progn - (hc-quit t) - (hc-complete-stack-top "" nil t)) - (hc-complete-stack-top "" nil t)))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; stuff for completions buffer. -;; - -(defvar hc-completion-buffer-name " *Completions*" - "Name of buffer in which to display list of completions") - -(defun hc-display-completions (&optional jump) - "Show possible completions, just like `minibuffer-completion-help'" - (interactive) - (if (and (not (equal jump 'jump)) - (equal hc-last-display-time (car hc-stack)) - (get-buffer-window hc-completion-buffer-name)) - (let ((ow (selected-window)) - (w (get-buffer-window hc-completion-buffer-name))) - (select-window w) - (condition-case nil - (if (<= (point-max) (window-end)) - (goto-char (point-min)) - (scroll-up)) - (error (goto-char (point-min)))) - (select-window ow)) - (setq hc-last-display-time (car hc-stack)) - (let ((all (all-completions (car hc-stack) hc-table hc-predicate)) - results ans) - (if (not (fboundp hc-display-filter)) nil - (while all - (setq ans (funcall hc-display-filter (car all))) - (and ans - (setq results (cons ans results))) - (setq all (cdr all))) - (setq all (nreverse results))) - (if all - (hc-display-completions-internal all))))) - -(defun hc-switch-to-completions () - "Select the completion list window." - (interactive) - ;; Make sure we have a completions window. - (hc-display-completions 'jump) - (select-window (get-buffer-window hc-completion-buffer-name)) - (goto-char (point-min)) - (search-forward "\n\n") - (forward-line 1)) - -(defun hc-choose-completion () - "Choose the completion that point is in or next to. -Just like choose-completion, except this calls -hc-choose-completion-string instead of choose-completion-string." - (interactive) - (let (beg end completion (buffer completion-reference-buffer) - (base-size completion-base-size)) - (if (and (not (eobp)) (get-text-property (point) 'mouse-face)) - (setq end (point) beg (1+ (point)))) - (if (and (not (bobp)) (get-text-property (1- (point)) 'mouse-face)) - (setq end (1- (point)) beg (point))) - (if (null beg) - (error "No completion here")) - (setq beg (previous-single-property-change beg 'mouse-face)) - (setq end (or (next-single-property-change end 'mouse-face) - (point-max))) - (setq completion (buffer-substring-no-properties beg end)) - (let ((owindow (selected-window))) - (if (and (one-window-p t 'selected-frame) - (window-dedicated-p (selected-window))) - ;; This is a special buffer's frame - (iconify-frame (selected-frame)) - (or (window-dedicated-p (selected-window)) - (bury-buffer))) - (select-window owindow)) - (hc-choose-completion-string completion buffer base-size))) - -(defun hc-mouse-choose-completion (event) - "Click on an alternative in the `*Completions*' buffer to choose it. -Just like mouse-choose-completion, except this calls -hc-choose-completion-string instead of choose-completion-string." - (interactive "e") - ;; Give temporary modes such as isearch a chance to turn off. - (run-hooks 'mouse-leave-buffer-hook) - (let ((buffer (window-buffer)) - choice - base-size) - (save-excursion - (set-buffer (window-buffer (posn-window (event-start event)))) - (if completion-reference-buffer - (setq buffer completion-reference-buffer)) - (setq base-size completion-base-size) - (save-excursion - (goto-char (posn-point (event-start event))) - (let (beg end) - (if (and (not (eobp)) (get-text-property (point) 'mouse-face)) - (setq end (point) beg (1+ (point)))) - (if (null beg) - (error "No completion here")) - (setq beg (previous-single-property-change beg 'mouse-face)) - (setq end (or (next-single-property-change end 'mouse-face) - (point-max))) - (setq choice (buffer-substring-no-properties beg end))))) - (let ((owindow (selected-window))) - (select-window (posn-window (event-start event))) - (if (and (one-window-p t 'selected-frame) - (window-dedicated-p (selected-window))) - ;; This is a special buffer's frame - (iconify-frame (selected-frame)) - (or (window-dedicated-p (selected-window)) - (bury-buffer))) - (select-window owindow)) - (hc-choose-completion-string choice buffer base-size))) - -(defun hc-choose-completion-string (choice &optional buffer base-size) - "Like choose-completion-string (from simple.el), with some stuff to -make it work well (it says here) with highlighting completion." - (let ((buffer (or buffer completion-reference-buffer))) - ;; If BUFFER is a minibuffer, barf unless it's the currently - ;; active minibuffer. - (if (and (string-match "\\` \\*Minibuf-[0-9]+\\*\\'" (buffer-name buffer)) - (or (not (active-minibuffer-window)) - (not (equal buffer - (window-buffer (active-minibuffer-window)))))) - (error "Minibuffer is not active for completion") - ;; Insert the completion into the buffer where completion was requested. - (set-buffer buffer) - (if base-size - (delete-region (+ base-size (point-min)) (point)) - (choose-completion-delete-max-match choice)) - (insert choice) -; (remove-text-properties (- (point) (length choice)) (point) -; '(mouse-face nil)) - (if (string-match (regexp-quote (car hc-stack)) choice) - (setq hc-stack (cons choice hc-stack)) - (setq hc-stack (cons (concat (car hc-stack) choice) - hc-stack))) - ;; choice may be part of a multiline string (e.g. in ultra-tex), - ;; so complete - (if (hc-complete-stack-top "" t) - (hc-complete-stack-top "")) - ;; Update point in the window that BUFFER is showing in. - (let ((window (get-buffer-window buffer t))) - (set-window-point window (point))) - ;; If completing for the minibuffer, exit it with this choice. - (if (and (equal buffer (window-buffer (minibuffer-window))) - minibuffer-completion-table) - ;; If this is reading a file name, and the file name chosen - ;; is a directory, don't exit the minibuffer. - (if (and (eq minibuffer-completion-table 'read-file-name-internal) - (file-directory-p (buffer-string))) - (select-window (active-minibuffer-window)) - (exit-minibuffer)) - (and hc-prev-windows - (hc-quit 'choose)))))) - -(defvar hc-completion-fixup-function nil - "A function to customize how completions are identified in completion lists. -`hc-completion-setup-function' calls this function with no arguments -each time it has found what it thinks is one completion. -Point is at the end of the completion in the completion list buffer. -If this function moves point, it can alter the end of that completion.") - -(defvar hc-completion-message-function - 'hc-completion-default-message-function - "A function to give the text at the top of the *Completions* -buffer. Called by `hc-completion-setup-function'.") - -(defun hc-completion-default-message-function nil - "Standard message function for hc-completion-setup-function." - (if (hc-window-system) - (insert (substitute-command-keys - "Click \\[hc-mouse-choose-completion] on a completion to select it.\n"))) - (insert (substitute-command-keys - "In this buffer, type \\[hc-choose-completion] to \ -select the completion near point.\n\n")) - (forward-line 1)) - -(defun hc-completion-setup-function () - "Like completion-setup-function (from simple.el), except with -slightly different messages." - (save-excursion - (let ((mainbuf (current-buffer))) - (set-buffer standard-output) - (completion-list-mode) - (make-local-variable 'completion-reference-buffer) - (setq completion-reference-buffer mainbuf) - ;; The value 0 is right in most cases, but not for file name completion. - ;; so this has to be turned off. - ;; (setq completion-base-size 0) - (goto-char (point-min)) - (if hc-completion-message-function - (funcall hc-completion-message-function)) - (while (re-search-forward "[^ \t\n]+\\( [^ \t\n]+\\)*" nil t) - (let ((beg (match-beginning 0)) - (end (point))) - (if hc-completion-fixup-function - (funcall hc-completion-fixup-function)) - (put-text-property beg (point) 'mouse-face 'highlight) - (goto-char end)))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; utilities -;; - -(defun word-grabber nil - "Move point to just after the word point is in or after, and -return length of word." - (skip-chars-forward "^ \n\t\f\"`'();{}") - (- (point) (save-excursion (skip-chars-backward "^ \n\t\f\"`'();{}") - (point)))) - -(defun point-adjust-hook (arg) - "Intended to be used when hc-table is an alist whose elements look -like `(<string> <number> . <hook>)'. Move point forward <number> -chars, and then run <hook> (if non-nil)." - (forward-char (car (cdr arg))) - (if (cdr (cdr arg)) (funcall (cdr (cdr arg))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; entry points for completion on various things. see also -;; hc-complete-buffer-contents below. -;; - -(defun hc-complete-lisp-object nil - "Complete lisp object in buffer at point." - (interactive) - (hc-completing-insert obarray nil (word-grabber) nil "lisp objects")) - -(defun hc-complete-lisp-function nil - "Complete lisp object in buffer at point." - (interactive) - (hc-completing-insert obarray 'fboundp (word-grabber) nil "functions")) - -(defun hc-complete-lisp-variable nil - "Complete lisp object in buffer at point." - (interactive) - (hc-completing-insert obarray 'boundp (word-grabber) nil "variables")) - -(defun hc-complete-buffer-name nil - "Complete buffer name in buffer at point." - (interactive) - (hc-completing-insert (mapcar (function (lambda (x) (list (buffer-name x)))) - (buffer-list)) - nil (word-grabber) nil "buffer names")) - -(defun hc-complete-kill-ring nil - "Complete something from the kill ring in buffer at point." - (interactive) - (hc-completing-insert - (mapcar 'list - (apply 'append - (mapcar - (function - (lambda (x) - (cons x (and (string-match "\\s-+" x) - (list (substring x (match-end 0))))))) - kill-ring))) - nil 0 nil "recent kills")) - -(defun hc-complete-word nil - "Complete the current word using ispell." - (interactive) - (hc-completing-insert 'hc-lookup-words nil - (word-grabber) nil - "words")) - -(defun hc-lookup-words (string pred flag) - "Complete STRING a la ispell-complete-word. PRED will always be -nil--it's there for compatibility purposes. If FLAG is non-nil, return -all possible completions. If FLAG is nil, complete as far as -possible. If there is a unique completion, return it. If STRING -equals the unique completion, return t." - (require 'ispell) - (let ((word-list (lookup-words string)) - (guess string)) - (if flag word-list - (if (zerop (length word-list)) - nil - (if (= 1 (length word-list)) - (or (string= string (car word-list)) - (car word-list)) - (while (and (not (string= guess (car word-list))) - (not (member nil - (mapcar - (function - (lambda (word) - (string-match (regexp-quote - (substring - (car word-list) - 0 (1+ (length - guess)))) - word))) - word-list)))) - (setq guess (substring (car word-list) - 0 (1+ (length guess))))) - guess))))) - -(defalias 'hc-completing-insert-lisp-object 'hc-complete-lisp-object) -(defalias 'hc-completing-insert-lisp-function 'hc-complete-lisp-function) -(defalias 'hc-completing-insert-lisp-variable 'hc-complete-lisp-variable) -(defalias 'hc-completing-insert-buffer-name 'hc-complete-buffer-name) -(defalias 'hc-completing-insert-kill 'hc-complete-kill-ring) -(defalias 'hc-completing-insert-file-name 'hc-complete-file-name) -(defalias 'hc-completing-insert-buffer-contents 'hc-complete-buffer-contents) -(defalias 'hc-ispell-complete-word 'hc-complete-word) -(defalias 'hc-completing-insert-according-to-mode 'hc-complete-a-la-mode) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; completion a la mode -;; - -(defun hc-complete-a-la-mode nil - "Start highlighting completion. If possible, resumes stopped completion. -Otherwise, in the minibuffer, uses its table and predicate (slightly -modified for file name reading). Failing that, calls -`hc-default-completion-function' if the mode has it set. Final default -is lisp-object completion." - (interactive) - (cond ((hc-completing-insert hc-table hc-predicate -1 hc-hook) nil) - ((and (minibuffer-window-active-p (minibuffer-window)) - minibuffer-completion-table) - (let* ((table (if (eq minibuffer-completion-table - 'read-file-name-internal) - 'hc-read-file-name-internal - minibuffer-completion-table)) - (message - (cond ((eq table 'hc-read-file-name-internal) - "file names") - ((and (listp table) (bufferp (cdr (car table)))) - "buffers") - ((eq obarray table) - (cond ((not - (and (boundp - 'minibuffer-completion-predicate) - minibuffer-completion-predicate)) - "lisp objects") - ((eq 'fboundp minibuffer-completion-predicate) - "functions") - ((eq 'commandp minibuffer-completion-predicate) - "commands") - ((eq 'boundp minibuffer-completion-predicate) - "variables") - ((eq 'user-variable-p - minibuffer-completion-predicate) - "user variables"))) - (t "something"))) - (display (and (eq table 'hc-read-file-name-internal) - 'hc-file-display-filter))) - (or (hc-completing-insert table minibuffer-completion-predicate - -1) - (hc-completing-insert table minibuffer-completion-predicate - (progn (goto-char (point-max)) - (- (point) (point-min))) - nil message display)))) - ;; I moved this here to make existing minibuffer - ;; completion info take precedence over stopped completion. - ;; -- Nick Reingold 5/24/92 - ((hc-completing-insert hc-table hc-predicate -1 - hc-hook hc-display-filter) nil) - (hc-default-completion-function - (call-interactively hc-default-completion-function)) - (t (hc-complete-lisp-object)))) - -(defvar hc-default-completion-function nil - "Function to be called by M-x hc-complete-a-la-mode, -if non-nil") -(make-variable-buffer-local 'hc-default-completion-function) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; turning on highlighting -;; - -;; Customize the variable highlight-completion-mode, to turn on -;; highlighting completion. -(defun highlight-completion-setup () - (interactive) - (let ((pred minibuffer-completion-predicate) - complete-p message table display) - (cond ((eq minibuffer-history-variable 'file-name-history) - (setq complete-p (hc-complete-p 'files) - message "file names" - table 'hc-read-file-name-internal - pred (hc-expand-file-name pred) - display 'hc-file-display-filter)) - ((eq 'fboundp minibuffer-completion-predicate) - (setq complete-p (hc-complete-p 'functions) - message "functions" - table obarray)) - ((eq 'commandp minibuffer-completion-predicate) - (setq complete-p (hc-complete-p 'commands) - message "commands" - table obarray)) - ((eq 'boundp minibuffer-completion-predicate) - (setq complete-p (hc-complete-p 'variables) - message "variables" - table obarray)) - ((eq 'user-variable-p minibuffer-completion-predicate) - (setq complete-p (hc-complete-p 'user-variables) - message "user variables" - table obarray)) - ((and (eq minibuffer-completion-table obarray) - (not (and (boundp 'minibuffer-completion-predicate) - minibuffer-completion-predicate))) - (setq complete-p (hc-complete-p 'lisp-objects) - message "lisp objects" - table obarray)) - ((eq 'Info-complete-menu-item minibuffer-completion-table) - (setq complete-p (hc-complete-p 'info-menu-items) - message "Info menu items" - table minibuffer-completion-table)) - ((eq minibuffer-history-variable 'query-replace-history) - (setq complete-p (hc-complete-p 'query) - message "buffer contents" - table 'hc-buffer-completion-internal - pred (car (cdr (buffer-list))))) - ((and (listp minibuffer-completion-table) - (listp (car minibuffer-completion-table)) - (bufferp (cdr (car minibuffer-completion-table)))) - (setq complete-p (hc-complete-p 'buffers) - message "buffers" - table minibuffer-completion-table)) - (minibuffer-completion-table - (setq complete-p (hc-complete-p 'misc) - message "something" - table minibuffer-completion-table))) - (if (and highlight-completion-mode complete-p) - (progn - (or (hc-completing-insert table pred -1) - (hc-completing-insert table pred - (progn (goto-char (point-max)) - (- (point) - (point-min) - (hc-minibuffer-prompt-width))) - nil message display)))))) - -(defun query-replace-read-args (string regexp-flag) - (hc-query-replace-read-args string regexp-flag)) - -(defun hc-query-replace-read-args (string regexp-flag) - (let (from to) - (if query-replace-interactive - (setq from (car (if regexp-flag regexp-search-ring search-ring))) - (setq from (read-from-minibuffer (format "%s: " string) - nil nil nil - 'query-replace-history))) - (remove-hook 'minibuffer-setup-hook 'highlight-completion-setup) - (condition-case () - (setq to (read-from-minibuffer (format "%s %s with: " string from) - nil nil nil - 'query-replace-history)) - (quit - (add-hook 'minibuffer-setup-hook 'highlight-completion-setup) - (error "Quit"))) - (add-hook 'minibuffer-setup-hook 'highlight-completion-setup) - (list from to current-prefix-arg))) - -(defun hc-complete-p (arg) - "Non-nil if one should do highlighting completion in environment ARG, -as determined by the value of the variable highlight-completion-list." - (cdr (assoc arg highlight-completion-list))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; file completion stuff -;; - -(defun hc-complete-file-name (&optional dir init) - "Complete file name in buffer at point. Non-interactively, use directory -DIR (nil for current default-directory); start with INIT chars before point." - (interactive (list nil (word-grabber))) - (hc-completing-insert 'hc-read-file-name-internal - (or dir default-directory) (or init 0) - nil "file names" 'hc-file-display-filter)) - -(defconst hc-literal-file-regexp - "\\(\\(^\\|/\\)\\(~[^/]*\\|\\.\\.?\\)\\|\\${?[a-zA-Z0-9]*\\)$" - "Regexp for file names which don't get completed, yet.") -(defconst hc-expand-this-file-regexp - "\\(\\${[a-zA-Z0-9]*}\\|\\(^\\|/\\)\\.\\.?/\\)$" - "Regexp for file names which get expanded before completion.") - -(defun hc-read-file-name-internal (str dir action) - "\"Internal\" subroutine for `hc-complete-file-name'. Do not -call this." - (let (str-dir real-str) - (cond ((and (null action) (string-match hc-literal-file-regexp str)) - str) - ((progn (setq real-str (hc-expand-file-name - (substitute-in-file-name str) dir) - str-dir (file-name-directory real-str)) - (not (file-directory-p str-dir))) - nil) - ((eq action t) - (mapcar (function (lambda (x) - (expand-file-name x str-dir))) - (read-file-name-internal str dir action))) - ((file-directory-p real-str) - real-str) - (t - (let* ((exp (string-match hc-expand-this-file-regexp str)) - (str (if exp real-str str)) - (ans (read-file-name-internal str dir action))) - (if (null action) - (if (and exp (eq ans t)) str ans) - (and (not exp) ans))))))) - -(defun hc-expand-file-name (name &optional dir) - "Like expand-file-name, except that if first arg NAME is something -like `bozo/.' then return `bozo/'. expand-file-name, in contrast, -would return `bozo'." - (concat (expand-file-name name dir) - (if (or (and (< 1 (length name)) - (string= "/." (substring name -2))) - (and (< 2 (length name)) - (string= "/.." (substring name -3)))) - "/"))) - -(defun hc-file-display-filter (fn) - (cond ((string-match hc-ignored-file-extensions fn) - nil) - ((file-directory-p fn) - (let ((dir (if (file-directory-p (car hc-stack)) - (car hc-stack) - (directory-file-name (car hc-stack))))) - (if (string= fn (hc-expand-file-name "./" dir)) - "./" - (if (string= fn (hc-expand-file-name "../" dir)) - "../" - (concat (file-name-nondirectory (directory-file-name fn)) - "/"))))) - (t (file-name-nondirectory fn)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; buffer completion stuff. -;; -;; This section adapts highlighting completion to complete on -;; reasonably balanced substrings of a buffer. The main entry point -;; is -;; (hc-complete-buffer-contents BUF) -;; where BUF is interactively the current buffer or, with arg, a buffer -;; specified by the user. - -(defun hc-buffer-sub-hunk (start end) - "Return substring of current buffer from START at least up to END, extended -sufficiently to be balanced if possible, but in any case not to include -more than one non-blank line past END." - (save-excursion - (goto-char end) - (skip-chars-forward "\n") - (skip-chars-forward "^\n") - (save-restriction - (narrow-to-region start (point)) - (goto-char start) - (let (n) - (while (< (point) end) - (condition-case what (goto-char (setq n (scan-sexps (point) 1))) - (error (if (or (null n) (= ?U (aref (car (cdr what)) 0))) - (goto-char (point-max)) - (forward-char 1)))))) - (buffer-substring-no-properties start (point))))) - -(defvar hc-buf-comp-internal-last nil) ; last return of a try-type call - -(defun hc-buffer-completion-internal (str buf action) - "Internal subroutine for `hc-complete-buffer-contents'. Do -not call this. - Used like `read-file-name-internal' but for completing STR as a -substring of buffer BUF. Completing with space as last char matches -anything, as long as the match is unique. ACTION nil means common -part of proper extensions of STR, up to next sexp boundary, t means -list of some of these extensions. Other means return nil (no -substring is ever considered complete)." - (and - (memq action '(nil t)) ; never complete so keep is disabled - (save-window-excursion - (let* ((obuf (prog1 (current-buffer) (set-buffer buf))) - inhibit-quit case-fold-search find (l (length str))) - (prog2 - (if (eq buf obuf) ; hide completion in progress - (progn (setq inhibit-quit t) - (delete-backward-char (length (car hc-stack))))) - (if action - (let ((oball (make-vector 37 0)) (n 700)) - (save-excursion - (goto-char (point-min)) - (while (and (< 0 (setq n (1- n))) - (search-forward str nil t)) - (intern (hc-buffer-sub-hunk (match-beginning 0) - (min (point-max) (1+ (point)))) - oball)) - (if (< 0 n) (all-completions "" oball) - '("Completions too numerous to mention!")))) - (setq ; this arranges that identical repeats - hc-buf-comp-internal-last ; of a try call do no work, speeding - (if (eq str hc-buf-comp-internal-last) str ; up hc-complete-stack-top. - (save-excursion - (goto-char (point-min)) - (or - (and - (search-forward str nil t) - (setq find (hc-buffer-sub-hunk (match-beginning 0) (point))) - (progn - (while (and (> (length find) l) (search-forward str nil t)) - (setq find (try-completion - "" - (list (list find) - (list - (buffer-substring-no-properties - (match-beginning 0) - (min (point-max) - (+ (match-beginning 0) - (length find))))))))) - find)) - (and (string-match "\\s-" (substring str -1)) - (search-forward (setq str (substring str 0 -1)) nil t) - (setq find (hc-buffer-sub-hunk (match-beginning 0) - (min (point-max) - (1+ (point))))) - (progn - (setq l (1- l)) - (while (and (> (length find) l) - (search-forward str nil t)) - (setq find (try-completion - "" - (list - (list find) - (list - (buffer-substring-no-properties - (match-beginning 0) - (min (point-max) - (+ (match-beginning 0) - (length find))))))))) - (and (> (length find) l) find)))))))) - ;; unhide: - (if (eq buf obuf) (insert (car hc-stack)))))))) - -(defun hc-complete-buffer-contents (&optional buf) - "Complete on substrings of BUF extending to sexp boundaries. String is -never complete, so exit with C-c. Once unique, space means match more. -Interactively, with arg, ask for the buffer, else current buffer." - (interactive "P") - (if (and (interactive-p) buf) - (setq buf (read-buffer "Complete from buffer: "))) - (setq buf (or buf (current-buffer))) - (hc-completing-insert 'hc-buffer-completion-internal buf 0 nil "buffer contents")) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Functions that depend on the version of Emacs. -;; - -(defun hc-character-to-event (char) - "Convert a character CHAR into an event. This just returns CHAR -in GNU Emacs 19 or 20. In XEmacs, it calls character-to-event." - (if (fboundp 'character-to-event) - (character-to-event char) - char)) - -(defun hc-window-system () - "Non-nil if using x windows" - (if (fboundp 'console-type) - (eq (console-type) 'x) - (eq window-system 'x))) - -(defun hc-minibuffer-prompt-width () - "0 unless using GNU Emacs 21, in which case minibuffer-prompt-width" - (if hc-emacs-21-p - (minibuffer-prompt-width) - 0)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; More stuff dependent on the version of emacs. This is all related -;; to displaying completions. -;; - -(defvar hc-completion-default-help-string - '(concat - (if (device-on-window-system-p) - (substitute-command-keys - "Click \\<hc-completion-list-mode-map>\\[hc-mouse-choose-completion] on a completion to select it.\n") "") - (substitute-command-keys - "Type \\<hc-mode-map>\\[hc-advertised-switch-to-completions] or \\<hc-mode-map>\\[hc-advertised-switch-to-completions] to move to this buffer, for keyboard selection.\n -In this buffer, type \\<hc-completion-list-mode-map>\\[hc-choose-completion] to -select the completion near point.\n\n")) - "For use with XEmacs only. -Form the evaluate to get a help string for completion lists. -This string is inserted at the beginning of the buffer. -See `display-completion-list'.") - -(defun hc-display-completions-internal (all) - "Run display-completion-list with appropriate modifications, -depending on whether we're using XEmacs or not." - (if hc-xemacs-p - (with-output-to-temp-buffer hc-completion-buffer-name - (display-completion-list - (sort all 'string<) - :help-string hc-completion-default-help-string)) - (let ((old-hook completion-setup-hook) - (old-map completion-list-mode-map)) - (setq completion-setup-hook - 'hc-completion-setup-function - completion-list-mode-map - hc-completion-list-mode-map) - (with-output-to-temp-buffer hc-completion-buffer-name - (display-completion-list - (sort all 'string<))) - (setq completion-setup-hook old-hook - completion-list-mode-map old-map)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(provide 'highlight-completion) - -;;; highlight-completion.el ends here diff --git a/elisp/emacs-goodies-el/highlight-current-line.el b/elisp/emacs-goodies-el/highlight-current-line.el deleted file mode 100755 index 9d6e9dd..0000000 --- a/elisp/emacs-goodies-el/highlight-current-line.el +++ /dev/null @@ -1,405 +0,0 @@ -;;; highlight-current-line.el --- highlight line where the cursor is. - -;; Copyright (c) 1997-2003 Christoph Conrad Time-stamp: <19.09.2003 20:10:05> - -;; Author: Christoph Conrad <Christoph.Conrad@gmx> -;; Created: 10 Oct 1997 -;; Version: 0.57 -;; Keywords: faces - -;; This file is not yet part of any Emacs. - -;; This program 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. - -;; This program 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 this program; if not, write to the Free Software Foundation, Inc., -;; 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; Minor mode to highlight the line the cursor is in. You can change colors -;; of foreground (text) and background. The default behaviour is to set -;; only a background color, so that font-lock fontification colors remain -;; visible (syntax coloring). Enable a buffer using the command -;; `highlight-current-line-minor-mode' and customize via: -;; -;; M-x customize-group highlight-current-line <RET>. -;; -;; You can select whether the whole line (from left to right window border) -;; is marked or only the really filled parts of the line (from left window -;; border to the last char in the line). The second behaviour is suitable -;; if it's important for you to see trailing spaces or tabs in a -;; line. Customize the variable `highlight-current-line-whole-line' (or use -;; the function `highlight-current-line-whole-line-on' retained for -;; compatibility with prior versions). -;; -;; You may enable the minor-mode automatically for (almost) all buffers by -;; customizing the variable `highlight-current-line-globally' (or using the -;; compatibility command `highlight-current-line-on'). Buffers whose -;; buffer-name match the regular expression in the customizable variable -;; `highlight-current-line-ignore-regexp' do not highlighted. You can -;; extend or redefine this regexp. This works together with the default -;; ignore function `highlight-current-line-ignore-function'. You can -;; redefine this function to implement your own criterias. - -;; (The functions `highlight-current-line-on', -;; `highlight-current-line-set-fg-color' and -;; `highlight-current-line-set-bg-color' are retained for backward -;; compatibility. There's a special color "none" defined to set no color.) - - -;;; People which made contributions or suggestions: - -;; This list is ordered by time. Latest in time first. -;; - Peter S Galbraith <psg@debian.org> -;; - Masatake Yamato <jet@gyve.org> -;; - Hrvoje Niksic <hniksic@srce.hr> -;; - Jari Aalto <jari.aalto@ntc.nokia.com> -;; - Shawn Ostermann <sdo@picard.cs.OhioU.Edu> -;; - Peter Ikier <p_ikier@infoac.rmi.de> -;; Many thanks to him for the idea. He liked this behaviour in another -;; editor ("Q"). - -;;; Installation: -;; -;; Put a copy of highlight-current-line.el/.elc into some path of -;; `load-path'. To show `load-path': <C-h v> load-path RET -;; -;; Load the file, e.g. add in ~/.emacs -;; -;; (require 'highlight-current-line) -;; -;; Enable it on a buffer using `M-x highlight-current-line-minor-mode' -;; or globally by customizing `highlight-current-line-globally'. -;; -;; Previous versions of this code worked by adding other comamnds in -;; ~/.emacs instead of using the custom interface. This is still -;; supported: -;; -;; ;; If you want to mark only to the end of line: -;; (highlight-current-line-whole-line-on nil) -;; ;; switch highlighting on -;; (highlight-current-line-on t) -;; ;; Ignore no buffer -;; (setq highlight-current-line-ignore-regexp nil) ; or set to "" -;; ;; alternate way to ignore no buffers -;; (fmakunbound 'highlight-current-line-ignore-function) -;; ;; Ignore more buffers -;; (setq highlight-current-line-ignore-regexp -;; (concat "Dilberts-Buffer\\|" -;; highlight-current-line-ignore-regexp)) - -;;; Troubleshooting: - -;; - Q: I do not see matching parens from paren.el any more! -;; - A: Check the colors from highlight-current-line or from show-paren-face -;; and choose some combination which works together. - -;;; ToDo: - -;; - highlight paragraphs, functions etc... (suggestion by Daniel Lundin -;; <daniel@emacs.org> 19 Dec 1999) -;; - provide overlay priorities -;; (overlay-put highlight-current-line-overlay 'priority 60) -;; - better way to switch off 'ignore buffer' -;; - face fore/backgroundcolor depending on major-mode -;; - better way to detect xemacs - -;; - some suggestions for default keys -;; - highlight-current-line as minor mode. Suggested by Shawn Ostermann. - -;;; Change log: - -;; 10 Sept 2003 - v0.57 <psg@debian.org> -;; - highlight-current-line-minor-mode created. -;; - highlight-current-line-globally defcustom added. - -;; 7 Sept 2003 - v0.56 -;; - defface for highlight-current-line-face with customization. -;; Thanks to Peter S. Galbraith for the suggestion. Retained -;; highlight-current-line-set-fg/bg-color for backward -;; compatibility. - -;; 7 Sept 2003 - v0.55 -;; - v0.54 change works now correctly - -;; 22 Mar 2003 - v0.54 -;; - don't highlight lines which contain faces specified in -;; highlight-current-line-high-faces. Elisp manual: "Currently, all -;; overlays take priority over text properties." So, if a text -;; property is a face, highlight-current-line always hides that face. - -;; 12 Mar 2002 - v0.53 -;; - updated email address - -;; 05 Feb 2001 -;; - highlight-current-line-ignore-regexp: better regexp for minibuffers - -;; 15 Jul 2000 - v0.52: -;; - Masatake YAMATO: added emacsclient / gnudoit support. Invoking emacs -;; to load a file from external, highlight-current-line couldn't -;; initially show the line of the loaded file highlighted. - -;; 19 Oct 1997 - v0.51: -;; - uses defcustom-library if available. Suggested by Jari Aalto and Hrvoje -;; Niksic. -;; - logic error in if-condition of post-command-hook. All Buffers were -;; ignored if highlight-current-line-ignore-function was unbound. - -;; 18 Oct 1997 - v0.5: -;; - GNU General Public License -;; - ignore user-definable buffernames which are ignored for -;; highlighting. Suggested by Jari Aalto. -;; - works with XEmacs, at least version 19.15. Mark whole line doesnt work -;; yet. Suggested by Jari Aalto. -;; - highlight-current-line-set-fg/bg-color understand "none" as color -;; - overlay-put moved from post-command-hook to initialization-code -;; - version-variable: `highlight-current-line-version'. Always -;; "major.minor". Suggested by Jari Aalto. - -;; 11 Oct 1997 - v0.4: -;; - Possibility to highlight whole line (from left to right windowborder) or -;; only from left window border to the last char in the line. -;; -;; 20 Aug 1997 - v0.3: -;; - First public released version. - -;;; Code: - -;; Initialization for XEmacs - -;; XEmacs needs overlay emulation package. -;; Old XEmacs won't have the package and we must quit. -(eval-and-compile - (if (boundp 'xemacs-logo) - (if (not (load "overlay" 'noerr)) - (error "\ -highlight-current-line.el: ** This package requires overlays. Abort")))) - -;; Compatibility code - blob for those without the custom library: -(eval-and-compile - (condition-case () - (require 'custom) - (error nil)) - (if (and (featurep 'custom) (fboundp 'custom-declare-variable)) - nil ;; We've got what we needed - ;; We have the old custom-library, hack around it! - (defmacro defgroup (&rest args) - nil) - (defmacro defcustom (var value doc &rest args) - (` (defvar (, var) (, value) (, doc)))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Variables -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; can be set by user - -(defgroup highlight-current-line nil - "Highlight line where the cursor is." - :load 'highlight-current-line - :group 'faces) ;; or 'matching?? - -(defcustom highlight-current-line-ignore-regexp - (concat - "Faces\\|Colors\\| \\*Mini" - ;; for example: - ;; "\\|RMAIL.*summary\\|\\*Group\\|\\*Summary" - ) - "*Regexps for buffers to ignore. -Used by `highlight-current-line-ignore-function'." - :type 'regexp - :group 'highlight-current-line) - -(defcustom highlight-current-line-whole-line t - "*If non-nil, mark up to `end-of-line'. If nil, mark up to window-border. -Use `highlight-current-line-whole-line-on' to set this value." - :type 'boolean - :group 'highlight-current-line) - -(defcustom highlight-current-line-high-faces '() - "*Lines containing one of this faces are not highlighted." - :type 'list - :group 'highlight-current-line) - -(defface highlight-current-line-face - '((t (:background "wheat"))) - "Face used to highlight current line." - :group 'highlight-current-line) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; should not be set by user - -(defconst highlight-current-line-version "0.57" - "Version number." ) - -(defvar highlight-current-line-minor-mode nil - "Non-nil if using highlight-current-line mode as a minor mode. -Use the command `highlight-current-line-minor-mode' to toggle or set this -variable.") -(make-variable-buffer-local 'highlight-current-line-minor-mode) - -(defvar highlight-current-line-overlay - ;; Dummy initialization - (make-overlay 1 1) - "Overlay for highlighting.") - -;; Set face-property of overlay -(overlay-put highlight-current-line-overlay - 'face 'highlight-current-line-face) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Functions -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; Internal function for test -(defun highlight-current-line-reload () - "Reload library highlight-current-line for test purposes." - (unload-feature 'highlight-current-line) - (load-library "highlight-current-line")) - -;; Decide whether to highlight the buffer. -(defun highlight-current-line-ignore-function () - "Check current buffer name against `highlight-current-line-ignore-regexp'. -Inhibits global enabling of highlight-current-line on buffer whose name -match this regexp." - (if (or (equal "" highlight-current-line-ignore-regexp) - (not highlight-current-line-ignore-regexp)) - nil - (string-match highlight-current-line-ignore-regexp (buffer-name)))) - -(defvar highlight-current-line-globally) - -;; Post-Command-Hook for highlighting -(defun highlight-current-line-hook () - "Post-Command-Hook for highlighting." - (condition-case () - (if (or highlight-current-line-minor-mode - (and highlight-current-line-globally - (or (not (fboundp 'highlight-current-line-ignore-function)) - (not (highlight-current-line-ignore-function))))) - (let ((current-point (point))) - - ;; Set overlay - (let ((beg (progn (beginning-of-line) (point))) - (end (progn (if highlight-current-line-whole-line - (forward-line 1) - (end-of-line)) - (point)))) - (if (delete nil (mapcar - (lambda( face ) - (text-property-any beg end 'face face)) - highlight-current-line-high-faces)) - (delete-overlay highlight-current-line-overlay) - (move-overlay highlight-current-line-overlay - beg end (current-buffer))) - - (goto-char current-point)))) - (error nil))) - -(defconst highlight-current-line-no-color (if (boundp 'xemacs-logo) - '[] - nil) - "'color' value that represents \"no color\".") - -;; Compatibility code -(defun highlight-current-line-on (&optional on-off) - "Switch highlighting of cursor-line on/off globally. -Key: \\[highlight-current-line-on]" - (interactive (list (y-or-n-p "Highlight line with cursor? "))) - (setq-default highlight-current-line-globally on-off) - (highlight-current-line on-off nil)) - -;; Compatibility code - Set foregroundcolor of cursor-line. -(defun highlight-current-line-set-fg-color (color) - "Set foregroundcolor for highlighting cursor-line to COLOR. -Key: \\[highlight-current-line-set-fg-color]" - (interactive "sForeground color (\"none\" means no color): ") - (if (equal "none" color) - (setq color highlight-current-line-no-color)) - (set-face-foreground 'highlight-current-line-face color)) - -;; Compatibility code - Set backgroundcolor of cursor-line. -(defun highlight-current-line-set-bg-color (color) - "Set backgroundcolor for highlighting cursor-line to COLOR. -Key: \\[highlight-current-line-set-bg-color]" - (interactive "sBackground color (\"none\" means no color): ") - (if (equal "none" color) - (setq color highlight-current-line-no-color)) - (set-face-background 'highlight-current-line-face color)) - -;; Compatibility code - Enable/Disable whole line marking -(defun highlight-current-line-whole-line-on (&optional on-off) - "Switch highlighting of whole line ON-OFF. -Key: \\[highlight-current-line-whole-line-on]" - (interactive (list (y-or-n-p "Highlight whole line? "))) - (setq highlight-current-line-whole-line on-off)) - -;; Enable/Disable Highlighting -(defun highlight-current-line (&optional on-off local) - "Switch highlighting of cursor-line ON-OFF -If LOCAL is non-nil, do so locally for the current buffer only." - (cond - (on-off - (if (or (= emacs-major-version 20) - (string-match "XEmacs" emacs-version)) - (make-local-hook 'post-command-hook)) - (add-hook 'post-command-hook 'highlight-current-line-hook nil local) - (if (boundp 'server-switch-hook) - (add-hook 'server-switch-hook 'highlight-current-line-hook nil local)) - (if (boundp 'gnuserv-visit-hook) - (add-hook 'gnuserv-visit-hook 'highlight-current-line-hook nil local))) - (t - (if (boundp 'server-switch-hook) - (remove-hook 'server-switch-hook 'highlight-current-line-hook local)) - (if (boundp 'gnuserv-visit-hook) - (remove-hook 'gnuserv-visit-hook 'highlight-current-line-hook local)) - (remove-hook 'post-command-hook 'highlight-current-line-hook t) - (delete-overlay highlight-current-line-overlay)))) - -;;;###autoload -(defun highlight-current-line-minor-mode (&optional arg) - "Toggle highlight-current-line minor mode. -With ARG, turn minor mode on if ARG is positive, off otherwise. -You can customize the face of the highlighted line and whether the entire -line is hightlighted by customizing the group highlight-current-line." - (interactive "P") - (setq highlight-current-line-minor-mode - (if (null arg) - (not highlight-current-line-minor-mode) - (> (prefix-numeric-value arg) 0))) - (if highlight-current-line-minor-mode - (highlight-current-line t t) - (highlight-current-line nil t))) - -(or (assq 'highlight-current-line-minor-mode minor-mode-alist) - (setq minor-mode-alist - (append minor-mode-alist - (list '(highlight-current-line-minor-mode " hcl"))))) - -(defcustom highlight-current-line-globally nil - "*Whether to enable `highlight-current-line-minor-mode' automatically. -This affects only files visited after this variable is set. -Buffers will not be enabled if they match the regular expression in -`highlight-current-line-ignore-regexp'." - :type 'boolean - :require 'highlight-current-line - :set (lambda (symbol value) - (set-default symbol value) - (if value - (highlight-current-line t nil) - (highlight-current-line nil nil))) - :group 'highlight-current-line) - -(provide 'highlight-current-line) - -;;; highlight-current-line.el ends here diff --git a/elisp/emacs-goodies-el/home-end.el b/elisp/emacs-goodies-el/home-end.el deleted file mode 100755 index 7f499dd..0000000 --- a/elisp/emacs-goodies-el/home-end.el +++ /dev/null @@ -1,98 +0,0 @@ -;;; home-end.el --- Alternative Home and End commands. -;; Copyright 1996 Kai Grossjohann and Toby Speight -;; Copyright 2002-2011 Toby Speight - -;; home-end.el is free software distributed under the terms of the GNU -;; General Public Licence, version 3. - - -;;; Commentary: -;; -;; Some useful bindings for Home and End keys: -;; Hit the key once to go to the beginning/end of a line, -;; hit it twice in a row to go to the beginning/end of the window, -;; three times in a row goes to the beiginning/end of the buffer. -;; N.B. there is no timeout involved. -;; -;; To use: -;; (global-set-key [end] 'home-end-end) -;; (global-set-key [home] 'home-end-home) - - -;;; History: -;; -;; Kai Grossjohann <grossjohann@ls6.informatik.uni-dortmund.de> -;; 29 Jul 96: -;; Posted to Usenet. -;; -;; Modified by Toby Speight <tms@ansa.co.uk> -;; 1996-11-14: -;; Ensure that mark is set only when moving to beginning of window, -;; and is not set again when moving to beginning of buffer. -;; -;; Modified by Toby Speight <streapadair@gmx.net>> -;; 2002-07-12: -;; Added comments and license terms (with Kai's agreement). -;; Added autoload cookies. -;; -;; 2002-07-15: -;; Use `equal' instead of `eq' at suggestion of James LewisMoss -;; <dres@debian.org>, for XEmacs compatibility. -;; -;; 2011-02-22: -;; Don't attempt to use `recent-keys' during keyboard macro definition -;; or replay. Thanks to Dima Kogan <dkogan@cds.caltech.edu> for the -;; patch. - -(defvar home-end-marker) - -;;;###autoload -(defun home-end-home (&optional arg) - "Go to beginning of line/window/buffer. -First hitting key goes to beginning of line, second in a row goes to -beginning of window, third in a row goes to beginning of buffer." - (interactive "P") - (if (or executing-kbd-macro - defining-kbd-macro) - (move-beginning-of-line arg) - (if arg - (beginning-of-buffer arg) - (let* ((keys (recent-keys)) - (len (length keys)) - (key1 (if (> len 0) (elt keys (- len 1)) nil)) - (key2 (if (> len 1) (elt keys (- len 2)) nil)) - (key3 (if (> len 2) (elt keys (- len 3)) nil)) - (key-equal-1 (equal key1 key2)) - (key-equal-2 (and key-equal-1 (equal key2 key3)))) - (cond (key-equal-2 (goto-char (point-min))) - (key-equal-1 (push-mark home-end-marker) - (move-to-window-line 0)) - (t (setq home-end-marker (copy-marker (point))) - (beginning-of-line))))))) - -;;;###autoload -(defun home-end-end (&optional arg) - "Go to end of line/window/buffer. -First hitting key goes to end of line, second in a row goes to end -of window, third in a row goes to end of buffer." - (interactive "P") - (if (or executing-kbd-macro - defining-kbd-macro) - (move-end-of-line arg) - (if arg - (beginning-of-buffer arg) - (let* ((keys (recent-keys)) - (len (length keys)) - (key1 (if (> len 0) (elt keys (- len 1)) nil)) - (key2 (if (> len 1) (elt keys (- len 2)) nil)) - (key3 (if (> len 2) (elt keys (- len 3)) nil)) - (key-equal-1 (equal key1 key2)) - (key-equal-2 (and key-equal-1 (equal key2 key3)))) - (cond (key-equal-2 (goto-char (point-max))) - (key-equal-1 (push-mark home-end-marker) - (move-to-window-line -1) - (end-of-line)) - (t (setq home-end-marker (copy-marker (point))) - (end-of-line))))))) - -(provide 'home-end) diff --git a/elisp/emacs-goodies-el/htmlize.el b/elisp/emacs-goodies-el/htmlize.el deleted file mode 100755 index 89a57b4..0000000 --- a/elisp/emacs-goodies-el/htmlize.el +++ /dev/null @@ -1,1769 +0,0 @@ -;; htmlize.el -- Convert buffer text and decorations to HTML. - -;; Copyright (C) 1997,1998,1999,2000,2001,2002,2003,2005,2006,2009 Hrvoje Niksic - -;; Author: Hrvoje Niksic <hniksic@xemacs.org> -;; Keywords: hypermedia, extensions - -;; This program 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. - -;; This program 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 this program; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; This package converts the buffer text and the associated -;; decorations to HTML. Mail to <hniksic@xemacs.org> to discuss -;; features and additions. All suggestions are more than welcome. - -;; To use this, just switch to the buffer you want HTML-ized and type -;; `M-x htmlize-buffer'. You will be switched to a new buffer that -;; contains the resulting HTML code. You can edit and inspect this -;; buffer, or you can just save it with C-x C-w. `M-x htmlize-file' -;; will find a file, fontify it, and save the HTML version in -;; FILE.html, without any additional intervention. `M-x -;; htmlize-many-files' allows you to htmlize any number of files in -;; the same manner. `M-x htmlize-many-files-dired' does the same for -;; files marked in a dired buffer. - -;; htmlize supports three types of HTML output, selected by setting -;; `htmlize-output-type': `css', `inline-css', and `font'. In `css' -;; mode, htmlize uses cascading style sheets to specify colors; it -;; generates classes that correspond to Emacs faces and uses <span -;; class=FACE>...</span> to color parts of text. In this mode, the -;; produced HTML is valid under the 4.01 strict DTD, as confirmed by -;; the W3C validator. `inline-css' is like `css', except the CSS is -;; put directly in the STYLE attribute of the SPAN element, making it -;; possible to paste the generated HTML to other documents. In `font' -;; mode, htmlize uses <font color="...">...</font> to colorize HTML, -;; which is not standard-compliant, but works better in older -;; browsers. `css' mode is the default. - -;; You can also use htmlize from your Emacs Lisp code. When called -;; non-interactively, `htmlize-buffer' and `htmlize-region' will -;; return the resulting HTML buffer, but will not change current -;; buffer or move the point. - -;; I tried to make the package elisp-compatible with multiple Emacsen, -;; specifically aiming for XEmacs 19.14+ and GNU Emacs 19.34+. Please -;; let me know if it doesn't work on some of those, and I'll try to -;; fix it. I relied heavily on the presence of CL extensions, -;; especially for cross-emacs compatibility; please don't try to -;; remove that particular dependency. When byte-compiling under GNU -;; Emacs, you're likely to get some warnings; just ignore them. - -;; The latest version should be available at: -;; -;; <http://fly.srk.fer.hr/~hniksic/emacs/htmlize.el> -;; -;; You can find a sample of htmlize's output (possibly generated with -;; an older version) at: -;; -;; <http://fly.srk.fer.hr/~hniksic/emacs/htmlize.el.html> - -;; Thanks go to the multitudes of people who have sent reports and -;; contributed comments, suggestions, and fixes. They include Ron -;; Gut, Bob Weiner, Toni Drabik, Peter Breton, Thomas Vogels, Juri -;; Linkov, Maciek Pasternacki, and many others. - -;; User quotes: "You sir, are a sick, sick, _sick_ person. :)" -;; -- Bill Perry, author of Emacs/W3 - - -;;; Code: - -(require 'cl) -(eval-when-compile - (if (string-match "XEmacs" emacs-version) - (byte-compiler-options - (warnings (- unresolved)))) - (defvar font-lock-auto-fontify) - (defvar font-lock-support-mode) - (defvar global-font-lock-mode) - (when (and (eq emacs-major-version 19) - (not (string-match "XEmacs" emacs-version))) - ;; Older versions of GNU Emacs fail to autoload cl-extra even when - ;; `cl' is loaded. - (load "cl-extra"))) - -(defconst htmlize-version "1.36") - -;; Incantations to make custom stuff work without customize, e.g. on -;; XEmacs 19.14 or GNU Emacs 19.34. -(eval-and-compile - (condition-case () - (require 'custom) - (error nil)) - (if (and (featurep 'custom) (fboundp 'custom-declare-variable)) - nil ; we've got what we needed - ;; No custom or obsolete custom, define surrogates. Define all - ;; three macros, so we don't hose another library that expects - ;; e.g. `defface' to work after (fboundp 'defcustom) succeeds. - (defmacro defgroup (&rest ignored) nil) - (defmacro defcustom (var value doc &rest ignored) - `(defvar ,var ,value ,doc)) - (defmacro defface (face value doc &rest stuff) - `(make-face ,face)))) - -(defgroup htmlize nil - "Convert buffer text and faces to HTML." - :group 'hypermedia) - -(defcustom htmlize-head-tags "" - "*Additional tags to insert within HEAD of the generated document." - :type 'string - :group 'htmlize) - -(defcustom htmlize-output-type 'css - "*Output type of generated HTML, one of `css', `inline-css', or `font'. -When set to `css' (the default), htmlize will generate a style sheet -with description of faces, and use it in the HTML document, specifying -the faces in the actual text with <span class=\"FACE\">. - -When set to `inline-css', the style will be generated as above, but -placed directly in the STYLE attribute of the span ELEMENT: <span -style=\"STYLE\">. This makes it easier to paste the resulting HTML to -other documents. - -When set to `font', the properties will be set using layout tags -<font>, <b>, <i>, <u>, and <strike>. - -`css' output is normally preferred, but `font' is still useful for -supporting old, pre-CSS browsers, and both `inline-css' and `font' for -easier embedding of colorized text in foreign HTML documents (no style -sheet to carry around)." - :type '(choice (const css) (const inline-css) (const font)) - :group 'htmlize) - -(defcustom htmlize-generate-hyperlinks t - "*Non-nil means generate the hyperlinks for URLs and mail addresses. -This is on by default; set it to nil if you don't want htmlize to -insert hyperlinks in the resulting HTML. (In which case you can still -do your own hyperlinkification from htmlize-after-hook.)" - :type 'boolean - :group 'htmlize) - -(defcustom htmlize-hyperlink-style " - a { - color: inherit; - background-color: inherit; - font: inherit; - text-decoration: inherit; - } - a:hover { - text-decoration: underline; - } -" - "*The CSS style used for hyperlinks when in CSS mode." - :type 'string - :group 'htmlize) - -(defcustom htmlize-replace-form-feeds t - "*Non-nil means replace form feeds in source code with HTML separators. -Form feeds are the ^L characters at line beginnings that are sometimes -used to separate sections of source code. If this variable is set to -`t', form feed characters are replaced with the <hr> separator. If this -is a string, it specifies the replacement to use. Note that <pre> is -temporarily closed before the separator is inserted, so the default -replacement is effectively \"</pre><hr /><pre>\". If you specify -another replacement, don't forget to close and reopen the <pre> if you -want the output to remain valid HTML. - -If you need more elaborate processing, set this to nil and use -htmlize-after-hook." - :type 'boolean - :group 'htmlize) - -(defcustom htmlize-html-charset nil - "*The charset declared by the resulting HTML documents. -When non-nil, causes htmlize to insert the following in the HEAD section -of the generated HTML: - - <meta http-equiv=\"Content-Type\" content=\"text/html; charset=CHARSET\"> - -where CHARSET is the value you've set for htmlize-html-charset. Valid -charsets are defined by MIME and include strings like \"iso-8859-1\", -\"iso-8859-15\", \"utf-8\", etc. - -If you are using non-Latin-1 charsets, you might need to set this for -your documents to render correctly. Also, the W3C validator requires -submitted HTML documents to declare a charset. So if you care about -validation, you can use this to prevent the validator from bitching. - -Needless to say, if you set this, you should actually make sure that -the buffer is in the encoding you're claiming it is in. (Under Mule -that is done by ensuring the correct \"file coding system\" for the -buffer.) If you don't understand what that means, this option is -probably not for you." - :type '(choice (const :tag "Unset" nil) - string) - :group 'htmlize) - -(defcustom htmlize-convert-nonascii-to-entities (featurep 'mule) - "*Whether non-ASCII characters should be converted to HTML entities. - -When this is non-nil, characters with codes in the 128-255 range will be -considered Latin 1 and rewritten as \"&#CODE;\". Characters with codes -above 255 will be converted to \"&#UCS;\", where UCS denotes the Unicode -code point of the character. If the code point cannot be determined, -the character will be copied unchanged, as would be the case if the -option were nil. - -When the option is nil, the non-ASCII characters are copied to HTML -without modification. In that case, the web server and/or the browser -must be set to understand the encoding that was used when saving the -buffer. (You might also want to specify it by setting -`htmlize-html-charset'.) - -Note that in an HTML entity \"&#CODE;\", CODE is always a UCS code point, -which has nothing to do with the charset the page is in. For example, -\"©\" *always* refers to the copyright symbol, regardless of charset -specified by the META tag or the charset sent by the HTTP server. In -other words, \"©\" is exactly equivalent to \"©\". - -By default, entity conversion is turned on for Mule-enabled Emacsen and -turned off otherwise. This is because Mule knows the charset of -non-ASCII characters in the buffer. A non-Mule Emacs cannot tell -whether a character with code 0xA9 represents Latin 1 copyright symbol, -Latin 2 \"S with caron\", or something else altogether. Setting this to -t without Mule means asserting that 128-255 characters always mean Latin -1. - -For most people htmlize will work fine with this option left at the -default setting; don't change it unless you know what you're doing." - :type 'sexp - :group 'htmlize) - -(defcustom htmlize-ignore-face-size 'absolute - "*Whether face size should be ignored when generating HTML. -If this is nil, face sizes are used. If set to t, sizes are ignored -If set to `absolute', only absolute size specifications are ignored. -Please note that font sizes only work with CSS-based output types." - :type '(choice (const :tag "Don't ignore" nil) - (const :tag "Ignore all" t) - (const :tag "Ignore absolute" absolute)) - :group 'htmlize) - -(defcustom htmlize-css-name-prefix "" - "*The prefix used for CSS names. -The CSS names that htmlize generates from face names are often too -generic for CSS files; for example, `font-lock-type-face' is transformed -to `type'. Use this variable to add a prefix to the generated names. -The string \"htmlize-\" is an example of a reasonable prefix." - :type 'string - :group 'htmlize) - -(defcustom htmlize-use-rgb-txt t - "*Whether `rgb.txt' should be used to convert color names to RGB. - -This conversion means determining, for instance, that the color -\"IndianRed\" corresponds to the (205, 92, 92) RGB triple. `rgb.txt' -is the X color database that maps hundreds of color names to such RGB -triples. When this variable is non-nil, `htmlize' uses `rgb.txt' to -look up color names. - -If this variable is nil, htmlize queries Emacs for RGB components of -colors using `color-instance-rgb-components' and `x-color-values'. -This can yield incorrect results on non-true-color displays. - -If the `rgb.txt' file is not found (which will be the case if you're -running Emacs on non-X11 systems), this option is ignored." - :type 'boolean - :group 'htmlize) - -(defcustom htmlize-html-major-mode nil - "The mode the newly created HTML buffer will be put in. -Set this to nil if you prefer the default (fundamental) mode." - :type '(radio (const :tag "No mode (fundamental)" nil) - (function-item html-mode) - (function :tag "User-defined major mode")) - :group 'htmlize) - -(defvar htmlize-before-hook nil - "Hook run before htmlizing a buffer. -The hook functions are run in the source buffer (not the resulting HTML -buffer).") - -(defvar htmlize-after-hook nil - "Hook run after htmlizing a buffer. -Unlike `htmlize-before-hook', these functions are run in the generated -HTML buffer. You may use them to modify the outlook of the final HTML -output.") - -(defvar htmlize-file-hook nil - "Hook run by `htmlize-file' after htmlizing a file, but before saving it.") - -(defvar htmlize-buffer-places) - -;;; Some cross-Emacs compatibility. - -;; I try to conditionalize on features rather than Emacs version, but -;; in some cases checking against the version *is* necessary. -(defconst htmlize-running-xemacs (string-match "XEmacs" emacs-version)) - -(eval-and-compile - ;; save-current-buffer, with-current-buffer, and with-temp-buffer - ;; are not available in 19.34 and in older XEmacsen. Strictly - ;; speaking, we should stick to our own namespace and define and use - ;; htmlize-save-current-buffer, etc. But non-standard special forms - ;; are a pain because they're not properly fontified or indented and - ;; because they look weird and ugly. So I'll just go ahead and - ;; define the real ones if they're not available. If someone - ;; convinces me that this breaks something, I'll switch to the - ;; "htmlize-" namespace. - (unless (fboundp 'save-current-buffer) - (defmacro save-current-buffer (&rest forms) - `(let ((__scb_current (current-buffer))) - (unwind-protect - (progn ,@forms) - (set-buffer __scb_current))))) - (unless (fboundp 'with-current-buffer) - (defmacro with-current-buffer (buffer &rest forms) - `(save-current-buffer (set-buffer ,buffer) ,@forms))) - (unless (fboundp 'with-temp-buffer) - (defmacro with-temp-buffer (&rest forms) - (let ((temp-buffer (gensym "tb-"))) - `(let ((,temp-buffer - (get-buffer-create (generate-new-buffer-name " *temp*")))) - (unwind-protect - (with-current-buffer ,temp-buffer - ,@forms) - (and (buffer-live-p ,temp-buffer) - (kill-buffer ,temp-buffer)))))))) - -;; We need a function that efficiently finds the next change of a -;; property (usually `face'), preferably regardless of whether the -;; change occurred because of a text property or an extent/overlay. -;; As it turns out, it is not easy to do that compatibly. -;; -;; Under XEmacs, `next-single-property-change' does that. Under GNU -;; Emacs beginning with version 21, `next-single-char-property-change' -;; is available and does the same. GNU Emacs 20 had -;; `next-char-property-change', which we can use. GNU Emacs 19 didn't -;; provide any means for simultaneously examining overlays and text -;; properties, so when using Emacs 19.34, we punt and fall back to -;; `next-single-property-change', thus ignoring overlays altogether. - -(cond - (htmlize-running-xemacs - ;; XEmacs: good. - (defun htmlize-next-change (pos prop &optional limit) - (next-single-property-change pos prop nil (or limit (point-max))))) - ((fboundp 'next-single-char-property-change) - ;; GNU Emacs 21: good. - (defun htmlize-next-change (pos prop &optional limit) - (next-single-char-property-change pos prop nil limit))) - ((fboundp 'next-char-property-change) - ;; GNU Emacs 20: bad, but fixable. - (defun htmlize-next-change (pos prop &optional limit) - (let ((done nil) - (current-value (get-char-property pos prop)) - newpos next-value) - ;; Loop over positions returned by next-char-property-change - ;; until the value of PROP changes or we've hit EOB. - (while (not done) - (setq newpos (next-char-property-change pos limit) - next-value (get-char-property newpos prop)) - (cond ((eq newpos pos) - ;; Possibly at EOB? Whatever, just don't infloop. - (setq done t)) - ((eq next-value current-value) - ;; PROP hasn't changed -- keep looping. - ) - (t - (setq done t))) - (setq pos newpos)) - pos))) - (t - ;; GNU Emacs 19.34: hopeless, cannot properly support overlays. - (defun htmlize-next-change (pos prop &optional limit) - (unless limit - (setq limit (point-max))) - (let ((res (next-single-property-change pos prop))) - (if (or (null res) - (> res limit)) - limit - res))))) - -;;; Transformation of buffer text: HTML escapes, untabification, etc. - -(defvar htmlize-basic-character-table - ;; Map characters in the 0-127 range to either one-character strings - ;; or to numeric entities. - (let ((table (make-vector 128 ?\0))) - ;; Map characters in the 32-126 range to themselves, others to - ;; &#CODE entities; - (dotimes (i 128) - (setf (aref table i) (if (and (>= i 32) (<= i 126)) - (char-to-string i) - (format "&#%d;" i)))) - ;; Set exceptions manually. - (setf - ;; Don't escape newline, carriage return, and TAB. - (aref table ?\n) "\n" - (aref table ?\r) "\r" - (aref table ?\t) "\t" - ;; Escape &, <, and >. - (aref table ?&) "&" - (aref table ?<) "<" - (aref table ?>) ">" - ;; Not escaping '"' buys us a measurable speedup. It's only - ;; necessary to quote it for strings used in attribute values, - ;; which htmlize doesn't do. - ;(aref table ?\") """ - ) - table)) - -;; A cache of HTML representation of non-ASCII characters. Depending -;; on availability of `encode-char' and the setting of -;; `htmlize-convert-nonascii-to-entities', this maps non-ASCII -;; characters to either "&#<code>;" or "<char>" (mapconcat's mapper -;; must always return strings). It's only filled as characters are -;; encountered, so that in a buffer with e.g. French text, it will -;; only ever contain French accented characters as keys. It's cleared -;; on each entry to htmlize-buffer-1 to allow modifications of -;; `htmlize-convert-nonascii-to-entities' to take effect. -(defvar htmlize-extended-character-cache (make-hash-table :test 'eq)) - -(defun htmlize-protect-string (string) - "HTML-protect string, escaping HTML metacharacters and I18N chars." - ;; Only protecting strings that actually contain unsafe or non-ASCII - ;; chars removes a lot of unnecessary funcalls and consing. - (if (not (string-match "[^\r\n\t -%'-;=?-~]" string)) - string - (mapconcat (lambda (char) - (cond - ((< char 128) - ;; ASCII: use htmlize-basic-character-table. - (aref htmlize-basic-character-table char)) - ((gethash char htmlize-extended-character-cache) - ;; We've already seen this char; return the cached - ;; string. - ) - ((not htmlize-convert-nonascii-to-entities) - ;; If conversion to entities is not desired, always - ;; copy the char literally. - (setf (gethash char htmlize-extended-character-cache) - (char-to-string char))) - ((< char 256) - ;; Latin 1: no need to call encode-char. - (setf (gethash char htmlize-extended-character-cache) - (format "&#%d;" char))) - ((and (fboundp 'encode-char) - ;; Must check if encode-char works for CHAR; - ;; it fails for Arabic and possibly elsewhere. - (encode-char char 'ucs)) - (setf (gethash char htmlize-extended-character-cache) - (format "&#%d;" (encode-char char 'ucs)))) - (t - ;; encode-char doesn't work for this char. Copy it - ;; unchanged and hope for the best. - (setf (gethash char htmlize-extended-character-cache) - (char-to-string char))))) - string ""))) - -(defconst htmlize-ellipsis "...") -(put-text-property 0 (length htmlize-ellipsis) 'htmlize-ellipsis t htmlize-ellipsis) - -(defun htmlize-buffer-substring-no-invisible (beg end) - ;; Like buffer-substring-no-properties, but don't copy invisible - ;; parts of the region. Where buffer-substring-no-properties - ;; mandates an ellipsis to be shown, htmlize-ellipsis is inserted. - (let ((pos beg) - visible-list invisible show next-change) - ;; Iterate over the changes in the `invisible' property and filter - ;; out the portions where it's non-nil, i.e. where the text is - ;; invisible. - (while (< pos end) - (setq invisible (get-char-property pos 'invisible) - next-change (htmlize-next-change pos 'invisible end)) - (if (not (listp buffer-invisibility-spec)) - ;; If buffer-invisibility-spec is not a list, then all - ;; characters with non-nil `invisible' property are visible. - (setq show (not invisible)) - ;; Otherwise, the value of a non-nil `invisible' property can be: - ;; 1. a symbol -- make the text invisible if it matches - ;; buffer-invisibility-spec. - ;; 2. a list of symbols -- make the text invisible if - ;; any symbol in the list matches - ;; buffer-invisibility-spec. - ;; If the match of buffer-invisibility-spec has a non-nil - ;; CDR, replace the invisible text with an ellipsis. - (let (match) - (if (symbolp invisible) - (setq match (member* invisible buffer-invisibility-spec - :key (lambda (i) - (if (symbolp i) i (car i))))) - (setq match (block nil - (dolist (elem invisible) - (let ((m (member* - elem buffer-invisibility-spec - :key (lambda (i) - (if (symbolp i) i (car i)))))) - (when m (return m)))) - nil))) - (setq show (cond ((null match) t) - ((and (cdr-safe (car match)) - ;; Conflate successive ellipses. - (not (eq show htmlize-ellipsis))) - htmlize-ellipsis) - (t nil))))) - (cond ((eq show t) - (push (buffer-substring-no-properties pos next-change) visible-list)) - ((stringp show) - (push show visible-list))) - (setq pos next-change)) - (if (= (length visible-list) 1) - ;; If VISIBLE-LIST consists of only one element, return it - ;; without concatenation. This avoids additional consing in - ;; regions without any invisible text. - (car visible-list) - (apply #'concat (nreverse visible-list))))) - -(defun htmlize-trim-ellipsis (text) - ;; Remove htmlize-ellipses ("...") from the beginning of TEXT if it - ;; starts with it. It checks for the special property of the - ;; ellipsis so it doesn't work on ordinary text that begins with - ;; "...". - (if (get-text-property 0 'htmlize-ellipsis text) - (substring text (length htmlize-ellipsis)) - text)) - -(defconst htmlize-tab-spaces - ;; A table of strings with spaces. (aref htmlize-tab-spaces 5) is - ;; like (make-string 5 ?\ ), except it doesn't cons. - (let ((v (make-vector 32 nil))) - (dotimes (i (length v)) - (setf (aref v i) (make-string i ?\ ))) - v)) - -(defun htmlize-untabify (text start-column) - "Untabify TEXT, assuming it starts at START-COLUMN." - (let ((column start-column) - (last-match 0) - (chunk-start 0) - chunks match-pos tab-size) - (while (string-match "[\t\n]" text last-match) - (setq match-pos (match-beginning 0)) - (cond ((eq (aref text match-pos) ?\t) - ;; Encountered a tab: create a chunk of text followed by - ;; the expanded tab. - (push (substring text chunk-start match-pos) chunks) - ;; Increase COLUMN by the length of the text we've - ;; skipped since last tab or newline. (Encountering - ;; newline resets it.) - (incf column (- match-pos last-match)) - ;; Calculate tab size based on tab-width and COLUMN. - (setq tab-size (- tab-width (% column tab-width))) - ;; Expand the tab. - (push (aref htmlize-tab-spaces tab-size) chunks) - (incf column tab-size) - (setq chunk-start (1+ match-pos))) - (t - ;; Reset COLUMN at beginning of line. - (setq column 0))) - (setq last-match (1+ match-pos))) - ;; If no chunks have been allocated, it means there have been no - ;; tabs to expand. Return TEXT unmodified. - (if (null chunks) - text - (when (< chunk-start (length text)) - ;; Push the remaining chunk. - (push (substring text chunk-start) chunks)) - ;; Generate the output from the available chunks. - (apply #'concat (nreverse chunks))))) - -(defun htmlize-despam-address (string) - "Replace every occurrence of '@' in STRING with @. -`htmlize-make-hyperlinks' uses this to spam-protect mailto links -without modifying their meaning." - ;; Suggested by Ville Skytta. - (while (string-match "@" string) - (setq string (replace-match "@" nil t string))) - string) - -(defun htmlize-make-hyperlinks () - "Make hyperlinks in HTML." - ;; Function originally submitted by Ville Skytta. Rewritten by - ;; Hrvoje Niksic, then modified by Ville Skytta and Hrvoje Niksic. - (goto-char (point-min)) - (while (re-search-forward - "<\\(\\(mailto:\\)?\\([-=+_.a-zA-Z0-9]+@[-_.a-zA-Z0-9]+\\)\\)>" - nil t) - (let ((address (match-string 3)) - (link-text (match-string 1))) - (delete-region (match-beginning 0) (match-end 0)) - (insert "<<a href=\"mailto:" - (htmlize-despam-address address) - "\">" - (htmlize-despam-address link-text) - "</a>>"))) - (goto-char (point-min)) - (while (re-search-forward "<\\(\\(URL:\\)?\\([a-zA-Z]+://[^;]+\\)\\)>" - nil t) - (let ((url (match-string 3)) - (link-text (match-string 1))) - (delete-region (match-beginning 0) (match-end 0)) - (insert "<<a href=\"" url "\">" link-text "</a>>")))) - -;; Tests for htmlize-make-hyperlinks: - -;; <mailto:hniksic@xemacs.org> -;; <http://fly.srk.fer.hr> -;; <URL:http://www.xemacs.org> -;; <http://www.mail-archive.com/bbdb-info@xemacs.org/> -;; <hniksic@xemacs.org> -;; <xalan-dev-sc.10148567319.hacuhiucknfgmpfnjcpg-john=doe.com@xml.apache.org> - -(defun htmlize-defang-local-variables () - ;; Juri Linkov reports that an HTML-ized "Local variables" can lead - ;; visiting the HTML to fail with "Local variables list is not - ;; properly terminated". He suggested changing the phrase to - ;; syntactically equivalent HTML that Emacs doesn't recognize. - (goto-char (point-min)) - (while (search-forward "Local Variables:" nil t) - (replace-match "Local Variables:" nil t))) - - -;;; Color handling. - -(if (fboundp 'locate-file) - (defalias 'htmlize-locate-file 'locate-file) - (defun htmlize-locate-file (file path) - (dolist (dir path nil) - (when (file-exists-p (expand-file-name file dir)) - (return (expand-file-name file dir)))))) - -(defvar htmlize-x-library-search-path - '("/usr/X11R6/lib/X11/" - "/usr/X11R5/lib/X11/" - "/usr/lib/X11R6/X11/" - "/usr/lib/X11R5/X11/" - "/usr/local/X11R6/lib/X11/" - "/usr/local/X11R5/lib/X11/" - "/usr/local/lib/X11R6/X11/" - "/usr/local/lib/X11R5/X11/" - "/usr/X11/lib/X11/" - "/usr/lib/X11/" - "/usr/local/lib/X11/" - "/usr/X386/lib/X11/" - "/usr/x386/lib/X11/" - "/usr/XFree86/lib/X11/" - "/usr/unsupported/lib/X11/" - "/usr/athena/lib/X11/" - "/usr/local/x11r5/lib/X11/" - "/usr/lpp/Xamples/lib/X11/" - "/usr/openwin/lib/X11/" - "/usr/openwin/share/lib/X11/")) - -(defun htmlize-get-color-rgb-hash (&optional rgb-file) - "Return a hash table mapping X color names to RGB values. -The keys in the hash table are X11 color names, and the values are the -#rrggbb RGB specifications, extracted from `rgb.txt'. - -If RGB-FILE is nil, the function will try hard to find a suitable file -in the system directories. - -If no rgb.txt file is found, return nil." - (let ((rgb-file (or rgb-file (htmlize-locate-file - "rgb.txt" - htmlize-x-library-search-path))) - (hash nil)) - (when rgb-file - (with-temp-buffer - (insert-file-contents rgb-file) - (setq hash (make-hash-table :test 'equal)) - (while (not (eobp)) - (cond ((looking-at "^\\s-*\\([!#]\\|$\\)") - ;; Skip comments and empty lines. - ) - ((looking-at - "[ \t]*\\([0-9]+\\)[ \t]+\\([0-9]+\\)[ \t]+\\([0-9]+\\)[ \t]+\\(.*\\)") - (setf (gethash (downcase (match-string 4)) hash) - (format "#%02x%02x%02x" - (string-to-number (match-string 1)) - (string-to-number (match-string 2)) - (string-to-number (match-string 3))))) - (t - (error - "Unrecognized line in %s: %s" - rgb-file - (buffer-substring (point) (progn (end-of-line) (point)))))) - (forward-line 1)))) - hash)) - -;; Compile the RGB map when loaded. On systems where rgb.txt is -;; missing, the value of the variable will be nil, and rgb.txt will -;; not be used. -(defvar htmlize-color-rgb-hash (htmlize-get-color-rgb-hash)) - -;;; Face handling. - -(defun htmlize-face-specifies-property (face prop) - ;; Return t if face specifies PROP, as opposed to it being inherited - ;; from the default face. The problem with e.g. - ;; `face-foreground-instance' is that it returns an instance for - ;; EVERY face because every face inherits from the default face. - ;; However, we'd like htmlize-face-{fore,back}ground to return nil - ;; when called with a face that doesn't specify its own foreground - ;; or background. - (or (eq face 'default) - (assq 'global (specifier-spec-list (face-property face prop))))) - -(defun htmlize-face-color-internal (face fg) - ;; Used only under GNU Emacs. Return the color of FACE, but don't - ;; return "unspecified-fg" or "unspecified-bg". If the face is - ;; `default' and the color is unspecified, look up the color in - ;; frame parameters. - (let* ((function (if fg #'face-foreground #'face-background)) - color) - (if (>= emacs-major-version 22) - ;; For GNU Emacs 22+ set INHERIT to get the inherited values. - (setq color (funcall function face nil t)) - (setq color (funcall function face)) - ;; For GNU Emacs 21 (which has `face-attribute'): if the color - ;; is nil, recursively check for the face's parent. - (when (and (null color) - (fboundp 'face-attribute) - (face-attribute face :inherit) - (not (eq (face-attribute face :inherit) 'unspecified))) - (setq color (htmlize-face-color-internal - (face-attribute face :inherit) fg)))) - (when (and (eq face 'default) (null color)) - (setq color (cdr (assq (if fg 'foreground-color 'background-color) - (frame-parameters))))) - (when (or (eq color 'unspecified) - (equal color "unspecified-fg") - (equal color "unspecified-bg")) - (setq color nil)) - (when (and (eq face 'default) - (null color)) - ;; Assuming black on white doesn't seem right, but I can't think - ;; of anything better to do. - (setq color (if fg "black" "white"))) - color)) - -(defun htmlize-face-foreground (face) - ;; Return the name of the foreground color of FACE. If FACE does - ;; not specify a foreground color, return nil. - (cond (htmlize-running-xemacs - ;; XEmacs. - (and (htmlize-face-specifies-property face 'foreground) - (color-instance-name (face-foreground-instance face)))) - (t - ;; GNU Emacs. - (htmlize-face-color-internal face t)))) - -(defun htmlize-face-background (face) - ;; Return the name of the background color of FACE. If FACE does - ;; not specify a background color, return nil. - (cond (htmlize-running-xemacs - ;; XEmacs. - (and (htmlize-face-specifies-property face 'background) - (color-instance-name (face-background-instance face)))) - (t - ;; GNU Emacs. - (htmlize-face-color-internal face nil)))) - -;; Convert COLOR to the #RRGGBB string. If COLOR is already in that -;; format, it's left unchanged. - -(defun htmlize-color-to-rgb (color) - (let ((rgb-string nil)) - (cond ((null color) - ;; Ignore nil COLOR because it means that the face is not - ;; specifying any color. Hence (htmlize-color-to-rgb nil) - ;; returns nil. - ) - ((string-match "\\`#" color) - ;; The color is already in #rrggbb format. - (setq rgb-string color)) - ((and htmlize-use-rgb-txt - htmlize-color-rgb-hash) - ;; Use of rgb.txt is requested, and it's available on the - ;; system. Use it. - (setq rgb-string (gethash (downcase color) htmlize-color-rgb-hash))) - (t - ;; We're getting the RGB components from Emacs. - (let ((rgb - ;; Here I cannot conditionalize on (fboundp ...) - ;; because ps-print under some versions of GNU Emacs - ;; defines its own dummy version of - ;; `color-instance-rgb-components'. - (if htmlize-running-xemacs - (mapcar (lambda (arg) - (/ arg 256)) - (color-instance-rgb-components - (make-color-instance color))) - (mapcar (lambda (arg) - (/ arg 256)) - (x-color-values color))))) - (when rgb - (setq rgb-string (apply #'format "#%02x%02x%02x" rgb)))))) - ;; If RGB-STRING is still nil, it means the color cannot be found, - ;; for whatever reason. In that case just punt and return COLOR. - ;; Most browsers support a decent set of color names anyway. - (or rgb-string color))) - -;; We store the face properties we care about into an -;; `htmlize-fstruct' type. That way we only have to analyze face -;; properties, which can be time consuming, once per each face. The -;; mapping between Emacs faces and htmlize-fstructs is established by -;; htmlize-make-face-map. The name "fstruct" refers to variables of -;; type `htmlize-fstruct', while the term "face" is reserved for Emacs -;; faces. - -(defstruct htmlize-fstruct - foreground ; foreground color, #rrggbb - background ; background color, #rrggbb - size ; size - boldp ; whether face is bold - italicp ; whether face is italic - underlinep ; whether face is underlined - overlinep ; whether face is overlined - strikep ; whether face is struck through - css-name ; CSS name of face - ) - -(defun htmlize-face-emacs21-attr (fstruct attr value) - ;; For ATTR and VALUE, set the equivalent value in FSTRUCT. - (case attr - (:foreground - (setf (htmlize-fstruct-foreground fstruct) (htmlize-color-to-rgb value))) - (:background - (setf (htmlize-fstruct-background fstruct) (htmlize-color-to-rgb value))) - (:height - (setf (htmlize-fstruct-size fstruct) value)) - (:weight - (when (string-match (symbol-name value) "bold") - (setf (htmlize-fstruct-boldp fstruct) t))) - (:slant - (setf (htmlize-fstruct-italicp fstruct) (or (eq value 'italic) - (eq value 'oblique)))) - (:bold - (setf (htmlize-fstruct-boldp fstruct) value)) - (:italic - (setf (htmlize-fstruct-italicp fstruct) value)) - (:underline - (setf (htmlize-fstruct-underlinep fstruct) value)) - (:overline - (setf (htmlize-fstruct-overlinep fstruct) value)) - (:strike-through - (setf (htmlize-fstruct-strikep fstruct) value)))) - -(defun htmlize-face-size (face) - ;; The size (height) of FACE, taking inheritance into account. - ;; Only works in Emacs 21 and later. - (let ((size-list - (loop - for f = face then (face-attribute f :inherit) - until (or (not f) (eq f 'unspecified)) - for h = (face-attribute f :height) - collect (if (eq h 'unspecified) nil h)))) - (reduce 'htmlize-merge-size (cons nil size-list)))) - -(defun htmlize-face-to-fstruct (face) - "Convert Emacs face FACE to fstruct." - (let ((fstruct (make-htmlize-fstruct - :foreground (htmlize-color-to-rgb - (htmlize-face-foreground face)) - :background (htmlize-color-to-rgb - (htmlize-face-background face))))) - (cond (htmlize-running-xemacs - ;; XEmacs doesn't provide a way to detect whether a face is - ;; bold or italic, so we need to examine the font instance. - ;; #### This probably doesn't work under MS Windows and/or - ;; GTK devices. I'll need help with those. - (let* ((font-instance (face-font-instance face)) - (props (font-instance-properties font-instance))) - (when (equalp (cdr (assq 'WEIGHT_NAME props)) "bold") - (setf (htmlize-fstruct-boldp fstruct) t)) - (when (or (equalp (cdr (assq 'SLANT props)) "i") - (equalp (cdr (assq 'SLANT props)) "o")) - (setf (htmlize-fstruct-italicp fstruct) t)) - (setf (htmlize-fstruct-strikep fstruct) - (face-strikethru-p face)) - (setf (htmlize-fstruct-underlinep fstruct) - (face-underline-p face)))) - ((fboundp 'face-attribute) - ;; GNU Emacs 21 and further. - (dolist (attr '(:weight :slant :underline :overline :strike-through)) - (let ((value (if (>= emacs-major-version 22) - ;; Use the INHERIT arg in GNU Emacs 22. - (face-attribute face attr nil t) - ;; Otherwise, fake it. - (let ((face face)) - (while (and (eq (face-attribute face attr) - 'unspecified) - (not (eq (face-attribute face :inherit) - 'unspecified))) - (setq face (face-attribute face :inherit))) - (face-attribute face attr))))) - (when (and value (not (eq value 'unspecified))) - (htmlize-face-emacs21-attr fstruct attr value)))) - (let ((size (htmlize-face-size face))) - (unless (eql size 1.0) ; ignore non-spec - (setf (htmlize-fstruct-size fstruct) size)))) - (t - ;; Older GNU Emacs. Some of these functions are only - ;; available under Emacs 20+, hence the guards. - (when (fboundp 'face-bold-p) - (setf (htmlize-fstruct-boldp fstruct) (face-bold-p face))) - (when (fboundp 'face-italic-p) - (setf (htmlize-fstruct-italicp fstruct) (face-italic-p face))) - (setf (htmlize-fstruct-underlinep fstruct) - (face-underline-p face)))) - ;; Generate the css-name property. Emacs places no restrictions - ;; on the names of symbols that represent faces -- any characters - ;; may be in the name, even ^@. We try hard to beat the face name - ;; into shape, both esthetically and according to CSS1 specs. - (setf (htmlize-fstruct-css-name fstruct) - (let ((name (downcase (symbol-name face)))) - (when (string-match "\\`font-lock-" name) - ;; Change font-lock-FOO-face to FOO. - (setq name (replace-match "" t t name))) - (when (string-match "-face\\'" name) - ;; Drop the redundant "-face" suffix. - (setq name (replace-match "" t t name))) - (while (string-match "[^-a-zA-Z0-9]" name) - ;; Drop the non-alphanumerics. - (setq name (replace-match "X" t t name))) - (when (string-match "\\`[-0-9]" name) - ;; CSS identifiers may not start with a digit. - (setq name (concat "X" name))) - ;; After these transformations, the face could come - ;; out empty. - (when (equal name "") - (setq name "face")) - ;; Apply the prefix. - (setq name (concat htmlize-css-name-prefix name)) - name)) - fstruct)) - -(defmacro htmlize-copy-attr-if-set (attr-list dest source) - ;; Expand the code of the type - ;; (and (htmlize-fstruct-ATTR source) - ;; (setf (htmlize-fstruct-ATTR dest) (htmlize-fstruct-ATTR source))) - ;; for the given list of boolean attributes. - (cons 'progn - (loop for attr in attr-list - for attr-sym = (intern (format "htmlize-fstruct-%s" attr)) - collect `(and (,attr-sym ,source) - (setf (,attr-sym ,dest) (,attr-sym ,source)))))) - -(defun htmlize-merge-size (merged next) - ;; Calculate the size of the merge of MERGED and NEXT. - (cond ((null merged) next) - ((integerp next) next) - ((null next) merged) - ((floatp merged) (* merged next)) - ((integerp merged) (round (* merged next))))) - -(defun htmlize-merge-two-faces (merged next) - (htmlize-copy-attr-if-set - (foreground background boldp italicp underlinep overlinep strikep) - merged next) - (setf (htmlize-fstruct-size merged) - (htmlize-merge-size (htmlize-fstruct-size merged) - (htmlize-fstruct-size next))) - merged) - -(defun htmlize-merge-faces (fstruct-list) - (cond ((null fstruct-list) - ;; Nothing to do, return a dummy face. - (make-htmlize-fstruct)) - ((null (cdr fstruct-list)) - ;; Optimize for the common case of a single face, simply - ;; return it. - (car fstruct-list)) - (t - (reduce #'htmlize-merge-two-faces - (cons (make-htmlize-fstruct) fstruct-list))))) - -;; GNU Emacs 20+ supports attribute lists in `face' properties. For -;; example, you can use `(:foreground "red" :weight bold)' as an -;; overlay's "face", or you can even use a list of such lists, etc. -;; We call those "attrlists". -;; -;; htmlize supports attrlist by converting them to fstructs, the same -;; as with regular faces. - -(defun htmlize-attrlist-to-fstruct (attrlist) - ;; Like htmlize-face-to-fstruct, but accepts an ATTRLIST as input. - (let ((fstruct (make-htmlize-fstruct))) - (cond ((eq (car attrlist) 'foreground-color) - ;; ATTRLIST is (foreground-color . COLOR) - (setf (htmlize-fstruct-foreground fstruct) - (htmlize-color-to-rgb (cdr attrlist)))) - ((eq (car attrlist) 'background-color) - ;; ATTRLIST is (background-color . COLOR) - (setf (htmlize-fstruct-background fstruct) - (htmlize-color-to-rgb (cdr attrlist)))) - (t - ;; ATTRLIST is a plist. - (while attrlist - (let ((attr (pop attrlist)) - (value (pop attrlist))) - (when (and value (not (eq value 'unspecified))) - (htmlize-face-emacs21-attr fstruct attr value)))))) - (setf (htmlize-fstruct-css-name fstruct) "ATTRLIST") - fstruct)) - -(defun htmlize-face-list-p (face-prop) - "Return non-nil if FACE-PROP is a list of faces, nil otherwise." - ;; If not for attrlists, this would return (listp face-prop). This - ;; way we have to be more careful because attrlist is also a list! - (cond - ((eq face-prop nil) - ;; FACE-PROP being nil means empty list (no face), so return t. - t) - ((symbolp face-prop) - ;; A symbol other than nil means that it's only one face, so return - ;; nil. - nil) - ((not (consp face-prop)) - ;; Huh? Not a symbol or cons -- treat it as a single element. - nil) - (t - ;; We know that FACE-PROP is a cons: check whether it looks like an - ;; ATTRLIST. - (let* ((car (car face-prop)) - (attrlist-p (and (symbolp car) - (or (eq car 'foreground-color) - (eq car 'background-color) - (eq (aref (symbol-name car) 0) ?:))))) - ;; If FACE-PROP is not an ATTRLIST, it means it's a list of - ;; faces. - (not attrlist-p))))) - -(defun htmlize-make-face-map (faces) - ;; Return a hash table mapping Emacs faces to htmlize's fstructs. - ;; The keys are either face symbols or attrlists, so the test - ;; function must be `equal'. - (let ((face-map (make-hash-table :test 'equal)) - css-names) - (dolist (face faces) - (unless (gethash face face-map) - ;; Haven't seen FACE yet; convert it to an fstruct and cache - ;; it. - (let ((fstruct (if (symbolp face) - (htmlize-face-to-fstruct face) - (htmlize-attrlist-to-fstruct face)))) - (setf (gethash face face-map) fstruct) - (let* ((css-name (htmlize-fstruct-css-name fstruct)) - (new-name css-name) - (i 0)) - ;; Uniquify the face's css-name by using NAME-1, NAME-2, - ;; etc. - (while (member new-name css-names) - (setq new-name (format "%s-%s" css-name (incf i)))) - (unless (equal new-name css-name) - (setf (htmlize-fstruct-css-name fstruct) new-name)) - (push new-name css-names))))) - face-map)) - -(defun htmlize-unstringify-face (face) - "If FACE is a string, return it interned, otherwise return it unchanged." - (if (stringp face) - (intern face) - face)) - -(defun htmlize-faces-in-buffer () - "Return a list of faces used in the current buffer. -Under XEmacs, this returns the set of faces specified by the extents -with the `face' property. (This covers text properties as well.) Under -GNU Emacs, it returns the set of faces specified by the `face' text -property and by buffer overlays that specify `face'." - (let (faces) - ;; Testing for (fboundp 'map-extents) doesn't work because W3 - ;; defines `map-extents' under FSF. - (if htmlize-running-xemacs - (let (face-prop) - (map-extents (lambda (extent ignored) - (setq face-prop (extent-face extent) - ;; FACE-PROP can be a face or a list of - ;; faces. - faces (if (listp face-prop) - (union face-prop faces) - (adjoin face-prop faces))) - nil) - nil - ;; Specify endpoints explicitly to respect - ;; narrowing. - (point-min) (point-max) nil nil 'face)) - ;; FSF Emacs code. - ;; Faces used by text properties. - (let ((pos (point-min)) face-prop next) - (while (< pos (point-max)) - (setq face-prop (get-text-property pos 'face) - next (or (next-single-property-change pos 'face) (point-max))) - ;; FACE-PROP can be a face/attrlist or a list thereof. - (setq faces (if (htmlize-face-list-p face-prop) - (nunion (mapcar #'htmlize-unstringify-face face-prop) - faces :test 'equal) - (adjoin (htmlize-unstringify-face face-prop) - faces :test 'equal))) - (setq pos next))) - ;; Faces used by overlays. - (dolist (overlay (overlays-in (point-min) (point-max))) - (let ((face-prop (overlay-get overlay 'face))) - ;; FACE-PROP can be a face/attrlist or a list thereof. - (setq faces (if (htmlize-face-list-p face-prop) - (nunion (mapcar #'htmlize-unstringify-face face-prop) - faces :test 'equal) - (adjoin (htmlize-unstringify-face face-prop) - faces :test 'equal)))))) - faces)) - -;; htmlize-faces-at-point returns the faces in use at point. The -;; faces are sorted by increasing priority, i.e. the last face takes -;; precedence. -;; -;; Under XEmacs, this returns all the faces in all the extents at -;; point. Under GNU Emacs, this returns all the faces in the `face' -;; property and all the faces in the overlays at point. - -(cond (htmlize-running-xemacs - (defun htmlize-faces-at-point () - (let (extent extent-list face-list face-prop) - (while (setq extent (extent-at (point) nil 'face extent)) - (push extent extent-list)) - ;; extent-list is in reverse display order, meaning that - ;; smallest ones come last. That is the order we want, - ;; except it can be overridden by the `priority' property. - (setq extent-list (stable-sort extent-list #'< - :key #'extent-priority)) - (dolist (extent extent-list) - (setq face-prop (extent-face extent)) - ;; extent's face-list is in reverse order from what we - ;; want, but the `nreverse' below will take care of it. - (setq face-list (if (listp face-prop) - (append face-prop face-list) - (cons face-prop face-list)))) - (nreverse face-list)))) - (t - (defun htmlize-faces-at-point () - (let (all-faces) - ;; Faces from text properties. - (let ((face-prop (get-text-property (point) 'face))) - (setq all-faces (if (htmlize-face-list-p face-prop) - (nreverse (mapcar #'htmlize-unstringify-face - face-prop)) - (list (htmlize-unstringify-face face-prop))))) - ;; Faces from overlays. - (let ((overlays - ;; Collect overlays at point that specify `face'. - (delete-if-not (lambda (o) - (overlay-get o 'face)) - (overlays-at (point)))) - list face-prop) - ;; Sort the overlays so the smaller (more specific) ones - ;; come later. The number of overlays at each one - ;; position should be very small, so the sort shouldn't - ;; slow things down. - (setq overlays (sort* overlays - ;; Sort by ascending... - #'< - ;; ...overlay size. - :key (lambda (o) - (- (overlay-end o) - (overlay-start o))))) - ;; Overlay priorities, if present, override the above - ;; established order. Larger overlay priority takes - ;; precedence and therefore comes later in the list. - (setq overlays (stable-sort - overlays - ;; Reorder (stably) by acending... - #'< - ;; ...overlay priority. - :key (lambda (o) - (or (overlay-get o 'priority) 0)))) - (dolist (overlay overlays) - (setq face-prop (overlay-get overlay 'face)) - (setq list (if (htmlize-face-list-p face-prop) - (nconc (nreverse (mapcar - #'htmlize-unstringify-face - face-prop)) - list) - (cons (htmlize-unstringify-face face-prop) list)))) - ;; Under "Merging Faces" the manual explicitly states - ;; that faces specified by overlays take precedence over - ;; faces specified by text properties. - (setq all-faces (nconc all-faces list))) - all-faces)))) - -;; htmlize supports generating HTML in two several fundamentally -;; different ways, one with the use of CSS and nested <span> tags, and -;; the other with the use of the old <font> tags. Rather than adding -;; a bunch of ifs to many places, we take a semi-OO approach. -;; `htmlize-buffer-1' calls a number of "methods", which indirect to -;; the functions that depend on `htmlize-output-type'. The currently -;; used methods are `doctype', `insert-head', `body-tag', and -;; `insert-text'. Not all output types define all methods. -;; -;; Methods are called either with (htmlize-method METHOD ARGS...) -;; special form, or by accessing the function with -;; (htmlize-method-function 'METHOD) and calling (funcall FUNCTION). -;; The latter form is useful in tight loops because `htmlize-method' -;; conses. -;; -;; Currently defined output types are `css' and `font'. - -(defmacro htmlize-method (method &rest args) - ;; Expand to (htmlize-TYPE-METHOD ...ARGS...). TYPE is the value of - ;; `htmlize-output-type' at run time. - `(funcall (htmlize-method-function ',method) ,@args)) - -(defun htmlize-method-function (method) - ;; Return METHOD's function definition for the current output type. - ;; The returned object can be safely funcalled. - (let ((sym (intern (format "htmlize-%s-%s" htmlize-output-type method)))) - (indirect-function (if (fboundp sym) - sym - (let ((default (intern (concat "htmlize-default-" - (symbol-name method))))) - (if (fboundp default) - default - 'ignore)))))) - -(defvar htmlize-memoization-table (make-hash-table :test 'equal)) - -(defmacro htmlize-memoize (key generator) - "Return the value of GENERATOR, memoized as KEY. -That means that GENERATOR will be evaluated and returned the first time -it's called with the same value of KEY. All other times, the cached -\(memoized) value will be returned." - (let ((value (gensym))) - `(let ((,value (gethash ,key htmlize-memoization-table))) - (unless ,value - (setq ,value ,generator) - (setf (gethash ,key htmlize-memoization-table) ,value)) - ,value))) - -;;; Default methods. - -(defun htmlize-default-doctype () - nil ; no doc-string - ;; According to DTDs published by the W3C, it is illegal to embed - ;; <font> in <pre>. This makes sense in general, but is bad for - ;; htmlize's intended usage of <font> to specify the document color. - - ;; To make generated HTML legal, htmlize's `font' mode used to - ;; specify the SGML declaration of "HTML Pro" DTD here. HTML Pro - ;; aka Silmaril DTD was a project whose goal was to produce a GPL'ed - ;; DTD that would encompass all the incompatible HTML extensions - ;; procured by Netscape, MSIE, and other players in the field. - ;; Apparently the project got abandoned, the last available version - ;; being "Draft 0 Revision 11" from January 1997, as documented at - ;; <http://imbolc.ucc.ie/~pflynn/articles/htmlpro.html>. - - ;; Since by now HTML Pro is remembered by none but the most die-hard - ;; early-web-days nostalgics and used by not even them, there is no - ;; use in specifying it. So we return the standard HTML 4.0 - ;; declaration, which makes generated HTML technically illegal. If - ;; you have a problem with that, use the `css' engine designed to - ;; create fully conforming HTML. - - "<!DOCTYPE html PUBLIC \"-//W3C//DTD HTML 4.01//EN\">" - - ;; Now-abandoned HTML Pro declaration. - ;"<!DOCTYPE HTML PUBLIC \"+//Silmaril//DTD HTML Pro v0r11 19970101//EN\">" - ) - -(defun htmlize-default-body-tag (face-map) - nil ; no doc-string - "<body>") - -;;; CSS based output support. - -;; Internal function; not a method. -(defun htmlize-css-specs (fstruct) - (let (result) - (when (htmlize-fstruct-foreground fstruct) - (push (format "color: %s;" (htmlize-fstruct-foreground fstruct)) - result)) - (when (htmlize-fstruct-background fstruct) - (push (format "background-color: %s;" - (htmlize-fstruct-background fstruct)) - result)) - (let ((size (htmlize-fstruct-size fstruct))) - (when (and size (not (eq htmlize-ignore-face-size t))) - (cond ((floatp size) - (push (format "font-size: %d%%;" (* 100 size)) result)) - ((not (eq htmlize-ignore-face-size 'absolute)) - (push (format "font-size: %spt;" (/ size 10.0)) result))))) - (when (htmlize-fstruct-boldp fstruct) - (push "font-weight: bold;" result)) - (when (htmlize-fstruct-italicp fstruct) - (push "font-style: italic;" result)) - (when (htmlize-fstruct-underlinep fstruct) - (push "text-decoration: underline;" result)) - (when (htmlize-fstruct-overlinep fstruct) - (push "text-decoration: overline;" result)) - (when (htmlize-fstruct-strikep fstruct) - (push "text-decoration: line-through;" result)) - (nreverse result))) - -(defun htmlize-css-insert-head (buffer-faces face-map) - (insert " <style type=\"text/css\">\n <!--\n") - (insert " body {\n " - (mapconcat #'identity - (htmlize-css-specs (gethash 'default face-map)) - "\n ") - "\n }\n") - (dolist (face (sort* (copy-list buffer-faces) #'string-lessp - :key (lambda (f) - (htmlize-fstruct-css-name (gethash f face-map))))) - (let* ((fstruct (gethash face face-map)) - (cleaned-up-face-name - (let ((s - ;; Use `prin1-to-string' rather than `symbol-name' - ;; to get the face name because the "face" can also - ;; be an attrlist, which is not a symbol. - (prin1-to-string face))) - ;; If the name contains `--' or `*/', remove them. - (while (string-match "--" s) - (setq s (replace-match "-" t t s))) - (while (string-match "\\*/" s) - (setq s (replace-match "XX" t t s))) - s)) - (specs (htmlize-css-specs fstruct))) - (insert " ." (htmlize-fstruct-css-name fstruct)) - (if (null specs) - (insert " {") - (insert " {\n /* " cleaned-up-face-name " */\n " - (mapconcat #'identity specs "\n "))) - (insert "\n }\n"))) - (insert htmlize-hyperlink-style - " -->\n </style>\n")) - -(defun htmlize-css-insert-text (text fstruct-list buffer) - ;; Insert TEXT colored with FACES into BUFFER. In CSS mode, this is - ;; easy: just nest the text in one <span class=...> tag for each - ;; face in FSTRUCT-LIST. - (dolist (fstruct fstruct-list) - (princ "<span class=\"" buffer) - (princ (htmlize-fstruct-css-name fstruct) buffer) - (princ "\">" buffer)) - (princ text buffer) - (dolist (fstruct fstruct-list) - (ignore fstruct) ; shut up the byte-compiler - (princ "</span>" buffer))) - -;; `inline-css' output support. - -(defun htmlize-inline-css-body-tag (face-map) - (format "<body style=\"%s\">" - (mapconcat #'identity (htmlize-css-specs (gethash 'default face-map)) - " "))) - -(defun htmlize-inline-css-insert-text (text fstruct-list buffer) - (let* ((merged (htmlize-merge-faces fstruct-list)) - (style (htmlize-memoize - merged - (let ((specs (htmlize-css-specs merged))) - (and specs - (mapconcat #'identity (htmlize-css-specs merged) " ")))))) - (when style - (princ "<span style=\"" buffer) - (princ style buffer) - (princ "\">" buffer)) - (princ text buffer) - (when style - (princ "</span>" buffer)))) - -;;; `font' tag based output support. - -(defun htmlize-font-body-tag (face-map) - (let ((fstruct (gethash 'default face-map))) - (format "<body text=\"%s\" bgcolor=\"%s\">" - (htmlize-fstruct-foreground fstruct) - (htmlize-fstruct-background fstruct)))) - -(defun htmlize-font-insert-text (text fstruct-list buffer) - ;; In `font' mode, we use the traditional HTML means of altering - ;; presentation: <font> tag for colors, <b> for bold, <u> for - ;; underline, and <strike> for strike-through. - (let* ((merged (htmlize-merge-faces fstruct-list)) - (markup (htmlize-memoize - merged - (cons (concat - (and (htmlize-fstruct-foreground merged) - (format "<font color=\"%s\">" (htmlize-fstruct-foreground merged))) - (and (htmlize-fstruct-boldp merged) "<b>") - (and (htmlize-fstruct-italicp merged) "<i>") - (and (htmlize-fstruct-underlinep merged) "<u>") - (and (htmlize-fstruct-strikep merged) "<strike>")) - (concat - (and (htmlize-fstruct-strikep merged) "</strike>") - (and (htmlize-fstruct-underlinep merged) "</u>") - (and (htmlize-fstruct-italicp merged) "</i>") - (and (htmlize-fstruct-boldp merged) "</b>") - (and (htmlize-fstruct-foreground merged) "</font>")))))) - (princ (car markup) buffer) - (princ text buffer) - (princ (cdr markup) buffer))) - -(defun htmlize-buffer-1 () - ;; Internal function; don't call it from outside this file. Htmlize - ;; current buffer, writing the resulting HTML to a new buffer, and - ;; return it. Unlike htmlize-buffer, this doesn't change current - ;; buffer or use switch-to-buffer. - (save-excursion - ;; Protect against the hook changing the current buffer. - (save-excursion - (run-hooks 'htmlize-before-hook)) - ;; Convince font-lock support modes to fontify the entire buffer - ;; in advance. - (htmlize-ensure-fontified) - (clrhash htmlize-extended-character-cache) - (clrhash htmlize-memoization-table) - (let* ((buffer-faces (htmlize-faces-in-buffer)) - (face-map (htmlize-make-face-map (adjoin 'default buffer-faces))) - ;; Generate the new buffer. It's important that it inherits - ;; default-directory from the current buffer. - (htmlbuf (generate-new-buffer (if (buffer-file-name) - (htmlize-make-file-name - (file-name-nondirectory - (buffer-file-name))) - "*html*"))) - ;; Having a dummy value in the plist allows writing simply - ;; (plist-put places foo bar). - (places '(nil nil)) - (title (if (buffer-file-name) - (file-name-nondirectory (buffer-file-name)) - (buffer-name)))) - ;; Initialize HTMLBUF and insert the HTML prolog. - (with-current-buffer htmlbuf - (buffer-disable-undo) - (insert (htmlize-method doctype) ?\n - (format "<!-- Created by htmlize-%s in %s mode. -->\n" - htmlize-version htmlize-output-type) - "<html>\n ") - (plist-put places 'head-start (point-marker)) - (insert "<head>\n" - " <title>" (htmlize-protect-string title) "</title>\n" - (if htmlize-html-charset - (format (concat " <meta http-equiv=\"Content-Type\" " - "content=\"text/html; charset=%s\">\n") - htmlize-html-charset) - "") - htmlize-head-tags) - (htmlize-method insert-head buffer-faces face-map) - (insert " </head>") - (plist-put places 'head-end (point-marker)) - (insert "\n ") - (plist-put places 'body-start (point-marker)) - (insert (htmlize-method body-tag face-map) - "\n ") - (plist-put places 'content-start (point-marker)) - (insert "<pre>\n")) - (let ((insert-text-method - ;; Get the inserter method, so we can funcall it inside - ;; the loop. Not calling `htmlize-method' in the loop - ;; body yields a measurable speed increase. - (htmlize-method-function 'insert-text)) - ;; Declare variables used in loop body outside the loop - ;; because it's faster to establish `let' bindings only - ;; once. - next-change text face-list fstruct-list trailing-ellipsis) - ;; This loop traverses and reads the source buffer, appending - ;; the resulting HTML to HTMLBUF with `princ'. This method is - ;; fast because: 1) it doesn't require examining the text - ;; properties char by char (htmlize-next-change is used to - ;; move between runs with the same face), and 2) it doesn't - ;; require buffer switches, which are slow in Emacs. - (goto-char (point-min)) - (while (not (eobp)) - (setq next-change (htmlize-next-change (point) 'face)) - ;; Get faces in use between (point) and NEXT-CHANGE, and - ;; convert them to fstructs. - (setq face-list (htmlize-faces-at-point) - fstruct-list (delq nil (mapcar (lambda (f) - (gethash f face-map)) - face-list))) - ;; Extract buffer text, sans the invisible parts. Then - ;; untabify it and escape the HTML metacharacters. - (setq text (htmlize-buffer-substring-no-invisible - (point) next-change)) - (when trailing-ellipsis - (setq text (htmlize-trim-ellipsis text))) - ;; If TEXT ends up empty, don't change trailing-ellipsis. - (when (> (length text) 0) - (setq trailing-ellipsis - (get-text-property (1- (length text)) - 'htmlize-ellipsis text))) - (setq text (htmlize-untabify text (current-column))) - (setq text (htmlize-protect-string text)) - ;; Don't bother writing anything if there's no text (this - ;; happens in invisible regions). - (when (> (length text) 0) - ;; Insert the text, along with the necessary markup to - ;; represent faces in FSTRUCT-LIST. - (funcall insert-text-method text fstruct-list htmlbuf)) - (goto-char next-change))) - - ;; Insert the epilog and post-process the buffer. - (with-current-buffer htmlbuf - (insert "</pre>") - (plist-put places 'content-end (point-marker)) - (insert "\n </body>") - (plist-put places 'body-end (point-marker)) - (insert "\n</html>\n") - (when htmlize-generate-hyperlinks - (htmlize-make-hyperlinks)) - (htmlize-defang-local-variables) - (when htmlize-replace-form-feeds - ;; Change each "\n^L" to "<hr />". - (goto-char (point-min)) - (let ((source - ;; ^L has already been escaped, so search for that. - (htmlize-protect-string "\n\^L")) - (replacement - (if (stringp htmlize-replace-form-feeds) - htmlize-replace-form-feeds - "</pre><hr /><pre>"))) - (while (search-forward source nil t) - (replace-match replacement t t)))) - (goto-char (point-min)) - (when htmlize-html-major-mode - ;; What sucks about this is that the minor modes, most notably - ;; font-lock-mode, won't be initialized. Oh well. - (funcall htmlize-html-major-mode)) - (set (make-local-variable 'htmlize-buffer-places) places) - (run-hooks 'htmlize-after-hook) - (buffer-enable-undo)) - htmlbuf))) - -;; Utility functions. - -(defmacro htmlize-with-fontify-message (&rest body) - ;; When forcing fontification of large buffers in - ;; htmlize-ensure-fontified, inform the user that he is waiting for - ;; font-lock, not for htmlize to finish. - `(progn - (if (> (buffer-size) 65536) - (message "Forcing fontification of %s..." - (buffer-name (current-buffer)))) - ,@body - (if (> (buffer-size) 65536) - (message "Forcing fontification of %s...done" - (buffer-name (current-buffer)))))) - -(defun htmlize-ensure-fontified () - ;; If font-lock is being used, ensure that the "support" modes - ;; actually fontify the buffer. If font-lock is not in use, we - ;; don't care because, except in htmlize-file, we don't force - ;; font-lock on the user. - (when (and (boundp 'font-lock-mode) - font-lock-mode) - ;; In part taken from ps-print-ensure-fontified in GNU Emacs 21. - (cond - ((and (boundp 'jit-lock-mode) - (symbol-value 'jit-lock-mode)) - (htmlize-with-fontify-message - (jit-lock-fontify-now (point-min) (point-max)))) - ((and (boundp 'lazy-lock-mode) - (symbol-value 'lazy-lock-mode)) - (htmlize-with-fontify-message - (lazy-lock-fontify-region (point-min) (point-max)))) - ((and (boundp 'lazy-shot-mode) - (symbol-value 'lazy-shot-mode)) - (htmlize-with-fontify-message - ;; lazy-shot is amazing in that it must *refontify* the region, - ;; even if the whole buffer has already been fontified. <sigh> - (lazy-shot-fontify-region (point-min) (point-max)))) - ;; There's also fast-lock, but we don't need to handle specially, - ;; I think. fast-lock doesn't really defer fontification, it - ;; just saves it to an external cache so it's not done twice. - ))) - - -;;;###autoload -(defun htmlize-buffer (&optional buffer) - "Convert BUFFER to HTML, preserving colors and decorations. - -The generated HTML is available in a new buffer, which is returned. -When invoked interactively, the new buffer is selected in the current -window. The title of the generated document will be set to the buffer's -file name or, if that's not available, to the buffer's name. - -Note that htmlize doesn't fontify your buffers, it only uses the -decorations that are already present. If you don't set up font-lock or -something else to fontify your buffers, the resulting HTML will be -plain. Likewise, if you don't like the choice of colors, fix the mode -that created them, or simply alter the faces it uses." - (interactive) - (let ((htmlbuf (with-current-buffer (or buffer (current-buffer)) - (htmlize-buffer-1)))) - (when (interactive-p) - (switch-to-buffer htmlbuf)) - htmlbuf)) - -;;;###autoload -(defun htmlize-region (beg end) - "Convert the region to HTML, preserving colors and decorations. -See `htmlize-buffer' for details." - (interactive "r") - ;; Don't let zmacs region highlighting end up in HTML. - (when (fboundp 'zmacs-deactivate-region) - (zmacs-deactivate-region)) - (let ((htmlbuf (save-restriction - (narrow-to-region beg end) - (htmlize-buffer-1)))) - (when (interactive-p) - (switch-to-buffer htmlbuf)) - htmlbuf)) - -(defun htmlize-region-for-paste (beg end) - "Htmlize the region and return just the HTML as a string. -This forces the `inline-css' style and only returns the HTML body, -but without the BODY tag. This should make it useful for inserting -the text to another HTML buffer." - (let* ((htmlize-output-type 'inline-css) - (htmlbuf (htmlize-region beg end))) - (unwind-protect - (with-current-buffer htmlbuf - (buffer-substring (plist-get htmlize-buffer-places 'content-start) - (plist-get htmlize-buffer-places 'content-end))) - (kill-buffer htmlbuf)))) - -(defun htmlize-make-file-name (file) - "Make an HTML file name from FILE. - -In its default implementation, this simply appends `.html' to FILE. -This function is called by htmlize to create the buffer file name, and -by `htmlize-file' to create the target file name. - -More elaborate transformations are conceivable, such as changing FILE's -extension to `.html' (\"file.c\" -> \"file.html\"). If you want them, -overload this function to do it and htmlize will comply." - (concat file ".html")) - -;; Older implementation of htmlize-make-file-name that changes FILE's -;; extension to ".html". -;(defun htmlize-make-file-name (file) -; (let ((extension (file-name-extension file)) -; (sans-extension (file-name-sans-extension file))) -; (if (or (equal extension "html") -; (equal extension "htm") -; (equal sans-extension "")) -; (concat file ".html") -; (concat sans-extension ".html")))) - -;;;###autoload -(defun htmlize-file (file &optional target) - "Load FILE, fontify it, convert it to HTML, and save the result. - -Contents of FILE are inserted into a temporary buffer, whose major mode -is set with `normal-mode' as appropriate for the file type. The buffer -is subsequently fontified with `font-lock' and converted to HTML. Note -that, unlike `htmlize-buffer', this function explicitly turns on -font-lock. If a form of highlighting other than font-lock is desired, -please use `htmlize-buffer' directly on buffers so highlighted. - -Buffers currently visiting FILE are unaffected by this function. The -function does not change current buffer or move the point. - -If TARGET is specified and names a directory, the resulting file will be -saved there instead of to FILE's directory. If TARGET is specified and -does not name a directory, it will be used as output file name." - (interactive (list (read-file-name - "HTML-ize file: " - nil nil nil (and (buffer-file-name) - (file-name-nondirectory - (buffer-file-name)))))) - (let ((output-file (if (and target (not (file-directory-p target))) - target - (expand-file-name - (htmlize-make-file-name (file-name-nondirectory file)) - (or target (file-name-directory file))))) - ;; Try to prevent `find-file-noselect' from triggering - ;; font-lock because we'll fontify explicitly below. - (font-lock-mode nil) - (font-lock-auto-fontify nil) - (global-font-lock-mode nil) - ;; Ignore the size limit for the purposes of htmlization. - (font-lock-maximum-size nil) - ;; Disable font-lock support modes. This will only work in - ;; more recent Emacs versions, so htmlize-buffer-1 still needs - ;; to call htmlize-ensure-fontified. - (font-lock-support-mode nil)) - (with-temp-buffer - ;; Insert FILE into the temporary buffer. - (insert-file-contents file) - ;; Set the file name so normal-mode and htmlize-buffer-1 pick it - ;; up. Restore it afterwards so with-temp-buffer's kill-buffer - ;; doesn't complain about killing a modified buffer. - (let ((buffer-file-name file)) - ;; Set the major mode for the sake of font-lock. - (normal-mode) - (font-lock-mode 1) - (unless font-lock-mode - ;; In GNU Emacs (font-lock-mode 1) doesn't force font-lock, - ;; contrary to the documentation. This seems to work. - (font-lock-fontify-buffer)) - ;; htmlize the buffer and save the HTML. - (with-current-buffer (htmlize-buffer-1) - (unwind-protect - (progn - (run-hooks 'htmlize-file-hook) - (write-region (point-min) (point-max) output-file)) - (kill-buffer (current-buffer))))))) - ;; I haven't decided on a useful return value yet, so just return - ;; nil. - nil) - -;;;###autoload -(defun htmlize-many-files (files &optional target-directory) - "Convert FILES to HTML and save the corresponding HTML versions. - -FILES should be a list of file names to convert. This function calls -`htmlize-file' on each file; see that function for details. When -invoked interactively, you are prompted for a list of files to convert, -terminated with RET. - -If TARGET-DIRECTORY is specified, the HTML files will be saved to that -directory. Normally, each HTML file is saved to the directory of the -corresponding source file." - (interactive - (list - (let (list file) - ;; Use empty string as DEFAULT because setting DEFAULT to nil - ;; defaults to the directory name, which is not what we want. - (while (not (equal (setq file (read-file-name - "HTML-ize file (RET to finish): " - (and list (file-name-directory - (car list))) - "" t)) - "")) - (push file list)) - (nreverse list)))) - ;; Verify that TARGET-DIRECTORY is indeed a directory. If it's a - ;; file, htmlize-file will use it as target, and that doesn't make - ;; sense. - (and target-directory - (not (file-directory-p target-directory)) - (error "target-directory must name a directory: %s" target-directory)) - (dolist (file files) - (htmlize-file file target-directory))) - -;;;###autoload -(defun htmlize-many-files-dired (arg &optional target-directory) - "HTMLize dired-marked files." - (interactive "P") - (htmlize-many-files (dired-get-marked-files nil arg) target-directory)) - -(provide 'htmlize) - -;;; htmlize.el ends here diff --git a/elisp/emacs-goodies-el/initsplit.el b/elisp/emacs-goodies-el/initsplit.el index 1787a41..1787a41 100755..100644 --- a/elisp/emacs-goodies-el/initsplit.el +++ b/elisp/emacs-goodies-el/initsplit.el diff --git a/elisp/emacs-goodies-el/joc-toggle-buffer.el b/elisp/emacs-goodies-el/joc-toggle-buffer.el index 5a74c9a..5a74c9a 100755..100644 --- a/elisp/emacs-goodies-el/joc-toggle-buffer.el +++ b/elisp/emacs-goodies-el/joc-toggle-buffer.el diff --git a/elisp/emacs-goodies-el/joc-toggle-case.el b/elisp/emacs-goodies-el/joc-toggle-case.el index 6318692..6318692 100755..100644 --- a/elisp/emacs-goodies-el/joc-toggle-case.el +++ b/elisp/emacs-goodies-el/joc-toggle-case.el diff --git a/elisp/emacs-goodies-el/keydef.el b/elisp/emacs-goodies-el/keydef.el index 7ea0edd..7ea0edd 100755..100644 --- a/elisp/emacs-goodies-el/keydef.el +++ b/elisp/emacs-goodies-el/keydef.el diff --git a/elisp/emacs-goodies-el/keywiz.el b/elisp/emacs-goodies-el/keywiz.el index 8b093a1..8b093a1 100755..100644 --- a/elisp/emacs-goodies-el/keywiz.el +++ b/elisp/emacs-goodies-el/keywiz.el diff --git a/elisp/emacs-goodies-el/lcomp.el b/elisp/emacs-goodies-el/lcomp.el index e8f8f38..e8f8f38 100755..100644 --- a/elisp/emacs-goodies-el/lcomp.el +++ b/elisp/emacs-goodies-el/lcomp.el diff --git a/elisp/emacs-goodies-el/map-lines.el b/elisp/emacs-goodies-el/map-lines.el index a663181..a663181 100755..100644 --- a/elisp/emacs-goodies-el/map-lines.el +++ b/elisp/emacs-goodies-el/map-lines.el diff --git a/elisp/emacs-goodies-el/marker-visit.el b/elisp/emacs-goodies-el/marker-visit.el index d12f876..d12f876 100755..100644 --- a/elisp/emacs-goodies-el/marker-visit.el +++ b/elisp/emacs-goodies-el/marker-visit.el diff --git a/elisp/emacs-goodies-el/matlab.el b/elisp/emacs-goodies-el/matlab.el deleted file mode 100644 index f6852cf..0000000 --- a/elisp/emacs-goodies-el/matlab.el +++ /dev/null @@ -1,5814 +0,0 @@ -;;; matlab.el --- major mode for MATLAB(R) dot-m files -;; -;; Author: Matt Wette <mwette@alumni.caltech.edu>, -;; Eric M. Ludlam <eludlam@mathworks.com> -;; Maintainer: Eric M. Ludlam <eludlam@mathworks.com> -;; Created: 04 Jan 91 -;; Keywords: MATLAB(R) -;; Version: - -(defconst matlab-mode-version "3.3.2" - "Current version of MATLAB(R) mode.") - -;; -;; Copyright (C) 2004-2010 The Mathworks, Inc -;; Copyright (C) 1997-2004 Eric M. Ludlam: The MathWorks, Inc -;; Copyright (C) 1991-1997 Matthew R. Wette -;; -;; This program 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. -;; -;; This program 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 GNU Emacs; see the file COPYING. If not, write to -;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -;; -;;; Commentary: -;; -;; This major mode for GNU Emacs provides support for editing MATLAB(R) dot-m -;; files. It automatically indents for block structures (including nested -;; functions), line continuations (e.g., ...), and comments. -;; -;; Additional features include auto-fill including auto-additions of -;; ellipsis for commands, and even strings. Block/end construct -;; highlighting as you edit. Primitive code-verification and -;; identification. Templates and other code editing functions. -;; Advanced symbol completion. Code highlighting via font-lock. -;; There are many navigation commands that let you move across blocks -;; of code at different levels. -;; -;; Lastly, there is support for running MATLAB(R) in an Emacs buffer, -;; with full shell history and debugger support (when used with the db -;; commands.) The shell can be used as an online help while editing -;; code, providing help on functions, variables, or running arbitrary -;; blocks of code from the buffer you are editing. - -;;; Code: - -(require 'easymenu) -(require 'tempo) -(require 'derived) - -;; compatibility -(if (string-match "X[Ee]macs" emacs-version) - (progn - (defalias 'matlab-make-overlay 'make-extent) - (defalias 'matlab-overlay-put 'set-extent-property) - (defalias 'matlab-overlay-get 'extent-property) - (defalias 'matlab-delete-overlay 'delete-extent) - (defalias 'matlab-overlay-start 'extent-start-position) - (defalias 'matlab-overlay-end 'extent-end-position) - (defalias 'matlab-previous-overlay-change 'previous-extent-change) - (defalias 'matlab-next-overlay-change 'next-extent-change) - (defalias 'matlab-overlays-at - (lambda (pos) (extent-list nil pos pos))) - (defalias 'matlab-cancel-timer 'delete-itimer) - (defun matlab-run-with-idle-timer (secs repeat function &rest args) - (condition-case nil - (apply 'start-itimer - "matlab" function secs - (if repeat secs nil) t - t (car args)) - (error - ;; If the above doesn't work, then try this old version of - ;; start itimer. - (start-itimer "matlab" function secs (if repeat secs nil))))) - ) - (defalias 'matlab-make-overlay 'make-overlay) - (defalias 'matlab-overlay-put 'overlay-put) - (defalias 'matlab-overlay-get 'overlay-get) - (defalias 'matlab-delete-overlay 'delete-overlay) - (defalias 'matlab-overlay-start 'overlay-start) - (defalias 'matlab-overlay-end 'overlay-end) - (defalias 'matlab-previous-overlay-change 'previous-overlay-change) - (defalias 'matlab-next-overlay-change 'next-overlay-change) - (defalias 'matlab-overlays-at 'overlays-at) - (defalias 'matlab-cancel-timer 'cancel-timer) - (defalias 'matlab-run-with-idle-timer 'run-with-idle-timer) - ) - -(cond ((fboundp 'point-at-bol) - (defalias 'matlab-point-at-bol 'point-at-bol) - (defalias 'matlab-point-at-eol 'point-at-eol)) - ;; Emacs 20.4 - ((fboundp 'line-beginning-position) - (defalias 'matlab-point-at-bol 'line-beginning-position) - (defalias 'matlab-point-at-eol 'line-end-position)) - (t - (defmacro matlab-point-at-bol () - (save-excursion (beginning-of-line) (point))) - (defmacro matlab-point-at-eol () - (save-excursion (end-of-line) (point))))) - -(defmacro matlab-run-in-matlab-mode-only (&rest body) - "Execute BODY only if the active buffer is a MATLAB(R) M-file buffer." - `(if (eq major-mode 'matlab-mode) - (progn - ,@body) - (error "This command works only in a MATLAB M-file buffer"))) - -(defun matlab-with-emacs-link () - "Return non-nil if Emacs Link is running and user wants to use it." - (and (featurep 'matlab-eei) - matlab-use-eei - matlab-eei-process)) - -;;; User-changeable variables ================================================= - -;; Variables which the user can change -(defgroup matlab nil - "MATLAB(R) mode." - :prefix "matlab-" - :group 'languages) - -(defcustom matlab-indent-level 4 - "*The basic indentation amount in `matlab-mode'." - :group 'matlab - :type 'integer) - -(defcustom matlab-cont-level 4 - "*Basic indentation after continuation if no other methods are found." - :group 'matlab - :type 'integer) - -(defcustom matlab-cont-requires-ellipsis t - "*Specify if ellipses are required at the end of a line for continuation. -Future versions of Matlab may not require ellipses ... , so a heuristic -determining if there is to be continuation is used instead." - :group 'matlab - :type 'integer) - -(defcustom matlab-case-level '(2 . 2) - "*How far to indent case/otherwise statements in a switch. -This can be an integer, which is the distance to indent the CASE and -OTHERWISE commands, and how far to indent commands appearing in CASE -and OTHERWISE blocks. It can also be a cons cell which is of form - (CASEINDENT . COMMANDINDENT) -where CASEINDENT is the indentation of the CASE and OTHERWISE -statements, and COMMANDINDENT is the indentation of commands appearing -after the CASE or OTHERWISE command. - -Note: Currently a bug exists if: - CASEINDENT+COMMANDINDENT != `matlab-indent-level' -so if you customize these variables, follow the above rule, and you -should be ok." - :group 'matlab - :type 'sexp) - -(defcustom matlab-indent-function-body 'guess - "*If non-nil, indent body of function. -If the global value is nil, do not indent function bodies. -If the global value is t, always indent function bodies. -If the global value is 'guess, then the local value will be set to -either nil or t when the MATLAB mode is started in a buffer based on the -file's current indentation. -If the global value is 'MathWorks-Standard, then the local value is not -changed, and functions are indented based on `matlab-functions-have-end'." - :group 'matlab - :type '(choice (const :tag "Always" t) - (const :tag "Never" nil) - (const :tag "Guess" 'guess) - (const :tag "MathWorks Standard" - 'MathWorks-Standard)) - ) - -(make-variable-buffer-local 'matlab-indent-function-body) - -(defcustom matlab-functions-have-end nil - "*If non-nil, functions-have-end minor mode is on by default." - :group 'matlab - :type 'boolean) - -(make-variable-buffer-local 'matlab-functions-have-end) - -(defun matlab-toggle-functions-have-end () - (interactive) - (matlab-toggle-functions-have-end-minor-mode)) - -;; The following minor mode is on if and only if the above variable is true; -(easy-mmode-define-minor-mode matlab-functions-have-end-minor-mode - "Toggle functions-have-end minor mode, indicating function/end pairing." - nil - (condition-case nil ;; avoid parse error on xemacs - (eval (read "#(\" function...end\" 0 15 (face (font-lock-keyword-face) fontified t))")) - (error " function...end")) - nil ; empty mode-map - ;; body of matlab-functions-have-end-minor-mode - (if matlab-functions-have-end-minor-mode - (setq matlab-functions-have-end t) - (setq matlab-functions-have-end nil) - ) -) - -(defun matlab-do-functions-have-end-p () - "Non-nil if the first function in the current buffer terminates with end." - (save-excursion - (goto-char (point-min)) - (if (re-search-forward matlab-defun-regex nil t) - (let ((matlab-functions-have-end t)) - (beginning-of-line) - (condition-case nil - (progn (matlab-forward-sexp) t) - (error nil)) - ) - nil - ) - )) - -(defun matlab-toggle-functions-have-end-minor-mode () - (matlab-functions-have-end-minor-mode) - (if (and matlab-functions-have-end-minor-mode (not (eq major-mode 'matlab-mode))) - (progn - (matlab-functions-have-end-minor-mode -1) - (error "functions-have-end minor mode is only for MATLAB Major mode"))) - (setq matlab-functions-have-end matlab-functions-have-end-minor-mode)) - -(defun matlab-indent-function-body-p () - "Non-nil if functions bodies are indented. -See `matlab-indent-function-body' variable." - (if (eq matlab-indent-function-body 'MathWorks-Standard) - ;; Dec '09 - ;; The MathWorks standard is the same as if functions have end. - matlab-functions-have-end - ;; Else, just return the variable. - matlab-indent-function-body)) - -(defcustom matlab-indent-past-arg1-functions - "[sg]et\\(_param\\)?\\|waitfor" - "*Regex describing functions whose first arg is special. -This specialness means that all following parameters which appear on -continued lines should appear indented to line up with the second -argument, not the first argument." - :group 'matlab - :type 'string) - -(defcustom matlab-arg1-max-indent-length 15 - "*The maximum length to indent when indenting past arg1. -If arg1 is exceptionally long, then only this number of characters -will be indented beyond the open paren starting the parameter list.") - -(defcustom matlab-maximum-indents '(;; = is a convenience. Don't go too far - (?= . (10 . 4)) - ;; Fns should provide hard limits - (?\( . 50) - ;; Matrix/Cell arrays - (?\[ . 20) - (?\{ . 20)) - "Alist of maximum indentations when lining up code. -Each element is of the form (CHAR . INDENT) where char is a character -the indent engine is using, and INDENT is the maximum indentation -allowed. Indent could be of the form (MAXIMUM . INDENT), where -MAXIMUM is the maximum allowed calculated indent, and INDENT is the -amount to use if MAXIMUM is reached." - :group 'matlab - :type '(repeat (cons (character :tag "Open List Character") - (sexp :tag "Number (max) or cons (max indent)")))) - -(defcustom matlab-handle-simulink t - "*If true, add in a few simulink customizations. -This variable's state is mostly useful when set at load time when -simulink font lock keywords can be removed. This will handle -additional cases as the need arrises." - :group 'matlab - :type 'boolean) - -(defcustom matlab-auto-fill t - "*If true, set variable `auto-fill-function' to our function at startup." - :group 'matlab - :type 'boolean) - -(defcustom matlab-fill-fudge 10 - "Number of characters around `fill-column' we can fudge filling. -Basically, there are places that are very convenient to fill at, but -might not be the closest fill spot, or occur after `fill-column'. -If they occur within this fudge factor, we will use them. -Also, if none of the above occur, and we find a symbol to break at, -but an open paren (group) starts or ends within this fudge factor, -move there to boost the amount of fill leverage we can get." - :group 'matlab - :type 'integer) - -(defcustom matlab-fill-fudge-hard-maximum 79 - "The longest line allowed when auto-filling code. -This overcomes situations where the `fill-column' plus the -`matlab-fill-fudge' is greater than some hard desired limit." - :group 'matlab - :type 'integer) - -(defcustom matlab-elipsis-string "..." - "Text used to perform continuation on code lines. -This is used to generate and identify continuation lines.") - -(defcustom matlab-fill-code t - "*If true, `auto-fill-mode' causes code lines to be automatically continued." - :group 'matlab - :type 'boolean) - -(defcustom matlab-fill-count-ellipsis-flag t - "*Non-nil means to count the ellipsis when auto filling. -This effectively shortens the `fill-column' by the length of -`matlab-elipsis-string'.") - -(defcustom matlab-fill-strings-flag t - "*Non-nil means that when auto-fill is on, strings are broken across lines. -If `matlab-fill-count-ellipsis-flag' is non nil, this shortens the -`fill-column' by the length of `matlab-elipsis-string'.") - -(defcustom matlab-comment-column 40 - "*The goal comment column in `matlab-mode' buffers." - :group 'matlab - :type 'integer) - -(defcustom matlab-comment-anti-indent 0 - "*Amount of anti-indentation to use for comments in relation to code." - :group 'matlab - :type 'integer) - -(defcustom matlab-comment-line-s "% " - "*String to start comment on line by itself." - :group 'matlab - :type 'string) - -(defcustom matlab-comment-on-line-s "% " - "*String to start comment on line with code." - :group 'matlab - :type 'string) - -(defcustom matlab-comment-region-s "% $$$ " - "*String inserted by \\[matlab-comment-region] at start of each line in \ -region." - :group 'matlab - :type 'string) - -(defcustom matlab-verify-on-save-flag t - "*Non-nil means to verify M whenever we save a file." - :group 'matlab - :type 'boolean) - -(defcustom matlab-mode-verify-fix-functions - '(matlab-mode-vf-functionname) - "List of function symbols which perform a verification and fix to M code. -Each function gets no arguments, and returns nothing. They can move -point, but it will be restored for them." - :group 'matlab - :type '(repeat (choice :tag "Function: " - '(matlab-mode-vf-functionname - matlab-mode-vf-block-matches-forward - matlab-mode-vf-block-matches-backward - matlab-mode-vf-quiesce-buffer - )))) - -(defcustom matlab-block-verify-max-buffer-size 50000 - "*Largest buffer size allowed for block verification during save." - :group 'matlab - :type 'integer) - -;; It is time to disable this. -(defcustom matlab-vers-on-startup nil - "*If non-nil, show the version number on startup." - :group 'matlab - :type 'boolean) - -(defcustom matlab-highlight-block-match-flag t - "*Non-nil means to highlight the matching if/end/whatever. -The highlighting only occurs when the cursor is on a block start or end -keyword." - :group 'matlab - :type 'boolean) - -(defcustom matlab-show-periodic-code-details-flag nil - "*Non-nil means to show code details in the minibuffer. -This will only work if `matlab-highlight-block-match-flag' is non-nil." - :group 'matlab - :type 'boolean) - -(defcustom matlab-use-eei t - "*Use Emacs Link for save-and-go and run-region." - :group 'matlab - :type 'boolean) - -(defcustom matlab-mode-hook nil - "*List of functions to call on entry to MATLAB mode." - :group 'matlab - :type 'hook) - -(defcustom matlab-completion-technique 'complete - "*How the `matlab-complete-symbol' interfaces with the user. -Valid values are: - -'increment - which means that new strings are tried with each - successive call until all methods are exhausted. - (Similar to `hippie-expand'.) -'complete - Which means that if there is no single completion, then - all possibilities are displayed in a completion buffer." - :group 'matlab - :type '(radio (const :tag "Incremental completion (hippie-expand)." - increment) - (const :tag "Show completion buffer." - complete))) - -(defcustom matlab-show-mlint-warnings nil - "*If non-nil, show mlint warnings." - :group 'matlab - :type 'boolean) - -(make-variable-buffer-local 'matlab-show-mlint-warnings) - -(defcustom matlab-highlight-cross-function-variables nil - "*If non-nil, highlight cross-function variables." - :group 'matlab - :type 'boolean) - -(make-variable-buffer-local 'matlab-highlight-cross-function-variables) - -(defcustom matlab-return-add-semicolon nil - "*If non nil, check to see a semicolon is needed when RET is pressed." - :group 'matlab - :type 'boolean) - -(make-variable-buffer-local 'matlab-return-add-semicolon) - -;; Load in the region we use for highlighting stuff. -(if (and (featurep 'custom) (fboundp 'custom-declare-variable)) - - (let ((l-region-face (if (facep 'region) 'region 'zmacs-region))) - ;; If we have custom, we can make our own special face like this - (defface matlab-region-face - (list - (list t - (list :background (face-background l-region-face) - :foreground (face-foreground l-region-face)))) - "*Face used to highlight a matlab region." - :group 'matlab)) - - ;; If we do not, then we can fake it by copying 'region. - (cond ((facep 'region) - (copy-face 'region 'matlab-region-face)) - (t - (copy-face 'zmacs-region 'matlab-region-face)))) - -(defvar matlab-unterminated-string-face 'matlab-unterminated-string-face - "Self reference for unterminated string face.") - -(defvar matlab-simulink-keyword-face 'matlab-simulink-keyword-face - "Self reference for simulink keywords.") - -(defvar matlab-nested-function-keyword-face 'matlab-nested-function-keyword-face - "Self reference for nested function/end keywords.") - -(defvar matlab-cross-function-variable-face 'matlab-cross-function-variable-face - "Self reference for cross-function variables.") - -(defvar matlab-cellbreak-face 'matlab-cellbreak-face - "Self reference for cellbreaks.") - -(defun matlab-font-lock-adjustments () - "Make adjustments for font lock. -If font lock is not loaded, lay in wait." - (if (and (featurep 'custom) (fboundp 'custom-declare-variable)) - - (progn - (defface matlab-unterminated-string-face - (list - (list t - (list :background (face-background font-lock-string-face) - :foreground (face-foreground font-lock-string-face) - :underline t))) - "*Face used to highlight unterminated strings." - :group 'matlab) - (defface matlab-simulink-keyword-face - (list - (list t - (list :background (face-background font-lock-type-face) - :foreground (face-foreground font-lock-type-face) - :underline t))) - "*Face used to highlight simulink specific functions." - :group 'matlab) - (defface matlab-nested-function-keyword-face - (list - (list t - (list :slant 'italic))) - "*Face to use for cross-function variables.") - (defface matlab-cross-function-variable-face - (list - (list t - (list :weight 'bold - :slant 'italic))) - "*Face to use for cross-function variables." - :group 'matlab) - (defface matlab-cellbreak-face - (list - (list t - (list :background (face-background font-lock-comment-face) - :foreground (face-foreground font-lock-comment-face) - :overline t - :bold t))) - "*Face to use for cellbreak %% lines.") - ) - - ;; Now, lets make the unterminated string face - (cond ((facep 'font-lock-string-face) - (copy-face 'font-lock-string-face - 'matlab-unterminated-string-face)) - (t - (make-face 'matlab-unterminated-string-face))) - (set-face-underline-p 'matlab-unterminated-string-face t) - - ;; Now make some simulink faces - (cond ((facep 'font-lock-type-face) - (copy-face 'font-lock-type-face 'matlab-simulink-keyword-face)) - (t - (make-face 'matlab-simulink-keyword-face))) - (set-face-underline-p 'matlab-simulink-keyword-face t) - - ;; Now make some nested function/end keyword faces - (cond ((facep 'font-lock-type-face) - (copy-face 'font-lock-type-face 'matlab-nested-function-keyword-face)) - (t - (make-face 'matlab-nested-function-keyword-face))) - - ;; Now make some cross-function variable faces - (cond ((facep 'font-lock-type-face) - (copy-face 'font-lock-type-face 'matlab-cross-function-variable-face)) - (t - (make-face 'matlab-cross-function-variable-face))) - (set-face-bold-p 'matlab-cross-function-variable-face t) - - ;; Now make some cellbreak variable faces - (cond ((facep 'font-comment-face) - (copy-face 'font-lock-comment-face 'matlab-cellbreak-face)) - (t - (make-face 'matlab-cellbreak-face))) - (set-face-bold-p 'matlab-cellbreak-face t) - (condition-case nil - (set-face-attribute 'matlab-cellbreak-face nil :overline t) - (error nil)) - ) - (remove-hook 'font-lock-mode-hook 'matlab-font-lock-adjustments)) - -;; Make the adjustments for font lock after it's loaded. -;; I found that eval-after-load was unreliable. -(if (featurep 'font-lock) - (matlab-font-lock-adjustments) - (add-hook 'font-lock-mode-hook 'matlab-font-lock-adjustments)) - - -;;; MATLAB mode variables ===================================================== - -(defvar matlab-tempo-tags nil - "List of templates used in MATLAB mode.") - -;; syntax table -(defvar matlab-mode-syntax-table - (let ((st (make-syntax-table (standard-syntax-table)))) - (modify-syntax-entry ?_ "_" st) - (modify-syntax-entry ?% "<" st) - (modify-syntax-entry ?\n ">" st) - (modify-syntax-entry ?\\ "." st) - (modify-syntax-entry ?\t " " st) - (modify-syntax-entry ?+ "." st) - (modify-syntax-entry ?- "." st) - (modify-syntax-entry ?* "." st) - (modify-syntax-entry ?' "." st) - (modify-syntax-entry ?/ "." st) - (modify-syntax-entry ?= "." st) - (modify-syntax-entry ?< "." st) - (modify-syntax-entry ?> "." st) - (modify-syntax-entry ?& "." st) - (modify-syntax-entry ?| "." st) - st) - "The syntax table used in `matlab-mode' buffers.") - -(defvar matlab-mode-special-syntax-table - (let ((st (copy-syntax-table matlab-mode-syntax-table))) - ;; Make _ a part of words so we can skip them better - (modify-syntax-entry ?_ "w" st) - st) - "The syntax table used when navigating blocks.") - -;; abbrev table -(defvar matlab-mode-abbrev-table nil - "The abbrev table used in `matlab-mode' buffers.") - -(define-abbrev-table 'matlab-mode-abbrev-table ()) - -;;; Keybindings =============================================================== - -(defvar matlab-help-map - (let ((km (make-sparse-keymap))) - (define-key km "r" 'matlab-shell-run-command) - (define-key km "f" 'matlab-shell-describe-command) - (define-key km "a" 'matlab-shell-apropos) - (define-key km "v" 'matlab-shell-describe-variable) - (define-key km "t" 'matlab-shell-topic-browser) - km) - "The help key map for `matlab-mode' and `matlab-shell-mode'.") - -(defvar matlab-insert-map - (let ((km (make-sparse-keymap))) - (define-key km "c" 'matlab-insert-next-case) - (define-key km "e" 'matlab-insert-end-block) - (define-key km "i" 'tempo-template-matlab-if) - (define-key km "I" 'tempo-template-matlab-if-else) - (define-key km "f" 'tempo-template-matlab-for) - (define-key km "s" 'tempo-template-matlab-switch) - (define-key km "t" 'tempo-template-matlab-try) - (define-key km "w" 'tempo-template-matlab-while) - (define-key km "F" 'tempo-template-matlab-function) - (define-key km "'" 'matlab-stringify-region) - ;; Not really inserts, but auto coding stuff - (define-key km "\C-s" 'matlab-ispell-strings) - (define-key km "\C-c" 'matlab-ispell-comments) - km) - "Keymap used for inserting simple texts based on context.") - -;; mode map -(defvar matlab-mode-map - (let ((km (make-sparse-keymap))) - (define-key km [return] 'matlab-return) - (define-key km "%" 'matlab-electric-comment) - (define-key km "\C-c;" 'matlab-comment-region) - (define-key km "\C-c:" 'matlab-uncomment-region) - (define-key km [(control c) return] 'matlab-comment-return) - (define-key km [(control c) (control c)] matlab-insert-map) - (define-key km [(control c) (control f)] 'matlab-fill-comment-line) - (define-key km [(control c) (control j)] 'matlab-justify-line) - (define-key km [(control c) (control q)] 'matlab-fill-region) - (define-key km [(control c) (control s)] 'matlab-shell-save-and-go) - (define-key km [(control c) (control r)] 'matlab-shell-run-region) - (define-key km [(meta control return)] 'matlab-shell-run-cell) - (define-key km [(control c) (control t)] 'matlab-show-line-info) - (define-key km [(control c) ?. ] 'matlab-find-file-on-path) - (define-key km [(control h) (control m)] matlab-help-map) - (define-key km [(control j)] 'matlab-linefeed) - (define-key km "\M-\r" 'newline) - (define-key km [(meta \;)] 'matlab-comment) - (define-key km [(meta q)] 'matlab-fill-paragraph) - (define-key km [(meta a)] 'matlab-beginning-of-command) - (define-key km [(meta e)] 'matlab-end-of-command) - (define-key km [(meta j)] 'matlab-comment-line-break-function) - (define-key km [(meta s)] 'matlab-show-matlab-shell-buffer) - (define-key km "\M-\t" 'matlab-complete-symbol) - (define-key km [(meta control f)] 'matlab-forward-sexp) - (define-key km [(meta control b)] 'matlab-backward-sexp) - (define-key km [(meta control q)] 'matlab-indent-sexp) - (define-key km [(meta control a)] 'matlab-beginning-of-defun) - (define-key km [(meta control e)] 'matlab-end-of-defun) - (if (string-match "XEmacs" emacs-version) - (define-key km [(control meta button1)] 'matlab-find-file-click) - (define-key km [(control meta mouse-2)] 'matlab-find-file-click)) - (substitute-key-definition 'comment-region 'matlab-comment-region - km) ; global-map ;torkel - km) - "The keymap used in `matlab-mode'.") - -;;; Font locking keywords ===================================================== - -(defvar matlab-string-start-regexp "\\(^\\|[^]})a-zA-Z0-9_.']\\)" - "Regexp used to represent the character before the string char '. -The ' character has restrictions on what starts a string which is needed -when attempting to understand the current context.") - -;; To quote a quote, put two in a row, thus we need an anchored -;; first quote. In addition, we don't want to color strings in comments. -(defvar matlab-string-end-regexp "[^'\n]*\\(''[^'\n]*\\)*'" - "Regexp used to represent the character pattern for ending a string. -The ' character can be used as a transpose, and can transpose transposes. -Therefore, to end, we must check all that goop.") - -(defun matlab-font-lock-string-match-normal (limit) - "When font locking strings, call this function for normal strings. -Argument LIMIT is the maximum distance to scan." - (matlab-font-lock-string-match-here - (concat matlab-string-start-regexp - "\\('" matlab-string-end-regexp "\\)" - "\\([^']\\|$\\)") - limit)) - -(defun matlab-font-lock-string-match-unterminated (limit) - "When font locking strings, call this function for normal strings. -Argument LIMIT is the maximum distance to scan." - (matlab-font-lock-string-match-here - (concat matlab-string-start-regexp "\\('[^'\n]*\\(''[^'\n]*\\)*\\)$") - limit)) - -(defun matlab-font-lock-string-match-here (regex limit) - "When font-locking strings, call this function to determine a match. -Argument REGEX is the expression to scan for. Match 2 must be the string. -Argument LIMIT is the maximum distance to scan." - (let (e) - (while (and (re-search-forward regex limit t) - (progn - ;; This gets us out of a comment after the string. - (setq e (match-end 2)) - (goto-char (match-beginning 2)) - (prog1 - (or (matlab-cursor-in-comment) - (if (bolp) nil - (save-excursion - (forward-char -1) - (matlab-cursor-in-string)))) - (goto-char e)))) - (setq e nil)) - (if (not e) - nil - (goto-char e) - t))) - -(defun matlab-font-lock-comment-match (limit) - "When font-locking comments, call this function to determine a match. -Argument LIMIT is the maximum distance to scan." - (let (e) - (while (and (re-search-forward "\\(%[^%\n]*\\)" limit t) - (progn - (setq e (match-end 1)) - (member (get-text-property (match-beginning 0) 'face) - '(font-lock-string-face - matlab-unterminated-string-face)))) - (setq e nil)) - (if (not e) - nil - (goto-char e) - t))) - -(defun matlab-find-unreachable-code (limit) - "Find code that is if'd out with if(0) or if(false), and mark it as a comment. -The if(0) and else/end construct should be highlighted differently. -Argument LIMIT is the maximum distance to search." - (if (and (< (point) limit) - (re-search-forward - "\\<\\(if\\>\\s-*(?\\s-*\\(0\\|false\\)\\s-*)?$\\)" - limit t)) - (let ((b1 (match-beginning 1)) - (e1 (match-end 1)) - (b2 nil) (e2 nil) - (b3 nil) (e3 nil)) - (goto-char b1) - (condition-case nil - (progn - ;; Go forward over the matlab sexp. Include scanning - ;; for ELSE since parts of the ELSE block are not - ;; `commented out'. - (matlab-forward-sexp t) - (forward-word -1) - ;; Is there an ELSE in this block? - (if (looking-at (matlab-block-mid-re)) - (progn - (setq b3 (match-beginning 0) - e3 (match-end 0)) - ;; Now find the REAL end. - (matlab-forward-sexp) - (forward-word -1))) - ;; End of block stuff - (if (looking-at (matlab-block-end-re)) - (progn - (setq b2 (match-beginning 0) - e2 (match-end 0)) - ;; make sure something exists... - (if (not b3) (setq b3 b2 e3 e2))) - (error "Eh?")) - ;; Ok, build up some match data. - (set-match-data - (list b1 e2 ;the real deal. - b1 e1 ;if (0) - b2 e2 ;end - b3 e3 ;else (if applicable.) - b1 e3)) ;body commented out. - t) - (error nil))))) - -(defun matlab-font-lock-nested-function-keyword-match (limit) - "Find next nested function/end keyword for font-lock. -Argument LIMIT is the maximum distance to search." -; Because of the way overlays are setup, the cursor will be sitting -; on either a "function" or "end" keyword. - (catch 'result - (let ((pos (point)) - overlays) - (while (< pos limit) - (setq overlays (matlab-overlays-at pos)) - (while overlays - (let ((overlay (car overlays))) - (when (matlab-overlay-get overlay 'nested-function) - (when (= pos (matlab-overlay-start overlay)) - (goto-char pos) - ;; The following line presumably returns true. - (throw 'result (re-search-forward "function" (+ pos 8) t))) - (let ((end-of-overlay (- (matlab-overlay-end overlay) 3))) - (when (<= pos end-of-overlay) - (goto-char end-of-overlay) - (throw 'result - (re-search-forward "end" (+ end-of-overlay 3) t)))))) - (setq overlays (cdr overlays))) - (setq pos (matlab-next-overlay-change pos))) - nil ;; no matches, stop - ))) - -(defun matlab-font-lock-cross-function-variables-match (limit) - "Find next cross-function variable for font-lock. -Argument LIMIT is the maximum distance to search." - (catch 'result - (let ((pos (point)) - overlays variables) - (while (< pos limit) - (let ((overlays (matlab-overlays-at pos))) - (while overlays - (let ((overlay (car overlays))) - (setq variables (matlab-overlay-get - overlay 'cross-function-variables)) - (if variables - (progn - (goto-char pos) - (setq pos (min limit (matlab-overlay-end overlay))) - (if (re-search-forward variables pos t) - (progn - (throw 'result t)))))) - (setq overlays (cdr overlays)))) - (setq pos (matlab-next-overlay-change pos))) - nil ;; no matches, stop - ))) - -(defun matlab-find-block-comments (limit) - "Find code that is commented out with %{ until %}. -Argument LIMIT is the maximum distance to search." - (if (and (< (point) limit) - (re-search-forward "%{" limit t)) - (let ((b1 (match-beginning 0)) - (e1 (match-end 0)) - (b2 nil) (e2 nil) - (b3 nil) (e3 nil)) - (goto-char b1) - (forward-char -1) - (when (not (matlab-cursor-in-comment)) - (setq b2 (re-search-forward "%}" limit t)) - (when b2 - (setq b2 (match-beginning 0) - e2 (match-end 0)) - (set-match-data - (list b1 e2 ; full match - b1 e2 ; the full comment - b1 e1 ; the block start - b2 e2 ; the block end - )) - t - ))))) - -(defcustom matlab-keyword-list '("global" "persistent" "for" "parfor" "while" - "spmd" "if" "elseif" "else" - "endfunction" "return" "break" "continue" - "switch" "case" "otherwise" "try" - "catch" "tic" "toc" - ;; MCOS keywords - "classdef" "properties" "methods" "enumeration" - ) - "List of keywords for MATLAB used in highlighting. -Customizing this variable is only useful if `regexp-opt' is available." - :group 'matlab - :type '(repeat (string :tag "Keyword: "))) - -(defcustom matlab-handle-graphics-list '("figure" "axes" "axis" "line" - "surface" "patch" "text" "light" - "image" "set" "get" "uicontrol" - "uimenu" "uitoolbar" - "uitoggletool" "uipushtool" - "uicontext" "uicontextmenu" - "setfont" "setcolor") - "List of handle graphics functions used in highlighting. -Customizing this variable is only useful if `regexp-opt' is available." - :group 'matlab - :type '(repeat (string :tag "HG Keyword: "))) - -(defcustom matlab-debug-list '("dbstop" "dbclear" "dbcont" "dbdown" "dbmex" - "dbstack" "dbstatus" "dbstep" "dbtype" "dbup" - "dbquit") - "List of debug commands used in highlighting. -Customizing this variable is only useful if `regexp-opt' is available." - :group 'matlab - :type '(repeat (string :tag "Debug Keyword: "))) - -;; font-lock keywords -(defvar matlab-font-lock-keywords - (list - ;; String quote chars are also used as transpose, but only if directly - ;; after characters, numbers, underscores, or closing delimiters. - '(matlab-font-lock-string-match-normal 2 font-lock-string-face) - ;; A string with no termination is not currently highlighted. - ;; This will show that the string needs some attention. - '(matlab-font-lock-string-match-unterminated - 2 matlab-unterminated-string-face) - ;; Comments must occur after the string, that way we can check to see - ;; if the comment start char has occurred inside our string. (EL) - '(matlab-font-lock-comment-match 1 font-lock-comment-face) - ;; Various pragmas should be in different colors. - ;; I think pragmas are always lower case? - '("%#\\([a-z]+\\)" (1 'bold prepend)) - ;; General keywords - (list - (if (fboundp 'regexp-opt) - (concat "\\<\\(" (regexp-opt matlab-keyword-list) "\\)\\>") - ;; Original hard-coded value for pre Emacs 20.1 - "\\<\\(break\\|ca\\(se\\|tch\\)\\|e\\(lse\\(\\|if\\)\\|ndfunction\\)\ -\\|\\(par\\)?for\\|spmd\\|global\\|if\\|otherwise\\|return\\|switch\\|try\\|while\\|tic\\|toc\\)\\>") - '(0 font-lock-keyword-face)) - ;; The end keyword is only a keyword when not used as an array - ;; dereferencing part. - '("\\(^\\|[;,]\\)[ \t]*\\(end\\)\\b" - 2 (if (matlab-valid-end-construct-p) font-lock-keyword-face nil)) - ;; How about unreachable code? MUsT BE AFTER KEYWORDS in order to - ;; get double-highlighting. - '(matlab-find-unreachable-code - (1 'underline prepend) ;if part - (2 'underline prepend) ;end part - (3 'underline prepend) ;else part (if applicable) - (4 font-lock-comment-face prepend) ;commented out part. - ) - ;; block comments need to be commented out too! - '(matlab-find-block-comments - (1 font-lock-comment-face prepend) ; commented out - (2 'underline prepend) - (3 'underline prepend) ;the comment parts - ) - ;; Cell mode breaks get special treatment - '("^\\s-*\\(%%[^\n]*\n\\)" (1 matlab-cellbreak-face append)) - ;; Highlight cross function variables - '(matlab-font-lock-cross-function-variables-match - (1 matlab-cross-function-variable-face prepend)) - ;; Highlight nested function/end keywords - '(matlab-font-lock-nested-function-keyword-match - (0 matlab-nested-function-keyword-face prepend)) - ;; The global keyword defines some variables. Mark them. - '("^\\s-*global\\s-+" - ("\\(\\w+\\)\\(\\s-*=[^,; \t\n]+\\|[, \t;]+\\|$\\)" - nil nil (1 font-lock-variable-name-face))) - ;; Handle graphics stuff - (list - (if (fboundp 'regexp-opt) - (concat "\\<\\(" (regexp-opt matlab-handle-graphics-list) "\\)\\>") - ;; The original regular expression for pre Emacs 20.1 - "\\<\\(ax\\(es\\|is\\)\\|figure\\|get\\|image\\|li\\(ght\\|ne\\)\\|\ -patch\\|s\\(et\\(\\|color\\|font\\)\\|urface\\)\\|text\\|\ -ui\\(cont\\(ext\\(\\|menu\\)\\|rol\\)\\|menu\\|\ -\\(toggle\\|push\\)tool\\|toolbar\\)\\)\\>") - '(0 font-lock-type-face)) - ) - "Expressions to highlight in MATLAB mode.") - -(defconst matlab-function-arguments - "\\(([^)]*)\\)?\\s-*\\([,;\n%]\\|$\\)") - -(defvar matlab-gaudy-font-lock-keywords - (append - matlab-font-lock-keywords - (list - ;; defining a function, a (possibly empty) list of assigned variables, - ;; function name, and an optional (possibly empty) list of input variables - (list (concat "^\\s-*\\(function\\)\\>[ \t\n.]*" - "\\(\\[[^]]*\\]\\|\\sw+\\)[ \t\n.]*" - "=[ \t\n.]*\\(\\sw+\\)[ \t\n.]*" - matlab-function-arguments) - '(1 font-lock-keyword-face append) - '(2 font-lock-variable-name-face append) - '(3 font-lock-function-name-face append)) - ;; defining a function, a function name, and an optional (possibly - ;; empty) list of input variables - (list (concat "^\\s-*\\(function\\)[ \t\n.]+" - "\\(\\sw+\\)[ \t\n.]*" - matlab-function-arguments) - '(1 font-lock-keyword-face append) - '(2 font-lock-function-name-face append)) - ;; Anchor on the function keyword, highlight params - (list (concat "^\\s-*function\\>[ \t\n.]*" - "\\(\\(\\[[^]]*\\]\\|\\sw+\\)[ \t\n.]*=[ \t\n.]*\\)?" - "\\sw+\\s-*(") - '("\\s-*\\(\\sw+\\)\\s-*[,)]" nil nil - (1 font-lock-variable-name-face))) - ;; I like variables for FOR loops - '("\\<\\(for\\|parfor\\)\\s-+\\(\\sw+\\)\\s-*=\\s-*\ -\\(\\([^\n,;%(]+\\|([^\n%)]+)\\)+\\)" - (1 font-lock-keyword-face) - (2 font-lock-variable-name-face append) - (3 font-lock-reference-face append)) - ;; Items after a switch statements are cool - '("\\<\\(case\\|switch\\)\\s-+\\({[^}\n]+}\\|[^,%\n]+\\)" - (1 font-lock-keyword-face) (2 font-lock-reference-face)) - ;; How about a few matlab constants such as pi, infinity, and sqrt(-1)? - ;; The ^>> is in case I use this in an interactive mode someday - '("\\<\\(eps\\|pi\\|inf\\|Inf\\|NaN\\|nan\\|ans\\|i\\|j\\|^>>\\)\\>" - 1 font-lock-reference-face) - '("\\<[0-9]\\.?\\(i\\|j\\)\\>" 1 font-lock-reference-face) - ;; Define these as variables since this is about as close - ;; as matlab gets to variables - (list (concat "\\<" matlab-indent-past-arg1-functions "\\s-*") - '("(\\s-*\\(\\w+\\)\\s-*\\(,\\|)\\)" nil nil - (1 font-lock-variable-name-face))) - )) - "Expressions to highlight in MATLAB mode.") - -(defvar matlab-really-gaudy-font-lock-keywords - (append - matlab-gaudy-font-lock-keywords - (list - ;; Since it's a math language, how bout dem symbols? - '("\\([<>~]=?\\|\\.[/*^']\\|==\\|\\<xor\\>\\|[-!^&|*+\\/~:]\\)" - 1 font-lock-type-face) - ;; How about references in the HELP text. - (list (concat "^" matlab-comment-line-s "\\s-*" - "\\(\\([A-Z]+\\s-*=\\s-+\\|\\[[^]]+]\\s-*=\\s-+\\|\\)" - "\\([A-Z][0-9A-Z]+\\)\\(([^)\n]+)\\| \\)\\)") - '(1 font-lock-reference-face prepend)) - (list (concat "^" matlab-comment-line-s "\\s-*" - "See also\\s-+") - '("\\([A-Z][A-Z0-9]+\\)\\([,.]\\| and\\|$\\) *" nil nil - (1 font-lock-reference-face prepend))) - (list (concat "^" matlab-comment-line-s "\\s-*" - "\\(\\$" "Revision" "[^\n$]+\\$\\)") - '(1 font-lock-reference-face prepend)) - ;; continuation ellipsis. - '("[^.]\\(\\.\\.\\.+\\)\\([^\n]*\\)" (1 'underline) - (2 font-lock-comment-face)) - ;; How about debugging statements? - ;;'("\\<\\(db\\sw+\\)\\>" 1 'bold) - (list - (if (fboundp 'regexp-opt) - (concat "\\<\\(" (regexp-opt matlab-debug-list) "\\)\\>") - ;; pre-regexp-opt days. - "\\<\\(db\\(c\\(lear\\|ont\\)\\|down\\|mex\\|quit\\|\ -st\\(a\\(ck\\|tus\\)\\|ep\\|op\\)\\|type\\|up\\)\\)\\>") - '(0 'bold))) - (if matlab-handle-simulink - ;; Simulink functions, but only if the user wants it. - (list (list (concat "\\<\\(\\([sg]et_param\\|sim\\([gs]et\\)?\\|" - "\\(mld\\|ss\\)[A-Z]\\w+\\)\\|" - "\\(new\\|open\\|close\\|save\\|find\\)_system\\|" - "\\(add\\|delete\\|replace\\)_\\(block\\|line\\)\\|" - "simulink\\|bd\\(root\\|close\\)" - "\\)\\>") - 1 matlab-simulink-keyword-face)) - nil)) - "Expressions to highlight in MATLAB mode.") - -(defvar matlab-shell-font-lock-keywords - (list - ;; How about Errors? - '("^\\(Error in\\|Syntax error in\\)\\s-+==>\\s-+\\(.+\\)$" - (1 font-lock-comment-face) (2 font-lock-string-face)) - ;; and line numbers - '("^\\(On line [0-9]+\\)" 1 font-lock-comment-face) - ;; User beep things - '("\\(\\?\\?\\?[^\n]+\\)" 1 font-lock-comment-face) - ;; Useful user commands, but not useful programming constructs - '("\\<\\(demo\\|whatsnew\\|info\\|subscribe\\|help\\|doc\\|lookfor\\|what\ -\\|whos?\\|cd\\|clear\\|load\\|save\\|helpdesk\\|helpwin\\)\\>" - 1 font-lock-keyword-face) - ;; Various notices - '(" M A T L A B " 0 'underline) - '("All Rights Reserved" 0 'italic) - '("\\((c)\\s-+Copyright[^\n]+\\)" 1 font-lock-comment-face) - '("\\(Version\\)\\s-+\\([^\n]+\\)" - (1 font-lock-function-name-face) (2 font-lock-variable-name-face)) - ) - "Additional keywords used by MATLAB when reporting errors in interactive\ -mode.") - -;; Imenu support. -(defvar matlab-imenu-generic-expression - '((nil "^\\s-*function\\>[ \t\n.]*\\(\\(\\[[^]]*\\]\\|\\sw+\\)[ \t\n.]*\ -< =\[ \t\n.]*\\)?\\([a-zA-Z0-9_]+\\)" 3)) - "Expressions which find function headings in MATLAB M files.") - - -;;; MATLAB mode entry point ================================================== - -;;;###autoload -(add-to-list 'auto-mode-alist '("\\.m$" . matlab-mode)) - -;;;###autoload -(defun matlab-mode () - "MATLAB(R) mode is a major mode for editing MATLAB dot-m files. -\\<matlab-mode-map> -Convenient editing commands are: - \\[matlab-comment-region] - Comment/Uncomment out a region of code. - \\[matlab-fill-comment-line] - Fill the current comment line. - \\[matlab-fill-region] - Fill code and comments in region. - \\[matlab-fill-paragraph] - Refill the current command or comment. - \\[matlab-complete-symbol] - Symbol completion of matlab symbols\ -based on the local syntax. - \\[matlab-indent-sexp] - Indent syntactic block of code. - -Convenient navigation commands are: - \\[matlab-beginning-of-command] - Move to the beginning of a command. - \\[matlab-end-of-command] - Move to the end of a command. - \\[matlab-beginning-of-defun] - Move to the beginning of a function. - \\[matlab-end-of-defun] - Move do the end of a function. - \\[matlab-forward-sexp] - Move forward over a syntactic block of code. - \\[matlab-backward-sexp] - Move backwards over a syntactic block of code. - -Convenient template insertion commands: - \\[tempo-template-matlab-function] - Insert a function definition. - \\[tempo-template-matlab-if] - Insert an IF END block. - \\[tempo-template-matlab-for] - Insert a FOR END block. - \\[tempo-template-matlab-switch] - Insert a SWITCH END statement. - \\[matlab-insert-next-case] - Insert the next CASE condition in a SWITCH. - \\[matlab-insert-end-block] - Insert a matched END statement. With \ -optional ARG, reindent. - \\[matlab-stringify-region] - Convert plaintext in region to a string \ -with correctly quoted chars. - -Variables: - `matlab-indent-level' Level to indent blocks. - `matlab-cont-level' Level to indent continuation lines. - `matlab-cont-requires-ellipsis' Does your MATLAB support implied elipsis. - `matlab-case-level' Level to unindent case statements. - `matlab-indent-past-arg1-functions' - Regexp of functions to indent past the first - argument on continuation lines. - `matlab-maximum-indents' List of maximum indents during lineups. - `matlab-comment-column' Goal column for on-line comments. - `fill-column' Column used in auto-fill. - `matlab-indent-function-body' If non-nil, indents body of MATLAB functions. - `matlab-functions-have-end' If non-nil, MATLAB functions terminate with end. - `matlab-return-function' Customize RET handling with this function. - `matlab-auto-fill' Non-nil, do auto-fill at startup. - `matlab-fill-code' Non-nil, auto-fill code. - `matlab-fill-strings' Non-nil, auto-fill strings. - `matlab-verify-on-save-flag' Non-nil, enable code checks on save. - `matlab-highlight-block-match-flag' - Enable matching block begin/end keywords. - `matlab-vers-on-startup' If t, show version on start-up. - `matlab-handle-simulink' If t, enable simulink keyword highlighting. - -All Key Bindings: -\\{matlab-mode-map}" - (interactive) - (kill-all-local-variables) - (use-local-map matlab-mode-map) - (setq major-mode 'matlab-mode) - (setq mode-name "MATLAB") - (if (boundp 'whitespace-modes) - (add-to-list 'whitespace-modes 'matlab-mode)) - (setq local-abbrev-table matlab-mode-abbrev-table) - (set-syntax-table matlab-mode-syntax-table) - (setq indent-tabs-mode nil) - (make-local-variable 'indent-line-function) - (setq indent-line-function 'matlab-indent-line) - (make-local-variable 'paragraph-start) - (setq paragraph-start (concat "^$\\|" page-delimiter)) - (make-local-variable 'paragraph-separate) - (setq paragraph-separate paragraph-start) - (make-local-variable 'paragraph-ignore-fill-prefix) - (setq paragraph-ignore-fill-prefix t) - (make-local-variable 'comment-start-skip) - (setq comment-start-skip "%\\s-+") - (make-local-variable 'comment-start) - (setq comment-start "%") - (make-local-variable 'page-delimiter) - (setq page-delimiter "^\\(\f\\|%%\\(\\s-\\|\n\\)\\)") - (make-local-variable 'comment-column) - (setq comment-column matlab-comment-column) - (make-local-variable 'comment-indent-function) - (setq comment-indent-function 'matlab-comment-indent) - (make-local-variable 'add-log-current-defun-function) - (setq add-log-current-defun-function 'matlab-current-defun) - (make-local-variable 'fill-column) - (setq fill-column default-fill-column) - (make-local-variable 'auto-fill-function) - (if matlab-auto-fill (setq auto-fill-function 'matlab-auto-fill)) - ;; Emacs 20 supports this variable. This lets users turn auto-fill - ;; on and off and still get the right fill function. - (make-local-variable 'normal-auto-fill-function) - (setq normal-auto-fill-function 'matlab-auto-fill) - (make-local-variable 'fill-prefix) - (make-local-variable 'imenu-generic-expression) - (setq imenu-generic-expression matlab-imenu-generic-expression) - ;; Save hook for verifying src. This lets us change the name of - ;; the function in `write-file' and have the change be saved. - ;; It also lets us fix mistakes before a `save-and-go'. - (make-local-variable 'write-contents-hooks) - (add-hook 'write-contents-hooks 'matlab-mode-verify-fix-file-fn) - ;; Tempo tags - (make-local-variable 'tempo-local-tags) - (setq tempo-local-tags (append matlab-tempo-tags tempo-local-tags)) - ;; give each file it's own parameter history - (make-local-variable 'matlab-shell-save-and-go-history) - (make-local-variable 'font-lock-defaults) - (setq font-lock-defaults '((matlab-font-lock-keywords - matlab-gaudy-font-lock-keywords - matlab-really-gaudy-font-lock-keywords - ) - t ; do not do string/comment highlighting - nil ; keywords are case sensitive. - ;; This puts _ as a word constituent, - ;; simplifying our keywords significantly - ((?_ . "w")))) - (matlab-enable-block-highlighting 1) - (if window-system (matlab-frame-init)) - - ;; If first function is terminated with an end statement, then functions have - ;; ends. - (if (matlab-do-functions-have-end-p) - (matlab-functions-have-end-minor-mode 1) - (matlab-functions-have-end-minor-mode -1) - ) - - ;; When matlab-indent-function-body is set to 'MathWorks-Standard, - ;; - we indent all functions that terminate with an end statement - ;; - old style functions (those without end statements) are not - ;; indented. - ;; It is desired that all code be terminate with an end statement. - ;; - ;; When matlab-indent-function-body is set to 'guess, - ;; - look at the first line of code and if indented, keep indentation - ;; otherwise use MathWorks-Standard - ;; - (cond - ((eq matlab-indent-function-body 'MathWorks-Standard) - ) - - ((eq matlab-indent-function-body 'guess) - (save-excursion - (goto-char (point-max)) - - (if (re-search-backward matlab-defun-regex nil t) - (let ((beg (point)) - end ; filled in later - (cc (current-column)) - ) - (setq end (if matlab-functions-have-end - (progn (forward-line 0) (point)) - (point-max))) - (goto-char beg) - (catch 'done - (while (progn (forward-line 1) (< (point) end)) - (if (looking-at "\\s-*\\(%\\|$\\)") - nil ; go on to next line - (looking-at "\\s-*") - (goto-char (match-end 0)) - (setq matlab-indent-function-body (> (current-column) cc)) - (throw 'done nil)))) - ) - (setq matlab-indent-function-body 'MathWorks-Standard) - )) - ) - - (t) - ) - - - (if (or (featurep 'mlint) - matlab-show-mlint-warnings - matlab-highlight-cross-function-variables) - ;; Some users may not feel like getting all the extra stuff - ;; needed for mlint working. Do this only if we can get - ;; mlint loaded ok. - (condition-case nil - (mlint-minor-mode - (if (or matlab-show-mlint-warnings matlab-highlight-cross-function-variables) - 1 - 0)) - ;; If there is an error loading the stuff, don't - ;; continue. - (error nil))) - (save-excursion - (goto-char (point-min)) - (run-hooks 'matlab-mode-hook)) - (if matlab-vers-on-startup (matlab-show-version))) - -;;; Utilities ================================================================= - -(defun matlab-show-version () - "Show the version number in the minibuffer." - (interactive) - (message "matlab-mode, version %s" matlab-mode-version)) - -(defun matlab-find-prev-line () - "Recurse backwards until a code line is found." - (if (= -1 (forward-line -1)) nil - (if (or (matlab-ltype-empty) - (matlab-ltype-comm-ignore)) - (matlab-find-prev-line) t))) - -(defun matlab-prev-line () - "Go to the previous line of code. Return nil if not found." - (interactive) - (let ((old-point (point))) - (if (matlab-find-prev-line) t (goto-char old-point) nil))) - -(defun matlab-uniquafy-list (lst) - "Return a list that is a subset of LST where all elements are unique." - (let ((nlst nil)) - (while lst - (if (and (car lst) (not (member (car lst) nlst))) - (setq nlst (cons (car lst) nlst))) - (setq lst (cdr lst))) - (nreverse nlst))) - -; Aki Vehtari <Aki.Vehtari@hut.fi> recommends this: (19.29 required) -;(require 'backquote) -;(defmacro matlab-navigation-syntax (&rest body) -; "Evaluate BODY with the matlab-mode-special-syntax-table" -; '(let ((oldsyntax (syntax-table))) -; (unwind-protect -; (progn -; (set-syntax-table matlab-mode-special-syntax-table) -; ,@body) -; (set-syntax-table oldsyntax)))) - -(defmacro matlab-navigation-syntax (&rest forms) - "Set the current environment for syntax-navigation and execute FORMS." - (list 'let '((oldsyntax (syntax-table)) - (case-fold-search nil)) - (list 'unwind-protect - (list 'progn - '(set-syntax-table matlab-mode-special-syntax-table) - (cons 'progn forms)) - '(set-syntax-table oldsyntax)))) - -(put 'matlab-navigation-syntax 'lisp-indent-function 0) -(add-hook 'edebug-setup-hook - (lambda () - (def-edebug-spec matlab-navigation-syntax def-body))) - -(defun matlab-up-list (count &optional restrict) - "Move forwards or backwards up a list by COUNT. -Optional argument RESTRICT is where to restrict the search." - ;; MATLAB syntax table has no disabling strings or comments. - (let ((dir (if (> 0 count) -1 +1)) - (origin (point)) - (ms nil)) - ;; Make count positive - (setq count (* count dir)) - (if (= dir -1) - (while (/= count 0) - ;; Search till we find an unstrung paren object. - (setq ms (re-search-backward "\\s(\\|\\s)" restrict t)) - (while (and (save-match-data (matlab-cursor-in-string-or-comment)) - (setq ms (re-search-backward "\\s(\\|\\s)" restrict t)))) - (if (not ms) - (progn - (goto-char origin) - (error "Scan Error: List missmatch"))) - ;; View it's match. - (let ((s (match-string 0))) - (if (string-match "\\s(" s) - (setq count (1- count)) - (setq count (1+ count))))) - (error "Not implemented")) - ms)) - -(defun matlab-valid-end-construct-p () - "Return non-nil if the end after point terminates a block. -Return nil if it is being used to dereference an array." - (let ((p (point)) - (err1 t)) - (condition-case nil - (save-restriction - ;; Restrict navigation only to the current command line - (save-excursion - (matlab-beginning-of-command) - (narrow-to-region (point) - (save-excursion - (goto-char p) - (matlab-point-at-eol)))) - ;; This used to add some sort of protection, but I don't know what - ;; the condition was, or why the simple case doesn't handle it. - ;; - ;; The above replacement fixes a case where a continuation in an array - ;; befuddles the indenter. - ;; (progn ;;(matlab-end-of-command (point)) - ;; (end-of-line) - ;; (if (> p (point)) - ;; (progn - ;; (setq err1 nil) - ;; (error))) - ;; (point)))) - (save-excursion - ;; beginning of param list - (matlab-up-list -1) - ;; backup over the parens. If that fails - (condition-case nil - (progn - (forward-sexp 1) - ;; If we get here, the END is inside parens, which is not a - ;; valid location for the END keyword. As such it is being - ;; used to dereference array parameters - nil) - ;; This error means that we have an unterminated paren - ;; block, so this end is currently invalid. - (error nil)))) - ;; an error means the list navigation failed, which also means we are - ;; at the top-level - (error err1)))) - -;;; Regexps for MATLAB language =============================================== - -;; "-pre" means "partial regular expression" -;; "-if" and "-no-if" means "[no] Indent Function" - -(defconst matlab-defun-regex "^\\(\\s-*function\\|classdef\\)[ \t.[]" - "Regular expression defining the beginning of a MATLAB function.") - -(defconst matlab-mcos-regexp "\\|classdef\\|properties\\|methods\\|enumeration" - "Keywords which mark the beginning of mcos blocks.") - -(defcustom matlab-block-indent-tic-toc-flag nil - "*Non-nil means that tic,toc should indent like a if,end block. -This variable should be set before loading matlab.el" - :group 'matlab - :type 'boolean) - -(defconst matlab-block-beg-pre-if - (if matlab-block-indent-tic-toc-flag - (concat "function\\|parfor\\|spmd\\|for\\|while\\|if\\|switch\\|try\\|tic" - matlab-mcos-regexp) - (concat "function\\|parfor\\|spmd\\|for\\|while\\|if\\|switch\\|try" - matlab-mcos-regexp)) - "Keywords which mark the beginning of an indented block. -Includes function.") - -(defconst matlab-block-beg-pre-no-if - (if matlab-block-indent-tic-toc-flag - (concat "parfor\\|for\\|spmd\\|while\\|if\\|switch\\|try\\|tic" - matlab-mcos-regexp) - (concat "parfor\\|for\\|spmd\\|while\\|if\\|switch\\|try" - matlab-mcos-regexp)) - "Keywords which mark the beginning of an indented block. -Excludes function.") - -(defun matlab-block-beg-pre () - "Partial regular expression to recognize MATLAB block-begin keywords." - (if matlab-functions-have-end - matlab-block-beg-pre-if - matlab-block-beg-pre-no-if)) - -(defconst matlab-block-mid-pre - "elseif\\|else\\|catch" - "Partial regular expression to recognize MATLAB mid-block keywords.") - -(defconst matlab-block-end-pre-if - (if matlab-block-indent-tic-toc-flag - "end\\(function\\)?\\|function\\|\\(\\sw+\\s-*\\((.*)\\)?\\s-*=\\s-*\\)?toc" - "end\\(function\\)?\\|function") - "Partial regular expression to recognize MATLAB block-end keywords.") - -(defconst matlab-block-end-pre-no-if - (if matlab-block-indent-tic-toc-flag - "end\\|\\(\\sw+\\s-*\\((.*)\\)?\\s-*=\\s-*\\)?toc" - "end") - "Partial regular expression to recognize MATLAB block-end keywords.") - -(defun matlab-block-end-pre () - "Partial regular expression to recognize MATLAB block-end keywords." - (if matlab-functions-have-end - matlab-block-end-pre-if - matlab-block-end-pre-no-if)) - -;; Not used. -;;(defconst matlab-other-pre -;; "function\\|return" -;; "Partial regular express to recognize MATLAB non-block keywords.") - -(defconst matlab-endless-blocks - "case\\|otherwise" - "Keywords which initialize new blocks, but don't have explicit ends. -Thus, they are endless. A new case or otherwise will end a previous -endless block, and and end will end this block, plus any outside normal -blocks.") - -(defun matlab-block-re () - "Regular expression for keywords which begin MATLAB blocks." - (concat "\\(^\\|[;,]\\)\\s-*\\(" - (matlab-block-beg-pre) "\\|" - matlab-block-mid-pre "\\|" - (matlab-block-end-pre) "\\|" - matlab-endless-blocks "\\)\\b")) - -(defun matlab-block-scan-re () - "Expression used to scan over matching pairs of begin/ends." - (concat "\\(^\\|[;,]\\)\\s-*\\(" - (matlab-block-beg-pre) "\\|" - (matlab-block-end-pre) "\\)\\b")) - -(defun matlab-block-beg-re () - "Expression used to find the beginning of a block." - (concat "\\(" (matlab-block-beg-pre) "\\)")) - -(defun matlab-block-mid-re () - "Expression used to find block center parts (like else)." - (concat "\\(" matlab-block-mid-pre "\\)")) - -(defun matlab-block-end-re () - "Expression used to end a block. Usually just `end'." - (concat "\\(" (matlab-block-end-pre) "\\)")) - -(defun matlab-block-end-no-function-re () - "Expression representing and end if functions are excluded." - (concat "\\<\\(" matlab-block-end-pre-no-if "\\)\\>")) - -(defun matlab-endless-blocks-re () - "Expression of block starters that do not have associated ends." - (concat "\\(" matlab-endless-blocks "\\)")) - -(defun matlab-match-function-re () - "Expression to match a function start line. -There are no reliable numeric matches in this expression. -Know that `match-end' of 0 is the end of the functin name." - ;; old function was too unstable. - ;;"\\(^function\\s-+\\)\\([^=\n]+=[ \t\n.]*\\)?\\(\\sw+\\)" - (concat "\\(^\\s-*function\\b[ \t\n.]*\\)\\(\\(\\[[^]]*\\]\\|\\sw+\\)" - "[ \t\n.]*=[ \t\n.]*\\|\\(\\)\\)\\(\\sw+\\)")) - -(defconst matlab-cline-start-skip "[ \t]*%[ \t]*" - "*The regular expression for skipping comment start.") - -;;; Lists for matlab keywords ================================================= - -(defvar matlab-keywords-solo - '("break" "case" "else" "elseif" "end" "for" "parfor" "function" "if" "tic" "toc" - "otherwise" "profile" "switch" "while" "try" "catch" "spmd") - "Keywords that appear on a line by themselves.") -(defvar matlab-keywords-return - '("acos" "acosh" "acot" "acoth" "acsch" "asech" "asin" "asinh" - "atan" "atan2" "atanh" "cos" "cosh" "coth" "csc" "csch" "exp" - "log" "log10" "log2" "sec" "sech" "sin" "sinh" "tanh" - "abs" "sign" "sqrt" ) - "List of MATLAB keywords that have return arguments. -This list still needs lots of help.") -(defvar matlab-keywords-boolean - '("all" "any" "exist" "isempty" "isequal" "ishold" "isfinite" "isglobal" - "isinf" "isletter" "islogical" "isnan" "isprime" "isreal" "isspace" - "logical" "isa") - "List of keywords that are typically used as boolean expressions.") - -(defvar matlab-core-properties - '("ButtonDownFcn" "Children" "Clipping" "CreateFcn" "DeleteFcn" - "BusyAction" "HandleVisibility" "HitTest" "Interruptible" - "Parent" "Selected" "SelectionHighlight" "Tag" "Type" - "UIContextMenu" "UserData" "Visible") - "List of properties belonging to all HG objects.") - -(defvar matlab-property-lists - '(("root" . - ("CallbackObject" "Language" "CurrentFigure" "Diary" "DiaryFile" - "Echo" "ErrorMessage" "Format" "FormatSpacing" "PointerLocation" - "MonitorPositions" - "PointerWindow" "Profile" "ProfileFile" "ProfileCount" - "ProfileInterval" "RecursionLimit" "ScreenDepth" "ScreenSize" - "ShowHiddenHandles" "TerminalHideGraphCommand" "TerminalOneWindow" - "TerminalDimensions" "TerminalProtocol" "TerminalShowGraphCommand" - "Units" "AutomaticFileUpdates" )) - ("axes" . - ("AmbientLightColor" "Box" "CameraPosition" "CameraPositionMode" - "CameraTarget" "CameraTargetMode" "CameraUpVector" - "CameraUpVectorMode" "CameraViewAngle" "CameraViewAngleMode" "CLim" - "CLimMode" "Color" "CurrentPoint" "ColorOrder" "DataAspectRatio" - "DataAspectRatioMode" "DrawMode" "FontAngle" "FontName" "FontSize" - "FontUnits" "FontWeight" "GridLineStyle" "Layer" "LineStyleOrder" - "LineWidth" "NextPlot" "PlotBoxAspectRatio" "PlotBoxAspectRatioMode" - "Projection" "Position" "TickLength" "TickDir" "TickDirMode" "Title" - "Units" "View" "XColor" "XDir" "XGrid" "XLabel" "XAxisLocation" "XLim" - "XLimMode" "XScale" "XTick" "XTickLabel" "XTickLabelMode" "XTickMode" - "YColor" "YDir" "YGrid" "YLabel" "YAxisLocation" "YLim" "YLimMode" - "YScale" "YTick" "YTickLabel" "YTickLabelMode" "YTickMode" "ZColor" - "ZDir" "ZGrid" "ZLabel" "ZLim" "ZLimMode" "ZScale" "ZTick" - "ZTickLabel" "ZTickLabelMode" "ZTickMode")) - ("figure" . - ("BackingStore" "CloseRequestFcn" "Color" "Colormap" - "CurrentAxes" "CurrentCharacter" "CurrentObject" "CurrentPoint" - "Dithermap" "DithermapMode" "FixedColors" "IntegerHandle" - "InvertHardcopy" "KeyPressFcn" "MenuBar" "MinColormap" "Name" - "NextPlot" "NumberTitle" "PaperUnits" "PaperOrientation" - "PaperPosition" "PaperPositionMode" "PaperSize" "PaperType" - "Pointer" "PointerShapeCData" "PointerShapeHotSpot" "Position" - "Renderer" "RendererMode" "Resize" "ResizeFcn" "SelectionType" - "ShareColors" "Units" "WindowButtonDownFcn" - "WindowButtonMotionFcn" "WindowButtonUpFcn" "WindowStyle")) - ("image" . ("CData" "CDataMapping" "EraseMode" "XData" "YData")) - ("light" . ("Position" "Color" "Style")) - ("line" . - ("Color" "EraseMode" "LineStyle" "LineWidth" "Marker" "LineSmoothing" - "MarkerSize" "MarkerEdgeColor" "MarkerFaceColor" "XData" "YData" - "ZData")) - ("patch" . - ("CData" "CDataMapping" "FaceVertexCData" "EdgeColor" "EraseMode" - "FaceColor" "Faces" "LineStyle" "LineWidth" "Marker" "LineSmoothing" - "MarkerEdgeColor" "MarkerFaceColor" "MarkerSize" "Vertices" - "XData" "YData" "ZData" "FaceLighting" "EdgeLighting" - "BackFaceLighting" "AmbientStrength" "DiffuseStrength" - "SpecularStrength" "SpecularExponent" "SpecularColorReflectance" - "VertexNormals" "NormalMode")) - ("surface" . - ("CData" "CDataMapping" "EdgeColor" "EraseMode" "FaceColor" - "LineStyle" "LineWidth" "Marker" "MarkerEdgeColor" "LineSmoothing" - "MarkerFaceColor" "MarkerSize" "MeshStyle" "XData" "YData" - "ZData" "FaceLighting" "EdgeLighting" "BackFaceLighting" - "AmbientStrength" "DiffuseStrength" "SpecularStrength" - "SpecularExponent" "SpecularColorReflectance" "VertexNormals" - "NormalMode")) - ("text\\|title\\|xlabel\\|ylabel\\|zlabel" . - ("Color" "EraseMode" "Editing" "Extent" "FontAngle" "FontName" - "FontSize" "FontUnits" "FontWeight" "HorizontalAlignment" - "BackgroundColor" "EdgeColor" "Margin" - "Position" "Rotation" "String" "Units" "Interpreter" - "VerticalAlignment")) - ("uicontextmenu" . ("Callback")) - ("uicontrol" . - ("BackgroundColor" "Callback" "CData" "Enable" "Extent" - "FontAngle" "FontName" "FontSize" "FontUnits" "FontWeight" - "ForegroundColor" "HorizontalAlignment" "ListboxTop" "Max" "Min" - "Position" "String" "Style" "SliderStep" "TooltipString" "Units" - "Value")) - ("uimenu" . - ("Accelerator" "Callback" "Checked" "Enable" "ForegroundColor" - "Label" "Position" "Separator")) - ;; Flesh this out more later. - ("uipushtool\\|uitoggletool\\|uitoolbar" . - ("Cdata" "Callback" "Separator" "Visible")) - ) - "List of property lists on a per object type basis.") - -(defvar matlab-unknown-type-commands - "[gs]et\\|findobj\\|waitfor" - "Expression for commands that have unknown types.") - -(defun matlab-all-known-properties () - "Return a list of all properties." - (let ((lst matlab-core-properties) - (tl matlab-property-lists)) - (while tl - (setq lst (append lst (cdr (car tl))) - tl (cdr tl))) - (matlab-uniquafy-list lst))) - -(defvar matlab-all-known-properties (matlab-all-known-properties) - "List of all the known properties.") - -(defmacro matlab-property-function () - "Regexp of all builtin functions that take property lists." - '(let ((r matlab-unknown-type-commands) - (tl matlab-property-lists)) - (while tl - (setq r (concat r "\\|" (car (car tl))) - tl (cdr tl))) - r)) - -;;; Navigation =============================================================== - -(defvar matlab-scan-on-screen-only nil - "When this is set to non-nil, then forward/backward sexp stops off screen. -This is so the block highlighter doesn't gobble up lots of time when -a block is not terminated.") - -(defun matlab-backward-sexp (&optional autoend noerror) - "Go backwards one balanced set of MATLAB expressions. -If optional AUTOEND, then pretend we are at an end. -If optional NOERROR, then we return t on success, and nil on failure. -This assumes that expressions do not cross \"function\" at the left margin." - (interactive "P") - (matlab-navigation-syntax - (if (and (not autoend) - (save-excursion (backward-word 1) - (or (not - (and (looking-at - (matlab-block-end-no-function-re)) - (matlab-valid-end-construct-p))) - (matlab-cursor-in-string-or-comment)))) - ;; Go backwards one simple expression - (forward-sexp -1) - ;; otherwise go backwards recursively across balanced expressions - ;; backup over our end - (if (not autoend) (forward-word -1)) - (let ((done nil) (start (point)) (returnme t) (bound nil)) - (when (search-backward "\nfunction" nil t) - (if (progn (forward-char 9) (looking-at "\\b")) - (setq bound (- (point) 8))) - (goto-char start)) - (while (and (not done) - (or (not matlab-scan-on-screen-only) - (pos-visible-in-window-p))) - (if (re-search-backward (matlab-block-scan-re) bound t) - (progn - (goto-char (match-beginning 2)) - (if (looking-at (matlab-block-end-no-function-re)) - (if (or (matlab-cursor-in-string-or-comment) - (not (matlab-valid-end-construct-p))) - nil - ;; we must skip the expression and keep searching - (forward-word 1) - (matlab-backward-sexp)) - (if (not (matlab-cursor-in-string-or-comment)) - (setq done t)))) - (goto-char start) - (if noerror - (setq returnme nil) - (error "Unstarted END construct")))) - returnme)))) - -(defun matlab-forward-sexp (&optional includeelse) - "Go forward one balanced set of MATLAB expressions. -Optional argument INCLUDEELSE will stop on ELSE if it matches the starting IF." - (interactive "P") - (let (p) ;; go to here if no error. - (save-excursion ;; don't go anywhere if there is an error - (matlab-navigation-syntax - ;; skip over preceeding whitespace - (skip-chars-forward " \t\n;") - (if (or (not (looking-at (concat "\\(" - (matlab-block-beg-pre) - "\\|" - (matlab-block-mid-re) - "\\)\\>"))) - (matlab-cursor-in-string-or-comment)) - ;; Go forwards one simple expression - (forward-sexp 1) - ;; otherwise go forwards recursively across balanced expressions - (forward-word 1) - (let ((done nil) (s nil) - (expr-scan (if includeelse - (matlab-block-re) - (matlab-block-scan-re))) - (expr-look (matlab-block-beg-pre))) - (while (and (not done) - (setq s (re-search-forward expr-scan nil t)) - (or (not matlab-scan-on-screen-only) - (pos-visible-in-window-p))) - (goto-char (match-beginning 2)) - (if (looking-at expr-look) - (if (matlab-cursor-in-string-or-comment) - (forward-word 1) - ;; we must skip the expression and keep searching - ;; NEVER EVER call with value of INCLUDEELSE - (matlab-forward-sexp)) - (forward-word 1) - (if (and (not (matlab-cursor-in-string-or-comment)) - (matlab-valid-end-construct-p)) - (setq done t)))) - (if (not s) - (error "Unterminated block")))) - (setq p (point)))) ;; really go here - (goto-char p))) - -(defun matlab-indent-sexp () - "Indent the syntactic block starting at point." - (interactive) - (indent-region (point) (save-excursion (matlab-forward-sexp) (point)) nil)) - -(defun matlab-beginning-of-enclosing-defun () - "Move cursor to beginning of enclosing function. -If `matlab-functions-have-end', skip over functions with end." - (catch 'done - (let ((start (point)) - (beg nil)) - (while (re-search-backward matlab-defun-regex nil t) - (setq beg (point)) - (condition-case nil - (progn - (matlab-forward-sexp) - (if (> (point) start) (throw 'done beg))) - (error (throw 'done beg))) - (goto-char beg))) - nil)) - -(defun matlab-beginning-of-defun () - "Go to the beginning of the current function." - (interactive) - (if matlab-functions-have-end - (goto-char (or (matlab-beginning-of-enclosing-defun) (point-min))) - (or (re-search-backward matlab-defun-regex nil t) - (goto-char (point-min))))) - -(defun matlab-end-of-defun () - "Go to the end of the current function." - (interactive) - (or (progn - (if (looking-at matlab-defun-regex) (goto-char (match-end 0))) - (if (re-search-forward matlab-defun-regex nil t) - (progn (forward-line -1) - t))) - (goto-char (point-max)))) - -(defun matlab-current-defun () - "Return the name of the current function." - (save-excursion - (matlab-beginning-of-defun) - (if (looking-at (matlab-match-function-re)) - (progn - (goto-char (match-end 0)) - (current-word))))) - -(defun matlab-beginning-of-command () - "Go to the beginning of an M command. -Travels across continuations." - (interactive) - (beginning-of-line) - (let ((p nil) - ;; This restriction is a wild guess where to end reverse - ;; searching for array continuations. The reason is that - ;; matlab up list is very slow, and most people would never - ;; put a blank line in a matrix. Either way, it's worth the - ;; trade off to speed this up for large files. - ;; This list of keywords is NOT meant to be comprehensive. - (r (save-excursion - (re-search-backward - "^\\s-*\\(%\\|if\\|else\\(if\\)\\|while\\|\\(par\\)?for\\|$\\)\\>" - nil t)))) - (while (and (or (save-excursion (and (matlab-prev-line) - (matlab-lattr-cont))) - (matlab-ltype-continued-comm) - (setq p (matlab-lattr-array-cont r))) - (save-excursion (beginning-of-line) (not (bobp)))) - (if p (goto-char p) (matlab-prev-line)) - (setq p nil)) - (back-to-indentation))) - -(defun matlab-end-of-command (&optional beginning) - "Go to the end of an M command. -Optional BEGINNING is where the command starts from." - (interactive) - (while (and (or (matlab-lattr-cont) - (save-excursion - (forward-line 1) - (or (matlab-ltype-continued-comm) - (matlab-lattr-array-cont beginning)))) - ;; This hack is a short circuit. If a user did not - ;; correctly end a matrix, this will short-circuit - ;; as soon as somethng that would never appear in a matrix - ;; becomes visible. - (not (save-excursion - (beginning-of-line) - (looking-at (matlab-block-scan-re)))) - ;; If we hit the end of the buffer unexpectedly, this test - ;; will fail and we'll avoid looping forever. (E.g., this - ;; is triggered if a continuation line is the last one in - ;; the buffer, and the line lacks the final newline.) - (zerop (forward-line 1)))) - (end-of-line)) - - -;;; Line types and attributes ================================================= - -(defun matlab-ltype-empty () ; blank line - "Return t if current line is empty." - (save-excursion - (beginning-of-line) - (looking-at "^[ \t]*$"))) - -(defun matlab-ltype-comm () ; comment line - "Return t if current line is a MATLAB comment line. -Return the symbol 'cellstart if it is a double %%. -Return the symbol 'blockcomm if it is a block comment start." - (save-excursion - (beginning-of-line) - (cond ((looking-at "[ \t]*%\\([^%]\\|$\\)") - t) - ((looking-at "[ \t]*%%") - 'cellstart) - ((matlab-ltype-block-comm) - 'blockcomm) - (t nil)))) - -(defun matlab-ltype-comm-ignore () ; comment out a region line - "Return t if current line is a MATLAB comment region line." - (save-excursion - (beginning-of-line) - (looking-at (concat "[ \t]*" matlab-comment-region-s)))) - -(defun matlab-ltype-help-comm () - "Return t if the current line is part of the MATLAB help comment." - (save-excursion - (if (not (matlab-ltype-comm)) - nil - (while (and (matlab-ltype-comm) (not (bobp)) - (matlab-prev-line)) - (beginning-of-line)) - (matlab-ltype-function-definition)))) - -(defun matlab-ltype-block-comm () - "Return t if we are in a block comment." - (save-excursion - (if (looking-at "%{") - t - (when (re-search-backward "\\%\\([{}]\\)" nil t) - (let ((ms (match-string 1))) - (if (string= ms "{") t nil)))))) - -(defun matlab-ltype-endfunction-comm () - "Return t if the current line is an ENDFUNCTION style comment." - (save-excursion - (if (not (matlab-ltype-comm)) - nil - (beginning-of-line) - (if (looking-at "^[ \t]*%[ \t]*endfunction") - t - (while (and (or (matlab-ltype-comm) - (matlab-ltype-empty)) - (not (eobp))) - (forward-line 1)) - (and (matlab-ltype-function-definition) - (not (save-excursion (matlab-beginning-of-enclosing-defun)))) - )))) - -(defun matlab-ltype-continued-comm () - "Return column of previous line's comment start, or nil." - (save-excursion - (beginning-of-line) - (let ((commtype (matlab-ltype-comm))) - (if (or (eq commtype 'cellstart) ;; Cells are not continuations from previous comments. - (null commtype) - (bobp)) - nil - ;; We use forward-line and not matlab-prev-line because - ;; we want blank lines to terminate this indentation method. - (forward-line -1) - (let ((col (matlab-lattr-comm))) - (if col - (progn - (goto-char col) - (current-column)) - nil)))))) - -(defun matlab-ltype-function-definition () - "Return t if the current line is a function definition." - (save-excursion - (beginning-of-line) - (looking-at matlab-defun-regex))) - -(defun matlab-ltype-code () ; line of code - "Return t if current line is a MATLAB code line." - (and (not (matlab-ltype-empty)) (not (matlab-ltype-comm)))) - -(defun matlab-lattr-comm () ; line has comment - "Return t if current line contain a comment." - (save-excursion (matlab-comment-on-line))) - -(defun matlab-lattr-implied-continuation () - "Return non-nil if this line has implied continuation on the next. -This is only useful for new versions of MATLAB where ... is optional." - (when (not (matlab-lattr-comm)) - (let ((imp nil)) - (save-excursion - (end-of-line) - (skip-chars-backward " \t") - ;; Test for oporator incompleteness. - (setq imp - (/= (point) - ;; Careful, - means range in this expression. - (progn (skip-chars-backward "-+=/*.^&~<>") - (point)))) - (if (not imp) - ;; Test for argument list incompleteness - (condition-case nil - (progn - (end-of-line) - (matlab-up-list -1) - (setq imp (looking-at "("))) - (error nil))) - ) - imp))) - -(defun matlab-lattr-cont () ; line has continuation - "Return non-nil if current line ends in ... and optional comment. -If `matlab-cont-requires-ellipsis' is nil, then we need to apply -a heuristic to determine if this line would use continuation -based on what it ends with." - (save-excursion - (beginning-of-line) - (or - ;; Here, if the line ends in ..., then it is what we are supposed to do. - (and (re-search-forward "[^ \t.][ \t]*\\.\\.+[ \t]*\\(%.*\\)?$" - (matlab-point-at-eol) t) - (progn (goto-char (match-beginning 0)) - (not (matlab-cursor-in-comment)))) - ;; If the line doesn't end in ..., but we have optional ..., then - ;; use this annoying heuristic. - (and (null matlab-cont-requires-ellipsis) - (matlab-lattr-implied-continuation)) - ))) - -(defun matlab-lattr-array-cont (&optional restrict) - "Return non-nil if current line is in an array. -If the entirety of the array is on this line, return nil. -Optional option RESTRICT is the distrance to restrict the search." - (condition-case nil - (save-excursion - (beginning-of-line) - (matlab-up-list -1 restrict) - (and (looking-at "[[{]") (point))) - (error nil))) - -(defun matlab-lattr-array-end () - "Return non-nil if the current line closes an array. -by close, the first character is the end of an array." - (save-excursion - (back-to-indentation) - (and (looking-at "[]}]") (matlab-lattr-array-cont)))) - -(defun matlab-lattr-block-cont (&optional eol) - "Return a number representing the number of unterminated block constructs. -This is any block, such as if or for, that doesn't have an END on this line. -Optional EOL indicates a virtual end of line." - (let ((v 0)) - (save-excursion - (beginning-of-line) - (save-restriction - (narrow-to-region (point) (or eol (matlab-point-at-eol))) - (matlab-navigation-syntax - (while (re-search-forward (concat "\\<" (matlab-block-beg-re) "\\>") - nil t) - (if (matlab-cursor-in-string-or-comment) - ;; Do nothing - nil - ;; Increment counter, move to end. - (setq v (1+ v)) - (let ((p (point))) - (forward-word -1) - (condition-case nil - (progn - (matlab-forward-sexp) - (setq v (1- v))) - (error (goto-char p)))))) - v))))) - -(defun matlab-lattr-middle-block-cont () - "Return the number of middle block continuations. -This should be 1 or nil, and only true if the line starts with one of these -special items." - (save-excursion - (back-to-indentation) - (if (looking-at (concat (matlab-block-mid-re) "\\>")) - (if (and (re-search-forward (matlab-block-end-pre) - (matlab-point-at-eol) - t) - (matlab-valid-end-construct-p)) - ;; If there is an END, we still need to return non-nil, - ;; but the number value is a net of 0. - 0 - 1) - nil))) - -(defun matlab-lattr-endless-block-cont () - "Return the number of middle block continuations. -This should be 1 or nil, and only true if the line starts with one of these -special items." - (save-excursion - (back-to-indentation) - (if (looking-at (concat (matlab-endless-blocks-re) "\\>")) - 1 - nil))) - -(defun matlab-lattr-block-close (&optional start) - "Return the number of closing block constructs. -Argument START is where to start searching from." - (let ((v 0)) - (save-excursion - (when start (goto-char start)) - (save-restriction - (narrow-to-region (save-excursion - (matlab-beginning-of-command) - (point)) - (matlab-point-at-eol)) - (goto-char (point-max)) - (while (and (re-search-backward (concat "\\<" (matlab-block-end-re) "\\>") - nil t) - (not (matlab-cursor-in-string-or-comment)) - (matlab-valid-end-construct-p)) - (setq v (1+ v)) - (let ((startmove (match-end 0)) - (nomove (point))) - (condition-case nil - (progn - (matlab-backward-sexp t) - (setq v (1- v))) - (error (goto-char nomove))) - )) - ;; If we can't scoot back, do a cheat-test to see if there - ;; is a matching else or elseif. - (goto-char (point-min)) - (back-to-indentation) - (if (looking-at (matlab-block-mid-re)) - (setq v (1- v))) - ;; Return nil, or a number - (if (<= v 0) nil v))))) - -(defun matlab-lattr-local-end () - "Return t if this line begins with an end construct." - (save-excursion - (back-to-indentation) - (and (looking-at (concat "\\<" (matlab-block-end-re) "\\>")) - (matlab-valid-end-construct-p)))) - -(defun matlab-lattr-semantics (&optional prefix) - "Return the semantics of the current position. -Values are nil 'solo, 'value, and 'boolean. Boolean is a subset of -value. nil means there is no semantic content (ie, string or comment.) -If optional PREFIX, then return 'solo if that is the only thing on the -line." - (cond ;((matlab-cursor-in-string-or-comment) - ;nil) - ((or (matlab-ltype-empty) - (and prefix (save-excursion - (beginning-of-line) - (looking-at (concat "\\s-*" prefix "\\s-*$"))))) - 'solo) - ((save-excursion - (matlab-beginning-of-command) - (looking-at "\\s-*\\(if\\|elseif\\|while\\)\\>")) - 'boolean) - ((save-excursion - (matlab-beginning-of-command) - (looking-at (concat "\\s-*\\(" (matlab-property-function) - "\\)\\>"))) - 'property) - (t - 'value))) - -(defun matlab-function-called-at-point () - "Return a string representing the function called nearby point." - (save-excursion - (beginning-of-line) - (cond ((looking-at "\\s-*\\([a-zA-Z]\\w+\\)[^=][^=]") - (match-string 1)) - ((and (re-search-forward "=" (matlab-point-at-eol) t) - (looking-at "\\s-*\\([a-zA-Z]\\w+\\)\\s-*[^=]")) - (match-string 1)) - (t nil)))) - -(defun matlab-cursor-in-string-or-comment () - "Return t if the cursor is in a valid MATLAB comment or string." - ;; comment and string depend on each other. Here is one test - ;; that does both. - (save-restriction - (narrow-to-region (matlab-point-at-bol) (matlab-point-at-eol)) - (let ((p (1+ (point))) - (returnme nil) - (sregex (concat matlab-string-start-regexp "'"))) - (save-excursion - (goto-char (point-min)) - (while (and (re-search-forward - (concat "'\\|%\\|" (regexp-quote matlab-elipsis-string)) - nil t) - (<= (point) p)) - (if (or (= ?% (preceding-char)) - (= ?. (preceding-char))) - ;; Here we are in a comment for the rest of it. - (progn - (goto-char p) - (setq returnme t)) - ;; Here, we could be a string start, or transpose... - (if (or (= (current-column) 1) - (save-excursion (forward-char -2) - (looking-at sregex))) - ;; a valid string start, find the end - (let ((f (re-search-forward matlab-string-end-regexp nil t))) - (if f - (setq returnme (> (point) p)) - (setq returnme t))) - ;; Ooops, a transpose, keep going. - )))) - returnme))) - -(defun matlab-cursor-in-comment () - "Return t if the cursor is in a valid MATLAB comment." - (save-match-data - (save-restriction - (narrow-to-region (matlab-point-at-bol) (matlab-point-at-eol)) - (save-excursion - (let ((prev-match nil)) - (while (and (re-search-backward - (concat "%\\|" (regexp-quote matlab-elipsis-string) "+") - nil t) - (not (matlab-cursor-in-string))) - (setq prev-match (point))) - (if (and prev-match (matlab-cursor-in-string)) - (goto-char prev-match)) - (and (looking-at (concat "%\\|" - (regexp-quote matlab-elipsis-string))) - (not (matlab-cursor-in-string)))))))) - -(defun matlab-cursor-in-string (&optional incomplete) - "Return t if the cursor is in a valid MATLAB string. -If the optional argument INCOMPLETE is non-nil, then return t if we -are in what could be a an incomplete string." - (let ((m (match-data)) - (returnme nil)) - (save-restriction - (narrow-to-region (matlab-point-at-bol) (matlab-point-at-eol)) - (let ((p (1+ (point))) - - (sregex (concat matlab-string-start-regexp "'")) - (instring nil)) - (save-excursion - ;; Comment hunters need strings to not call the comment - ;; identifiers. Thus, this routines must be savvy of comments - ;; without recursing to them. - (goto-char (point-min)) - (while (or (and instring (looking-at "'")) - (and (re-search-forward - (concat "'\\|%\\|" - (regexp-quote matlab-elipsis-string)) - nil t) - (<= (point) p) - ;; Short circuit to fix this. - (progn (setq instring nil) t))) - ;; The next line emulates re-search-foward - (if instring (goto-char (match-end 0))) - (if (or (= ?% (preceding-char)) - (= ?. (preceding-char))) - ;; Here we are in a comment for the rest of it. - ;; thus returnme is a force-false. - (goto-char p) - ;; Here, we could be in a string start, or transpose... - (if (or (= (current-column) 1) - instring - (save-excursion (forward-char -2) - (looking-at sregex))) - ;; a valid string start, find the end - (let ((f (re-search-forward matlab-string-end-regexp nil t))) - (if (and (not f) incomplete) - (setq returnme t) - (setq returnme (> (point) p)) - (setq instring t))) - ;; Ooops, a transpose, keep going. - )))))) - (set-match-data m) - returnme)) - - -(defun matlab-comment-on-line () - "Place the cursor on the beginning of a valid comment on this line. -If there isn't one, then return nil, point otherwise." - (interactive) - (let ((eol (matlab-point-at-eol)) - (p (point)) - (signal-error-on-buffer-boundary nil)) - (beginning-of-line) - (while (and (re-search-forward "%" eol t) - (save-excursion (forward-char -1) (matlab-cursor-in-string t)))) - (if (not (bolp)) (forward-char -1)) - (if (and (looking-at "%") (not (matlab-cursor-in-string t))) - (point) - (goto-char p) - nil))) - -;;; Indent functions ========================================================== - -(defun matlab-indent-line () - "Indent a line in `matlab-mode'." - (interactive) - (let ((i (matlab-calc-indent)) - (c (current-column))) - (save-excursion - (back-to-indentation) - (if (= i (current-column)) - nil - (beginning-of-line) - (delete-horizontal-space) - (indent-to i)) - ;; If line contains a comment, format it. - (if () (if (matlab-lattr-comm) (matlab-comment)))) - (if (<= c i) (move-to-column i)))) - -(defun matlab-calc-indent () - "Return the appropriate indentation for this line as an integer." - (interactive) - ;; The first step is to find the current indentation. - ;; This is defined to be zero if all previous lines are empty. - (let* ((ci (save-excursion (if (not (matlab-prev-line)) - 0 - (matlab-next-line-indentation)))) - (sem (matlab-calculate-indentation ci))) - ;; simplistic - (nth 1 sem))) - -(defconst matlab-functions-have-end-should-be-true - "This end closes a function definition.\nDo you want functions to have ends? " - "Prompt the user about whether to change matlab-functions-have-end") - -(defun matlab-calculate-indentation (current-indentation) - "Calculate out the indentation of the current line. -Return a list of descriptions for this line. Return format is: - '(TYPE DEPTHNUMBER) -where TYPE is one of (comment, code, function, blockstart, blockmid, -blockendless, blockend) DEPTHNUMBER is how many characters to indent -this line. - Argument CURRENT-INDENTATION is what the previous line thinks -this line's indentation should be. See `matlab-next-line-indentation'." - (matlab-navigation-syntax - (matlab-calculate-indentation-1 current-indentation))) - -(defun matlab-calculate-indentation-1 (current-indentation) - "Do the indentation work of `matlab-calculate-indentation'. -Argument CURRENT-INDENTATION is what the previous line recommends for indentation." - (let ((ci current-indentation) - (tmp nil)) - (cond - ;; COMMENTS - ((matlab-ltype-comm) - (cond - ;; HELP COMMENT and COMMENT REGION - ((or (matlab-ltype-help-comm) - (matlab-ltype-comm-ignore)) - (list 'comment-help - (save-excursion - (matlab-beginning-of-defun) - (current-indentation)))) - ;; COMMENT Continued From Previous Line - ((setq tmp (matlab-ltype-continued-comm)) - (list 'comment tmp)) - ;; END FUNCTION COMMENT - ((matlab-ltype-endfunction-comm) - (list 'comment-endfunction 0)) - (t - (list 'comment (+ ci matlab-comment-anti-indent))))) - ;; FUNCTION DEFINITION - ((matlab-ltype-function-definition) - (if matlab-functions-have-end - ;; A function line has intrinsic indentation iff function bodies are - ;; not indented and the function line is nested within another function. - (if (and (not (matlab-indent-function-body-p)) - (save-excursion - (beginning-of-line) - (matlab-beginning-of-enclosing-defun))) - (setq ci (+ ci matlab-indent-level)) - ;; If no intrinsic indentation, do not change from ci. - ) - ;; If functions are not nested, functions go to left margin. - (setq ci 0)) - (list 'function ci)) - ;; END keyword - ((matlab-lattr-local-end) - (let ((end-of-function - (let ((matlab-functions-have-end t)) - (save-excursion - (beginning-of-line) - (matlab-backward-sexp t) ;; may throw "unstarted block" error - (matlab-ltype-function-definition))))) - (if end-of-function - (if (or matlab-functions-have-end - (if (yes-or-no-p matlab-functions-have-end-should-be-true) - ;; TODO - ask user to reindent the fcn now? - (setq matlab-functions-have-end t) - (error "Unmatched end"))) - (if (matlab-indent-function-body-p) - (setq ci (- ci matlab-indent-level)))) - ;; Next, see if this line starts with an end, and whether the - ;; end is matched, and whether the line is blank up to the match. - ;; If so, return the indentation of the match. - (catch 'indent - (save-excursion - (when (progn (beginning-of-line) - (and (looking-at "[ \t]*end\\b") - (matlab-backward-sexp t t))) - (let ((match (point))) - (beginning-of-line) - (looking-at "[ \t]*") - (when (= match (match-end 0)) - (setq ci (- match (match-beginning 0))) - (throw 'indent nil))))) - ;; End of special case for end and match after "^[ \t]*". - (setq ci (+ ci - (* (1- (matlab-lattr-block-cont (point))) - matlab-indent-level)))))) - (list 'blockend ci)) - ;; ELSE/CATCH keywords - ((matlab-lattr-middle-block-cont) - (let ((m (match-string 1))) - (list 'blockmid - (condition-case nil - (save-excursion - (beginning-of-line) - (matlab-backward-sexp t) - (if (matlab-ltype-function-definition) (error "")) - (current-column)) - (error (error "Unmatched %s" m)))))) - ;; CASE/OTHERWISE keywords - ((matlab-lattr-endless-block-cont) - (list 'blockendless - (condition-case nil - (save-excursion - (beginning-of-line) - (matlab-backward-sexp t) - (if (not (looking-at "switch\\>")) (error "")) - (+ (current-column) - (if (listp matlab-case-level) - (car matlab-case-level) - matlab-case-level))) - (error (error "Unmatched case/otherwise part"))))) - ;; End of a MATRIX - ((matlab-lattr-array-end) - (list 'array-end (save-excursion - (back-to-indentation) - (matlab-up-list -1) - (let* ((fc (following-char)) - (mi (assoc fc matlab-maximum-indents)) - (max (if mi (if (listp (cdr mi)) - (car (cdr mi)) (cdr mi)) - nil)) - (ind (if mi (if (listp (cdr mi)) - (cdr (cdr mi)) (cdr mi)) - nil))) - ;; apply the maximum limits. - (if (and ind (> (- (current-column) ci) max)) - (1- ind) ; decor - (current-column)))))) - ;; Code lines - ((save-excursion - (beginning-of-line) - (back-to-indentation) - (= (point) (progn (matlab-beginning-of-command) (point)))) - ;; This means we are at the beginning of a command structure. - ;; Always match up against the previous line. - (list 'code ci)) - ;; Lines continued from previous statements. - (t - (list (if (matlab-ltype-empty) 'empty - (if (matlab-lattr-array-cont) 'array-cont 'code)) - (condition-case nil - ;; Line up with opening paren/brace/bracket - (let ((boc (save-excursion - (matlab-beginning-of-command) - (point)))) - (save-excursion - (beginning-of-line) - (matlab-up-list -1) - (if (> boc (point)) (error nil)) - ;; Ok, it MIGHT be that we are in a program - ;; statement, and this particular command is an HG - ;; statement that would look better if the - ;; following lines lined up AFTER the first - ;; argument. Lets look. - (let ((parendepth (current-column))) - (cond ((and (= (following-char) ?\( ) - (save-excursion - (matlab-navigation-syntax - (forward-word -1) - (looking-at - matlab-indent-past-arg1-functions))) - (let ((start-paren (point))) - (while - (and - (re-search-forward - "," (matlab-point-at-eol) t) - (save-excursion - (matlab-up-list -1) - (> (point) start-paren)))) - (if (and - (= (preceding-char) ?,) - ;; Don't bother if we hit the EOL. - (not (looking-at - - "\\s-*\\(\\.\\.\\.\\|$\\|)\\)"))) - t - (move-to-column parendepth) - nil))) - (skip-chars-forward " \t") - (if (> (- (current-column) parendepth) - matlab-arg1-max-indent-length) - (+ parendepth matlab-arg1-max-indent-length) - (current-column))) - (t - (let* ((fc (following-char)) - (mi (assoc fc matlab-maximum-indents)) - (max (if mi - (if (listp (cdr mi)) - (car (cdr mi)) (cdr mi)) - nil)) - (ind (if mi - (if (listp (cdr mi)) - (cdr (cdr mi)) (cdr mi)) - nil))) - (forward-char 1) - (skip-chars-forward " \t") - ;; If we are at the end of a line and - ;; this open paren is there, then we - ;; DONT want to indent to it. Use the - ;; standard indent. - (if (looking-at "\\.\\.\\.\\|$") - ;; This could happen in another set - ;; of matricies. Find a current - ;; indentation based on the - ;; previous line. - (let ((cci (current-indentation))) - (+ cci matlab-cont-level)) - ;; apply the maximum limits. - (if (and ind (> (- (current-column) ci) max)) - (+ ci ind) - (current-column))))))))) - (error - ;; Line up to an equals sign. - (save-excursion - (matlab-beginning-of-command) - (while (and (re-search-forward "=" (matlab-point-at-eol) t) - (matlab-cursor-in-string-or-comment))) - (if (/= (preceding-char) ?=) - (+ ci matlab-cont-level) - (skip-chars-forward " \t") - (let ((cc (current-column)) - (mi (assoc ?= matlab-maximum-indents))) - (if (looking-at "\\.\\.\\.\\|$") - ;; In this case, the user obviously wants the - ;; indentation to be somewhere else. - (+ ci (cdr (cdr mi))) - ;; If the indent delta is greater than the max, - ;; use the max + currenti - (if (and mi (> (- cc ci) (if (listp (cdr mi)) - (car (cdr mi)) - (cdr mi)))) - (setq cc (+ ci (if (listp (cdr mi)) - (cdr (cdr mi)) - (cdr mi))))) - cc)))))))) - ))) - -(defun matlab-next-line-indentation () - "Calculate the indentation for lines following this command line. -Assume that the following line does not contribute its own indentation -\(as it does in the case of nested functions in the following situations): - o function---positive indentation when not indenting function bodies. - o end---negative indentation except when the 'end' matches a function and - not indenting function bodies. -See `matlab-calculate-indentation'." - (matlab-navigation-syntax - (let ((startpnt (point-at-eol))) - (save-excursion - (matlab-beginning-of-command) - (let ((cc (or (matlab-lattr-block-close startpnt) 0)) - (end (matlab-lattr-local-end)) - (bc (matlab-lattr-block-cont startpnt)) - (mc (matlab-lattr-middle-block-cont)) - (ec (matlab-lattr-endless-block-cont)) - (hc (and (matlab-indent-function-body-p) (matlab-ltype-help-comm))) - (rc (and (/= 0 matlab-comment-anti-indent) - (matlab-ltype-comm) - (not (matlab-ltype-help-comm)) - (not (matlab-ltype-continued-comm)) - (not (matlab-ltype-endfunction-comm)))) - (ci (current-indentation))) - ;; When the current point is on a line with a function, the value of bc will - ;; reflect the function in a block count iff if matlab-functions-have-end is - ;; true. However, if matlab-indent-function-body-p is false, there should be - ;; no actual indentation, so bc needs to be decremented by 1. Similarly, if - ;; on a line with an end that closes a function, bc needs to be decremented - ;; by 1 if matlab-functions-have-end is true and matlab-indent-function-body-p - ;; is false. However, just to be safe, indentation is not allowed to go - ;; negative. Thus: - (if matlab-functions-have-end - (if (and - (not (matlab-indent-function-body-p)) - (or (matlab-ltype-function-definition) - (and (matlab-lattr-local-end) - (save-excursion - (matlab-backward-sexp t) - (looking-at "function\\b"))))) - (if (> bc 0) - (setq bc (1- bc)) - (if (>= ci matlab-indent-level) - (setq bc -1)))) - (if (and (matlab-indent-function-body-p) (matlab-ltype-function-definition)) - (setq bc (1+ bc)))) - ;; Remove 1 from the close count if there is an END on the beginning - ;; of this line, since in that case, the unindent has already happened. - (when end (setq cc (1- cc))) - ;; Calculate the suggested indentation. - (+ ci - (* matlab-indent-level bc) - (* matlab-indent-level (or mc 0)) - (* matlab-indent-level (- cc)) - (* (if (listp matlab-case-level) - (cdr matlab-case-level) matlab-case-level) - (or ec 0)) - (if hc matlab-indent-level 0) - (if rc (- 0 matlab-comment-anti-indent) 0) - )))))) - -;;; The return key ============================================================ - -(defcustom matlab-return-function 'matlab-indent-end-before-ret - "Function to handle return key. -Must be one of: - 'matlab-plain-ret - 'matlab-indent-after-ret - 'matlab-indent-end-before-ret - 'matlab-indent-before-ret" - :group 'matlab - :type '(choice (function-item matlab-plain-ret) - (function-item matlab-indent-after-ret) - (function-item matlab-indent-end-before-ret) - (function-item matlab-indent-before-ret))) - -(defun matlab-return () - "Handle carriage return in `matlab-mode'." - (interactive) - (matlab-semicolon-on-return) - (funcall matlab-return-function)) - -(defun matlab-plain-ret () - "Vanilla new line." - (interactive) - (newline)) - -(defun matlab-indent-after-ret () - "Indent after new line." - (interactive) - (newline) - (matlab-indent-line)) - -(defun matlab-indent-end-before-ret () - "Indent line if block end, start new line, and indent again." - (interactive) - (if (save-excursion - (beginning-of-line) - (looking-at (concat "^\\s-*\\(" (matlab-block-end-re) - "\\|" (matlab-block-mid-re) - "\\|" (matlab-endless-blocks-re) - "\\|function\\)"))) - (matlab-indent-line)) - (newline) - (matlab-indent-line)) - -(defun matlab-semicolon-on-return () - "If needed, add a semicolon at point automatically." - (if matlab-return-add-semicolon - (if (and (not (matlab-ltype-empty)) - (not (save-excursion - (skip-chars-backward " \t;" (matlab-point-at-bol)) - (looking-at "\\s-*;"))) - (save-excursion - (let ((p (point))) - (matlab-end-of-command (point)) - (eq p (point)))) - (save-excursion - (matlab-beginning-of-command) - ;; Note: Compile warning below, but defined later. - (not (looking-at matlab-quiesce-nosemi-regexp)))) - (insert ";")) - )) - -(defun matlab-indent-before-ret () - "Indent line, start new line, and indent again." - (interactive) - (matlab-indent-line) - (newline) - (matlab-indent-line)) - -(defun matlab-linefeed () - "Handle line feed in `matlab-mode'. -Has effect of `matlab-return' with (not matlab-indent-before-return)." - (interactive) - (matlab-indent-line) - (newline) - (matlab-indent-line)) - -(defun matlab-comment-return () - "Handle carriage return for MATLAB comment line." - (interactive) - (cond - ((matlab-ltype-comm) - (matlab-set-comm-fill-prefix) (newline) (insert fill-prefix) - (matlab-reset-fill-prefix) (matlab-indent-line)) - ((matlab-lattr-comm) - (newline) (indent-to comment-column) - (insert matlab-comment-on-line-s)) - (t - (newline) (matlab-comment) (matlab-indent-line)))) - -(defun matlab-comm-from-prev () - "If the previous line is a comment-line then set up a comment on this line." - (save-excursion - ;; If the previous line is a comment-line then set the fill prefix from - ;; the previous line and fill this line. - (if (and (= 0 (forward-line -1)) (matlab-ltype-comm)) - (progn - (matlab-set-comm-fill-prefix) - (forward-line 1) (beginning-of-line) - (delete-horizontal-space) - (if (looking-at "%") (delete-char 1)) - (delete-horizontal-space) - (insert fill-prefix) - (matlab-reset-fill-prefix))))) - -(defun matlab-electric-comment (arg) - "Indent line and insert comment character. -Argument ARG specifies how many %s to insert." - (interactive "P") - (self-insert-command (or arg 1)) - (when (matlab-ltype-comm) - (matlab-indent-line) - ;; The above seems to put the cursor on the %, not after it. - (skip-chars-forward "%"))) - - -;;; Comment management======================================================== - -(defun matlab-comment () - "Add a comment to the current line." - (interactive) - (cond ((matlab-ltype-empty) ; empty line - (matlab-comm-from-prev) - (if (matlab-lattr-comm) - (skip-chars-forward " \t%") - (insert matlab-comment-line-s) - (matlab-indent-line))) - ((matlab-ltype-comm) ; comment line - (matlab-comm-from-prev) - (skip-chars-forward " \t%")) - ((matlab-lattr-comm) ; code line w/ comment - (beginning-of-line) - (re-search-forward "[^%]%[ \t]") - (forward-char -2) - (if (> (current-column) comment-column) (delete-horizontal-space)) - (if (< (current-column) comment-column) (indent-to comment-column)) - (skip-chars-forward "% \t")) - (t ; code line w/o comment - (end-of-line) - (re-search-backward "[^ \t\n^]" 0 t) - (forward-char) - (delete-horizontal-space) - (if (< (current-column) comment-column) - (indent-to comment-column) - (insert " ")) - (insert matlab-comment-on-line-s)))) - -(defun matlab-comment-line-break-function (&optional soft) - "Break the current line, and if in a comment, continue it. -Optional argument SOFT indicates that the newline is soft, and not hard." - (interactive) - (if (not (matlab-cursor-in-comment)) - (matlab-return) - ;; Will the below fn work in old emacsen? - (if soft (insert-and-inherit ?\n) (newline 1)) - (insert "% ") - (matlab-indent-line) - (end-of-line))) - -(defun matlab-comment-indent () - "Indent a comment line in `matlab-mode'." - (matlab-calc-indent)) - -(defun matlab-comment-region (beg-region end-region arg) - "Comments every line in the region. -Puts `matlab-comment-region-s' at the beginning of every line in the region. -BEG-REGION and END-REGION are arguments which specify the region boundaries. -With non-nil ARG, uncomments the region." - (interactive "*r\nP") - (let ((end-region-mark (make-marker)) (save-point (point-marker))) - (set-marker end-region-mark end-region) - (goto-char beg-region) - (beginning-of-line) - (if (not arg) ;comment the region - (progn (insert matlab-comment-region-s) - (while (and (= (forward-line 1) 0) - (< (point) end-region-mark)) - (insert matlab-comment-region-s))) - (let ((com (regexp-quote matlab-comment-region-s))) ;uncomment the region - (if (looking-at com) - (delete-region (point) (match-end 0))) - (while (and (= (forward-line 1) 0) - (< (point) end-region-mark)) - (if (looking-at com) - (delete-region (point) (match-end 0)))))) - (goto-char save-point) - (set-marker end-region-mark nil) - (set-marker save-point nil))) - -(defun matlab-uncomment-region (beg end) - "Uncomment the current region if it is commented out. -Argument BEG and END indicate the region to uncomment." - (interactive "*r") - (matlab-comment-region beg end t)) - -;;; Filling =================================================================== - -(defun matlab-set-comm-fill-prefix () - "Set the `fill-prefix' for the current (comment) line." - (interactive) - (if (matlab-lattr-comm) - (setq fill-prefix - (save-excursion - (beginning-of-line) - (let ((e (matlab-point-at-eol)) - (pf nil)) - (while (and (re-search-forward "%+[ \t]*\\($$$ \\)?" e t) - (matlab-cursor-in-string))) - (setq pf (match-string 0)) - (concat (make-string (- (current-column) (length pf)) ? ) - pf)))))) - -(defun matlab-set-comm-fill-prefix-post-code () - "Set the `fill-prefix' for the current post-code comment line." - (interactive) - (matlab-set-comm-fill-prefix)) - -(defun matlab-reset-fill-prefix () - "Reset the `fill-prefix'." - (setq fill-prefix nil)) - -(defun matlab-find-convenient-line-break () - "For the current line, position the cursor where we want to break the line. -Basically, spaces are best, then operators. Always less than `fill-column' -unless we decide we can fudge the numbers. Return nil if this line should -not be broken. This function will ONLY work on code." - ;; First of all, if this is a continuation, then the user is - ;; requesting that we don't mess with his stuff. - (if (matlab-lattr-cont) - nil - (save-restriction - (narrow-to-region (matlab-point-at-bol) (matlab-point-at-eol)) - ;; get ourselves onto the fill-column. - (move-to-column fill-column) - (let ((pos nil) - (orig (point))) - (or - ;; Next, if we have a trailing comment, use that. - (progn (setq pos (or (matlab-lattr-comm) (matlab-point-at-bol))) - (goto-char pos) - (if (and (> (current-column) (- fill-column matlab-fill-fudge)) - (< (current-column) (+ fill-column matlab-fill-fudge))) - t - (goto-char orig) - nil)) - ;; Now, lets find the nearest space (after or before fill column) - (let* ((after (save-excursion - (re-search-forward "[ \t]" nil t))) - (before (save-excursion - (re-search-backward "[ \t]" nil t))) - (afterd (- (or after (matlab-point-at-eol)) (point))) - (befored (- (point) (or before (matlab-point-at-bol))))) - ;; Here, if "before" is actually the beginning of our - ;; indentation, then this is most obiously a bad place to - ;; break our lines. - (if before - (save-excursion - (goto-char before) - (if (<= (point) (save-excursion - (back-to-indentation) - (point))) - (setq before nil)))) - (cond ((and after - (< afterd matlab-fill-fudge) - (< afterd befored)) - (goto-char after) - t) - ((and before - (< befored matlab-fill-fudge) - (< befored afterd)) - (goto-char before) - t) - (t (goto-char orig) - nil))) - ;; Now, lets find the nearest backwards - (progn - (re-search-backward "\\(\\s-\\|\\s.\\)+" nil t) - (while (and (looking-at "\\^\\|\\.\\|'") - (re-search-backward "\\(\\s-\\|\\s.\\)+" nil t))) - (if (or (not (looking-at "\\(\\s-\\|\\s.\\)+")) - (<= (point) (save-excursion - (back-to-indentation) - (point)))) - (progn - ;; We failed in our mission to find anything, or fell - ;; of the edge of the earth. If we are out of - ;; bounds, lets try again. - (goto-char orig) - (if (re-search-backward "\\s.+" nil t) - t - nil)) - ;; Ok, we have a good location to break. Check for column - ;; and ref against nearest list ending to predict a possibly - ;; better break point. - (forward-char 1) - (let ((okpos (current-column)) - (startlst (save-excursion - (condition-case nil - (matlab-up-list -1) - (error nil)) - (if (save-excursion - (forward-char -1) - (looking-at "\\w")) - (forward-word -1)) - (current-column))) - (endlst (save-excursion - (condition-case nil - (matlab-up-list 1) - (error nil)) - (current-column)))) - ;; When evaluating list fudge factores, breaking on the - ;; edge of a list, or at the beginning of a function - ;; call can be more valuable than breaking on a symbol - ;; of a mid-sized list. As such, allow double-fudge - ;; for lists. - (cond - ;; First, pick the end of a list. - ((and (< endlst matlab-fill-fudge-hard-maximum) - (<= endlst (+ fill-column matlab-fill-fudge)) - (or (<= (* matlab-fill-fudge 2) (- endlst okpos)) - (<= endlst fill-column)) - (save-excursion - (move-to-column endlst) - (not (looking-at "\\^")))) - (move-to-column endlst) - t) - ;; Else, back up over this list and poke around - ((>= (* 2 matlab-fill-fudge) (- okpos startlst)) - (move-to-column startlst) - t) - ;; Oh well, just do this symbol. - (t (move-to-column okpos) - t))))) - ;; Well, this just sucks - (progn (goto-char orig) - nil)))))) - -(defun matlab-auto-fill () - "Do auto filling. -Set variable `auto-fill-function' to this symbol to enable MATLAB style auto -filling which will automatically insert `...' and the end of a line." - (interactive) - (let ((fill-prefix fill-prefix) ;; safe way of modifying fill-prefix. - (fill-column (- fill-column - (if matlab-fill-count-ellipsis-flag - (save-excursion - (move-to-column fill-column) - (if (not (bobp)) - (forward-char -1)) - (if (matlab-cursor-in-string 'incomplete) - 4 3)) - 0)))) - (if (> (current-column) fill-column) - (cond - ((matlab-ltype-comm-ignore) - nil) - ((or (matlab-ltype-comm) - (and (save-excursion (move-to-column fill-column) - (matlab-cursor-in-comment)) - (matlab-lattr-comm))) - ;; If the whole line is a comment, do this. - (matlab-set-comm-fill-prefix) (do-auto-fill) - (matlab-reset-fill-prefix)) - ((and (matlab-ltype-code) - (not (matlab-lattr-cont)) - matlab-fill-code) - ;; If we are on a code line, we ellipsify before we fill. - (let ((m (make-marker))) - (move-marker m (point)) - (set-marker-insertion-type m t) - (if (not (matlab-find-convenient-line-break)) - nil - (if (not (save-excursion - (forward-char -1) - (matlab-cursor-in-string 'incomplete))) - (progn - (delete-horizontal-space) - (insert " " matlab-elipsis-string "\n") - (matlab-indent-line)) - (if matlab-fill-strings-flag - (let ((pos (point)) - (pos2 nil)) - (while (and (re-search-backward "'" (point-at-bol) t) - (progn (forward-char -1) - (looking-at "''")))) - (setq pos2 (point)) - ;; Check if there is already an opening bracket or if string is continued - (if (or (looking-at "\\[") - (save-excursion (skip-chars-backward " \t") - (forward-char -1) - (looking-at "\\[")) - (progn - (beginning-of-line) - (skip-chars-backward (concat " \t\n" matlab-elipsis-string)) - (if (> (point) (point-min)) - (progn - (forward-char -1) - (looking-at (concat "'\\s-*" matlab-elipsis-string)))))) - (goto-char pos) - (goto-char pos2) - (forward-char 1) - (insert "[") - (goto-char pos) - (forward-char 1)) - ;(delete-horizontal-space) - (skip-chars-forward " \t") - (insert "' " matlab-elipsis-string "\n") - (matlab-indent-line) - (insert "'") - ;; Re scan forward for the end of the string. Add an end bracket - ;; if there isn't one already. Also add an apostrophe if necessary. - (if (not (looking-at "'\\s-*]")) - (save-excursion - (if (not (re-search-forward "[^']'[^']" (line-end-position) t)) - (progn - (end-of-line) - (insert "']") - (move-marker m (- (point) 2))) - (forward-char -2) - (if (not (looking-at "'\\s-*]")) - (progn - (forward-char 1) - (insert "]")))))) - )))) - (goto-char m))) - )))) - -(defun matlab-join-comment-lines () - "Join current comment line to the next comment line." - ;; New w/ V2.0: This used to join the previous line, but I could find - ;; no editors that had a "join" that did that. I modified join to have - ;; a behaviour I thought more inline with other editors. - (interactive) - (end-of-line) - (if (looking-at "\n[ \t]*%") - (replace-match " " t t nil) - (error "No following comment to join with"))) - -(defun matlab-fill-region (beg-region end-region &optional justify-flag) - "Fill the region between BEG-REGION and END-REGION. -Non-nil JUSTIFY-FLAG means justify comment lines as well." - (interactive "*r\nP") - (let ((end-reg-mk (make-marker))) - (set-marker end-reg-mk end-region) - (goto-char beg-region) - (beginning-of-line) - (while (< (point) end-reg-mk) - ;; This function must also leave the point at the end of the - ;; justified line. - (matlab-fill-paragraph justify-flag) - (forward-line 1) - (beginning-of-line)))) - -(defun matlab-fill-comment-line (&optional justify) - "Fill the current comment line. -With optional argument, JUSTIFY the comment as well." - (interactive) - (if (not (matlab-comment-on-line)) - (error "No comment to fill")) - (beginning-of-line) - ;; First, find the beginning of this comment... - (while (and (looking-at matlab-cline-start-skip) - (not (bobp))) - (forward-line -1) - (beginning-of-line)) - (if (not (looking-at matlab-cline-start-skip)) - (forward-line 1)) - ;; Now scan to the end of this comment so we have our outer bounds, - ;; and narrow to that region. - (save-restriction - (narrow-to-region (point) - (save-excursion - (while (and (looking-at matlab-cline-start-skip) - (not (save-excursion (end-of-line) (eobp)))) - (forward-line 1) - (beginning-of-line)) - (if (not (looking-at matlab-cline-start-skip)) - (forward-line -1)) - (end-of-line) - (point))) - ;; Find the fill prefix... - (matlab-comment-on-line) - (looking-at "%[ \t]*") - (let ((fill-prefix (concat (make-string (current-column) ? ) - (match-string 0)))) - (fill-region (point-min) (point-max) justify)))) - -(defun matlab-justify-line () - "Delete space on end of line and justify." - (interactive) - (save-excursion - (end-of-line) - (delete-horizontal-space) - (justify-current-line))) - -(defun matlab-fill-paragraph (arg) - "When in a comment, fill the current paragraph. -Paragraphs are always assumed to be in a comment. -ARG is passed to `fill-paragraph' and will justify the text." - (interactive "P") - (cond ((or (matlab-ltype-comm) - (and (matlab-cursor-in-comment) - (not (matlab-lattr-cont)))) - ;; We are in a comment, lets fill the paragraph with some - ;; nice regular expressions. - ;; Cell start/end markers of %% also separate paragraphs - (let ((paragraph-separate "%%\\|%[a-zA-Z]\\|%[ \t]*$\\|[ \t]*$") - (paragraph-start "%[a-zA-Z]\\|%[ \t]*$\\|[ \t]*$") - (paragraph-ignore-fill-prefix nil) - (start (save-excursion (matlab-beginning-of-command) - (if (looking-at "%%") - (progn (end-of-line) - (forward-char 1))) - (point))) - (end (save-excursion (matlab-end-of-command) - (point))) - (fill-prefix nil)) - (matlab-set-comm-fill-prefix) - (save-restriction - ;; Ben North fixed to handle comment at the end of - ;; a buffer. - (narrow-to-region start (min (point-max) (+ end 1))) - (fill-paragraph arg)))) - ((matlab-ltype-code) - ;; Ok, lets get the outer bounds of this command, then - ;; completely refill it using the smart line breaking code. - (save-restriction - (narrow-to-region (save-excursion - (matlab-beginning-of-command) - (beginning-of-line) - (point)) - (save-excursion - (matlab-end-of-command) - (point))) - ;; Remove all line breaks - (goto-char (point-min)) - (while (and (re-search-forward "$" nil t) - (not (eobp))) - (delete-horizontal-space) - ;; Blow away continuation marks - (if (matlab-lattr-cont) - (progn - (goto-char (match-beginning 0)) - (forward-char 1) - (delete-region (point) (matlab-point-at-eol)))) - ;; Zap the CR - (if (not (eobp)) (delete-char 1)) - ;; Clean up whitespace - (delete-horizontal-space) - ;; Clean up trailing comments - (if (and (looking-at "% *") - (matlab-cursor-in-comment)) - (progn - (delete-char 1) - (delete-horizontal-space))) - (insert " ")) - ;; Now fill till we are done - (goto-char (point-max)) - (while (or (> (current-column) (+ fill-column matlab-fill-fudge)) - (> (current-column) matlab-fill-fudge-hard-maximum)) - (if (= (point) - (progn - (matlab-auto-fill) - (point))) - (error "Fill algorith failed!")) - (if arg (save-excursion - (forward-line -1) - (matlab-justify-line)))) - (if arg (save-excursion - (forward-line -1) - (matlab-justify-line))))) - (t - (message "Paragraph Fill not supported in this context.")))) - -;;; Semantic text insertion and management ==================================== - -(defun matlab-find-recent-variable-list (prefix) - "Return a list of most recent variables starting with PREFIX as a string. -Reverse searches for the following are done first: - 1) Assignment - 2) if|for|while|switch <var> - 3) global variables - 4) function arguments. -All elements are saved in a list, which is then uniqafied. -If NEXT is non-nil, then the next element from the saved list is used. -If the list is empty, then searches continue backwards through the code." - (matlab-navigation-syntax - (let* ((bounds (save-excursion - (if (re-search-backward "^\\s-*function\\>" nil t) - (match-beginning 0) (point-min)))) - (syms - (append - (save-excursion - (let ((lst nil)) - (while (and - (re-search-backward - (concat "^\\s-*\\(" prefix "\\w+\\)\\s-*=") - bounds t) - (< (length lst) 10)) - (setq lst (cons (match-string 1) lst))) - (nreverse lst))) - (save-excursion - (let ((lst nil)) - (while (and (re-search-backward - (concat "\\<\\(" matlab-block-beg-pre-no-if - "\\)\\s-+(?\\s-*\\(" prefix - "\\w+\\)\\>") - bounds t) - (< (length lst) 10)) - (setq lst (cons (match-string 2) lst))) - (nreverse lst))) - (save-excursion - (if (re-search-backward "^\\s-*global\\s-+" bounds t) - (let ((lst nil) m e) - (goto-char (match-end 0)) - (while (looking-at "\\(\\w+\\)\\([ \t]+\\|$\\)") - (setq m (match-string 1) - e (match-end 0)) - (if (equal 0 (string-match prefix m)) - (setq lst (cons m lst))) - (goto-char e)) - (nreverse lst)))) - (save-excursion - (if (and (re-search-backward "^\\s-*function\\>" bounds t) - (re-search-forward "\\<\\(\\w+\\)(" - (matlab-point-at-eol) t)) - (let ((lst nil) m e) - (while (looking-at "\\(\\w+\\)\\s-*[,)]\\s-*") - (setq m (match-string 1) - e (match-end 0)) - (if (equal 0 (string-match prefix m)) - (setq lst (cons m lst))) - (goto-char e)) - (nreverse lst)))))) - (fl nil)) - (while syms - (if (car syms) (setq fl (cons (car syms) fl))) - (setq syms (cdr syms))) - (matlab-uniquafy-list (nreverse fl))))) - -(defvar matlab-most-recent-variable-list nil - "Maintained by `matlab-find-recent-variable'.") - -(defun matlab-find-recent-variable (prefix &optional next) - "Return the most recently used variable starting with PREFIX as a string. -See `matlab-find-recent-variable-list' for details. -In NEXT is non-nil, than continue through the list of elements." - (if next - (let ((next (car matlab-most-recent-variable-list))) - (setq matlab-most-recent-variable-list - (cdr matlab-most-recent-variable-list)) - next) - (let ((syms (matlab-find-recent-variable-list prefix)) - (first nil)) - (if (eq matlab-completion-technique 'complete) - syms - (setq first (car syms)) - (setq matlab-most-recent-variable-list (cdr syms)) - first)))) - -(defun matlab-find-user-functions-list (prefix) - "Return a list of user defined functions that match PREFIX." - (matlab-navigation-syntax - (let ((syms - (append - (save-excursion - (goto-char (point-min)) - (let ((lst nil)) - (while (re-search-forward "^\\s-*function\\>" nil t) - (if (re-search-forward - (concat "\\(" prefix "\\w+\\)\\s-*\\($\\|(\\)") - (matlab-point-at-eol) t) - (setq lst (cons (match-string 1) lst)))) - (nreverse lst))) - (let ((lst nil) - (files (directory-files - default-directory nil - (concat "^" prefix - "[a-zA-Z][a-zA-Z0-9_]+\\.m$")))) - (while files - (setq lst (cons (progn (string-match "\\.m" (car files)) - (substring (car files) 0 - (match-beginning 0))) - lst) - files (cdr files))) - lst))) - (fl nil)) - (while syms - (if (car syms) (setq fl (cons (car syms) fl))) - (setq syms (cdr syms))) - (matlab-uniquafy-list (nreverse fl))))) - -(defvar matlab-user-function-list nil - "Maintained by `matlab-find-user-functions'.") - -(defun matlab-find-user-functions (prefix &optional next) - "Return a user function that match PREFIX and return it. -If optional argument NEXT is non-nil, then return the next found -object." - (if next - (let ((next (car matlab-user-function-list))) - (setq matlab-user-function-list (cdr matlab-user-function-list)) - next) - (let ((syms (matlab-find-user-functions-list prefix)) - (first nil)) - (if (eq matlab-completion-technique 'complete) - syms - (setq first (car syms)) - (setq matlab-user-function-list (cdr syms)) - first)))) - -(defvar matlab-generic-list-placeholder nil - "Maintained by `matalb-generic-list-expand'. -Holds sub-lists of symbols left to be expanded.") - -(defun matlab-generic-list-expand (list prefix &optional next) - "Return an element from LIST that start with PREFIX. -If optional NEXT argument is non nil, then the next element in the -list is used. nil is returned if there are not matches." - (if next - (let ((next (car matlab-generic-list-placeholder))) - (setq matlab-generic-list-placeholder - (cdr matlab-generic-list-placeholder)) - next) - (let ((re (concat "^" (regexp-quote prefix))) - (first nil) - (fl nil)) - (while list - (if (string-match re (car list)) - (setq fl (cons (car list) fl))) - (setq list (cdr list))) - (setq fl (nreverse fl)) - (if (eq matlab-completion-technique 'complete) - fl - (setq first (car fl)) - (setq matlab-generic-list-placeholder (cdr fl)) - first)))) - -(defun matlab-solo-completions (prefix &optional next) - "Return PREFIX matching elements for solo symbols. -If NEXT then the next patch from the list is used." - (matlab-generic-list-expand matlab-keywords-solo prefix next)) - -(defun matlab-value-completions (prefix &optional next) - "Return PREFIX matching elements for value symbols. -If NEXT then the next patch from the list is used." - (matlab-generic-list-expand matlab-keywords-return prefix next)) - -(defun matlab-boolean-completions (prefix &optional next) - "Return PREFIX matching elements for boolean symbols. -If NEXT then the next patch from the list is used." - (matlab-generic-list-expand matlab-keywords-boolean prefix next)) - -(defun matlab-property-completions (prefix &optional next) - "Return PREFIX matching elements for property names in strings. -If NEXT then the next property from the list is used." - (let ((f (matlab-function-called-at-point)) - (lst matlab-property-lists) - (foundlst nil) - (expandto nil)) - ;; Look for this function. If it is a known function then we - ;; can now use a subset of available properties! - (while (and lst (not foundlst)) - (if (string= (car (car lst)) f) - (setq foundlst (cdr (car lst)))) - (setq lst (cdr lst))) - (if foundlst - (setq foundlst (append foundlst matlab-core-properties)) - (setq foundlst matlab-all-known-properties)) - (setq expandto (matlab-generic-list-expand foundlst prefix next)) - ;; This looks to see if we have a singular completion. If so, - ;; then return it, and also append the "'" to the end. - (cond ((and (listp expandto) (= (length expandto) 1)) - (setq expandto (list (concat (car expandto) "'")))) - ((stringp expandto) - (setq expandto (concat expandto "'")))) - expandto)) - -(defvar matlab-last-prefix nil - "Maintained by `matlab-complete-symbol'. -The prefix used for the first completion command.") -(defvar matlab-last-semantic nil - "Maintained by `matlab-complete-symbol'. -The last type of semantic used while completing things.") -(defvar matlab-completion-search-state nil - "List of searching things we will be doing.") - -(defun matlab-complete-symbol (&optional arg) - "Complete a partially typed symbol in a MATLAB mode buffer. -If the previously entered command was also `matlab-complete-symbol' -then undo the last completion, and find a new one. - The types of symbols tried are based on the semantics of the current -cursor position. There are two types of symbols. For example, if the -cursor is in an if statement, boolean style functions and symbols are -tried first. If the line is blank, then flow control, or high level -functions are tried first. - The completion technique is controlled with `matlab-completion-technique' -It defaults to incremental completion described above. If a -completion list is preferred, then change this to 'complete. If you -just want a completion list once, then use the universal argument ARG -to change it temporarily." - (interactive "P") - (matlab-navigation-syntax - (let* ((prefix (if (and (not (eq last-command 'matlab-complete-symbol)) - (member (preceding-char) '(? ?\t ?\n ?, ?\( ?\[ ?\'))) - "" - (buffer-substring-no-properties - (save-excursion (forward-word -1) (point)) - (point)))) - (sem (matlab-lattr-semantics prefix)) - (matlab-completion-technique - (if arg (cond ((eq matlab-completion-technique 'complete) - 'increment) - (t 'complete)) - matlab-completion-technique))) - (if (not (eq last-command 'matlab-complete-symbol)) - (setq matlab-last-prefix prefix - matlab-last-semantic sem - matlab-completion-search-state - (cond ((eq sem 'solo) - '(matlab-solo-completions - matlab-find-user-functions - matlab-find-recent-variable)) - ((eq sem 'boolean) - '(matlab-find-recent-variable - matlab-boolean-completions - matlab-find-user-functions - matlab-value-completions)) - ((eq sem 'value) - '(matlab-find-recent-variable - matlab-find-user-functions - matlab-value-completions - matlab-boolean-completions)) - ((eq sem 'property) - '(matlab-property-completions - matlab-find-user-functions - matlab-find-recent-variable - matlab-value-completions)) - (t '(matlab-find-recent-variable - matlab-find-user-functions - matlab-value-completions - matlab-boolean-completions))))) - (cond - ((eq matlab-completion-technique 'increment) - (let ((r nil) (donext (eq last-command 'matlab-complete-symbol))) - (while (and (not r) matlab-completion-search-state) - (message "Expand with %S" (car matlab-completion-search-state)) - (setq r (funcall (car matlab-completion-search-state) - matlab-last-prefix donext)) - (if (not r) (setq matlab-completion-search-state - (cdr matlab-completion-search-state) - donext nil))) - (delete-region (point) (progn (forward-char (- (length prefix))) - (point))) - (if r - (insert r) - (insert matlab-last-prefix) - (message "No completions.")))) - ((eq matlab-completion-technique 'complete) - (let ((allsyms (apply 'append - (mapcar (lambda (f) (funcall f prefix)) - matlab-completion-search-state)))) - (cond ((null allsyms) - (message "No completions.") - (ding)) - ((= (length allsyms) 1) - (delete-region (point) (progn - (forward-char (- (length prefix))) - (point))) - (insert (car allsyms))) - ((= (length allsyms) 0) - (message "No completions.")) - (t - (let* ((al (mapcar (lambda (a) (list a)) allsyms)) - (c (try-completion prefix al))) - ;; This completion stuff lets us expand as much as is - ;; available to us. When the completion is the prefix - ;; then we want to display all the strings we've - ;; encountered. - (if (and (stringp c) (not (string= prefix c))) - (progn - (delete-region - (point) - (progn (forward-char (- (length prefix))) - (point))) - (insert c)) - ;; `display-completion-list' does all the complex - ;; ui work for us. - (with-output-to-temp-buffer "*Completions*" - (display-completion-list - (matlab-uniquafy-list allsyms))))))))))))) - -(defun matlab-insert-end-block (&optional reindent) - "Insert and END block based on the current syntax. -Optional argument REINDENT indicates if the specified block should be re-indented." - (interactive "P") - (if (not (matlab-ltype-empty)) (progn (end-of-line) (insert "\n"))) - (let ((valid t) (begin nil)) - (save-excursion - (condition-case nil - (progn - (matlab-backward-sexp t) - (setq begin (point) - valid (buffer-substring-no-properties - (point) (save-excursion - (re-search-forward "[\n,;.]" nil t) - (point))))) - (error (setq valid nil)))) - (if (not valid) - (error "No block to end") - (insert "end") - (if (stringp valid) (insert " % " valid)) - (matlab-indent-line) - (if reindent (indent-region begin (point) nil))))) - -(tempo-define-template - "matlab-for" - '("for " p "=" p "," > n> - r> & - "end" > %) - "for" - "Insert a MATLAB for statement" - 'matlab-tempo-tags - ) - -(tempo-define-template - "matlab-while" - '("while (" p ")," > n> - r> & - "end" > %) - "while" - "Insert a MATLAB while statement" - 'matlab-tempo-tags - ) - -(tempo-define-template - "matlab-if" - '("if " p > n - r> - "end" > n) - "if" - "Insert a MATLAB if statement" - 'matlab-tempo-tags - ) - -(tempo-define-template - "matlab-if-else" - '("if " p > n - r> - "else" > n - "end" > n) - "if" - "Insert a MATLAB if statement" - 'matlab-tempo-tags - ) - -(tempo-define-template - "matlab-try" - '("try " > n - r> - "catch" > n - p > n - "end" > n) - "try" - "Insert a MATLAB try catch statement" - 'matlab-tempo-tags - ) - -(tempo-define-template - "matlab-switch" - '("switch " p > n - "otherwise" > n - r> - "end" > n) - "switch" - "Insert a MATLAB switch statement with region in the otherwise clause." - 'matlab-tempo-tags) - -(defun matlab-insert-next-case () - "Insert a case statement inside this switch statement." - (interactive) - ;; First, make sure we are where we think we are. - (let ((valid t)) - (save-excursion - (condition-case nil - (progn - (matlab-backward-sexp t) - (setq valid (looking-at "switch"))) - (error (setq valid nil)))) - (if (not valid) - (error "Not in a switch statement"))) - (if (not (matlab-ltype-empty)) (progn (end-of-line) (insert "\n"))) - (indent-to 0) - (insert "case ") - (matlab-indent-line)) - -(tempo-define-template - "matlab-function" - '("function " - (P "output argument(s): " output t) - ;; Insert brackets only if there is more than one output argument - (if (string-match "," (tempo-lookup-named 'output)) - '(l "[" (s output) "]") - '(l (s output))) - ;; Insert equal sign only if there is output argument(s) - (if (= 0 (length (tempo-lookup-named 'output))) nil - " = ") - ;; The name of a function, as defined in the first line, should - ;; be the same as the name of the file without .m extension - (if (= 1 (count-lines 1 (point))) - (tempo-save-named - 'fname - (file-name-nondirectory (file-name-sans-extension - (buffer-file-name)))) - '(l (P "function name: " fname t))) - (tempo-lookup-named 'fname) - "(" (P "input argument(s): ") ")" n - "% " (upcase (tempo-lookup-named 'fname)) " - " (P "H1 line: ") n - "% " p n - (if matlab-functions-have-end - '(l "end" n))) - "function" - "Insert a MATLAB function statement" - 'matlab-tempo-tags - ) - -(defun matlab-stringify-region (begin end) - "Put MATLAB 's around region, and quote all quotes in the string. -Stringification allows you to type in normal MATLAB code, mark it, and -then turn it into a MATLAB string that will output exactly what's in -the region. BEGIN and END mark the region to be stringified." - (interactive "r") - (save-excursion - (goto-char begin) - (if (re-search-forward "\n" end t) - (error - "You may only stringify regions that encompass less than one line")) - (let ((m (make-marker))) - (move-marker m end) - (goto-char begin) - (insert "'") - (while (re-search-forward "'" m t) - (insert "'")) - (goto-char m) - (insert "'")))) - -(defun matlab-ispell-strings-region (begin end) - "Spell check valid strings in region with Ispell. -Argument BEGIN and END mark the region boundary." - (interactive "r") - (require 'ispell) - (save-excursion - (goto-char begin) - ;; Here we use the font lock function for finding strings. - ;; Its cheap, fast, and accurate. - (while (and (matlab-font-lock-string-match-normal end) - (ispell-region (match-beginning 2) (match-end 2)))))) - -(defun matlab-ispell-strings () - "Spell check valid strings in the current buffer with Ispell. -Calls `matlab-ispell-strings-region'" - (interactive) - (matlab-ispell-strings-region (point-min) (point-max))) - -(defun matlab-ispell-comments (&optional arg) - "Spell check comments in the current buffer with Ispell. -Optional ARG means to only check the current comment." - (interactive "P") - (let ((beg (point-min)) - (end (point-max))) - (if (and arg (matlab-ltype-comm)) - (setq beg (save-excursion (matlab-beginning-of-command) (point)) - end (save-excursion (matlab-end-of-command) (point)))) - (save-excursion - (goto-char beg) - (beginning-of-line) - (while (and (matlab-font-lock-comment-match end) - (ispell-region (match-beginning 1) (match-end 1))))))) - -(defun matlab-generate-latex () - "Convert a MATLAB M file into a Latex document for printing. -Author: Uwe Brauer oub@eucmos.sim.ucm.es -Created: 14 Feb 2002" - (interactive "*") - (save-restriction - (save-excursion - (goto-char (point-min)) - (insert "\\documentclass[12pt]{report}\n -\\usepackage{listings} -\\lstloadlanguages{Matlab} -\\lstset{language=Matlab,keywordstyle=\\bfseries,labelstep=1,escapechar=\\#} -\\begin{document} -\\begin{lstlisting}{}") - (newline) - (goto-char (point-max)) - (insert "\n\\end{lstlisting}\n\\end{document}") - (widen))) - (font-lock-mode nil) - (LaTeX-mode) - (font-lock-mode nil)) - - -;;; Block highlighting ======================================================== - -(defvar matlab-block-highlighter-timer nil - "The timer representing the block highlighter.") - -(defun matlab-enable-block-highlighting (&optional arg) - "Start or stop the block highlighter. -Optional ARG is 1 to force enable, and -1 to disable. -If ARG is nil, then highlighting is toggled." - (interactive "P") - (if (not (fboundp 'matlab-run-with-idle-timer)) - (setq matlab-highlight-block-match-flag nil)) - ;; Only do it if it's enabled. - (if (not matlab-highlight-block-match-flag) - nil - ;; Use post command idle hook as a local hook to dissuade too much - ;; cpu time while doing other things. - ;;(make-local-hook 'post-command-hook) - (if (not arg) - (setq arg - (if (member 'matlab-start-block-highlight-timer - post-command-hook) - -1 1))) - (if (> arg 0) - (add-hook 'post-command-hook 'matlab-start-block-highlight-timer) - (remove-hook 'post-command-hook 'matlab-start-block-highlight-timer)))) - -(defvar matlab-block-highlight-overlay nil - "The last highlighted overlay.") -(make-variable-buffer-local 'matlab-block-highlight-overlay) - -(defvar matlab-block-highlight-timer nil - "Last started timer.") -(make-variable-buffer-local 'matlab-block-highlight-timer) - -(defun matlab-start-block-highlight-timer () - "Set up a one-shot timer if we are in MATLAB mode." - (if (eq major-mode 'matlab-mode) - (progn - (if matlab-block-highlight-overlay - (unwind-protect - (matlab-delete-overlay matlab-block-highlight-overlay) - (setq matlab-block-highlight-overlay nil))) - (if matlab-block-highlight-timer - (unwind-protect - (matlab-cancel-timer matlab-block-highlight-timer) - (setq matlab-block-highlight-timer nil))) - (setq matlab-block-highlight-timer - (matlab-run-with-idle-timer - 1 nil 'matlab-highlight-block-match - (current-buffer)))))) - -(defun matlab-highlight-block-match (&optional buff-when-launched) - "Highlight a matching block if available. -BUFF-WHEN-LAUNCHED is the buffer that was active when the timer was set." - (setq matlab-block-highlight-timer nil) - (if (null buff-when-launched) - ;; We were passed a null. This indicates an old version of XEmacs - ;; so just turn the feature off - (setq matlab-highlight-block-match-flag nil) - ;; Only do neat stuff in the same buffer as the one we were - ;; initialized from. - (when (and buff-when-launched - (eq buff-when-launched (current-buffer))) - (let ((inhibit-quit nil) ;turn on G-g - (matlab-scan-on-screen-only t)) - (if matlab-show-periodic-code-details-flag - (matlab-show-line-info)) - (if (not (matlab-cursor-in-string-or-comment)) - (save-excursion - (if (or (bolp) - (looking-at "\\s-") - (save-excursion (forward-char -1) (looking-at "\\s-"))) - nil - (forward-word -1)) - (if (and (looking-at (concat (matlab-block-beg-re) "\\>")) - (not (looking-at "function"))) - (progn - ;; We scan forward... - (matlab-forward-sexp) - (backward-word 1) - (if (not (looking-at matlab-block-end-pre-if)) - nil ;(message "Unterminated block, or end off screen.") - (setq matlab-block-highlight-overlay - (matlab-make-overlay (point) - (progn (forward-word 1) - (point)) - (current-buffer))) - (matlab-overlay-put matlab-block-highlight-overlay - 'face 'matlab-region-face))) - (if (and (looking-at (concat (matlab-block-end-pre) "\\>")) - (not (looking-at "function")) - (matlab-valid-end-construct-p)) - (progn - ;; We scan backward - (forward-word 1) - (condition-case nil - (progn - (matlab-backward-sexp) - (if (not (looking-at (matlab-block-beg-re))) - nil ;(message "Unstarted block at cursor.") - (setq matlab-block-highlight-overlay - (matlab-make-overlay (point) - (progn (forward-word 1) - (point)) - (current-buffer))) - (matlab-overlay-put matlab-block-highlight-overlay - 'face 'matlab-region-face))) - (error (message "Unstarted block at cursor.")))) - ;; do nothing - )))))))) - - -;;; M Block Folding with hideshow ============================================= - -(defun matlab-hideshow-forward-sexp-func (arg) - "Move forward one sexp for hideshow. -Argument ARG specifies the number of blocks to move forward." - (beginning-of-line) - (matlab-forward-sexp arg) - ) - -(defun matlab-hideshow-adjust-beg-func (arg) - "Adjust the beginning of a hideshow block. -Argument ARG to make it happy." - (end-of-line) - (point) - ) - -;; Use this to enable hideshow in MATLAB. -;; It has not been tested by me enough. - -;; REMOVE PUSHNEW FROM THIS LINE -;;(pushnew (list 'matlab-mode -;; (matlab-block-beg-pre) -;; (matlab-block-end-pre) -;; "%" -;; 'matlab-hideshow-forward-sexp-func -;; 'matlab-hideshow-adjust-beg-func -;; ) -;; hs-special-modes-alist :test 'equal) - - -;;; M Code verification & Auto-fix ============================================ - -(defun matlab-mode-verify-fix-file-fn () - "Verify the current buffer from `write-contents-hooks'." - (if matlab-verify-on-save-flag - (matlab-mode-verify-fix-file (> (point-max) - matlab-block-verify-max-buffer-size))) - ;; Always return nil. - nil) - -(defun matlab-mode-verify-fix-file (&optional fast) - "Verify the current buffer satisfies all M things that might be useful. -We will merely loop across a list of verifiers/fixers in -`matlab-mode-verify-fix-functions'. -If optional FAST is non-nil, do not perform usually lengthy checks." - (interactive) - (let ((p (point)) - (l matlab-mode-verify-fix-functions)) - (while l - (funcall (car l) fast) - (setq l (cdr l))) - (goto-char p)) - (if (interactive-p) - (message "Done."))) - -(defun matlab-toggle-show-mlint-warnings () - "Toggle `matlab-show-mlint-warnings'." - (interactive) - (setq matlab-show-mlint-warnings (not matlab-show-mlint-warnings)) - (if matlab-highlight-cross-function-variables - (if matlab-show-mlint-warnings - (mlint-buffer) ; became true, recompute mlint info - (mlint-clear-warnings))) ; became false, just remove hilighting - ;; change mlint mode altogether - (mlint-minor-mode - (if (or matlab-highlight-cross-function-variables - matlab-show-mlint-warnings) - 1 -1))) - -(defun matlab-toggle-highlight-cross-function-variables () - "Toggle `matlab-highlight-cross-function-variables'." - (interactive) - (setq matlab-highlight-cross-function-variables - (not matlab-highlight-cross-function-variables)) - (if matlab-show-mlint-warnings - (if matlab-highlight-cross-function-variables - (mlint-buffer) ; became true, recompute mlint info - ; became false, just remove hilighting ... - (mlint-clear-cross-function-variable-highlighting))) - (mlint-minor-mode - (if (or matlab-highlight-cross-function-variables - matlab-show-mlint-warnings) - 1 -1))) ; change mlint mode altogether - -;; -;; Add more auto verify/fix functions here! -;; -(defun matlab-mode-vf-functionname (&optional fast) - "Verify/Fix the function name of this file. -Optional argument FAST is ignored." - (matlab-navigation-syntax - (goto-char (point-min)) - (while (and (or (matlab-ltype-empty) (matlab-ltype-comm)) - (/= (matlab-point-at-eol) (point-max))) - (forward-line 1)) - (let ((func nil) - (bn (file-name-sans-extension - (file-name-nondirectory (buffer-file-name))))) - (if (looking-at (matlab-match-function-re)) - ;; The expression above creates too many numeric matches - ;; to apply a known one to our function. We cheat by knowing that - ;; match-end 0 is at the end of the function name. We can then go - ;; backwards, and get the extents we need. Navigation syntax - ;; lets us know that backward-word really covers the word. - (let ((end (match-end 0)) - (begin (progn (goto-char (match-end 0)) - (forward-word -1) - (point)))) - (setq func (buffer-substring begin end)) - (if (not (string= func bn)) - (if (not (matlab-mode-highlight-ask - begin end - "Function and file names are different. Fix?")) - nil - (goto-char begin) - (delete-region begin end) - (insert bn)))))))) - -(defun matlab-mode-vf-block-matches-forward (&optional fast) - "Verify/Fix unterminated (or un-ended) blocks. -This only checks block regions like if/end. -Optional argument FAST causes this check to be skipped." - (goto-char (point-min)) - (let ((go t) - (expr (concat "\\<\\(" (matlab-block-beg-pre) "\\)\\>"))) - (matlab-navigation-syntax - (while (and (not fast) go (re-search-forward expr nil t)) - (forward-word -1) ;back over the special word - (let ((s (point))) - (condition-case nil - (if (and (not (matlab-cursor-in-string-or-comment)) - (not (looking-at "function"))) - (progn - (matlab-forward-sexp) - (forward-word -1) - (if (not (looking-at - (concat matlab-block-end-pre-no-if "\\>"))) - (setq go nil))) - (forward-word 1)) - (error (setq go nil))) - (if (and (not go) (goto-char s) - (not (matlab-mode-highlight-ask - (point) (save-excursion (forward-word 1) (point)) - "Unterminated block. Continue anyway?"))) - (error "Unterminated Block found!"))) - (message "Block-check: %d%%" (/ (/ (* 100 (point)) (point-max)) 2)))))) - -(defun matlab-mode-vf-block-matches-backward (&optional fast) - "Verify/fix unstarted (or dangling end) blocks. -Optional argument FAST causes this check to be skipped." - (goto-char (point-max)) - (let ((go t) (expr (concat "\\<\\(" (matlab-block-end-no-function-re) - "\\)\\>"))) - (matlab-navigation-syntax - (while (and (not fast) go (re-search-backward expr nil t)) - (forward-word 1) - (let ((s (point))) - (condition-case nil - (if (and (not (matlab-cursor-in-string-or-comment)) - (matlab-valid-end-construct-p)) - (matlab-backward-sexp) - (backward-word 1)) - (error (setq go nil))) - (if (and (not go) (goto-char s) - (not (matlab-mode-highlight-ask - (point) (save-excursion (backward-word 1) (point)) - "Unstarted block. Continue anyway?"))) - (error "Unstarted Block found!"))) - (message "Block-check: %d%%" - (+ (/ (/ (* 100 (- (point-max) (point))) (point-max)) 2) 50)))))) - -;;; Utility for verify/fix actions if you need to highlight -;; a section of the buffer for the user's approval. -(defun matlab-mode-highlight-ask (begin end prompt) - "Highlight from BEGIN to END while asking PROMPT as a yes-no question." - (let ((mo (matlab-make-overlay begin end (current-buffer))) - (ans nil)) - (condition-case nil - (progn - (matlab-overlay-put mo 'face 'matlab-region-face) - (setq ans (y-or-n-p prompt)) - (matlab-delete-overlay mo)) - (quit (matlab-delete-overlay mo) (error "Quit"))) - ans)) - -;;; Quiesce an M file to remove accidental display of ANS during a run. -;; Useful if you have random outputs and you don't know where they are from, -;; or before compiling to standalone where some functions now have outputs -;; that did not have outputs earlier. -;; -;; You probably don't want this as a default verify function -(defvar matlab-quiesce-nosemi-regexp "\\s-*\\(function\\|parfor\\|for\\|spmd\\|while\\|try\\|catch\\|\ -switch\\|otherwise\\|case\\|break\\|if\\|else\\|end\\|return\\|disp\\|\ -$\\|%\\)" - "Regular expression used to detect if a semicolon is needed at the end of a line.") - -(defun matlab-mode-vf-quiesce-buffer (&optional fast) - "Find all commands that do not end in ;, and add one. -This has the effect of removing any extraneous output that may not be -desired. Optional argument FAST is not used." - (interactive) - (save-excursion - (push-mark) - (goto-char (point-min)) - (let ((msgpos 0) (dir .2)) - (while (not (save-excursion (end-of-line) (eobp))) - (message (aref [ "Scanning o...." "Scanning .o..." "Scanning ..o.." - "Scanning ...o." "Scanning ....o" ] (floor msgpos))) - (setq msgpos (+ msgpos dir)) - (if (or (> msgpos 5) (< msgpos 0)) (setq dir (- dir) - msgpos (+ (* 2 dir) msgpos))) - (matlab-end-of-command (point)) - (if (matlab-cursor-in-comment) - (progn - (matlab-comment-on-line) - (skip-chars-backward " \t"))) - (if (and (not (= (preceding-char) ?\;)) - (not (matlab-cursor-in-string t)) - (not (save-excursion - (beginning-of-line) - (looking-at matlab-quiesce-nosemi-regexp)))) - (let ((p (point))) - (skip-chars-backward " \t") - (if (/= p (point)) - (progn - (delete-region p (point)) - (forward-line -1)) - (if (matlab-mode-highlight-ask (point) (+ 1 (point)) - "Add Semi colon here? ") - (insert ";"))))) - (forward-line 1)))) - (message "Scanning .... done")) - - - -;;; V19 stuff ================================================================= - -(defvar matlab-mode-menu-keymap nil - "Keymap used in MATLAB mode to provide a menu.") - -(defun matlab-frame-init () - "Initialize Emacs menu system." - (interactive) - ;; make a menu keymap - (easy-menu-define - matlab-mode-menu - matlab-mode-map - "MATLAB menu" - '("MATLAB" - ["Start MATLAB" matlab-shell - :active (not (or (matlab-with-emacs-link) (matlab-shell-active-p))) - :visible (not (matlab-shell-active-p)) ] - ["Switch to MATLAB" matlab-shell - :active (and (not (matlab-with-emacs-link)) (matlab-shell-active-p)) - :visible (matlab-shell-active-p) ] - ["Save and go" matlab-shell-save-and-go t] - ["Run Region" matlab-shell-run-region t] - ["Run Cell" matlab-shell-run-cell t] - ["Version" matlab-show-version t] - "----" - ["Find M file" matlab-find-file-on-path t] - ["Show M-Lint Warnings" matlab-toggle-show-mlint-warnings - :active (and (locate-library "mlint") (fboundp 'mlint-minor-mode)) - :style toggle :selected matlab-show-mlint-warnings - ] - ("Auto Fix" - ["Verify/Fix source" matlab-mode-verify-fix-file t] - ["Spell check strings" matlab-ispell-strings t] - ["Spell check comments" matlab-ispell-comments t] - ["Quiesce source" matlab-mode-vf-quiesce-buffer t] - ) - ("Navigate" - ["Beginning of Command" matlab-beginning-of-command t] - ["End of Command" matlab-end-of-command t] - ["Forward Block" matlab-forward-sexp t] - ["Backward Block" matlab-backward-sexp t] - ["Beginning of Function" matlab-beginning-of-defun t] - ["End of Function" matlab-end-of-defun t]) - ("Format" - ["Justify Line" matlab-justify-line t] - ["Fill Region" matlab-fill-region t] - ["Fill Comment Paragraph" matlab-fill-paragraph - (save-excursion (matlab-comment-on-line))] - ["Join Comment" matlab-join-comment-lines - (save-excursion (matlab-comment-on-line))] - ["Comment Region" matlab-comment-region t] - ["Uncomment Region" matlab-uncomment-region t] - ["Indent Synactic Block" matlab-indent-sexp]) - ("Insert" - ["Complete Symbol" matlab-complete-symbol t] - ["Comment" matlab-comment t] - ["if end" tempo-template-matlab-if t] - ["if else end" tempo-template-matlab-if-else t] - ["for end" tempo-template-matlab-for t] - ["switch otherwise end" tempo-template-matlab-switch t] - ["Next case" matlab-insert-next-case t] - ["try catch end" tempo-template-matlab-try t] - ["while end" tempo-template-matlab-while t] - ["End of block" matlab-insert-end-block t] - ["Function" tempo-template-matlab-function t] - ["Stringify Region" matlab-stringify-region t] - ) - ("Customize" -; ["Auto Fill Counts Elipsis" -; (lambda () (setq matlab-fill-count-ellipsis-flag -; (not matlab-fill-count-ellipsis-flag))) -; :style toggle :selected 'matlab-fill-count-ellipsis-flag] - ["Indent Function Body" - (setq matlab-indent-function-body (not (matlab-indent-function-body-p))) - :style toggle :selected matlab-indent-function-body] - ["Functions Have end" - matlab-toggle-functions-have-end - :style toggle :selected matlab-functions-have-end] - ["Verify File on Save" - (setq matlab-verify-on-save-flag (not matlab-verify-on-save-flag)) - :style toggle :selected matlab-verify-on-save-flag] - ["Auto Fill does Code" - (setq matlab-fill-code (not matlab-fill-code)) - :style toggle :selected matlab-fill-code ] - ["Periodic Code Details" - (setq matlab-show-periodic-code-details-flag - (not matlab-show-periodic-code-details-flag)) - :style toggle :selected matlab-show-periodic-code-details-flag ] - ["Highlight Matching Blocks" - (matlab-enable-block-highlighting) - :style toggle :selected (member 'matlab-start-block-highlight-timer - post-command-hook) ] - ["Highlight Cross-Function Variables" - matlab-toggle-highlight-cross-function-variables - :active (locate-library "mlint") - :style toggle :selected matlab-highlight-cross-function-variables - ] - ["Add Needed Semicolon on RET" - (setq matlab-return-add-semicolon (not matlab-return-add-semicolon)) - :style toggle :selected matlab-return-add-semicolon - ] - ["Customize" (customize-group 'matlab) - (and (featurep 'custom) (fboundp 'custom-declare-variable)) - ] - ) - "----" - ["Run M Command" matlab-shell-run-command (matlab-shell-active-p)] - ["Describe Command" matlab-shell-describe-command (matlab-shell-active-p)] - ["Describe Variable" matlab-shell-describe-variable (matlab-shell-active-p)] - ["Command Apropos" matlab-shell-apropos (matlab-shell-active-p)] - ["Topic Browser" matlab-shell-topic-browser (matlab-shell-active-p)] - )) - (easy-menu-add matlab-mode-menu matlab-mode-map)) - -;;; MATLAB shell ============================================================= - -(defgroup matlab-shell nil - "MATLAB shell mode." - :prefix "matlab-shell-" - :group 'matlab) - -(defcustom matlab-shell-command "matlab" - "*The name of the command to be run which will start the MATLAB process." - :group 'matlab-shell - :type 'string) - -(defcustom matlab-shell-command-switches '("-nodesktop") - "*Command line parameters run with `matlab-shell-command'. -Command switches are a list of strings. Each entry is one switch." - :group 'matlab-shell - :type '(list :tag "Switch: ")) - -(defcustom matlab-shell-echoes t - "*If `matlab-shell-command' echoes input." - :group 'matlab-shell - :type 'boolean) - -(defvar matlab-shell-running-matlab-version nil - "The version of MATLAB running in the current `matlab-shell' buffer.") -(defvar matlab-shell-running-matlab-release nil - "The release of MATLAB running in the curbrent `matlab-shell' buffer.") -(defvar matlab-shell-use-emacs-toolbox - ;; matlab may not be on path. (Name change, explicit load, etc) - (let* ((mlfile (locate-library "matlab")) - (dir (expand-file-name "toolbox/emacsinit.m" - (file-name-directory (or mlfile ""))))) - (and mlfile (file-exists-p dir))) - "Add the `matlab-shell' MATLAB toolbox to the MATLAB path on startup.") -(defvar matlab-shell-emacsclient-command "emacsclient -n" - "The command to use as an external editor for MATLAB. -Using emacsclient allows the currently running Emacs to also be the -external editor for MATLAB.") - -(defcustom matlab-shell-history-file "~/.matlab/%s/history.m" - "*Location of the history file. -A %s is replaced with the MATLAB version release number, such as R12. -This file is read to initialize the comint input ring.") - -(defcustom matlab-shell-input-ring-size 32 - "*Number of history elements to keep." - :group 'matlab-shell - :type 'integer) - -(defcustom matlab-shell-enable-gud-flag t - "*Non-nil means to use GUD mode when running the MATLAB shell." - :group 'matlab-shell - :type 'boolean) - -(defcustom matlab-shell-mode-hook nil - "*List of functions to call on entry to MATLAB shell mode." - :group 'matlab-shell - :type 'hook) - -(defcustom matlab-shell-ask-MATLAB-for-completions t - "When Non-nil, ask MATLAB for a completion list. -When nil, just complete file names. (The original behavior.) -At this time, MATLAB based completion can be slow if there are -a lot of possible answers." - :group 'matlab-shell - :type 'boolean) - -(defvar matlab-shell-buffer-name "MATLAB" - "Name used to create `matlab-shell' mode buffers. -This name will have *'s surrounding it.") - -(defun matlab-shell-active-p () - "Return t if the MATLAB shell is active." - (if (get-buffer (concat "*" matlab-shell-buffer-name "*")) - (save-excursion - (set-buffer (concat "*" matlab-shell-buffer-name "*")) - (if (comint-check-proc (current-buffer)) - (current-buffer))))) - -(defvar matlab-shell-mode-map () - "Keymap used in `matlab-shell-mode'.") - -(defvar matlab-shell-font-lock-keywords-1 - (append matlab-font-lock-keywords matlab-shell-font-lock-keywords) - "Keyword symbol used for font-lock mode.") - -(defvar matlab-shell-font-lock-keywords-2 - (append matlab-shell-font-lock-keywords-1 matlab-gaudy-font-lock-keywords) - "Keyword symbol used for gaudy font-lock symbols.") - -(defvar matlab-shell-font-lock-keywords-3 - (append matlab-shell-font-lock-keywords-2 - matlab-really-gaudy-font-lock-keywords) - "Keyword symbol used for really gaudy font-lock symbols.") - -(defvar matlab-prompt-seen nil - "Track visibility of MATLAB prompt in MATLAB Shell.") - -(eval-when-compile (require 'gud) (require 'comint) (require 'shell)) - -;;;###autoload -(defun matlab-shell () - "Create a buffer with MATLAB running as a subprocess. - -MATLAB shell cannot work on the MS Windows platform because MATLAB is not -a console application." - (interactive) - ;; MATLAB shell does not work by default on the Windows platform. Only - ;; permit it's operation when the shell command string is different from - ;; the default value. (True when the engine program is running.) - (if (and (or (eq window-system 'pc) (eq window-system 'w32)) - (string= matlab-shell-command "matlab")) - (error "MATLAB cannot be run as a inferior process. \ -Try C-h f matlab-shell RET")) - - (require 'shell) - (require 'gud) - - ;; Make sure this is safe... - (if (and matlab-shell-enable-gud-flag (fboundp 'gud-def)) - ;; We can continue using GUD - nil - (message "Sorry, your emacs cannot use the MATLAB Shell GUD features.") - (setq matlab-shell-enable-gud-flag nil)) - - (switch-to-buffer (concat "*" matlab-shell-buffer-name "*")) - (if (matlab-shell-active-p) - nil - ;; Clean up crufty state - (kill-all-local-variables) - ;; Build keymap here in case someone never uses comint mode - (if matlab-shell-mode-map - () - (setq matlab-shell-mode-map - (let ((km (make-sparse-keymap 'matlab-shell-mode-map))) - (if (fboundp 'set-keymap-parent) - (set-keymap-parent km comint-mode-map) - ;; 19.31 doesn't have set-keymap-parent - (setq km (nconc km comint-mode-map))) - (substitute-key-definition 'next-error 'matlab-shell-last-error - km global-map) - (define-key km [(control h) (control m)] - matlab-help-map) - (define-key km "\C-c." 'matlab-find-file-on-path) - (define-key km [(tab)] 'matlab-shell-tab) - (define-key km "\C-i" 'matlab-shell-tab) - (define-key km [(control up)] - 'comint-previous-matching-input-from-input) - (define-key km [(control down)] - 'comint-next-matching-input-from-input) - (define-key km [up] - 'matlab-shell-previous-matching-input-from-input) - (define-key km [down] - 'matlab-shell-next-matching-input-from-input) - (define-key km [(control return)] 'comint-kill-input) - (define-key km "\C-?" - 'matlab-shell-delete-backwards-no-prompt) - (define-key km [(backspace)] - 'matlab-shell-delete-backwards-no-prompt) - km))) - (switch-to-buffer - ;; Thx David Chappaz for reminding me about this patch. - (let* ((windowid (frame-parameter (selected-frame) 'outer-window-id)) - (newvar (concat "WINDOWID=" windowid)) - (process-environment (cons newvar process-environment))) - (apply 'make-comint matlab-shell-buffer-name matlab-shell-command - nil matlab-shell-command-switches))) - - (setq shell-dirtrackp t) - (comint-mode) - - (if matlab-shell-enable-gud-flag - (progn - (gud-mode) - (make-local-variable 'matlab-prompt-seen) - (setq matlab-prompt-seen nil) - (make-local-variable 'gud-marker-filter) - (setq gud-marker-filter 'gud-matlab-marker-filter) - (make-local-variable 'gud-find-file) - (setq gud-find-file 'gud-matlab-find-file) - - (set-process-filter (get-buffer-process (current-buffer)) - 'gud-filter) - (set-process-sentinel (get-buffer-process (current-buffer)) - 'gud-sentinel) - (gud-set-buffer)) - ;; What to do when there is no GUD - ;(set-process-filter (get-buffer-process (current-buffer)) - ; 'matlab-shell-process-filter) - ) - - ;; Comint and GUD both try to set the mode. Now reset it to - ;; matlab mode. - (matlab-shell-mode))) - -(defcustom matlab-shell-logo - (if (fboundp 'locate-data-file) - ;; Starting from XEmacs 20.4 use locate-data-file - (locate-data-file "matlab.xpm") - (expand-file-name "matlab.xpm" data-directory)) - "*The MATLAB logo file." - :group 'matlab-shell - :type '(choice (const :tag "None" nil) - (file :tag "File" ""))) - - -(defun matlab-shell-hack-logo (str) - "Replace the text logo with a real logo. -STR is passed from the commint filter." - (when (string-match "< M A T L A B >" str) - (save-excursion - (when (re-search-backward "^[ \t]+< M A T L A B (R) >" (point-min) t) - (delete-region (match-beginning 0) (match-end 0)) - (insert (make-string 16 ? )) - (set-extent-begin-glyph (make-extent (point) (point)) - (make-glyph matlab-shell-logo)))) - ;; Remove this function from `comint-output-filter-functions' - (remove-hook 'comint-output-filter-functions - 'matlab-shell-hack-logo)) - - ) - -(defun matlab-shell-version-scrape (str) - "Scrape the MATLAB Version from the MATLAB startup text. -Argument STR is the string to examine for version information." - (when (string-match "\\(Version\\)\\s-+\\([.0-9]+\\)\\s-+(\\(R[.0-9]+[ab]?\\))" str) - ;; Extract the release number - (setq matlab-shell-running-matlab-version - (match-string 2 str) - matlab-shell-running-matlab-release - (match-string 3 str)) - ;; Now get our history loaded - (setq comint-input-ring-file-name - (format matlab-shell-history-file matlab-shell-running-matlab-release)) - (if (fboundp 'comint-read-input-ring) - (comint-read-input-ring t)) - ;; Remove the scrape from our list of things to do. - (remove-hook 'comint-output-filter-functions - 'matlab-shell-version-scrape))) - -(defun matlab-shell-mode () - "Run MATLAB as a subprocess in an Emacs buffer. - -This mode will allow standard Emacs shell commands/completion to occur -with MATLAB running as an inferior process. Additionally, this shell -mode is integrated with `matlab-mode', a major mode for editing M -code. - -> From an M file buffer: -\\<matlab-mode-map> -\\[matlab-shell-save-and-go] - Save the current M file, and run it in a \ -MATLAB shell. - -> From Shell mode: -\\<matlab-shell-mode-map> -\\[matlab-shell-last-error] - find location of last MATLAB runtime error \ -in the offending M file. - -> From an M file, or from Shell mode: -\\<matlab-mode-map> -\\[matlab-shell-run-command] - Run COMMAND and show result in a popup buffer. -\\[matlab-shell-describe-variable] - Show variable contents in a popup buffer. -\\[matlab-shell-describe-command] - Show online documentation for a command \ -in a popup buffer. -\\[matlab-shell-apropos] - Show output from LOOKFOR command in a popup buffer. -\\[matlab-shell-topic-browser] - Topic browser using HELP. - -> Keymap: -\\{matlab-mode-map}" - (setq major-mode 'matlab-shell-mode - mode-name "M-Shell" - comint-prompt-regexp "^\\(K\\|EDU\\)?>> *" - comint-delimiter-argument-list (list [ 59 ]) ; semi colon - comint-dynamic-complete-functions '(comint-replace-by-expanded-history) - comint-process-echoes matlab-shell-echoes - ) - ;; matlab-shell variable setup - (make-local-variable 'matlab-shell-last-error-anchor) - (setq matlab-shell-last-error-anchor nil) - - ;; Shell Setup - (require 'shell) - (if (fboundp 'shell-directory-tracker) - (add-hook 'comint-input-filter-functions 'shell-directory-tracker nil t)) ;; patch Eli Merriam - ;; Add a spiffy logo if we are running XEmacs - (if (and (string-match "XEmacs" emacs-version) - (stringp matlab-shell-logo) - (file-readable-p matlab-shell-logo)) - (add-hook 'comint-output-filter-functions 'matlab-shell-hack-logo)) - ;; Add a version scraping logo identification filter. - (add-hook 'comint-output-filter-functions 'matlab-shell-version-scrape) - ;; Add pseudo html-renderer - (add-hook 'comint-output-filter-functions 'matlab-shell-render-html-anchor nil t) - (add-hook 'comint-output-filter-functions 'matlab-shell-render-html-txt-format nil t) - (add-hook 'comint-output-filter-functions 'matlab-shell-render-errors-as-anchor nil t) - ;; Scroll to bottom after running cell/region - (add-hook 'comint-output-filter-functions 'comint-postoutput-scroll-to-bottom) - - (make-local-variable 'comment-start) - (setq comment-start "%") - (use-local-map matlab-shell-mode-map) - (set-syntax-table matlab-mode-syntax-table) - (make-local-variable 'font-lock-defaults) - (setq font-lock-defaults '((matlab-shell-font-lock-keywords-1 - matlab-shell-font-lock-keywords-2 - matlab-shell-font-lock-keywords-3) - t nil ((?_ . "w")))) - (set (make-local-variable 'comint-input-ring-size) - matlab-shell-input-ring-size) - (set (make-local-variable 'comint-input-ring-file-name) - (format matlab-shell-history-file "R12")) - (if (fboundp 'comint-read-input-ring) - (comint-read-input-ring t)) - (make-local-variable 'gud-marker-acc) - (easy-menu-define - matlab-shell-menu - matlab-shell-mode-map - "MATLAB shell menu" - '("MATLAB" - ["Goto last error" matlab-shell-last-error t] - "----" - ["Stop On Errors" matlab-shell-dbstop-error t] - ["Don't Stop On Errors" matlab-shell-dbclear-error t] - "----" - ["Run Command" matlab-shell-run-command t] - ["Describe Variable" matlab-shell-describe-variable t] - ["Describe Command" matlab-shell-describe-command t] - ["Lookfor Command" matlab-shell-apropos t] - ["Topic Browser" matlab-shell-topic-browser t] - "----" - ["Demos" matlab-shell-demos t] - ["Close Current Figure" matlab-shell-close-current-figure t] - ["Close Figures" matlab-shell-close-figures t] - "----" - ["Customize" (customize-group 'matlab-shell) - (and (featurep 'custom) (fboundp 'custom-declare-variable)) - ] - ["Exit" matlab-shell-exit t])) - (easy-menu-add matlab-shell-menu matlab-shell-mode-map) - - (if matlab-shell-enable-gud-flag - (progn - (gud-def gud-break "dbstop at %l in %f" "\C-b" "Set breakpoint at current line.") - (gud-def gud-remove "dbclear at %l in %f" "\C-d" "Remove breakpoint at current line") - (gud-def gud-step "dbstep in" "\C-s" "Step one source line, possibly into a function.") - (gud-def gud-next "dbstep %p" "\C-n" "Step over one source line.") - (gud-def gud-cont "dbcont" "\C-r" "Continue with display.") - (gud-def gud-finish "dbquit" "\C-f" "Finish executing current function.") - (gud-def gud-up "dbup %p" "<" "Up N stack frames (numeric arg).") - (gud-def gud-down "dbdown %p" ">" "Down N stack frames (numeric arg).") - (gud-def gud-print "%e" "\C-p" "Evaluate M expression at point.") - (if (fboundp 'gud-make-debug-menu) - (gud-make-debug-menu)) - (if (fboundp 'gud-overload-functions) - (gud-overload-functions - '((gud-massage-args . gud-matlab-massage-args) - (gud-marker-filter . gud-matlab-marker-filter) - (gud-find-file . gud-matlab-find-file)))) - ;; XEmacs doesn't seem to have this concept already. Oh well. - (setq gud-marker-acc nil) - ;; XEmacs has problems w/ this variable. Set it here. - (set-marker comint-last-output-start (point-max)) - )) - (run-hooks 'matlab-shell-mode-hook) - (matlab-show-version) - ) - -(defvar gud-matlab-marker-regexp-prefix "error:\\|opentoline" - "A prefix to scan for to know if output might be scarfed later.") - -(defvar matlab-shell-html-map - (let ((km (make-sparse-keymap))) - (if (string-match "XEmacs" emacs-version) - (define-key km [button2] 'matlab-shell-html-click) - (define-key km [mouse-2] 'matlab-shell-html-click)) - (define-key km [return] 'matlab-shell-html-go) - km) - "Keymap used on overlays that represent errors.") - -;; ANCHORS -(defvar matlab-anchor-beg "<a href=\"\\(?:matlab: \\)?\\([^\"]+\\)\">" - "Beginning of html anchor.") - -(defvar matlab-anchor-end "</a>" - "End of html anchor.") - -(defun matlab-shell-render-html-anchor (str) - "Render html anchors inserted into the MATLAB shell buffer. -Argument STR is the text for the anchor." - (if (string-match matlab-anchor-end str) - (save-excursion - (while (re-search-backward matlab-anchor-beg - ;; Arbitrary back-buffer. We don't - ;; usually get text in such huge chunks - (max (point-min) (- (point-max) 8192)) - t) - (let* ((anchor-beg-start (match-beginning 0)) - (anchor-beg-finish (match-end 0)) - (anchor-text (match-string 1)) - (anchor-end-finish (search-forward matlab-anchor-end)) - (anchor-end-start (match-beginning 0)) - (o (matlab-make-overlay anchor-beg-finish anchor-end-start))) - (matlab-overlay-put o 'mouse-face 'highlight) - (matlab-overlay-put o 'face 'underline) - (matlab-overlay-put o 'matlab-url anchor-text) - (matlab-overlay-put o 'keymap matlab-shell-html-map) - (matlab-overlay-put o 'help-echo anchor-text) - (delete-region anchor-end-start anchor-end-finish) - (delete-region anchor-beg-start anchor-beg-finish) - )))) - ) - -;; TEXT FORMATTING -(defvar matlab-txt-format-beg "<\\(strong\\|u\\)>" - "Beginning of html text formatting signal in HTML.") - -(defvar matlab-txt-format-end "</%s>" - "End of some html text formatter. -Includes a %s to match the kind of text format start regexp.") - -(defun matlab-shell-render-html-txt-format (str) - "Render html text format inserted into the MATLAB shell buffer. -Argument STR is the text for the text formater." - (if (string-match "</\\w+>" str) - (save-excursion - (while (re-search-backward matlab-txt-format-beg - ;; Arbitrary back-buffer. We don't - ;; usually get text in such huge chunks - (max (point-min) (- (point-max) 8192)) - t) - (let* ((txt-format-beg-start (match-beginning 0)) - (txt-format-beg-finish (match-end 0)) - (txt-format-text (match-string 1)) - (txt-format-end-finish - ;; The finish combines the text from the start to get an - ;; exact match. - (search-forward (format matlab-txt-format-end txt-format-text))) - (txt-format-end-start (match-beginning 0)) - (o (matlab-make-overlay txt-format-beg-finish txt-format-end-start))) - (cond ((string= txt-format-text "strong") - (upcase-region txt-format-beg-finish txt-format-end-start) - (matlab-overlay-put o 'face 'bold)) - ((string= txt-format-text "u") - (matlab-overlay-put o 'face 'underline)) - (t - ;; If we don't match, delete the overlay instead. - (matlab-delete-overlay o) - (setq o nil) - )) - (when o - (delete-region txt-format-end-start txt-format-end-finish) - (delete-region txt-format-beg-start txt-format-beg-finish)) - )))) - ) - -;; The regular expression covers the following form: -;; Errors: Error in ==> <function name> -;; On line # ==> <command_name> -;; Errors: Error using ==> <function name> at <#> -;; Syntax: Syntax error in ==> <filename> -;; On line # ==> <sample-text> -;; Warning: In <filename> at line # <stuff> -(defvar gud-matlab-error-regexp - (concat "\\(Error \\(?:in\\|using\\) ==>\\|Syntax error in ==>\\|In\\) " - "\\([-@.a-zA-Z_0-9/ \\\\:]+\\)\\(?:>[^ ]+\\)?.*[\n ]\\(?:On\\|at\\)\\(?: line\\)? " - "\\([0-9]+\\) ?") - "Regular expression finding where an error occurred.") - -(defvar matlab-shell-last-error-anchor nil - "Last point where an error anchor was set.") -(defvar matlab-shell-last-anchor-as-frame nil - ;; NOTE: this isn't being used yet. - "The last error anchor saved, represented as a debugger frame.") - -(defun matlab-shell-render-errors-as-anchor (str) - "Detect non-url errors, and treat them as if they were url anchors. -Argument STR is the text that might have errors in it." - (save-excursion - ;; We have found an error stack to investigate. - (let ((first nil) - (overlaystack nil)) - (while (re-search-backward gud-matlab-error-regexp - (if matlab-shell-last-error-anchor - (min matlab-shell-last-error-anchor (point)) - (point)) - t) - (let* ((err-start (match-beginning 0)) - (err-end (match-end 0)) - (err-text (match-string 0)) - (err-file (match-string 2)) - (err-line (match-string 3)) - (o (matlab-make-overlay err-start err-end)) - (url (concat "opentoline('" err-file "'," err-line ",0)")) - ) - (matlab-overlay-put o 'mouse-face 'highlight) - (matlab-overlay-put o 'face 'underline) - ;; The url will recycle opentoline code. - (matlab-overlay-put o 'matlab-url url) - (matlab-overlay-put o 'keymap matlab-shell-html-map) - (matlab-overlay-put o 'help-echo (concat "Jump to error at " err-file ".")) - (setq first url) - (push o overlaystack) - ;; Save as a frame - (setq matlab-shell-last-anchor-as-frame - (cons err-file err-line)) - )) - ;; Keep track of the very first error in this error stack. - ;; It will represent the "place to go" for "go-to-last-error". - (dolist (O overlaystack) - (matlab-overlay-put O 'first-in-error-stack first)) - ;; Once we've found something, don't scan it again. - (setq matlab-shell-last-error-anchor (point-marker))))) - -(defvar gud-matlab-marker-regexp-1 "^K>>" - "Regular expression for finding a file line-number.") - -(defvar gud-matlab-marker-regexp-2 - (concat "^> In \\(" matlab-anchor-beg - "\\|\\)\\([-.a-zA-Z0-9_>/@]+\\) \\((\\w+) \\|\\)at line \\([0-9]+\\)[ \n]+") - "Regular expression for finding a file line-number. -Please note: The leading > character represents the current stack frame, so if -there are several frames, this makes sure we pick the right one to popup.") - -(defun gud-matlab-massage-args (file args) - "Argument massager for starting matlab file. -I don't think I have to do anything, but I'm not sure. -FILE is ignored, and ARGS is returned." - args) - -(defun gud-matlab-marker-filter (string) - "Filters STRING for the Unified Debugger based on MATLAB output." - (if matlab-prompt-seen - nil - (when (string-match ">> " string) - (if matlab-shell-use-emacs-toolbox - ;; Use our local toolbox directory. - (process-send-string - (get-buffer-process gud-comint-buffer) - (format "addpath('%s','-begin'); rehash; emacsinit('%s');\n" - (expand-file-name "toolbox" - (file-name-directory - (locate-library "matlab"))) - matlab-shell-emacsclient-command)) - ;; User doesn't want to use our fancy toolbox directory - (process-send-string - (get-buffer-process gud-comint-buffer) - "if usejava('jvm'), \ -com.mathworks.services.Prefs.setBooleanPref('EditorGraphicalDebugging', false); \ -end\n" - )) - ;; Mark that we've seen at least one prompt. - (setq matlab-prompt-seen t) - )) - (let ((garbage (concat "\\(" (regexp-quote "\C-g") "\\|" - (regexp-quote "\033[H0") "\\|" - (regexp-quote "\033[H\033[2J") "\\|" - (regexp-quote "\033H\033[2J") "\\)"))) - (while (string-match garbage string) - (if (= (aref string (match-beginning 0)) ?\C-g) - (beep t)) - (setq string (replace-match "" t t string)))) - - (setq gud-marker-acc (concat gud-marker-acc string)) - (let ((output "") (frame nil)) - - (when (not frame) - (when (string-match gud-matlab-marker-regexp-1 gud-marker-acc) - (when (not frame) - ;; If there is a debug prompt, and no frame currently set, - ;; go find one. - (let ((url gud-marker-acc) - ef el) - (cond - ((string-match "^error:\\(.*\\),\\([0-9]+\\),\\([0-9]+\\)$" url) - (setq ef (substring url (match-beginning 1) (match-end 1)) - el (substring url (match-beginning 2) (match-end 2))) - ) - ((string-match "opentoline('\\([^']+\\)',\\([0-9]+\\),\\([0-9]+\\))" url) - (setq ef (substring url (match-beginning 1) (match-end 1)) - el (substring url (match-beginning 2) (match-end 2))) - ) - ;; If we have the prompt, but no match (as above), - ;; perhaps it is already dumped out into the buffer. In - ;; that case, look back through the buffer. - - ) - (when ef - (setq frame (cons ef (string-to-number el))))))) - ) - ;; This if makes sure that the entirety of an error output is brought in - ;; so that matlab-shell-mode doesn't try to display a file that only partially - ;; exists in the buffer. Thus, if MATLAB output: - ;; error: /home/me/my/mo/mello.m,10,12 - ;; All of that is in the buffer, and it goes to mello.m, not just - ;; the first half of that file name. - ;; The below used to match against the prompt, not \n, but then text that - ;; had error: in it for some other reason wouldn't display at all. - (if (and matlab-prompt-seen ;; Don't collect during boot - (not frame) ;; don't collect debug stuff - (let ((start (string-match gud-matlab-marker-regexp-prefix gud-marker-acc))) - (and start - (not (string-match "\n" gud-marker-acc start)) - ;;(not (string-match "^K?>>\\|\\?\\?\\?\\s-Error while evaluating" gud-marker-acc start)) - ))) - ;; We could be collecting something. Wait for a while. - nil - ;; Finish off this part of the output. None of our special stuff - ;; ends with a \n, so display those as they show up... - (while (string-match "^[^\n]*\n" gud-marker-acc) - (setq output (concat output (substring gud-marker-acc 0 (match-end 0))) - gud-marker-acc (substring gud-marker-acc (match-end 0)))) - - (setq output (concat output gud-marker-acc) - gud-marker-acc "") - ;; Check our output for a prompt, and existence of a frame. - ;; If t his is true, throw out the debug arrow stuff. - (if (and (string-match "^>> $" output) - gud-last-last-frame) - (progn - (setq overlay-arrow-position nil - gud-last-last-frame nil - gud-overlay-arrow-position nil) - (sit-for 0) - ))) - - (if frame (setq gud-last-frame frame)) - - ;;(message "[%s] [%s]" output gud-marker-acc) - - output)) - -(defun gud-matlab-find-file (f) - "Find file F when debugging frames in MATLAB." - (save-excursion - (let* ((realfname (if (string-match "\\.\\(p\\)$" f) - (progn - (aset f (match-beginning 1) ?m) - f) - f)) - (buf (find-file-noselect realfname))) - (set-buffer buf) - (if (fboundp 'gud-make-debug-menu) - (gud-make-debug-menu)) - buf))) - -(defun matlab-shell-next-matching-input-from-input (n) - "Get the Nth next matching input from for the command line." - (interactive "p") - (matlab-shell-previous-matching-input-from-input (- n))) - -(defun matlab-shell-previous-matching-input-from-input (n) - "Get the Nth previous matching input from for the command line." - (interactive "p") - (end-of-line) ;; patch: Mark Histed - (if (comint-after-pmark-p) - (if (memq last-command '(matlab-shell-previous-matching-input-from-input - matlab-shell-next-matching-input-from-input)) - ;; This hack keeps the cycling working well. - (let ((last-command 'comint-previous-matching-input-from-input)) - (comint-next-matching-input-from-input (- n))) - ;; first time. - (comint-next-matching-input-from-input (- n))) - - ;; If somewhere else, just move around. - (previous-line n))) - -(defun matlab-shell-delete-backwards-no-prompt (&optional arg) - "Delete one char backwards without destroying the matlab prompt. -Optional argument ARG describes the number of chars to delete." - (interactive "P") - (let ((promptend (save-excursion - (beginning-of-line) - (if (looking-at "K?>> ") - (match-end 0) - (point)))) - (numchars (if (integerp arg) (- arg) -1))) - (if (<= promptend (+ (point) numchars)) - (delete-char numchars) - (error "Beginning of line")))) - -(defun matlab-shell-completion-list (str) - "Get a list of completions from MATLAB. -STR is a substring to complete." - (save-excursion - (let* ((msbn (matlab-shell-buffer-barf-not-running)) - (cmd (concat "matlabMCRprocess = com.mathworks.jmi.MatlabMCR;" - "matlabMCRprocess.mtFindAllTabCompletions('" - str "'), clear('matlabMCRprocess');")) - (comint-scroll-show-maximum-output nil) - output - (completions nil)) - (set-buffer msbn) - (if (not (matlab-on-prompt-p)) - (error "MATLAB shell must be non-busy to do that")) - (setq output (matlab-shell-collect-command-output cmd)) - ;; Debug - (string-match "ans =" output) - (setq output (substring output (match-end 0))) - ;; Parse the output string. - (while (string-match "'" output) - ;; Hack off the preceeding quote - (setq output (substring output (match-end 0))) - (string-match "'" output) - ;; we are making a completion list, so that is a list of lists. - (setq completions (cons (list (substring output 0 (match-beginning 0))) - completions) - output (substring output (match-end 0)))) - ;; Return them - (nreverse completions)))) - -(defun matlab-shell-which-fcn (fcn) - "Get the location of FCN's M file. -Returns an alist: ( LOCATION . BUILTINFLAG ) -LOCATION is a string indicating where it is, and BUILTINFLAG is -non-nil if FCN is a builtin." - (save-excursion - (let* ((msbn (matlab-shell-buffer-barf-not-running)) - (cmd (concat "which " fcn)) - (comint-scroll-show-maximum-output nil) - output - builtin - ) - (set-buffer msbn) - (if (not (matlab-on-prompt-p)) - (error "MATLAB shell must be non-busy to do that")) - (setq output (matlab-shell-collect-command-output cmd)) - ;; BUILT-IN - (cond - ((string-match "built-in (\\([^)]+\\))" output) - (cons (concat (substring output (match-beginning 1) (match-end 1)) - ".m") - t)) - ;; Error - ((string-match "not found" output) - nil) - ;; JUST AN M FILE - (t - (string-match "$" output) - (cons (substring output 0 (match-beginning 0)) nil)))))) - -(defun matlab-shell-matlabroot () - "Get the location of of this shell's root. -Returns a string path to the root of the executing MATLAB." - (save-excursion - (let* ((msbn (matlab-shell-buffer-barf-not-running)) - (cmd "disp(matlabroot)") - (comint-scroll-show-maximum-output nil) - output - builtin - ) - (set-buffer msbn) - - (if (and (boundp 'matlab-shell-matlabroot-run) - matlab-shell-matlabroot-run) - matlab-shell-matlabroot-run - ;; If we haven't cache'd it, calculate it now. - - (if (not (matlab-on-prompt-p)) - (error "MATLAB shell must be non-busy to do that")) - (setq output (matlab-shell-collect-command-output cmd)) - - (string-match "$" output) - (substring output 0 (match-beginning 0)))))) - -(defvar matlab-shell-window-exists-for-display-completion-flag nil - "Non-nil means there was an 'other-window' available when `display-completion-list' is called.") - -(defun matlab-shell-tab () - "Send [TAB] to the currently running matlab process and retrieve completion." - (interactive) - (if (not matlab-shell-ask-MATLAB-for-completions) - (call-interactively 'comint-dynamic-complete-filename) - (if (not (matlab-on-prompt-p)) - (error "Completions not available")) - (if nil - ;; For older versions of MATLAB that don't have TAB - ;; completion. - (call-interactively 'comint-dynamic-complete-filename) - ;; Save the old command - (goto-char (point-max)) - (let ((inhibit-field-text-motion t)) - (beginning-of-line)) - (re-search-forward comint-prompt-regexp) - (let* ((lastcmd (buffer-substring (point) (matlab-point-at-eol))) - (tempcmd lastcmd) - (completions nil) - (limitpos nil)) - ;; search for character which limits completion, and limit command to it - (setq limitpos - (if (string-match ".*\\([( /[.,;=']\\)" lastcmd) - (1+ (match-beginning 1)) - 0)) - (setq lastcmd (substring lastcmd limitpos)) - ;; Whack the old command so we can insert it back later. - (delete-region (+ (point) limitpos) (matlab-point-at-eol)) - ;; double every single quote - (while (string-match "[^']\\('\\)\\($\\|[^']\\)" tempcmd) - (setq tempcmd (replace-match "''" t t tempcmd 1))) - ;; collect the list - (setq completions (matlab-shell-completion-list tempcmd)) - (goto-char (point-max)) - (if (eq (length completions) 1) - ;; If there is only one, then there is an obvious thing to do. - (progn - (insert (car (car completions))) - ;; kill completions buffer if still visible - (matlab-shell-tab-hide-completions)) - (let ((try (try-completion lastcmd completions))) - ;; Insert in a good completion. - (cond ((or (eq try nil) (eq try t) - (and (stringp try) - (string= try lastcmd))) - (insert lastcmd) - ;; Before displaying the completions buffer, check to see if - ;; the completions window is already displayed, or if there is - ;; a next window to display. This determines how to remove the - ;; completions later. - (if (get-buffer-window "*Completions*") - nil ;; Recycle old value of the display flag. - ;; Else, reset this variable. - (setq matlab-shell-window-exists-for-display-completion-flag - ;; Else, it isn't displayed, save an action. - (if (eq (next-window) (selected-window)) - ;; If there is no other window, the post action is - ;; to delete. - 'delete - ;; If there is a window to display, the post - ;; action is to bury. - 'bury))) - (with-output-to-temp-buffer "*Completions*" - (display-completion-list (mapcar 'car completions) lastcmd))) - ((stringp try) - (insert try) - (matlab-shell-tab-hide-completions)) - (t - (insert lastcmd)))) - ))))) - -(defun matlab-shell-tab-hide-completions () - "Hide any completion windows for `matlab-shell-tab'." - (cond ((eq matlab-shell-window-exists-for-display-completion-flag 'delete) - (when (get-buffer "*Completions*") - (delete-windows-on "*Completions*"))) - ((eq matlab-shell-window-exists-for-display-completion-flag 'bury) - (let ((orig (selected-window)) - (bw nil)) - (while (setq bw (get-buffer-window "*Completions*")) - (select-window bw) - (bury-buffer)) - (select-window orig))) - ) - ;; Reset state. - (setq matlab-shell-window-exists-for-display-completion-flag nil)) - - -;;; MATLAB mode Shell commands ================================================ - -(defun matlab-show-matlab-shell-buffer () - "Switch to the buffer containing the matlab process." - (interactive) - (let ((msbn (concat "*" matlab-shell-buffer-name "*"))) - (if (get-buffer msbn) - (switch-to-buffer-other-window msbn) - (message "There is not an active MATLAB process.")))) - -(defvar matlab-shell-save-and-go-history '("()") - "Keep track of parameters passed to the MATLAB shell.") - -(defun matlab-shell-add-to-input-history (string) - "Add STRING to the input-ring and run `comint-input-filter-functions' on it. -Similar to `comint-send-input'." - (if (and (funcall comint-input-filter string) - (or (null comint-input-ignoredups) - (not (ring-p comint-input-ring)) - (ring-empty-p comint-input-ring) - (not (string-equal (ring-ref comint-input-ring 0) string)))) - (ring-insert comint-input-ring string)) - (run-hook-with-args 'comint-input-filter-functions - (concat string "\n")) - (if (boundp 'comint-save-input-ring-index);only bound in GNU emacs - (setq comint-save-input-ring-index comint-input-ring-index)) - (setq comint-input-ring-index nil)) - -(defun matlab-shell-save-and-go () - "Save this M file, and evaluate it in a MATLAB shell." - (interactive) - (if (not (eq major-mode 'matlab-mode)) - (error "Save and go is only useful in a MATLAB buffer!")) - (if (not (buffer-file-name (current-buffer))) - (call-interactively 'write-file)) - (let ((fn-name (file-name-sans-extension - (file-name-nondirectory (buffer-file-name)))) - (msbn (concat "*" matlab-shell-buffer-name "*")) - (param "")) - (save-buffer) - ;; Do we need parameters? - (if (save-excursion - (goto-char (point-min)) - (end-of-line) - (forward-sexp -1) - (looking-at "([a-zA-Z]")) - (setq param (read-string "Parameters: " - (car matlab-shell-save-and-go-history) - 'matlab-shell-save-and-go-history))) - (if (matlab-with-emacs-link) - ;; Execute the current file in MATLAB - (matlab-eei-run) - - ;; No buffer? Make it! - (if (not (get-buffer msbn)) (matlab-shell)) - ;; Ok, now fun the function in the matlab shell - (if (get-buffer-window msbn t) - (select-window (get-buffer-window msbn t)) - (switch-to-buffer (concat "*" matlab-shell-buffer-name "*"))) - - (let ((cmd (concat fn-name " " param))) - (matlab-shell-add-to-input-history cmd) - (matlab-shell-send-string (concat cmd "\n")))))) - -(defun matlab-shell-run-region (beg end &optional noshow) - "Run region from BEG to END and display result in MATLAB shell. -If NOSHOW is non-nil, replace newlines with commas to suppress output. -This command requires an active MATLAB shell." - (interactive "r") - (if (> beg end) (let (mid) (setq mid beg beg end end mid))) - - (let ((command - (let ((str (concat (buffer-substring beg end) "\n"))) - ;; Remove comments - (with-temp-buffer - (insert str) - (goto-char (point-min)) - (while (search-forward "%" nil t) - (when (not (matlab-cursor-in-string)) - (delete-region (1- (point)) (matlab-point-at-eol)))) - (setq str (buffer-substring-no-properties (point-min) (point-max)))) - (while (string-match "\n\\s-*\n" str) - (setq str (concat (substring str 0 (match-beginning 0)) - "\n" - (substring str (match-end 0))))) - (when noshow - ;; Remove continuations - (while (string-match - (concat "\\s-*" - (regexp-quote matlab-elipsis-string) - "\\s-*\n") - str) - (setq str (replace-match " " t t str))) - (while (string-match "\n" str) - (setq str (replace-match ", " t t str))) - (setq str (concat str "\n"))) - str)) - (msbn nil) - (lastcmd) - (inhibit-field-text-motion t)) - (if (matlab-with-emacs-link) - ;; Run the region w/ Emacs Link - (matlab-eei-eval-region beg end) - - (save-excursion - (setq msbn (matlab-shell-buffer-barf-not-running)) - (set-buffer msbn) - (if (not (matlab-on-prompt-p)) - (error "MATLAB shell must be non-busy to do that")) - ;; Save the old command - (beginning-of-line) - (re-search-forward comint-prompt-regexp) - (setq lastcmd (buffer-substring (point) (matlab-point-at-eol))) - (delete-region (point) (matlab-point-at-eol)) - ;; We are done error checking, run the command. - (matlab-shell-send-string command) - (insert lastcmd)) - (set-buffer msbn) - (goto-char (point-max)) - (display-buffer msbn nil "visible")) - )) - -(defun matlab-shell-run-cell () - "Run the cell the cursor is in." - (interactive) - (let ((start (save-excursion (forward-page -1) - (if (looking-at "function") - (error "You are not in a cell. Try `matlab-shell-save-and-go' instead")) - (when (matlab-ltype-comm) - ;; Skip over starting comment from the current cell. - (matlab-end-of-command 1) - (end-of-line) - (forward-char 1)) - (point))) - (end (save-excursion (forward-page 1) - (when (matlab-ltype-comm) - (beginning-of-line) - (forward-char -1)) - (point)))) - (matlab-shell-run-region start end t))) - -(defun matlab-shell-run-region-or-line () - "Run region from BEG to END and display result in MATLAB shell. -pIf region is not active run the current line. -This command requires an active MATLAB shell." - (interactive) - (if (and transient-mark-mode mark-active) - (matlab-shell-run-region (mark) (point)) - (matlab-shell-run-region (matlab-point-at-bol) (matlab-point-at-eol)))) - - -;;; MATLAB Shell Commands ===================================================== - -(defun matlab-read-word-at-point () - "Get the word closest to point, but do not change position. -Has a preference for looking backward when not directly on a symbol. -Snatched and hacked from dired-x.el" - (let ((word-chars "a-zA-Z0-9_") - (bol (matlab-point-at-bol)) - (eol (matlab-point-at-eol)) - start) - (save-excursion - ;; First see if just past a word. - (if (looking-at (concat "[" word-chars "]")) - nil - (skip-chars-backward (concat "^" word-chars "{}()\[\]") bol) - (if (not (bobp)) (backward-char 1))) - (if (numberp (string-match (concat "[" word-chars "]") - (char-to-string (following-char)))) - (progn - (skip-chars-backward word-chars bol) - (setq start (point)) - (skip-chars-forward word-chars eol)) - (setq start (point))) ; If no found, return empty string - (buffer-substring start (point))))) - -(defun matlab-read-line-at-point () - "Get the line under point, if command line." - (if (eq major-mode 'matlab-shell-mode) - (save-excursion - (let ((inhibit-field-text-motion t)) - (beginning-of-line) - (if (not (looking-at (concat comint-prompt-regexp))) - "" - (search-forward-regexp comint-prompt-regexp) - (buffer-substring (point) (matlab-point-at-eol))))) - (save-excursion - ;; In matlab buffer, find all the text for a command. - ;; so back over until there is no more continuation. - (while (save-excursion (forward-line -1) (matlab-lattr-cont)) - (forward-line -1)) - ;; Go forward till there is no continuation - (beginning-of-line) - (let ((start (point))) - (while (matlab-lattr-cont) (forward-line 1)) - (end-of-line) - (buffer-substring start (point)))))) - -(defun matlab-non-empty-lines-in-string (str) - "Return number of non-empty lines in STR." - (let ((count 0) - (start 0)) - (while (string-match "^.+$" str start) - (setq count (1+ count) - start (match-end 0))) - count)) - -(defun matlab-output-to-temp-buffer (buffer output) - "Print output to temp buffer, or a message if empty string. -BUFFER is the buffer to output to, and OUTPUT is the text to insert." - (let ((lines-found (matlab-non-empty-lines-in-string output))) - (cond ((= lines-found 0) - (message "(MATLAB command completed with no output)")) - ((= lines-found 1) - (string-match "^.+$" output) - (message (substring output (match-beginning 0)(match-end 0)))) - (t (with-output-to-temp-buffer buffer (princ output)) - (save-excursion - (set-buffer buffer) - (matlab-shell-help-mode)))))) - -(defun matlab-shell-run-command (command) - "Run COMMAND and display result in a buffer. -This command requires an active MATLAB shell." - (interactive (list (read-from-minibuffer - "MATLAB command line: " - (cons (matlab-read-line-at-point) 0)))) - (let ((doc (matlab-shell-collect-command-output command))) - (matlab-output-to-temp-buffer "*MATLAB Help*" doc))) - -(defun matlab-shell-describe-variable (variable) - "Get the contents of VARIABLE and display them in a buffer. -This uses the WHOS (MATLAB 5) command to find viable commands. -This command requires an active MATLAB shell." - (interactive (list (read-from-minibuffer - "MATLAB variable: " - (cons (matlab-read-word-at-point) 0)))) - (let ((doc (matlab-shell-collect-command-output (concat "whos " variable)))) - (matlab-output-to-temp-buffer "*MATLAB Help*" doc))) - -(defun matlab-shell-describe-command (command) - "Describe COMMAND textually by fetching it's doc from the MATLAB shell. -This uses the lookfor command to find viable commands. -This command requires an active MATLAB shell." - (interactive - (let ((fn (matlab-function-called-at-point)) - val) - (setq val (read-string (if fn - (format "Describe function (default %s): " fn) - "Describe function: "))) - (if (string= val "") (list fn) (list val)))) - (let ((doc (matlab-shell-collect-command-output (concat "help " command)))) - (matlab-output-to-temp-buffer "*MATLAB Help*" doc))) - -(defun matlab-shell-apropos (matlabregex) - "Look for any active commands in MATLAB matching MATLABREGEX. -This uses the lookfor command to find viable commands." - (interactive (list (read-from-minibuffer - "MATLAB command subexpression: " - (cons (matlab-read-word-at-point) 0)))) - (let ((ap (matlab-shell-collect-command-output - (concat "lookfor " matlabregex)))) - (matlab-output-to-temp-buffer "*MATLAB Apropos*" ap))) - -(defun matlab-on-prompt-p () - "Return t if we MATLAB can accept input." - (save-excursion - (let ((inhibit-field-text-motion t)) - (goto-char (point-max)) - (beginning-of-line) - (looking-at comint-prompt-regexp)))) - -(defun matlab-on-empty-prompt-p () - "Return t if we MATLAB is on an empty prompt." - (save-excursion - (let ((inhibit-field-text-motion t)) - (goto-char (point-max)) - (beginning-of-line) - (looking-at (concat comint-prompt-regexp "\\s-*$"))))) - -(defun matlab-shell-buffer-barf-not-running () - "Return a running MATLAB buffer iff it is currently active." - (or (matlab-shell-active-p) - (error "You need to run the command `matlab-shell' to do that!"))) - -(defun matlab-shell-collect-command-output (command) - "If there is a MATLAB shell, run the MATLAB COMMAND and return it's output. -It's output is returned as a string with no face properties. The text output -of the command is removed from the MATLAB buffer so there will be no -indication that it ran." - (let ((msbn (matlab-shell-buffer-barf-not-running)) - (pos nil) - (str nil) - (lastcmd) - (inhibit-field-text-motion t)) - (save-excursion - (set-buffer msbn) - (if (not (matlab-on-prompt-p)) - (error "MATLAB shell must be non-busy to do that")) - ;; Save the old command - (goto-char (point-max)) - (beginning-of-line) - (re-search-forward comint-prompt-regexp) - (setq lastcmd (buffer-substring (point) (matlab-point-at-eol))) - (delete-region (point) (matlab-point-at-eol)) - ;; We are done error checking, run the command. - (setq pos (point)) - (comint-simple-send (get-buffer-process (current-buffer)) - (concat command "\n")) - ;;(message "MATLAB ... Executing command.") - (goto-char (point-max)) - (while (or (>= (+ pos (string-width command)) (point)) (not (matlab-on-empty-prompt-p))) - (accept-process-output (get-buffer-process (current-buffer))) - (goto-char (point-max)) - ;;(message "MATLAB reading...") - ) - ;;(message "MATLAB reading...done") - (save-excursion - (goto-char pos) - (beginning-of-line) - (setq str (buffer-substring-no-properties (save-excursion - (goto-char pos) - (beginning-of-line) - (forward-line 1) - (point)) - (save-excursion - (goto-char (point-max)) - (beginning-of-line) - (point)))) - (delete-region pos (point-max))) - (insert lastcmd)) - str)) - -(defun matlab-shell-send-string (string) - "Send STRING to the currently running matlab process." - (if (not matlab-shell-echoes) - (let ((proc (get-buffer-process (current-buffer)))) - (goto-char (point-max)) - (insert string) - (set-marker (process-mark proc) (point)))) - (comint-send-string (get-buffer-process (current-buffer)) string)) - -(defun matlab-url-at (p) - "Return the matlab-url overlay at P, or nil." - (let ((url nil) (o (matlab-overlays-at p))) - (while (and o (not url)) - (setq url (matlab-overlay-get (car o) 'matlab-url) - o (cdr o))) - url)) - -(defun matlab-url-stack-top-at (p) - "Return the matlab-url overlay at P, or nil." - (let ((url nil) (o (matlab-overlays-at p))) - (while (and o (not url)) - (setq url (or (matlab-overlay-get (car o) 'first-in-error-stack) - (matlab-overlay-get (car o) 'matlab-url)) - o (cdr o))) - url)) - -(defun matlab-shell-previous-matlab-url (&optional stacktop) - "Find a previous occurrence of an overlay with a MATLAB URL. -If STACKTOP is non-nil, then also get the top of some stack, which didn't -show up in reverse order." - (save-excursion - (let ((url nil) (o nil) (p (point))) - (while (and (not url) - (setq p (matlab-previous-overlay-change p)) - (not (eq p (point-min)))) - (setq url - (if stacktop - (matlab-url-stack-top-at p) - (matlab-url-at p)))) - url))) - -(defun matlab-find-other-window-file-line-column (ef el ec &optional debug) - "Find file EF in other window and to go line EL and 1-basec column EC. -If DEBUG is non-nil, then setup GUD debugging features." - (cond ((file-exists-p ef) - nil);; keep ef the same - ((file-exists-p (concat ef ".m")) - (setq ef (concat ef ".m"))) ;; Displayed w/out .m? - ((string-match ">" ef) - (setq ef (concat (substring ef 0 (match-beginning 0)) ".m"))) - ) - (find-file-other-window ef) - (goto-line (string-to-number el)) - (when debug - (setq gud-last-frame (cons (buffer-file-name) (string-to-number el))) - (gud-display-frame)) - (setq ec (string-to-number ec)) - (if (> ec 0) (forward-char (1- ec)))) - -(defun matlab-find-other-window-via-url (url &optional debug) - "Find other window using matlab URL and optionally set DEBUG cursor." - (cond ((string-match "^error:\\(.*\\),\\([0-9]+\\),\\([0-9]+\\)$" url) - (let ((ef (substring url (match-beginning 1) (match-end 1))) - (el (substring url (match-beginning 2) (match-end 2))) - (ec (substring url (match-beginning 3) (match-end 3)))) - (matlab-find-other-window-file-line-column ef el ec debug))) - ((string-match "opentoline('\\([^']+\\)',\\([0-9]+\\),\\([0-9]+\\))" url) - (let ((ef (substring url (match-beginning 1) (match-end 1))) - (el (substring url (match-beginning 2) (match-end 2))) - (ec (substring url (match-beginning 3) (match-end 3)))) - (matlab-find-other-window-file-line-column ef el ec debug))) - ((string-match "^matlab: *\\(.*\\)$" url) - (process-send-string - (get-buffer-process gud-comint-buffer) - (concat (substring url (match-beginning 1) (match-end 1)) "\n"))))) - -(defun matlab-shell-last-error () - "In the MATLAB interactive buffer, find the last MATLAB error, and go there. -To reference old errors, put the cursor just after the error text." - (interactive) - (catch 'done - (let ((url (matlab-shell-previous-matlab-url t))) - (if url - (progn (matlab-find-other-window-via-url url) (throw 'done nil)) - (save-excursion - (end-of-line) ;; In case we are before the linenumber 1998/06/05 16:54sk - (if (not (re-search-backward gud-matlab-error-regexp nil t)) - (error "No errors found!")) - (let ((ef (buffer-substring-no-properties - (match-beginning 2) (match-end 2))) - (el (buffer-substring-no-properties - (match-beginning 3) (match-end 3)))) - (matlab-find-other-window-file-line-column ef el "0"))))))) - -(defun matlab-shell-html-click (e) - "Go to the error at the location of event E." - (interactive "e") - (mouse-set-point e) - (matlab-shell-html-go)) - -(defun matlab-shell-html-go () - "Go to the error at the location `point'." - (interactive) - (let ((url (matlab-url-at (point)))) - (if url (matlab-find-other-window-via-url url)))) - -(defun matlab-shell-dbstop-error () - "Stop on errors." - (interactive) - (comint-send-string (get-buffer-process (current-buffer)) - "dbstop if error\n")) - -(defun matlab-shell-dbclear-error () - "Don't stop on errors." - (interactive) - (comint-send-string (get-buffer-process (current-buffer)) - "dbclear if error\n")) - -(defun matlab-shell-demos () - "MATLAB demos." - (interactive) - (comint-send-string (get-buffer-process (current-buffer)) "demo\n")) - -(defun matlab-shell-close-figures () - "Close any open figures." - (interactive) - (comint-send-string (get-buffer-process (current-buffer)) "close all\n")) - -(defun matlab-shell-close-current-figure () - "Close current figure." - (interactive) - (comint-send-string (get-buffer-process (current-buffer)) "delete(gcf)\n")) - -(defun matlab-shell-exit () - "Exit MATLAB shell." - (interactive) - (comint-send-string (get-buffer-process (current-buffer)) "exit\n") - (kill-buffer nil)) - - -;;; matlab-shell based Topic Browser and Help ================================= - -(defcustom matlab-shell-topic-mode-hook nil - "*MATLAB shell topic hook." - :group 'matlab-shell - :type 'hook) - -(defvar matlab-shell-topic-current-topic nil - "The currently viewed topic in a MATLAB shell topic buffer.") - -(defun matlab-shell-topic-browser () - "Create a topic browser by querying an active MATLAB shell using HELP. -Maintain state in our topic browser buffer." - (interactive) - ;; Reset topic browser if it doesn't exist. - (if (not (get-buffer "*MATLAB Topic*")) - (setq matlab-shell-topic-current-topic nil)) - (let ((b (get-buffer-create "*MATLAB Topic*"))) - (switch-to-buffer b) - (if (string= matlab-shell-topic-current-topic "") - nil - (matlab-shell-topic-mode) - (matlab-shell-topic-browser-create-contents "")))) - -(defvar matlab-shell-topic-mouse-face-keywords - '(;; These are subtopic fields... - ("^\\(\\w+/\\w+\\)[ \t]+-" 1 font-lock-reference-face) - ;; These are functions... - ("^[ \t]+\\(\\w+\\)[ \t]+-" 1 font-lock-function-name-face) - ;; Here is a See Also line... - ("[ \t]+See also " - ("\\(\\w+\\)\\([,.]\\| and\\|$\\) *" nil nil (1 font-lock-reference-face)))) - "These are keywords we also want to put mouse-faces on.") - -(defvar matlab-shell-topic-font-lock-keywords - (append matlab-shell-topic-mouse-face-keywords - '(("^[^:\n]+:$" 0 font-lock-keyword-face) - ;; These are subheadings... - ("^[ \t]+\\([^.\n]+[a-zA-Z.]\\)$" 1 'underline) - )) - "Keywords useful for highlighting a MATLAB TOPIC buffer.") - -(defvar matlab-shell-help-font-lock-keywords - (append matlab-shell-topic-mouse-face-keywords - '(;; Function call examples - ("[ \t]\\([A-Z]+\\)\\s-*=\\s-*\\([A-Z]+[0-9]*\\)(" - (1 font-lock-variable-name-face) - (2 font-lock-function-name-face)) - ("[ \t]\\([A-Z]+[0-9]*\\)(" - (1 font-lock-function-name-face)) - ;; Parameters: Not very accurate, unfortunately. - ("[ \t]\\([A-Z]+[0-9]*\\)(" - ("'?\\(\\w+\\)'?\\([,)]\\) *" nil nil - (1 font-lock-variable-name-face)) - ) - ;; Reference uppercase words - ("\\<\\([A-Z]+[0-9]*\\)\\>" 1 font-lock-reference-face))) - "Keywords for regular help buffers.") - -;; View-major-mode is an emacs20 thing. This gives us a small compatibility -;; layer. -(if (not (fboundp 'view-major-mode)) (defalias 'view-major-mode 'view-mode)) - -(define-derived-mode matlab-shell-help-mode - view-major-mode "M-Help" - "Major mode for viewing MATLAB help text. -Entry to this mode runs the normal hook `matlab-shell-help-mode-hook'. - -Commands: -\\{matlab-shell-help-mode-map}" - (make-local-variable 'font-lock-defaults) - (setq font-lock-defaults '((matlab-shell-help-font-lock-keywords) - t nil ((?_ . "w")))) - ;; This makes sure that we really enter font lock since - ;; kill-all-local-variables is not used by old view-mode. - (and (boundp 'global-font-lock-mode) global-font-lock-mode - (not font-lock-mode) (font-lock-mode 1)) - (easy-menu-add matlab-shell-help-mode-menu matlab-shell-help-mode-map) - (matlab-shell-topic-mouse-highlight-subtopics) - ) - -(define-key matlab-shell-help-mode-map [return] 'matlab-shell-topic-choose) -(define-key matlab-shell-help-mode-map "t" 'matlab-shell-topic-browser) -(define-key matlab-shell-help-mode-map "q" 'bury-buffer) -(define-key matlab-shell-help-mode-map - [(control h) (control m)] matlab-help-map) -(if (string-match "XEmacs" emacs-version) - (define-key matlab-shell-help-mode-map [button2] 'matlab-shell-topic-click) - (define-key matlab-shell-help-mode-map [mouse-2] 'matlab-shell-topic-click)) - -(easy-menu-define - matlab-shell-help-mode-menu matlab-shell-help-mode-map - "MATLAB shell topic menu" - '("MATLAB Help" - ["Describe This Command" matlab-shell-topic-choose t] - "----" - ["Describe Command" matlab-shell-describe-command t] - ["Describe Variable" matlab-shell-describe-variable t] - ["Command Apropos" matlab-shell-apropos t] - ["Topic Browser" matlab-shell-topic-browser t] - "----" - ["Exit" bury-buffer t])) - -(define-derived-mode matlab-shell-topic-mode - matlab-shell-help-mode "M-Topic" - "Major mode for browsing MATLAB HELP topics. -The output of the MATLAB command HELP with no parameters creates a listing -of known help topics at a given installation. This mode parses that listing -and allows selecting a topic and getting more help for it. -Entry to this mode runs the normal hook `matlab-shell-topic-mode-hook'. - -Commands: -\\{matlab-shell-topic-mode-map}" - (setq font-lock-defaults '((matlab-shell-topic-font-lock-keywords) - t t ((?_ . "w")))) - (if (string-match "XEmacs" emacs-version) - (setq mode-motion-hook 'matlab-shell-topic-highlight-line)) - (easy-menu-add matlab-shell-topic-mode-menu matlab-shell-topic-mode-map) - ) - -(easy-menu-define - matlab-shell-topic-mode-menu matlab-shell-topic-mode-map - "MATLAB shell topic menu" - '("MATLAB Topic" - ["Select This Topic" matlab-shell-topic-choose t] - ["Top Level Topics" matlab-shell-topic-browser t] - "----" - ["Exit" bury-buffer t])) - -(defun matlab-shell-topic-browser-create-contents (subtopic) - "Fill in a topic browser with the output from SUBTOPIC." - (toggle-read-only -1) - (erase-buffer) - (insert (matlab-shell-collect-command-output (concat "help " subtopic))) - (goto-char (point-min)) - (forward-line 1) - (delete-region (point-min) (point)) - (setq matlab-shell-topic-current-topic subtopic) - (if (not (string-match "XEmacs" emacs-version)) - (matlab-shell-topic-mouse-highlight-subtopics)) - (toggle-read-only 1) - ) - -(defun matlab-shell-topic-click (e) - "Click on an item in a MATLAB topic buffer we want more information on. -Must be bound to event E." - (interactive "e") - (mouse-set-point e) - (matlab-shell-topic-choose)) - -(defun matlab-shell-topic-choose () - "Choose the topic to expand on that is under the cursor. -This can fill the topic buffer with new information. If the topic is a -command, use `matlab-shell-describe-command' instead of changing the topic -buffer." - (interactive) - (let ((topic nil) (fun nil) (p (point))) - (save-excursion - (beginning-of-line) - (if (looking-at "^\\w+/\\(\\w+\\)[ \t]+-") - (setq topic (match-string 1)) - (if (looking-at "^[ \t]+\\(\\(\\w\\|_\\)+\\)[ \t]+-") - (setq fun (match-string 1)) - (if (and (not (looking-at "^[ \t]+See also")) - (not (save-excursion (forward-char -2) - (looking-at ",$")))) - (error "You did not click on a subtopic, function or reference") - (goto-char p) - (forward-word -1) - (if (not (looking-at "\\(\\(\\w\\|_\\)+\\)\\([.,]\\| and\\|\n\\)")) - (error "You must click on a reference") - (setq topic (match-string 1))))))) - (message "Opening item %s..." (or topic fun)) - (if topic - (matlab-shell-topic-browser-create-contents (downcase topic)) - (matlab-shell-describe-command fun)) - )) - -(defun matlab-shell-topic-mouse-highlight-subtopics () - "Put a `mouse-face' on all clickable targets in this buffer." - (save-excursion - (let ((el matlab-shell-topic-mouse-face-keywords)) - (while el - (goto-char (point-min)) - (while (re-search-forward (car (car el)) nil t) - (let ((cd (car (cdr (car el))))) - (if (numberp cd) - (put-text-property (match-beginning cd) (match-end cd) - 'mouse-face 'highlight) - (while (re-search-forward (car cd) nil t) - (put-text-property (match-beginning (car (nth 3 cd))) - (match-end (car (nth 3 cd))) - 'mouse-face 'highlight))))) - (setq el (cdr el)))))) - -(defun matlab-shell-topic-highlight-line (event) - "A value of `mode-motion-hook' which will highlight topics under the mouse. -EVENT is the user mouse event." - ;; XEMACS only function - (let* ((buffer (event-buffer event)) - (point (and buffer (event-point event)))) - (if (and buffer (not (eq buffer mouse-grabbed-buffer))) - (save-excursion - (save-window-excursion - (set-buffer buffer) - (mode-motion-ensure-extent-ok event) - (if (not point) - (detach-extent mode-motion-extent) - (goto-char point) - (end-of-line) - (setq point (point)) - (beginning-of-line) - (if (or (looking-at "^\\w+/\\(\\w+\\)[ \t]+-") - (looking-at "^[ \t]+\\(\\(\\w\\|_\\)+\\)[ \t]+-")) - (set-extent-endpoints mode-motion-extent (point) point) - (detach-extent mode-motion-extent)))))))) - - -;;; M File path stuff ========================================================= - -(defun matlab-mode-determine-mfile-path () - "Create the path in `matlab-mode-install-path'." - (let ((path (file-name-directory matlab-shell-command))) - ;; if we don't have a path, find the MATLAB executable on our path. - (if (not path) - (let ((pl exec-path)) - (while (and pl (not path)) - (if (and (file-exists-p (concat (car pl) "/" matlab-shell-command)) - (not (car (file-attributes (concat (car pl) "/" - matlab-shell-command))))) - (setq path (car pl))) - (setq pl (cdr pl))))) - (if (not path) - nil - ;; When we find the path, we need to massage it to identify where - ;; the M files are that we need for our completion lists. - (if (string-match "/bin$" path) - (setq path (substring path 0 (match-beginning 0)))) - ;; Everything stems from toolbox (I think) - (setq path (concat path "/toolbox/"))) - path)) - -(defcustom matlab-mode-install-path (list (matlab-mode-determine-mfile-path)) - "Base path pointing to the locations of all the m files used by matlab. -All directories under each element of `matlab-mode-install-path' are -checked, so only top level toolbox directories need be added. -Paths should be added in the order in which they should be searched." - :group 'matlab-shell - :type '(repeat (string :tag "Path: "))) - -(defun matlab-find-file-under-path (path filename) - "Return the pathname or nil of PATH under FILENAME." - (if (file-exists-p (concat path filename)) - (concat path filename) - (let ((dirs (if (file-directory-p path) - ;; Not checking as a directory first fails on XEmacs - ;; Stelios Kyriacou <kyriacou@cbmv.jhu.edu> - (directory-files path t nil t))) - (found nil)) - (while (and dirs (not found)) - (if (and (car (file-attributes (car dirs))) - ;; require directory readable - (file-readable-p (car dirs)) - ;; don't redo our path names - (not (string-match "/\\.\\.?$" (car dirs))) - ;; don't find files in object directories. - (not (string-match "@" (car dirs)))) - (setq found - (matlab-find-file-under-path (concat (car dirs) "/") - filename))) - (setq dirs (cdr dirs))) - found))) - -(defun matlab-find-file-on-path (filename) - "Find FILENAME on the current MATLAB path. -The MATLAB path is determined by `matlab-mode-install-path' and the -current directory. You must add user-installed paths into -`matlab-mode-install-path' if you would like to have them included." - (interactive - (list - (let ((default (matlab-read-word-at-point))) - (if default - (let ((s (read-string (concat "File (default " default "): ")))) - (if (string= s "") default s)) - (read-string "File: "))))) - (if (string= filename "") - (error "You must specify an M file")) - (if (not (string-match "\\.m$" filename)) - (setq filename (concat filename ".m"))) - (let ((fname nil) - (dirs matlab-mode-install-path)) - (if (file-exists-p (concat default-directory filename)) - (setq fname (concat default-directory filename))) - (while (and (not fname) dirs) - (if (stringp (car dirs)) - (progn - (message "Searching for %s in %s" filename (car dirs)) - (setq fname (matlab-find-file-under-path (car dirs) filename)))) - (setq dirs (cdr dirs))) - (if fname (find-file fname) - (error "File %s not found on any known paths. \ -Check `matlab-mode-install-path'" filename)))) - -(defun matlab-find-file-click (e) - "Find the file clicked on with event E on the current path." - (interactive "e") - (mouse-set-point e) - (let ((f (matlab-read-word-at-point))) - (if (not f) (error "To find an M file, click on a word")) - (matlab-find-file-on-path f))) - - -;;; matlab-mode debugging ===================================================== - -(defun matlab-show-line-info () - "Display type and attributes of current line. Used in debugging." - (interactive) - (let ((msg "line-info:") - (indent (matlab-calculate-indentation (current-indentation))) - (nexti (matlab-next-line-indentation))) - (setq msg (concat msg - " Line type: " (symbol-name (car indent)) - " This Line: " (int-to-string (nth 1 indent)) - " Next Line: " (int-to-string nexti))) - (if (matlab-lattr-cont) - (setq msg (concat msg " w/cont"))) - (if (matlab-lattr-comm) - (setq msg (concat msg " w/comm"))) - (message msg))) - -(provide 'matlab) - -;;; matlab.el ends here diff --git a/elisp/emacs-goodies-el/minibuf-electric.el b/elisp/emacs-goodies-el/minibuf-electric.el deleted file mode 100755 index f5c5b6e..0000000 --- a/elisp/emacs-goodies-el/minibuf-electric.el +++ /dev/null @@ -1,121 +0,0 @@ -;;; minibuf-electric.el -- Electric minibuffer behavior from XEmacs. -;;; - -;; Extracted from minibuf.el --- Minibuffer functions for XEmacs -;; Copyright (C) 1992, 1993, 1994, 1997 Free Software Foundation, Inc. -;; Copyright (C) 1995 Tinker Systems. -;; Copyright (C) 1995, 1996, 2000 Ben Wing. - -;; Modified by Karl Hegbloom for GNU Emacs. Taken from XEmacs 21.4 -;; "lisp/minibuf.el". It needs fine tuning and placement in a -;; suitable location within the GNU Emacs Lisp tree. See below for -;; notes concerning key-maps. -;; -;; Submitted for inclusion in the Debian `emacs-goodies-el' package. -;; -;; GPL. - -;;; Commentary: -;; -;; -;; This works with GNU Emacs. It implements the XEmacs minibuffer -;; behavior for C-x C-f and other file name reading actions. When you -;; type "//", it clears the minibuffer back to the start, leaving only a -;; single "/". When you type a "~", it does the similar, leaving only -;; "~/". This is nicer than having to explicitly erase the contents of -;; the minibuffer. -;; -;; In the next GNU Emacs release (V22), the following will achieve this: -;; -;; (setq file-name-shadow-tty-properties '(invisible t)) -;; (file-name-shadow-mode 1) - -;;; History: -;; -;; 2005-09-26 Peter Galbraith <psg@debian.org> -;; - checkdoc clean. Added command doc strings. -;; - added commentary from Karl's email about the file. - - -;;; Code: -(defcustom minibuffer-electric-file-name-behavior nil - "*If non-nil, slash and tilde in certain places cause immediate deletion. -These are the same places where this behavior would occur later on anyway, -in `substitute-in-file-name'." - :type 'boolean - :require 'minibuf-electric - :group 'minibuffer) - -;;; originally by Stig@hackvan.com, taken from XEmacs 21.4 -;;; -(defun minibuffer-electric-separator () - "Insert / separator, but clear line first if typed twice in a row." - (interactive) - (let ((c last-command-char)) - (and minibuffer-completing-file-name ; added for GNU Emacs - minibuffer-electric-file-name-behavior - (eq c directory-sep-char) - (eq c (char-before (point))) - (not (save-excursion ;; ange-ftp, tramp - (goto-char (minibuffer-prompt-end)) - (and (looking-at "/.+:~?[^/]*/.+") - (re-search-forward "/.+:~?[^/]*" nil t) - (progn - (delete-region (point) (point-max)) - t)))) - (not (save-excursion - (goto-char (minibuffer-prompt-end)) - (and (looking-at ".+://[^/]*/.+") - (re-search-forward ".+:/" nil t) - (progn - (delete-region (point) (point-max)) - t)))) - ;; permit `//hostname/path/to/file' - (not (eq (point) (1+ (minibuffer-prompt-end)))) - ;; permit `http://url/goes/here' - (or (not (eq ?: (char-after (- (point) 2)))) - (eq ?/ (char-after (minibuffer-prompt-end)))) - (delete-region (minibuffer-prompt-end) (point))) - (insert c))) - -(defun minibuffer-electric-tilde () - "Insert ~ but clear line first if twice not in logical place." - (interactive) - (and minibuffer-completing-file-name ; Added for GNU Emacs - minibuffer-electric-file-name-behavior - (eq directory-sep-char (char-before (point))) - ;; permit URL's with //, for e.g. http://hostname/~user - (not (save-excursion (search-backward "//" (minibuffer-prompt-end) t))) - (delete-region (minibuffer-prompt-end) (point))) - (insert ?~)) - - -;;; This is really not quite right, but I don't know how to do the -;;; right thing yet. What's the matter is that these keys should -;;; really only be bound when the minibuffer is reading a file name. -;;; I'm afraid that these key maps may be too general and might be the -;;; ones used when reading other things. If they really are used only -;;; for reading file names, then I think they are mis-named, and -;;; should be named more specifically. -;;; -;;; For now, it works for me with `find-file', `find-alternate-file', -;;; and `write-file', which all seem to use -;;; `minibuffer-local-completion-map'. The `insert-file' defun uses -;;; the `minibuffer-local-must-match-map'. - -(define-key minibuffer-local-completion-map - (char-to-string directory-sep-char) - #'minibuffer-electric-separator) - -(define-key minibuffer-local-must-match-map - (char-to-string directory-sep-char) - #'minibuffer-electric-separator) - -(define-key minibuffer-local-completion-map "~" #'minibuffer-electric-tilde) -(define-key minibuffer-local-must-match-map "~" #'minibuffer-electric-tilde) - -(provide 'minibuf-electric) - -(provide 'minibuf-electric) - -;;; minibuf-electric.el ends here diff --git a/elisp/emacs-goodies-el/minibuffer-complete-cycle.el b/elisp/emacs-goodies-el/minibuffer-complete-cycle.el deleted file mode 100644 index 1626d19..0000000 --- a/elisp/emacs-goodies-el/minibuffer-complete-cycle.el +++ /dev/null @@ -1,266 +0,0 @@ -;;; minibuffer-complete-cycle.el --- Cycle through the *Completions* buffer - -;; Copyright © 1997,1998,2000,2003,2006 Kevin Rodgers -;; Copyright © 2013 Akinori MUSHA - -;; Author: Akinori MUSHA <knu@iDaemons.org> -;; Kevin Rodgers <ihs_4664@yahoo.com> -;; Maintainer: Akinori MUSHA <knu@iDaemons.org> -;; URL: https://github.com/knu/minibuffer-complete-cycle -;; Created: 15 Oct 1997 -;; Version: 1.25.20130814 -;; Keywords: completion -;; X-Original-Version: $Revision: 1.5 $ -;; X-Original-RCS: $Id: minibuffer-complete-cycle.el,v 1.5 2016/11/06 19:31:23 psg Exp $ - -;; This program 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 of -;; the License, or (at your option) any later version. - -;; This program 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 this program; if not, write to the Free -;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, -;; MA 02111-1307 USA - -;;; Commentary: - -;; The `minibuffer-complete' command, bound by default to TAB in the -;; minibuffer completion keymaps, displays the list of possible -;; completions when no additional characters can be completed. -;; Subsequent invocations of this command cause the window displaying -;; the *Completions* buffer to scroll, if necessary. -;; -;; This library advises the `minibuffer-complete' command so that -;; subsequent invocations instead select each of the possible -;; completions in turn, inserting it into the minibuffer and -;; highlighting it in the *Completions* buffer. As before, the window -;; displaying the possible completions is scrolled if necessary. This -;; feature is enabled by loading this file and setting the -;; `minibuffer-complete-cycle' option to t with `M-x customize-variable' -;; or `M-x set-variable'; it is disabled by unsetting the option (to -;; nil). Besides t, the special value `auto' enables the feature and -;; also causes the first completion to be selected immediately. -;; -;; You can also customize the `minibuffer-complete-cycle' face, which is -;; used to highlight the selected completion, with `M-x customize-face' -;; or any of the `M-x set-face-' commands. - -;; The technique of deleting the minibuffer contents, then (for file -;; name completion) inserting the directory component of the initial -;; input, and then inserting the completion string itself is based on -;; cycle-mini.el (1.03) by Joe Reiss <jreiss@vt.edu>. -;; -;; Emacs 24 introduced `completion-cycle-threshold' which achieves a -;; similar goal. This extension allows you to see the completion -;; window while cycling, and to cycle backward with <backtab>. - -;;; Change log: -;; -;; Version 1.25.20130814 2013-08-14 Akinori MUSHA -;; Support for Emacs 24. -;; Fix a bug with partial completion. -;; Fix a bug when the minibuffer is like "~/dir1/~/". -;; Bind <backtab> to minibuffer-complete-backward rather than M-TAB. -;; Make the slash key settle the curent path component if appropriate. - -;;; Code: - -;; Package interface: -(provide 'minibuffer-complete-cycle) - -(require 'custom) ; defgroup, defcustom, defface - -(eval-when-compile (require 'cl)) - -;; User options: - -(defgroup minibuffer-complete-cycle nil - "Cycle through the *Completions* buffer." - :group 'completion) - -(defcustom minibuffer-complete-cycle nil - "*If non-nil, `minibuffer-complete' cycles through the possible completions. -If `auto', `minibuffer-complete' selects the first completion immediately." - :type '(choice (const t) (const auto) (const nil)) - :group 'minibuffer-complete-cycle - :require 'minibuffer-complete-cycle) - -(defface minibuffer-complete-cycle - '((t (:inherit secondary-selection))) - "Face for highlighting the selected completion in the *Completions* buffer." - :group 'minibuffer-complete-cycle) - -;; Internal variables: -(defvar mcc-completion-begin nil ; point in the *Completions* buffer - "If non-nil, the beginning of the selected completion.") -(defvar mcc-completion-end nil ; point in the *Completions* buffer - "If non-nil, the end of the selected completion.") - -(defvar mcc-completion-property - 'mouse-face - "The text property used to identify completions.") - -(defvar mcc-overlay - (let ((overlay (make-overlay 1 1))) - (overlay-put overlay 'face 'minibuffer-complete-cycle) - overlay) - "If non-nil, the overlay used to highlight the *Completions* buffer.") - - -;; Commands: - -(defadvice minibuffer-complete (around cycle (&optional count) activate compile) - "If the `minibuffer-complete-cycle' option is set, then instead of -just scrolling the window of possible completions, insert each one in -turn in the minibuffer and highlight it in the *Completions* buffer with -the `minibuffer-complete-cycle' face. - -Prefix arg means select the COUNT'th next completion. -To cycle to previous completions, type <backtab>." -;; `\\<minibuffer-local-completion-map>\\[minibuffer-complete-backward]' - (interactive "p") - (if (and minibuffer-complete-cycle - (not (eq this-command 'completion-at-point)) ; Emacs 24 - ;; See Fminibuffer_complete: - (or (eq last-command this-command) - (eq last-command 'completion-at-point) ; Emacs 24 - (and (eq minibuffer-complete-cycle 'auto) - (progn - (setq mcc-completion-begin nil - mcc-completion-end nil) - ad-do-it))) - minibuffer-scroll-window - (window-live-p minibuffer-scroll-window)) - (let ((lastlen (and mcc-completion-begin mcc-completion-end - (- mcc-completion-end mcc-completion-begin))) - (completion (mcc-completion-string count))) - (cond (lastlen - ;; Delete the part last completed - (delete-region (- (point-max) lastlen) - (point-max))) - (minibuffer-completing-file-name - ;; Skip the last component - (or (re-search-backward "/" (minibuffer-prompt-end) t) - (goto-char (minibuffer-prompt-end))) - ;; Skip components to be completed - (let ((str (directory-file-name completion)) - (start 0)) - (while (string-match "/" str start) - (setq start (match-end 0)) - (or (re-search-backward "/" (minibuffer-prompt-end) t) - (goto-char (minibuffer-prompt-end)))) - (if (looking-at "/") (forward-char 1)) - (delete-region (point) (point-max)))) - (t (delete-region (minibuffer-prompt-end) - (point-max)))) - (insert completion) - (mcc-display-completion (< count 0))) - ;; Reset the mcc variables and proceed normally: - (setq mcc-completion-begin nil - mcc-completion-end nil) - ad-do-it)) - -(defun minibuffer-complete-backward (&optional count) - "Just like `minibuffer-complete', but cycle to the previous completion. -Prefix arg means select the COUNT'th previous completion." - (interactive "p") - (setq this-command 'minibuffer-complete) - (minibuffer-complete (- count))) - -(defun minibuffer-complete-slash (&optional arg) - "Insert a slash ARG times, or settle the current path component if complete-cycling is at a directory name." - (interactive "p") - (or - (and (= arg 1) - (eq last-command 'minibuffer-complete) - minibuffer-completing-file-name - (eolp) - (char-equal (preceding-char) ?/)) - (self-insert-command arg))) - -;; Functions: - -;;;###autoload -(defun mcc-define-keys () ; mcc-minor-mode & -keymap - "Define extra key bindings in the local keymap. -This has no effect unless the `minibuffer-complete-cycle' option is set." - (when minibuffer-complete-cycle - (dolist (binding - '(("<backtab>" . minibuffer-complete-backward) - ("/" . minibuffer-complete-slash) - )) - (let ((key (kbd (car binding))) - (func (cdr binding))) - (and (null (local-key-binding key)) - (local-set-key key func)))))) - -;;;###autoload -(add-hook 'minibuffer-setup-hook 'mcc-define-keys) - -(defun mcc-completion-string (n) - "Return the Nth next completion. -If N is negative, return the Nth previous completion." - (let ((completion-buffer (window-buffer minibuffer-scroll-window))) - ;; Verify the buffer and window configuration: - (or (eq completion-buffer (get-buffer "*Completions*")) - (error "minibuffer-scroll-window isn't displaying \ -the *Completions* buffer")) - (save-excursion - (set-buffer completion-buffer) - ;; Find the beginning and end of the completion: - (if (< n 0) - (while (< n 0) - (setq mcc-completion-end - (or (and mcc-completion-begin - (previous-single-property-change mcc-completion-begin - mcc-completion-property)) - (point-max))) - (setq mcc-completion-begin - (previous-single-property-change mcc-completion-end - mcc-completion-property - nil (point-min))) - (setq n (1+ n))) - (while (> n 0) - (setq mcc-completion-begin - (next-single-property-change (if (and mcc-completion-end - (< mcc-completion-end - (point-max))) - mcc-completion-end - (point-min)) - mcc-completion-property)) - (setq mcc-completion-end - (next-single-property-change mcc-completion-begin - mcc-completion-property - nil (point-max))) - (setq n (1- n)))) - (buffer-substring-no-properties mcc-completion-begin mcc-completion-end)))) - -(defun mcc-display-completion (&optional backward) - "Highlight the current completion and scroll the *Completions* buffer \ -if necessary. -Scroll up by default, but scroll down if BACKWARD is non-nil." - (let ((completion-buffer (window-buffer minibuffer-scroll-window)) - (minibuffer-window (selected-window))) - (if mcc-overlay - (move-overlay mcc-overlay mcc-completion-begin mcc-completion-end - completion-buffer)) - (unwind-protect - (progn - (select-window minibuffer-scroll-window) ; completion-buffer - (or (pos-visible-in-window-p mcc-completion-begin) - (if backward - (if (= (window-start) (point-min)) - (set-window-point (selected-window) (point-max)) - (scroll-down)) - (if (= (window-end) (point-max)) - (set-window-point (selected-window) (point-min)) - (scroll-up))))) - (select-window minibuffer-window)))) - -;;; minibuffer-complete-cycle.el ends here diff --git a/elisp/emacs-goodies-el/miniedit.el b/elisp/emacs-goodies-el/miniedit.el index 46f4bab..46f4bab 100755..100644 --- a/elisp/emacs-goodies-el/miniedit.el +++ b/elisp/emacs-goodies-el/miniedit.el diff --git a/elisp/emacs-goodies-el/mutt-alias.el b/elisp/emacs-goodies-el/mutt-alias.el index c3803b1..c3803b1 100755..100644 --- a/elisp/emacs-goodies-el/mutt-alias.el +++ b/elisp/emacs-goodies-el/mutt-alias.el diff --git a/elisp/emacs-goodies-el/muttrc-mode.el b/elisp/emacs-goodies-el/muttrc-mode.el index 9f249f7..9f249f7 100755..100644 --- a/elisp/emacs-goodies-el/muttrc-mode.el +++ b/elisp/emacs-goodies-el/muttrc-mode.el diff --git a/elisp/emacs-goodies-el/nuke-trailing-whitespace.el b/elisp/emacs-goodies-el/nuke-trailing-whitespace.el deleted file mode 100755 index fd33ab2..0000000 --- a/elisp/emacs-goodies-el/nuke-trailing-whitespace.el +++ /dev/null @@ -1,163 +0,0 @@ -;;; whitespace.el --- strip trailing whitespace from buffers - -;; Copyright (C) 1995, 1996, 1997, 2000 Noah S. Friedman - -;; Author: Noah Friedman <friedman@splode.com> -;; Maintainer: friedman@splode.com -;; Keywords: extensions -;; Status: Works in Emacs 19 and XEmacs. - -;; $Id: nuke-trailing-whitespace.el,v 1.2 2009-09-04 02:24:05 psg Exp $ - -;; This program 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. -;; -;; This program 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 this program; if not, you can either send email to this -;; program's maintainer or write to: The Free Software Foundation, -;; Inc.; 51 Franklin Street, Fifth Floor; Boston, MA 02110-1301, USA. - -;;; Commentary: - -;; You may wish to do the following in your .emacs: -;; -;; (autoload 'nuke-trailing-whitespace "whitespace" nil t) -;; (add-hook 'mail-send-hook 'nuke-trailing-whitespace) -;; (add-hook 'write-file-hooks 'nuke-trailing-whitespace) - -;;; Code: - -(defvar nuke-trailing-whitespace-p 'whitespace-check-mode - "*Specify when stripping whitespace should be done. -This variable affects how the function `nuke-trailing-whitespace' behaves. -If `t', unreservedly strip trailing whitespace, including excess newlines. -If `nil', do nothing. -If a symbol \(not bound to a function\), query for each instance. - -If a function or name of a function, call it to decide what to do. -This function is called once and should return `t', `nil', or the symbol -`query' to decide what to do. - -This variable is made buffer-local when set in any fashion.") -(make-variable-buffer-local 'nuke-trailing-whitespace-p) - -;; The regexp "\\s-+$" is too general, since form feeds (\n), carriage -;; returns (\r), and form feeds/page breaks (C-l) count as whitespace in -;; some syntaxes even though they serve a functional purpose in the file. -(defconst whitespace-regexp "[ \t]+$" - "Regular expression which matches trailing whitespace.") - -;; Match two or more trailing newlines at the end of the buffer; all but -;; the first newline will be deleted. -(defconst whitespace-eob-newline-regexp "\n\n+\\'" - "Regular expression which matches newlines at the end of the buffer.") - -(defvar nuke-trailing-whitespace-always-major-modes - '(ada-mode - c++-mode - c-mode - change-log-mode - cperl-mode - emacs-lisp-mode - fortran-mode - latex-mode - lisp-interaction-mode - lisp-mode - makefile-mode - nroff-mode - perl-mode - plain-tex-mode - prolog-mode - scheme-mode - sgml-mode - tcl-mode - slitex-mode - sml-mode - texinfo-mode) - "*Major modes for which `whitespace-check-mode' will return `t'. -These are major modes for which `nuke-trailing-whitespace' should -strip all trailing whitespace and excess newlines at the end of the buffer -without asking.") - -(defvar nuke-trailing-whitespace-never-major-modes - '(mail-mode - rmail-mode - vm-mode - vm-summary-mode) - "*Major modes for which `whitespace-check-mode' will return `nil'. -These are major modes for which `nuke-trailing-whitespace' should -never strip trailing whitespace automatically.") - - -;;;###autoload -(defun nuke-trailing-whitespace () - "Nuke all trailing whitespace in the buffer. -Whitespace in this case is just spaces or tabs. -This is a useful function to put on write-file-hooks. - -Unless called interactively, this function uses -`nuke-trailing-whitespace-p' to determine how to behave. -However, even if this variable is `t', this function will query for -replacement if the buffer is read-only." - (interactive) - (cond ((interactive-p) - (call-interactively 'whitespace-do-nuke-whitespace)) - (t - (let ((flag nuke-trailing-whitespace-p)) - (and nuke-trailing-whitespace-p - (symbolp nuke-trailing-whitespace-p) - (fboundp nuke-trailing-whitespace-p) - (setq flag (funcall nuke-trailing-whitespace-p))) - - (and flag - (whitespace-do-nuke-whitespace flag))))) - ;; always return nil, in case this is on write-file-hooks. - nil) - -(defun whitespace-do-nuke-whitespace (&optional flag) - (interactive) - (let ((buffer-orig-read-only buffer-read-only) - (buffer-read-only nil)) - (save-excursion - (save-restriction - (save-match-data - (widen) - (goto-char (point-min)) - (cond - ((or (and (eq flag t) - (not buffer-orig-read-only)) - (interactive-p)) - (while (re-search-forward whitespace-regexp (point-max) t) - (delete-region (match-beginning 0) (match-end 0))) - (goto-char (point-min)) - (and (re-search-forward whitespace-eob-newline-regexp nil t) - (delete-region (1+ (match-beginning 0)) (match-end 0)))) - (t - (query-replace-regexp whitespace-regexp "") - (goto-char (point-min)) - (and (re-search-forward whitespace-eob-newline-regexp nil t) - (save-match-data - (y-or-n-p - "Delete excess trailing newlines at end of buffer? ")) - (delete-region (1+ (match-beginning 0)) (match-end 0)))))))))) - -(defun whitespace-check-mode (&optional mode) - (or mode (setq mode major-mode)) - (cond ((memq mode nuke-trailing-whitespace-always-major-modes) t) - ((memq mode nuke-trailing-whitespace-never-major-modes) nil) - ;; Only query for visible buffers; invisible buffers are probably - ;; managed by programs (e.g. w3 history list) and a query for them - ;; is confusing. - ((get-buffer-window (current-buffer) t) 'query) - (t nil))) - -(provide 'whitespace) - -;;; whitespace.el ends here. diff --git a/elisp/emacs-goodies-el/obfusurl.el b/elisp/emacs-goodies-el/obfusurl.el deleted file mode 100755 index f63b31c..0000000 --- a/elisp/emacs-goodies-el/obfusurl.el +++ /dev/null @@ -1,114 +0,0 @@ -;;; obfusurl.el --- Obfuscate URLs so they aren't spoilers -;; Copyright 2001-2008 by Dave Pearson <davep@davep.org> -;; $Revision: 1.3 $ - -;; obfusurl.el is free software distributed under the terms of the GNU -;; General Public Licence, version 2 or (at your option) any later version. -;; For details see the file COPYING. - -;;; Commentary: -;; -;; obfusurl.el provides `obfuscate-url', a command that will obfuscate an -;; URL under the cursor. This might be useful if you are writing out an URL -;; for someone but the URL itself might spoil the surprise. -;; -;; For example, this: -;; -;; <URL:http://www.davep.org/emacs/> -;; -;; is turned into this: -;; -;; <URL:http://www.davep.org/%65%6d%61%63%73/> -;; -;; The latest obfusurl.el is always available from: -;; -;; <URL:http://www.davep.org/emacs/obfusurl.el> -;; <URL:http://www.davep.org/%65%6d%61%63%73/%6f%62%66%75%73%75%72%6c%2e%65%6c> - -;;; THANKS: -;; -;; Andy Sawyer <andys@morebhp.com> for initially pointing out that URLs with -;; percent escapes already in them would get broken. -;; -;; Kevin Rodgers <kevinr@ihs.com> for suggesting a method of fixing the -;; above. -;; -;; Toby Speight <streapadair@gmx.net> for pointing out that I needed to -;; cater for reserved characters. - -;;; INSTALLATION: -;; -;; o Drop obfusurl.el somwehere into your `load-path'. Try your site-lisp -;; directory for example (you might also want to byte-compile the file). -;; -;; o Add the following autoload statement to your ~/.emacs file: -;; -;; (autoload 'obfuscate-url "obfusurl" "Obfuscate URL under point" t) - -;;; Code: - -;; Things we need: - -(eval-when-compile - (require 'cl)) -(require 'thingatpt) - -;; Constants. - -(defconst obfuscate-url-reserved-chars '(?\; ?/ ?? ?: ?@ ?& ?= ?+ ?$ ?,) - "Characters reserved by RFC 2396.") - -;; Main code. - -(defun obfuscate-url-hexify-string (string) - "Return STRING as percent-escaped hex values. - -Existing percent-escapes and reserved characters (as defined in RFC 2396) in -the text are preserved." - (flet ((hexify-string (string) - (with-output-to-string - (mapc (lambda (c) - (princ (format - (if (member c obfuscate-url-reserved-chars) - "%c" - "%%%02x") - c))) string)))) - (let ((case-fold-search t)) - (with-output-to-string - (loop for i = 0 then (match-end 0) - while (string-match "%[0-9a-f][0-9a-f]" string i) - do (princ - (concat (hexify-string (substring string i (match-beginning 0))) - (match-string 0 string))) - finally (princ (hexify-string (substring string i)))))))) - -(defun obfuscate-url-hexify-url (url) - "Return URL as a percent-escaped URL." - (let ((trailing-slash (string-match "/$" url)) - (split (split-string url "/"))) - (with-output-to-string - (princ (format "%s//%s" (nth 0 split) (nth 2 split))) - (loop for part in (nthcdr 3 split) - unless (string= part "") ; Because of XEmacs' `split-string'. - do (princ (concat "/" (obfuscate-url-hexify-string part))) - finally (when trailing-slash (princ "/")))))) - -;;;###autoload -(defun obfuscate-url () - "Obfuscate an URL under `point'. - -This might be useful if you're writing out an URL for someone but the URL -itself is a spoiler. The URL will still work but it won't be readable (by -most mortals anyway)." - (interactive "*") - (let ((url (thing-at-point 'url))) - (if url - (let ((bounds (bounds-of-thing-at-point 'url))) - (setf (point) (car bounds)) - (delete-region (car bounds) (cdr bounds)) - (insert (obfuscate-url-hexify-url url))) - (error "I can't see an URL here")))) - -(provide 'obfusurl) - -;;; obfusurl.el ends here diff --git a/elisp/emacs-goodies-el/pack-windows.el b/elisp/emacs-goodies-el/pack-windows.el index 4351944..4351944 100755..100644 --- a/elisp/emacs-goodies-el/pack-windows.el +++ b/elisp/emacs-goodies-el/pack-windows.el diff --git a/elisp/emacs-goodies-el/perldoc.el b/elisp/emacs-goodies-el/perldoc.el index 194a4ee..194a4ee 100755..100644 --- a/elisp/emacs-goodies-el/perldoc.el +++ b/elisp/emacs-goodies-el/perldoc.el diff --git a/elisp/emacs-goodies-el/pod-mode.el b/elisp/emacs-goodies-el/pod-mode.el deleted file mode 100755 index 1617a32..0000000 --- a/elisp/emacs-goodies-el/pod-mode.el +++ /dev/null @@ -1,706 +0,0 @@ -;;; pod-mode.el --- Major mode for editing .pod-files - -;;; POD is the Plain Old Documentation format of Perl. - -;;; Copyright 2003-2010 Steffen Schwigon - -;;; Author: Steffen Schwigon <ss5@renormalist.net> -;;; -;;; Keywords: perl pod -;;; X-URL: http://search.cpan.org/~schwigon/pod-mode/ - -;;; This program 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. -;;; -;;; This program 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 this program; if not, write to the Free Software -;;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, -;;; MA 02110-1301, USA. - -;;; This code is supposed to work on all platforms on both GNU Emacs -;;; and XEmacs at least as of version 21.2.1 and 21.4, -;;; respectively. Please speak up if it doesn't on your platform or -;;; recent-ish version of an Emacs of your choice - -;;; Commentary: - -;;; This mode is built with help of the -;;; "Emacs language mode creation tutorial" at -;;; -;;; http://two-wugs.net/emacs/mode-tutorial.html -;;; -;;; which disapeared from the net and is now hosted at -;;; -;;; http://renormalist.net/Renormalist/EmacsLanguageModeCreationTutorial -;;; - -;;; Usage: - -;;; Put this file into your load-path and the following into your ~/.emacs: -;;; -;;; (require 'pod-mode) -;;; -;;; -;;; To associate pod-mode with .pod files add the following to your ~/.emacs -;;; -;;; (add-to-list 'auto-mode-alist '("\\.pod$" . pod-mode)) -;;; -;;; -;;; To automatically turn on font-lock-mode add the following to your ~/.emacs -;;; -;;; (add-hook 'pod-mode-hook 'font-lock-mode) -;;; -;;; -;;; In addition to the standard POD commands, custom commands as -;;; defined by a Pod::Weaver configuration are supported. However, for -;;; those to work, eproject.el as available at -;;; http://github.com/jrockway/eproject is required. -;;; -;;; Make sure to require eproject.el or create an autoload for -;;; eproject-maybe-turn-on if you expect custom commands to work. -;;; -;;; -;;; When automatically inserting hyperlink formatting codes to modules -;;; or sections within modules, autocompletion for module names will -;;; be provided if perldoc.el, as available at -;;; git://gaffer.ptitcanardnoir.org/perldoc-el.git, is present. -;;; - -;;; Code: - -(require 'cl) - -(defgroup pod-mode nil - "Mode for editing POD files" - :group 'faces) - -(defgroup pod-mode-faces nil - "Faces for highlighting POD constructs" - :prefix "pod-mode-" - :group 'pod-mode) - -(defface pod-mode-command-face - '((((class grayscale) (background light)) (:foreground "LightGray" :weight bold)) - (((class grayscale) (background dark)) (:foreground "DimGray" :weight bold)) - (((class color) (min-colors 88) (background light)) (:foreground "Purple")) - (((class color) (min-colors 88) (background dark)) (:foreground "Cyan1")) - (((class color) (min-colors 16) (background light)) (:foreground "Purple")) - (((class color) (min-colors 16) (background dark)) (:foreground "Cyan")) - (((class color) (min-colors 8)) (:foreground "cyan" :weight bold)) - (t (:weight bold))) - "Face used to highlight POD commands" - :group 'pod-mode-faces) - -(defface pod-mode-head-face - '((t (:inherit pod-mode-command-face))) - "Face used to highlight =head commands" - :group 'pod-mode-faces) - -(defface pod-mode-command-text-face - '((((class grayscale) (background light)) - (:foreground "DimGray" :weight bold :slant italic)) - (((class grayscale) (background dark)) - (:foreground "LightGray" :weight bold :slant italic)) - (((class color) (min-colors 88) (background light)) - (:foreground "Firebrick")) - (((class color) (min-colors 88) (background dark)) - (:foreground "chocolate1")) - (((class color) (min-colors 16) (background light)) - (:foreground "red")) - (((class color) (min-colors 16) (background dark)) - (:foreground "red1")) - (((class color) (min-colors 8) (background light)) - (:foreground "red")) - (((class color) (min-colors 8) (background dark)) - ) - (t (:weight bold :slant italic))) - "Face used to highlight text after POD commands" - :group 'pod-mode-faces) - -(defface pod-mode-verbatim-face - '((((class grayscale) (background light)) (:foreground "Gray90" :weight bold)) - (((class grayscale) (background dark)) (:foreground "DimGray" :weight bold)) - (((class color) (min-colors 88) (background light)) (:foreground "ForestGreen")) - (((class color) (min-colors 88) (background dark)) (:foreground "PaleGreen")) - (((class color) (min-colors 16) (background light)) (:foreground "ForestGreen")) - (((class color) (min-colors 16) (background dark)) (:foreground "PaleGreen")) - (((class color) (min-colors 8)) (:foreground "green")) - (t (:weight bold :underline t))) - "Face used to highlight verbatim paragraphs in POD" - :group 'pod-mode-faces) - -(defface pod-mode-formatting-code-character-face - '((((class grayscale) (background light)) - (:foreground "Gray90" :weight bold :slant italic)) - (((class grayscale) (background dark)) - (:foreground "DimGray" :weight bold :slant italic)) - (((class color) (min-colors 88) (background light)) (:foreground "sienna")) - (((class color) (min-colors 88) (background dark)) (:foreground "LightGoldenrod")) - (((class color) (min-colors 16) (background light)) (:foreground "DarkGoldenrod")) - (((class color) (min-colors 16) (background dark)) (:foreground "LightGoldenrod")) - (((class color) (min-colors 8)) (:foreground "yellow" :weight light)) - (t (:weight bold :slant italic))) - "Face used to highlight formatting codes in POD" - :group 'pod-mode-faces) - -(defface pod-mode-formatting-code-face - '((((class grayscale) (background light)) - (:foreground "LightGray" :weight bold :underline t)) - (((class grayscale) (background dark)) - (:foreground "Gray50" :weight bold :underline t)) - (((class color) (min-colors 88) (background light)) (:foreground "dark cyan")) - (((class color) (min-colors 88) (background dark)) (:foreground "Aquamarine")) - (((class color) (min-colors 16) (background light)) (:foreground "CadetBlue")) - (((class color) (min-colors 16) (background dark)) (:foreground "Aquamarine")) - (((class color) (min-colors 8)) (:foreground "magenta")) - (t (:weight bold :underline t))) - "Face used to highlight text within formatting codes in POD" - :group 'pod-mode-faces) - -(defface pod-mode-formatting-code-i-face - '((t (:inherit pod-mode-formatting-code-face :slant italic))) - "Face used to highlight I<> formatting codes in POD" - :group 'pod-mode-faces) - -(defface pod-mode-formatting-code-b-face - '((t (:inherit pod-mode-formatting-code-face :weight bold))) - "Face used to highlight B<> formatting codes in POD" - :group 'pod-mode-faces) - -(defface pod-mode-alternative-formatting-code-face - '((((class color) (min-colors 88) (background light)) (:foreground "Blue1")) - (((class color) (min-colors 88) (background dark)) (:foreground "LightSkyBlue")) - (((class color) (min-colors 16) (background light)) (:foreground "Blue")) - (((class color) (min-colors 16) (background dark)) (:foreground "LightSkyBlue")) - (((class color) (min-colors 8)) (:foreground "blue" :weight bold)) - (t (:inverse-video t :weight bold))) - "Alternative face used to highlight formatting codes in POD. -This is used for E<> escapes and for the link target in L<> -escapes." - :group 'pod-mode-faces) - -(defface pod-mode-string-face - '((((class grayscale) (background light)) (:foreground "DimGray" :slant italic)) - (((class grayscale) (background dark)) (:foreground "LightGray" :slant italic)) - (((class color) (min-colors 88) (background light)) (:foreground "VioletRed4")) - (((class color) (min-colors 88) (background dark)) (:foreground "LightSalmon")) - (((class color) (min-colors 16) (background light)) (:foreground "RosyBrown")) - (((class color) (min-colors 16) (background dark)) (:foreground "LightSalmon")) - (((class color) (min-colors 8)) (:foreground "green")) - (t (:slant italic))) - "Face used to highlight quoted strings in POD" - :group 'pod-mode-faces) - -(defvar pod-mode-hook nil - "List of functions to be called when activating `pod-mode'.") - -;;; Version: 1.01 -(defvar pod-version "1.01" - "Version of POD mode.") - -(let* ((head-sizes '(1.9 1.7 1.5 1.3)) - (heads (loop for i from 1 to (length head-sizes) collect - (cons i (nth (- i 1) head-sizes))))) - (defconst pod-font-lock-keywords-1 - (append - (loop for (n . s) in heads collect - (let ((head-face-name (intern (format "pod-mode-head%d-face" n))) - (text-face-name (intern (format "pod-mode-head%d-text-face" n)))) - (eval `(defface ,head-face-name - '((t (:inherit pod-mode-head-face :height ,s))) - ,(format "Face used to highlight head%d commands" n) - :group 'pod-mode-faces)) - (eval `(defface ,text-face-name - '((t (:inherit pod-mode-command-text-face :height ,s))) - ,(format "Face used to hightlight text in head%d commands" n) - :group 'pod-mode-faces)) - `(,(format "^\\(=head%d\\)\\(.*\\)" n) - (1 (quote ,head-face-name)) - (2 (quote ,text-face-name))))) - `((,(format "^\\(=%s\\)\\(.*\\)" - (regexp-opt '("item" "over" "back" "cut" "pod" - "for" "begin" "end" "encoding"))) - (1 'pod-mode-command-face) - (2 'pod-mode-command-text-face)))) - "Minimal highlighting expressions for POD mode.")) - -(defconst pod-font-lock-keywords-2 - (append pod-font-lock-keywords-1 '()) - "Additional Keywords to highlight in POD mode.") - -(defun pod-matcher-for-code (code body) - "Create a matcher function for a given POD formatting CODE. -Will return a quoted lambda as expected by `font-lock-keywords' -as MATCHER. - -When executing the lambda, it will match a POD formatting code -introduced with the character CODE and as described in perlpod. - -BODY is expected to be a quoted lambda. It will be executed -after a successful match of a well-balanced formatting code. -It'll get two arguments, the start and end position of the text -contained in the formatting code. It should return a list of -positions suitable to use as match data for later highlighting by -`font-lock-keywords'." - `(lambda (limit) - (when (re-search-forward - ,(concat - code - "\\(?:\\(?:\\(<\\)[^<]\\)\\|\\(?:\\(<\\{2,\\}\\)\s\\)\\)") - limit t) - (let ((beg (or (match-end 1) - (match-end 2))) - (n-lt (length (or (match-string-no-properties 1) - (match-string-no-properties 2))))) - (goto-char (- (point) 1)) - (when (re-search-forward - (concat (when (> n-lt 1) "\s") - "\\(" - (apply 'concat (loop for i from 1 to n-lt collect ">")) - "\\)") - limit t) - (let* ((end (match-beginning 1)) - (match-data (funcall ,body beg end))) - (when (match-data) - (store-match-data (append - (list (- beg n-lt 1) beg) - match-data - (list end (+ end n-lt)))) - t))))))) - -(defun pod-keyword-for-simple-code (code face) - "Build a `font-lock-keywords' keyword for a POD formatting code. -CODE is the character introducing the formatting code to be -matched. FACE is the face that should be used to map the text -within the formattign code. - -In addition to matching the code's content with FACE, the -formatting code itself will be highlighted using -`pod-mode-formatting-code-character-face'." - `(,(pod-matcher-for-code code '(lambda (beg end) - (list beg end))) - (0 'pod-mode-formatting-code-character-face prepend) - (1 ',face append) - (2 'pod-mode-formatting-code-character-face prepend))) - -(defconst pod-font-lock-keywords-3 - (append pod-font-lock-keywords-2 - (loop for code in '("C" "F" "X" "Z" "S") - collect (pod-keyword-for-simple-code - code 'pod-mode-formatting-code-face)) - (list - (pod-keyword-for-simple-code - "E" 'pod-mode-alternative-formatting-code-face) - (pod-keyword-for-simple-code "I" 'pod-mode-formatting-code-i-face) - (pod-keyword-for-simple-code "B" 'pod-mode-formatting-code-b-face) - `(,(pod-matcher-for-code - "L" (lambda (beg end) - (goto-char beg) - (if (re-search-forward "\\([^|]\\)|" end t) - (list beg (match-end 1) - (+ (match-end 1) 1) end) - (list 0 0 beg end)))) - (0 'pod-mode-formatting-code-character-face prepend) - (1 'pod-mode-formatting-code-face append) - (2 'pod-mode-alternative-formatting-code-face append) - (3 'pod-mode-formatting-code-character-face prepend)) - '("\"\\([^\"]+\\)\"" - (0 'pod-mode-string-face)) - '("^[ \t]+\\(.*\\)$" 1 'pod-mode-verbatim-face prepend))) - "Balls-out highlighting in POD mode.") - -(defvar pod-font-lock-keywords pod-font-lock-keywords-3 - "Default highlighting expressions for POD mode.") - -(defvar pod-weaver-section-keywords nil - "List of custom Pod::Weaver keywords describing sections. -This is an alist, mapping strings with pod commands to a number -describing their level within the document.") -(make-local-variable 'pod-weaver-section-keywords) - -(defun pod-linkable-sections-for-buffer (buffer &optional section-keywords) - "Extract POD sections from BUFFER. -Returns a list of POD section names with BUFFER. By default only -=head commands are looked for. The optional second argument -SECTION-KEYWORDS may be used to also extract section names from -additional pod commands." - (with-current-buffer buffer - (save-excursion - (save-match-data - (goto-char (point-min)) - (loop while (re-search-forward - (format "^=%s\s+\\(.*\\)$" - (regexp-opt - (append - (loop for i from 1 to 4 - collect (format "head%d" i)) - '("item") - section-keywords))) - nil t) - collect (match-string-no-properties 1)))))) - -(defun pod-linkable-sections-for-module (module) - "Extract POD sections from MODULE. -Opens the documentation of an installed perl MODULE and returns a -list of all section names in it. - -`pod-linkable-sections-for-buffer' is used to actually extract -the sections." - (with-current-buffer (get-buffer-create (concat "*POD " module "*")) - (unwind-protect - (progn - (kill-all-local-variables) - (erase-buffer) - (text-mode) - (let ((default-directory "/")) - (call-process "perldoc" nil (current-buffer) nil "-T" "-u" module) - (goto-char (point-min)) - (when (and (> (count-lines (point-min) (point-max)) 1) - (not (re-search-forward - "No documentation found for .*" nil t))) - (pod-linkable-sections-for-buffer (current-buffer))))) - (kill-buffer (current-buffer))))) - -(defun pod-linkable-sections (&optional module) - "Extract POD sections. -Extracts all POD sections from either the current buffer, or, if -MODULE is given, from the POD documentation of an installed -module. - -If MODULE is given, `pod-linkable-sections-for-module' will be -called. Otherwise `pod-linkable-sections-for-buffer' for -`current-buffer', and with all additional POD section keywords as -provided by `pod-weaver-section-keywords'." - (if module - (pod-linkable-sections-for-module module) - (pod-linkable-sections-for-buffer - (current-buffer) - (mapcar (lambda (i) (car i)) - pod-weaver-section-keywords)))) - -(defun pod-linkable-modules (&optional re-cache) - "Find all installed perl modules. -Returns a list of all installed perl modules, as provided by -function `perldoc-modules-alist'. This requires `perldoc' to be -loadable. - -If the optional argument RE-CACHE is non-nil, a possibly cached -version of the module list will be discarded and rebuilt." - (save-current-buffer - (when (ignore-errors (require 'perldoc)) - (when (or re-cache (not perldoc-modules-alist)) - (message "Building completion list of all perl modules...")) - (mapcar (lambda (i) (car i)) (perldoc-modules-alist re-cache))))) - -(defun pod-link (link &optional text) - "Insert a POD hyperlink formatting code. -Inserts a POD L<> formatting code at point. The content of the -code will be LINK. - -If the optional argument TEXT is a string and contains anything -that's not whitespace, it will be used as the link title." - (insert (concat "L<" - (when (and (stringp text) - (string-match-p "[^\s]" text)) - (concat text "|")) - link - ">"))) - -(defun pod-completing-read (prompt choices) - "Use `completing-read' to do a completing read." - (completing-read prompt choices)) - -(defun pod-icompleting-read (prompt choices) - "Use iswitchb to do a completing read." - (let ((iswitchb-make-buflist-hook - (lambda () - (setq iswitchb-temp-buflist choices)))) - (unwind-protect - (progn - (when (not iswitchb-mode) - (add-hook 'minibuffer-setup-hook 'iswitchb-minibuffer-setup)) - (iswitchb-read-buffer prompt)) - (when (not iswitchb-mode) - (remove-hook 'minibuffer-setup-hook 'iswitchb-minibuffer-setup))))) - -(defun pod-ido-completing-read (prompt choices) - "Use ido to do a completing read." - (ido-completing-read prompt choices)) - -(defcustom pod-completing-read-function - #'pod-icompleting-read - "Ask the user to select a single item from a list. -Used by `pod-link-section', `pod-link-module', and -`pod-link-module-section'." - :group 'pod-mode - :type '(radio (function-item - :doc "Use Emacs' standard `completing-read' function." - pod-completing-read) - (function-item :doc "Use iswitchb's completing-read function." - pod-icompleting-read) - (function-item :doc "Use ido's completing-read function." - pod-ido-completing-read) - (function))) - -(defun pod-do-completing-read (&rest args) - "Do a completing read with the configured `pod-completing-read-function'." - (apply pod-completing-read-function args)) - -(defun pod-link-uri (uri &optional text) - "Insert POD hyperlink formatting code for a URL. -Calls `pod-link' with URI and TEXT. - -When called interactively, URI and TEXT will be read from the -minibuffer." - (interactive - (list (read-string "URI: ") - (read-string "Text: "))) - (pod-link uri text)) - -(defun pod-link-section (section &optional text) - "Insert hyperlink formatting code for a POD section. -Insert an L<> formatting code pointing to a section within the -current document. - -When called interactively, SECTION and TEXT will be read using -`pod-do-completing-read'. - -When reading SECTION, `pod-linkable-sections' will be used to -provide completions." - (interactive - (list (pod-do-completing-read "Section: " (pod-linkable-sections)) - (read-string "Text: "))) - (pod-link-module-section "" section text)) - -(defun pod-link-module (module &optional text) - "Insert POD hyperlink formatting code for a module. -Insert an L<> formatting code pointing to a MODULE. - -When called interactively, MODULE and TEXT will be read using -`pod-do-completing-read'. - -When reading MODULE, `pod-linkable-modules' will be used to -provide completions." - (interactive - (list (pod-do-completing-read "Module: " - (pod-linkable-modules current-prefix-arg)) - (read-string "Text: "))) - (pod-link module text)) - -(defun pod-link-module-section (module section &optional text) - "Insert POD hyperlink formatting code for a section in a module. -Insert an L<> formatting code pointing to a part of MODULE -documentation as described by SECTION. - -When called interactive, MODULE, SECTION, and TEXT will be read -using `pod-do-completing-read'. - -When reading MODULE and SECTION, `pod-linkable-modules' and -`pod-linkable-sections', respectively, will be used to provide -completions." - (interactive - (let ((module (pod-do-completing-read - "Module: " - (pod-linkable-modules current-prefix-arg)))) - (list module - (pod-do-completing-read "Section: " (pod-linkable-sections module)) - (read-string "Text: ")))) - (pod-link - (concat module - "/" - (if (string-match-p "\s" section) - (concat "\"" section "\"") - section)) - text)) - -(defvar pod-mode-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "C-c C-l u") 'pod-link-uri) - (define-key map (kbd "C-c C-l s") 'pod-link-section) - (define-key map (kbd "C-c C-l m") 'pod-link-module) - (define-key map (kbd "C-c C-l M") 'pod-link-module-section) - map) - "Keymap for POD major mode.") - -(defvar pod-mode-syntax-table - (let ((st (make-syntax-table))) - st) - "Syntax table for `pod-mode'.") - -(defun pod-add-support-for-outline-minor-mode (&rest sections) - "Provides additional menus from section commands for function -`outline-minor-mode'. - -SECTIONS can be used to supply section commands in addition to -the POD defaults." - (make-local-variable 'outline-regexp) - (setq outline-regexp - (format "=%s\s" - (regexp-opt - (append (loop for i from 1 to 4 collect (format "head%d" i)) - '("item") sections)))) - (make-local-variable 'outline-level) - (setq outline-level - (lambda () - (save-excursion - (save-match-data - (let ((sect (format "^=%s\s" - (regexp-opt - (mapcar (lambda (i) (car i)) - pod-weaver-section-keywords) t)))) - (cond - ((looking-at sect) - (cdr (assoc (match-string-no-properties 1) - pod-weaver-section-keywords))) - ((looking-at "^=item\s") 5) - ((string-to-number (buffer-substring - (+ (point) 5) - (+ (point) 6))))))))))) - -(defun pod-add-support-for-imenu (&rest sections) - "Set up `imenu-generic-expression' for pod section commands. -SECTIONS can be used to supply section commands in addition to -the POD defaults." - (setq imenu-generic-expression - `((nil ,(format "^=%s\s+\\(.*\\)" - (regexp-opt - (append - (loop for i from 1 to 4 collect (format "head%d" i)) - '("item") sections))) - 1)))) - -(defun pod-enable-weaver-collector-keywords (collectors) - "Enable support for Pod::Weaver collector commands. -Enables fontification for all commands described by COLLECTORS. - -Also updates `pod-weaver-section-keywords', `outline-regexp', and -`imenu-generic-expression' accordingly." - (let ((collectors-by-replacement)) - (save-match-data - (setf pod-weaver-section-keywords - (loop for col in collectors - with cmd with new-cmd with new-name - do (progn - (setq cmd (getf col 'command) - new-cmd (getf col 'new_command) - new-name (symbol-name new-cmd)) - (let ((pos (loop for i in collectors-by-replacement do - (when (equal (car i) new-cmd) - (return i))))) - (if (not pos) - (push (list new-cmd cmd) collectors-by-replacement) - (setcdr (last pos) (list cmd))))) - when (string-match "^head\\([1-4]\\)$" new-name) - collect (cons (symbol-name cmd) - (string-to-number - (match-string-no-properties 1 new-name))) - when (string-match "^item$" new-name) - collect (cons (symbol-name cmd) 5)))) - (let ((sections (mapcar (lambda (i) (car i)) - pod-weaver-section-keywords))) - (apply #'pod-add-support-for-outline-minor-mode sections) - (apply #'pod-add-support-for-imenu sections)) - (setf - pod-font-lock-keywords - (append - (mapcar (lambda (i) - (append - (list (format "^\\(=%s\\)\\(.*\\)" - (regexp-opt (mapcar (lambda (k) (symbol-name k)) - (cdr i))))) - (let ((n (symbol-name (car i)))) - (if (string-match-p "^head[1-4]$" n) - (list - `(1 (quote - ,(intern (format "pod-mode-%s-face" n)))) - `(2 (quote - ,(intern (format "pod-mode-%s-text-face" n))))) - (list - '(1 'pod-mode-command-face) - '(2 'pod-mode-command-text-face)))))) - collectors-by-replacement) - pod-font-lock-keywords)) - (setq font-lock-mode-major-mode nil) - (font-lock-fontify-buffer))) - -(defun pod-enable-weaver-features (buffer weaver-config) - "Enable support for Pod::Weaver features. -Enables support for custom Pod::Weaver commands within a BUFFER. - -WEAVER-CONFIG is a structure as returned by -\"dzil weaverconf -f lisp\". - -Currently only supports collector commands via -`pod-enable-weaver-collector-keywords'." - (with-current-buffer buffer - (pod-enable-weaver-collector-keywords (getf weaver-config 'collectors)) - (message "Pod::Weaver keywords loaded."))) - -(defun pod-load-weaver-config (dir) - "Load additional pod keywords from dist.ini/weaver.ini in DIR." - (let* ((proc (start-process-shell-command - (concat "weaverconf-" (buffer-name (current-buffer))) - nil (format "cd %s; dzil weaverconf -f lisp" dir)))) - (set-process-plist proc (list :buffer (current-buffer) - :output "")) - (set-process-filter - proc (lambda (proc str) - (let ((plist (process-plist proc))) - (plist-put plist :output (concat (plist-get plist :output) str))))) - (set-process-sentinel - proc (lambda (proc event) - (if (string-equal event "finished\n") - (let* ((plist (process-plist proc)) - (weaver-config - (ignore-errors - (eval (car (read-from-string - (plist-get plist :output))))))) - (if weaver-config (pod-enable-weaver-features - (plist-get (process-plist proc) :buffer) - weaver-config)))))))) - -(defun pod-add-support-for-weaver () - "Enable support for Pod::Weaver features in the current buffer. -Calls `pod-load-weaver-config' with the project directory of the -current buffer's file. To be able to successfully determine the -project directory, `eproject-maybe-turn-on' will be used and -'eproject.el' is expected to be loaded. - -Does nothing if finding the project directory fails." - (let ((project-root (ignore-errors (eproject-maybe-turn-on)))) - (if project-root (pod-load-weaver-config project-root)))) - -;;;###autoload -(defun pod-mode () - "Major mode for editing POD files (Plain Old Documentation for Perl). - -Commands:\\<pod-mode-map> -\\[pod-link] `pod-link' -\\[pod-link-section] `pod-link-section' -\\[pod-link-module] `pod-link-module' -\\[pod-link-module-section] `pod-link-module-section' - -Turning on pod mode calls the hooks in `pod-mode-hook'." - (interactive) - (kill-all-local-variables) - (set-syntax-table pod-mode-syntax-table) - (use-local-map pod-mode-map) - (make-local-variable 'font-lock-defaults) - (setq font-lock-defaults '(pod-font-lock-keywords 't)) - (setq major-mode 'pod-mode) - (setq mode-name "POD") - (pod-add-support-for-imenu) - (pod-add-support-for-outline-minor-mode) - (run-hooks 'pod-mode-hook) - (pod-add-support-for-weaver)) - -(provide 'pod-mode) - -;;; pod-mode.el ends here diff --git a/elisp/emacs-goodies-el/pp-c-l.el b/elisp/emacs-goodies-el/pp-c-l.el index 203cb72..203cb72 100755..100644 --- a/elisp/emacs-goodies-el/pp-c-l.el +++ b/elisp/emacs-goodies-el/pp-c-l.el diff --git a/elisp/emacs-goodies-el/projects.el b/elisp/emacs-goodies-el/projects.el index 1f60f5d..1f60f5d 100755..100644 --- a/elisp/emacs-goodies-el/projects.el +++ b/elisp/emacs-goodies-el/projects.el diff --git a/elisp/emacs-goodies-el/protbuf.el b/elisp/emacs-goodies-el/protbuf.el index 92eab3c..92eab3c 100755..100644 --- a/elisp/emacs-goodies-el/protbuf.el +++ b/elisp/emacs-goodies-el/protbuf.el diff --git a/elisp/emacs-goodies-el/protocols.el b/elisp/emacs-goodies-el/protocols.el deleted file mode 100755 index 35de52e..0000000 --- a/elisp/emacs-goodies-el/protocols.el +++ /dev/null @@ -1,166 +0,0 @@ -;;; protocols.el --- Protocol database access functions. -;; Copyright 2000-2008 by Dave Pearson <davep@davep.org> -;; $Revision: 1.4 $ - -;; protocols.el is free software distributed under the terms of the GNU -;; General Public Licence, version 2 or (at your option) any later version. -;; For details see the file COPYING. - -;;; Commentary: -;; -;; protocols.el provides a set of functions for accessing the protocol -;; details list. -;; -;; The latest protocols.el is always available from: -;; -;; <URL:http://www.davep.org/emacs/#protocols.el> - -;;; BUGS: -;; -;; o Large parts of this code look like large parts of the code you'll find -;; in services.el, this is unfortunate and makes me cringe. However, I -;; also wanted them to be totally independant of each other. Suggestions -;; of how to sweetly remedy this situation are welcome. - -;;; INSTALLATION: -;; -;; o Drop protocols.el somwehere into your `load-path'. Try your site-lisp -;; directory for example (you might also want to byte-compile the file). -;; -;; o Add the following autoload statement to your ~/.emacs file: -;; -;; (autoload 'protocols-lookup "protocols" "Perform a protocol lookup" t) -;; (autoload 'protocols-clear-cache "protocols" "Clear the protocols cache" t) - -;;; Code: - -;; Things we need: - -(eval-when-compile - (require 'cl)) - -;; Attempt to handle older/other emacs. - -(eval-and-compile - - ;; If `line-beginning-position' isn't available provide one. - (unless (fboundp 'line-beginning-position) - (defun line-beginning-position (&optional n) - "Return the `point' of the beginning of the current line." - (save-excursion - (beginning-of-line n) - (point)))) - - ;; If `line-end-position' isn't available provide one. - (unless (fboundp 'line-end-position) - (defun line-end-position (&optional n) - "Return the `point' of the end of the current line." - (save-excursion - (end-of-line n) - (point))))) - -;; Customisable variables. - -(defvar protocols-file "/etc/protocols" - "*Name of the protocols file.") - -;; Non-customize variables. - -(defvar protocols-cache nil - "\"Cache\" of protocols.") - -(defvar protocols-name-cache nil - "\"Cache\" of protocol names.") - -;; Main code. - -(defsubst proto-name (proto) - "Return the name of protocol PROTO." - (car proto)) - -(defsubst proto-number (proto) - "Return the number of protocol PROTO." - (cadr proto)) - -(defsubst proto-aliases (proto) - "Return the alias list of protocol PROTO." - (cadr (cdr proto))) - -(defun protocols-line-to-list (line) - "Convert LINE from a string into a structured protocol list." - (let ((words (split-string line))) - (list - (car words) - (string-to-int (cadr words)) - (loop for s in (cddr words) - while (not (= (aref s 0) ?#)) - collect s)))) - -(defun* protocols-read (&optional (file protocols-file)) - "Read the protocol list from FILE. - -If FILE isn't supplied the value of `protocols-file' is used." - (or protocols-cache - (setq protocols-cache (when (file-readable-p file) - (with-temp-buffer - (insert-file-contents file) - (setf (point) (point-min)) - (loop until (eobp) - do (setf (point) (line-beginning-position)) - unless (or (looking-at "^[ \t]*#") (looking-at "^[ \t]*$")) - collect (protocols-line-to-list (buffer-substring (line-beginning-position) (line-end-position))) - do (forward-line))))))) - -(defun* protocols-find-by-name (name &optional (protocols (protocols-read))) - "Find the protocol whose name is NAME." - (assoc name protocols)) - -(defun* protocols-find-by-number (number &optional (protocols (protocols-read))) - "Find the protocol whose number is NUMBER." - (loop for protocol in protocols - when (= (proto-number protocol) number) return protocol)) - -(defun* protocols-find-by-alias (alias &optional (protocols (protocols-read))) - "Find the protocol that has an alias of ALIAS." - (loop for protocol in protocols - when (member alias (proto-aliases protocol)) return protocol)) - -;;;###autoload -(defun protocols-lookup (search) - "Find a protocol and display its details." - (interactive (list - (completing-read "Protocol search: " - (or protocols-name-cache - (setq protocols-name-cache - (loop for protocol in (protocols-read) - collect (list (proto-name protocol)) - append (loop for alias in (proto-aliases protocol) - collect (list alias)))))))) - (let* ((protocols (protocols-read)) - (protocol (or (when (string-match "^[0-9]+$" search) - (protocols-find-by-number (string-to-int search) protocols)) - (protocols-find-by-name search protocols) - (protocols-find-by-name (downcase search) protocols) - (protocols-find-by-name (upcase search) protocols) - (protocols-find-by-alias search protocols) - (protocols-find-by-alias (downcase search) protocols) - (protocols-find-by-alias (upcase search) protocols)))) - (if protocol - (message "Protocol: %s ID: %d Aliases: %s" - (proto-name protocol) - (proto-number protocol) - (with-output-to-string - (loop for alias in (proto-aliases protocol) - do (princ alias) (princ " ")))) - (error "Can't find a protocol matching \"%s\"" search)))) - -;;;###autoload -(defun protocols-clear-cache () - "Clear the protocols \"cache\"." - (interactive) - (setq protocols-cache nil - protocols-name-cache nil)) - -(provide 'protocols) - -;;; protocols.el ends here. diff --git a/elisp/emacs-goodies-el/quack.el b/elisp/emacs-goodies-el/quack.el deleted file mode 100644 index 0aa0a44..0000000 --- a/elisp/emacs-goodies-el/quack.el +++ /dev/null @@ -1,4820 +0,0 @@ -;;; quack.el --- enhanced support for editing and running Scheme code - -(defconst quack-copyright "Copyright (C) 2002-2012, 2016 Neil Van Dyke") -(defconst quack-copyright-2 "Portions Copyright (C) Free Software Foundation") -;; Emacs-style font-lock specs adapted from GNU Emacs 21.2 scheme.el. -;; Scheme Mode menu adapted from GNU Emacs 21.2 cmuscheme.el. - -(defconst quack-version "0.48") -(defconst quack-author-name "Neil Van Dyke") -(defconst quack-author-email "neil@neilvandyke.org") -(defconst quack-web-page "http://www.neilvandyke.org/quack/") - -(defconst quack-legal-notice - "This 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. This 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. See -http://www.gnu.org/licenses/ for details. For other licenses and consulting, -please contact Neil Van Dyke.") - -(defconst quack-cvsid "$Id: quack.el,v 1.5 2016/11/06 19:44:39 psg Exp $") - -;;; Commentary: - -;; INTRODUCTION: -;; -;; Quack enhances Emacs support for Scheme programming. -;; -;; Install Quack rather than following non-Quack-based tutorials on how to -;; set up Emacs for Scheme. -;; -;; The name "Quack" was a play on "DrScheme". -;; -;; Quack is dedicated to Yosh, naturally. - -;; COMPATIBILITY: -;; -;; GNU Emacs 23 and 22 -- Yes. Quack is now developed under GNU Emacs 23 -;; on a GNU/Linux system, which is the preferred platform for Quacksmokers. -;; Quack should work under GNU Emacs 23 on any Un*x-like OS. Reportedly, -;; Quack also works with GNU Emacs 22 on Apple Mac OS X and Microsoft -;; Windows (NT, 2000, XP), but the author has no means of testing on those -;; platforms. -;; -;; GNU Emacs 21 -- Probably, but no longer tested. -;; -;; GNU Emacs 20 -- Probably mostly. When last tested. Some of the menus do -;; not work properly, due to a bug in easymenu.el (which the FSF will not -;; fix, since they no longer support Emacs 20). Nested block comments are -;; not fontified correctly. Pretty-lambda does not work. Quack runs less -;; efficiently in 20 than 21, due to the lack of standard hash tables. -;; -;; XEmacs 21 -- Probably mostly, but no longer tested. Block comment -;; fontification is not yet supported under XEmacs 21, due to what appears -;; to be a bug in 21.4 font-lock. Pretty-lambda does not work. XEmacs -;; Quacksmokers who always want the latest and greatest Quack should -;; consider GNU Emacs 21 -- Quack treats XEmacs like a high-maintenance -;; redheaded stepchild. - -;; INSTALLATION: -;; -;; To install, put this file (`quack.el') somewhere in your Emacs load -;; path, and add the following line to your `.emacs' file: -;; -;; (require 'quack) -;; -;; If you don't know what your Emacs load path is, try invoking the command -;; "C-h v load-path RET" or consulting the Emacs manual. -;; -;; Note to advanced Emacsers: Byte-compiled `quack.elc' files generally are -;; *not* portable between Emacs implementations, nor between different -;; versions of the same implementation. -;; -;; You will also need the GNU `wget' program, which Quack uses for -;; downloading SRFI indexes. This popular program is included in most -;; GNU/Linux distributions and is available for most other platforms. -;; -;; Note to PLT Scheme users: If you do not already have the PLT manuals -;; installed, they can be downloaded from -;; `http://download.plt-scheme.org/doc/' and installed in your PLT `doc' -;; collection. If Quack is not finding installed PLT manuals, then be sure -;; that the `quack-pltcollect-dirs' variable contains the appropriate -;; collection directory (if it does not, then either set the `PLTHOME' -;; and/or `PLTCOLLECTS' environment variables appropriately, or set -;; `quack-pltcollect-dirs'). - -;; KEY BINDINGS: -;; -;; The key bindings that Quack adds to `scheme-mode' include: -;; -;; C-c C-q m View a manual in your Web browser. -;; C-c C-q k View the manual documentation for a keyword -;; (currently only works for PLT manuals). -;; C-c C-q s View an SRFI. -;; C-c C-q r Run an inferior Scheme process. -;; C-c C-q f Find a file using context of point for default. -;; C-c C-q l Toggle `lambda' syntax of `define'-like form. -;; C-c C-q t Tidy the formatting of the buffer. -;; -;; One additional command that does not currently have a standard binding -;; is `quack-dired-pltcollect', which prompts for a PLT collection name and -;; creates a Dired buffer on the collection's directory. (A future version -;; of Quack may integrate this functionality into a more generalized -;; documentation navigation interface.) - -;; RELEASE ANNOUNCEMENTS EMAIL: -;; -;; To receive email notification when a new Quack version is released, ask -;; neil@neilvandyke.org to add you to the moderated `scheme-announce' list. - -;; HISTORY: -;; -;; Version 0.48 (2016-04-03): -;; * Made fontify `#true` and `#false`. -;; -;; Version 0.47 (2012-11-15): -;; * Added indent for `call-with-' file variants and semaphore. -;; * Added font and indent for `with-handlers*', `define-runtime-path', -;; `match-let'. -;; -;; Version 0.46 (2012-06-20): -;; * Added indent for `letrec-values'. -;; * Corrected date on history for version 0.45. -;; -;; Version 0.45 (2012-06-18): -;; * Added a bunch of indent rules for Scribble definition forms -;; and Racket sequence/iterator stuff, plus Overeasy `test-section'. -;; -;; Version 0.44 (2012-04-11): -;; * Added indent and fontify for `struct', `module+', `module*'. -;; * Changed intent for `module' from `defun' to 2. -;; * Added fontify for `define-syntax-class', -;; `define-splicing-syntax-class', `begin-for-syntax'. -;; * Changed `define-struct' fontify. -;; -;; Version 0.43 (2011-08-23): -;; * Add indent and fontify for "syntax-parse". -;; * Added another compile error regexp for Racket backtraces. -;; -;; Version 0.42 (2011-07-30): -;; * Added compile error regexp for "raco". -;; -;; Version 0.41 (2011-06-04) -;; * Added `sxml-match' to `scheme-indent-function'. -;; -;; Version 0.40 (2010-12-22) -;; * Added indent rules for Racket `let:', `let*:', and `match'. And -;; a provisional rule for `define:'. -;; -;; Version 0.39 (2010-10-18) -;; * Renamed "typed/scheme" to "typed/racket". -;; -;; Version 0.38 (2010-10-14) -;; * Replaced old PLT Scheme programs in `quack-programs' with Racket. -;; * Added Racket ".rkt" and ".rktd" filename extensions. -;; * Added some Racket keywords for fontifying. -;; -;; Version 0.37 (2009-06-29) -;; * Disabled highlighting of "Compilation started at" lines. -;; -;; Version 0.36 (2009-05-27) -;; * Made `#:' ``colon keywords'' fontify in PLT-ish mode. -;; * Added PLT `r6rs' and `typed-scheme' languages to `quack-programs'. -;; -;; Version 0.35 (2009-02-24) -;; * Added `interpreter-mode-alist' support, so Scheme scripts with "#!" -;; start in `scheme-mode'. -;; * Added PLT `parameterize-break'. -;; * Improved `compile' mode for PLT 4.x tracebacks when there is only -;; file, line, and column, but no additional information. -;; -;; Version 0.34 (2009-02-19) -;; * Added fontify and indent support for PLT `define/kw', `lambda/kw', -;; `parameterize*'. -;; * Fontify Unix "#!" cookie in PLT-ish font-lock. -;; * Changed reference to `quack-announce' email list to -;; `scheme-announce'. -;; * Added PLT `default-load-handler' to -;; `quack-compilation-error-regexp-alist-additions' -;; * Changed some face ":height" attributes. -;; -;; Version 0.33 (2008-07-31) -;; * Added handlers for some PLT 4.0.1 "setup-plt" messages. -;; -;; Version 0.32 (2008-06-19) -;; * Added to `quack-programs'. -;; * Updated compatibility comments. -;; * Added indent rule for `for/fold'. -;; -;; Version 0.31 (2008-05-03) -;; * Added `defvar' for `quack-pltish-font-lock-keywords', so that the -;; GNU Emacs 22.1 compiler doesn't complain about assignment to a free -;; variable. -;; * Changed banner regexp for MzScheme for v3.99.x. -;; * Set `dynamic-wind' `scheme-indent-function to 0, when the default -;; is 3. It was just taking up too much space. DrScheme's -;; indentation seems to be equivalent -1, so there is precedent for -;; something different. We generally respect Emacs indentation -;; convention. -;; * Added fontifying and indent for PLT `define-for-syntax', -;; `define-values-for-syntax', `quasisyntax', `quasisyntax/loc', -;; `syntax', `syntax/loc', `define-parameters'. -;; * Advise `scheme-interactively-start-process' for GNU Emacs 22. -;; * Removed TODO comment that mentioned using `(current-eventspace -;; (make-eventspace))' under `mred', as Robby Findler has indicated -;; that is not good advice. -;; -;; Version 0.30 (2007-06-27) -;; * Emacs 22 compatibility change: `string-to-number' instead of -;; `string-to-int'. Thanks to Charles Comstock. -;; -;; Version 0.29 (2006-11-12) -;; * Fixed `quack-bar-syntax-string', which caused vertical bar -;; characters to be treated as whitespace. Thanks to Eric Hanchrow -;; for reporting. -;; -;; Version 0.28 (2005-05-14) -;; * Added `quack-smart-open-paren-p'. -;; * Changed `scheme-indent-function' for `parameterize' from `defun' -;; to `1'. -;; * In `quack-pltish-keywords-to-fontify': added `quasiquote', -;; `unquote', and `unquote-splicing'. -;; * Added ".mzschemerc" to `auto-mode-alist'. -;; * Added a little extra threesemi fontification for Funcelit and -;; similar Texinfo markup formats. -;; -;; Version 0.27 (2004-12-19) -;; * For Gambit-C, added REPL banner fontifying, `quack-manuals' entry, -;; and "gsi ~~/syntax-case.scm -" `quack-programs' entry. -;; * Changed "[PLT]" prefix on PLT manuals to "PLT", to make it easier -;; to type. -;; * Minor changes to reflect "MIT Scheme" becoming "MIT/GNU Scheme". -;; -;; Version 0.26 (2004-07-14) -;; * Added fontifying of a bunch of "define-"* syntax from Chicken. -;; -;; Version 0.25 (2004-07-09) -;; * Added `define-record-type' to `quack-pltish-keywords-to-fontify'. -;; * Added "csi -hygienic" to `quack-programs'. -;; * In `quack-manuals', replaced PLT-specific `r5rs' and `t-y-scheme' -;; with generic ones. -;; * Updated URL in `quack-manuals' for 3rd ed. of `tspl'. -;; * `quack-view-manual' completions no longer include symbols. -;; * `quack-view-manual' completion default is now "R5RS". -;; -;; Version 0.24 (2004-05-09) -;; * Made `quack-pltish-keywords-to-fontify' and -;; `quack-emacs-keywords-to-fontify' custom changes update -;; immediately. Bug reported by Taylor Campbell. -;; * Removed some non-syntax names from -;; `quack-pltish-keywords-to-fontify'. -;; * Documentation changes. -;; -;; Version 0.23 (2003-11-11) -;; * `quack-local-keywords-for-remote-manuals-p' can now have the value -;; of the symbol `always', to work around a defect in some versions -;; of Microsoft Windows. Thanks to Bill Clementson. -;; * `quack-w3m-browse-url-other-window' no longer splits a `*w3m*' -;; buffer. -;; * Added indent and `quack-pltish-keywords-to-fontify' rules for -;; `c-lambda' and `c-declare'. -;; -;; Version 0.22 (2003-07-03) -;; * `quack-newline-behavior' controls the RET key behavior in Scheme -;; buffers. -;; * In `quack-manuals', added Chez Scheme, and updated Chicken. -;; * Added error message navigation to `compile' for PLT `setup-plt'. -;; * Partial fix for Quack global menu disappearing from the main menu -;; bar in XEmacs. Thought it used to work, but it doesn't in XEmacs -;; 21.4.12. -;; -;; Version 0.21 (2003-05-28) -;; * `quack-find-file' is faster in many cases due to fix to -;; `quack-backward-sexp'. -;; * Added auto-mode-alist for `.ccl', `.stk', and `.stklos' files. -;; * Indent rule additions/changes for `chicken-setup' and `unit/sig'. -;; -;; Version 0.20 (2003-05-04) -;; * Added indent and fontify for SRFI-8 "receive". -;; * Added indent and fontify for additional PLT syntax. -;; * Added `quack-fontify-threesemi-p'. -;; * `quack-tidy-buffer' sets `fill-prefix' to nil when running. -;; * Added messages to `run-scheme', if only to get rid of annoying -;; "Mark set" message. -;; * Added "mzscheme -M errortrace" to `quack-programs'. -;; * `quack-dired-pltcollect' prompt defaults to `mzlib'. -;; * "Update SRFI Index" menu item has moved to top of menu, mainly to -;; avoid usability issue in a particular Emacs menu implementation. -;; * Several code quality improvements sent by Stefan Monnier will be -;; in the next release. -;; -;; Version 0.19 (2003-03-04) -;; * Commands such as `scheme-load-file' now start a Scheme process if -;; none is found. -;; * Bugfix for using `match-string-no-properties' when we meant -;; `quack-match-string-no-properties'. (Thanks to Noel Welsh.) -;; -;; Version 0.18 (2003-05-02) -;; * Removed uses of `(regexp-opt LIST t)', since XEmacs21 does not -;; create match data. (Thanks to Garrett Mitchener for debugging.) -;; * Added to `quack-programs' and `quack-manuals'. -;; * Added pretty-case-lambda. -;; * Changed PLT documentation URL function. -;; -;; Version 0.17 (2003-01-03) -;; * Pretty-lambda is supported well under GNU Emacs 21, when using PLT -;; Style fontification. Enable via the Options menu. (Based on -;; approach by Stefan Monnier; suggested by Ray Racine.) -;; * Various faces now have separate defaults for `light' and `dark' -;; backgrounds, so may now look better on dark backgrounds. -;; (Suggested by Eli Barzilay.) -;; * `quack-find-file' now respects `insert-default-directory' when -;; there is no default file. (Thanks to Eli Barzilay.) -;; * Most of the special w3m support has been moved to a separate -;; package, `w3mnav' (`http://www.neilvandyke.org/w3mnav/'). -;; `quack-w3m-browse-url-other-window' has been added. -;; -;; Version 0.16 (2002-12-16) -;; * `quack-insert-closing' now calls `blink-paren-function'. (Thanks -;; to Guillaume Marceau and Steve Elkins for reporting this.) -;; * Now uses PLT 202 manuals. Added "PLT Framework" manual. -;; * Added `quack-pltish-module-defn-face'. -;; * Added some PLTish font-lock keywords. -;; -;; Version 0.15 (2002-11-21) -;; * "Keywords" are now fontified in PLT Style fontification mode. -;; * Definition names are now blue by default in PLT Style. -;; * Symbol literals with vertical bars are now fontified in PLT Style. -;; * New `quack-manuals-webjump-sites' function for people who prefer -;; to use the `webjump' package for invoking manuals. -;; * New `quack-quiet-warnings-p' option. -;; * New `quack-pltish-class-defn-face' face. -;; -;; Version 0.14 (2002-10-18) -;; * Fix for `quack-view-manual' interactive prompting (thanks to Marko -;; Slyz for reporting this). -;; * `quack-emacsw3m-go-next' and `quack-emacsw3m-go-prev' now work -;; with GTK reference documentation (not that this has anything to do -;; with Scheme). -;; * Added SLIB to `quack-manuals'. -;; * Added comment about installing PLT manuals (thanks to Marko). -;; * We now call the canonical version of Emacs "GNU Emacs," instead of -;; "FSF Emacs". -;; -;; Version 0.13 (2002-09-21) -;; * Bugfix: No longer drop SRFI index entries on the floor. -;; -;; Version 0.12 (2002-09-20) -;; * New "View SRFI" menu. Select "Update SRFI Index" if the submenus -;; "Draft", "Final", and "Withdrawn" are disabled. -;; * Most options are now settable via "Options" menu. -;; * PLT collections are no longer scanned when building "View Manuals" -;; menu. -;; * "View Keyword Docs..." back on Scheme Mode menu in addition to -;; Quack menu. -;; * Various `defcustom' variables have been made to dynamically update -;; relevant program state when changed. -;; * Under GNU Emacs 20, dynamic menus still do not work -- they now -;; display, but do not perform the selected action. Will do more -;; debugging after this release. -;; * '[' and ']' keys work in emacs-w3m of MIT Scheme manuals. -;; -;; Version 0.11 (2002-09-17) -;; * Menus now work under XEmacs. Also now partly broken for Emacs 20. -;; * New global "Quack" menu. Disable with `quack-global-menu-p'. -;; * New "View Manual" submenu under GNU Emacs 21 and XEmacs (GNU Emacs -;; 20 is stuck with the old "View Manual..." menu item). -;; * Fix for `quack-pltcollects-alist' to include PLT `doc' collection, -;; which was preventing local manuals from being used. -;; * `quack-manuals' now includes `t-y-scheme'. -;; * `quack-view-in-different-browser' command that spawns alternative -;; Web browser from the special emacs-w3m support, bound to `B'. For -;; when you normally view manuals in an Emacs window, but -;; occasionally want to view a particular page in normal Web browser. -;; * More `scheme-indent-function' properties set. -;; * `quack-about' command. -;; * Fix to `quack-keyword-at-point'. -;; -;; Version 0.10 (2002-09-11) -;; * `quack-view-srfi' now prompts with completion, including titles -;; for all SRFIs. The SRFI titles are fetched from the official SRFI -;; Web site using the GNU Wget program, and cached locally. -;; * `quack-view-srfi' also now defaults to the SRFI number at or near -;; the point. -;; * `quack-dir' variable specifies a directory where Quack should -;; store its persistent data files (e.g., cached SRFI indexes), and -;; defaults to "~/.quack/". -;; * New `quack-tidy-buffer' command. [C-c C-q t] is now bound to -;; this; [C-c C-q l] ("l" as in "lambda) is now the official binding -;; for `quack-toggle-lambda'. -;; * `quack-find-file' now recognizes PLT `dynamic-require' form. -;; * Fix to make `quack-looking-at-backward' preserve match data. -;; * Fix for benign bug in `quack-parent-sexp-search'. -;; -;; Version 0.9 (2002-09-04) -;; * Quack now works under XEmacs 21, except no menus are currently -;; defined (that will come in a later version) and block comments -;; aren't fontified. -;; * `quack-toggle-lambda' command toggles a `define' form between -;; explicit and implicit `lambda' syntax. -;; * `quack-dired-pltcollect' feature prompts for a PLT collection name -;; and creates a Dired on the collection. -;; * `)' and `]' keys are bound to insert a closing character that -;; agrees with the opening character of the sexp. -;; * Nested `#|' comment blocks are now fontified mostly correctly -;; under GNU Emacs 21. -;; * Fix to `quack-parent-sexp-search'. -;; * Fix for PLT manual keywords lookup under Emacs 20. -;; * `quack-manuals' URLs for assorted implementation manuals now point -;; to canonical Web copies. -;; * No longer warns about PLT manual keywords file found without HTML. -;; * `find-file' key bindings are automatically remapped to -;; `quack-find-file' in Scheme buffers. -;; * Both PLT-style and Emacs-style fontification now work with the -;; `noweb-mode' package. Tested under GNU Emacs 21 with -;; Debian `nowebm' package version 2.10c-1. -;; * Added to `quack-emacsish-keywords-to-fontify'. -;; * Disabled fontification of named `let'. -;; * Renamed "collect" in PLT identifiers to "pltcollect". -;; * `auto-mode-alist' set more aggressively. -;; -;; Version 0.8 (2002-08-25) -;; * PLT package file viewing mode. This is mainly used to easily -;; inspect a ".plt" package before installing it via DrScheme or -;; "setup-plt". -;; * No longer warns about `font-lock-keywords' when `noweb-mode' -;; package is installed. -;; -;; Version 0.7 (2002-08-22) -;; * Now works on GNU Emacs 20 (though people are still encouraged to -;; upgrade to GNU Emacs 21 if they are able). -;; * `quack-manuals' now includes MIT Scheme and Chicken manuals -;; (currently where Debian GNU/Linux puts them). -;; * `quack-view-srfi' command. -;; * Named-`let' name is fontified like a PLTish definition name. -;; * `define-record' and `define-opt' fontified. -;; * Scheme Mode is forced in `auto-mode-alist' for ".sch" files. -;; * Fix to `quack-backward-sexp'. -;; * `quack-warning' messages get your attention. -;; * `quack-pltrequire-at-point-data-1' search depth limited. -;; -;; Version 0.6 (2002-08-20) -;; * `quack-find-file' now supports multi-line PLT `require' forms. -;; * When `emacs-w3m' is used, the keys "[", "]", and "t" are bound to -;; navigate through PLT manuals like in Info mode. -;; * Names highlighted in PLT-style fontification of `defmacro', -;; `defmacro-public', `defsyntax'. -;; * Advised `run-scheme' no longer prompts when there is already a -;; running Scheme. -;; * "csi" (Chicken interpreter) added to `quack-programs' default. -;; * Forces `auto-mode-alist' for ".scm" files to `scheme-mode' -;; (two can play at that game, `bee-mode'!). -;; * To-do comments moved from the top of the file to throughout code. -;; -;; Version 0.5 (2002-08-15) -;; * New `quack-find-file' permits quick navigation to files indicated -;; by a PLT Scheme `require' form under the point. Currently only -;; works when the "(require" string is on the same line as point. -;; * Improved PLT-style fontification. Most noticeable difference is -;; that names in many definition forms are boldfaced. See -;; `quack-pltish-fontify-definition-names-p' option. -;; * `quack-collects-alist' added. -;; * "~/plt/" has been removed from `quack-collect-dirs' default. -;; * Unnecessary syntax table settings have been removed. -;; * Reduced memory usage in some cases, via explicit GC calls. -;; -;; Version 0.4 (2002-08-07) -;; * Functionality adapted from author's `giguile.el' package: -;; - Enhanced `run-scheme' behavior. `quack-run-mzscheme', -;; `quack-run-mred', and `quack-remove-run-scheme-menu-item-p' -;; are obsolete. -;; - Enhanced `switch-to-scheme' behavior. -;; - Options menu. -;; - Indent rules for a few Guile-isms. -;; * Inferior Scheme Mode now uses the preferred fontification method. -;; * Now uses the PLT-bundled version of R5RS manual, which permits -;; keyword searching. -;; * `quack-banner-face' for the MzScheme/MrEd banner in REPL buffer. -;; * This code includes a start on toolbars and XEmacs21 portability, -;; but neither feature is yet functional. -;; -;; Version 0.3 (2002-08-01) -;; * PLT-style fontification added, except for quoted lists. Emacs- -;; style fontification still available; see `quack-fontify-style'. -;; * `emacs-w3m' package support for lightweight viewing of PLT manuals -;; in Emacs window. If you install the `emacs-w3m' package, then you -;; can change the new `quack-browse-url-browser-function' option to -;; use it. -;; * Quack menu items added to Scheme Mode menu. "Run Scheme" item -;; is removed by default; see `quack-remove-run-scheme-menu-item-p'. -;; * MrEd REPL supported with `quack-run-mred'. -;; * Better default for `quack-collect-dirs'. -;; * More `scheme-indent-function' settings. -;; * Bugfix for `quack-prompt-for-kwmatch-choice'. -;; * Bugfix for font-lock keywords getting set too early. -;; * Now byte-compiles without warnings/errors. -;; -;; Version 0.2 (2002-07-28) -;; * Manual keywords lookup. -;; * Other minor changes. -;; -;; Version 0.1 (2002-07-18) -;; * Initial release. - -;; ADMONISHMENT TO IMPRESSIONABLE YOUNG SCHEME STUDENTS: -;; -;; Quack should by no means be construed as a model of good programming, -;; much less of good software engineering. Emacs is by nature a complex -;; system of interacting kludges. To get Emacs to do useful new things is -;; to artfully weave one's extensions into a rich tapestry of sticky duct -;; tape. Also, Quack usually only got hacked on when I was stuck in a busy -;; lobby for an hour with a laptop and unable to do real work. - -;;; Code: - -;; Dependencies: - -(require 'advice) -(require 'cmuscheme) -(require 'compile) -(require 'custom) -(require 'easymenu) -(require 'font-lock) -(require 'scheme) -(require 'thingatpt) - -(unless (fboundp 'customize-save-variable) - (autoload 'customize-save-variable "cus-edit")) - -;; Custom Variables: - -(defgroup quack nil - "Enhanced support for editing and running Scheme code." - :group 'scheme - :prefix "quack-" - :link '(url-link "http://www.neilvandyke.org/quack/")) - -(defcustom quack-dir "~/.quack" - "*Directory where Quack stores various persistent data in file format." - :type 'string - :group 'quack) - -(defcustom quack-scheme-mode-keymap-prefix "\C-c\C-q" - "*Keymap prefix string for `quack-scheme-mode-keymap'. - -One of the nice things about having C-q in the prefix is that it is unlikely to -be already be in use, due to the historical reality of software flow control -\(and the fact that it is hard to type). If your C-q doesn't seem to be going -through, then you have several options: disable flow control (if it is safe to -do so), change the value of this variable, or see the Emacs documentation for -`enable-flow-control-on'." - :type 'string - :group 'quack) - -(defcustom quack-remap-find-file-bindings-p t - "Whether to remap `find-file' key bindings to `quack-find-file'. -The local map in Scheme Mode and Inferior Scheme Mode buffers is used." - :type 'boolean - :group 'quack) - -(defcustom quack-global-menu-p t - "*Whether to have a \"Quack\" menu always on the menu bar." - :type 'boolean :group 'quack) - -(defcustom quack-tabs-are-evil-p t - "*Whether Quack should avoid use of Tab characters in indentation." - :type 'boolean - :group 'quack) - -(defcustom quack-browse-url-browser-function nil - "*Optional override for `browse-url-browser-function'. - -If non-nil, overrides that variable for URLs viewed by `quack-browse-url'." - :type '(choice (const :tag "Do Not Override" nil) - (function :tag "Function") - (alist :tag "Regexp/Function Association List" - :key-type regexp :value-type function)) - :group 'quack) - -(defcustom quack-manuals ; TODO: Options menu. - - ;; TODO: If we make this so users are likely to want to override parts of it, - ;; then introduce `quack-manuals-defaults' variable with this in it, - ;; and let users edit `quack-manuals-overrides' which are keyed on the - ;; ID symbol. - - ;; TODO: Have a way for finding docs on the local filesystem, and/or - ;; permitting a user to easily specify location. - - ;; TODO: Provide a way of specifying alternative access means so that, for - ;; example, we can look for R5RS first in locally-installed PLT - ;; collection, then in one of various non-PLT directories it might be - ;; mirrored, then remote PLT copy using local PLT keywords file, then - ;; the canonical HTML copy on the Web... Maybe even permit Info - ;; format. Let's just reinvent the Web, while we're at it. - - '( - - (r5rs "R5RS" - "http://www.schemers.org/Documents/Standards/R5RS/HTML/" - nil) - - (bigloo - "Bigloo" - "http://www-sop.inria.fr/mimosa/fp/Bigloo/doc/bigloo.html" - ;;"file:///usr/share/doc/bigloo/manuals/bigloo.html" - nil) - - (chez - "Chez Scheme User's Guide" - "http://www.scheme.com/csug/index.html" - nil) - - (chicken - "Chicken User's Manual" - "http://www.call-with-current-continuation.org/manual/manual.html" - ;;"file:///usr/share/doc/chicken/manual.html" - nil) - - (gambit - "Gambit-C home page" - "http://www.iro.umontreal.ca/~gambit/") - - (gauche - "Gauche Reference Manual" - "http://www.shiro.dreamhost.com/scheme/gauche/man/gauche-refe.html" - nil) - - (mitgnu-ref - "MIT/GNU Scheme Reference" - "http://www.gnu.org/software/mit-scheme/documentation/scheme.html" - ;;"http://www.swiss.ai.mit.edu/projects/scheme/documentation/scheme.html" - - ;;"file:///usr/share/doc/mit-scheme/html/scheme.html" - nil) - - (mitgnu-user - "MIT/GNU Scheme User's Manual" - "http://www.gnu.org/software/mit-scheme/documentation/user.html" - ;;"http://www.swiss.ai.mit.edu/projects/scheme/documentation/user.html" - ;;"file:///usr/share/doc/mit-scheme/html/user.html" - nil) - - (mitgnu-sos - "MIT/GNU Scheme SOS Reference Manual" - "http://www.gnu.org/software/mit-scheme/documentation/sos.html" - ;;"http://www.swiss.ai.mit.edu/projects/scheme/documentation/sos.html" - ;;"file:///usr/share/doc/mit-scheme/html/sos.html" - nil) - - (plt-mzscheme "PLT MzScheme: Language Manual" plt t) - (plt-mzlib "PLT MzLib: Libraries Manual" plt t) - (plt-mred "PLT MrEd: Graphical Toolbox Manual" plt t) - (plt-framework "PLT Framework: GUI Application Framework" plt t) - (plt-drscheme "PLT DrScheme: Programming Environment Manual" plt nil) - (plt-insidemz "PLT Inside PLT MzScheme" plt nil) - (plt-tools "PLT Tools: DrScheme Extension Manual" plt nil) - (plt-mzc "PLT mzc: MzScheme Compiler Manual" plt t) - (plt-r5rs "PLT R5RS" plt t) - - (scsh - "Scsh Reference Manual" - "http://www.scsh.net/docu/html/man-Z-H-1.html" - ;;"file:///usr/share/doc/scsh-doc/scsh-manual/man-Z-H-1.html" - nil) - - (sisc - "SISC for Seasoned Schemers" - "http://sisc.sourceforge.net/manual/html/" - nil) - - (htdp "How to Design Programs" - "http://www.htdp.org/" - nil) - (htus "How to Use Scheme" - "http://www.htus.org/" - nil) - (t-y-scheme "Teach Yourself Scheme in Fixnum Days" - "http://www.ccs.neu.edu/home/dorai/t-y-scheme/t-y-scheme.html" - nil) - (tspl "Scheme Programming Language (Dybvig)" - "http://www.scheme.com/tspl/" - nil) - (sicp "Structure and Interpretation of Computer Programs" - "http://mitpress.mit.edu/sicp/full-text/book/book-Z-H-4.html" - nil) - (slib "SLIB" - "http://swissnet.ai.mit.edu/~jaffer/SLIB.html" - nil) - (faq "Scheme Frequently Asked Questions" - "http://www.schemers.org/Documents/FAQ/" - nil)) - "*List of specifications of manuals that can be viewed. - -Each manual specification is a list of four elements: - - (SYMBOL TITLE LOCATION USE-KEYWORDS-P) - -where SYMBOL is a short symbol that identifies the manual, TITLE is a string, -LOCATION is either a string with the URL of the manual or the symbol `plt', -and USE-KEYWORDS-P is `t' or `nil'. - -If LOCATION is `plt', then Quack treats it as a PLT bundled manual, looking for -the HTML and keyword files in `quack-pltcollect-dirs', and optionally providing -keyword lookup if USE-KEYWORDS-P is `t'. Remote canonical copies of the -manuals will be used if local copies cannot be found. - -If LOCATION is a URL, then USE-KEYWORDS-P must be `nil'." - :type '(repeat (list (symbol :tag "Identifying Symbol") - (string :tag "Title String") - (choice :tag "Location" - (string :tag "URL") - (const :tag "PLT Bundled Manual" plt)) - (boolean :tag "Use Keywords?"))) - :group 'quack) - -(defcustom quack-local-keywords-for-remote-manuals-p t - "*If non-nil, Quack will use canonical remote Web URLs when there is a local -keyword file for a PLT manual but no local HTML files. (This feature was -prompted by the Debian 200.2-3 package for MzScheme, which includes keyword -files but not HTML files.) If the symbol `always', then Quack will always use -remote Web manuals for keywords lookup, even if local HTML files exist, as a -workaround for how some versions of Emacs interact with some versions of -Microsoft Windows \(inexplicably discarding the fragment identifier from `file' -scheme URI\)." - :type '(choice (const :tag "Permit" t) - (const :tag "Forbid" nil) - (const :tag "Always" always)) - :group 'quack - :set 'quack-custom-set - :initialize 'custom-initialize-default) - -(defcustom quack-srfi-master-base-url "http://srfi.schemers.org/" - ;; Note: Intentionally not letting user change this through the options menu. - "*The base URL for the master SRFI Web pages. -The SRFI index files should be immediately beneath this." - :type 'string - :group 'quack) - -(defcustom quack-pltcollect-dirs - (let ((good '())) - (mapcar (function (lambda (dir) - (and dir - (not (assoc dir good)) - (file-directory-p dir) - (setq good (nconc good (list dir)))))) - `(,@(let ((v (getenv "PLTCOLLECTS"))) - (and v (split-string v ":"))) - ,(let ((v (getenv "PLTHOME"))) - (and v (expand-file-name "collects" v))) - ,@(mapcar 'expand-file-name - '("/usr/lib/plt/collects" - "/usr/local/lib/plt/collects")))) - good) - "*PLT collection directories. -Listed in order of priority." - :type '(repeat directory) - :group 'quack - :set 'quack-custom-set - :initialize 'custom-initialize-default) - -(defcustom quack-fontify-style 'plt - "*Which font-lock fontification style to use. - -If symbol `plt', an approximation of PLT DrScheme 200 Check Syntax -fontification will be used. If symbol `emacs', then fontification in the style -of GNU Emacs' Scheme Mode with extensions will be used. If nil, then Quack -will not override the default Scheme Mode fontification." - :type '(choice (const :tag "PLT Style" plt) - (const :tag "Extended GNU Emacs Style" emacs) - (const :tag "Emacs Default" nil)) - :group 'quack - :set 'quack-custom-set - :initialize 'custom-initialize-default) - -(defcustom quack-pltish-fontify-definition-names-p t - "*If non-nil, fontify names in definition forms for PLT-style fontification. - -This only has effect when `quack-fontify-style' is `plt'." - :type 'boolean - :group 'quack - :set 'quack-custom-set - :initialize 'custom-initialize-default) - -(defcustom quack-pltish-fontify-keywords-p t - ;; TODO: Rename this from "keywords" to "syntax-keywords", here, and in for - ;; face names. - "*If non-nil, fontify keywords in PLT-style fontification. - -This only has effect when `quack-fontify-style' is `plt'." - :type 'boolean - :group 'quack - :set 'quack-custom-set - :initialize 'custom-initialize-default) - -(defcustom quack-pltish-keywords-to-fontify - ;; TODO: These are currently R5RS and some SRFI special syntax plus a bunch - ;; of PLT, especially PLT 200 class.ss, and some "define-"* variants from - ;; various dialects, plus some Racket 5.0.2... The dumbness of this kind of - ;; highlighting without regard to context is not really satisfactory. - '( - - "and" "begin" "begin-for-syntax" - "begin0" "c-declare" "c-lambda" "case" "case-lambda" "class" - "class*" "class*/names" "class100" "class100*" "compound-unit/sig" "cond" - "cond-expand" "define" "define-class" "define-compound-unit" - "define-const-structure" - "define-constant" "define-embedded" "define-entry-point" "define-external" - "define-for-syntax" "define-foreign-record" "define-foreign-type" - "define-foreign-variable" "define-generic" "define-generic-procedure" - "define-inline" "define-location" "define-macro" "define-method" - "define-module" "define-opt" "define-public" "define-reader-ctor" - "define-record" "define-record-printer" "define-record-type" - "define-runtime-path" - "define-signature" - "define-splicing-syntax-class" - "define-struct" - "define-structure" - "define-syntax" - "define-syntax-class" - "define-syntax-set" "define-values" "define-values-for-syntax" - "define-values/invoke-unit/infer" - "define-values/invoke-unit/sig" "define/contract" "define/override" - "define/private" "define/public" "define/kw" - "delay" "do" "doc" "else" "exit-handler" "field" - "if" "import" "inherit" "inherit-field" "init" "init-field" "init-rest" - "instantiate" "interface" "lambda" "lambda/kw" "let" "let*" "let*-values" - "let+" - "let-syntax" "let-values" "let/ec" "letrec" "letrec-values" "letrec-syntax" - "match-lambda" "match-lambda*" "match-let" "match-let*" "match-letrec" - "match-define" "mixin" "module" "module*" "module+" "opt-lambda" "or" "override" "override*" - "namespace-variable-bind/invoke-unit/sig" "parameterize" "parameterize*" - "parameterize-break" "private" - "private*" "protect" "provide" "provide-signature-elements" - "provide/contract" "public" "public*" "quasiquote" - "quasisyntax" "quasisyntax/loc" "quote" "receive" - "rename" "require" "require-for-syntax" "send" "send*" "set!" "set!-values" - "signature->symbols" "super-instantiate" "syntax" "syntax/loc" - "syntax-case" "syntax-case*" "syntax-error" "syntax-parse" "syntax-rules" - "unit/sig" - "unless" "unquote" "unquote-splicing" "when" "with-handlers" "with-handlers*" "with-method" - "with-syntax" - "define-type-alias" - "define-struct:" - "define:" - "let:" - "letrec:" - "let*:" - "lambda:" - "match-let" - "plambda:" - "case-lambda:" - "pcase-lambda:" - "require/typed" - "require/opaque-type" - "require-typed-struct" - "struct" - "inst" - "ann" - - ) - "*Scheme keywords to fontify when `quack-fontify-style' is `plt'." - :type '(repeat string) - :group 'quack - :set 'quack-custom-set - :initialize 'custom-initialize-default) - -(defcustom quack-emacsish-keywords-to-fontify - '("and" "begin" "begin0" "call-with-current-continuation" - "call-with-input-file" "call-with-output-file" "call/cc" "case" - "case-lambda" "class" "cond" "delay" "do" "else" "exit-handler" "field" - "for-each" "if" "import" "inherit" "init-field" "interface" "lambda" "let" - "let*" "let*-values" "let-values" "let-syntax" "let/ec" "letrec" - "letrec-syntax" "map" "mixin" "opt-lambda" "or" "override" "protect" - "provide" "public" "rename" "require" "require-for-syntax" "syntax" - "syntax-case" "syntax-error" "syntax-rules" "unit/sig" "unless" "when" - "with-syntax") - "*Scheme keywords to fontify when `quack-fontify-style' is `emacs'." - :type '(repeat string) - :group 'quack - :set 'quack-custom-set - :initialize 'custom-initialize-default) - -(defcustom quack-fontify-threesemi-p t - "*Whether three-semicolon comments should be fontified differently." - :type 'boolean - :group 'quack - :set 'quack-custom-set - :initialize 'custom-initialize-default) - -(defcustom quack-pretty-lambda-p nil - "*Whether Quack should display \"lambda\" as the lambda character. - -`quack-fontify-style' must be `plt'. Only supported under GNU Emacs version -21\; not under XEmacs or older GNU Emacs. - -Note: Pretty lambda requires that suitable iso8859-7 fonts be available. Under -Debian/GNU Linux, for example, these can be downloaded and installed with the -shell command \"apt-get install 'xfonts-greek-*'\". If iso8859-7 fonts are -unavailable for your system, please notify the Quack author." - :type 'boolean - :group 'quack - :set 'quack-custom-set - :initialize 'custom-initialize-default) - -(defcustom quack-programs - '("bigloo" "csi" "csi -hygienic" "gosh" "gracket" "gsi" - "gsi ~~/syntax-case.scm -" "guile" "kawa" "mit-scheme" "racket" - "racket -il typed/racket" "rs" "scheme" "scheme48" "scsh" "sisc" "stklos" - "sxi") - "List of Scheme interpreter programs that can be used with `run-scheme'. - -These names will be accessible via completion when `run-scheme' prompts for -which program to run." - :group 'quack - :type '(repeat string) - :set 'quack-custom-set - :initialize 'custom-initialize-default) - -(defcustom quack-default-program "mzscheme" - "Default Scheme interpreter program to use with `run-scheme'." - :group 'quack - :type 'string) - -(defcustom quack-run-scheme-always-prompts-p t - "`run-scheme' should always prompt for which program to run. - -If nil, `run-scheme' will always use `quack-default-program' when invoked -interactively without a prefix argument; this is closest to the behavior of the -`cmuscheme' package." - :group 'quack - :type 'boolean) - -(defcustom quack-run-scheme-prompt-defaults-to-last-p t - "If non-nil, `run-scheme' prompt should default to the last program run." - :group 'quack - :type 'boolean) - -(defcustom quack-remember-new-programs-p t - "Programs are added to `quack-programs' automatically." - :group 'gigule - :type 'boolean) - -(defcustom quack-switch-to-scheme-method 'other-window - "Method to use for choosing a window and frame for the process buffer. - -One of three symbols: -`other-window' will split display in a different window in the current frame, -splitting the current window if necessary. -`own-frame' will display the process buffer in its own frame. -`cmuscheme' will use the normal behavior of the `cmuscheme' package." - :group 'quack - :type '(choice (const :tag "Other Window" other-window) - (const :tag "Own Frame" own-frame) - (const :tag "Cmuscheme Behavior" cmuscheme))) - -(defcustom quack-warp-pointer-to-frame-p t - "Warp mouse pointer to frame with Scheme process buffer. - -When `quack-switch-to-scheme-method' is `own-frame', `switch-to-scheme' will -warp the mouse pointer to the frame displaying the Scheme process buffer." - :group 'quack - :type 'boolean) - -(defcustom quack-newline-behavior 'newline-indent - "*Behavior of the RET key in Scheme-Mode buffers. The value is one of three -symbols: `newline' inserts a normal newline, `newline-indent' \(the default\) -inserts a newline and leaves the point properly indented on the new line, and -`indent-newline-indent' indents the current line before inserting a newline and -indenting the new one." - :type '(choice (const 'newline) - (const 'newline-indent) - (const 'indent-newline-indent)) - :group 'quack) - -(defcustom quack-smart-open-paren-p nil - "The `[' can be used to insert `(' characters. -Actually, this just makes the `(' and '[' keys both insert `(', unless given a -prefix argument. This makes typing parens easier on typical keyboards for -which `(' requires a shift modifier but `[' does not. A later version of Quack -might add actual \"smart\" support for automatic PLT-esque insertion of `[' -instead of `(' in some syntactic contexts." - :group 'quack - :type 'boolean) - -(defcustom quack-options-persist-p t - "Option menu settings and programs persist using the `custom' facility. - -Note that the value of this option itself cannot be set persistently via the -option menu -- you must use the `customize' interface or set it manually in an -Emacs startup file. This is by design, to avoid the risk of users accidentally -disabling their ability to set persistent options via the option menu." - :group 'quack - :type 'boolean) - -(defcustom quack-quiet-warnings-p t ; TODO: Options menu. - "Warning messages are quiet and subtle." - :group 'quack - :type 'boolean) - -(defconst quack-pltish-comment-face 'quack-pltish-comment-face) -(defface quack-pltish-comment-face - '((((class color) (background light)) (:foreground "cyan4")) - (((class color) (background dark)) (:foreground "cyan1")) - (t (:slant italic))) - "Face used for comments when `quack-fontify-style' is `plt'." - :group 'quack) - -(defconst quack-pltish-selfeval-face 'quack-pltish-selfeval-face) -(defface quack-pltish-selfeval-face - '((((class color) (background light)) (:foreground "green4")) - (((class color) (background dark)) (:foreground "green2")) - (t ())) - "Face used for self-evaluating forms when `quack-fontify-style' is `plt'." - :group 'quack) - -(defconst quack-pltish-paren-face 'quack-pltish-paren-face) -(defface quack-pltish-paren-face - '((((class color) (background light)) (:foreground "red3")) - (((class color) (background dark)) (:foreground "red1")) - (((class grayscale)) (:foreground "gray")) - (t ())) - "Face used for parentheses when `quack-fontify-style' is `plt'." - :group 'quack) - -(defconst quack-pltish-colon-keyword-face 'quack-pltish-colon-keyword-face) -(defface quack-pltish-colon-keyword-face - '((t (:bold t :foreground "gray50"))) - "Face used for `#:' keywords when `quack-fontify-style' is `plt'. -Note that this isn't based on anything in PLT." - :group 'quack) - -(defconst quack-pltish-paren-face 'quack-pltish-paren-face) -(defface quack-pltish-paren-face - '((((class color) (background light)) (:foreground "red3")) - (((class color) (background dark)) (:foreground "red1")) - (((class grayscale)) (:foreground "gray")) - (t ())) - "Face used for parentheses when `quack-fontify-style' is `plt'." - :group 'quack) - -(defconst quack-banner-face 'quack-banner-face) -(defface quack-banner-face - '((t (:family "Helvetica"))) - "Face used in the inferior process buffer for the MzScheme banner. - -Currently only takes effect when `quack-fontify-style' is `plt'." - :group 'quack) - -(defconst quack-pltish-defn-face 'quack-pltish-defn-face) -(defface quack-pltish-defn-face - '((((class color) (background light)) (:bold t :foreground "blue3")) - (((class color) (background dark)) (:bold t :foreground "blue1")) - (t (:bold t :underline t))) - "Face used for names in toplevel definitions. - -For PLT-style when `quack-pltish-fontify-definition-names-p' is non-nil." - :group 'quack) - -(defconst quack-pltish-class-defn-face 'quack-pltish-class-defn-face) -(defface quack-pltish-class-defn-face - '((((class color) (background light)) - (:foreground "purple3" :inherit quack-pltish-defn-face)) - (((class color) (background dark)) - (:foreground "purple1" :inherit quack-pltish-defn-face)) - (t (:inherit quack-pltish-defn-face))) - "Face used for class names in toplevel definitions. - -For PLT-style when `quack-pltish-fontify-definition-names-p' is non-nil." - :group 'quack) - -(defconst quack-pltish-module-defn-face 'quack-pltish-module-defn-face) -(defface quack-pltish-module-defn-face - '((((class color) (background light)) - (:foreground "purple3" :inherit quack-pltish-defn-face)) - (((class color) (background dark)) - (:foreground "purple1" :inherit quack-pltish-defn-face)) - (t (:inherit quack-pltish-defn-face))) - "Face used for module names in toplevel definitions. - -For PLT-style when `quack-pltish-fontify-definition-names-p' is non-nil." - :group 'quack) - -(defconst quack-pltish-keyword-face 'quack-pltish-keyword-face) -(defface quack-pltish-keyword-face - '((t (:bold t))) - "Face used for keywords in PLT Style fontification. - -For PLT-style when `quack-pltish-fontify-keywords-p' is non-nil." - :group 'quack) - -(defconst quack-threesemi-semi-face 'quack-threesemi-semi-face) -(defface quack-threesemi-semi-face - '((((class color) (background light)) - (:foreground "#a0ffff":background "#c0ffff")) - (((class color) (background dark)) - (:foreground "cyan2" :background "cyan4")) - (t (:slant italic))) - "Face used for `;;;' semicolons when `quack-fontify-threesemi-p' is non-nil." - :group 'quack) - -(defconst quack-threesemi-text-face 'quack-threesemi-text-face) -(defface quack-threesemi-text-face - '((((class color) (background light)) - (:foreground "cyan4" :background "#c0ffff")) - (((class color) (background dark)) - (:foreground "white" :background "cyan4")) - (t (:slant italic))) - "Face used for `;;;' text when `quack-fontify-threesemi-p' is non-nil." - :group 'quack) - -(defconst quack-threesemi-h1-face 'quack-threesemi-h1-face) -(defface quack-threesemi-h1-face - '((t (:bold t :family "Helvetica" :height 1.4 :size "20pt"))) - "Face used for H1 headings in `;;;' text." - :group 'quack) - -(defconst quack-threesemi-h2-face 'quack-threesemi-h2-face) -(defface quack-threesemi-h2-face - '((t (:bold t :family "Helvetica" :height 1.2 :size "16pt"))) - "Face used for H2 headings in `;;;' text." - :group 'quack) - -(defconst quack-threesemi-h3-face 'quack-threesemi-h3-face) -(defface quack-threesemi-h3-face - '((t (:bold t :family "Helvetica"))) - "Face used for H3 headings in `;;;' text." - :group 'quack) - -(defconst quack-pltfile-prologue-face 'quack-pltfile-prologue-face) -(defface quack-pltfile-prologue-face - '((((class color)) (:foreground "black" :background "gray66")) - (((class grayscale)) (:foreground "black" :background "gray66")) - (t ())) - "Face used for the prologue in a decoded PLT package buffer." - :group 'quack) - -(defconst quack-pltfile-dir-face 'quack-pltfile-dir-face) -(defface quack-pltfile-dir-face - '((((class color)) (:bold t :foreground "white" :background "gray33" - :family "Helvetica" :height 1.2 :size "20pt")) - (((class grayscale)) (:bold t :foreground "white" :background "gray33" - :family "Helvetica" :height 1.2 :size "20pt")) - (t (:bold t :inverse-video t))) - "Face used for directory headers in a decoded PLT package buffer." - :group 'quack) - -(defconst quack-pltfile-file-face 'quack-pltfile-file-face) -(defface quack-pltfile-file-face - '((((class color)) (:bold t :foreground "black" :background "gray66" - :family "Helvetica" :height 1.2 :size "20pt")) - (((class grayscale)) (:bold t :foreground "black" :background "gray66" - :family "Helvetica" :height 1.2 :size "20pt")) - (t (:bold t :inverse-video t))) - "Face used for file headers in a decoded PLT package buffer." - :group 'quack) - -(defconst quack-about-title-face 'quack-about-title-face) -(defface quack-about-title-face - '((((class color) (background light)) - (:bold t :family "Helvetica" :foreground "#008000" - :height 2.0 :size "24pt")) - (((class color) (background dark)) - (:bold t :family "Helvetica" :foreground "#00f000" - :height 2.0 :size "24pt")) - (t (:bold t :family "Helvetica" - :height 2.0 :size "24pt"))) - "Face used for Quack name in About Quack." - :group 'quack) - -(defconst quack-about-face 'quack-about-face) -(defface quack-about-face - '((t (:family "Helvetica"))) - "Face used for the body text in About Quack." - :group 'quack) - -(defconst quack-smallprint-face 'quack-smallprint-face) -(defface quack-smallprint-face - '((t (:family "Courier" :height 0.8 :size "8pt"))) - "Face used for the \"small print\" in About Quack." - :group 'quack) - -;; Compatibility/Portability Misc. Kludges: - -;; Note: Some compatibility gotchas found while porting Quack that aren't -;; addressed by macros and functions: -;; -;; * `defface' in Emacs 21 supports ":weight bold", but this is silently -;; ignored under older Emacsen, so ":bold t" must be used instead. -;; -;; * Third argument of `detect-coding-region' is different in Emacs 21 and -;; XEmacs 21, so only use the first two args. -;; -;; * Under XEmacs 21, characters are `equal' but not `eq' to their integer -;; ASCII values -;; -;; * GNU Emacs 21 faces have `:height' property that is either absolute -;; decipoints or relative scaling factor. XEmacs 21 faces instead have -;; `:size' property, which appears to be absolute point or mm size. -;; -;; * XEmacs 21 text properties appear to be front-sticky, and there did not -;; seem to be any documentation references to stickiness. -;; -;; * XEmacs 21 `local-variable-p' has second argument mandatory. -;; -;; * XEmacs 21 does not display submenu labels at all unless the submenu has -;; content. For inactive submenus, an empty string suffices for content. -;; -;; * XEmacs 21 doesn't support composite characters (which we use for very -;; nice pretty lambda under GNU Emacs). - -(eval-and-compile - (defvar quack-xemacs-p (eval '(and (boundp 'running-xemacs) running-xemacs))) - (defvar quack-gnuemacs-p (not quack-xemacs-p))) - -(defmacro quack-when-xemacs (&rest args) - (if quack-xemacs-p (cons 'progn args) 'nil)) - -(defmacro quack-when-gnuemacs (&rest args) - (if quack-gnuemacs-p (cons 'progn args) 'nil)) - -(defmacro quack-define-key-after (keymap key definition &optional after) - (if quack-gnuemacs-p - `(define-key-after ,keymap ,key ,definition ,after) - `(define-key ,keymap ,key (prog1 ,definition ,after)))) - -(defmacro quack-delete-horizontal-space (&rest args) - (if (and quack-gnuemacs-p (>= emacs-major-version 21)) - `(delete-horizontal-space ,@args) - `(delete-horizontal-space))) - -(defmacro quack-match-string-no-properties (&rest args) - `(,(if quack-xemacs-p 'match-string 'match-string-no-properties) ,@args)) - -(defmacro quack-menufilter-return (name form) - (if (= emacs-major-version 20) - ;; Note: This isn't working in Emacs 20. Menu displays now but actions - ;; are not executed. No answer to test case posted to comp.emacs - ;; and then to gnu.emacs.help. In response to my subsequent bug - ;; report against Emacs, RMS says that, if this is indeed a bug, - ;; then nothing will be done, since 20 is no longer supported. I'm - ;; going to let this quietly not work unless someone emails me that - ;; they're actually using Emacs 20. - `(easy-menu-filter-return (easy-menu-create-menu ,name ,form)) - form)) - -(defmacro quack-propertize (obj &rest props) - (if (and quack-gnuemacs-p (>= emacs-major-version 21)) - `(propertize ,obj ,@props) - (let ((obj-var 'quack-propertize-G-obj)) - `(let ((,obj-var ,obj)) - (add-text-properties 0 (length ,obj-var) (list ,@props) ,obj-var) - ,obj-var)))) - -(eval-when-compile - (when quack-xemacs-p - (defvar inhibit-eol-conversion) - (defvar minibuffer-allow-text-properties))) - -;; Compatibility/Portability Hash Table: - -(eval-and-compile - (defmacro quack-make-hash-table (&rest args) - `(,(if (>= emacs-major-version 21) - 'make-hash-table - 'quack-fake-make-hash-table) - ,@args))) - -(defmacro quack-puthash (key value table) - (list (if (>= emacs-major-version 21) 'puthash 'quack-fake-puthash) - key value table)) - -(defmacro quack-gethash (key table &optional dflt) - (list (if (>= emacs-major-version 21) 'gethash 'quack-fake-gethash) - key table dflt)) - -(defun quack-fake-make-hash-table (&rest args) - ;; TODO: Parse the keyword args and make this do 'assoc or 'assq, as - ;; appropriate. Currently, this package only needs 'assoc. - (vector 'assoc '())) - -(defun quack-fake-puthash (key value table) - (let ((pair (funcall (aref table 0) key (aref table 1)))) - (if pair - (setcdr pair value) - (aset table 1 (cons (cons key value) (aref table 1)))))) - -(defun quack-fake-gethash (key table &optional dflt) - (let ((pair (funcall (aref table 0) key (aref table 1)))) - (if pair (cdr pair) dflt))) - -;; Compatibility/Portability Overlays/Extents: - -;; TODO: Maybe get rid of overlays (and the XEmacs extent kludge), and just use -;; text properties instead. - -(defmacro quack-make-face-ovlext (beg end face) - (if quack-xemacs-p - `(set-extent-property (make-extent ,beg ,end) 'face ,face) - `(overlay-put (make-overlay ,beg ,end) 'face ,face))) - -(defmacro quack-make-hiding-ovlext (beg end) - (if quack-xemacs-p - `(set-extent-property (make-extent ,beg ,end) 'invisible t) - `(overlay-put (make-overlay ,beg ,end) 'category 'quack-hiding-ovlcat))) - -;; Messages, Errors, Warnings: - -(defmacro quack-activity (what &rest body) - (let ((var-what (make-symbol "quack-activity-G-what"))) - `(let ((,var-what ,what)) - (message (concat ,var-what "...")) - (prog1 (progn ,@body) - (message (concat ,var-what "...done")))))) - -(defun quack-internal-error (&optional format &rest args) - (if format - (apply 'error (concat "Quack Internal Error: " format) args) - (error "Quack Internal Error."))) - -(defun quack-warning (format &rest args) - (apply 'message (concat "Quack Warning: " format) args) - (unless quack-quiet-warnings-p - (beep) - (sleep-for 1))) - -;; Regular Expressions: - -(defun quack-re-alt (&rest regexps) - (concat "\\(" (mapconcat 'identity regexps "\\|") "\\)")) - -(defun quack-re-optional (&rest regexps) - (concat "\\(" - (apply 'concat regexps) - "\\)?")) - -;; Misc.: - -;; (defun quack-abbreviate-file-name (file-name) -;; (let ((directory-abbrev-alist '())) -;; (abbreviate-file-name file-name))) - -(defun quack-delete-file-if-can (file) - (condition-case nil (delete-file file) (error nil))) - -(defun quack-expand-file-name (name-or-names &optional directory) - ;; Note: This only works for systems with Unix-like filenames. - (expand-file-name (if (listp name-or-names) - (mapconcat 'identity name-or-names "/") - name-or-names) - directory)) - -(defun quack-kill-current-buffer () - (interactive) - (kill-buffer (current-buffer))) - -(defun quack-line-at-point () - (save-excursion - (buffer-substring-no-properties - (progn (beginning-of-line) (point)) - (progn (end-of-line) (point))))) - -(defun quack-looking-at-backward (re &optional limit) - (save-excursion - (save-restriction - (let ((start-pt (point))) - (narrow-to-region (point-min) (point)) - (and (re-search-backward re limit t) - (= (match-end 0) start-pt) - (match-beginning 0)))))) - -(defun quack-looking-at-close-paren-backward () - (save-match-data - (quack-looking-at-backward "[])][ \t\r\n\f]*"))) - -(defun quack-looking-at-open-paren-backward () - (save-match-data - (quack-looking-at-backward "[[(][ \t\r\n\f]*"))) - -(defun quack-make-directory (dir) - (setq dir (file-name-as-directory dir)) - (unless (file-directory-p dir) - (make-directory dir t))) - -(defun quack-make-directory-for-file (file) - (let ((dir (file-name-directory file))) - (when dir (quack-make-directory dir)))) - -(defun quack-propertize-bold (str) - (quack-propertize str 'face 'bold)) - -(defun quack-propertize-face (str face) - (quack-propertize str 'face face)) - -(defun quack-propertize-italic (str) - (quack-propertize str 'face 'italic)) - -(defun quack-sort-string-list-copy (lst) - (sort (copy-sequence lst) 'string<)) - -(defun quack-uncomment-region (beg end) - ;; TODO: Make a quack-toggle-commentout-region. - (interactive "r") - (comment-region beg end '(4))) - -(defun quack-without-side-whitespace (str) - ;; Copied from `padr-str-trim-ws' by author. - ;; - ;; TODO: Don't make an intermediate string. Use regexp match start position. - (save-match-data - (if (string-match "^[ \t\n\r]+" str) - (setq str (substring str (match-end 0)))) - (if (string-match "[ \t\n\r]+$" str) - (setq str (substring str 0 (match-beginning 0)))) - str)) - -;; Kludgey Sexp Buffer Operations: - -(defconst quack-backward-sexp-re - (concat "\\`" - (quack-re-alt "[^\";\\\\]" - "\\\\\\." - (concat "\"" - (quack-re-alt "[^\"\\\\]" - "\\\\\\.") - "*\"")) - "*\\([\"\\\\]\\)?")) - -(defun quack-backward-sexp () - ;; Returns non-nil iff point was in a string literal or comment. - (interactive) - (when (bobp) - (error "beginning of buffer")) - (save-match-data - (let* ((orig (point)) - (bol (progn (beginning-of-line) (point)))) - (if (string-match quack-backward-sexp-re - (buffer-substring-no-properties bol orig)) - (if (match-beginning 3) - ;; We're in what appears to be a comment or unterminated string - ;; literal (though might not be, due to multi-line string - ;; literals and block comments), so move point to the beginning. - (progn (goto-char (+ bol (match-beginning 3))) - t) - ;; We don't appear to be in a comment or string literal, so just - ;; let `backward-sexp' do its thing. - (goto-char orig) - (backward-sexp) - nil))))) - -(defun quack-parent-sexp-search (name-regexp &optional max-depth max-breadth) - (save-match-data - (save-excursion - (let ((max-depth (or max-depth 100)) - (max-breadth (or max-breadth 100)) - (orig-point (point)) - (found 'looking) - (depth 0) - (child-start nil)) - (while (and (eq found 'looking) (< depth max-depth)) - (condition-case nil - (let ((breadth 0)) - ;; Loop until we hit max breadth or error. - (while (< breadth max-breadth) - (when (and (quack-backward-sexp) (not child-start)) - (setq child-start (point))) - (setq breadth (1+ breadth))) - ;; We hit our max breadth without erroring, so set the found - ;; flag to indicate failure and then fall out of our loop. - (setq found nil)) - (error ; scan-error - ;; We probably hit the beginning of the enclosing sexp, and point - ;; should be on the first sexp, which will most often be the form - ;; name, so first check that there really is an open paren to our - ;; left, and then check if it matches our regexp. - (let ((paren-start (quack-looking-at-open-paren-backward))) - (if paren-start - ;; There is a paren, so check the name of the form. - (if (and (looking-at name-regexp) - (quack-not-symbol-char-at-point-p (match-end 0))) - ;; Found it, so set the result to a list (lexeme, lexeme - ;; end point, last nested child sexp start point, parent - ;; paren start point) and then fall out of our loop. - ;; Note that we return the original point if no child - ;; point was found, on the assumption that point was at - ;; the beginning of the child sexp (unless it was within - ;; the found form name, in which case child sexp start - ;; is nil). - (setq found (list (quack-match-string-no-properties 0) - (match-end 0) - (or child-start - (if (> orig-point (match-end 0)) - orig-point)) - paren-start)) - ;; This form name didn't match, so try to move up in the - ;; paren syntax (which will usually mean moving left one - ;; character). - (condition-case nil - (progn (up-list -1) - (setq child-start (point)) - (setq depth (1+ depth))) - (error ; scan-error - ;; We can't go up here, so set found flag to indicate - ;; failure and then fall out of the loop. - (setq found nil)))) - ;; There wasn't a paren, which means we hit a scan error for - ;; some reason other than being at the beginning of the sexp, - ;; so consider the search a failure - (setq found nil)))))) - (if (eq found 'looking) - nil - found))))) - -;; TODO: We really need a global definition of what are Scheme symbol -;; constituent characters (or a whole-symbol regexp)! - -(defun quack-not-symbol-char-at-point-p (pt) - ;; This is used to check for a symbol boundary point. - (save-match-data - (or (= pt (point-max)) - (if (string-match "[^-a-zA-Z0-9!+<=>$%&*./:@^_~]" - (buffer-substring-no-properties pt (1+ pt))) - t)))) - -;; String Constant Hashtable: - -(eval-and-compile - (if (< emacs-major-version 21) - - (defun quack-strconst (str) str) - - (defvar quack-strconst-hashtable - (if (>= emacs-major-version 21) - (quack-make-hash-table :test 'equal :size 1000))) - - (defun quack-strconst (str) - (unless (stringp str) - (error "Non-string object passed to quack-strconst: %s" str)) - (or (quack-gethash str quack-strconst-hashtable nil) - (quack-puthash str str quack-strconst-hashtable) - str)))) - -;; Web URLs: - -(defun quack-quote-url-substring (str &optional quote-slash-p always-new-p) - (save-match-data - (let ((regexp (if quote-slash-p "[^-_.A-Za-z0-9]" "[^-_.A-Za-z0-9/]")) - (subs '()) - (len (length str)) - (start 0)) - (while (and (> len start) - (string-match regexp str start)) - (let ((beg (match-beginning 0)) - (end (match-end 0))) - (when (> beg start) - (setq subs (cons (substring str start beg) subs))) - (setq subs (cons (format "%%%X" (aref str beg)) subs)) - (setq start end))) - (if subs - (apply 'concat (reverse (if (> len start) - (cons (substring str start len) subs) - subs))) - (if always-new-p (copy-sequence str) str))))) - -(defun quack-file-url (dir file) - ;; TODO: This is Unix-centric and a little fragile. Rewrite eventually. - (concat "file:" - (quack-quote-url-substring dir) - "/" - (or (quack-quote-url-substring file) ""))) - -(defun quack-build-url (base path) - (let ((base-slash-p (= (aref base (1- (length base))) ?\/))) - (if path - (mapconcat 'identity - (cons (if base-slash-p - (substring base 0 -1) - base) - path) - "/") - (if base-slash-p - base - (concat base "/"))))) - -;; Web Browsing: - -(defun quack-browse-url (url) - (require 'browse-url) - (message "Quack viewing URL: %s" url) - (let ((browse-url-browser-function (or quack-browse-url-browser-function - browse-url-browser-function))) - (browse-url url))) - -(defun quack-browse-quack-web-page () - (interactive) - (quack-browse-url quack-web-page)) - -(defun quack-w3m-browse-url-other-window (url &optional new-window) - (interactive (eval '(browse-url-interactive-arg "URL: "))) - (unless (string= (buffer-name) "*w3m*") - (switch-to-buffer-other-window (current-buffer))) - ;; TODO: If `*w3m*' buffer is visible in current frame or other frame, - ;; switch to that, for Emacsen that don't do that by default. - (eval '(w3m-browse-url url nil))) - -;; Web Getting: - -(defconst quack-web-get-log-buffer-name "*quack-web-get*") - -(defun quack-web-get-to-file (url out-file) - ;; TODO: Support other getting tools, such as "lynx -source", "links - ;; -source", "w3m -dump_source", and the Emacs w3 package. Most of - ;; these send the Web content to stdout, so, unlike for wget, it will - ;; be easier to insert directly to a buffer and send stderr to a temp - ;; file. We should have *-to-file-* and *-insert-via-* functions for - ;; each external downloader program anyway. - (quack-make-directory-for-file out-file) - (quack-web-get-to-file-via-wget url out-file)) - -;;(defun quack-web-get-to-temp-file (url) -;; (let ((temp-file (quack-make-temp-file "web-get"))) -;; (quack-web-get-to-file url temp-file) -;; temp-file)) - -(defun quack-web-get-to-file-via-wget (url out-file) - ;; TODO: Make this initially download to a temp file; replace any - ;; pre-existing out-file after successful download. Do this for any - ;; external downloader programs that write to the specified output file - ;; before the download is complete. - (let ((window (selected-window)) - (saved-buf (current-buffer)) - (log-buf (get-buffer-create quack-web-get-log-buffer-name))) - (unwind-protect - (progn - ;; Prepare the log buffer. - (set-buffer log-buf) - (widen) - (buffer-disable-undo) - (goto-char (point-min)) - (delete-region (point-min) (point-max)) - (set-window-buffer window log-buf) - ;; Do the wget. - (quack-activity - (format "Getting %S via wget" url) - (let ((status (call-process "wget" nil t t - "-O" out-file "-t" "1" "--" url))) - (unless (= status 0) - (quack-delete-file-if-can out-file) - (error "Could not get %S via wget." url)) - (kill-buffer log-buf) - out-file))) - ;; unwind-protect cleanup - (set-window-buffer window saved-buf) - (set-buffer saved-buf)))) - -;; HTML Kludges: - -(defun quack-strip-limited-html-tags (str) - (save-match-data - (let ((case-fold-search t) - (str-len (length str)) - (frags '()) - (start 0)) - (while (string-match "</?[a-z]+[ \r\n]*>" str start) - (when (> (match-beginning 0) start) - (setq frags (cons (substring str start (match-beginning 0)) frags))) - (setq start (match-end 0))) - (if frags - (progn (when (< start str-len) - (setq frags (cons (substring str start) frags))) - (apply 'concat (reverse frags))) - str)))) - -;; Temp Files: - -(defun quack-temp-dir () - (file-name-as-directory (expand-file-name "tmp" quack-dir))) - -;; TODO: Make sure this gets executed in load phase even if byte-compiled. - -(random t) - -(defun quack-make-temp-file (purpose-str) - ;; Note: There is an obvious race condition here. But we're trying to do - ;; this in portable Elisp, and if user's `quack-dir' is writable by - ;; someone other than user, then user has bigger problems. - (save-excursion - (let* ((buf (generate-new-buffer "*quack-make-temp-file*")) - (dir (quack-temp-dir)) - file) - (set-buffer buf) - (quack-make-directory dir) - (while (progn (setq file (expand-file-name (format "%d-%s-%d" - (emacs-pid) - purpose-str - (random 10000)) - dir)) - (file-exists-p file))) - (set-visited-file-name file) - (save-buffer 0) - (kill-buffer buf) - file))) - -;; About: - -(defun quack-about () - (interactive) - (let* ((buf-name "*About Quack*") - (buf (get-buffer buf-name))) - (when buf (kill-buffer buf)) - (setq buf (get-buffer-create buf-name)) - (switch-to-buffer buf) - (setq buffer-read-only nil) - (widen) - (fundamental-mode) - (when font-lock-mode - ;;(quack-warning "Font-lock mode mysteriously on in fundamental-mode.") - (font-lock-mode -1)) - (buffer-disable-undo) - ;;(delete-region (point-min) (point-max)) - (erase-buffer) - (insert - "\n" - (quack-propertize-face (copy-sequence "Quack") 'quack-about-title-face) - " Version " - (quack-propertize-bold (copy-sequence quack-version)) - "\n" - (quack-propertize-italic - (copy-sequence "Enhanced Emacs support for Scheme programming")) - "\n\n" - "You can email bug reports and feature requests to the author,\n" - quack-author-name - " <" - quack-author-email - ">. Mention that\n" - "you are using " - (quack-propertize-bold - (copy-sequence - (cond (quack-gnuemacs-p "GNU Emacs") - (quack-xemacs-p "XEmacs") - (t "*an unrecognized Emacs kind*")))) - " " - (quack-propertize-bold - (format "%d.%d" emacs-major-version emacs-minor-version)) - " on " - (quack-propertize-bold (copy-sequence system-configuration)) - ".\n\n" - "To be notified via email when new Quack versions are released,\n" - "ask Neil to add you to the moderated " - (quack-propertize-bold "scheme-announce") - " list.\n\n" - "Visit the Web page: " - quack-web-page - "\n") - (insert "\n\n" - (quack-propertize-face (copy-sequence quack-copyright) - 'quack-smallprint-face) - "\n" - (quack-propertize-face (copy-sequence quack-copyright-2) - 'quack-smallprint-face) - "\n\n" - (quack-propertize-face (concat quack-legal-notice "\n") - 'quack-smallprint-face)) - (goto-char (point-min)) - (set-buffer-modified-p nil) - (setq buffer-read-only t) - (local-set-key "q" 'quack-kill-current-buffer) - (local-set-key "w" 'quack-browse-quack-web-page) - (message - "Press `q' to quit *About Quack*, `w' to visit the Quack Web page."))) - -;; PLT Collections: - -(defvar quack-pltcollects-alist-cache nil) - -(defun quack-invalidate-pltcollects-caches () - (setq quack-pltcollects-alist-cache nil) - (quack-invalidate-manuals-caches)) - -(defun quack-pltcollects-alist () - (or quack-pltcollects-alist-cache - (quack-activity - "Scanning PLT collection directories" - (let ((result '())) - (mapcar (function - (lambda (dir) - (mapcar (function - (lambda (subdir) - (unless (member subdir '("." ".." "CVS" "RCS")) - (let ((subdir-path (expand-file-name subdir - dir))) - (when (file-directory-p subdir-path) - (setq result - (cons (cons subdir subdir-path) - result))))))) - (condition-case nil - (directory-files dir) - (file-error nil))))) - quack-pltcollect-dirs) - (setq quack-pltcollects-alist-cache (reverse result)))))) - -(defun quack-dir-for-pltcollect (name) - (cdr (assoc name (quack-pltcollects-alist)))) - -(defun quack-dired-pltcollect () - (interactive) - (let* ((alist (quack-pltcollects-alist)) - (default (if (assoc "mzlib" alist) "mzlib" nil)) - (dir (cdr (assoc - (completing-read - (if default - (format "Dired for PLT collection (default %S): " - default) - "Dired for PLT collection: ") - alist nil t nil nil default) - alist)))) - (and dir (dired dir)))) - -;; Find File: - -(defun quack-shorter-file-relative-name (filename &optional directory) - (let ((absolute (expand-file-name filename directory)) - (relative (file-relative-name filename directory))) - (if (< (length relative) (length absolute)) - relative - absolute))) - -;; TODO: Also write `quack-find-file-other-window' and -;; `quack-find-file-other-frame' and steal appropriate key bindings. - -(defun quack-find-file () - ;; TODO: Hangup/delay problems in mega-huge files. - ;; - ;; TODO: Handle `(load <filename>)' - (interactive) - (let* ((default (quack-find-file-default)) - (entry (let ((insert-default-directory (if default - nil - insert-default-directory))) - (read-file-name - (if default - (format "Quack find file (default %S): " - (quack-shorter-file-relative-name - default - default-directory)) - "Quack find file: ") - default-directory - default)))) - (find-file (if (string= entry "") - (or default "") - entry)))) - -(defun quack-find-file-default () - (or (quack-pltrequire-at-point-filename) - ;; TODO: Add support for syntax from Guile, SLIB, Chicken, etc. - )) - -;; TODO: Guile `:use-module' support. Forget about 1.4, and do 1.6. -;; -;; (defun quack-guilecolonusemodule-at-point-data () -;; (save-match-data -;; (when (thing-at-point-looking-at -;; ":use-module[ \t]+\\(([^][()\"#'`,]+)\\)") -;; (condition-case nil -;; (car (read-from-string (buffer-substring-no-properties -;; (match-beginning 1) (match-end 1)))) -;; (error nil))))) -;; -;; ;; (define-module (ice-9 expect) :use-module (ice-9 regex)) - -;; TODO: Guile 1.6 `use-modules' and `use-syntax' support. -;; -;; (use-modules (ice-9 regex)) -;; -;; (use-modules ((ice-9 popen) -;; :select ((open-pipe . pipe-open) close-pipe) -;; :renamer (symbol-prefix-proc 'unixy:))) -;; -;; (use-modules { SPEC }+ ) -;; -;; SPEC ::= MODULE-NAME | (MODULE-NAME [:select SELECTION] [:renamer RENAMER]) -;; -;; (use-syntax MODULE-NAME) - -;; TODO: Support SLIB-style `require' forms: -;; -;; (require 'foo) - -;; TODO: Bigloo `import' and maybe `extern' support. -;; -;; ;; /usr/share/doc/bigloo-examples/examples/Foreign/ -;; (module example -;; (import (bis foreign2 "foreign2.scm")) -;; ...) -;; -;; ;; /usr/share/doc/bigloo-examples/examples/Fork/ -;; (module sys-example -;; (extern (include "sys/types.h") -;; (include "wait.h") -;; (include "unistd.h") -;; ...)) - -;; TODO: PLT module language syntax: (module info (lib "infotab.ss" "setup") - -(defconst quack-pltrequire-at-point-data-re - (quack-re-alt "dynamic-require" - (concat "require" - (quack-re-alt "-for-syntax" - "")))) - -(defconst quack-pltrequire-at-point-data-1-re - (concat quack-pltrequire-at-point-data-re - "\\>")) - -(defconst quack-pltrequire-at-point-data-2-re - (concat "[^\r\n]*[[(]" - quack-pltrequire-at-point-data-re - "[ \t]+\\([^\r\n]+\\)")) - -(defun quack-pltrequire-at-point-data-1 () - (save-match-data - (let ((qpss (quack-parent-sexp-search quack-pltrequire-at-point-data-1-re - 4))) - (when qpss - (let ((child-start (nth 2 qpss))) - (when child-start - (save-excursion - (goto-char child-start) - (condition-case nil - ;; Note: It is normally OK to use the Elisp reader here. - (read (current-buffer)) - (error nil))))))))) - -(defun quack-pltrequire-at-point-data-2 () - (save-match-data - (when (thing-at-point-looking-at quack-pltrequire-at-point-data-2-re) - (let* ((read-start (match-beginning 2)) - (parts-pt (- (point) read-start)) - (parts (buffer-substring-no-properties read-start - (match-end 2))) - (parts-len (length parts)) - (start 0) - (result '())) - (condition-case nil - (while (< start parts-len) - ;; Note: It is normally OK to use the Elisp reader here. - (let ((r (read-from-string parts start))) - (when (or (not result) (> parts-pt start)) - (setq result (car r))) - (setq start (cdr r)))) - (error nil)) - result)))) - -(defun quack-pltrequire-at-point-filename (&optional silent) - (let* ((d (or (quack-pltrequire-at-point-data-1) - (quack-pltrequire-at-point-data-2))) - (m (cond - ((not d) nil) - ((stringp d) d) - ((listp d) - (let ((f (car d))) - (when (symbolp f) - (cond ((memq f '(file lib)) d) - ((memq f '(all-except rename)) (nth 1 d)) - ((memq f '(prefix prefix-all-except)) (nth 2 d))))))))) - (cond - ((stringp m) m) - ((listp m) - (let ((f (car m))) - (when (symbolp f) - (cond ((eq f 'file) (nth 1 f)) - ((eq f 'lib) - (let* ((file (nth 1 m)) - (collect (or (nth 2 m) "mzlib")) - (collect-dir (quack-dir-for-pltcollect collect)) - (subs (nthcdr 3 m))) - (when file - (if collect-dir - (quack-expand-file-name (nconc subs (list file)) - collect-dir) - (unless silent - (quack-warning "Cannot find collection %S" collect)) - nil))))))))))) - -;; Indenting Newline: - -(defun quack-newline (&optional arg) - (interactive "*P") - (if (eq quack-newline-behavior 'newline) - (newline arg) - (if (eq quack-newline-behavior 'indent-newline-indent) - (lisp-indent-line) - (unless (eq quack-newline-behavior 'newline-indent) - (error "invalid quack-newline-behavior value: %s" - quack-newline-behavior))) - (let ((n (prefix-numeric-value arg))) - (when (> n 0) - (while (> n 0) - (setq n (1- n)) - (quack-delete-horizontal-space t) - (newline)) - (lisp-indent-line))))) - -;; Agreeing-Paren Insert: - -;; TODO: Make paren-matching within comments limit seaching to within comments, -;; not skip back and try to match code. One workaround is to prefix -;; parents/brackets in comments with backslash. - -(defun quack-insert-closing (prefix default-close other-open other-close) - (insert default-close) - (unless prefix - (let ((open-pt (condition-case nil - (scan-sexps (point) -1) - (error (beep) nil)))) - (when open-pt - (let ((open-char (aref (buffer-substring-no-properties - open-pt (1+ open-pt)) - 0))) - (when (= open-char other-open) - (delete-backward-char 1) - (insert other-close)))))) - (when blink-paren-function (funcall blink-paren-function))) - -(defun quack-insert-closing-paren (&optional prefix) - (interactive "P") - (quack-insert-closing prefix ?\) ?\[ ?\])) - -(defun quack-insert-closing-bracket (&optional prefix) - (interactive "P") - (quack-insert-closing prefix ?\] ?\( ?\))) - -;; Opening-Paren Insert: - -(defun quack-insert-opening (prefix char) - (insert (if (or prefix (not quack-smart-open-paren-p)) char ?\()) - (when blink-paren-function (funcall blink-paren-function))) - -(defun quack-insert-opening-paren (&optional prefix) - (interactive "P") - (quack-insert-opening prefix ?\()) - -(defun quack-insert-opening-bracket (&optional prefix) - (interactive "P") - (quack-insert-opening prefix ?\[)) - -;; Definition Lambda Syntax Toggling: - -(defconst quack-toggle-lambda-re-1 - (concat "define\\*?" - (quack-re-alt "-for-syntax" - "-public" - "/override" - "/private" - "/public" - ""))) - -(defconst quack-toggle-lambda-re-2 - (let ((ws-opt "[ \t\r\n\f]*") - (symbol "[^][() \t\r\n\f]+") - (open-paren "[[(]") - (close-paren "[])]")) - (concat ws-opt - (quack-re-alt ; #=1 - (concat "\\(" ; #<2 `NAME (lambda (' - "\\(" ; #<3 name - symbol - "\\)" ; #>3 - ws-opt - open-paren - ws-opt - "lambda" - ws-opt - open-paren - ws-opt - "\\)") - (concat "\\(" ; #<4 `(NAME' - open-paren - ws-opt - "\\(" ; #<5 name - symbol - "\\)" ; #>5 - ws-opt - "\\)")) - "\\(" ; #<6 optional close paren - close-paren - "\\)?" ; #>6 - ))) - -(defun quack-toggle-lambda () - (interactive) - (save-match-data - (let ((found (quack-parent-sexp-search quack-toggle-lambda-re-1)) - last-paren-marker - leave-point-marker) - (unless found - (error "Sorry, this does not appear to be a definition form.")) - (unwind-protect - (let ((lexeme-end (nth 1 found)) - (define-beg (nth 3 found))) - - ;; Make the markers. - (setq last-paren-marker (make-marker)) - (setq leave-point-marker (point-marker)) - - ;; Move to right after the define form keyword, and match the - ;; pattern of the two possible syntaxes. Error if no match. - (goto-char lexeme-end) - (unless (looking-at quack-toggle-lambda-re-2) - (error "Sorry, we can't grok this definition syntax.")) - - ;; Pattern matched, so find the closing paren of the define form. - (let ((pt (condition-case nil - (scan-sexps define-beg 1) - (error ; scan-error - nil)))) - (if pt - (set-marker last-paren-marker (1- pt)) - (quack-warning - "This definition form sexp is unclosed. Consider undo."))) - - ;; Now act based on which syntax we saw. - (cond - - ((match-beginning 2) - ;; We saw the syntax `NAME (lambda ('. - (let ((name (quack-match-string-no-properties 3))) - (when (marker-position last-paren-marker) - (goto-char last-paren-marker) - (let ((victim-beg (quack-looking-at-close-paren-backward))) - (unless victim-beg - (error "This definition form should end with `))'.")) - (delete-region victim-beg (point)))) - (goto-char lexeme-end) - (delete-region lexeme-end (match-end 2)) - (insert " (" name (if (match-beginning 6) "" " ")))) - - ((match-beginning 4) - ;; We saw the syntax `(NAME'. - (let ((name (quack-match-string-no-properties 5))) - (when (marker-position last-paren-marker) - (goto-char last-paren-marker) - (insert ")")) - (goto-char lexeme-end) - (delete-region lexeme-end (match-end 4)) - (insert " " name "\n") - (set-marker leave-point-marker (point)) - (insert "(lambda (") - (set-marker-insertion-type leave-point-marker t))) - - (t (quack-internal-error))) - - ;; Reindent, which also takes care of font-lock updating of deleted - ;; and inserted text. - (indent-region define-beg - (or (marker-position last-paren-marker) - (max (marker-position leave-point-marker) - (point))) - nil)) - - ;; unwind-protect cleanup - (goto-char (marker-position leave-point-marker)) - (set-marker leave-point-marker nil))))) - -;; Buffer Tidying: - -;; TODO: Maybe have an option to automatically tidy the buffer on save. Make -;; default off. This can be slow for larger buffers on older computers, -;; especially if font-lock is activated. It can also annoy people who -;; have a CM system full of improperly formatted files, or who like -;; things like formfeed characters in their files. - -(defun quack-delete-all-in-buffer (regexp &optional subexp) - (unless subexp (setq subexp 0)) - ;; Note: This moves the point and changes the match data. - (goto-char (point-min)) - (while (re-search-forward regexp nil t) - (goto-char (match-end subexp)) - (delete-region (match-beginning subexp) (point)))) - -(defun quack-tidy-buffer () - - ;; TODO: Make sure this works with odd eol conventions and the various - ;; codeset representations in various versions of Emacs. - - ;; TODO: Maybe detect DrScheme ASCII-art "big letters" and protect them from - ;; reindenting. - - "Tidy the formatting of the current Scheme buffer. - -This reindents, converts tabs to spaces, removes trailing whitespace on lines, -removes formfeed characters, removes extraneous blank lines, and makes sure -the buffer ends with a newline. - -This can conceivably corrupt multi-line string literals, but not in any way -they wouldn't be corrupted by Usenet, various mailers, typesetting for print, -etc. - -This may also result in large diffs when the tidied file is commited back to a -version control or configuration management system. Consider making a VC or CM -delta that consists only of changes made by `quack-tidy-buffer'." - (interactive) - (if (= (point-min) (point-max)) - (message "Buffer is empty; no tidying necessary.") - (let ((marker (point-marker)) - (fill-prefix nil)) - (unwind-protect - (save-excursion - (save-match-data - (quack-activity - "Tidying buffer" - - ;; Make sure last character is a newline. - (unless (string= "\n" (buffer-substring-no-properties - (1- (point-max)) - (point-max))) - (goto-char (point-max)) - (insert "\n")) - - ;; Remove form-feed characters. - (quack-delete-all-in-buffer "\f") - - ;; Reindent buffer (without inserting any new tabs). - ;; Note: This is the time-consuming pass. - (let ((saved-indent-tabs-mode indent-tabs-mode)) - (unwind-protect - (progn (setq indent-tabs-mode nil) - (indent-region (point-min) (point-max) nil)) - ;; unwind-protect cleanup - (setq indent-tabs-mode saved-indent-tabs-mode))) - - ;; Expand any remaining tabs. - (untabify (point-min) (point-max)) - - ;; Remove trailing whitespace on each line. - (quack-delete-all-in-buffer "\\([ \t\r]+\\)\n" 1) - - ;; Remove blank lines from top. - (goto-char (point-min)) - (when (looking-at "[ \t\r\n]+") - (delete-region (match-beginning 0) (match-end 0))) - - ;; Remove excess adjacent blank lines. - (quack-delete-all-in-buffer "\n\n\\(\n+\\)" 1) - - ;; Remove blank lines from bottom. - (goto-char (point-max)) - (when (quack-looking-at-backward - "\n\\(\n\\)" - (max (point-min) (- (point-max) 3))) - (delete-region (match-beginning 1) (match-end 1)))))) - - ;; unwind-protect cleanup - (goto-char (marker-position marker)) - (set-marker marker nil))))) - -;; SRFIs: - -;; TODO: Archive local copies of SRFIs? Have to update them when modified, but -;; without unnecessarily downloading from the master site. This is -;; doable with wget mirroring, but not with things like "lynx -source". - -(defconst quack-srfi-subindex-kinds '(draft final withdrawn) - "List of symbols representing the three possible states of an SRFI (`draft', -`final', and `withdrawn'), in order of increasing precedence (e.g., final -follows draft,since a final version supercedes a draft version).") - -(defvar quack-srfi-completes-cache 'invalid) -(defvar quack-srfi-menu-cache 'invalid) - -(defun quack-srfi-completes () - (when (eq quack-srfi-completes-cache 'invalid) - (quack-process-srfi-subindex-files)) - quack-srfi-completes-cache) - -(defun quack-srfi-menu (&optional noninteractive) - (when (eq quack-srfi-menu-cache 'invalid) - (quack-process-srfi-subindex-files noninteractive)) - quack-srfi-menu-cache) - -(defun quack-srfi-master-url (path) - (quack-build-url quack-srfi-master-base-url path)) - -(defun quack-srfi-subindex-master-url (kind) - (quack-srfi-master-url (list (quack-srfi-subindex-basename kind)))) - -(defun quack-srfi-dir () - (file-name-as-directory (expand-file-name "srfi" quack-dir))) - -(defun quack-srfi-subindex-file (kind) - (expand-file-name (quack-srfi-subindex-basename kind) (quack-srfi-dir))) - -(defun quack-srfi-subindex-basename (kind) - (format "%S-srfis.html" kind)) - -(defun quack-invalidate-srfi-index-caches () - (setq quack-srfi-completes-cache 'invalid) - (setq quack-srfi-menu-cache 'invalid)) - -(defun quack-update-srfi-index () - (interactive) - (quack-activity - "Updating SRFI index" - (quack-download-srfi-subindex-files))) - -(defun quack-download-srfi-subindex-files () - (quack-invalidate-srfi-index-caches) - (mapcar (function - (lambda (kind) - (quack-activity - (format "Downloading %s SRFI subindex" kind) - (quack-web-get-to-file (quack-srfi-subindex-master-url kind) - (quack-srfi-subindex-file kind))))) - quack-srfi-subindex-kinds)) - -(defun quack-download-srfi-subindex-files-if-missing () - (let ((missing '())) - (mapcar (function - (lambda (kind) - (unless (file-exists-p (quack-srfi-subindex-file kind)) - (setq missing (nconc missing (list kind)))))) - quack-srfi-subindex-kinds) - (when (and missing - (y-or-n-p "Some cached SRFI subindexes are missing. Update? ")) - (quack-update-srfi-index)))) - -(defun quack-process-srfi-subindex-files (&optional noninteractive) - (let ((index '()) - (completes '()) - (menu (mapcar (function (lambda (kind) (cons kind nil))) - quack-srfi-subindex-kinds))) - - ;; Invalidate dependent caches. - (quack-invalidate-srfi-index-caches) - - ;; Give user a chance to download any missing cache files all at once, - ;; instead of prompting individually later. - (unless noninteractive - (quack-download-srfi-subindex-files-if-missing)) - - ;; Parse the index files, letting entries for successive states supercede. - (mapcar (function - (lambda (kind) - (mapcar (function - (lambda (new) - (let (old) - (if (setq old (assq (car new) index)) - (setcdr old (cdr new)) - (setq index (cons new index)))))) - (quack-parse-srfi-subindex-file kind noninteractive)))) - quack-srfi-subindex-kinds) - - ;; Sort the parse form in reverse order, since the cache-building functions - ;; will reverse this. - (setq index (sort index (function (lambda (a b) (>= (car a) (car b)))))) - - ;; Build the completions and menu caches. - (let ((fmt (concat "%" - (if index - (number-to-string - (length (number-to-string (car (car index))))) - "") - "d %s"))) - (mapcar (function - (lambda (n) - (let ((num (nth 0 n)) - (kind (nth 1 n)) - (title (nth 2 n))) - (unless kind (quack-internal-error)) - (setq completes - (cons (cons (if (eq kind 'final) - (format "%d %s" num title) - (format "%d [%s] %s" num kind title)) - num) - completes)) - (let ((pair (or (assq kind menu) - (quack-internal-error)))) - (setcdr pair (cons `[,(format fmt num title) - (quack-view-srfi ,num)] - (cdr pair))))))) - index)) - - ;; Finish the menu. - (mapcar (function (lambda (n) - (setcar n (cdr (assoc (car n) - '((draft . "Draft") - (final . "Final") - (withdrawn . "Withdrawn"))))) - ;; Add dummy content so that XEmacs 21 will display - ;; the submenu label. - (unless (cdr n) - (setcdr n (cons "(None)" nil))))) - menu) - (setq menu `(["Update SRFI Index" quack-update-srfi-index] - "---" - ,@menu - ["Other SRFI..." quack-view-srfi])) - - ;; Store the results. - (setq quack-srfi-menu-cache menu) - (setq quack-srfi-completes-cache completes))) - -(defun quack-parse-srfi-subindex-file (kind &optional noninteractive) - (save-excursion - (let ((file (quack-srfi-subindex-file kind))) - (unless (file-exists-p file) - (error "No SRFI index file %S" file)) - (let* ((buf (get-file-buffer file)) - (already-visiting-p buf)) - (unless buf - (setq buf (find-file-noselect file t t))) - (unwind-protect - (progn (set-buffer buf) - (quack-parse-srfi-subindex-buffer kind)) - ;; unwind-protect-cleanup - (unless already-visiting-p - (kill-buffer buf))))))) - -(defconst quack-parse-srfi-index-buffer-re-1 - (concat - "<LI><A HREF=\"?srfi-[0-9]+/?\"?>SRFI[ \t]+" - "\\([0-9]+\\)" ; #=1 srfi number - "</A>:?[ \t]*" - "\\(" ; #<2 srfi title - ; #=3 - (quack-re-alt "[^\r\n<>]" "</?[a-z]+>") - "+" - "\\)")) - -(defun quack-parse-srfi-subindex-buffer (kind) - (save-excursion - (let ((case-fold-search t) - (alist '())) - (goto-char (point-min)) - (while (re-search-forward quack-parse-srfi-index-buffer-re-1 nil t) - (let ((number (string-to-number (quack-match-string-no-properties 1))) - (title (quack-without-side-whitespace - (quack-strip-limited-html-tags - (quack-match-string-no-properties 2))))) - (setq alist (cons - - ;;(cons number - ;; (if (and kind (not (eq kind 'final))) - ;; (format "[%s] %s" kind title) - ;; title)) - (list number kind title) - - alist)))) - (setq alist (reverse alist))))) - -(defun quack-srfi-num-url (num) - (quack-srfi-master-url (list (format "srfi-%d" num) - (format "srfi-%d.html" num)))) - -(defconst quack-srfi-num-at-point-re-1 - "srfi[-: \t]*\\([0-9]+\\)") - -(defconst quack-srfi-num-at-point-re-2 - ;; Note: We can't have "[^\r\n]*" as a prefix, since it's too slow. - (concat quack-srfi-num-at-point-re-1 "[^\r\n]*")) - -(defun quack-srfi-num-at-point () - ;; TODO: Make this get the nearest SRFI number in all cases. - (save-match-data - (let ((case-fold-search t)) - (cond ((thing-at-point-looking-at quack-srfi-num-at-point-re-1) - (string-to-number (quack-match-string-no-properties 1))) - ((thing-at-point-looking-at "[0-9]+") - (string-to-number (quack-match-string-no-properties 0))) - ((thing-at-point-looking-at quack-srfi-num-at-point-re-2) - (string-to-number (quack-match-string-no-properties 1))) - ((let ((str (quack-line-at-point))) - (when (string-match quack-srfi-num-at-point-re-1 str) - (string-to-number - (quack-match-string-no-properties 1 str))))))))) - -(defun quack-view-srfi (num) - (interactive (list (quack-srfi-num-prompt "View SRFI number"))) - (when num - (unless (and (integerp num) (>= num 0)) - (error "Not a valid SRFI number: %S" num)) - (quack-browse-url (quack-srfi-num-url num)))) - -(defun quack-srfi-num-prompt (prompt) - (let* ((completes (quack-srfi-completes)) - (default (quack-srfi-num-at-point)) - (input (quack-without-side-whitespace - (completing-read - (if default - (format "%s (default %d): " prompt default) - (concat prompt ": ")) - completes))) - v) - (cond ((or (not input) (string= "" input)) default) - ((setq v (assoc input completes)) (cdr v)) - ((and (setq v (condition-case nil - (string-to-number input) - (error nil))) - (integerp v) - (>= v 0)) - v) - (t (error "Invalid SRFI number: %s" input))))) - -;; Doc Keyword Value Object: - -(defmacro quack-kw-get-syntax (o) `(aref ,o 0)) -(defmacro quack-kw-get-file (o) `(aref ,o 1)) -(defmacro quack-kw-get-fragment (o) `(aref ,o 2)) - -(defmacro quack-kw-set-syntax (o v) `(aset ,o 0 ,v)) -(defmacro quack-kw-set-file (o v) `(aset ,o 1 ,v)) -(defmacro quack-kw-set-fragment (o v) `(aset ,o 2 ,v)) - -;; Documentation Object: - -;; TODO: Rework these document representations once we know the different kinds -;; of documents with which we'll be dealing. - -(defmacro quack-doc-get-type (o) `(aref ,o 0)) -(defmacro quack-doc-get-sym (o) `(aref ,o 1)) -(defmacro quack-doc-get-title (o) `(aref ,o 2)) -(defmacro quack-doc-get-loc (o) `(aref ,o 3)) -(defmacro quack-doc-get-kw-p (o) `(aref ,o 4)) -(defmacro quack-doc-get-start-url (o) `(aref ,o 5)) -(defmacro quack-doc-get-kw-base-url (o) `(aref ,o 6)) -(defmacro quack-doc-get-kw-file (o) `(aref ,o 7)) -(defmacro quack-doc-get-kw-hashtable (o) `(aref ,o 8)) - -(defmacro quack-doc-set-type (o v) `(aset ,o 0 ,v)) -(defmacro quack-doc-set-sym (o v) `(aset ,o 1 ,v)) -(defmacro quack-doc-set-title (o v) `(aset ,o 2 ,v)) -(defmacro quack-doc-set-loc (o v) `(aset ,o 3 ,v)) -(defmacro quack-doc-set-kw-p (o v) `(aset ,o 4 ,v)) -(defmacro quack-doc-set-start-url (o v) `(aset ,o 5 ,v)) -(defmacro quack-doc-set-kw-base-url (o v) `(aset ,o 6 ,v)) -(defmacro quack-doc-set-kw-file (o v) `(aset ,o 7 ,v)) -(defmacro quack-doc-set-kw-hashtable (o v) `(aset ,o 8 ,v)) - -(defun quack-manual-to-doc (manual) - ;; Accepts a user's manual preference object of the list form: - ;; - ;; (SYM TITLE LOC KW-P) - ;; - ;; and creates a manual doc object of the vector form: - ;; - ;; [manual SYM TITLE LOC KW-P START-URL KW-BASE-URL KW-FILE KW-P - ;; KEYWORDS] - ;; - ;; KEYWORDS is not populated here -- keywords importing for a manual happens - ;; the first time keyword searching is done for the manual." - (let ((sym (nth 0 manual)) - (title (nth 1 manual)) - (loc (nth 2 manual)) - (kw-p (nth 3 manual)) - (start-url nil) - (kw-file nil) - (kw-base nil)) - (cond - ;; If the location is a string, then handle manual as simple URL. - ((stringp loc) - (setq start-url loc) - (when kw-p - (quack-warning "Quack can only use keywords for PLT manuals.") - (setq kw-p nil))) - ;; If the location is a symbol, handle manual as special. - ((symbolp loc) - (cond - ;; If the location is symbol `plt', handle manual as PLT bundled. - ((eq loc 'plt) - (let* ((plt-name (let ((s (symbol-name sym))) - (if (string-match "\\`plt-\\(.+\\)\\'" s) - (match-string 1 s) - s))) - (web-base (concat - "http://download.plt-scheme.org/doc/" - plt-name - "/")) - (index-name "index.htm") - (col-dirs quack-pltcollect-dirs)) - ;; Search from the collection directories for keywords and index - ;; files. Note that we currently look for keywords files even if - ;; `kw-p' is false since we want to allow the user to dynamically - ;; enable and disable keywords searching for a particular manual - ;; without us having to change `quack-docs'. - (while (and col-dirs (not (and kw-file kw-base start-url))) - (let ((dir (expand-file-name plt-name - (expand-file-name "doc" - (car col-dirs))))) - (setq col-dirs (cdr col-dirs)) - (when (file-directory-p dir) - (let* ((k-f (expand-file-name "keywords" dir)) - (i-f (expand-file-name index-name dir)) - (i-r (file-readable-p i-f))) - (if (file-readable-p k-f) - ;; Keywords file. - (if i-r - ;; Keywords file and index file. So, unless we - ;; already found a keywords base URL, set everything - ;; based on this directory. Note that we override - ;; any existing start URL because we prefer to use - ;; the same manual version for both keywords and - ;; non-keywords access. - (unless kw-base - (setq kw-file k-f) - (setq kw-base (quack-file-url dir nil)) - (setq start-url (quack-file-url dir index-name))) - ;; Keywords file, but no index file. So, unless we - ;; already have a keywords file, set it to this one. - (unless kw-file - (setq kw-file k-f))) - ;; No keywords file. So, if there is an index file, and we - ;; don't already have one, then use this one. - (when (and i-r (not start-url)) - (setq start-url (quack-file-url dir index-name)))))))) - ;; If we didn't find a start URL, use the Web one. - (unless start-url - (setq start-url (concat web-base index-name))) - ;; Do we have a keywords file? - (if kw-file - ;; We have a keywords file, so set the keywords base to the Web - ;; if needed and desired. Note that we never use the keywords - ;; file from one directory with the HTML files from a different - ;; directory, on the assumption that a local copy of HTML missing - ;; a keywords file is suspect, and that the Web version is - ;; therefore preferable. - (when (or (eq quack-local-keywords-for-remote-manuals-p 'always) - (and (not kw-base) - quack-local-keywords-for-remote-manuals-p)) - (setq kw-base web-base)) - ;; We don't have a keywords file, so warn if the user wanted - ;; keywords for this manual. - (when kw-p - (quack-warning "Could not find keywords file for manual %S." - plt-name))))) - ;; The location is an unrecognized symbol, so just barf. - (t (quack-internal-error)))) - ;; The location is something other than a string or symbol, so just barf. - (t (quack-internal-error))) - ;; We've populated all the variables for the location type, so return the - ;; representation. - (vector 'manual sym title loc kw-p start-url kw-base kw-file nil))) - -(defun quack-doc-keyword-lookup (doc keyword) - (let ((ht (or (quack-doc-get-kw-hashtable doc) - (progn (quack-doc-import-keywords doc) - (quack-doc-get-kw-hashtable doc))))) - (if ht - (quack-gethash keyword ht nil) - (quack-warning "No keywords for document \"%S\"." - (quack-doc-get-sym doc)) - nil))) - -(defun quack-doc-import-keywords (doc) - (if (eq (quack-doc-get-loc doc) 'plt) - (quack-doc-import-plt-manual-keywords doc) - (quack-internal-error))) - -(defun quack-doc-import-plt-manual-keywords (doc) - ;; Reads in the predetermined keywords file for PLT manual `doc' object, - ;; populating the `kw-hashtable' field of the `doc' object. The format of - ;; each entry in the PLT keywords file is a list of 5 strings: - ;; - ;; (KEYWORD SYNTAX FILE FRAGMENT SECTION) - ;; - ;; The hashtable is keyed on the KEYWORD string, for which the value is - ;; usually a vector: - ;; - ;; [SYNTAX FILE-CONST FRAGMENT] - ;; - ;; where FILE-CONST is the FILE string registered with the `quack-strconst' - ;; to save memory on redundant strings. - ;; - ;; When more there is more than one entry for a given keyword, then the value - ;; of the hashtable entry for that keyword is a list of vectors, in the order - ;; in which they were derived from the original keywords file. - ;; - ;; These duplicate values may be duplicated or conflicting, as in: - ;; - ;; (["(regexp-match pattern input-port [start-k end-k output-port])" - ;; "mzscheme-Z-H-10.html" "%_kw_definitionregexp-match"] - ;; ["(regexp-match pattern string [start-k end-k output-port])" - ;; "mzscheme-Z-H-10.html" "%_kw_definitionregexp-match"]) - ;; - ;; No attempt is made here to weed out any duplicate/conflicting entries -- - ;; that behavior left up to the code that accesses the hashtable. For the - ;; example above, a command to display the syntax for the keyword would need - ;; to display both values. However, a command to view the documentation for - ;; the keyword would need only to display one Web page without querying the - ;; user, since both entries above point to the same page and fragment. - (quack-activity - (format "Importing keywords for manual %S" (quack-doc-get-sym doc)) - (let (sexp) - (garbage-collect) - (condition-case err - (setq sexp (quack-read-sexp-file - (or (quack-doc-get-kw-file doc) - (quack-warning "Manual %S has no keywords file." - (quack-doc-get-sym doc))))) - (error (quack-warning "Problem importing keywords for manual %S: %s" - (quack-doc-get-sym doc) err))) - (when sexp - (garbage-collect) - (let ((ht (quack-make-hash-table :test 'equal - :size (length sexp) - :rehash-threshold 1.0))) - ;; Note: We make the hashtable equal to the length of the read list of - ;; keyword forms so that it will be at least large enough for all the - ;; keywords without being excessively overlarge, and without having to - ;; do resizes or a counting pass or intermediate representation. The - ;; hashtable will be a little larger than necessary when there are - ;; multiple keyword forms for the same keyword. In a test with - ;; MzScheme 200.2, the hashtable used/size for "mzscheme" manual was - ;; 489/502; for "mzlib", 245/257. - (quack-doc-set-kw-hashtable doc ht) - (mapcar (function - (lambda (raw-entry) - (let* ((kw (nth 0 raw-entry)) - (new (vector (nth 1 raw-entry) - (quack-strconst (nth 2 raw-entry)) - (nth 3 raw-entry))) - (old (quack-gethash kw ht nil))) - (quack-puthash - kw - (cond ((not old) new) - ((vectorp old) (list old new)) - ((listp old) (nconc old (list new)))) - ht)))) - sexp)))))) - -(defun quack-read-sexp-file (filename) - (save-excursion - (let* ((buf (generate-new-buffer "*quack-read-sexp-file*"))) - (set-buffer buf) - (unwind-protect - (progn (insert-file-contents-literally filename) - (goto-char (point-min)) - (read buf)) - ;; unwind-protect cleanup - (kill-buffer buf))))) - -;; Documentation Database: - -(defvar quack-docs 'invalid) - -(defun quack-docs () - (when (eq quack-docs 'invalid) - (quack-docs-build)) - quack-docs) - -(defun quack-docs-build () - (quack-activity - "Building Quack docs database" - (quack-invalidate-manuals-caches) - (setq quack-docs (mapcar 'quack-manual-to-doc quack-manuals)))) - -(defun quack-docs-manual-lookup (sym) - (let ((docs (quack-docs)) - (found nil)) - (while (and docs (not found)) - (let ((doc (car docs))) - (setq docs (cdr docs)) - (when (eq (quack-doc-get-sym doc) sym) - (setq found doc)))) - found)) - -(defun quack-docs-manual-keyword-lookup (keyword) - (let ((results '())) - (mapcar (function - (lambda (doc) - (cond - ((not (quack-doc-get-kw-p doc)) nil) - ((not (quack-doc-get-kw-base-url doc)) - (quack-warning "Manual %S has no HTML." - (quack-doc-get-sym doc))) - (t (let ((match (quack-doc-keyword-lookup doc keyword))) - (cond - ((not match) nil) - ((vectorp match) - (setq results (cons (cons doc match) results))) - ((listp match) - (mapcar (function - (lambda (m) - (setq results (cons (cons doc m) results)))) - match)) - (t (quack-internal-error)))))))) - (quack-docs)) - (reverse results))) - -;; Keyword Lookup Match Object: - -(defmacro quack-kwmatch-get-doc (o) `(car ,o)) -(defmacro quack-kwmatch-get-kw (o) `(cdr ,o)) - -(defun quack-kwmatch-url (kwmatch) - (let ((doc (car kwmatch)) - (kw (cdr kwmatch))) - (concat (quack-doc-get-kw-base-url doc) - (quack-quote-url-substring (quack-kw-get-file kw)) - "#" - (quack-quote-url-substring (quack-kw-get-fragment kw) t)))) - -;; Manual Viewing: - -(defun quack-view-manual (&optional sym) - "View a manual." - (interactive - (list - (let* ((completes (or (quack-manuals-completes) - (error - "Sorry, variable \"quack-manuals\" is empty."))) - (default "R5RS") - (input (let ((completion-ignore-case t)) - (completing-read - (format "Quack Manual (default %S): " default) - completes nil t nil nil default)))) - (cdr (or (assoc input completes) - (error "No manual %S." input)))))) - (quack-activity - (format "Viewing manual \"%S\"" sym) - (quack-browse-url (or (quack-doc-get-start-url - (or (quack-docs-manual-lookup sym) - (error "Manual \"%S\" not found." sym))) - (error "Don't know a URL for manual \"%S\"." sym))))) - -(defvar quack-manuals-menu-cache 'invalid) -(defvar quack-manuals-completes-cache 'invalid) - -(defun quack-invalidate-manuals-caches () - (setq quack-docs 'invalid) - (setq quack-manuals-completes-cache 'invalid) - (setq quack-manuals-menu-cache 'invalid)) - -;;(quack-invalidate-manuals-caches) - -;; This version maps completion strings to URLs. -;; (defun quack-manuals-completes () -;; (when (eq quack-manuals-completes-cache 'invalid) -;; (let ((completes '())) -;; (mapcar (function -;; (lambda (doc) -;; (let ((sym (quack-doc-get-sym doc)) -;; (url (quack-doc-get-start-url doc))) -;; (setq completes -;; (cons (cons (quack-doc-get-title doc) url) -;; (cons (cons (symbol-name sym) url) -;; completes)))))) -;; (quack-docs)) -;; (setq quack-manuals-completes-cache (reverse completes)))) -;; quack-manuals-completes-cache) - -(defun quack-manuals-completes () - (when (eq quack-manuals-completes-cache 'invalid) - (let ((completes '())) - (mapcar (function - (lambda (doc) - (let ((sym (quack-doc-get-sym doc)) - ;;(url (quack-doc-get-start-url doc)) - ) - (setq completes - (cons (cons (quack-doc-get-title doc) sym) - ;;(cons (cons (symbol-name sym) sym) - completes - ;;) - ))))) - (quack-docs)) - (setq quack-manuals-completes-cache (reverse completes)))) - quack-manuals-completes-cache) - -(defun quack-manuals-menu () - (when (eq quack-manuals-menu-cache 'invalid) - (setq quack-manuals-menu-cache - (mapcar (function - (lambda (manual) - (let ((sym (nth 0 manual)) - (title (nth 1 manual))) - `[,title (quack-view-manual (quote ,sym))]))) - quack-manuals))) - quack-manuals-menu-cache) - -(defun quack-manuals-webjump-sites () - "Returns `webjump' entries for manuals in `quack-manuals'. - -Can be used in your `~/.emacs' file something like this: - - (require 'quack) - (require 'webjump) - (require 'webjump-plus) - (setq webjump-sites - (append my-own-manually-maintained-webjump-sites - (quack-manuals-webjump-sites) - webjump-plus-sites - webjump-sample-sites))" - ;; TODO: Note what they should do if they are adding to plt collectsion dirs - ;; via custom settings but quack-manuals-webjump-sites is getting - ;; called before then. - (let ((result '()) - (quack-quiet-warnings-p t)) - (mapcar (function - (lambda (doc) - (let ((url (quack-doc-get-start-url doc))) - (when url - (setq result (cons (cons (quack-doc-get-title doc) url) - result)))))) - (quack-docs)) - result)) - -;; Keyword Docs Viewing: - -;; TODO: Add doc lookup in PLT "doc.txt" files. A little tricky. Maybe make -;; sure doc.txt is a long-term format first. - -(defun quack-view-keyword-docs (keyword) - ;; TODO: Don't prompt if all choices would result in the same URL. - (interactive (list (quack-prompt-for-keyword "View docs for keyword"))) - (when (and keyword (stringp keyword) (not (string= keyword ""))) - (let ((matches (quack-docs-manual-keyword-lookup keyword))) - (if (not matches) - (message "Sorry, no documentation found for keyword %S." keyword) - (quack-browse-url - (quack-kwmatch-url - (if (cdr matches) - (quack-prompt-for-kwmatch-choice "Which" matches) - (car matches)))))))) - -(defun quack-keyword-at-point () - ;; TODO: Make sure this reads all Scheme symbols -- it may currently only - ;; read valid Elisp symbols. - (let ((bounds (bounds-of-thing-at-point 'symbol))) - ;; In some cases (point at beginning of empty buffer?), `bounds' will be - ;; the bounds of an empty string, so check this. - (when bounds - (let ((beg (car bounds)) - (end (cdr bounds))) - (when (/= beg end) - (buffer-substring-no-properties beg end)))))) - -(defun quack-prompt-for-keyword (prompt) - (let* ((default (quack-keyword-at-point)) - (history (list default))) - (read-string (if default - (format "%s (default %S): " prompt default) - (concat prompt ": ")) - nil - ;; Note: Gratuitous reference to `history' eliminates warning - ;; from XEmacs 21 byte-compiler. - (if (and default history) 'history nil) - default))) - -(defun quack-prompt-for-kwmatch-choice (prompt kwmatch-list) - (let ((completes '())) - ;; Build the completion alist, ensure each key is unique. - (mapcar - (function - (lambda (kwmatch) - (let* ((kw (quack-kwmatch-get-kw kwmatch)) - (orig-name (or (quack-kw-get-syntax kw) - (progn (quack-warning "No keyword syntax: %s" - kw) - "???"))) - (name orig-name) - (name-tries 1)) - ;; Ensure the name is unique within the completion list thus far. - (while (assoc name completes) - (setq name-tries (1+ name-tries)) - (setq name (format "%s #%d" orig-name name-tries))) - ;; Prepend to the completion list (we'll reverse the list later). - (setq completes (cons (cons name kwmatch) completes))))) - kwmatch-list) - (setq completes (reverse completes)) - ;; Prompt user and return selection. - (let* ((default (car (car completes))) - (read (let ((completion-ignore-case t)) - (completing-read - (format "%s (default %S): " prompt default) - completes nil t nil nil default)))) - (cdr (assoc read completes))))) - -;; Inferior Process: - -(defvar quack-run-scheme-prompt-history '()) - -(defun quack-remember-program-maybe (program) - (when (and quack-remember-new-programs-p - (not (member program quack-programs))) - (quack-option-set 'quack-programs (cons program quack-programs) t) - (message "Remembering program %S." program))) - -(defun quack-run-scheme-prompt () - (let* ((last (car quack-run-scheme-prompt-history)) - (default (or (and quack-run-scheme-prompt-defaults-to-last-p - last) - quack-default-program - scheme-program-name - last - "mzscheme")) - (program (let ((minibuffer-allow-text-properties nil)) - (completing-read - (concat "Run Scheme" - (if default - (format " (default %S)" default) - "") - ": ") - (quack-run-scheme-prompt-completion-collection) - nil nil nil - 'quack-run-scheme-prompt-history - default)))) - (quack-remember-program-maybe program) - program)) - -(defun quack-run-scheme-prompt-completion-collection () - (let ((program-list quack-programs)) - (mapcar (function (lambda (program) - (and program - (not (member program program-list)) - (setq program-list (cons program program-list))))) - (list quack-default-program - scheme-program-name)) - (mapcar (function (lambda (program) (cons program nil))) - program-list))) - -(defadvice run-scheme (around quack-ad-run first nil activate) - "Adds prompting for which Scheme interpreter program to run." - ;; We don't want to prompt if there's already a Scheme running, but it's - ;; possible for process to die between the comint check in `interactive' form - ;; of this advice and the comint check in the `run-scheme' function. We - ;; should override `run-scheme' altogether, but for now let's only call the - ;; original in the case that we do not detect a running Scheme. - (interactive (list (cond ((comint-check-proc "*scheme*") nil) - ((or current-prefix-arg - quack-run-scheme-always-prompts-p) - (quack-run-scheme-prompt)) - (t quack-default-program)))) - (if cmd - ;; We will assume there is no running Scheme, so... Since `run-scheme' - ;; calls `pop-to-buffer' rather than `switch-to-scheme', our options for - ;; Scheme process window management, such as putting the process buffer - ;; window in its own frame, do not take effect when the process buffer is - ;; displayed by `run-scheme'. So, unless we are using the `cmuscheme' - ;; window management behavior, we attempt to undo whatever window changes - ;; and buffer changes `run-scheme' makes, then just call - ;; `switch-to-scheme'. (This code will be revisited once we decide how - ;; to handle multiple Schemes, if not before then.) - (let ((buf (current-buffer)) - (wg (current-window-configuration))) - ad-do-it - (unless (or (not quack-switch-to-scheme-method) - (eq quack-switch-to-scheme-method 'cmuscheme)) - (set-window-configuration wg) - (set-buffer buf) - (switch-to-scheme t)) - (message "Started Scheme: %s" scheme-program-name)) - ;; There is a running Scheme, so don't call the `run-scheme' function at - ;; all -- just call `switch-to-scheme' or duplicate the `cmuscheme' - ;; package's `pop-to-buffer' behavior. - (if (or (not quack-switch-to-scheme-method) - (eq quack-switch-to-scheme-method 'cmuscheme)) - (pop-to-buffer "*scheme*") - (switch-to-scheme t)) - (message "Switched to running Scheme: %s" scheme-program-name))) - -(defadvice scheme-interactively-start-process (around - quack-ad-sisp - first - (&optional cmd) - activate) - ;; (save-window-excursion - (call-interactively 'run-scheme) - ;; ) - ) - -(defadvice scheme-proc (around quack-ad-scheme-proc first nil activate) - (condition-case nil - ad-do-it - (error (message "Oops, we must start a Scheme process!") - (call-interactively 'run-scheme) - (setq ad-return-value (scheme-proc))))) - -;; Switch-to-Scheme: - -(defun quack-force-frame-switch-to-window (win) - (let ((frame (window-frame win))) - (unless (eq frame (selected-frame)) - (and window-system - quack-warp-pointer-to-frame-p - (set-mouse-position frame 0 0)) - (select-frame frame)) - (select-window win))) - -(defadvice switch-to-scheme (before quack-ad-switch last nil activate) - "Adds support for the `quack-switch-to-scheme-method' option." - ;; This can be done as before-advice since the `pop-to-buffer' that - ;; `switch-to-scheme' is using appears to always be a no-op when the target - ;; buffer is already the current buffer. - (require 'cmuscheme) - ;; The `eval' below is to avoid problems with the byte-compiler and advising. - ;; It doesn't seem to like: (and (boundp 'SYM) SYM) - (let ((repl-buf (eval '(and (boundp 'scheme-buffer) - scheme-buffer - (get-buffer scheme-buffer))))) - (cond ((not repl-buf) - (error (concat "No process current buffer." - " Set `scheme-buffer' or execute `run-scheme'"))) - - ((or (not quack-switch-to-scheme-method) - (eq quack-switch-to-scheme-method 'cmuscheme)) - nil) - - ((eq (current-buffer) repl-buf) nil) - - ((eq quack-switch-to-scheme-method 'other-window) - (switch-to-buffer-other-window repl-buf)) - - ;; The following code may be revived if anyone reports problems with - ;; the use of `special-display-popup-frame'. - ;; - ;; ((eq quack-switch-to-scheme-method 'own-frame) - ;; (let ((pop-up-frames t) - ;; (same-window-buffer-names nil) - ;; (same-window-regexps nil) - ;; (special-display-buffer-names nil) - ;; (special-display-regexps nil)) - ;; (switch-to-buffer (pop-to-buffer repl-buf)))) - - ((eq quack-switch-to-scheme-method 'own-frame) - (quack-force-frame-switch-to-window - (special-display-popup-frame repl-buf))) - - (t (error "Invalid quack-switch-to-scheme-method: %S" - quack-switch-to-scheme-method))))) - -;; Customize: - -(defun quack-customize () - "Customize the Quack package." - (interactive) - (customize-group 'quack)) - -;; Auto Modes: - -(defun quack-add-auto-mode-alist (alist) - (setq auto-mode-alist - (append alist - (let ((retained '())) - (mapcar (function (lambda (pair) - (unless (assoc (car pair) alist) - (setq retained (cons pair retained))))) - auto-mode-alist) - (reverse retained))))) - -(quack-add-auto-mode-alist '(("\\.ccl\\'" . scheme-mode) - ("\\.rkt\\'" . scheme-mode) - ("\\.rktd\\'" . scheme-mode) - ("\\.sch\\'" . scheme-mode) - ("\\.scm\\'" . scheme-mode) - ("\\.ss\\'" . scheme-mode) - ("\\.stk\\'" . scheme-mode) - ("\\.stklos\\'" . scheme-mode) - ;; - ("/\\.mzschemerc\\'" . scheme-mode) - ;; Non-Scheme: - ("\\.plt\\'" . quack-pltfile-mode))) - -;; Syntax Table: - -(defmacro quack-str-syntax (str) - `(,(if (and quack-gnuemacs-p (>= emacs-major-version 21)) - 'string-to-syntax - 'quack-kludged-string-to-syntax) - ,str)) - -(defun quack-kludged-string-to-syntax (str) - (let* ((str-len (length str)) - (code (aref str 0)) - (matches (if (> str-len 1) (aref str 1))) - (result (cond ((= code 32) 0) - ((= code ?_) 3) - (t (quack-internal-error)))) - (i 2)) - (while (< i str-len) - (let ((c (aref str i))) - (setq i (1+ i)) - (setq result (logior result - (lsh 1 (cond ((= c ?1) 16) - ((= c ?2) 17) - ((= c ?3) 18) - ((= c ?4) 19) - ((= c ?p) 20) - ((= c ?b) 21) - ((= c ?n) 21) - (t (quack-internal-error)))))))) - (cons result (if (= matches 32) nil matches)))) - -;; Note: We are assuming that it is better to endeavor to fontify all "#|" -;; block comments as nestable rather than as unnestable, regardless of -;; whether or not a user's target Scheme dialect supports nested. - -(defconst quack-pound-syntax-string (if quack-gnuemacs-p "_ p14bn" "_ p14b")) -;; (defconst quack-bar-syntax-string (if quack-gnuemacs-p " 23bn" " 23b")) -(defconst quack-bar-syntax-string (if quack-gnuemacs-p "_ 23bn" "_ 23b")) - -(defconst quack-pound-syntax (quack-str-syntax quack-pound-syntax-string)) -(defconst quack-bar-syntax (quack-str-syntax quack-bar-syntax-string)) - -(modify-syntax-entry ?# quack-pound-syntax-string scheme-mode-syntax-table) -(modify-syntax-entry ?| quack-bar-syntax-string scheme-mode-syntax-table) - -;; Note: Unclear why, but `scheme.el' in GNU Emacs 21.2 is doing -;; `(set-syntax-table scheme-mode-syntax-table)' in whatever buffer is -;; active at the time the Elisp package is loaded. - -;; Indent Properties: - -(put 'begin0 'scheme-indent-function 1) -(put 'c-declare 'scheme-indent-function 0) -(put 'c-lambda 'scheme-indent-function 2) -(put 'call-with-input-file 'scheme-indent-function 1) -(put 'call-with-input-file* 'scheme-indent-function 1) -(put 'call-with-output-file 'scheme-indent-function 1) -(put 'call-with-output-file* 'scheme-indent-function 1) -(put 'call-with-semaphore 'scheme-indent-function 1) -(put 'case-lambda 'scheme-indent-function 0) -(put 'catch 'scheme-indent-function 1) -(put 'chicken-setup 'scheme-indent-function 1) -(put 'class 'scheme-indent-function 'defun) -(put 'class* 'scheme-indent-function 'defun) -(put 'compound-unit/sig 'scheme-indent-function 0) -(put 'defboolparam 'scheme-indent-function 2) -(put 'defform 'scheme-indent-function 1) -(put 'defform* 'scheme-indent-function 1) -(put 'defform*/subs 'scheme-indent-function 2) -(put 'defform/none 'scheme-indent-function 1) -(put 'defform/subs 'scheme-indent-function 2) -(put 'defidform 'scheme-indent-function 1) -(put 'define-runtime-path 'scheme-indent-function 1) -(put 'define-sequence-id 'scheme-indent-function 1) -(put 'define: 'scheme-indent-function 3) -(put 'defparam 'scheme-indent-function 3) -(put 'defproc 'scheme-indent-function 2) -(put 'defproc* 'scheme-indent-function 1) -(put 'defstruct 'scheme-indent-function 2) -(put 'defstruct* 'scheme-indent-function 2) -(put 'defthing 'scheme-indent-function 2) -(put 'deftogether 'scheme-indent-function 1) -(put 'do 'scheme-indent-function 2) -(put 'dynamic-wind 'scheme-indent-function 0) -(put 'filebox 'scheme-indent-function 1) -(put 'for 'scheme-indent-function 1) -(put 'for* 'scheme-indent-function 1) -(put 'for*/and 'scheme-indent-function 1) -(put 'for*/first 'scheme-indent-function 1) -(put 'for*/fold 'scheme-indent-function 2) -(put 'for*/fold/derived 'scheme-indent-function 3) -(put 'for*/hash 'scheme-indent-function 1) -(put 'for*/hasheq 'scheme-indent-function 1) -(put 'for*/hasheqv 'scheme-indent-function 1) -(put 'for*/last 'scheme-indent-function 1) -(put 'for*/list 'scheme-indent-function 1) -(put 'for*/lists 'scheme-indent-function 2) -(put 'for*/or 'scheme-indent-function 1) -(put 'for*/product 'scheme-indent-function 1) -(put 'for*/sum 'scheme-indent-function 1) -(put 'for*/vector 'scheme-indent-function 1) -(put 'for*/vector 'scheme-indent-function 1) -(put 'for/and 'scheme-indent-function 1) -(put 'for/first 'scheme-indent-function 1) -(put 'for/fold 'scheme-indent-function 2) -(put 'for/fold 'scheme-indent-function 2) -(put 'for/fold/derived 'scheme-indent-function 3) -(put 'for/hash 'scheme-indent-function 1) -(put 'for/hasheq 'scheme-indent-function 1) -(put 'for/hasheqv 'scheme-indent-function 1) -(put 'for/last 'scheme-indent-function 1) -(put 'for/list 'scheme-indent-function 1) -(put 'for/lists 'scheme-indent-function 2) -(put 'for/or 'scheme-indent-function 1) -(put 'for/product 'scheme-indent-function 1) -(put 'for/sum 'scheme-indent-function 1) -(put 'for/vector 'scheme-indent-function 1) -(put 'instantiate 'scheme-indent-function 2) -(put 'interface 'scheme-indent-function 1) -(put 'lambda/kw 'scheme-indent-function 1) -(put 'let*-values 'scheme-indent-function 1) -(put 'let*: 'scheme-indent-function 'quack-let-colon-indent) -(put 'let+ 'scheme-indent-function 1) -(put 'let-values 'scheme-indent-function 1) -(put 'let/ec 'scheme-indent-function 1) -(put 'let: 'scheme-indent-function 'quack-let-colon-indent) -(put 'letrec-values 'scheme-indent-function 1) -(put 'match 'scheme-indent-function 1) -(put 'match-let 'scheme-indent-function 1) -(put 'mixin 'scheme-indent-function 2) -(put 'module 'scheme-indent-function 'defun) -(put 'module 'scheme-indent-function 2) -(put 'module* 'scheme-indent-function 2) -(put 'module+ 'scheme-indent-function 1) -(put 'opt-lambda 'scheme-indent-function 1) -(put 'parameterize 'scheme-indent-function 1) -(put 'parameterize* 'scheme-indent-function 1) -(put 'parameterize-break 'scheme-indent-function 1) -(put 'quasisyntax/loc 'scheme-indent-function 1) -(put 'receive 'scheme-indent-function 2) -(put 'send* 'scheme-indent-function 1) -(put 'sigaction 'scheme-indent-function 1) -(put 'specform 'scheme-indent-function 1) -(put 'specspecsubform 'scheme-indent-function 1) -(put 'specspecsubform/subs 'scheme-indent-function 2) -(put 'specsubform 'scheme-indent-function 1) -(put 'specsubform/subs 'scheme-indent-function 2) -(put 'struct 'scheme-indent-function 1) -(put 'sxml-match 'scheme-indent-function 1) -(put 'syntax-case 'scheme-indent-function 2) -(put 'syntax-parse 'scheme-indent-function 1) -(put 'syntax/loc 'scheme-indent-function 1) -(put 'test-section 'scheme-indent-function 1) -(put 'unit 'scheme-indent-function 'defun) -(put 'unit/sig 'scheme-indent-function 2) -(put 'unless 'scheme-indent-function 1) -(put 'when 'scheme-indent-function 1) -(put 'while 'scheme-indent-function 1) -(put 'with-handlers 'scheme-indent-function 1) -(put 'with-handlers* 'scheme-indent-function 1) -(put 'with-method 'scheme-indent-function 1) -(put 'with-syntax 'scheme-indent-function 1) - -(defun quack-let-colon-indent (state indent-point normal-indent) - ;; Note: This was adapted from "scheme.el" "scheme-let-indent". - (skip-chars-forward " \t") - (if (looking-at "[-a-zA-Z0-9+*/?!@$%^&_:~]") - (lisp-indent-specform 4 state indent-point normal-indent) - (lisp-indent-specform 1 state indent-point normal-indent))) - -;; Keymaps: - -(defvar quack-scheme-mode-keymap nil) - -(setq quack-scheme-mode-keymap (make-sparse-keymap)) - -;; TODO: Maybe have an option to also map the Ctrl variants of each of these -;; keys to their respective bindings. As Eli pointed out, `C-c C-q C-x' -;; is arguably easier to type than `C-c C-q x'. Actually, though, I -;; don't like the `C-c C-q' prefix at all -- it signifies everything that -;; is wrong with traditional modifier-happy Emacs keybindings. Maybe we -;; should encourage users to set the prefix to some other key, like an -;; unmodified function key. - -(define-key quack-scheme-mode-keymap "f" 'quack-find-file) -(define-key quack-scheme-mode-keymap "k" 'quack-view-keyword-docs) -(define-key quack-scheme-mode-keymap "m" 'quack-view-manual) -(define-key quack-scheme-mode-keymap "r" 'run-scheme) -(define-key quack-scheme-mode-keymap "s" 'quack-view-srfi) -(define-key quack-scheme-mode-keymap "l" 'quack-toggle-lambda) -(define-key quack-scheme-mode-keymap "t" 'quack-tidy-buffer) - -;; Menus: - -(defmacro quack-bool-menuitem (title var &rest rest) - (unless (stringp title) (quack-internal-error)) - (unless (symbolp var) (quack-internal-error)) - `[,title (quack-option-toggle (quote ,var)) :style toggle :selected ,var - ,@rest]) - -(defmacro quack-radio-menuitems (var alist) - (unless (symbolp var) (quack-internal-error)) - (unless (listp alist) (quack-internal-error)) - `(quote ,(mapcar - (function (lambda (pair) - (let ((title (car pair)) - (value (cdr pair))) - (unless (stringp title) (quack-internal-error)) - (unless (symbolp value) (quack-internal-error)) - `[,title - (quack-option-set (quote ,var) (quote ,value)) - :style radio - :selected (eq ,var (quote ,value))]))) - alist))) - -(defconst quack-browser-radio-alist - '((nil . "(Browse-URL Default)") - (browse-url-galeon . "Galeon") - (browse-url-mozilla . "Mozilla") - (browse-url-kde . "KDE Konqueror") - (browse-url-netscape . "Netscape Navigator") - (browse-url-w3 . "Emacs W3") - (w3m-browse-url . "W3M") - (quack-w3m-browse-url-other-window . "W3M (in other window)") - (browse-url-lynx-xterm . "Lynx in Xterm") - (browse-url-lynx-emacs . "Lynx in Emacs") - (browse-url-default-windows-browser . "MS Windows Default"))) - -(defconst quack-global-menuspec - `("Quack" - ["About Quack..." quack-about] - ("Options" - ("Startup Options" - "These settings take full effect" - "once Emacs is restarted." - "---" - ,(quack-bool-menuitem "Put Quack on Global Menu Bar" quack-global-menu-p) - ,(quack-bool-menuitem "Remap Find-File Bindings" - quack-remap-find-file-bindings-p) - "---" - ["Quack Directory..." (customize-option 'quack-dir)] - ["Quack Scheme Mode Keymap Prefix..." - (customize-option 'quack-scheme-mode-keymap-prefix)]) - "---" - ("Default Program" :filter quack-defaultprogram-menufilter) - ,(quack-bool-menuitem "Always Prompt for Program" - quack-run-scheme-always-prompts-p) - ,(quack-bool-menuitem "Program Prompt Defaults to Last" - quack-run-scheme-prompt-defaults-to-last-p) - ,(quack-bool-menuitem "Remember New Programs" - quack-remember-new-programs-p) - "---" - ("Newline Behavior" - ,@(quack-radio-menuitems - quack-newline-behavior - (("Newline" . newline) - ("Newline-Indent" . newline-indent) - ("Indent-Newline-Indent" . indent-newline-indent)))) - ,(quack-bool-menuitem "Smart Open-Paren" - quack-smart-open-paren-p) - ("Switch-to-Scheme Method" - ,@(quack-radio-menuitems quack-switch-to-scheme-method - (("Other Window" . other-window) - ("Own Frame" . own-frame) - ("Cmuscheme Behavior" . cmuscheme))) - "---" - ,(quack-bool-menuitem - "Warp Pointer to Frame" - quack-warp-pointer-to-frame-p - :active (eq quack-switch-to-scheme-method 'own-frame))) - ("Fontification" - ,@(quack-radio-menuitems quack-fontify-style - (("PLT Style" . plt) - ("Extended GNU Emacs Style" . emacs) - ("Emacs Default" . nil))) - "---" - ,(quack-bool-menuitem "Pretty Lambda \(in PLT Style\)" - quack-pretty-lambda-p - :active (and quack-pretty-lambda-supported-p - (memq quack-fontify-style '(plt)))) - ,(quack-bool-menuitem "Fontify Definition Names \(in PLT Style\)" - quack-pltish-fontify-definition-names-p - :active (eq quack-fontify-style 'plt)) - ,(quack-bool-menuitem "Fontify Syntax Keywords \(in PLT Style\)" - quack-pltish-fontify-keywords-p - :active (eq quack-fontify-style 'plt)) - ;; TODO: Add menuitem here for "Fontify #: Keywords \(in PLT Style\)" - ,(quack-bool-menuitem "Fontify 3-Semicolon Comments \(in PLT Style\)" - quack-fontify-threesemi-p - :active (memq quack-fontify-style '(plt))) - ) - ("Web Browser" - ,@(mapcar (function - (lambda (n) - (let ((func (car n)) - (title (cdr n))) - `[,title - (quack-option-set 'quack-browse-url-browser-function - (quote ,func)) - :style radio - :selected ,(if (not func) - '(not quack-browse-url-browser-function) - `(eq quack-browse-url-browser-function - (quote ,func)))]))) - quack-browser-radio-alist) - ["(Other)..." - (customize-option 'quack-browse-url-browser-function) - :style radio - :selected (not (assq quack-browse-url-browser-function - quack-browser-radio-alist))]) - ,(quack-bool-menuitem "Tab Characters are Evil" quack-tabs-are-evil-p) - ("Local Keywords for Remote Manuals" - ,@(quack-radio-menuitems - quack-local-keywords-for-remote-manuals-p - (("Permit" . t) - ("Forbid" . nil) - ("Always" . always)))) - ["PLT Collection Directories..." - (customize-option 'quack-pltcollect-dirs)] - "---" - ["Customize..." quack-customize]) - "---" - ["Run Scheme" run-scheme] - ["Switch to Scheme Buffer" switch-to-scheme] - "---" - ("View Manual" :filter quack-view-manual-menufilter) - ("View SRFI" :filter quack-view-srfi-menufilter) - ["View Keyword Docs..." quack-view-keyword-docs] - ["Dired on PLT Collection..." quack-dired-pltcollect])) - -(defun quack-install-global-menu () - (when quack-global-menu-p - (quack-when-gnuemacs - (unless (assq 'Quack menu-bar-final-items) - (setq menu-bar-final-items (cons 'Quack menu-bar-final-items))) - (easy-menu-define quack-global-menu global-map "" - quack-global-menuspec)) - (quack-when-xemacs - ;; Die! Die! Die! - ;;(mapcar (function (lambda (n) - ;;(delete-menu-item '("Quack") n) - ;;(add-submenu nil quack-global-menuspec "Help" n))) - ;;(list - ;;;;current-menubar - ;;default-menubar - ;;)) - (delete-menu-item '("Quack") current-menubar) - (add-submenu nil quack-global-menuspec "Help" current-menubar) - (set-menubar-dirty-flag)))) - -;; TODO: We should make sure the user's custom settings have been loaded -;; before we do this. -(quack-install-global-menu) - -;; And die some more! -;;(quack-when-xemacs (add-hook 'after-init-hook 'quack-install-global-menu)) - -(defconst quack-scheme-mode-menuspec - `("Scheme" - ("Quack Global" ,@(cdr quack-global-menuspec)) - "---" - ["Toggle Lambda Syntax" quack-toggle-lambda] - ["Tidy Buffer Formatting" quack-tidy-buffer] - ["Comment-Out Region" comment-region] - ["Un-Comment-Out Region" quack-uncomment-region] - "---" - ["Evaluate Last S-expression" scheme-send-last-sexp] - ["Evaluate Region" scheme-send-region] - ["Evaluate Region & Go" scheme-send-region-and-go] - ["Evaluate Last Definition" scheme-send-definition] - ["Evaluate Last Definition & Go" scheme-send-definition-and-go] - ["Compile Definition" scheme-compile-definition] - ["Compile Definition & Go" scheme-compile-definition-and-go] - ["Load Scheme File" scheme-load-file] - ["Compile Scheme File" scheme-compile-file] - "---" - ["View Keyword Docs..." quack-view-keyword-docs] - ["Quack Find File" quack-find-file])) - -(defvar quack-scheme-mode-menu) -(quack-when-gnuemacs - (let ((map (make-sparse-keymap))) - (setq quack-scheme-mode-menu nil) - (easy-menu-define quack-scheme-mode-menu map "" - quack-scheme-mode-menuspec) - (define-key scheme-mode-map [menu-bar scheme] - (cons "Scheme" - (or (lookup-key map [menu-bar Scheme]) - (lookup-key map [menu-bar scheme])))))) - -(defun quack-view-manual-menufilter (arg) - (quack-menufilter-return "quack-view-manual-menufilter-menu" - (quack-manuals-menu))) - -(defun quack-view-srfi-menufilter (arg) - (quack-menufilter-return - "quack-view-srfi-menufilter-menu" - (condition-case nil - (quack-srfi-menu t) - ;; TODO: Move the generation of this fallback menu down to - ;; quack-srfi-menu. - (error '(["Update SRFI Index" quack-update-srfi-index] - "---" - ("Draft" :active nil "") - ("Final" :active nil "") - ("Withdrawn" :active nil "") - ["Other SRFI..." quack-view-srfi]))))) - -(defun quack-defaultprogram-menufilter (arg) - (quack-menufilter-return - "quack-defaultprogram-menufilter-menu" - `(,@(quack-optionmenu-items-setdefaultprogram) - "---" - ["Other Program..." quack-set-other-default-program] - "---" - ("Forget Program" - ,@(mapcar - (function - (lambda (program) - `[,(format "Forget %s" program) - (quack-forget-program ,program)])) - quack-programs))))) - -(defun quack-optionmenu-items-setdefaultprogram () - (let* ((programs (quack-sort-string-list-copy quack-programs)) - (add-default-p (and quack-default-program - (not (member quack-default-program programs))))) - (and add-default-p - (setq programs (cons quack-default-program programs))) - (mapcar - (function - (lambda (program) - (let* ((selected-p (and quack-default-program - (equal program quack-default-program)))) - `[,(format "%s%s" - program - (if (and add-default-p - (equal program quack-default-program)) - " (temporary)" - "")) - (quack-option-set 'quack-default-program ,program) - :style radio :selected ,selected-p]))) - programs))) - -(mapcar (function (lambda (sym) (put sym 'menu-enable 'mark-active))) - '(comment-region - indent-region - quack-uncomment-region - scheme-send-region - scheme-send-region-and-go)) - -;; Option Menu Callbacks: - -(defun quack-set-other-default-program () - (interactive) - (let* ((minibuffer-allow-text-properties nil) - (program (quack-without-side-whitespace - (read-string "Other Default Program: ")))) - (if (string= program "") - (message "Default program unchanged.") - (quack-remember-program-maybe program) - (quack-option-set 'quack-default-program - program)))) - -(defun quack-forget-program (program) - (setq quack-programs (delete program quack-programs)) - (quack-option-set 'quack-programs quack-programs t) - (message "Forgot program %S." program)) - -(defun quack-custom-set (sym value) - ;; Clean up the value based on the variable symbol. - (cond ((eq sym 'quack-programs) - (setq value (quack-sort-string-list-copy value)))) - - ;; Set default binding. Set local binding just for the halibut, although if - ;; there are local bindings, then other things will likely break. \(We used - ;; to have a check here, but removed it while porting to XEmacs.\) - (set sym value) - (set-default sym value) - - ;; TODO: Probably don't do this during Emacs initialization time, to avoid - ;; unnecessary behavior like: - ;; - ;; Loading ~/emacs/my-custom.el (source)... - ;; Updating Scheme Mode buffers...done - ;; Updating Scheme Mode buffers...done - ;; Updating Scheme Mode buffers...done - ;; Updating Scheme Mode buffers...done - ;; Updating Scheme Mode buffers...done - ;; Loading ~/emacs/my-custom.el (source)...done - - ;; Update dependent program state. - (cond ((memq sym '(quack-emacsish-keywords-to-fontify - quack-fontify-style - quack-fontify-threesemi-p - quack-pltish-fontify-definition-names-p - quack-pltish-fontify-keywords-p - quack-pltish-keywords-to-fontify - quack-pretty-lambda-p)) - (quack-update-scheme-mode-buffers)) - - ((eq sym 'quack-local-keywords-for-remote-manuals-p) - (quack-invalidate-manuals-caches)) - - ((eq sym 'quack-pltcollect-dirs) - (quack-invalidate-pltcollects-caches)))) - -(defun quack-option-set (sym value &optional silently) - (if quack-options-persist-p - (customize-save-variable sym value) - (quack-custom-set sym value)) - (or silently - (message "Set %s%s to: %S" - sym - (if quack-options-persist-p "" " (non-persistently)") - value))) - -(defun quack-option-toggle (sym &optional silently) - (quack-option-set sym (not (symbol-value sym)) t) - (or silently - (message "Set %s%s %s." - sym - (if quack-options-persist-p "" " (non-persistently)") - (if (symbol-value sym) "ON" "OFF")))) - -(defun quack-update-scheme-mode-buffers () - (save-excursion - (quack-activity - "Updating Scheme Mode buffers" - (mapcar (function - (lambda (buf) - (set-buffer buf) - (when (eq major-mode 'scheme-mode) - (quack-activity (format "Updating buffer %S" (buffer-name)) - (scheme-mode))))) - (buffer-list))))) - -;; Pretty Lambda: - -(defconst quack-lambda-char (make-char 'greek-iso8859-7 107)) - -(defconst quack-pretty-lambda-supported-p - (and quack-gnuemacs-p (>= emacs-major-version 21))) - -;; Font Lock: - -(defconst quack-emacsish1-font-lock-keywords - `((,(concat "[[(]" - "\\(" ; #<1 - "define\\*?" - ; #=2 #=3 - (quack-re-alt (quack-re-alt "" - "-generic" - "-generic-procedure" - "-method" - "-public" - "/kw" - "/override" - "/private" - "/public") - ; #=4 - (quack-re-alt "-macro" - "-syntax") - "-class" - "-module" - "-signature" - "-struct") - "\\)" ; #>1 - "\\>" - "[ \t]*[[(]?" - ; #=5 - "\\(\\sw+\\)?") - (1 font-lock-keyword-face) - (5 (cond ((match-beginning 3) font-lock-function-name-face) - ((match-beginning 4) font-lock-variable-name-face) - (t font-lock-type-face)) - nil t)) - - ;; PLT module definitions. - ("[[(]\\(module\\)\\>[ \t]+\\(\\sw+\\)?" - (1 font-lock-keyword-face) - (2 font-lock-type-face nil t)))) - -(defconst quack-emacsish2-font-lock-keywords - (append quack-emacsish1-font-lock-keywords - `( - ;; Misc. keywords. - (,(concat - "[[(]\\(" - (regexp-opt quack-emacsish-keywords-to-fontify) - "\\)\\>") - . 1) - ;; Class specifiers in SOS, Stklos, Goops. - ("\\<<\\sw+>\\>" . font-lock-type-face) - ;; Colon keywords. - ("\\<:\\sw+\\>" . font-lock-builtin-face)))) - -(defvar quack-pltish-font-lock-keywords nil) - -(defun quack-pltish-num-re (radix digit base16-p) - ;; These regexps started as a transliteration of the R5RS BNF to regular - ;; expressions, adapted for PLTisms, and with a few optimizations. - ;; - ;; PLTisms are that 'e' is not permitted as an exponent marker in base-16 - ;; literals, and that "decimal-point" forms are permitted in any radix. - ;; - ;; There's obvious opportunity for further optimization, especially if we - ;; relax the accepted syntax a little. These regexps have not been tested - ;; much, but, since this is only Emacs syntax fontification, false-positives - ;; and false-negatives will be obvious yet benign. - (let* ((uint (concat digit "+#*")) - (sign "[-+]?") - (suffix (quack-re-optional (if base16-p "[sSfFdDlL]" "[eEsSfFdDlL]") - sign - "[0-9]+")) - (decimal (quack-re-alt - (concat uint suffix) - (concat "\\." digit "+#*" suffix) - (concat digit - "+" - (quack-re-alt (concat "\\." digit "*") - "#+\\.") - "#*"))) - (ureal (quack-re-alt uint - (concat uint "/" uint) - decimal)) - (real (concat sign ureal)) - (complex (quack-re-alt - (concat real - (quack-re-alt (concat "@" real) - (quack-re-optional - "[-+]" - (quack-re-optional ureal) - "i") - "")) - (concat "[-+]" (quack-re-optional ureal) "i"))) - (exact (quack-re-optional "#[eEiI]")) - (prefix (quack-re-alt (concat radix exact) - (concat exact radix)))) - (concat "\\<" prefix complex "\\>"))) - -(defconst quack-pltish-fls-base - `( - ("\\`\\(MrEd\\|Welcome to MzScheme\\) v[^\n]+" . quack-banner-face) - ("\\`Gambit Version 4\\.0[^\n]*" . quack-banner-face) - ("\\`Welcome to scsh [0-9][^\n]+\nType ,\\? for help[^\n]+" - . quack-banner-face) - ("\\`MIT/GNU Scheme running under [^\n]+" . quack-banner-face) - ;;("\\`; This is the CHICKEN interpreter - Version [^\n]+\n; (c)[^\n]+" - ;; . quack-banner-face) - ;;("\\`Scheme Microcode Version[^\n]+\nMIT Scheme[^\n]+\n\\([^\n]+\n\\)+" . - ;;quack-banner-face) - ;; Unix cookie line. - ("\\`#![^\r\n]*" . quack-pltish-comment-face) - ;; Colon keywords: - ("\\<#:\\sw+\\>" . quack-pltish-colon-keyword-face) - ;; Self-evals: - ("'\\sw+\\>" . quack-pltish-selfeval-face) - ("'|\\(\\sw\\| \\)+|" . quack-pltish-selfeval-face) - ;; Note: The first alternative in the following rule will misleadingly - ;; fontify some invalid syntax, such as "#\(x". - ("\\<#\\\\\\([][-`~!@#$%&*()_+=^{}\;:'\"<>,.?/|\\\\]\\|\\sw+\\>\\)" - . quack-pltish-selfeval-face) - ("[][()]" . quack-pltish-paren-face) - ("\\<#\\(t\\(?:rue\\)?\\|f\\(?:alse\\)?\\)\\>" . quack-pltish-selfeval-face) - ("\\<+\\(inf.0\\|nan\\)\\>" . quack-pltish-selfeval-face) - ("\\<-inf.0\\>" . quack-pltish-selfeval-face) - ,@(mapcar (function (lambda (args) - (cons (apply 'quack-pltish-num-re args) - 'quack-pltish-selfeval-face))) - '(("#b" "[01]" nil) - ("#o" "[0-7]" nil) - ("\\(#d\\)?" "[0-9]" nil) - ("#x" "[0-9a-fA-F]" t))))) - -(defconst quack-pltish-fls-defnames - ;; TODO: Optimize these once they're fairly complete and correct. - - ;; TODO: Would be nice to fontify binding names everywhere they are - ;; introduced, such as in `let' and `lambda' forms. That may require - ;; real parsing to do reasonably well -- the kludges get too bad and - ;; slow, and font-lock gets in the way more than it helps. - - `( - ;,@quack-pltish-font-lock-keywords - - ;; Lots of definition forms that start with "define". - (,(concat "[[(]" - "define\\*?" - ;; TODO: make this into regexp-opt - (quack-re-alt "" - ":" - "-class" - "-class" - "-const-structure" - "-constant" - "-embedded" - "-entry-point" - "-external" - "-for-syntax" - "-foreign-record" - "-foreign-type" - "-foreign-variable" - "-generic" - "-generic-procedure" - "-inline" - "-location" - "-macro" - "-method" - "-opt" - "-parameters" - "-public" - "-reader-ctor" - "-record" - "-record-printer" - "-record-type" - "-signature" - "-structure" - "-syntax" - "-values" - "-values-for-syntax" - "/contract" - "/override" - "/private" - "/public") - "\\>" - "[ \t]*[[(]?" - "\\(\\sw+\\)") - (2 (let ((name (quack-match-string-no-properties 2))) - (if (= (aref name (1- (length name))) ?%) - quack-pltish-class-defn-face - quack-pltish-defn-face)) - nil t)) - - ;; Racket "struct" and "define-struct" forms: - (,(concat "[[(]" - "\\(?:define-\\)?" - "struct" - "\\>" - "[ \t]*[[(]?" - "\\(\\sw+\\)") - ;; TODO: Use a struct face rather than the class face. - (1 quack-pltish-class-defn-face nil t)) - - ;; `defmacro' and related SCM forms. - (,(concat "[[(]def" - (quack-re-alt (concat "macro" - (quack-re-alt "" "-public")) - "syntax") - "\\>[ \t]+\\(\\sw+\\)") - 3 quack-pltish-defn-face nil t) - - ;; `defmac' from SIOD. - ("[[(]defmac[ \t]+[[(][ \t]*\\(\\sw+\\)" - 1 quack-pltish-defn-face nil t) - - ;; `defvar' and `defun' from SIOD. - (,(concat "[[(]def" - (quack-re-alt "un" - "var") - "[ \t]+\\(\\sw+\\)") - 2 quack-pltish-defn-face nil t) - - ;; Guile and Chicken `define-module'. - ("[[(]define-module\\>[ \t]+[[(][ \t]*\\(\\sw+\\([ \t]+\\sw+\\)*\\)" - 1 quack-pltish-module-defn-face nil t) - - ;; PLT `define-values', `define-syntaxes', and `define-syntax-set'. - (,(concat "[[(]define-" - (quack-re-alt "values" "syntax-set" "syntaxes") - "\\>[ \t]+[[(][ \t]*\\(\\sw+\\([ \t]+\\sw+\\)*\\)") - 2 quack-pltish-defn-face nil t) - - ;; PLT `module'. - ("[[(]module\\>[ \t]+\\(\\sw+\\)" - 1 quack-pltish-module-defn-face nil t) - - ;; Named `let'. (Note: This is disabled because it's too incongruous.) - ;;("[[(]let\\>[ \t]+\\(\\sw+\\)" - ;; 1 quack-pltish-defn-face nil t) - )) - -;; TODO: Adding PLT-style (quasi)quoted list fontifying is obviously not doable -;; with just regexps. Probably requires either cloning -;; `font-lock-default-fontify-region' just to get it to call our -;; replacement syntactic pass fontification function, *or* -;; before-advising `font-lock-fontify-keywords-region' to perform our -;; syntactic pass when in scheme-mode, and around-advising -;; `font-lock-fontify-syntactically-region' to not do anything for -;; scheme-mode (or maybe setting `font-lock-keywords-only' to non-nil, -;; unless that breaks something else). Or just ditch font-lock. See -;; `font-lock-fontify-region-function' variable in font-lock specs. - -;; (defconst quack-pltish-fls-keywords -;; `((,(concat -;; "[[(]\\(" -;; (regexp-opt quack-pltish-keywords-to-fontify) -;; "\\)\\>") -;; (1 quack-pltish-keyword-face)))) - -(defun quack-install-fontification () - - (when (eq quack-fontify-style 'plt) - (set (make-local-variable 'font-lock-comment-face) - 'quack-pltish-comment-face) - (set (make-local-variable 'font-lock-string-face) - 'quack-pltish-selfeval-face)) - - (let* ((sk `(("\\(#\\)\\(|\\)" - (1 ,quack-pound-syntax) - (2 ,quack-bar-syntax)) - ("\\(|\\)\\(#\\)" - (1 ,quack-bar-syntax) - (2 ,quack-pound-syntax)))) - (pl (if (and quack-pretty-lambda-supported-p quack-pretty-lambda-p) - '(("[[(]\\(case-\\|match-\\|opt-\\)?\\(lambda\\)\\>" - 2 - (progn (compose-region (match-beginning 2) - (match-end 2) - quack-lambda-char) - nil))) - '())) - (threesemi - (if quack-fontify-threesemi-p - `( - (,(concat "^\\(\;\;\;\\)" - ;; TODO: Make this enforce space or newline after the - ;; three semicolons. - "\\(" - "[ \t]*" - "\\(" - "[^\r\n]*" - "\\)" - "\r?\n?\\)") - (1 quack-threesemi-semi-face prepend) - (2 quack-threesemi-text-face prepend) - ;;(4 quack-threesemi-h1-face prepend) - ;;(5 quack-threesemi-h2-face prepend) - ) - - ;; Funcelit: - ("^\;\;\; @\\(Package\\|section\\|unnumberedsec\\)[ \t]+\\([^\r\n]*\\)" - (2 quack-threesemi-h1-face prepend)) - ("^\;\;\; @subsection[ \t]+\\([^\r\n]*\\)" - (1 quack-threesemi-h2-face prepend)) - - ("^\;\;\; @section\\(?:\\[[^]]*\\]\\)?{\\([^\r\n]*\\)}" - (1 quack-threesemi-h1-face prepend)) - ("^\;\;\; @subsection\\(?:\\[[^]]*\\]\\)?{\\([^\r\n]*\\)}" - (1 quack-threesemi-h2-face prepend)) - - - ) - '())) - (fld `(,(cond - ((eq quack-fontify-style 'plt) - (set (make-local-variable - 'quack-pltish-font-lock-keywords) - `(,@quack-pltish-fls-base - ,@(if quack-pltish-fontify-definition-names-p - quack-pltish-fls-defnames - '()) - ,@pl - ,@(if quack-pltish-fontify-keywords-p - ;; quack-pltish-fls-keywords - `((,(concat - "[[(]\\(" - (regexp-opt - quack-pltish-keywords-to-fontify) - "\\)\\>") - (1 quack-pltish-keyword-face))) - '()) - ,@threesemi - )) - 'quack-pltish-font-lock-keywords) - ((eq quack-fontify-style 'emacs) - ;; TODO: Do pretty-lambda here too. But first get rid of - ;; this font-lock style "degrees of general gaudiness" - ;; and switch to separate options for each property of - ;; fontification. - '(quack-emacsish1-font-lock-keywords - quack-emacsish1-font-lock-keywords - quack-emacsish2-font-lock-keywords)) - (t (quack-internal-error))) - nil - t - ((?! . "w") (?$ . "w") (?% . "w") (?& . "w") (?* . "w") - (?+ . "w") (?- . "w") (?. . "w") (?/ . "w") (?: . "w") - (?< . "w") (?= . "w") (?> . "w") (?? . "w") (?@ . "w") - (?^ . "w") (?_ . "w") (?~ . "w") - ,@(if (eq quack-fontify-style 'plt) - '((?# . "w")) - '())) - ;; TODO: Using `beginning-of-defun' here could be very slow, - ;; say, when you have a large buffer that is wrapped in a - ;; `module' form. Look into whether this is a problem. - beginning-of-defun - ,@(if t ; quack-gnuemacs-p - `((font-lock-mark-block-function . mark-defun) - (font-lock-syntactic-keywords . ,sk)) - '())))) - - ;; TODO: Figure out why `font-lock-syntactic-keywords' just doesn't work in - ;; XEmacs 21, even though the syntax text properties seem to get set. - ;; We have already beaten it like an egg-sucking dog. - - ;;(if quack-xemacs-p - ;;(put 'scheme-mode 'font-lock-defaults fld) - (set (make-local-variable 'font-lock-defaults) fld) - ;;) - - ;;(when quack-xemacs-p - ;; (set (make-local-variable 'font-lock-syntactic-keywords) - ;; syntactic-keywords)) - )) - -;; Scheme Mode Startup Hook: - -(defun quack-locally-steal-key-bindings (old-func new-func) - (mapcar (function (lambda (key) - (unless (and (vectorp key) - (eq (aref key 0) 'menu-bar)) - (local-set-key key new-func)))) - (where-is-internal old-func))) - -(defun quack-shared-mode-hookfunc-stuff () - - ;; Install the Quack keymap and menu items. - (local-set-key quack-scheme-mode-keymap-prefix quack-scheme-mode-keymap) - (quack-when-xemacs - (when (featurep 'menubar) - ;;(set-buffer-menubar current-menubar) - ;; TODO: For XEmacs, we could have two versions of this menu -- the popup - ;; one would have the Global submenu, but the menubar one would have - ;; the Global submenu only if quack-global-menu-p were nil. - (add-submenu nil quack-scheme-mode-menuspec) - (set-menubar-dirty-flag) - (setq mode-popup-menu quack-scheme-mode-menuspec))) - - ;; Bind the paren-matching keys. - (local-set-key ")" 'quack-insert-closing-paren) - (local-set-key "]" 'quack-insert-closing-bracket) - - (local-set-key "(" 'quack-insert-opening-paren) - (local-set-key "[" 'quack-insert-opening-bracket) - - ;; Steal any find-file bindings. - (when quack-remap-find-file-bindings-p - (quack-locally-steal-key-bindings 'find-file 'quack-find-file) - (quack-locally-steal-key-bindings 'ido-find-file 'quack-find-file)) - - ;; Fight against tabs. - (when quack-tabs-are-evil-p - (setq indent-tabs-mode nil)) - - ;; Remove character compositions, to get rid of any pretty-lambda. (Note: - ;; This is bad, if it turns out compositions are used for other purposes in - ;; buffers that are edited with Scheme Mode.) - (when quack-pretty-lambda-supported-p - (eval '(decompose-region (point-min) (point-max)))) - - ;; Install fontification - (when quack-fontify-style - (when (and (boundp 'font-lock-keywords) - (symbol-value 'font-lock-keywords) - (not (featurep 'noweb-mode))) - ;; This warning is not given if the `noweb-mode' package is installed. - (quack-warning "`font-lock-keywords' already set when hook ran.")) - (quack-install-fontification)) - - ;; Die! Die! Die! - (quack-when-xemacs - (quack-install-global-menu))) - -(defun quack-inferior-scheme-mode-hookfunc () - (quack-shared-mode-hookfunc-stuff)) - -(defun quack-scheme-mode-hookfunc () - (quack-shared-mode-hookfunc-stuff) - - ;; Bind Return/Enter key. - (local-set-key "\r" 'quack-newline) - - ;; Install toolbar. - ;;(unless quack-xemacs-p - ;;(when (display-graphic-p) - ;;(quack-install-tool-bar))) - ) - -(add-hook 'scheme-mode-hook 'quack-scheme-mode-hookfunc) -(add-hook 'inferior-scheme-mode-hook 'quack-inferior-scheme-mode-hookfunc) - -;; Compilation Mode: - -;; TODO: Add compilation-directory-matcher support for "setup-plt: in". - -(defvar quack-saved-compilation-error-regexp-alist nil) - -(defconst quack-compilation-error-regexp-alist-additions - (let ((no-line (if quack-xemacs-p - (let ((m (make-marker))) (set-marker m 0) m) - 'quack-compile-no-line-number))) - `( - - ;; Racket 5.1.1 "raco" compile error (which can have multiple spaces): - ("^raco\\(?:cgc\\)?: +\\([^: ][^:]*\\):\\([0-9]+\\):\\([0-9]+\\):" - 1 2 3) - - ;; Racket 5.1.1 entries without line number info in "=== context ===": - ("^\\(/[^:]+\\): \\[running body\\]$" 1 nil nil 0) - - ;; PLT MzScheme 4.1.4 "=== context ===" traceback when there is only file, - ;; line, and column info, but potentially no following ":" and additional - ;; info like procedure name. - ("^\\([^:\n\" ]+\\):\\([0-9]+\\):\\([0-9]+\\)" 1 2 3) - - ;; PLT MzScheme 205 "setup-plt" - ;; load-handler: expected a `module' declaration for `bar-unit' in - ;; "/u/collects/bar/bar-unit.ss", but found something else - (,(concat "load-handler: expected a `module' declaration for `[^']+' in " - "\"\\([^:\n\"]+\\)\", but found something else") - 1 ,no-line) - - ;; PLT MzScheme 205 "setup-plt". - ;; setup-plt: Error during Compiling .zos for Foo Bar (/u/collects/fb) - ("setup-plt: Error during Compiling .zos for [^\n]+ \(\\([^\n\)]+\\)\)" - 1 ,no-line) - - ;; PLT MzScheme 4.0.1 "setup-plt". - ("setup-plt: +\\(?:WARNING: +\\)\\([^:\n]+\\)::" - 1 ,no-line) - - ;; PLT MzScheme 4.0.1 "setup-plt". - ("setup-plt: +\\(?:WARNING: +\\)\\([^:\n ][^:\n]*\\):\\([0-9]+\\):\\([0-9]+\\)" - 1 2 3) - - ;; PLT MzScheme 4.0.1 "setup-plt": - ("load-handler: expected a `module' declaration for `[^'\n]+' in #<path:\\([^>\n]+\\)>[^\n]+" - 1 ,no-line) - - ;; PLT Scheme 4.1.2 "default-load-handler" error without useful filename: - ("default-load-handler: cannot open input-file: " - nil ,no-line) - - ))) - -(defun quack-compile-no-line-number (filename column) - (list (point-marker) filename 1 (and column (string-to-number column)))) - -(defun quack-install-compilation-mode-stuff () - (unless quack-saved-compilation-error-regexp-alist - (setq quack-saved-compilation-error-regexp-alist - compilation-error-regexp-alist)) - (setq compilation-error-regexp-alist - (append quack-compilation-error-regexp-alist-additions - quack-saved-compilation-error-regexp-alist))) - -(quack-install-compilation-mode-stuff) - -;; Interpreter-mode-alist: - -(defvar quack-saved-interpreter-mode-alist nil) - -(defvar quack-interpreter-mode-alist-additions - (mapcar (function (lambda (x) - (cons x 'scheme-mode))) - '("bigloo" - "csi" - "gosh" - "gsi" - "guile" - "kawa" - "mit-scheme" - "mred" - "mred3m" - "mredcgc" - "mzscheme" - "mzscheme3m" - "mzschemecgc" - "r5rs" - "r6rs" - "rs" - "rs" - "scheme" - "scheme48" - "scsh" - "sisc" - "stklos" - "sxi"))) - -(defun quack-install-interpreter-mode-alist () - (unless quack-saved-interpreter-mode-alist - (setq quack-saved-interpreter-mode-alist - interpreter-mode-alist)) - (setq interpreter-mode-alist - (append quack-interpreter-mode-alist-additions - quack-saved-interpreter-mode-alist))) - -(quack-install-interpreter-mode-alist) - -;; PLT Package Mode: - -;; TODO: Do some simple checking and summarize what directories and files are -;; getting modified by this package. - -;; TODO: Maybe don't worry about preserving the decompressed text verbatim in -;; the buffer -- set markers and generate headings, and be able to -;; construct valid package. - -;; TODO: Command to install package from original file using "setup-plt". - -;; TODO: Fontify Scheme code file contents. - -(defvar quack-pltfile-mode-hook nil) - -(defvar quack-hiding-ovlcat) -(put 'quack-hiding-ovlcat 'face 'default) -(put 'quack-hiding-ovlcat 'intangible t) -(put 'quack-hiding-ovlcat 'invisible t) - -(defvar quack-pltfile-mode-map (make-sparse-keymap)) -(define-key quack-pltfile-mode-map "q" 'quack-pltfile-quit) -(define-key quack-pltfile-mode-map "r" 'quack-pltfile-raw) -(define-key quack-pltfile-mode-map " " 'scroll-up) - -;; TODO: Make a menu map for pltfile-mode. - -(defun quack-pltfile-mode () - (interactive) - "Major mode for viewing PLT Scheme `.plt' package files. - -\\{quack-pltfile-mode-map} - -Provided by Quack: http://www.neilvandyke.org/quack/" - (kill-all-local-variables) - (put 'quack-pltfile-mode 'mode-class 'special) - (setq major-mode 'quack-pltfile-mode) - (setq mode-name "PLT Package") - (use-local-map quack-pltfile-mode-map) - ;; Note: Currently, the `font-lock' feature is always defined, since we - ;; require it. - (when (featurep 'font-lock) - (setq font-lock-defaults nil)) - (buffer-disable-undo) - (let ((saved-bmp (buffer-modified-p))) - (quack-activity "Decoding PLT package" (quack-pltfile-decode-buffer)) - (setq buffer-read-only t) - (set-buffer-modified-p saved-bmp)) - (quack-when-xemacs - (make-variable-buffer-local 'write-contents-hooks)) - (add-hook 'write-contents-hooks 'quack-prevent-pltfile-write) - (run-hooks 'quack-pltfile-mode-hook) - (message "Decoded PLT package. %s" - (substitute-command-keys - (concat "`\\[quack-pltfile-quit]' to quit" - ", `\\[quack-pltfile-raw]' for raw format.")))) - -(defun quack-prevent-pltfile-write () - (unless (yes-or-no-p - "Write a decoded PLT package buffer?! Are you *sure*?!") - (error "Aborted write of decoded PLT package buffer."))) - -(defun quack-pltfile-raw () - (interactive) - (let ((auto-mode-alist '())) - (setq buffer-read-only nil) - (widen) - (delete-region (point-min) (point-max)) - (fundamental-mode) - (revert-buffer t t))) - -(defun quack-pltfile-quit () - (interactive) - (kill-buffer (current-buffer))) - -(defun quack-skip-whitespace-to-nonblank-line-beginning () - (save-match-data - (while (looking-at "[ \t\r\f]*\n") - (goto-char (match-end 0))))) - -(defun quack-pltfile-decode-buffer () - - ;; MIME Base-64 decode. (Note: an error is signaled if this fails.) - (base64-decode-region (point-min) (point-max)) - - ;; Gzip decompress. - (let ((coding-system-for-write (if quack-xemacs-p 'binary 'raw-text-unix)) - (coding-system-for-read (if quack-xemacs-p 'binary 'raw-text-unix)) - (inhibit-eol-conversion t) - status) - (unless (= (setq status (call-process-region (point-min) (point-max) - "gzip" t t nil "-d")) 0) - (error "Could not decompress PLT package: gzip process status %s" - status))) - - ;; Move past the "PLT" cookie, and the two sexp forms. - (goto-char (point-min)) - (unless (looking-at "PLT") - (error "This does not appear to be a PLT package file.")) - (goto-char (match-end 0)) - (forward-list 2) - (quack-skip-whitespace-to-nonblank-line-beginning) - (quack-make-face-ovlext (point-min) (point) 'quack-pltfile-prologue-face) - - ;; Process the buffer contents. - (let ((standard-input (current-buffer))) - - (while (not (eobp)) - (let ((step-beg (point))) - ;; TODO: This read will fail if we just had whitespace at the end of - ;; the file, which it shouldn't, but maybe we should check, just - ;; in case. - (let ((sym (read))) - (unless (symbolp sym) - (error "Expected a symbol, but saw: %S" sym)) - (cond - - ((eq sym 'dir) - (forward-list) - (quack-skip-whitespace-to-nonblank-line-beginning) - (quack-make-face-ovlext step-beg - (point) - 'quack-pltfile-dir-face)) - - ((memq sym '(file file-replace)) - (forward-list) - (let ((size (read))) - (unless (and (integerp size) (>= size 0)) - (error "Expected a file size, but saw: %S" size)) - (unless (looking-at "[ \t\r\n\f]*\\*") - (error "Expected a `*' after file size.")) - (goto-char (match-end 0)) - - ;; Fontify the file header. - (quack-make-face-ovlext step-beg - (1- (point)) - 'quack-pltfile-file-face) - - ;; Hide the file contents asterisk. - (quack-make-hiding-ovlext (1- (point)) (point)) - - ;; Set the coding region for the content. - (let* ((content-beg (point)) - (content-end (+ content-beg size)) - (cs (detect-coding-region content-beg - content-end))) - (goto-char content-end) - (when (listp cs) - (setq cs (car cs))) - (unless (eq cs 'undecided) - (cond ((eq cs 'undecided-dos) (setq cs 'raw-text-dos)) - ((eq cs 'undecided-mac) (setq cs 'raw-text-mac)) - ((eq cs 'undecided-unix) (setq cs 'raw-text-unix))) - (decode-coding-region content-beg content-end cs)) - ;; TODO: XEmacs 21 `decode-coding-region' seems to lose the - ;; point position. This is disconcerting, since the - ;; point semantics under coding system changes do not - ;; currently seem to be well-specified, so resetting the - ;; point here *might* not always be the right thing to - ;; do. Verify. - (quack-when-xemacs - (goto-char content-end))))) - - (t (error "Expected `dir', `file', or `file-replace', but saw: %S" - sym))))))) - - ;; Return point to top of buffer. - (goto-char (point-min))) - -;; The rest of this file except for the `provide' form is TODO comments. - -;; TODO: Add tool bar support later. -;; -;; (defvar quack-toolbarimage-width 24) -;; (defvar quack-toolbarimage-height 24) -;; -;; (defun quack-create-image (&rest args) -;; (if (and quack-gnuemacs-p (>= emacs-major-version 21)) -;; (apply 'create-image args) -;; nil)) -;; -;; (defun quack-make-toolbarimage (&rest lines) -;; ;; TODO: We really should make an efficient function to print N spaces -;; ;; or to return a string of N spaces. Or at least keep 1-2 -;; ;; strings for the left and right padding here, which will -;; ;; usually be the same for the duration of this function. -;; (quack-create-image -;; (let* ((lines-count (length lines)) -;; (blank-line (make-string quack-toolbarimage-width 32))) -;; (and (> lines-count quack-toolbarimage-height) (quack-internal-error)) -;; (with-output-to-string -;; (princ "/* XPM */\nstatic char *magick[] = {\n") -;; ;;(princ "/* columns rows colors chars-per-pixel */\n") -;; (princ (format "\"%d %d 5 1\",\n" -;; quack-toolbarimage-width quack-toolbarimage-height)) -;; (princ "\". c #f0f0f0\",\n") -;; (princ "\"@ c #0f0f0f\",\n") -;; (princ "\"g c #00b000\",\n") -;; (princ "\"r c #d00000\",\n") -;; (princ "\" c None\",\n") -;; ;;(princ "/* pixels */\n") -;; (let ((line-num 0)) -;; (mapcar (function -;; (lambda (line) -;; (princ "\"") -;; (if line -;; (let* ((c (length line)) -;; (l (/ (- quack-toolbarimage-width c) 2))) -;; (and (> c quack-toolbarimage-width) -;; (quack-internal-error)) -;; (princ (make-string l 32)) -;; (princ line) -;; (princ (make-string (- quack-toolbarimage-width -;; c l) -;; 32))) -;; (princ blank-line)) -;; (if (< (setq line-num (1+ line-num)) -;; quack-toolbarimage-height) -;; (princ "\",\n") -;; (princ "\"\n")))) -;; (let ((rows-before (/ (- quack-toolbarimage-width -;; lines-count) -;; 2))) -;; `(,@(make-list rows-before nil) -;; ,@lines -;; ,@(make-list (- quack-toolbarimage-height -;; lines-count rows-before) -;; nil))))) -;; (princ "};\n"))) -;; 'xpm t)) -;; -;; (defvar quack-tbi-evalbuf -;; (quack-make-toolbarimage -;; "@@@@@@@@@@ " -;; "@........@@ " -;; "@........@.@ ggg " -;; "@........@..@ ggg " -;; "@........@@@@@ ggg " -;; "@............@ ggg " -;; "@..@@........@ ggg " -;; "@...@@.......@ ggg " -;; "@....@@......@ ggg " -;; "@.....@@.....@ ggg " -;; "@....@@@@....@ ggg " -;; "@...@@..@@...@ ggg " -;; "@..@@....@@..@ ggg " -;; "@............@ ggg " -;; "@@@@@@@@@@@@@@ ggg " -;; " ggg " -;; " ggggggg" -;; " ggggg " -;; " ggg " -;; " g ")) -;; -;; (defvar quack-tbi-adoc -;; (quack-make-toolbarimage -;; "@@@@@@@@@@ " -;; "@........@@ " -;; "@........@.@ " -;; "@........@..@ " -;; "@........@@@@@" -;; "@...@@@......@" -;; "@..@@@@@@....@" -;; "@..@....@@...@" -;; "@...@@@.@@...@" -;; "@..@@@@@@@...@" -;; "@..@@...@@...@" -;; "@..@@..@@@...@" -;; "@...@@@@.@@..@" -;; "@............@" -;; "@@@@@@@@@@@@@@")) -;; -;; (defvar quack-tbi-manual -;; (quack-make-toolbarimage -;; "@@@@@@@@@@ " -;; "@........@@ " -;; "@........@.@ " -;; "@........@..@ " -;; "@........@@@@@" -;; "@............@" -;; "@..@@.@.@@...@" -;; "@..@@@@@@@@..@" -;; "@..@@.@@.@@..@" -;; "@..@@.@@.@@..@" -;; "@..@@.@@.@@..@" -;; "@..@@.@@.@@..@" -;; "@..@@.@@.@@..@" -;; "@............@" -;; "@@@@@@@@@@@@@@")) -;; -;; (defvar quack-tbi-manuallookup -;; (quack-make-toolbarimage -;; "@@@@@@@@@@ " -;; "@........@@ " -;; "@........@.@ " -;; "@........@..@ " -;; "@........@@@@@ " -;; "@............@ " -;; "@..@@.@@@@@@@@@@ " -;; "@...@@@........@@ " -;; "@....@@........@.@ " -;; "@.....@........@..@ " -;; "@....@@........@@@@@" -;; "@...@@@............@" -;; "@..@@.@..@@.@.@@...@" -;; "@.....@..@@@@@@@@..@" -;; "@@@@@@@..@@.@@.@@..@" -;; " @..@@.@@.@@..@" -;; " @..@@.@@.@@..@" -;; " @..@@.@@.@@..@" -;; " @..@@.@@.@@..@" -;; " @............@" -;; " @@@@@@@@@@@@@@")) -;; -;; (defvar quack-tbi-stop -;; (quack-make-toolbarimage -;; " @@@@@ " -;; " @@rrrrr@@ " -;; " @rrrrrrrrr@ " -;; " @rrrrrrrrr@ " -;; "@rr@@rrr@@rr@" -;; "@rrr@@r@@rrr@" -;; "@rrrr@@@rrrr@" -;; "@rrr@@r@@rrr@" -;; "@rr@@rrr@@rr@" -;; " @rrrrrrrrr@ " -;; " @rrrrrrrrr@ " -;; " @@rrrrr@@ " -;; " @@@@@ ")) -;; -;; (defun quack-install-tool-bar () -;; (require 'tool-bar) -;; (let ((map (make-sparse-keymap))) -;; -;; (quack-define-key-after map [quack-load-file] -;; `(menu-item "quack-evalbuffer" scheme-load-file -;; :image ,quack-tbi-evalbuf -;; :help "Load File")) -;; -;; (quack-define-key-after map [quack-alpha] -;; `(menu-item "quack-alpha" quack-alpha -;; :image ,quack-tbi-adoc -;; :help "alpha")) -;; -;; (quack-define-key-after map [quack-manual] -;; `(menu-item "quack-manual" quack-manual -;; :image ,quack-tbi-manual -;; :help "View Manual")) -;; -;; (quack-define-key-after map [quack-view-keyword-docs] -;; `(menu-item "quack-view-keyword-docs" -;; quack-view-keyword-docs -;; :image ,quack-tbi-manuallookup -;; :help "View Keyword Docs")) -;; -;; (quack-define-key-after map [quack-stop] -;; `(menu-item "quack-stop" quack-stop -;; :image ,quack-tbi-stop -;; :help "Stop")) -;; -;; (set (make-local-variable 'tool-bar-map) map))) - -;; TODO: Extend `scheme-imenu-generic-expression' for PLT-specific definition -;; forms and for definitions within modules. - -;; TODO: Clickable URLs -;; -;; (defvar quack-url-keymap) -;; -;; (setq quack-url-keymap (make-sparse-keymap)) -;; (define-key quack-url-keymap "\r" 'quack-browse-overlaid-url) -;; (define-key quack-url-keymap "q" 'quack-browse-overlaid-url) -;; -;; (defun quack-make-url-overlay (beg end &optional url) -;; (let ((ovl (make-overlay beg end nil t))) -;; (overlay-put ovl 'face 'underline) -;; (overlay-put ovl 'local-map 'quack-url-keymap) -;; (overlay-put ovl 'help-echo "Press RET to browse this URL.") -;; (overlay-put ovl 'quack-url -;; (or url (buffer-substring-no-properties beg end))) -;; ovl)) -;; -;; (defun quack-insert-url (url) -;; (let* ((beg (point))) -;; (insert url) -;; (quack-make-url-overlay beg (point)))) -;; -;; (defun quack-overlaid-url-at-point (&optional pt) -;; (let ((overlays (overlays-at (or pt (point)))) -;; (url nil)) -;; (while overlays -;; (setq overlays (if (setq url (overlay-get (car overlays) 'quack-url)) -;; (cdr overlays) -;; '()))) -;; url)) -;; -;; (defun quack-browse-overlaid-url (pt) -;; ;; Dehydration. -;; (interactive "d") -;; (quack-browse-url (quack-overlaid-url-at-point pt))) - -;; TODO: Possible Future Inferior Process I/O Stuff. Make encoding with -;; inferior process disambiguate REPL values, port output, error info, -;; etc. Start of code commented out below. This may require rewriting -;; chunks of `cmuscheme' and `comint'. -;; -;; Try to use ELI protocol first. http://www.cliki.net/ELI -;; -;; (defface quack-output-face -;; '((((class color)) (:foreground "purple4" :background "lavender")) -;; (t (:inverse-video t))) -;; "Face used for..." -;; :group 'quack) -;; -;; (defface quack-value-face -;; '((((class color)) (:foreground "blue4" :background "light sky blue")) -;; (t (:inverse-video t))) -;; "Face used for..." -;; :group 'quack) -;; -;; Escape Codes: -;; REPL State: -;; R repl read begin -;; r repl read end -;; E repl eval begin -;; e repl eval end -;; P repl print begin -;; p repl print end -;; Stream Change: -;; O output stream -;; E error stream -;; Error Info? -;; -;; (defconst quack-mzscheme-init-string -;; (let ((print-length nil) -;; (print-level nil)) -;; (prin1-to-string -;; '(let ((o (current-output-port)) -;; (i (current-input-port)) -;; (e (current-eval))) -;; ;; TODO: Define custom escaping output and error ports here. -;; (current-prompt-read -;; (lambda () -;; (display "\eR" o) -;; (begin0 (read-syntax "quack-repl" i) -;; (display "\er" o)))) -;; (current-eval -;; (lambda (n) -;; (display "\eE" o) -;; (begin0 (e n) -;; (display "\ee" o)))) -;; (current-print -;; (lambda (n) -;; (display "\eP" o) -;; (begin0 (print n o) -;; (display "\ep" o)))))))) -;; -;; In `quack' function, after call to `run-scheme': -;; -;; (add-hook 'comint-preoutput-filter-functions -;; 'quack-comint-preoutput-filter-func) -;; (comint-send-string (scheme-proc) quack-mzscheme-init-string) -;; (comint-send-string (scheme-proc) "\n") - -;; TODO: If we do that, then add pretty-printing of REPL results. - -;; TODO: Maybe provide utilities for converting to/from PLT-style -;; square-bracket paren conventions. - -;; TODO: Populate abbrevs table from keywords extracted from manuals, and from -;; definitions in current buffer. Or maybe query running MzScheme -;; process for bound symbols. - -;; TODO: Maybe use `compile-zos' to do error-checking for PLT (look up person -;; to credit with idea of using that to get more warnings). Need to know -;; more about a particular Scheme implementation than just the command -;; line to start its REPL, though. - -;; TODO: Perhaps put some initialization code that depends on user's custom -;; settings into after-init-hook. See if this works in XEmacs. - -;; TODO: Set `interpreter-mode-alist' based on interpreter list. - -;; TODO: "I think it would be good if the quack menu showed up only when emacs -;; was in Scheme mode." - -;; TODO: Support this: -;; -;; * Added 'addon-dir for `find-system-path': -;; Unix: "~/.plt-scheme" -;; Windows: "PLT Scheme" in the user's Application Data folder. -;; Mac OS X: "~/Library/PLT Scheme" -;; Mac OS Classic: "PLT Scheme" in the preferences folder. -;; -;; The version string for "~/.plt-scheme/<version>/collects/" might be: -;; mzscheme -mqe '(begin (display (version)) (exit))' -;; Double-check PLT source first. - -;; TODO: Add autoindenting to inferior Scheme buffer when pressing RET on an -;; incomplete sexp -- iff we can do this reliably enough. - -;; TODO: When tidying and point is within a series of multiple blank lines that -;; are reduced to a single blank line, leave point at the beginning of -;; the single blank line. - -;; TODO: Riastradh says: Do you suppose you could add a feature to Quack that -;; indents lists beginning with symbols of the form WITH-... & -;; CALL-WITH-... as if their SCHEME-INDENT-FUNCTION property were DEFUN? - -;; TODO: Matt Dickerson asks " Also, the command history appears to be based on -;; newlines -- I work with blocks of code in the REPL and would like C-p -;; to give me the last block, not the last line of the previous block." - -;; TODO: Maybe get appropriate PLT collection path from the default for -;; whatever "mzscheme" executable is picked up. -;; -;; mzscheme -emq '(begin (write (current-library-collection-paths)) (exit 0))' -;; ("/home/neil/collects" "/home/neil/.plt-scheme/208/collects" -;; "/usr/lib/plt/collects") - -;; TODO: Bind M-[ to quack-insert-parentheses - -;; TODO: Peter Barabas reports that `quack-global-menu-p' set to nil doesn't -;; disable the menu. - -;; TODO: Way to get default collects directories. From Matthew Flatt, -;; 2006-04-22: -;; -;; env PLTCOLLECTS="" mzscheme -mvqe '(printf "~s\n" (map path->string -;; (current-library-collection-paths)))' - -;; TODO: Have key binding to insert "lambda" (for use with pretty-lambda). -;; Suggested by Olwe Bottorff on 2006-04-20. - -;; TODO: Jerry van Dijk writes: "I would like to try out quack, but I do not -;; like its menu constantly on the main menu bar (as I use emacs for a lot of -;; things). Unfortunately sofar quack has bravely defied all my attempts to -;; remove it. From desecting the customize option to adding (define-key -;; global-map [menu-bar quack] nil)" - -;; TODO: We could do this: -;; -;; mzscheme -m -e "(begin (display #\') (write (map path->string (current-library-collection-paths))) (newline) (exit))" -;; '("/home/neil/collects" -;; "/home/neil/.plt-scheme/360/collects" -;; "/usr/lib/plt/collects") - -;; emacs22 -batch -no-site-file -f batch-byte-compile quack.el ; rm quack.elc -;; emacs21 -batch -no-site-file -f batch-byte-compile quack.el ; rm quack.elc -;; emacs20 -batch -no-site-file -f batch-byte-compile quack.el ; rm quack.elc -;; xemacs21 -batch -no-site-file -f batch-byte-compile quack.el ; rm quack.elc - -;; End: - -(provide 'quack) - -;; quack.el ends here diff --git a/elisp/emacs-goodies-el/rfcview.el b/elisp/emacs-goodies-el/rfcview.el deleted file mode 100644 index eefe201..0000000 --- a/elisp/emacs-goodies-el/rfcview.el +++ /dev/null @@ -1,860 +0,0 @@ -;;; rfcview.el -- view IETF RFCs with readability-improved formatting - -;; Copyright (C) 2001-2002 Neil W. Van Dyke -;; Copyright (C) 2006, 2008, 2009 Free Software Foundation, Inc. -;; (mods by Dave Love <fx@gnu.org>) - -;; Author: Neil W. Van Dyke <neil@neilvandyke.org> -;; Author: Dave Love <fx@gnu.org> -;; Version: 0.13 -;; X-URL: http://www.loveshack.ukfsn.org/emacs/rfcview.el - -;; This file 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 3 of the License, or -;; (at your option) any later version. - -;; This file 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 GNU Emacs. If not, see <http://www.gnu.org/licenses/>. - -;; [Van Dyke's original is GPL 2 or later.] - -;;; COMMENTARY: - -;; Introduction: -;; -;; For historical reasons, IETF Internet RFCs are required to be in a plain -;; ASCII text format that's best-suited for sending directly to a 6-lpi -;; US-letter-size printer. This makes them suboptimal for viewing on-screen, -;; as you will be doing for countless hours if you're ever doing network -;; programming to one of them. Fortunately, the ASCII format is usually -;; close to what you, the Emacs zealot, *truly* want -- which is a format -;; suited to more pleasurably viewing the RFC in Emacs. -;; -;; The `rfcview' package uses Emacs overlays to add some fontification and -;; hide the page headers and footers (which it replaces with one-line page -;; number references that look like "(p.1)", right-justified). The file is -;; never modified, and you can see the raw ASCII text by pressing `t'. - -;; System Requirements: -;; -;; The `rfcview.el' package was first written using FSF GNU Emacs 20.7 on a -;; GNU/Linux system, and is now maintained under Emacs 21.4. It should work -;; with recent Emacs versions on Unix variants. `rfcview.el' has not yet -;; been tested with the XEmacs fork of Emacs, and I'd welcome any necessary -;; patches. - -;; Installation: -;; -;; 1. Put this `rfcview.el' file somewhere in your Emacs Lisp load path. -;; -;; 2. Add the following lines to your `~/.emacs' file: -;; -;; (add-to-list 'auto-mode-alist -;; '("/\\(rfc\\|std\\)[0-9]+\\.txt\\'" . rfcview-mode)) -;; -;; (autoload 'rfcview-mode "rfcview" nil t) -;; -;; The next time you visit an RFC file, it should be -;; displayed prettily using `rfcview-mode'. (Do this before turning -;; on `auto-compression-mode', so that the `.gz' extension comes before -;; `.txt' in `auto-mode-alist'; then compressed RFCs will work too.) -;; -;; 4. Optionally, do `M-x rfcview-customize RET' to customize the mode -;; options. - -;; Things for the Author to Someday Do (but Probably Not): -;; -;; * RFC 1700 (STD 2) has unnumbered headings and column-zero body text. We -;; don't try to cope right now, but we might assume, e.g., that lines in -;; all-caps with preceding and succeeding blank lines are headings. -;; -;; * Hide extraneous blank lines. -;; -;; * Handle "Table of Contents" heading centered, such as in RFC 1035 and RFC -;; 1157. -;; -;; * Display bibliographic references in other-window -;; vertically-sized to fit only the reference (or min window height). -;; -;; * Download RFCs on demand, and cache them. Probably integrate one of the -;; existing one or two packages that do this. -;; -;; * Make an RFCedit mode. -;; -;; * Handle multi-line heading like: -;; -;; 19.6.1.1 Changes to Simplify Multi-homed Web Servers and Conserve IP -;; Addresses -;; -;; * Have a stack for (internal) hyperlinks a la Info. -;; -;; * Deal with an index (e.g. RFC 3986). - -;;; CHANGE LOG: - -;; [Version 0.11, 2008-02-02] (Dave Love) -;; * rfcview-find-rfc. -;; -;; [Version 0.10, 2008-01-28] (Dave Love) -;; * Fix rfcview-find-location-of-rfc-mouse interactive spec. -;; * Get speedbar working. -;; * Allow list of alternative locations for RFCs. -;; -;; [Version 0.9, 2007-10-14] (Dave Love) -;; * Fix view-mode require and fix overlay type for reference. -;; -;; [Version 0.8, 2007-04-25] (Dave Love) -;; * Fix rfcview-overriding-map; modify rfcview-headlink-face for dark b/g. -;; -;; [Version 0.7, 2006-10-01] (Dave Love) -;; * Use ange-ftp, not browse-url; -;; * Handle STDs as well as RFCs. -;; -;; [Version 0.6, 2006-07-07] Hyperlinking, imenu (Dave Love). -;; -;; [Version 0.5, 15-Oct-2002] Updated email address. -;; -;; [Version 0.4, 26-Feb-2002] -;; * Added `rfcview-use-view-mode-p' feature (suggested by Andreas Fuchs). -;; * Added `.gz' handling to `auto-mode-alist' example for people whose Emacs -;; auto-decompression features don't strip the compression extension before -;; doing the `auto-mode-alist' lookup. (thanks to Andreas Fuchs) -;; -;; [Version 0.3, 22-Feb-2002] -;; * Added autoload cookie (suggested by Daniel Pittman). - -;; [Version 0.2, 22-Feb-2002] -;; * Tweaks to support some Internet-Drafts. -;; * In heading patterns, `.' is now optional after single-integer heading -;; numbers, but remains mandatory after alphabetic (appendix) section -;; numbers. -;; * Hides carriage return characters (which is already done in some Emacs -;; configurations, but not in others). - -;; [Version 0.1, 17-Mar-2001] Initial release. Note that there's some -;; hyperlink-related code, but it's not finished, so pretend it's not there -- -;; but the static reformatting stuff works and is useful, and I can't spend any -;; more time on this package in the near future, so I'm releasing the package -;; now. - -;;; CODE: - -(require 'goto-addr) -(require 'view) - -;; Customization: - -(defgroup rfcview nil - "View IETF RFC files with formatting." - :group 'hypermedia - :prefix "rfcview-") - -(defcustom rfcview-mode-hook nil - "Hook variable for `rfcview-mode'." - :group 'rfcview - :type 'hook) - -(defcustom rfcview-use-view-mode-p t - "If non-nil, start `view-mode' when `rfcview-mode' is started." - :group 'rfcview - :type 'boolean) - -;; Note that this is also defined by `ffap-rfc-path', though Emacs -;; 21's value of that is wrong, and we probably don't want to require -;; ffap. -;; Fixme: This should be a path, e.g. local directory plus rfc-editor site. -(defcustom rfcview-rfc-location-pattern - "/ftp@ftp.rfc-editor.org:/in-notes/rfc%s.txt" - "Pattern to generate the location of a numbered RFC. -Must contain a single `%s' to be substituted with the RFC's number. -On a Debian-style system, with the doc-rfc packages installed, this could be -\"/usr/share/doc/RFC/links/rfc%s.txt.gz\" to read local copies. -A list of such patterns is also valid; its elements are tried in order -to find the RFC. Typically you want to try a local directory first and -then the IETF site. If you have installed suitable file handlers, e.g. -with `url-handler-mode', you can use arbitrary URL patterns. -See also `rfcview-std-location-pattern'." - :type '(choice string (repeat string)) - :group 'rfcview) - -(defcustom rfcview-std-location-pattern - "/ftp@ftp.rfc-editor.org:/in-notes/std/std%s.txt" - "Pattern to generate the location of a numbered STD. -Must contain a single `%s' to be substituted with the STD's number. -A list of such patterns is also valid; its elements are tried in order -to find the RFC. Typically you want to try a local directory first and -then the IETF site. See also `rfcview-rfc-location-pattern'." - :type '(choice string (repeat string)) - :group 'rfcview) - -(defcustom rfcview-index-location - (if (consp rfcview-rfc-location-pattern) - (mapcar (lambda (elt) - (replace-regexp-in-string "%s.txt" "-index.txt" elt)) - rfcview-rfc-location-pattern) - (replace-regexp-in-string "%s.txt" "-index.txt" - rfcview-rfc-location-pattern)) - "Location, or list of locations in which to find the RFC index. -The index is usually rfc-index.txt in the RFC directory." - :group 'rfcview - :type '(choice string (repeat string)) - :set-after '(rfcview-rfc-location-pattern)) - -(defface rfcview-title-face - '((t (:bold t))) - "Face used for titles." - :group 'rfcview) - -(defface rfcview-headname-face - '((t (:bold t :underline t))) - "Face used for heading names." - :group 'rfcview) - -(defface rfcview-headnum-face - '((t (:bold t))) - "Face used for heading numbers." - :group 'rfcview) - -(defface rfcview-headlink-face - '((((type tty pc) (class color)) (:foreground "blue" :weight light)) - (((class color) (background light)) (:foreground "blue")) - (((class color) (background dark)) (:foreground "LightSkyBlue")) - (t (:bold t))) - "Face used for hyperlinks to headings." - :group 'rfcview) - -(defface rfcview-mouseover-face - '((t (:inherit highlight))) - "Face used for mousing over a hyperlink." - :group 'rfcview) - -(defface rfcview-rfcnum-face - '((t (:bold t))) - "Face used for RFC number in the header." - :group 'rfcview) - -(defface rfcview-stdnum-face - '((t (:bold t))) - "Face used for STD number in the header." - :group 'rfcview) - -;; Global Variables: - -(defvar rfcview-debug-show-hidden-p nil) - -(defvar rfcview-mode-map - (let ((km (make-sparse-keymap))) - (define-key km "t" 'rfcview-textmode) - (define-key km "q" 'rfcview-quit) - (define-key km "\t" 'rfcview-next-button) - (easy-menu-define rfcview-mode-menu km - "Menu for RFCview." - '("RFCview" - ["Quit" rfcview-quit t] - ["Text Mode" rfcview-textmode t] - ["Next Button" rfcview-next-button t])) - km)) - -(defvar rfcview-stock-section-names - '("abstract" - "acknowledgement" - "acknowledgements" - "acknowledgment" - "acknowledgments" - "appendices" - "author's address" - "authors' addresses" - "bibliography" - "chair's address" - "copyright notice" - "copyright statement" - "editor's address" - "editors' addresses" - "full copyright notice" - "full copyright statement" - "iesg note" - "index" - "introduction" - "references and bibliography" - "references" - "security considerations" - "status of this memo" - "table of contents" - "informative references" - "normative references")) - -(defvar rfcview-headlink-ovlcat nil) -(defvar rfcview-headname-ovlcat nil) -(defvar rfcview-headnum-ovlcat nil) -(defvar rfcview-hide-ovlcat nil) -(defvar rfcview-pagenum-ovlcat nil) -(defvar rfcview-title-ovlcat nil) - -;; Buffer-Local Variables: - -(defvar rfcview-local-heading-alist nil) - -(defvar rfcview-ref-alist nil - "Alist of RFC references `(<reference> . <position>)'.") - -;; Functions: - -(defun rfcview-add-overlay (begin end category) - (unless category (error "rfcview-add-overlay nil category")) - (let ((overlay (make-overlay begin end))) - (overlay-put overlay 'category category) - overlay)) - -;;;###autoload -(defun rfcview-customize () - "Enter the RFCview Custom group." - (interactive) - (customize-group 'rfcview)) - -(defun rfcview-grok-buffer () - "Add overlays to the buffer to modify its presentation." - (interactive) - (let ((case-fold-search nil) - (top-point (point-min)) - (title-line-point nil)) - - ;; Clean up everything. - (rfcview-remove-all-overlays) - (make-local-variable 'rfcview-local-heading-alist) - (setq rfcview-local-heading-alist '()) - - ;; Hide any CRs. - (goto-char (point-min)) - (while (re-search-forward "\r+" nil t) - (rfcview-hide-region (match-beginning 0) (match-end 0))) - - ;; Add hiding overlay for whitespace at start of file, and set `top-point' - ;; to just after it. - (goto-char (point-min)) - (when (re-search-forward "\\`\\([ \t\f]*\r?\n\\)+" nil t) - (rfcview-hide-region (match-beginning 0) (match-end 0)) - (setq top-point (point))) - - ;; Add overlays for page headers and footers. - (let ((headerfooter-re (concat "^[ \t]*" - "\\(\r?\n\\)" ; #1 - "\\([ \t]*\r?\n\\)*" ; #2 - "[^ \t\f].*\\[Page " - "\\([0-9iIvVxX]+\\)" ; #3 - "\\][ ]*\r?\n?" - "\\(" ; <#4 - "\f" - "\\([ \t]*\r?\n\\)?" ; #5 - "\\(" ; <#6 - "\\(" ; <#7 - "RFC [0-9]+" - "\\|" ; |#7 - "Internet-Draft[ \t]" - "\\)" ; >#7 - ".*\r?\n" - "\\([ \t]*\r?\n\\)*" ; #8 - "\\)?" ; >#6 - "\\)?" ; >#4 - ))) - (while (re-search-forward headerfooter-re nil t) - (rfcview-hide-region (match-end 1) (match-end 0)) - (when (match-beginning 6) - (let ((overlay (rfcview-add-overlay (match-beginning 1) - (match-end 1) - 'rfcview-pagenum-ovlcat)) - ;; Note: If we wanted to do this right, we would save a marker - ;; and then backpatch once we see the next page footer. - (page-str (format - "(p.%s)" - (let ((n (string-to-number (match-string 3)))) - (if (= n 0) "?" (1+ n)))))) - (overlay-put overlay - 'before-string - (concat (make-string (max (- 79 - (- (match-beginning 1) - (match-beginning 0)) - (length page-str)) - 0) - 32) - page-str)))))) - - ;; Find the first blank line (which should be between top headers and - ;; before title), remember point, and hide any extraneous blank lines. - (goto-char top-point) - (unless (re-search-forward (concat "^[ \t]*\r?\n" - "\\(\\([ \t]*\r?\n\\)+\\)?") - nil t) - (error "This doesn't seem to be an RFC - no blank line before title")) - (when (match-beginning 1) - (rfcview-hide-region (match-beginning 1) (match-end 1))) - (setq title-line-point (point)) - - ;; Add overlay for the RFC number. - (goto-char top-point) - (when (let ((case-fold-search t)) - (re-search-forward "^request for comments:[ \t]+\\([0-9X]+\\)" - title-line-point t)) - (rfcview-add-overlay (match-beginning 1) - (match-end 1) - 'rfcview-rfcnum-ovlcat)) - - ;; Add overlay for the STD number. - (goto-char top-point) - (when (let ((case-fold-search nil)) - (re-search-forward "^STD:[ \t]+[0-9]+" - title-line-point t)) - (rfcview-add-overlay (match-beginning 0) - (match-end 0) - 'rfcview-stdnum-ovlcat)) - - ;; Add overlays to the title line(s). Note that we currently assume no - ;; blank lines in the title; otherwise we have to do a perfect job of - ;; identifying the first non-title line (usually a section heading, which - ;; some some RFCs make difficult to always identify). - (goto-char title-line-point) - (if (re-search-forward (concat - "\\([^ \t\f\r\n].*[^ \t\f\r\n]\\)" - "\\(\r?\n[ \t]*[^ \t\f\r\n].*[^ \t\f\r\n]\\)*")) - (rfcview-add-overlay (match-beginning 0) - (match-end 0) - 'rfcview-title-ovlcat)) - - ;; Find all the headings. Add overlays for them, and build - ;; `rfcview-local-heading-alist'. - (goto-char title-line-point) - (let ((case-fold-search t) - ;; Note: We can't just look for lines that begin in column 0, since - ;; some RFCs put source code, ASCII-art, description list headings, - ;; body text, and other stuff in column 0. So we look for stock - ;; headings and ones that appear to begin with section numbers. - (heading-re (concat - "^" - "\\(" ; <#1 - "\\(" ; <#2 = numbered section - "\\(" ; <#3 = number - "\\([0-9]+\\.?\\|[A-Z]\\.\\)" ; #4 - "\\([0-9]+\\.?\\)*" ; #5 - "\\)" ; >#3 = number - "[ \t]+" - "\\([^\r\n]+\\)" ; #6 = name - "\\)" ; >#2 = numbered section - "\\|" ; |#1 - "\\(" ; <#7 = stock section - "\\(" ; <#8 - (mapconcat 'identity rfcview-stock-section-names "\\|") - "\\)" ; >#8 - ":?[ \t]*$" - "\\)" ; >#7 = stock section - "\\|" ; |#1 - "\\(" ; <#9 = lit-appendix - - "appendix[ \t]+" - "\\([A-Z]\\)" ; #10 = number - - "\\(\\.\\|:\\|[ \t]+-\\)" ; #11 - "[ \t]+" - "\\([^\r\n]+\\)" ; #12 = name - - "\\)" ; >#9 = lit-appendix - "\\)" ; >#1 - ))) - (while (re-search-forward heading-re nil t) - (let ((num-match nil) - (num-highlight-begin nil) - (num-highlight-end nil) - (name-match nil)) - ;; Get the match data numbers. - (cond ((match-beginning 3) (setq num-match 3 - name-match 6)) - ((match-beginning 8) (setq num-match nil - name-match 8)) - ((match-beginning 9) (setq num-match 10 - name-match 12) - (setq num-highlight-begin (match-beginning 9) - num-highlight-end (match-end 11))) - (t (error "This should never happen"))) - - ;; Don't lose if author's initial used in page footer. - (unless (save-match-data - (string-match "[[]Page [0-9iIvVxX]+]\\'" - (match-string name-match))) - ;; Add overlays. - (when num-match - (rfcview-add-overlay (or num-highlight-begin - (match-beginning num-match)) - (or num-highlight-end - (match-end num-match)) - 'rfcview-headnum-ovlcat)) - (rfcview-add-overlay (match-beginning name-match) - (match-end name-match) - 'rfcview-headname-ovlcat) - ;; Prepend the `rfcview-local-heading-alist' entry. - (let ((num (when num-match - (upcase (match-string-no-properties num-match)))) - (name (match-string-no-properties name-match))) - (push (cons (downcase (or num name)) - (vector - num - name - (match-beginning 0) - (match-end 0))) - rfcview-local-heading-alist)))))) - ;; Reverse `rfcview-local-heading-alist'. - (setq rfcview-local-heading-alist (nreverse rfcview-local-heading-alist)) - - ;; Hyperlink the contents and references - (rfcview-hyperlink-contents) - (rfcview-hyperlink-refs) - - ;; Hyperlink URLs. `goto-address-fontify-maximum-size' is only - ;; 30000 by default. - (let ((goto-address-fontify-maximum-size (point-max)) - (goto-address-highlight-p t) - (goto-address-mail-regexp "\\<\\>")) ; don't match emails - (goto-address)) - - ;; Leave the point at the visible top of the buffer. - (goto-char top-point)) - - (message "This RFC has been reformatted for viewing in Emacs.")) - -(defun rfcview-hide-region (start end) - (rfcview-add-overlay start end 'rfcview-hide-ovlcat)) - -;; Hyperlinking - -(defun rfcview-imenu-index-function () - "`imenu-create-index-function' for RFCview." - (mapcar (lambda (elt) - (setq elt (cdr elt)) - (let ((num (aref elt 0)) - (head (aref elt 1)) - (pos (aref elt 2))) - (cons (if num - (concat num " " head) - head) - pos))) - rfcview-local-heading-alist)) - -(defun rfcview-link-add-headlink (start end pos) - (let ((overlay (rfcview-add-overlay start end 'rfcview-headlink-ovlcat))) - (overlay-put overlay 'rfcview-link (list 'head pos)) - overlay)) - -(defun rfcview-link-add-headlink-for (start end key) - (let ((vec (cdr (assoc (downcase key) rfcview-local-heading-alist)))) - (when vec - (rfcview-link-add-headlink start end (aref vec 2))))) - -(defun rfcview-hyperlink-contents () - "Find table of contents and hyperlink the entries to headers." - (let* ((elt (assoc "table of contents" rfcview-local-heading-alist)) - (start (if elt (aref (cdr elt) 3))) - (next (cadr (member elt rfcview-local-heading-alist))) - (end (if next (aref (cdr next) 2))) - (case-fold-search t)) - (when (and start end) - (save-excursion - (save-restriction - (narrow-to-region start end) - (goto-char (point-min)) - (dolist (elt rfcview-local-heading-alist) - (let ((key (car elt))) - (when (re-search-forward (concat "^ *\\(" (regexp-quote key) - "\\) ") - nil t) - (rfcview-link-add-headlink-for (match-beginning 1) - (line-end-position) - key) - (end-of-line))))))))) - -(defvar rfcview-link-map - (let ((map (make-sparse-keymap))) - (define-key map [mouse-2] #'rfcview-goto-link-mouse) - map) - "Keymap for use on link overlays.") - -(defvar rfcview-overriding-map - (let ((map (make-sparse-keymap))) - (define-key map "\C-m" #'rfcview-maybe-goto-link) - (set-keymap-parent map view-mode-map) - map) - "Keymap binding RET to override the View mode binding.") - -(defun rfcview-maybe-goto-link () - "Follow link if on one, else use normal binding of RET. -Push mark if on a link." - (interactive) - (or (rfcview-goto-link) - (rfcview-find-location-of-rfc) - (if (get-char-property (point) 'goto-address) ; URL found by goto-addr - (goto-address-at-point)) - ;; Use the binding that's presumably from View mode: - (let ((minor-mode-overriding-map-alist nil)) - (call-interactively (key-binding [?\C-m]))))) - -(defun rfcview-goto-link () - "If on a link, go to target, push mark, and return non-nil. -Else return nil." - (interactive) - (let ((pos (cadr (get-char-property (point) 'rfcview-link)))) - (when pos - (push-mark) - (goto-char pos)))) - -(defun rfcview-goto-link-mouse (event) - "Follow a link selected with the mouse EVENT and push mark." - (interactive "e") - (mouse-set-point event) - (rfcview-goto-link)) - -(defun rfcview-hyperlink-refs () - "Find references in appropriate sections and hyperlink them from elsewhere." - (save-excursion - ;; Find the references sections, including `Normative - ;; references' &c. - (dolist (elt rfcview-local-heading-alist) - (when (let ((case-fold-search t)) - (string-match "\\<\\(?:references\\|bibliography\\)\\'" - (aref (cdr elt) 1))) - (let* ((start (aref (cdr elt) 3)) - (next (cadr (member elt rfcview-local-heading-alist))) - (end (if next - (aref (cdr next) 2) - (point-max))) - (case-fold-search nil)) - (save-restriction - (narrow-to-region start end) - (goto-char (point-min)) - ;; Look for plausible-looking tags (with uppercase - ;; letters, numbers or hyphens within brackets). - (while (re-search-forward "^ *\\([[][-A-Z0-9]+]\\) " nil t) - (push (cons (match-string 1) (match-beginning 1)) - rfcview-ref-alist) - ;; If it looks like an RFC reference, hyperlink it. - (let ((start (match-beginning 1)) - (end (match-end 1)) - (string (match-string 1))) - (when (string-match "[[]\\(RFC\\|STD\\)\\([0-9]+\\)]" string) - (let ((overlay (make-overlay start end))) - (overlay-put overlay 'category 'rfcview-rfcurl-ovlcat) - (overlay-put overlay 'location - (if (equal "RFC" (match-string 1 string)) - (mapcar - (lambda (x) - (format x (match-string 2 string))) - (if (listp rfcview-rfc-location-pattern) - rfcview-rfc-location-pattern - (list rfcview-rfc-location-pattern))) - (mapcar - (lambda (x) - (format x (match-string 2 string))) - (if (listp rfcview-std-location-pattern) - rfcview-std-location-pattern - (list rfcview-std-location-pattern))))))))))))) - ;; Find and activate references in the body. Skip if it's at the - ;; position of a target. - (goto-char (point-min)) - (while (re-search-forward "\\([[][-A-Z0-9]+]\\)" nil t) - (let ((elt (assoc (match-string 1) rfcview-ref-alist))) - (when (and elt (/= (match-beginning 1) (cdr elt))) - (overlay-put (rfcview-add-overlay (match-beginning 1) (match-end 1) - 'rfcview-reflink-ovlcat) - 'rfcview-link (list 'ref (cdr elt)))))))) - -(defun rfcview-find-internal (files &optional sort mode) - "Find the first of FILES which exists. -FILES may be a list or a single file." - (catch 'found - (dolist (file files) - (when (file-exists-p file) - (let (text-mode-hook) ; don't run Flyspell etc. - (find-file file)) - (throw 'found t))) - (error "%s not found: %s" (or sort "RFC") - (mapconcat #'identity files ", "))) - (if (and mode (not (eq major-mode 'rfcview-mode))) - (rfcview-mode))) - -;;;###autoload -(defun rfcview-find-rfc (number) - "Find RFC NUMBER and view it in RFcview mode. -Interactively, prompt for the number. -See `rfcview-rfc-location-pattern' for where to search." - (interactive (rfcview-prompt-number)) - (rfcview-find-internal (mapcar - (lambda (x) - (format x number)) - (if (listp rfcview-rfc-location-pattern) - rfcview-rfc-location-pattern - (list rfcview-rfc-location-pattern))) - nil t)) - -(defun rfcview-prompt-number () - (let* ((n (number-at-point)) - (val (read-string "RFC number: " (if n (number-to-string n)) nil n))) - (if (> (length val) 0) - (list (string-to-number val)) - (error "Missing number")))) - -(defun rfcview-find-location-of-rfc () - "Browse to the LOCATION of any RFC referenced at point." - (interactive) - (rfcview-find-internal (get-char-property (point) 'location) nil t)) - -(defun rfcview-find-location-of-rfc-mouse (event) - "Browse to the LOCATION of the RFC reference at the mouse EVENT." - (interactive "e") - (save-excursion - (mouse-set-point event) - (rfcview-find-location-of-rfc))) - -(defvar rfcview-rfc-keymap - (let ((map (make-sparse-keymap))) - (define-key map [mouse-2] #'rfcview-find-location-of-rfc-mouse) - (define-key map [?\C-m] #'rfcview-find-location-of-rfc) - map) - "Keymap for links to RFC locations.") - -;;;###autoload -(defun rfcview-find-index () - "Find the RFC index and hyperlink it." - (interactive) - (rfcview-find-internal (if (listp rfcview-index-location) - rfcview-index-location - (list rfcview-index-location)) - "RFC index") - (view-mode) - (save-excursion - (goto-char (point-min)) - (when (= (point-max) - (next-single-char-property-change (point) 'rfcview-rfcnum-ovlcat)) - (let ((pattern (if (listp rfcview-rfc-location-pattern) - rfcview-rfc-location-pattern - (list rfcview-rfc-location-pattern)))) - (while (re-search-forward "^\\([0-9]\\{4\\}\\) " nil t) - (let ((start (match-beginning 1))) - (let ((overlay (make-overlay start (line-end-position)))) - (overlay-put overlay 'category 'rfcview-rfcurl-ovlcat) - (overlay-put overlay 'location - (mapcar (lambda (x) - (format x (match-string 1))) - pattern))) - (rfcview-add-overlay start (match-end 1) - 'rfcview-rfcnum-ovlcat))))))) - -;; Major mode - -;;;###autoload -(defun rfcview-mode () - "Major mode for viewing Internet RFCs. - -http://www.loveshack.ukfsn.org/emacs/rfcview.el -http://www.neilvandyke.org/rfcview/ - -Key bindings: -\\{rfcview-mode-map}" - (interactive) - (kill-all-local-variables) - (setq major-mode 'rfcview-mode) - (setq mode-name "RFCview") - (use-local-map rfcview-mode-map) - (make-local-variable 'font-lock-defaults) - (make-local-variable 'rfcview-local-heading-alist) - (setq font-lock-defaults nil) - ;; Arrange to lose the C-m binding from View mode: - (push (cons 'view-mode rfcview-overriding-map) - minor-mode-overriding-map-alist) - (set (make-local-variable 'imenu-create-index-function) - 'rfcview-imenu-index-function) - (set (make-local-variable 'imenu-sort-function) nil) - (make-local-variable 'rfcview-ref-alist) - (when rfcview-use-view-mode-p - (view-mode-enter nil #'rfcview-quit)) - (rfcview-grok-buffer) - ;; This is easier and probably better than inserting contents in the - ;; mode menu. - (imenu-add-to-menubar "Contents") - (run-hooks 'rfcview-mode-hook)) - -(defun rfcview-put-alist (symbol alist) - (mapcar (function (lambda (cell) - (put symbol (nth 0 cell) (cdr cell)))) - alist)) - -(defun rfcview-quit (&optional buffer) - "Kill the RFCview buffer. -Arg BUFFER is ignored." - (interactive) - (kill-buffer (current-buffer))) - -(defun rfcview-remove-all-overlays () - (mapcar (function (lambda (lst) - (while lst - (delete-overlay (car lst)) - (setq lst (cdr lst))))) - (let ((lists (overlay-lists))) - (list (car lists) (cdr lists))))) - -(defun rfcview-textmode () - "Remove overlays from the buffer and put it into Text mode." - (interactive) - (rfcview-remove-all-overlays) - (text-mode)) - -(defun rfcview-next-button () - "Move point to the next \"button\" (active link)." - (interactive) - (if (get-char-property (point) 'keymap) ; move off it - (goto-char (next-single-char-property-change (point) 'keymap))) - (goto-char (next-single-char-property-change (point) 'keymap))) - -;; Overlay Categories: - -(rfcview-put-alist 'rfcview-hide-ovlcat - (if rfcview-debug-show-hidden-p - '((face . region) - (intangible . nil) - (invisible . nil)) - '((face . default) - (intangible . t) - (invisible . t)))) - -(rfcview-put-alist 'rfcview-headname-ovlcat '((face . rfcview-headname-face))) -(rfcview-put-alist 'rfcview-headnum-ovlcat '((face . rfcview-headnum-face))) -(rfcview-put-alist 'rfcview-rfcnum-ovlcat '((face . rfcview-rfcnum-face))) -(rfcview-put-alist 'rfcview-stdnum-ovlcat '((face . rfcview-stdnum-face))) -(rfcview-put-alist 'rfcview-title-ovlcat '((face . rfcview-title-face))) - -(rfcview-put-alist 'rfcview-headlink-ovlcat - `((face . rfcview-headlink-face) - (mouse-face . rfcview-mouseover-face) - (keymap . ,rfcview-link-map) - (help-echo . "mouse-2, C-m: go to section"))) -(rfcview-put-alist 'rfcview-reflink-ovlcat - `((face . rfcview-headlink-face) - (mouse-face . rfcview-mouseover-face) - (keymap . ,rfcview-link-map) - (help-echo . "mouse-2, C-m: follow reference"))) - -(rfcview-put-alist 'rfcview-rfcurl-ovlcat - `((face . ,goto-address-url-face) - (mouse-face . ,goto-address-url-mouse-face) - (help-echo . "mouse-2, C-m: browse RFC's location") - (keymap . ,rfcview-rfc-keymap))) - -;; This persuades speedbar to use Imenu with RRCs. -(eval-after-load "speedbar" - '(speedbar-add-supported-extension '("rfc[0-9]+\.txt\.gz" "rfc[0-9]+\.txt"))) - -;; End: - -(provide 'rfcview) - -;;; rfcview.el ends here diff --git a/elisp/emacs-goodies-el/services.el b/elisp/emacs-goodies-el/services.el deleted file mode 100755 index 029b505..0000000 --- a/elisp/emacs-goodies-el/services.el +++ /dev/null @@ -1,184 +0,0 @@ -;;; services.el --- Services database access functions. -;; Copyright 2000-2008 by Dave Pearson <davep@davep.org> -;; $Revision: 1.4 $ - -;; services.el is free software distributed under the terms of the GNU -;; General Public Licence, version 2 or (at your option) any later version. -;; For details see the file COPYING. - -;;; Commentary: -;; -;; services.el provides a set of functions for accessing the services -;; details list. -;; -;; The latest services.el is always available from: -;; -;; <URL:http://www.davep.org/emacs/#services.el> - -;;; BUGS: -;; -;; o Large parts of this code look like large parts of the code you'll find -;; in protocols.el, this is unfortunate and makes me cringe. However, I -;; also wanted them to be totally independant of each other. Suggestions -;; of how to sweetly remedy this situation are welcome. - -;;; INSTALLATION: -;; -;; o Drop services.el somwehere into your `load-path'. Try your site-lisp -;; directory for example (you might also want to byte-compile the file). -;; -;; o Add the following autoload statement to your ~/.emacs file: -;; -;; (autoload 'services-lookup "services" "Perform a service lookup" t) -;; (autoload 'services-clear-cache "services" "Clear the service cache" t) - -;;; Code: - -;; Things we need: - -(eval-when-compile - (require 'cl)) - -;; Customisable variables. - -(defvar services-file "/etc/services" - "*Name of the services file.") - -;; Non-customize variables. - -(defvar services-cache nil - "\"Cache\" of services.") - -(defvar services-name-cache nil - "\"Cache\" of service names.") - -;; Main code: - -(defsubst service-name (service) - "Get the name of service SERVICE." - (car service)) - -(defsubst service-port (service) - "Get the port of service SERVICE." - (cadr service)) - -(defsubst service-protocols (service) - "Get the protocols of service SERVICE." - (car (cddr service))) - -(defsubst service-aliases (service) - "Get the aliases for service SERVICE." - (cadr (cddr service))) - -(defun services-line-to-list (line) - "Convert LINE from a string into a structured service list." - (let* ((words (split-string line)) - (port (split-string (cadr words) "/"))) - (list - (car words) - (string-to-int (car port)) - (list (cadr port)) - (loop for s in (cddr words) - while (not (= (aref s 0) ?#)) - collect s)))) - -(defun* services-read (&optional (file services-file)) - "Read the services list from FILE. - -If FILE isn't supplied the value of `services-file' is used." - (or services-cache - (setq services-cache - (when (file-readable-p file) - (with-temp-buffer - (insert-file-contents file) - (setf (point) (point-min)) - (let ((services (list))) - (loop for service in - (loop until (eobp) - do (setf (point) (line-beginning-position)) - unless (or (looking-at "^[ \t]*#") (looking-at "^[ \t]*$")) - collect (services-line-to-list (buffer-substring (line-beginning-position) (line-end-position))) - do (forward-line)) - do (let ((hit (assoc (service-name service) services))) - (if (and hit (= (service-port hit) (service-port service))) - (setf (cdr hit) (list - (service-port hit) - (append (service-protocols hit) (service-protocols service)) - (service-aliases hit))) - (push service services))) - finally return (reverse services)))))))) - -(defun* services-find-by-name (name &optional (protocol "tcp") (services (services-read))) - "Find the service whose name is NAME." - (loop for service in services - when (and (string= (service-name service) name) - (member protocol (service-protocols service))) - return service)) - -(defun* services-find-by-port (port &optional (protocol "tcp") (services (services-read))) - "Find the service whose port is PORT." - (loop for service in services - when (and (= (service-port service) port) - (member protocol (service-protocols service))) - return service)) - -(defun* services-find-by-alias (alias &optional (protocol "tcp") (services (services-read))) - "Find a the service whose with an alias of ALIAS." - (loop for service in services - when (and (member alias (service-aliases service)) - (member protocol (service-protocols service))) - return service)) - -;;;###autoload -(defun services-lookup (search protocol) - "Find a service and display its details." - (interactive (list - (completing-read "Service Search: " - (or services-name-cache - (setq services-name-cache - (loop for service in (services-read) - collect (list (service-name service)) - append (loop for alias in (service-aliases service) - collect (list alias))))) - nil nil "" nil) - (completing-read "Protocol: " '(("tcp") ("udp")) nil nil "tcp" nil))) - (let* ((services (services-read)) - (service (or (when (string-match "^[0-9]+$" search) - (services-find-by-port (string-to-int search) protocol services)) - (services-find-by-name search protocol services) - (services-find-by-name (downcase search) protocol services) - (services-find-by-name (upcase search) protocol services) - (services-find-by-alias search protocol services) - (services-find-by-alias (downcase search) protocol services) - (services-find-by-alias (upcase search) protocol services)))) - (if service - (let ((aliases (service-aliases service)) - (protocols (service-protocols service))) - (message "Service: %s Port: %d %s%s" - (service-name service) - (service-port service) - (if aliases - (format "Aliases: %s" - (with-output-to-string - (loop for alias in (service-aliases service) - do (princ alias) (princ " ")))) - "") - (if protocols - (format "%sProtocols: %s" - (if aliases " " "") - (with-output-to-string - (loop for protocol in protocols - do (princ protocol) (princ " ")))) - ""))) - (error "No service matching \"%s\" using protocol %s" search protocol)))) - -;;;###autoload -(defun services-clear-cache () - "Clear the services \"cache\"." - (interactive) - (setq services-cache nil - services-name-cache nil)) - -(provide 'services) - -;;; services.el ends here. diff --git a/elisp/emacs-goodies-el/session.el b/elisp/emacs-goodies-el/session.el deleted file mode 100755 index 0fce7bb..0000000 --- a/elisp/emacs-goodies-el/session.el +++ /dev/null @@ -1,1726 +0,0 @@ -;;; session.el --- use variables, registers and buffer places across sessions - -;; Copyright 1996, 1997, 1998, 1999, 2001, 2002, 2003, 2010 -;; Free Software Foundation, Inc. -;; -;; Author: Christoph Wedler <wedler@users.sourceforge.net> -;; Version: 2.3 (see also `session-version' below) -;; Keywords: session, session management, desktop, data, tools -;; X-URL: http://emacs-session.sourceforge.net/ - -;; This program 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 3 of the Licence, or -;; (at your option) any later version. -;; -;; This program 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 this program. If not, see <http://gnu.org/licences/>. - -;;; Commentary: - -;; When you start Emacs, package Session restores various variables (e.g., -;; input histories) from your last session. It also provides a menu -;; containing recently changed/visited files and restores the places (e.g., -;; point) of such a file when you revisit it. - -;; For details, check <http://emacs-session.sourceforge.net/> or, if you prefer -;; the manual style, the documentation of functions \\[session-save-session] -;; and `session-store-buffer-places'. - -;; Bug fixes, bug reports, improvements, and suggestions for the newest version -;; are strongly appreciated. - -;;; To-do: - -;; One could imaging a combination of desktop.el and session.el. IMHO it is -;; easier to include the remaining features of desktop.el (load some files at -;; startup) into session.el, but desktop.el is already part of Emacs... -;; Anyway, here are some ideas for the combined desktop/session: -;; -;; * Using contexts for buffer positions (idea from bookmark and vc). -;; * Define common code with bookmark to restore buffers from a -;; file-representation (for files, dired, info buffers). -;; * Saving window-configurations? - -;;; Installation, private: - -;; 1. Make sure to use Emacs-20.2, XEmacs-20.2 or higher. -;; 2. Put this file into your load-path, i.e. any directory mentioned in the -;; value of `load-path'. -;; 3. Byte-compile this file. -;; 4. Load this package by M-x load-library RET session RET -;; 5. Start customization with M-x customize-group RET session RET' or the -;; menu [Options][Customize...]...[Data][Session]. -;; 6. Toggle the [Session Use Package] option to "in use". -;; 7. Save your customization via [Save for future sessions]. -;; 8. If you use both this package and desktop.el, customize the variable -;; `desktop-globals-to-save' to include only the symbol -;; `desktop-missing-file-warning'. - -;; Remark: adding some code to your ~/.emacs like in previous versions of -;; session.el still works. - -;;; Installation, system- or distribution-wide: - -;; The idea here should be to offer new defaults to your users (like using this -;; package), while allowing them to choose otherwise. This is probably best -;; done by defining a custom theme (you probably add other customizations to -;; the custom theme file as well, custom themes might only work with newer -;; Emacsen): - -;; 1. Like 1-3 in the private installation instruction. -;; 2. Create the autoloads and custom-loads for session.el and make sure that -;; they are loaded at Emacs startup. You can do it manually by adding the -;; code below to your site.start.el. -;; 3. Define a custom theme like `our-custom' by adding a file called -;; "our-custom-theme.el" with the code below to a directory in the -;; load-path. -;; 4. Enable your custom theme by adding the code below to your default.el. -;; 5. Tell your users that they can disable this package by customizing the -;; user option according to 5-7 in the private installation instruction or -;; by setting `inhibit-default-init' to t. - -;; ;; site-start.el, Emacs: -;; (autoload 'session-jump-to-last-change "session" nil t) -;; (autoload 'session-initialize "session" nil t) -;; (eval-after-load "cus-load" -;; '(progn (custom-add-load 'data 'session) -;; (custom-add-load 'session 'session))) - -;; ;; site-start.el, XEmacs: -;; (autoload 'session-jump-to-last-change "session" nil t) -;; (autoload 'session-initialize "session" nil t) -;; (custom-add-load 'data 'session) -;; (custom-add-load 'session 'session) - -;; ;; our-custom-theme.el, Emacs and XEmacs: -;; (deftheme our-custom "Created 2011-01-15.") -;; (custom-theme-set-variables -;; 'our-custom -;; '(session-use-package t nil (session))) -;; (provide-theme 'our-custom) - -;; ;; default.el, Emacs: -;; (enable-theme 'our-custom) - -;; ;; default.el, XEmacs: -;; (require-theme 'our-custom) - -;;; Code: - -(provide 'session) -(require 'custom) - -;; General Emacs/XEmacs-compatibility compile-time macros -(eval-when-compile - (require 'cl) - (defmacro cond-emacs-xemacs (&rest args) - (cond-emacs-xemacs-macfn - args "`cond-emacs-xemacs' must return exactly one element")) - (defun cond-emacs-xemacs-macfn (args &optional msg) - (if (atom args) args - (and (eq (car args) :@) (null msg) ; (:@ ...spliced...) - (setq args (cdr args) - msg "(:@ ....) must return exactly one element")) - (let ((ignore (if (string-match "XEmacs" emacs-version) :EMACS :XEMACS)) - (mode :BOTH) code) - (while (consp args) - (if (memq (car args) '(:EMACS :XEMACS :BOTH)) (setq mode (pop args))) - (if (atom args) - (or args (error "Used selector %s without elements" mode)) - (or (eq ignore mode) - (push (cond-emacs-xemacs-macfn (car args)) code)) - (pop args))) - (cond (msg (if (or args (cdr code)) (error msg) (car code))) - ((or (null args) (eq ignore mode)) (nreverse code)) - (t (nconc (nreverse code) args)))))) - ;; Emacs/XEmacs-compatibility `defun': remove interactive "_" for Emacs, use - ;; existing functions when they are `fboundp', provide shortcuts if they are - ;; known to be defined in a specific Emacs branch (for short .elc) - (defmacro defunx (name arglist &rest definition) - (let ((xemacsp (string-match "XEmacs" emacs-version)) reuses first) - (while (memq (setq first (car definition)) - '(:try :emacs-and-try :xemacs-and-try - :emacs-only :xemacs-only)) - (if (memq first (if xemacsp - '(:xemacs-and-try :xemacs-only) - '(:emacs-and-try :emacs-only))) - (setq reuses (cadr definition) - definition nil) - (unless (memq first '(:emacs-only :xemacs-only)) - (push (cadr definition) reuses))) - (setq definition (cddr definition))) - (if (and reuses (symbolp reuses)) - `(defalias ',name ',reuses) - (let* ((docstring (if (stringp (car definition)) (pop definition))) - (spec (and (not xemacsp) - (eq (car-safe (car definition)) 'interactive) - (null (cddar definition)) - (cadar definition)))) - (if (and (stringp spec) - (not (string-equal spec "")) - (eq (aref spec 0) ?_)) - (setq definition - (cons (if (string-equal spec "_") - '(interactive) - `(interactive ,(substring spec 1))) - (cdr definition)))) - (if (null reuses) - `(defun ,name ,arglist ,docstring - ,@(cond-emacs-xemacs-macfn definition)) - ;; no dynamic docstring in this case - `(eval-and-compile ; no warnings in Emacs - (defalias ',name - (cond ,@(mapcar (lambda (func) `((fboundp ',func) ',func)) - (nreverse reuses)) - (t ,(if definition - `(lambda ,arglist ,docstring - ,@(cond-emacs-xemacs-macfn definition)) - 'ignore))))))))))) - -(eval-when-compile - (defvar put-buffer-names-in-file-menu) - (defvar menu-bar-files-menu) - (defvar yank-menu) - (defvar minibuffer-local-ns-map)) - - - -;;;;########################################################################## -;;;; User options, configuration variables -;;;;########################################################################## - - -(defconst session-version "2.3" - "Current version of package session. -Check <http://emacs-session.sourceforge.net/> for the newest.") - - -;;;=========================================================================== -;;; Customization and initialization -;;;=========================================================================== - -(defgroup session nil - "Use variables, registers and buffer places across sessions." - :group 'data - :link '(emacs-commentary-link "session.el") - :link '(url-link "http://emacs-session.sourceforge.net/") - :prefix "session-") - -(defgroup session-globals nil - "Which variables and registers to save across sessions." - :group 'session - :prefix "session-") - -(defgroup session-places nil - "Which places are stored for which buffers." - :group 'session - :prefix "session-") - -(defgroup session-miscellaneous nil - "Miscellaneous configurations of package session." - :group 'session - :prefix "session-") - -(defcustom session-initialize t - "Whether/what to initialize with function `session-initialize'. -If t, do full initialization. Otherwise, the value should be a list -with element. To enable, include - - * `de-saveplace' to de-install package saveplace (is redundant), - * `session' to load and save the session file, - * `places' to store and use places for files/buffers, - * `keys' to setup the default key and mouse bindings, - * `menus' to setup the menus." - :group 'session-miscellaneous - :type '(choice (const :tag "All" t) - (set :value (de-saveplace session places keys menus) - (const :tag "De-install saveplace" de-saveplace) - (const :tag "Load/Save Session" session) - (const :tag "Store/Use Places" places) - (const :tag "Setup Key/Mouse Bindings" keys) - (const :tag "Setup Menus" menus)))) - - -;;;=========================================================================== -;;; User Options and Configuration: Menu -;;;=========================================================================== - -(defcustom session-menu-max-size 36 - "*Max number of entries which may appear in the session menus." - :group 'session-miscellaneous - :type 'integer) - -(defcustom session-file-menu-max-string - (if (if (boundp 'put-buffer-names-in-file-menu) - put-buffer-names-in-file-menu ; XEmacs - nil) ; Emacs: no buffer names in file menu - (cons 50 20) - 50) - "*Max length of strings in submenus of the File menu. -Value has the form MAX or (MAX . NAME-THRESHOLD). If the second form is -used and the length returned by `buffer-name' is longer than -NAME-THRESHOLD, the maximum length will be shortened accordingly. - -Deprecated: a negative number -MAX stands for (MAX . 0)." - :group 'session-miscellaneous - :type '(choice (cons (integer :tag "Max. length" 50) - (integer :tag "Name threshold" 20)) - (integer 50))) - -(defcustom session-edit-menu-max-string 50 - "*Max length of strings in submenus of the Edit menu. -See also `session-compact-yank-gap-regexp'. - -When running under Emacs, customize `yank-menu-length' instead." - :group 'session-miscellaneous - :type 'integer) - -(defcustom session-compact-yank-gap-regexp "\\(\n\\|[ \t][ \t][ \t]\\)[ \t\n]*" - "*Regexp used when trying to find a gap in a long compact string. -If non-nil, leading and trailing whitespaces are not shown, and we try -to find a gap consisting matched by this regexp if we have to split the -string according to `session-edit-menu-max-string'. - -This variable has no effect when running under Emacs." - :group 'session-miscellaneous - :type 'string) - -(defcustom session-menu-permanent-string " *" - "*Marker for permanent files in menu \"File >> Open...recently changed\". -A file can set as permanent with prefix argument 3 for a command in -`session-kill-buffer-commands'. It can be set as non-permanent with -prefix argument -1." - :group 'session-miscellaneous - :type 'string) - -;; TODO: not quite sure whehter this is needed anymore - and if whether -;; it is the best way to exclude certain files. Other options are: -;; based on directory, file name, mode, calling command -(defcustom session-set-file-name-exclude-regexp - "[/\\]\\.overview\\|[/\\]\\.session\\|News[/\\]" - "*Regexp matching file names not to be stored in `file-name-history'. -This is used by `session-set-file-name-history'. Value nil means, do -not exclude any file." - :group 'session-miscellaneous - :type '(choice (const nil) regexp)) - -(defvar session-menu-accelerator-support - (and (featurep 'menu-accelerator-support) - (fboundp 'submenu-generate-accelerator-spec) - 'submenu-generate-accelerator-spec) - "Function to generate menu accelerators, or nil if not supported.") - -;; calling `abbrev-file-name' on remote files opens the connection! -(defvar session-abbrev-inhibit-function -;; this will be renamed with the next release (when minimum is -;; Emacs-22.1, jun 2007 and XEmacs 21.4.12, jan 2003) -> only there we have -;; `define-obsolete-variable-alias' - (cond ((fboundp 'file-remote-p) 'file-remote-p) - ;; `file-remote-p' doesn't exist in Emacs < 22.1 - ((fboundp 'efs-ftp-path) 'efs-ftp-path) - ((fboundp 'ange-ftp-ftp-name) 'ange-ftp-ftp-name) - ((fboundp 'ange-ftp-ftp-path) 'ange-ftp-ftp-path)) - "Function used to determine whether to abbreviate file name. -A file name is not abbreviated if this function returns non-nil when -called with the file name.") - -(defvar session-directory-sep-char ; directory-sep-char is not set - (if (memq system-type '(ms-dos windows-nt)) ?\\ ?\/) - "Directory separator character for session menus.") - -(defvar session-save-file-coding-system - (cond-emacs-xemacs - :EMACS 'iso-latin-1-with-esc - ;; used `emacs-mule' but this fails with X-Symbol characters... - :XEMACS (and (featurep 'mule) 'escape-quoted)) - "Coding system to use when writing `session-save-file' if non-nil.") - - -;;;=========================================================================== -;;; User Options and Configuration: save global variables between sessions -;;;=========================================================================== - -(defcustom session-globals-max-size 50 - "*Maximal number of elements in the global variables. -Global variables are only saved if they are non-empty lists. This value -can be shadowed by some element in `session-globals-include'. If an -element appears more than once in the list, only the first appearance -will be stored." - :group 'session-globals - :type 'integer) - -(defcustom session-globals-max-string 1024 - "*Maximal length of string elements in global variables." - :group 'session-globals - :type 'integer) - -(defcustom session-registers-max-string 1024 - "*Maximal length of string elements in registers." - :group 'session-globals - :type 'integer) - -(defcustom session-save-file - (expand-file-name ".session" - (cond ((boundp 'user-emacs-directory) user-emacs-directory) - ((boundp 'user-init-directory) user-init-directory) - (t "~"))) - "File to save global variables and registers into. -It is saved with coding system `session-save-file-coding-system' at the -end of an Emacs session and loaded at the beginning. Used for variables -which are typically changed by editing operations, e.g., history and -ring variables. See \\[session-save-session] for details." - :group 'session-globals - :type 'file) - -(defvar session-old-save-file (expand-file-name ".session" "~")) - -(defvar session-save-print-spec '(t 2 1024) - ;; only for advanced users -> no custom - "*TODO") - -(defcustom session-save-file-modes 384 - "Mode bits of session save file, as an integer, or nil. -After writing `session-save-file', set mode bits of that file to this -value if it is non-nil." - :group 'session-globals - :type '(choice (const :tag "Don't change" nil) integer)) - -(defvar session-before-save-hook nil - "Hook to be run before `session-save-file' is saved. -The functions are called after the global variables are written, -directly before the file is actually saved.") - -(defvar session-after-load-save-file-hook - (cond-emacs-xemacs - :EMACS (and (default-boundp 'yank-menu) - (fboundp 'menu-bar-update-yank-menu) - '(session-refresh-yank-menu))) - "Hook to be run after `session-save-file' has been loaded. -The functions are called when the file has been successfully loaded.") - -(defcustom session-globals-regexp "-\\(ring\\|history\\)\\'" - "Regexp matching global variables to be saved between sessions. -Variables in `session-globals-exclude' are not saved, but variables in -`session-globals-include' are always saved." - :group 'session-globals - :type 'regexp) - -(defcustom session-globals-exclude - '(load-history - register-alist vc-comment-ring flyspell-auto-correct-ring org-mark-ring - planner-browser-file-display-rule-ring) - "Global variables not to be saved between sessions. -It affects `session-globals-regexp' and `session-globals-include'." - :group 'session-globals - :type '(repeat variable)) - -(defcustom session-globals-include '((kill-ring 10) - (session-file-alist 100 t) - (file-name-history 200) - search-ring regexp-search-ring) - "Global variables to be saved between sessions. -Each element has one of the following forms: - NAME, - (NAME MAX-SIZE), or - (NAME MAX-SIZE ASSOC-P). -where NAME is the symbol name of the variable, whose value must be a -non-empty list and string elements in this list must be smaller than -`session-globals-max-string'. MAX-SIZE (default is -`session-globals-max-size') is the maximal number of elements to be -saved for this symbol where only the first of equal elements are saved, -and ASSOC-P (default is nil) non-nil means that the variable is an alist -where the equality of elements is checked on the `car'. - -If MAX-SIZE or ASSOC-P is non-nil, it can be useful to include a -variable in this list even if it matches `session-globals-regexp'. -`session-globals-exclude' has no effect on these variables. - -Do not use this variable to customize your Emacs. Package custom is the -appropriate choice for this!" - :group 'session-globals - :type '(repeat (choice (variable :tag "List var with standard max size") - (list variable - (integer :tag "Max size") - (boolean :tag "Alist"))))) - - -;;;=========================================================================== -;;; Configuration: registers and local variables -;;;=========================================================================== - -(defcustom session-registers '((?0 . ?9) ?- ?= ?\\ ?` region (?a . ?z)) - "*Registers to be saved in `session-save-file'. -Valid elements in this list are: - CHAR or (FROM . TO) or `file' or `region' or t. -CHAR is a register to save, (FROM . TO) represents a list of registers -from FROM to TO. `file' means, only save the following registers in -this list if they contain file or file-query references. `region' -means, only save registers if they contain a region which has less then -`session-registers-max-string' characters. t means, allow both content -types. Processing of this list starts with type `file'. - -Before saving the session files, markers in registers are turned into -file references, see variable `session-register-swap-out'." - :group 'session-globals - :type '(repeat (choice (const :tag "File registers:" file) - (const :tag "String registers:" region) - (const :tag "Any register type:" t) - (character :tag "Register") - (cons :tag "Registers" - (character :tag "From") - (character :tag "To"))))) - -(defcustom session-locals-include '(overwrite-mode) - "Local variables to be stored for specific buffers. -See also `session-locals-predicate'. - -Do not add variables to this list which are more appropriate for local -variables in files, i.e., variables which are related to the contents of -the file, e.g. `major-mode'!" - :group 'session-places - :type '(repeat variable)) - -(defcustom session-locals-predicate 'local-variable-p - "Function which must return non-nil for a local variable to be stored. -This function is called on all variables in `session-locals-include' -with the variable as the first and the current buffer as the second -argument. Good values are nil (do not store any variable), -`local-variable-p' for local variables, `local-variable-if-set-p' for -variables which become local when set, and t (store all variables in -`session-locals-include')." - :group 'session-places - :type '(choice (const :tag "none" nil) - (const :tag "All" t) - (function-item local-variable-p) - (function-item local-variable-if-set-p) - (function :tag "Other function"))) - -(defvar session-register-swap-out (if (fboundp 'register-swap-out) - 'register-swap-out - 'session-register-swap-out) - "Function processing markers in registers when a buffer is killed. -If non-nil, this function is added to `kill-buffer-hook'. Good values -are `register-swap-out' and the function `session-register-swap-out'.") - - -;;;=========================================================================== -;;; User Options and Configuration: buffer check--undo, mode+name -;;;=========================================================================== - -(defcustom session-jump-undo-threshold 240 - "*Number of character positions the undo position must be different. -Without prefix arg, `session-jump-to-last-change' jumps successively to -change positions which differ by at least `session-jump-undo-threshold' -characters compared to the current position and previously visited -change positions, see `session-jump-undo-remember'." - :group 'session-places - :type 'integer) - -(defcustom session-jump-undo-remember 2 - "*Number of previously visited change positions checked additionally. -See `session-jump-undo-threshold' and `session-jump-to-last-change'." - :group 'session-places - :type 'integer) - -;; Problem if homedir is a symlink (/bar/home -> /net/bar.home) & tmp-mounted -;; (file-truename "~/foo") => "/tmp_mnt/net/bar.home/foo" -;; (abbreviate-file-name "/tmp_mnt/net/bar.home/foo") => "/net/bar.home/foo" -;; I.e., there is a bug in `abbreviate-file-name' on both Emacs and XEmacs -;; (with 2nd arg t). Workaround: use the following in your ~/.emacs: - -;;(unless (string= (abbreviate-file-name (file-truename "~") t) "~") ; XEmacs -;; (setq abbreviated-home-dir -;; (let ((abbreviated-home-dir "$foo")) -;; (concat "\\`\\(?:" -;; (regexp-quote (abbreviate-file-name (expand-file-name "~"))) -;; "\\|" -;; (regexp-quote (abbreviate-file-name (file-truename "~"))) -;; "\\)\\(/\\|\\'\\)")))) - -(defconst session-use-truenames-default - (cond-emacs-xemacs - :EMACS (string= (abbreviate-file-name (file-truename "~")) "~") - :XEMACS (and (string= (abbreviate-file-name (file-truename "~") t) "~") - (if (eq system-type 'windows-nt) - 'session-xemacs-buffer-local-mswindows-file-p - t)))) - -(defcustom session-use-truenames session-use-truenames-default - "*Whether to use the canonical file names when saving/restoring places. -If a function, it is called with no argument and returns whether to use -the canonical names of files. If non-nil, store and check file names -returned by `file-truename'." - :group 'session-places - :type '(choice (const :tag "No" nil) - (const :tag "Yes" t) - (function-item :tag "If not starting with \\\\" - session-xemacs-buffer-local-mswindows-file-p) - (function :tag "Other function"))) - -(defcustom session-auto-store t - "*Determines whether a buffer to be killed passes the mode/name check. -This boolean is used by `session-default-buffer-check-p', see -`session-buffer-check-function'. - -A buffer passes the mode/name check, if it passes the mode check, see -below, and its file name is not matched by -`session-name-disable-regexp', or if fails the mode check and its file -name is matched by `session-name-enable-regexp'. - -A buffer passes the mode check, if this variable is non-nil and its -major mode is not a member of `session-mode-disable-list', or if this -variable is nil and its major mode is a member of -`session-mode-enable-list'." - :group 'session-places - :type 'boolean) - -(defcustom session-undo-check 1 - "*Determines how a buffer to be killed passes the undo check. -Its value is MIN or (MIN . LAST) where MIN is a number. Used by -`session-default-buffer-check-p', see `session-buffer-check-function'. - -To pass the undo check - * the length of `buffer-undo-list', assumed to be -1 if no undo - information is recorded, must be higher or equal to MIN, - * the first form is used or LAST is nil: no further requirement - * LAST is `and': additionally, `session-last-change' must be non-nil, - i.e., the buffer has been changed previously, - * LAST is `or': alternatively, `session-last-change' is non-nil." - :group 'session-places - :type '(choice (integer :tag "Min no of Changes") - (cons (integer :tag "Min no of Changes") - (choice :tag "Previous and New Changes" - (const :tag "Only consider New Changes" nil) - (const :tag "AND previously changed" and) - (const :tag "OR previously changed" or))))) - -(defcustom session-kill-buffer-commands '(kill-this-buffer) - "*Commands which kill a buffer. -If a prefix argument was provided to any of these commands, it will -influence the decision whether to store places for the buffer, see -`session-store-buffer-places'. Using commands which use the minibuffer -for input, is useless." - :group 'session-places - :type '(repeat (function :tag "Command"))) - -(defcustom session-buffer-check-function 'session-default-buffer-check-p - "Function which return non-nil if buffer places should be stored. -Used by `session-store-buffer-places'. This function is called with the -buffer to check as argument. You can also assume that the current -buffer is the buffer to check. - -The default value `session-default-buffer-check-p' returns non-nil, if -the buffer - * visits an existing readable file, - * passes the mode/name check, see `session-auto-store', and - * passes the undo check, see `session-undo-check', its default value 1 - means: the buffer must have been changed during the session." - :group 'session-globals - :type '(choice (function-item :tag "Default check" - session-default-buffer-check-p) - (function :tag "Other function"))) - -(defcustom session-mode-disable-list - '(vm-mode gnus-score-mode message-mode tar-mode) - "*Major modes of buffers for which no places are stored. -See `session-buffer-check-function'." - :group 'session-globals - :type '(repeat (function :tag "Major mode"))) - -(defcustom session-mode-enable-list nil - "*Major modes of buffers for which places are stored. -See `session-buffer-check-function'." - :group 'session-globals - :type '(repeat (function :tag "Major mode"))) - -(defcustom session-name-disable-regexp - (concat "\\`" (regexp-quote - (if (fboundp 'temp-directory) (temp-directory) "/tmp"))) - "*File names of buffers for which no places are stored. -See `session-buffer-check-function'." - :group 'session-places - :type '(choice (const nil) regexp)) - -(defcustom session-name-enable-regexp nil - "*File names of buffers for which places are stored. -See `session-buffer-check-function'." - :group 'session-places - :type '(choice (const nil) regexp)) - - - - -;;;;########################################################################## -;;;; Store buffer places and local variables, change register contents -;;;;########################################################################## - - -(defvar session-last-change nil - "Position of last change in current buffer. -This variable is set by `session-find-file-hook' if the buffer was -changed in a previous session. It can also be set by providing an -prefix argument to `session-jump-to-last-change'.") -(make-variable-buffer-local 'session-last-change) - -(defvar session-file-alist nil - "Alist for places and local variables for some files. -It has the form - (NAME POINT MARK POINT-MIN POINT-MAX PERMANENT LAST-CHANGE - (SYMBOL . VAR) ...) - -NAME is the file name, POINT is the point position, MARK is the mark -position, POINT-MIN and POINT-MAX determine the narrow part if non-nil, -PERMANENT is the permanent marker (see `session-buffer-check-function'), -LAST-CHANGE is the position of the last change in the previous session -or was explicitly set with prefix argument 0 for command -\\[session-jump-to-last-change]. Optional pairs (SYMBOL . VAR) are -local variables with their values.") - -(defvar session-jump-to-last-change-counter 0 - "Number of repeated invocations of `session-jump-to-last-change'.") - -(defvar session-jump-to-last-change-recent nil - "Current position and previously visited change positions.") - - -;;;=========================================================================== -;;; Position of last change -;;;=========================================================================== - -(defun session-undo-position (num pos1 pos2) - "Return a previous undo-position or set it. -If argument NUM is nil, set `session-last-change' to the recomputed -position given by argument POS1 and return POS1 normalized. - -Otherwise, return a previous undo-position or nil, if no such position -can be found. If `session-jump-to-last-change-counter' is nil, the -position found is the stored last-change position. - -If POS1 and POS2 are nil, NUM is the number of undo-boundaries to skip. -The position returned is the last change inside the corresponding undo -step. - -Otherwise, NUM is the number of undo entries to skip. The position -returned is the last change after these entries outside the range from -POS1 to POS2. Increment `session-jump-to-last-change-counter' by the -number of entries skipped additionally." - (let ((undo-list (and (consp buffer-undo-list) buffer-undo-list)) - elem ; element in undo-list, t = not of interest - back-list ; used position must be recomputed due to processed elems - len ; length of deletion/insertion - pos) ; interesting position in undo-list - (while (and undo-list (null (car undo-list))) - (pop undo-list)) ; ignore undo-boundaries at beg - (while undo-list - ;; inspect element in undo-list ---------------------------------------- - (setq elem (pop undo-list)) - (cond ((atom elem) ; marker position - (when (or elem pos1) ; undo-boundary is of interest if POS1=nil - (if (integerp elem) - (setq pos elem ; use point position in undo-list - back-list (cons nil back-list)) - (setq elem t)))) ; ignore uninteresting elem - ((stringp (car elem)) ; deletion: (TEXT . POSITION) - (setq pos (abs (cdr elem)) - len (length (car elem))) - (push (list* pos (+ pos len) (- len)) back-list) - (when pos1 ; adopt POS{1,2} if after deletion - (if (> pos1 pos) (incf pos1 len)) - (if (>= pos2 pos) (incf pos2 len)))) - ((integerp (car elem)) ; insertion: (START . END) - (setq pos (car elem) - len (- (cdr elem) pos)) - (push (list* pos pos len) back-list) - (when pos1 ; adopt POS{1,2} if after/in insertion - (if (> pos1 pos) - (setq pos1 (if (> pos1 (cdr elem)) (- pos1 len) pos))) - (if (> pos2 pos) - (setq pos2 (if (> pos2 (cdr elem)) (- pos2 len) pos)))) - (setq pos (cdr elem))) ; point more likely at end of insertion - (t - (setq elem t))) - ;; evaluation element inspection --------------------------------------- - (cond ((null num)) ; set POS1 as `session-last-change' - ((null pos1) ; looking for undo-boundaries - (when (if elem - (and (zerop num) pos) - (<= (decf num) 0)) - (setq undo-list nil))) - ((eq elem t) ; uninteresting element - (setq pos nil)) - ((> num 0) ; interesting, but not the NUM's one - (decf num) - (setq pos nil)) - ((and (<= pos1 pos) (<= pos pos2)) ; inside start region - (incf session-jump-to-last-change-counter) - (setq pos nil)) - (t - (setq undo-list nil)))) - ;; finalize: evaluate result and process back-list ----------------------- - (cond ((null num) ; set POS1 as `session-last-change' - (setq session-last-change pos1 - pos session-last-change)) - ((or (null pos) (> num 0)) ; no position found in undo-list - (setq session-jump-to-last-change-counter nil) - (setq pos session-last-change)) - (t ; pos in undo-list - (if session-jump-to-last-change-counter - (incf session-jump-to-last-change-counter)) - (setq back-list (cdr back-list)))) - (when pos - (while back-list - (setq elem (pop back-list)) - (cond ((null elem)) ; integer position in undo-list - ((> pos (cadr elem)) ; position after affected region - (incf pos (cddr elem))) ; increment/decrement position - ((> pos (car elem)) ; position in affected region - (setq pos (car elem))))) ; set position to region begin - pos))) - -;;;###autoload -(defun session-jump-to-last-change (&optional arg) - "Jump to the position of the last change. -Without prefix arg, jump successively to previous change positions which -differ by at least `session-jump-undo-threshold' characters by repeated -invocation of this command. With prefix argument 0, jump to end of last -change. With numeric prefix argument, jump to start of first change in -the ARG's undo block in the `buffer-undo-list'. - -With non-numeric prefix argument (\\[universal-argument] only), set -point as oldest change position. It might change slightly if you jump -to it due to intermediate insert/delete elements in the -`buffer-undo-list'." - ;; note: for compatibility reasons (pre v2.2), we use abs(ARG) - (interactive "P") - (if (consp arg) - (let ((pos (session-undo-position nil (point) (point))) - (undo-list (and (consp buffer-undo-list) buffer-undo-list))) - (setq arg 1) - (while (and undo-list (null (car undo-list))) (pop undo-list)) - (while undo-list (or (pop undo-list) (incf arg))) - (message "Store %d as special last-change position (%s %d %s)" - pos - (substitute-command-keys "\\[universal-argument]") - arg - (substitute-command-keys "\\[session-jump-to-last-change]"))) - ;; set and restrict previously visited undo positions -------------------- - (push (point) session-jump-to-last-change-recent) - (if (and (null arg) (eq last-command 'session-jump-to-last-change-seq)) - (let ((recent (nthcdr session-jump-undo-remember - session-jump-to-last-change-recent))) - (if recent (setcdr recent nil))) - (setcdr session-jump-to-last-change-recent nil) ; only point - (setq session-jump-to-last-change-counter 0)) - (let (pos) - (if arg - (setq pos (session-undo-position (abs (prefix-numeric-value arg)) - nil nil)) - ;; compute position, compare it with positions in - ;; `session-jump-to-last-change-recent' - (let ((recent session-jump-to-last-change-recent) old pos1 pos2) - (setq pos (point)) - (while recent ; at least point is there - (setq old (pop recent)) - (setq pos1 (- pos session-jump-undo-threshold) - pos2 (+ pos session-jump-undo-threshold)) - (when (and (<= pos1 old) (<= old pos2)) - (setq pos (session-undo-position - session-jump-to-last-change-counter pos1 pos2)) - (setq recent (and pos - session-jump-to-last-change-counter - session-jump-to-last-change-recent)))))) - (cond ((null pos) - (message (if (or arg (atom buffer-undo-list)) - "Do not know position of last change" - "Do not know position of last distant change"))) - ((< pos (point-min)) - (goto-char (point-min)) - (message "Change position outside visible region")) - ((> pos (point-max)) - (goto-char (point-max)) - (message "Change position outside visible region")) - (t - (goto-char pos) - (cond ((null session-jump-to-last-change-counter) - (message "Jumped to stored last-change position")) - ((null arg) - (setq this-command 'session-jump-to-last-change-seq)))))))) - - -;;;=========================================================================== -;;; Yank menu (Emacs: refresh existing menu, XEmacs: do our own) -;;;=========================================================================== - -;; this function should be defined in menu-bar.el... -(defunx session-refresh-yank-menu () - :xemacs-only ignore - "Refresh `yank-menu' according to `kill-ring'." - (when (and (default-boundp 'yank-menu) - (fboundp 'menu-bar-update-yank-menu)) - (let ((killed (reverse (default-value 'kill-ring)))) - (while killed - (menu-bar-update-yank-menu (pop killed) nil))))) - -(defun session-yank (arg) - "Reinsert the last stretch of killed text, like \\[yank]. -Calls `yank' with argument ARG and with `interprogram-paste-function' -bound to nil." - (interactive "*p") - (let ((interprogram-paste-function nil)) ;#dynamic - (yank arg))) - -(defun session-popup-yank-menu (event) - ;; checkdoc-params: (event) - "Pop up a menu for inserting items in `kill-ring'." - (interactive "e") - (when kill-ring - (setq this-command last-command) - (popup-menu '("Select and Paste" - :filter session-yank-menu-filter)))) - -(defun session-yank-menu-filter (menu-items) - ;; checkdoc-params: (menu-items) - "Return a menu for inserting items in `kill-ring'." - (let ((menu nil) - (ring nil) - (max session-menu-max-size) - (len (length kill-ring)) - (half-str-len (/ (- session-edit-menu-max-string 4) 2)) - (i 0) - (active (not buffer-read-only)) - elem - (interprogram-paste-function nil)) ;#dynamic - ;; Traversing (append kill-ring-yank-pointer kill-ring) instead indexing - ;; (current-kill INDEX) would be probably more efficient, but would be a - ;; very low-level hack - (while (and (< i len) (> max 0)) - (setq elem (current-kill i t) - i (1+ i)) - (unless (or (assoc elem ring) (string-match "\\`[ \t\n]*\\'" elem)) - (push (cons elem i) ring) - (setq max (1- max)))) - (while ring - (setq elem (car ring) - ring (cdr ring)) - (push (session-yank-string (car elem) half-str-len - (list 'session-yank (cdr elem)) - active) - menu)) - (session-menu-maybe-accelerator menu-items menu))) - -(defun session-yank-string (string half-len-str callback active) - ;; checkdoc-order: nil - "Return menu item STRING with callback CALLBACK. -If ACTIVE is non-nil, the item is active. HALF-LEN-STR is the length of -the two parts of a abbreviated menu item name." - (let ((beg (or (and session-compact-yank-gap-regexp - (string-match "\\`[ \t\n]+" string) - (match-end 0)) - 0)) - (end (or (and session-compact-yank-gap-regexp - (string-match "[ \t\n]+\\'" string)) - (length string)))) - (vector (if (> (- end beg) session-edit-menu-max-string) - (let ((gap (and session-compact-yank-gap-regexp - (string-match session-compact-yank-gap-regexp - string (- end half-len-str)) - (match-end 0)))) - (if (and gap (< gap (- end 3))) - (setq half-len-str (- (+ half-len-str half-len-str gap) - end)) - (setq gap (- end half-len-str))) - (concat (session-subst-char-in-string - ?\t ?\ (substring string beg (+ beg half-len-str)) t) - " ... " - (session-subst-char-in-string - ?\t ?\ (substring string gap end) t))) - (session-subst-char-in-string - ?\t ?\ (substring string beg end) t)) - callback - active))) - -;; from EMACS-20.4/lisp/subr.el: -(defunx session-subst-char-in-string (fromchar tochar string &optional inplace) - :try subst-char-in-string - "Replace FROMCHAR with TOCHAR in STRING each time it occurs. -Unless optional argument INPLACE is non-nil, return a new string." - (let ((i (length string)) - (newstr (if inplace string (copy-sequence string)))) - (while (> i 0) - (setq i (1- i)) - (if (eq (aref newstr i) fromchar) - (aset newstr i tochar))) - newstr)) - - -;;;=========================================================================== -;;; Menu filters (XEmacs only) -;;;=========================================================================== - -(defun session-file-opened-recompute () - (interactive) - (session-file-changed-recompute t)) - -(defun session-file-changed-recompute (&optional for-opened) - (interactive) - (let ((session-use-package t)) ;#dynamic - (save-excursion - (dolist (buffer (nreverse (buffer-list))) - (set-buffer buffer) - (when buffer-file-name - (condition-case nil ; potential errors with remote files - (if for-opened - (session-set-file-name-history) - (session-store-buffer-places 1)) - (error nil))))))) - -(defun session-file-opened-menu-filter (menu-items) - ;; checkdoc-params: (menu-items) - "This is the menu filter for \"File >> Open...recently visited\". -See `session-file-changed-menu-filter'." - (session-file-changed-menu-filter menu-items file-name-history)) - -(defun session-file-changed-menu-filter (menu-items &optional files find-fn) - ;; checkdoc-params: (menu-items) - "This is the menu filter for \"File >> Open...recently changed\". -It dynamically creates a list of files to use as the contents of the -menu. The files are taken from FILES or `session-file-alist'. It -doesn't show the same name twice and shows `session-menu-max-size' names -at most. FIND-FN or \\[find-file] is the function to use when selecting -a file in the menu." - (or files (setq files session-file-alist)) - (or find-fn (setq find-fn 'session-find-file)) - (let ((excl nil) - (menu nil) - (i session-menu-max-size) - (max-string (max (cond ((natnump session-file-menu-max-string) - session-file-menu-max-string) - ((integerp session-file-menu-max-string) - (- 0 session-file-menu-max-string - (length (buffer-name)))) - ((consp session-file-menu-max-string) - (- (car session-file-menu-max-string) - (max (- (length (buffer-name)) - (cdr session-file-menu-max-string)) - 0))) - (t 50)) - 16))) - (while (and files (> i 0)) - (let ((name (pop files)) desc) - (when (consp name) - (setq desc name - name (car name))) - (setq name (session-abbrev-file-name (directory-file-name name))) - (unless (member name excl) - (setq i (1- i)) - (push name excl) - (push (vector (or (session-file-prune-name name max-string) name) - (list find-fn name) - :keys (concat (and (sixth desc) "p") - (let ((buf (get-file-buffer name))) - (when buf - (with-current-buffer buf - (if (consp buffer-undo-list) - (if (buffer-modified-p) - "c" "s") - (if buffer-read-only - "r" "v"))))))) - menu)))) - (session-menu-maybe-accelerator menu-items (nreverse menu)))) - -(defun session-file-prune-name (elem max-string) - (when (> (length elem) max-string) - (let* ((sep-string (char-to-string session-directory-sep-char)) - (components (split-string elem (regexp-quote sep-string)))) - (or (cdr components) ; successful split - (eq session-directory-sep-char ?\/) ; already Unix separator - (setq sep-string "/" - components (split-string elem (regexp-quote sep-string)))) - (let* ((prefix (if (< (length (car components)) 3) ; e.g. "~" or "C:" - (concat (pop components) sep-string - (pop components)) - (pop components))) - (len (+ (length prefix) 7)) ; "/ ... /" - postfix) - (when (cdr components) ; more than one remaining dir component - (setq components (nreverse components)) - (incf len (length (car components))) - (push (pop components) postfix) ; always use last one - (while (<= (incf len (1+ (length (car components)))) max-string) - (push (pop components) postfix)) - (concat prefix sep-string " ... " sep-string - (mapconcat 'identity postfix sep-string))))))) - -(defun session-menu-maybe-accelerator (menu-items menu) - "Return menu consisting of items in MENU-ITEMS and MENU. -MENU-ITEMS have the usual format of elements in a menu, except that the -name always starts with a accelerator specification \"%_. \". Also, a -:keys specification will be evaluated if :keys is the first keyword. - -The items in MENU will be modified to add accelerator specifications if -`session-menu-accelerator-support' is non-nil." - (append menu-items - (if session-menu-accelerator-support - (funcall session-menu-accelerator-support menu) - menu))) - -(defun session-change-menu-item (item) ;; TODO: delete - "Change ITEM according to `session-menu-maybe-accelerator'." - (if (vectorp item) - (let ((keys (and (eq (aref item 2) :keys) - (not (stringp (aref item 3)))))) - (if (if session-menu-accelerator-support keys t) - (prog1 (setq item (copy-sequence item)) - (if keys - (aset item 3 (eval (aref item 3)))) - (or session-menu-accelerator-support - (aset item 0 (substring (aref item 0) 4)))) - item)) - item)) - -(defun session-abbrev-file-name (name) - "Return a version of NAME shortened using `directory-abbrev-alist'. -This function does not consider remote file names (see -`session-abbrev-inhibit-function') and substitutes \"~\" for the user's -home directory." - (if (and session-abbrev-inhibit-function - (or (not (fboundp session-abbrev-inhibit-function)) - (funcall session-abbrev-inhibit-function name))) - name - (cond-emacs-xemacs (abbreviate-file-name name :XEMACS t)))) - - -;;;=========================================================================== -;;; Functions in hooks -;;;=========================================================================== - -(defun session-find-file (filename) - ;; also sets history when just switching to existing buffer - (interactive "FFind file: ") - (find-file filename) - (let ((session-use-package t)) ;#dynamic - (session-set-file-name-history))) - -(defun session-set-file-name-history () - "Add file-name of current buffer to `file-name-history'. -Don't add the file name if it matches -`session-set-file-name-exclude-regexp', or if it is already at the front -of `file-name-history'. This function is useful in `find-file-hooks'." - (and session-use-package - buffer-file-name - (not (string= (car file-name-history) buffer-file-name)) - (not (string= (car file-name-history) buffer-file-truename)) -;; (file-exists-p buffer-file-name) (file-readable-p buffer-file-name) - (let ((name (session-abbrev-file-name buffer-file-name))) - (unless (and session-set-file-name-exclude-regexp - (string-match session-set-file-name-exclude-regexp name)) - (push name file-name-history))))) - -(defun session-find-file-hook () - "Function in `find-file-hooks'. See `session-file-alist'." - (unless (or (eq this-command 'session-disable) - (null session-use-package)) - (let* ((ass (assoc (session-buffer-file-name) session-file-alist)) - (point (second ass)) - (mark (third ass)) - (min (fourth ass)) - (max (fifth ass)) - (alist (nthcdr 7 ass))) - (condition-case nil - (while alist - (if (local-variable-if-set-p (caar alist) (current-buffer)) - (set (caar alist) (cdar alist))) - (setq alist (cdr alist))) - (error nil)) - (setq session-last-change (seventh ass)) - (and mark - (<= (point-min) mark) (<= mark (point-max)) - ;; I had `set-mark' but this function activates mark in Emacs, but - ;; not in XEmacs. `push-mark' is also OK and doesn't activate in - ;; both Emacsen which is better if we use `pending-delete-mode'. - (push-mark mark t)) - (and min max - (<= (point-min) min) (<= max (point-max)) - (narrow-to-region min max)) - (and point - (<= (point-min) point) (<= point (point-max)) - (goto-char point))))) - -(defun session-kill-buffer-hook () - "Function in `kill-buffer-hook'. -See `session-file-alist' and `session-registers'." - (if (and session-use-package buffer-file-name) - (let ((arg (if (memq this-command session-kill-buffer-commands) - (prefix-numeric-value current-prefix-arg) - 1))) - (condition-case nil - (if (> arg -2) - (session-store-buffer-places arg) - (setq file-name-history - (delete buffer-file-truename - (delete buffer-file-name file-name-history))) -;;; (setq session-file-alist -;;; (delete* (session-buffer-file-name) session-file-alist -;;; :key 'car :test 'string=))) ; Emacs CL policy... - (let ((fname (session-buffer-file-name)) - (alist (cons nil session-file-alist))) - (while (cdr alist) - (if (string= (cadr alist) fname) - (setcdr alist (cddr alist)) - (setq alist (cdr alist)))) - (setq session-file-alist (cdr alist)))) - (error nil))))) - - -;;;=========================================================================== -;;; Change register contents from marker to file -;;;=========================================================================== - -(defun session-register-swap-out () - "Turn markers in registers into file references when a buffer is killed. -See variable `session-register-swap-out'." - (and buffer-file-name - (let ((tail register-alist)) - (while tail - (and (markerp (cdr (car tail))) - (eq (marker-buffer (cdr (car tail))) (current-buffer)) - (setcdr (car tail) - (cons 'file buffer-file-name))) - (setq tail (cdr tail)))))) - - - -;;;;########################################################################## -;;;; Save global variables, add functions to hooks -;;;;########################################################################## - - -(defvar session-successful-p nil - "Whether the file `session-save-file' has been loaded successfully.") - - -;;;=========================================================================== -;;; The buffer file name -;;;=========================================================================== - -(defun session-xemacs-buffer-local-mswindows-file-p () - "Return t if the current buffer visits a local file on MS-Windows. -Also returns t if the current buffer does not visit a file. Return nil -of the current buffer visits a file starting with \"\\\\\". Workaround -for XEmacs bug in `file-truename' for file names starting with -\"\\\\\"." - (or (< (length buffer-file-name) 2) - (not (string= (substring buffer-file-name 0 2) "\\\\")))) - -(defun session-buffer-file-name () - "Return the buffer file name according to `session-use-truenames'." - (if (if (functionp session-use-truenames) - (funcall session-use-truenames) - session-use-truenames) - buffer-file-truename - buffer-file-name)) - - -;;;=========================================================================== -;;; Store places and local variables for buffer to be killed -;;;=========================================================================== - -(defun session-toggle-permanent-flag (arg &optional check) - "Toggle the permanent flag of the current buffer. -With ARG, set permanent flag if and only if ARG is positive. If the -permanent flag is set, the places are stored as well. If CHECK is -non-nil, just return the status of the permanent flag: either nil if it -is unset or `session-menu-permanent-string' if it is set." - (interactive "P") - (if buffer-file-name - (let ((permanent (if arg - (> (prefix-numeric-value arg) 0) - (not (nth 5 (assoc (session-buffer-file-name) - session-file-alist)))))) - (if check - (if permanent nil session-menu-permanent-string) - (session-store-buffer-places (if permanent 3 -1)) - (message (if permanent - "Permanent flag is set and places are stored" - "Permanent flag has been unset")))) - (if check nil (error "Buffer is not visiting a file")))) - -(defun session-store-buffer-places (arg) - "Store places and local variables in current buffer. -An entry for the current buffer and its places is added to the front of -`session-file-alist' if the buffer is visiting a file and if it is -mentioned in the list below. ARG is the prefix argument to a command in -`session-kill-buffer-commands' or 1 for any other command. - -ARG=-1: delete PERMANENT flag for buffer, -ARG=0: do nothing, -ARG=1: store buffer places, if the PERMANENT flag is set or the buffer - passes the function in `session-buffer-check-function', -ARG=2: always store buffer places, -ARG=3: set PERMANENT flag and store buffer places. - -See also `session-last-change' and `session-locals-include'. - -Note that not storing buffer places does not mean deleting an old entry -for the same file. It means that there is the danger of the entry -becoming too old to be saved across session. By default, only the first -100 entries of `session-file-alist' are saved, see -`session-globals-include'." - (let ((file-name (session-buffer-file-name))) - (when file-name - (let ((permanent (nthcdr 5 (assoc file-name session-file-alist)))) - (and (< arg 0) (car permanent) - (setcar permanent nil)) ; reset permanent in existing entry - (setq permanent (or (car permanent) (> arg 2))) - (if (or (and permanent (> arg 0)) - (> arg 1) - (and (= arg 1) - (funcall session-buffer-check-function (current-buffer)))) - (let ((locals session-locals-include) - (store nil)) - (while locals - (if (if (functionp session-locals-include) - (funcall session-locals-predicate - (car locals) (current-buffer)) - session-locals-predicate) - (push (cons (car locals) - (symbol-value (car locals))) - store)) - (setq locals (cdr locals))) - (setq store - (nconc (list file-name - (point) (mark t) - (point-min) - (and (<= (point-max) (buffer-size)) - (point-max)) - permanent - (session-undo-position 0 nil nil)) - store)) - (if (equal (caar session-file-alist) file-name) - (setcar session-file-alist store) - (push store session-file-alist)))))))) - -(defun session-find-file-not-found-hook () - "Query the user to delete the permanent flag for a non-existent file. -Always return nil." - (when session-use-package - (let ((file-name (session-buffer-file-name))) - (when file-name - (let ((permanent (nthcdr 5 (assoc file-name session-file-alist)))) - (and (car permanent) - (y-or-n-p "Delete permanent flag for non-existent file? ") - (setcar permanent nil))))))) - - -;;;=========================================================================== -;;; Default standard check for buffers to be killed -;;;=========================================================================== - -(defun session-default-buffer-check-p (buffer) - "Default function for `session-buffer-check-function'. -Argument BUFFER should be the current buffer." - (and - ;; undo check ------------------------------------------------------------- - (or (and (eq (cdr-safe session-undo-check) 'or) - session-last-change) - (and (or (not (eq (cdr-safe session-undo-check) 'and)) - session-last-change) - (>= (if (listp buffer-undo-list) (length buffer-undo-list) -1) - (if (consp session-undo-check) - (car session-undo-check) - session-undo-check)))) - ;; mode and name check ---------------------------------------------------- - (let ((file (buffer-file-name buffer))) - (and (or (and (fboundp session-abbrev-inhibit-function) - (funcall session-abbrev-inhibit-function file)) - (and (file-exists-p file) (file-readable-p file))) - (if (if session-auto-store - (not (memq major-mode session-mode-disable-list)) - (memq major-mode session-mode-enable-list)) - (not (and session-name-disable-regexp - (string-match session-name-disable-regexp file))) - (and session-name-enable-regexp - (string-match session-name-enable-regexp file))))))) - - -;;;=========================================================================== -;;; Save session file -;;;=========================================================================== - -(defun session-save-session (&optional force) - "Save session: file places, *-ring, *-history, registers. -Save some global variables and registers into file `session-save-file' -with coding system `session-save-file-coding-system'. Run functions in -`session-before-save-hook' before writing the file. - -See also `session-globals-regexp', `session-globals-include' and -`session-registers'. - -This command is executed when using \\[save-buffers-kill-emacs] without -prefix argument 0. See `kill-emacs-hook'." - (interactive "p") - (and (or force session-use-package) - session-save-file - (not (and (eq this-command 'save-buffers-kill-emacs) - (equal current-prefix-arg 0))) - (or session-successful-p - (not (file-exists-p session-save-file)) - (y-or-n-p "Overwrite old session file (not loaded)? ")) - (save-excursion - ;; `kill-emacs' doesn't kill the buffers ---------------------------- - (dolist (buffer (nreverse (buffer-list))) - (set-buffer buffer) - (when buffer-file-name - (condition-case nil ; potential errors with remote files - (session-store-buffer-places 1) - (error nil)) - (if session-register-swap-out - (funcall session-register-swap-out)))) - ;; create header of session file ------------------------------------ - (set-buffer (get-buffer-create " session ")) - (erase-buffer) - (let ((coding-system-for-write ;#dynamic - (and session-save-file-coding-system - (condition-case nil - (check-coding-system session-save-file-coding-system) - (error nil))))) - (when coding-system-for-write - (insert (format ";;; -*- coding: %S; -*-\n" - session-save-file-coding-system))) - (insert ";;; Automatically generated on " (current-time-string) - "\n;;; Invoked by " (user-login-name) "@" (system-name) - " using " emacs-version "\n") - ;; save global variables and registers ---------------------------- - (let ((s-excl session-globals-exclude)) - (dolist (incl (append session-globals-include - (apropos-internal session-globals-regexp - 'boundp))) - (let ((symbol (if (consp incl) (car incl) incl))) - (unless (memq symbol s-excl) - (push symbol s-excl) - (when (default-boundp symbol) - (session-save-insert-variable symbol - (default-value symbol) - (cdr-safe incl))))))) - (session-save-registers) - ;; write session file --------------------------------------------- - (run-hooks 'session-before-save-hook) - (condition-case var - (progn - (if (file-exists-p session-save-file) - (delete-file session-save-file)) - (make-directory (file-name-directory session-save-file) t) - (write-region (point-min) (point-max) session-save-file) - (if session-save-file-modes - (set-file-modes session-save-file - session-save-file-modes))) - (error ; efs would signal `ftp-error' - (or (y-or-n-p "Could not write session file. Exit anyway? ") - (cond-emacs-xemacs - (:EMACS signal :XEMACS signal-error :BOTH - (car var) (cdr var)))))) - (kill-buffer (current-buffer)))))) - -(defun session-save-insert-variable (symbol val spec) - ;; we don't print at all: - ;; - level-1 recursive lists - ;; - non true-list-p lists - ;; we don't print the following elements: - ;; - non-cons for assoc lists - ;; - string which are too long - ;; - non-readable elements (includes level-n recursions) - (when (consp val) - (let ((print-circle (car session-save-print-spec)) ;#dynamic - (print-level (cadr session-save-print-spec)) ;#dynamic - (print-length (caddr session-save-print-spec)) ;#dynamic - (len (or (car spec) session-globals-max-size)) - (ass-p (cadr spec)) - (slist nil) klist clist) - (while (and (consp val) (> len 0)) - (if (memq val clist) - (setq val t) ; don't print recursive lists - (push val clist) - (let* ((elem (pop val)) - (estr (prin1-to-string elem))) - ;; read/load isn't clever: ignore non-readable elements - (unless (cond (ass-p - (or (atom elem) - (member (car elem) klist) - (condition-case nil - (prog1 nil - (read estr) - (push (car elem) klist)) - (error t)))) - ((member estr slist)) - ((stringp elem) - (> (length elem) session-globals-max-string)) - ((condition-case nil - (prog1 nil - (read estr)) - (error t)))) - (push estr slist) - (decf len))))) - (when (and slist (null val)) ; don't print non-true lists - (insert (format "(setq-default %S '(" symbol)) - (setq slist (nreverse slist)) - (while slist - (insert (pop slist) (if slist " " "))\n"))))))) - -(defunx session-next-range-char (char) - ;; XEmacs register functions should handle integers as chars better... - :emacs-only 1+ - (int-to-char (1+ char))) - -(defun session-save-registers () - "Save registers in `session-registers'." - (let ((chars session-registers) - (type 'file) - register from to) - (while chars - (if (symbolp (car chars)) - (setq type (car chars) - chars (cdr chars)) - (setq from (car chars) - chars (cdr chars)) - (if (consp from) - (setq to (cdr from) - from (car from)) - (setq to from)) - (while (<= from to) - (setq register (get-register from)) - (cond ((null register)) - ((and (memq type '(file t)) - (consp register) - (memq (car register) '(file file-query))) - (insert (if (eq (car register) 'file) - (format "(set-register %S '(file . %S))\n" - from (cdr register)) - (format "(set-register %S '(file-query %S %d))\n" - from (cadr register) (caddr register))))) - ((and (memq type '(region t)) - (stringp register) - (< (length register) session-registers-max-string)) - (insert (format "(set-register %S %S)\n" from register)))) - (setq from (session-next-range-char from))))))) - - -;;;=========================================================================== -;;; Minibuffer history completion, see XEmacs' list-mode -;;;=========================================================================== - -(defvar session-history-help-string - '(concat (if (device-on-window-system-p) - (substitute-command-keys "Click \\<list-mode-map>\\[list-mode-item-mouse-selected] on a history element to select it.\n") "") - (substitute-command-keys "In this buffer, type RET to select the element near point.\n\n")) - "Form the evaluate to get a help string for history elements.") - -(defun session-minibuffer-history-help () - "List history of current minibuffer type. -In Emacs, the *History* buffer talks about \"completions\" instead -\"history elements\". In XEmacs before 21.4.9, selecting an entry might -not work if the minibuffer is non-empty." - (interactive) - (let ((history (symbol-value minibuffer-history-variable))) - (message nil) - (if history - (with-output-to-temp-buffer "*History*" - (cond-emacs-xemacs - (display-completion-list - (sort history #'string-lessp) - :XEMACS - :help-string session-history-help-string - :completion-string "Elements in the history are:")) - (save-excursion - (set-buffer standard-output) - (setq completion-base-size 0))) - (ding) - (session-minibuffer-message " [Empty history]")))) - -(defunx session-minibuffer-message (string) - :emacs-only minibuffer-message - :xemacs-only temp-minibuffer-message) - - -;;;=========================================================================== -;;; Set hooks, load session file -;;;=========================================================================== - -;; easymenu.el is for top-level menus only... both Emacs and XEmacs could -;; profit from a better menu interface... -(defunx session-add-submenu (menu) - "Add the menu MENU to the beginning of the File menu in the menubar. -If the \"File\" menu does not exist, no submenu is added. See -`easy-menu-define' for the format of MENU." - (and menu - :EMACS - (>= emacs-major-version 21) - (boundp 'menu-bar-files-menu) - (let ((keymap (easy-menu-create-menu (car menu) (cdr menu)))) - ;; `easy-menu-get-map' doesn't get the right one => use hard-coded - (define-key menu-bar-files-menu (vector (intern (car menu))) - (cons 'menu-item - (cons (car menu) - (if (not (symbolp keymap)) - (list keymap) - (cons (symbol-function keymap) - (get keymap 'menu-prop))))))) - :XEMACS - (featurep 'menubar) - (let ((current-menubar default-menubar) ;#dynamic - (first (cadar (find-menu-item default-menubar '("File"))))) - (when first - ;; XEmacs-20.4 `add-submenu' does not have 4th arg IN-MENU - (add-submenu '("File") menu - ;; arg BEFORE cannot be retrieved by any - ;; menubar function -- great... - (cond ((vectorp first) (aref first 0)) - ((consp first) (car first)))))))) - -(defunx session-initialize-keys () - (define-key ctl-x-map [(undo)] 'session-jump-to-last-change) - (define-key ctl-x-map [(control ?\/)] 'session-jump-to-last-change) - (define-key minibuffer-local-map [(meta ?\?)] - 'session-minibuffer-history-help) - :XEMACS - ;; C-down-mouse-3 pops up mode menu under Emacs - (define-key global-map [(control button3)] 'session-popup-yank-menu) - :EMACS - ;; Emacs doesn't seem to have keymap inheritance... - (define-key minibuffer-local-completion-map [(meta ?\?)] - 'session-minibuffer-history-help) - (define-key minibuffer-local-must-match-map [(meta ?\?)] - 'session-minibuffer-history-help) - (define-key minibuffer-local-ns-map [(meta ?\?)] - 'session-minibuffer-history-help)) - -(defunx session-initialize-menus () - (session-add-submenu '("Open...Recently Visited" - :included file-name-history - :filter session-file-opened-menu-filter - ["Move File Names Of All Buffers To Top" - session-file-opened-recompute] - "---")) - (session-add-submenu '("Open...Recently Changed" - ;;:included session-file-alist - :filter session-file-changed-menu-filter - ["Perform Evaluation For All Buffers" - session-file-changed-recompute] - ["Permanently List Current Buffer " - session-toggle-permanent-flag - ;; :keys must be at third position! - ;;:keys (session-toggle-permanent-flag nil t) - :active buffer-file-name - :style toggle - :selected (session-toggle-permanent-flag nil t)] - "---")) - :XEMACS - (and (featurep 'menubar) - (find-menu-item default-menubar '("Edit")) - (let ((current-menubar default-menubar)) - ;; XEmacs-20.4 `add-submenu' does not have 4th arg IN-MENU - (add-submenu '("Edit") - '("Select and Paste" - :included kill-ring - :filter session-yank-menu-filter) - (cond ((find-menu-item default-menubar - '("Edit" "Delete")) - "Delete") ; why just BEFORE, not AFTER - ((find-menu-item default-menubar - '("Edit" "Paste")) - "Paste") - ((find-menu-item default-menubar - '("Edit" "Undo")) - "Undo")))))) - -(defun session-initialize-do () - "Initialize package session and read previous session file. -Setup hooks and load `session-save-file', see variable `session-initialize'. At -best, this function is called at the end of the Emacs startup, i.e., add -this function to `after-init-hook'." - (when (and session-use-package - (null (get 'session-initialize :initilized-with))) - (when (or (eq session-initialize t) - (memq 'de-saveplace session-initialize)) - ;; Features of package saveplace, which has an auto-init, are covered by - ;; this package. - (when (functionp 'eval-after-load) - (eval-after-load "saveplace" - '(progn - (remove-hook 'find-file-hooks 'save-place-find-file-hook) - (remove-hook 'kill-emacs-hook 'save-place-kill-emacs-hook) - (remove-hook 'kill-buffer-hook 'save-place-to-alist))))) - (when (or (eq session-initialize t) - (memq 'places session-initialize)) - ;; `session-find-file-hook' should be *very* late in `find-file-hooks', - ;; esp. if some package, e.g. crypt, iso-cvt, change the buffer contents: - (add-hook 'find-file-hooks 'session-find-file-hook t) - (add-hook 'find-file-not-found-hooks 'session-find-file-not-found-hook t) - (add-hook 'kill-buffer-hook 'session-kill-buffer-hook) - (if session-register-swap-out - (add-hook 'kill-buffer-hook session-register-swap-out))) - (when (or (eq session-initialize t) (memq 'keys session-initialize)) - (condition-case nil - (session-initialize-keys) - (error nil))) - (when (or (eq session-initialize t) (memq 'menus session-initialize)) - (unless (memq 'session-set-file-name-history find-file-hooks) - ;; already initialized (probably not a good idea to redo for menus) - (add-hook 'find-file-hooks 'session-set-file-name-history) - (session-initialize-menus))) - (when (or (eq session-initialize t) - (memq 'session session-initialize)) - (add-hook 'kill-emacs-hook 'session-save-session) - (or session-successful-p - (setq session-successful-p - (and session-save-file - (condition-case nil - (progn - ;; load might fail with coding-system = emacs-mule - (unless (load session-save-file t nil t) - (and session-old-save-file - (load session-old-save-file t nil t))) - (run-hooks 'session-after-load-save-file-hook) - t) - (error nil)))))) - (put 'session-initialize :initilized-with session-initialize))) - -(defun session-initialize-and-set (symbol value) - (set-default symbol value) ; symbol should be `session-use-package' - (when value - (if (cond-emacs-xemacs - :EMACS (and (boundp 'after-init-time) (null after-init-time)) - :XEMACS (null init-file-loaded)) - ;; in the meantime,`session-use-package' could have been reset to nil - ;; (e.g. when using custom theme with t, user setting with nil) - (add-hook 'after-init-hook 'session-initialize-do) - (session-initialize-do)))) - -;; This must be late in this file as set function is called during loading. -(defcustom session-use-package nil - "Pseudo variable. Used to initialize session in custom buffer. -Put `(session-initialize)' into your ~/.emacs to initialize package -session in future sessions. See variable `session-initialize'." - :group 'session - :type '(boolean :on "in use" :off "not yet initialized or turned off" - :help-echo "Use package Session, initialize if necessary.") - :require 'session - :set 'session-initialize-and-set) - -;;;###autoload -(defun session-initialize () - "Initialize package session and read previous session file. -Setup hooks and load `session-save-file', see variable `session-initialize'. At -best, this function is called at the end of the Emacs startup, i.e., add -this function to `after-init-hook'." - (interactive) - (put 'session-initialize :initilized-with nil) - (custom-set-variables '(session-use-package t nil (session)))) - -;;; Local IspellPersDict: .ispell_session -;;; session.el ends here diff --git a/elisp/emacs-goodies-el/setnu.el b/elisp/emacs-goodies-el/setnu.el index e5b2821..e5b2821 100755..100644 --- a/elisp/emacs-goodies-el/setnu.el +++ b/elisp/emacs-goodies-el/setnu.el diff --git a/elisp/emacs-goodies-el/shell-command.el b/elisp/emacs-goodies-el/shell-command.el index 377f196..377f196 100755..100644 --- a/elisp/emacs-goodies-el/shell-command.el +++ b/elisp/emacs-goodies-el/shell-command.el diff --git a/elisp/emacs-goodies-el/show-wspace.el b/elisp/emacs-goodies-el/show-wspace.el deleted file mode 100755 index ecdf984..0000000 --- a/elisp/emacs-goodies-el/show-wspace.el +++ /dev/null @@ -1,257 +0,0 @@ -;;; show-wspace.el --- Highlight whitespace of various kinds. -;; -;; Filename: show-wspace.el -;; Description: Highlight whitespace of various kinds. -;; Author: Peter Steiner <unistein@isbe.ch>, Drew Adams -;; Maintainer: Drew Adams -;; Copyright (C) 2000-2009, Drew Adams, all rights reserved. -;; Created: Wed Jun 21 08:54:53 2000 -;; Version: 21.0 -;; Last-Updated: Sat Aug 1 15:42:17 2009 (-0700) -;; By: dradams -;; Update #: 282 -;; URL: http://www.emacswiki.org/cgi-bin/wiki/show-wspace.el -;; Keywords: highlight, whitespace -;; Compatibility: GNU Emacs: 20.x, 21.x, 22.x, 23.x -;; -;; Features that might be required by this library: -;; -;; None -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Commentary: -;; -;; Highlight whitespace of various kinds. -;; -;; To use this library: -;; -;; Add this to your initialization file (~/.emacs or ~/_emacs): -;; -;; (require 'show-wspace) ; Load this library. -;; -;; Then you can use commands `toggle-*' (see below) to turn the -;; various kinds of whitespace highlighting on and off in Font-Lock -;; mode. -;; -;; If you want to always use a particular kind of whitespace -;; highlighting, by default, then add the corresponding -;; `show-ws-highlight-*' function (see below) to the hook -;; `font-lock-mode-hook'. Then, whenever Font-Lock mode is turned on, -;; whitespace highlighting will also be turned on. -;; -;; For example, you can turn on tab highlighting by default by adding -;; function `show-ws-highlight-tabs' to `font-lock-mode-hook' in your -;; .emacs file, as follows: -;; -;; (add-hook 'font-lock-mode-hook 'show-ws-highlight-tabs) -;; -;; -;; Faces defined here: -;; -;; `show-ws-hard-space', `show-ws-tab', `show-ws-trailing-whitespace'. -;; -;; Commands defined here: -;; -;; `show-ws-toggle-show-hard-spaces', `show-ws-toggle-show-tabs', -;; `show-ws-toggle-show-trailing-whitespace', -;; `toggle-show-hard-spaces-show-ws' (alias), -;; `toggle-show-tabs-show-ws' (alias), -;; `toggle-show-trailing-whitespace-show-ws' (alias). -;; -;; Non-interactive functions defined here: -;; -;; `show-ws-dont-highlight-hard-spaces', -;; `show-ws-dont-highlight-tabs', -;; `show-ws-dont-highlight-trailing-whitespace', -;; `show-ws-highlight-hard-spaces', `show-ws-highlight-tabs', -;; `show-ws-highlight-trailing-whitespace'. -;; -;; Internal variables defined here: -;; -;; `show-ws-highlight-hard-spaces-p', `show-ws-highlight-tabs-p', -;; `show-ws-highlight-trailing-whitespace-p'. -;; -;; Drew Adams wrote the `toggle-*' commands and `*-p' variables. -;; -;; Peter Steiner wrote the original code that did the equivalent of -;; the `show-ws-highlight-*' commands here in his `hilite-trail.el'. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Change log: -;; -;; 2009/06/25 dadams -;; show-ws-dont-*: Should be no-op's for Emacs 20, 21. -;; 2009/06/17 dadams -;; Added: show-ws-dont-highlight-*. -;; show-ws-toggle-show-*: Remove the font-lock keywords. Needed for Emacs 22+. -;; 2007/09/25 dadams -;; Renamed to use prefix show-ws-. Thx to Cyril Brulebois. -;; 2006/11/11 dadams -;; Corrected doc strings. Clarified: hard space is non-breaking space, \240. -;; Included hard space in highlight-trailing-whitespace. -;; 2006/04/06 dadams -;; highlight-*: Use font-lock-add-keywords. Thanks to Karl Chen. -;; 2006/02/20 dadams -;; Mentioned in Commentary how to use non-interactively. -;; 2006/01/07 dadams -;; Added :link for sending bug report. -;; 2006/01/06 dadams -;; Added defgroup and use it. -;; 2005/12/30 dadams -;; Removed require of def-face-const.el. -;; Renamed faces, without "-face". -;; 2005/01/25 dadams -;; Removed ###autoload for defvars. -;; 2004/06/10 dadams -;; Fixed minor bug in highlight-* functions. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; This program 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. - -;; This program 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 this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth -;; Floor, Boston, MA 02110-1301, USA. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Code: - -(and (< emacs-major-version 20) (eval-when-compile (require 'cl))) ;; when, push - -;;;;;;;;;;;;;;;;;;;;;;;;; - -(defgroup Show-Whitespace nil - "Highlight whitespace of various kinds." - :prefix "show-ws-" - :group 'convenience :group 'matching - :link `(url-link :tag "Send Bug Report" - ,(concat "mailto:" "drew.adams" "@" "oracle" ".com?subject=\ -show-wspace.el bug: \ -&body=Describe bug here, starting with `emacs -q'. \ -Don't forget to mention your Emacs and library versions.")) - :link '(url-link :tag "Other Libraries by Drew" - "http://www.emacswiki.org/cgi-bin/wiki/DrewsElispLibraries") - :link '(url-link :tag "Download" - "http://www.emacswiki.org/cgi-bin/wiki/show-wspace.el") - :link '(url-link :tag "Description" - "http://www.emacswiki.org/cgi-bin/wiki/ShowWhiteSpace#ShowWspace") - :link '(emacs-commentary-link :tag "Commentary" "show-wspace") - ) - -(defface show-ws-tab '((t (:background "LemonChiffon"))) - "*Face for highlighting tab characters (`C-i') in Font-Lock mode." - :group 'Show-Whitespace :group 'font-lock :group 'faces) - -(defface show-ws-trailing-whitespace '((t (:background "Gold"))) - "*Face for highlighting whitespace at line ends in Font-Lock mode." - :group 'Show-Whitespace :group 'font-lock :group 'faces) - -(defface show-ws-hard-space '((t (:background "PaleGreen"))) - "*Face for highlighting non-breaking spaces (`\240')in Font-Lock mode." - :group 'Show-Whitespace :group 'font-lock :group 'faces) - - -(defvar show-ws-highlight-tabs-p nil - "Non-nil means font-lock mode highlights TAB characters (`C-i').") - -(defvar show-ws-highlight-trailing-whitespace-p nil - "Non-nil means font-lock mode highlights whitespace at line ends.") - -(defvar show-ws-highlight-hard-spaces-p nil - "Non-nil means font-lock mode highlights non-breaking spaces (`\240').") - -;;;###autoload -(defalias 'toggle-show-tabs-show-ws 'show-ws-toggle-show-tabs) -;;;###autoload -(defun show-ws-toggle-show-tabs () - "Toggle highlighting of TABs, using face `show-ws-tab'." - (interactive) - (setq show-ws-highlight-tabs-p (not show-ws-highlight-tabs-p)) - (if show-ws-highlight-tabs-p - (add-hook 'font-lock-mode-hook 'show-ws-highlight-tabs) - (remove-hook 'font-lock-mode-hook 'show-ws-highlight-tabs) - (show-ws-dont-highlight-tabs)) - (font-lock-mode) (font-lock-mode) - (message "TAB highlighting is now %s." (if show-ws-highlight-tabs-p "ON" "OFF"))) - -;;;###autoload -(defalias 'toggle-show-hard-spaces-show-ws 'show-ws-toggle-show-hard-spaces) -;;;###autoload -(defun show-ws-toggle-show-hard-spaces () - "Toggle highlighting of non-breaking space characters (`\240'). -Uses face `show-ws-hard-space'." - (interactive) - (setq show-ws-highlight-hard-spaces-p (not show-ws-highlight-hard-spaces-p)) - (if show-ws-highlight-hard-spaces-p - (add-hook 'font-lock-mode-hook 'show-ws-highlight-hard-spaces) - (remove-hook 'font-lock-mode-hook 'show-ws-highlight-hard-spaces) - (show-ws-dont-highlight-hard-spaces)) - (font-lock-mode) (font-lock-mode) - (message "Hard (non-breaking) space highlighting is now %s." - (if show-ws-highlight-hard-spaces-p "ON" "OFF"))) - -;;;###autoload -(defalias 'toggle-show-trailing-whitespace-show-ws - 'show-ws-toggle-show-trailing-whitespace) -;;;###autoload -(defun show-ws-toggle-show-trailing-whitespace () - "Toggle highlighting of trailing whitespace. -Uses face `show-ws-trailing-whitespace'." - (interactive) - (setq show-ws-highlight-trailing-whitespace-p - (not show-ws-highlight-trailing-whitespace-p)) - (if show-ws-highlight-trailing-whitespace-p - (add-hook 'font-lock-mode-hook 'show-ws-highlight-trailing-whitespace) - (remove-hook 'font-lock-mode-hook 'show-ws-highlight-trailing-whitespace) - (show-ws-dont-highlight-trailing-whitespace)) - (font-lock-mode) (font-lock-mode) - (message "Trailing whitespace highlighting is now %s." - (if show-ws-highlight-trailing-whitespace-p "ON" "OFF"))) - -(defun show-ws-highlight-tabs () - "Highlight tab characters (`C-i')." - (font-lock-add-keywords nil '(("[\t]+" (0 'show-ws-tab t))))) -(defun show-ws-highlight-hard-spaces () - "Highlight hard (non-breaking) space characters (`\240')." - (font-lock-add-keywords nil '(("[\240]+" (0 'show-ws-hard-space t))))) -(defun show-ws-highlight-trailing-whitespace () - "Highlight whitespace characters at line ends." - (font-lock-add-keywords - nil '(("[\240\040\t]+$" (0 'show-ws-trailing-whitespace t))))) - -;; These are no-ops for Emacs 20, 21: -;; `font-lock-remove-keywords' is not defined, and we don't need to use it. -(defun show-ws-dont-highlight-tabs () - "Don't highlight tab characters (`C-i')." - (when (fboundp 'font-lock-remove-keywords) - (font-lock-remove-keywords nil '(("[\t]+" (0 'show-ws-tab t)))))) - -(defun show-ws-dont-highlight-hard-spaces () - "Don't highlight hard (non-breaking) space characters (`\240')." - (when (fboundp 'font-lock-remove-keywords) - (font-lock-remove-keywords nil '(("[\240]+" (0 'show-ws-hard-space t)))))) - -(defun show-ws-dont-highlight-trailing-whitespace () - "Don't highlight whitespace characters at line ends." - (when (fboundp 'font-lock-remove-keywords) - (font-lock-remove-keywords - nil '(("[\240\040\t]+$" (0 'show-ws-trailing-whitespace t)))))) - -;;;;;;;;;;;;;;;;;;;;;;; - -(provide 'show-wspace) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; show-wspace.el ends here diff --git a/elisp/emacs-goodies-el/silly-mail.el b/elisp/emacs-goodies-el/silly-mail.el index 42a022d..42a022d 100755..100644 --- a/elisp/emacs-goodies-el/silly-mail.el +++ b/elisp/emacs-goodies-el/silly-mail.el diff --git a/elisp/emacs-goodies-el/slang-mode.el b/elisp/emacs-goodies-el/slang-mode.el index d79b900..d79b900 100755..100644 --- a/elisp/emacs-goodies-el/slang-mode.el +++ b/elisp/emacs-goodies-el/slang-mode.el diff --git a/elisp/emacs-goodies-el/sys-apropos.el b/elisp/emacs-goodies-el/sys-apropos.el deleted file mode 100755 index 5f291aa..0000000 --- a/elisp/emacs-goodies-el/sys-apropos.el +++ /dev/null @@ -1,118 +0,0 @@ -;; sys-apropos.el --- Interface for the *nix apropos command. - -;; Copyright (C) 2002 Henrik Enberg <henrik@enberg.org> - -;; Author: Henrik Enberg <henrik@enberg.org> -;; Keywords: help, external - -;; This file is not part of GNU Emacs. - -;; This program 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 of the License, or -;; (at your option) any later version. - -;; This program 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 this program; if not, write to the Free Software -;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -;;; Commentary: - -;;; Commentary: - -;; To install, drop it in a directory on your `load-path', and add -;; the following to your .emacs: - -;; (autoload 'sys-apropos "sys-apropos" nil t) - -;; Then do `M-x sys-apropos' and you're off. In the *System Apropos* -;; buffer, `RET' shows the manual for the program on that line and `q' -;; or `C-c C-c' quits the whole shebang. - -;;; Code: - -(require 'man) - -(defvar sys-apropos-line-regexp - "^\\([a-z0-9-_]+\\)[ \t]*(\\([0-9]\\))[ \t-]+\\(.*\\)" - "Regexp matching a line of output from the apropos command.") - -;;;###autoload -(defun sys-apropos (query) - "Ask the system apropos command for man-pages matching QUERY." - (interactive "sApropos query: ") - (let ((command (concat "apropos " query)) - (longest-name 0) - (output nil)) - (with-temp-buffer - (insert (shell-command-to-string command)) - (goto-char (point-min)) - (while (re-search-forward sys-apropos-line-regexp nil t) - (push (list (match-string 1) - (match-string 2) - (match-string 3)) - output) - (when (> (length (match-string 1)) longest-name) - (setq longest-name (length (match-string 1)))) - (forward-line 1))) - (if (not output) - (message "%s: nothing appropriate." query) - (let ((buffer (get-buffer-create "*System Apropos*")) - (inhibit-read-only t)) - (pop-to-buffer buffer) - (erase-buffer) - (setq output (nreverse output)) - (dolist (i output) - (let ((name (format "%s (%s)" (nth 0 i) (nth 1 i))) - (desciption (nth 2 i)) - (max-len (+ longest-name 4)) - (pad-char ? )) - (insert (propertize - (if (< (length name) max-len) - (concat name (make-string - (- max-len (length name)) - pad-char)) - name) 'face 'bold) - " - " desciption "\n"))) - (goto-char (point-min)) - (sys-apropos-mode))))) - -(defun sys-apropos-run-man () - "Show the man page on the current line." - (interactive) - (let ((beg (line-beginning-position)) - (end (line-end-position)) - (line nil)) - (setq line (buffer-substring-no-properties beg end)) - (with-temp-buffer - (insert line) - (goto-char (point-min)) - (when (re-search-forward sys-apropos-line-regexp nil t) - (let ((man-arg (concat (match-string 2) " " (match-string 1)))) - (Man-getpage-in-background man-arg)))))) - -(defun sys-apropos-quit () - "Exit from the `sys-apropos' buffer." - (interactive) - (when (eq major-mode 'sys-apropos-mode) - (kill-buffer (current-buffer)) - (when (/= (count-windows) 1) - (delete-window)))) - -(define-derived-mode sys-apropos-mode fundamental-mode "System Apropos" - "Major mode used in `sys-apropos' buffers. - -\\{sys-apropos-mode-map}" - (define-key sys-apropos-mode-map (kbd "RET") 'sys-apropos-run-man) - (define-key sys-apropos-mode-map (kbd "C-c C-c") 'sys-apropos-quit) - (define-key sys-apropos-mode-map (kbd "q") 'sys-apropos-quit) - (setq truncate-lines t - buffer-read-only t)) - -(provide 'sys-apropos) - -;;; sys-apropos.el ends here diff --git a/elisp/emacs-goodies-el/tabbar.el b/elisp/emacs-goodies-el/tabbar.el deleted file mode 100755 index 8f383a1..0000000 --- a/elisp/emacs-goodies-el/tabbar.el +++ /dev/null @@ -1,1932 +0,0 @@ -;;; Tabbar.el --- Display a tab bar in the header line - -;; Copyright (C) 2003, 2004, 2005 David Ponce - -;; Author: David Ponce <david@dponce.com> -;; Maintainer: David Ponce <david@dponce.com> -;; Created: 25 February 2003 -;; Keywords: convenience -;; Revision: $Id: tabbar.el,v 1.2 2007-08-08 22:24:29 psg Exp $ - -(defconst tabbar-version "2.0") - -;; This file is not part of GNU Emacs. - -;; This program 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. - -;; This program 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 this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth -;; Floor, Boston, MA 02110-1301, USA. - -;;; Commentary: -;; -;; This library provides the Tabbar global minor mode to display a tab -;; bar in the header line of Emacs 21 and later versions. You can use -;; the mouse to click on a tab and select it. Also, three buttons are -;; displayed on the left side of the tab bar in this order: the -;; "home", "scroll left", and "scroll right" buttons. The "home" -;; button is a general purpose button used to change something on the -;; tab bar. The scroll left and scroll right buttons are used to -;; scroll tabs horizontally. Tabs can be divided up into groups to -;; maintain several sets of tabs at the same time (see also the -;; chapter "Core" below for more details on tab grouping). Only one -;; group is displayed on the tab bar, and the "home" button, for -;; example, can be used to navigate through the different groups, to -;; show different tab bars. -;; -;; In a graphic environment, using the mouse is probably the preferred -;; way to work with the tab bar. However, you can also use the tab -;; bar when Emacs is running on a terminal, so it is possible to use -;; commands to press special buttons, or to navigate cyclically -;; through tabs. -;; -;; These commands, and default keyboard shortcuts, are provided: -;; -;; `tabbar-mode' -;; Toggle the Tabbar global minor mode. When enabled a tab bar is -;; displayed in the header line. -;; -;; `tabbar-local-mode' (C-c <C-f10>) -;; Toggle the Tabbar-Local minor mode. Provided the global minor -;; mode is turned on, the tab bar becomes local in the current -;; buffer when the local minor mode is enabled. This permits to -;; see the tab bar in a buffer where the header line is already -;; used by another mode (like `Info-mode' for example). -;; -;; `tabbar-mwheel-mode' -;; Toggle the Tabbar-Mwheel global minor mode. When enabled you -;; can use the mouse wheel to navigate through tabs of groups. -;; -;; `tabbar-press-home' (C-c <C-home>) -;; `tabbar-press-scroll-left' (C-c <C-prior>) -;; `tabbar-press-scroll-right' (C-c <C-next>) -;; Simulate a mouse-1 click on respectively the "home", "scroll -;; left", and "scroll right" buttons. A numeric prefix argument -;; value of 2, or 3, respectively simulates a mouse-2, or mouse-3 -;; click. -;; -;; `tabbar-backward' (C-c <C-left>) -;; `tabbar-forward' (C-c <C-right>) -;; Are the basic commands to navigate cyclically through tabs or -;; groups of tabs. The cycle is controlled by the -;; `tabbar-cycle-scope' option. The default is to navigate -;; through all tabs across all existing groups of tabs. You can -;; change the default behavior to navigate only through the tabs -;; visible on the tab bar, or through groups of tabs only. Or use -;; the more specialized commands below. -;; -;; `tabbar-backward-tab' -;; `tabbar-forward-tab' -;; Navigate through the tabs visible on the tab bar. -;; -;; `tabbar-backward-group' (C-c <C-up>) -;; `tabbar-forward-group' (C-c <C-down>) -;; Navigate through existing groups of tabs. -;; -;; -;; Core -;; ---- -;; -;; The content of the tab bar is represented by an internal data -;; structure: a tab set. A tab set is a collection (group) of tabs, -;; identified by an unique name. In a tab set, at any time, one and -;; only one tab is designated as selected within the tab set. -;; -;; A tab is a simple data structure giving the value of the tab, and a -;; reference to its tab set container. A tab value can be any Lisp -;; object. Each tab object is guaranteed to be unique. -;; -;; A tab set is displayed on the tab bar through a "view" defined by -;; the index of the leftmost tab shown. Thus, it is possible to -;; scroll the tab bar horizontally by changing the start index of the -;; tab set view. -;; -;; The visual representation of a tab bar is a list of valid -;; `header-line-format' template elements, one for each special -;; button, and for each tab found into a tab set "view". When the -;; visual representation of a tab is required, the function specified -;; in the variable `tabbar-tab-label-function' is called to obtain it. -;; The visual representation of a special button is obtained by -;; calling the function specified in `tabbar-button-label-function', -;; which is passed a button name among `home', `scroll-left', or -;; `scroll-right'. There are also options and faces to customize the -;; appearance of buttons and tabs (see the code for more details). -;; -;; When the mouse is over a tab, the function specified in -;; `tabbar-help-on-tab-function' is called, which is passed the tab -;; and should return a help string to display. When a tab is -;; selected, the function specified in `tabbar-select-tab-function' is -;; called, which is passed the tab and the event received. -;; -;; Similarly, to control the behavior of the special buttons, the -;; following variables are available, for respectively the `home', -;; `scroll-left' and `scroll-right' value of `<button>': -;; -;; `tabbar-<button>-function' -;; Function called when <button> is selected. The function is -;; passed the mouse event received. -;; -;; `tabbar-<button>-help-function' -;; Function called with no arguments to obtain a help string -;; displayed when the mouse is over <button>. -;; -;; To increase performance, each tab set automatically maintains its -;; visual representation in a cache. As far as possible, the cache is -;; used to display the tab set, and refreshed only when necessary. -;; -;; Several tab sets can be maintained at the same time. Only one is -;; displayed on the tab bar, it is obtained by calling the function -;; specified in the variable `tabbar-current-tabset-function'. -;; -;; A special tab set is maintained, that contains the list of the -;; currently selected tabs in the existing tab sets. This tab set is -;; useful to show the existing tab sets in a tab bar, and switch -;; between them easily. The function `tabbar-get-tabsets-tabset' -;; returns this special tab set. -;; -;; -;; Buffer tabs -;; ----------- -;; -;; The default tab bar implementation provided displays buffers in -;; dedicated tabs. Selecting a tab, switch (mouse-1), or pop -;; (mouse-2), to the buffer it contains. -;; -;; The list of buffers put in tabs is provided by the function -;; specified in the variable `tabbar-buffer-list-function'. The -;; default function: `tabbar-buffer-list', excludes buffers whose name -;; starts with a space, when they are not visiting a file. -;; -;; Buffers are organized in groups, each one represented by a tab set. -;; A buffer can have no group, or belong to more than one group. The -;; function specified by the variable `tabbar-buffer-groups-function' -;; is called for each buffer to obtain the groups it belongs to. The -;; default function provided: `tabbar-buffer-groups' organizes buffers -;; depending on their major mode (see that function for details). -;; -;; The "home" button toggles display of buffer groups on the tab bar, -;; allowing to easily show another buffer group by clicking on the -;; associated tab. -;; -;; Known problems: -;; -;; Bug item #858306 at <http://sf.net/tracker/?group_id=79309>: -;; tabbar-mode crashes GNU Emacs 21.3 on MS-Windows 98/95. -;; - -;;; History: -;; - -;;; Code: - -;;; Options -;; -(defgroup tabbar nil - "Display a tab bar in the header line." - :group 'convenience) - -(defcustom tabbar-cycle-scope nil - "*Specify the scope of cyclic navigation through tabs. -The following scopes are possible: - -- `tabs' - Navigate through visible tabs only. -- `groups' - Navigate through tab groups only. -- default - Navigate through visible tabs, then through tab groups." - :group 'tabbar - :type '(choice :tag "Cycle through..." - (const :tag "Visible Tabs Only" tabs) - (const :tag "Tab Groups Only" groups) - (const :tag "Visible Tabs then Tab Groups" nil))) - -(defcustom tabbar-auto-scroll-flag t - "*Non-nil means to automatically scroll the tab bar. -That is, when a tab is selected outside of the tab bar visible area, -the tab bar is scrolled horizontally so the selected tab becomes -visible." - :group 'tabbar - :type 'boolean) - -(defvar tabbar-inhibit-functions '(tabbar-default-inhibit-function) - "List of functions to be called before displaying the tab bar. -Those functions are called one by one, with no arguments, until one of -them returns a non-nil value, and thus, prevents to display the tab -bar.") - -(defvar tabbar-current-tabset-function nil - "Function called with no argument to obtain the current tab set. -This is the tab set displayed on the tab bar.") - -(defvar tabbar-tab-label-function nil - "Function that obtains a tab label displayed on the tab bar. -The function is passed a tab and should return a string.") - -(defvar tabbar-select-tab-function nil - "Function that select a tab. -The function is passed a mouse event and a tab, and should make it the -selected tab.") - -(defvar tabbar-help-on-tab-function nil - "Function to obtain a help string for a tab. -The help string is displayed when the mouse is onto the button. The -function is passed the tab and should return a help string or nil for -none.") - -(defvar tabbar-button-label-function nil - "Function that obtains a button label displayed on the tab bar. -The function is passed a button name should return a propertized -string to display.") - -(defvar tabbar-home-function nil - "Function called when clicking on the tab bar home button. -The function is passed the mouse event received.") - -(defvar tabbar-home-help-function nil - "Function to obtain a help string for the tab bar home button. -The help string is displayed when the mouse is onto the button. -The function is called with no arguments.") - -(defvar tabbar-scroll-left-function 'tabbar-scroll-left - "Function that scrolls tabs on left. -The function is passed the mouse event received when clicking on the -scroll left button. It should scroll the current tab set.") - -(defvar tabbar-scroll-left-help-function 'tabbar-scroll-left-help - "Function to obtain a help string for the scroll left button. -The help string is displayed when the mouse is onto the button. -The function is called with no arguments.") - -(defvar tabbar-scroll-right-function 'tabbar-scroll-right - "Function that scrolls tabs on right. -The function is passed the mouse event received when clicking on the -scroll right button. It should scroll the current tab set.") - -(defvar tabbar-scroll-right-help-function 'tabbar-scroll-right-help - "Function to obtain a help string for the scroll right button. -The help string is displayed when the mouse is onto the button. -The function is called with no arguments.") - -;;; Misc. -;; -(eval-and-compile - (defalias 'tabbar-display-update - (if (fboundp 'force-window-update) - #'(lambda () (force-window-update (selected-window))) - 'force-mode-line-update))) - -(defsubst tabbar-click-p (event) - "Return non-nil if EVENT is a mouse click event." - (memq 'click (event-modifiers event))) - -(defun tabbar-shorten (str width) - "Return a shortened string from STR that fits in the given display WIDTH. -WIDTH is specified in terms of character display width in the current -buffer; see also `char-width'. If STR display width is greater than -WIDTH, STR is truncated and an ellipsis string \"...\" is inserted at -end or in the middle of the returned string, depending on available -room." - (let* ((n (length str)) - (sw (string-width str)) - (el "...") - (ew (string-width el)) - (w 0) - (i 0)) - (cond - ;; STR fit in WIDTH, return it. - ((<= sw width) - str) - ;; There isn't enough room for the ellipsis, STR is just - ;; truncated to fit in WIDTH. - ((<= width ew) - (while (< w width) - (setq w (+ w (char-width (aref str i))) - i (1+ i))) - (substring str 0 i)) - ;; There isn't enough room to insert the ellipsis in the middle - ;; of the truncated string, so put the ellipsis at end. - ((zerop (setq sw (/ (- width ew) 2))) - (setq width (- width ew)) - (while (< w width) - (setq w (+ w (char-width (aref str i))) - i (1+ i))) - (concat (substring str 0 i) el)) - ;; Put the ellipsis in the middle of the truncated string. - (t - (while (< w sw) - (setq w (+ w (char-width (aref str i))) - i (1+ i))) - (setq w (+ w ew)) - (while (< w width) - (setq n (1- n) - w (+ w (char-width (aref str n))))) - (concat (substring str 0 i) el (substring str n))) - ))) - -;;; Tab and tab set -;; -(defsubst tabbar-make-tab (object tabset) - "Return a new tab with value OBJECT. -TABSET is the tab set the tab belongs to." - (cons object tabset)) - -(defsubst tabbar-tab-value (tab) - "Return the value of tab TAB." - (car tab)) - -(defsubst tabbar-tab-tabset (tab) - "Return the tab set TAB belongs to." - (cdr tab)) - -(defvar tabbar-tabsets nil - "The tab sets store.") - -(defvar tabbar-tabsets-tabset nil - "The special tab set of existing tab sets.") - -(defvar tabbar-current-tabset nil - "The tab set currently displayed on the tab bar.") -(make-variable-buffer-local 'tabbar-current-tabset) - -(defvar tabbar-init-hook nil - "Hook run after tab bar data has been initialized. -You should use this hook to initialize dependent data.") - -(defsubst tabbar-init-tabsets-store () - "Initialize the tab set store." - (setq tabbar-tabsets (make-vector 31 0) - tabbar-tabsets-tabset (make-symbol "tabbar-tabsets-tabset")) - (put tabbar-tabsets-tabset 'start 0) - (run-hooks 'tabbar-init-hook)) - -(defvar tabbar-quit-hook nil - "Hook run after tab bar data has been freed. -You should use this hook to reset dependent data.") - -(defsubst tabbar-free-tabsets-store () - "Free the tab set store." - (setq tabbar-tabsets nil - tabbar-tabsets-tabset nil) - (run-hooks 'tabbar-quit-hook)) - -;; Define an "hygienic" function free of side effect between its local -;; variables and those of the callee. -(eval-and-compile - (defalias 'tabbar-map-tabsets - (let ((function (make-symbol "function")) - (result (make-symbol "result")) - (tabset (make-symbol "tabset"))) - `(lambda (,function) - "Apply FUNCTION to each tab set, and make a list of the results. -The result is a list just as long as the number of existing tab sets." - (let (,result) - (mapatoms - #'(lambda (,tabset) - (push (funcall ,function ,tabset) ,result)) - tabbar-tabsets) - ,result))))) - -(defun tabbar-make-tabset (name &rest objects) - "Make a new tab set whose name is the string NAME. -It is initialized with tabs build from the list of OBJECTS." - (let* ((tabset (intern name tabbar-tabsets)) - (tabs (mapcar #'(lambda (object) - (tabbar-make-tab object tabset)) - objects))) - (set tabset tabs) - (put tabset 'select (car tabs)) - (put tabset 'start 0) - tabset)) - -(defsubst tabbar-get-tabset (name) - "Return the tab set whose name is the string NAME. -Return nil if not found." - (intern-soft name tabbar-tabsets)) - -(defsubst tabbar-delete-tabset (tabset) - "Delete the tab set TABSET. -That is, remove it from the tab sets store." - (unintern tabset tabbar-tabsets)) - -(defsubst tabbar-tabs (tabset) - "Return the list of tabs in TABSET." - (symbol-value tabset)) - -(defsubst tabbar-tab-values (tabset) - "Return the list of tab values in TABSET." - (mapcar 'tabbar-tab-value (tabbar-tabs tabset))) - -(defsubst tabbar-get-tab (object tabset) - "Search for a tab with value OBJECT in TABSET. -Return the tab found, or nil if not found." - (assoc object (tabbar-tabs tabset))) - -(defsubst tabbar-member (tab tabset) - "Return non-nil if TAB is in TABSET." - (or (eq (tabbar-tab-tabset tab) tabset) - (memq tab (tabbar-tabs tabset)))) - -(defsubst tabbar-template (tabset) - "Return the cached visual representation of TABSET. -That is, a `header-line-format' template, or nil if the cache is -empty." - (get tabset 'template)) - -(defsubst tabbar-set-template (tabset template) - "Set the cached visual representation of TABSET to TEMPLATE. -TEMPLATE must be a valid `header-line-format' template, or nil to -cleanup the cache." - (put tabset 'template template)) - -(defsubst tabbar-selected-tab (tabset) - "Return the tab selected in TABSET." - (get tabset 'select)) - -(defsubst tabbar-selected-value (tabset) - "Return the value of the tab selected in TABSET." - (tabbar-tab-value (tabbar-selected-tab tabset))) - -(defsubst tabbar-selected-p (tab tabset) - "Return non-nil if TAB is the selected tab in TABSET." - (eq tab (tabbar-selected-tab tabset))) - -(defvar tabbar--track-selected nil) - -(defsubst tabbar-select-tab (tab tabset) - "Make TAB the selected tab in TABSET. -Does nothing if TAB is not found in TABSET. -Return TAB if selected, nil if not." - (when (tabbar-member tab tabset) - (unless (tabbar-selected-p tab tabset) - (tabbar-set-template tabset nil) - (setq tabbar--track-selected tabbar-auto-scroll-flag)) - (put tabset 'select tab))) - -(defsubst tabbar-select-tab-value (object tabset) - "Make the tab with value OBJECT, the selected tab in TABSET. -Does nothing if a tab with value OBJECT is not found in TABSET. -Return the tab selected, or nil if nothing was selected." - (tabbar-select-tab (tabbar-get-tab object tabset) tabset)) - -(defsubst tabbar-start (tabset) - "Return the index of the first visible tab in TABSET." - (get tabset 'start)) - -(defsubst tabbar-view (tabset) - "Return the list of visible tabs in TABSET. -That is, the sub-list of tabs starting at the first visible one." - (nthcdr (tabbar-start tabset) (tabbar-tabs tabset))) - -(defun tabbar-add-tab (tabset object &optional append) - "Add to TABSET a tab with value OBJECT if there isn't one there yet. -If the tab is added, it is added at the beginning of the tab list, -unless the optional argument APPEND is non-nil, in which case it is -added at the end." - (let ((tabs (tabbar-tabs tabset))) - (if (tabbar-get-tab object tabset) - tabs - (let ((tab (tabbar-make-tab object tabset))) - (tabbar-set-template tabset nil) - (set tabset (if append - (append tabs (list tab)) - (cons tab tabs))))))) - -(defun tabbar-delete-tab (tab) - "Remove TAB from its tab set." - (let* ((tabset (tabbar-tab-tabset tab)) - (tabs (tabbar-tabs tabset)) - (sel (eq tab (tabbar-selected-tab tabset))) - (next (and sel (cdr (memq tab tabs))))) - (tabbar-set-template tabset nil) - (setq tabs (delq tab tabs)) - ;; When the selected tab is deleted, select the next one, if - ;; available, or the last one otherwise. - (and sel (tabbar-select-tab (car (or next (last tabs))) tabset)) - (set tabset tabs))) - -(defun tabbar-scroll (tabset count) - "Scroll the visible tabs in TABSET of COUNT units. -If COUNT is positive move the view on right. If COUNT is negative, -move the view on left." - (let ((start (min (max 0 (+ (tabbar-start tabset) count)) - (1- (length (tabbar-tabs tabset)))))) - (when (/= start (tabbar-start tabset)) - (tabbar-set-template tabset nil) - (put tabset 'start start)))) - -(defun tabbar-tab-next (tabset tab &optional before) - "Search in TABSET for the tab after TAB. -If optional argument BEFORE is non-nil, search for the tab before -TAB. Return the tab found, or nil otherwise." - (let* (last (tabs (tabbar-tabs tabset))) - (while (and tabs (not (eq tab (car tabs)))) - (setq last (car tabs) - tabs (cdr tabs))) - (and tabs (if before last (nth 1 tabs))))) - -(defun tabbar-current-tabset (&optional update) - "Return the tab set currently displayed on the tab bar. -If optional argument UPDATE is non-nil, call the user defined function -`tabbar-current-tabset-function' to obtain it. Otherwise return the -current cached copy." - (and update tabbar-current-tabset-function - (setq tabbar-current-tabset - (funcall tabbar-current-tabset-function))) - tabbar-current-tabset) - -(defun tabbar-get-tabsets-tabset () - "Return the tab set of selected tabs in existing tab sets." - (set tabbar-tabsets-tabset (tabbar-map-tabsets 'tabbar-selected-tab)) - (tabbar-scroll tabbar-tabsets-tabset 0) - (tabbar-set-template tabbar-tabsets-tabset nil) - tabbar-tabsets-tabset) - -;;; Faces -;; -(defface tabbar-default - '( - ;;(((class color grayscale) (background light)) - ;; :inherit variable-pitch - ;; :height 0.8 - ;; :foreground "gray50" - ;; :background "grey75" - ;; ) - (((class color grayscale) (background dark)) - :inherit variable-pitch - :height 0.8 - :foreground "grey75" - :background "gray50" - ) - (((class mono) (background light)) - :inherit variable-pitch - :height 0.8 - :foreground "black" - :background "white" - ) - (((class mono) (background dark)) - :inherit variable-pitch - :height 0.8 - :foreground "white" - :background "black" - ) - (t - :inherit variable-pitch - :height 0.8 - :foreground "gray50" - :background "gray75" - )) - "Default face used in the tab bar." - :group 'tabbar) - -(defface tabbar-unselected - '((t - :inherit tabbar-default - :box (:line-width 1 :color "white" :style released-button) - )) - "Face used for unselected tabs." - :group 'tabbar) - -(defface tabbar-selected - '((t - :inherit tabbar-default - :box (:line-width 1 :color "white" :style pressed-button) - :foreground "blue" - )) - "Face used for the selected tab." - :group 'tabbar) - -(defface tabbar-highlight - '((t - :underline t - )) - "Face used to highlight a tab during mouse-overs." - :group 'tabbar) - -(defface tabbar-separator - '((t - :inherit tabbar-default - :height 0.1 - )) - "Face used for separators between tabs." - :group 'tabbar) - -(defface tabbar-button - '((t - :inherit tabbar-default - :box (:line-width 1 :color "white" :style released-button) - :foreground "dark red" - )) - "Face used for tab bar buttons." - :group 'tabbar) - -(defface tabbar-button-highlight - '((t - :inherit tabbar-default - )) - "Face used to highlight a button during mouse-overs." - :group 'tabbar) - -(defcustom tabbar-background-color nil - "*Background color of the tab bar. -By default, use the background color specified for the -`tabbar-default' face (or inherited from another face), or the -background color of the `default' face otherwise." - :group 'tabbar - :type '(choice (const :tag "Default" nil) - (color))) - -(defsubst tabbar-background-color () - "Return the background color of the tab bar." - (or tabbar-background-color - (let* ((face 'tabbar-default) - (color (face-background face))) - (while (null color) - (or (facep (setq face (face-attribute face :inherit))) - (setq face 'default)) - (setq color (face-background face))) - color))) - -;;; Buttons and separator look and feel -;; -(defconst tabbar-button-widget - '(cons - (cons :tag "Enabled" - (string) - (repeat :tag "Image" - :extra-offset 2 - (restricted-sexp :tag "Spec" - :match-alternatives (listp)))) - (cons :tag "Disabled" - (string) - (repeat :tag "Image" - :extra-offset 2 - (restricted-sexp :tag "Spec" - :match-alternatives (listp)))) - ) - "Widget for editing a tab bar button. -A button is specified as a pair (ENABLED-BUTTON . DISABLED-BUTTON), -where ENABLED-BUTTON and DISABLED-BUTTON specify the value used when -the button is respectively enabled and disabled. Each button value is -a pair (STRING . IMAGE) where STRING is a string value, and IMAGE a -list of image specifications. -If IMAGE is non-nil, try to use that image, else use STRING. -If only the ENABLED-BUTTON image is provided, a DISABLED-BUTTON image -is derived from it.") - -;;; Home button -;; -(defvar tabbar-home-button-value nil - "Value of the home button.") - -(defconst tabbar-home-button-enabled-image - '((:type pbm :data "\ -P2 13 13 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 -255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 0 -6 0 255 255 255 255 255 255 255 255 255 255 9 130 9 255 255 255 255 -255 255 255 255 255 255 26 130 26 255 255 255 255 255 255 255 0 9 26 -41 130 41 26 9 0 255 255 255 255 5 145 140 135 130 125 120 115 5 255 -255 255 255 0 9 26 41 130 41 26 9 0 255 255 255 255 255 255 255 26 130 -26 255 255 255 255 255 255 255 255 255 255 9 130 9 255 255 255 255 255 -255 255 255 255 255 0 6 0 255 255 255 255 255 255 255 255 255 255 255 -255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 -255 255 255 -")) - "Default image for the enabled home button.") - -(defconst tabbar-home-button-disabled-image - '((:type pbm :data "\ -P2 13 13 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 -255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 -255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 -255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 -255 255 0 0 1 2 3 2 1 0 0 255 255 255 255 0 132 128 123 119 114 110 -106 0 255 255 255 255 0 0 1 2 3 2 1 0 0 255 255 255 255 255 255 255 -255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 -255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 -255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 -255 255 255 255 255 255 255 255 255 -")) - "Default image for the disabled home button.") - -(defcustom tabbar-home-button - (cons (cons "[o]" tabbar-home-button-enabled-image) - (cons "[x]" tabbar-home-button-disabled-image)) - "The home button. -The variable `tabbar-button-widget' gives details on this widget." - :group 'tabbar - :type tabbar-button-widget - :set '(lambda (variable value) - (custom-set-default variable value) - ;; Schedule refresh of button value. - (setq tabbar-home-button-value nil))) - -;;; Scroll left button -;; -(defvar tabbar-scroll-left-button-value nil - "Value of the scroll left button.") - -(defconst tabbar-scroll-left-button-enabled-image - '((:type pbm :data "\ -P2 13 13 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 -255 255 255 255 255 255 255 255 128 16 48 255 255 255 255 255 255 255 -255 144 28 86 128 0 255 255 255 255 255 255 160 44 92 159 135 113 0 -255 255 255 255 160 44 97 165 144 129 120 117 0 255 255 176 44 98 175 -174 146 127 126 127 128 0 255 255 0 160 184 156 143 136 134 135 137 -138 0 255 255 176 32 67 144 146 144 145 146 148 149 0 255 255 255 255 -160 42 75 140 154 158 159 160 0 255 255 255 255 255 255 160 40 74 154 -170 171 0 255 255 255 255 255 255 255 255 160 41 82 163 0 255 255 255 -255 255 255 255 255 255 255 160 32 48 255 255 255 255 255 255 255 255 -255 255 255 255 255 255 -")) - "Default image for the enabled scroll left button. -A disabled button image will be automatically build from it.") - -(defcustom tabbar-scroll-left-button - (cons (cons " <" tabbar-scroll-left-button-enabled-image) - (cons " =" nil)) - "The scroll left button. -The variable `tabbar-button-widget' gives details on this widget." - :group 'tabbar - :type tabbar-button-widget - :set '(lambda (variable value) - (custom-set-default variable value) - ;; Schedule refresh of button value. - (setq tabbar-scroll-left-button-value nil))) - -;;; Scroll right button -;; -(defvar tabbar-scroll-right-button-value nil - "Value of the scroll right button.") - -(defconst tabbar-scroll-right-button-enabled-image - '((:type pbm :data "\ -P2 13 13 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 -48 32 160 255 255 255 255 255 255 255 255 255 255 44 161 71 32 160 255 -255 255 255 255 255 255 255 36 157 163 145 62 32 160 255 255 255 255 -255 255 30 128 133 137 142 124 50 32 160 255 255 255 255 29 120 121 -124 126 126 124 105 42 32 176 255 255 31 126 127 128 128 128 128 126 -124 89 32 255 255 33 134 135 136 137 137 138 119 49 32 176 255 255 34 -143 144 145 146 128 54 32 160 255 255 255 255 36 152 153 134 57 32 160 -255 255 255 255 255 255 38 141 60 32 160 255 255 255 255 255 255 255 -255 48 32 160 255 255 255 255 255 255 255 255 255 255 255 255 255 255 -255 255 255 255 255 255 255 255 -")) - "Default image for the enabled scroll right button. -A disabled button image will be automatically build from it.") - -(defcustom tabbar-scroll-right-button - (cons (cons " >" tabbar-scroll-right-button-enabled-image) - (cons " =" nil)) - "The scroll right button. -The variable `tabbar-button-widget' gives details on this widget." - :group 'tabbar - :type tabbar-button-widget - :set '(lambda (variable value) - (custom-set-default variable value) - ;; Schedule refresh of button value. - (setq tabbar-scroll-right-button-value nil))) - -;;; Separator -;; -(defconst tabbar-separator-widget - '(cons (choice (string) - (number :tag "Space width" 0.2)) - (repeat :tag "Image" - :extra-offset 2 - (restricted-sexp :tag "Spec" - :match-alternatives (listp)))) - "Widget for editing a tab bar separator. -A separator is specified as a pair (STRING-OR-WIDTH . IMAGE) where -STRING-OR-WIDTH is a string value or a space width, and IMAGE a list -of image specifications. -If IMAGE is non-nil, try to use that image, else use STRING-OR-WIDTH. -The value (\"\"), or (0) hide separators.") - -(defvar tabbar-separator-value nil - "Value of the separator used between tabs.") - -(defcustom tabbar-separator (list 0.2) - "Separator used between tabs. -The variable `tabbar-separator-widget' gives details on this widget." - :group 'tabbar - :type tabbar-separator-widget - :set '(lambda (variable value) - (custom-set-default variable value) - ;; Schedule refresh of separator value. - (setq tabbar-separator-value nil))) - -;;; Images -;; -(defcustom tabbar-use-images t - "*Non-nil means to try to use images in tab bar. -That is for buttons and separators." - :group 'tabbar - :type 'boolean - :set '(lambda (variable value) - (custom-set-default variable value) - ;; Schedule refresh of all buttons and separator values. - (setq tabbar-separator-value nil - tabbar-home-button-value nil - tabbar-scroll-left-button-value nil - tabbar-scroll-right-button-value nil))) - -(defsubst tabbar-find-image (specs) - "Find an image, choosing one of a list of image specifications. -SPECS is a list of image specifications. See also `find-image'." - (when (and tabbar-use-images (display-images-p)) - (condition-case nil - (find-image specs) - (error nil)))) - -(defsubst tabbar-disable-image (image) - "From IMAGE, return a new image which looks disabled." - (setq image (copy-sequence image)) - (setcdr image (plist-put (cdr image) :conversion 'disabled)) - image) - -(defsubst tabbar-normalize-image (image &optional margin) - "Make IMAGE centered and transparent. -If optional MARGIN is non-nil, it must be a number of pixels to add as -an extra margin around the image." - (let ((plist (cdr image))) - (or (plist-get plist :ascent) - (setq plist (plist-put plist :ascent 'center))) - (or (plist-get plist :mask) - (setq plist (plist-put plist :mask '(heuristic t)))) - (or (not (natnump margin)) - (plist-get plist :margin) - (plist-put plist :margin margin)) - (setcdr image plist)) - image) - -;;; Button keymaps and callbacks -;; -(defun tabbar-make-mouse-keymap (callback) - "Return a keymap that call CALLBACK on mouse events. -CALLBACK is passed the received mouse event." - (let ((keymap (make-sparse-keymap))) - ;; Pass mouse-1, mouse-2 and mouse-3 events to CALLBACK. - (define-key keymap [header-line down-mouse-1] 'ignore) - (define-key keymap [header-line mouse-1] callback) - (define-key keymap [header-line down-mouse-2] 'ignore) - (define-key keymap [header-line mouse-2] callback) - (define-key keymap [header-line down-mouse-3] 'ignore) - (define-key keymap [header-line mouse-3] callback) - keymap)) - -(defsubst tabbar-make-mouse-event (&optional type) - "Return a mouse click event. -Optional argument TYPE is a mouse-click event or one of the -symbols `mouse-1', `mouse-2' or `mouse-3'. -The default is `mouse-1'." - (if (tabbar-click-p type) - type - (list (or (memq type '(mouse-2 mouse-3)) 'mouse-1) - (or (event-start nil) ;; Emacs 21.4 - (list (selected-window) (point) '(0 . 0) 0))))) - -;;; Buttons -;; -(defconst tabbar-default-button-keymap - (tabbar-make-mouse-keymap 'tabbar-select-button-callback) - "Default keymap of a button.") - -(defun tabbar-help-on-button (window object position) - "Return a help string or nil for none, for the button under the mouse. -WINDOW is the window in which the help was found (unused). -OBJECT is the button label under the mouse. -POSITION is the position in that label. -Call `tabbar-NAME-help-function' where NAME is the button name -associated to OBJECT." - (let* ((name (get-text-property position 'tabbar-button object)) - (funvar (and name - (intern-soft (format "tabbar-%s-help-function" - name))))) - (and (symbol-value funvar) - (funcall (symbol-value funvar))))) - -(defsubst tabbar-click-on-button (name &optional type) - "Handle a mouse click event on button NAME. -Call `tabbar-select-NAME-function' with the received, or simulated -mouse click event. -Optional argument TYPE is a mouse click event type (see the function -`tabbar-make-mouse-event' for details)." - (let ((funvar (intern-soft (format "tabbar-%s-function" name)))) - (when (symbol-value funvar) - (funcall (symbol-value funvar) (tabbar-make-mouse-event type)) - (tabbar-display-update)))) - -(defun tabbar-select-button-callback (event) - "Handle a mouse EVENT on a button. -Pass mouse click events on a button to `tabbar-click-on-button'." - (interactive "@e") - (when (tabbar-click-p event) - (let ((target (posn-string (event-start event)))) - (tabbar-click-on-button - (get-text-property (cdr target) 'tabbar-button (car target)) - event)))) - -(defun tabbar-make-button-keymap (name) - "Return a keymap to handle mouse click events on button NAME." - (if (fboundp 'posn-string) - tabbar-default-button-keymap - (let ((event (make-symbol "event"))) - (tabbar-make-mouse-keymap - `(lambda (,event) - (interactive "@e") - (and (tabbar-click-p ,event) - (tabbar-click-on-button ',name ,event))))))) - -;;; Button callbacks -;; -(defun tabbar-scroll-left (event) - "On mouse EVENT, scroll current tab set on left." - (when (eq (event-basic-type event) 'mouse-1) - (tabbar-scroll (tabbar-current-tabset) -1))) - -(defun tabbar-scroll-left-help () - "Help string shown when mouse is over the scroll left button." - "mouse-1: scroll tabs left.") - -(defun tabbar-scroll-right (event) - "On mouse EVENT, scroll current tab set on right." - (when (eq (event-basic-type event) 'mouse-1) - (tabbar-scroll (tabbar-current-tabset) 1))) - -(defun tabbar-scroll-right-help () - "Help string shown when mouse is over the scroll right button." - "mouse-1: scroll tabs right.") - -;;; Tabs -;; -(defconst tabbar-default-tab-keymap - (tabbar-make-mouse-keymap 'tabbar-select-tab-callback) - "Default keymap of a tab.") - -(defun tabbar-help-on-tab (window object position) - "Return a help string or nil for none, for the tab under the mouse. -WINDOW is the window in which the help was found (unused). -OBJECT is the tab label under the mouse. -POSITION is the position in that label. -Call `tabbar-help-on-tab-function' with the associated tab." - (when tabbar-help-on-tab-function - (let ((tab (get-text-property position 'tabbar-tab object))) - (funcall tabbar-help-on-tab-function tab)))) - -(defsubst tabbar-click-on-tab (tab &optional type) - "Handle a mouse click event on tab TAB. -Call `tabbar-select-tab-function' with the received, or simulated -mouse click event, and TAB. -Optional argument TYPE is a mouse click event type (see the function -`tabbar-make-mouse-event' for details)." - (when tabbar-select-tab-function - (funcall tabbar-select-tab-function - (tabbar-make-mouse-event type) tab) - (tabbar-display-update))) - -(defun tabbar-select-tab-callback (event) - "Handle a mouse EVENT on a tab. -Pass mouse click events on a tab to `tabbar-click-on-tab'." - (interactive "@e") - (when (tabbar-click-p event) - (let ((target (posn-string (event-start event)))) - (tabbar-click-on-tab - (get-text-property (cdr target) 'tabbar-tab (car target)) - event)))) - -(defun tabbar-make-tab-keymap (tab) - "Return a keymap to handle mouse click events on TAB." - (if (fboundp 'posn-string) - tabbar-default-tab-keymap - (let ((event (make-symbol "event"))) - (tabbar-make-mouse-keymap - `(lambda (,event) - (interactive "@e") - (and (tabbar-click-p ,event) - (tabbar-click-on-tab ',tab ,event))))))) - -;;; Tab bar construction -;; -(defun tabbar-button-label (name) - "Return a label for button NAME. -That is a pair (ENABLED . DISABLED), where ENABLED and DISABLED are -respectively the appearance of the button when enabled and disabled. -They are propertized strings which could display images, as specified -by the variable `tabbar-NAME-button'." - (let* ((btn (symbol-value - (intern-soft (format "tabbar-%s-button" name)))) - (on (tabbar-find-image (cdar btn))) - (off (and on (tabbar-find-image (cddr btn))))) - (when on - (tabbar-normalize-image on 1) - (if off - (tabbar-normalize-image off 1) - ;; If there is no disabled button image, derive one from the - ;; button enabled image. - (setq off (tabbar-disable-image on)))) - (cons - (propertize (or (caar btn) " ") 'display on) - (propertize (or (cadr btn) " ") 'display off)))) - -(defun tabbar-line-button (name) - "Return the display representation of button NAME. -That is, a propertized string used as an `header-line-format' template -element." - (let ((label (if tabbar-button-label-function - (funcall tabbar-button-label-function name) - (cons name name)))) - ;; Cache the display value of the enabled/disabled buttons in - ;; variables `tabbar-NAME-button-value'. - (set (intern (format "tabbar-%s-button-value" name)) - (cons - (propertize (car label) - 'tabbar-button name - 'face 'tabbar-button - 'mouse-face 'tabbar-button-highlight - 'pointer 'hand - 'local-map (tabbar-make-button-keymap name) - 'help-echo 'tabbar-help-on-button) - (propertize (cdr label) - 'face 'tabbar-button - 'pointer 'arrow))))) - -(defun tabbar-line-separator () - "Return the display representation of a tab bar separator. -That is, a propertized string used as an `header-line-format' template -element." - (let ((image (tabbar-find-image (cdr tabbar-separator)))) - ;; Cache the separator display value in variable - ;; `tabbar-separator-value'. - (setq tabbar-separator-value - (cond - (image - (propertize " " - 'face 'tabbar-separator - 'pointer 'arrow - 'display (tabbar-normalize-image image))) - ((numberp (car tabbar-separator)) - (propertize " " - 'face 'tabbar-separator - 'pointer 'arrow - 'display (list 'space - :width (car tabbar-separator)))) - ((propertize (or (car tabbar-separator) " ") - 'face 'tabbar-separator - 'pointer 'arrow)))) - )) - -(defsubst tabbar-line-buttons (tabset) - "Return a list of propertized strings for tab bar buttons. -TABSET is the tab set used to choose the appropriate buttons." - (list - (if tabbar-home-function - (car tabbar-home-button-value) - (cdr tabbar-home-button-value)) - (if (> (tabbar-start tabset) 0) - (car tabbar-scroll-left-button-value) - (cdr tabbar-scroll-left-button-value)) - (if (< (tabbar-start tabset) - (1- (length (tabbar-tabs tabset)))) - (car tabbar-scroll-right-button-value) - (cdr tabbar-scroll-right-button-value)) - tabbar-separator-value)) - -(defsubst tabbar-line-tab (tab) - "Return the display representation of tab TAB. -That is, a propertized string used as an `header-line-format' template -element. -Call `tabbar-tab-label-function' to obtain a label for TAB." - (concat (propertize - (if tabbar-tab-label-function - (funcall tabbar-tab-label-function tab) - tab) - 'tabbar-tab tab - 'local-map (tabbar-make-tab-keymap tab) - 'help-echo 'tabbar-help-on-tab - 'mouse-face 'tabbar-highlight - 'face (if (tabbar-selected-p tab (tabbar-current-tabset)) - 'tabbar-selected - 'tabbar-unselected) - 'pointer 'hand) - tabbar-separator-value)) - -(defun tabbar-line-format (tabset) - "Return the `header-line-format' value to display TABSET." - (let* ((sel (tabbar-selected-tab tabset)) - (tabs (tabbar-view tabset)) - (padcolor (tabbar-background-color)) - atsel elts) - ;; Initialize buttons and separator values. - (or tabbar-separator-value - (tabbar-line-separator)) - (or tabbar-home-button-value - (tabbar-line-button 'home)) - (or tabbar-scroll-left-button-value - (tabbar-line-button 'scroll-left)) - (or tabbar-scroll-right-button-value - (tabbar-line-button 'scroll-right)) - ;; Track the selected tab to ensure it is always visible. - (when tabbar--track-selected - (while (not (memq sel tabs)) - (tabbar-scroll tabset -1) - (setq tabs (tabbar-view tabset))) - (while (and tabs (not atsel)) - (setq elts (cons (tabbar-line-tab (car tabs)) elts) - atsel (eq (car tabs) sel) - tabs (cdr tabs))) - (setq elts (nreverse elts)) - ;; At this point the selected tab is the last elt in ELTS. - ;; Scroll TABSET and ELTS until the selected tab becomes - ;; visible. - (with-temp-buffer - (let ((truncate-partial-width-windows nil) - (inhibit-modification-hooks t) - deactivate-mark ;; Prevent deactivation of the mark! - start) - (setq truncate-lines nil - buffer-undo-list t) - (apply 'insert (tabbar-line-buttons tabset)) - (setq start (point)) - (while (and (cdr elts) ;; Always show the selected tab! - (progn - (delete-region start (point-max)) - (goto-char (point-max)) - (apply 'insert elts) - (goto-char (point-min)) - (> (vertical-motion 1) 0))) - (tabbar-scroll tabset 1) - (setq elts (cdr elts))))) - (setq elts (nreverse elts)) - (setq tabbar--track-selected nil)) - ;; Format remaining tabs. - (while tabs - (setq elts (cons (tabbar-line-tab (car tabs)) elts) - tabs (cdr tabs))) - ;; Cache and return the new tab bar. - (tabbar-set-template - tabset - (list (tabbar-line-buttons tabset) - (nreverse elts) - (propertize "%-" - 'face (list :background padcolor - :foreground padcolor) - 'pointer 'arrow))) - )) - -(defun tabbar-line () - "Return the header line templates that represent the tab bar. -Inhibit display of the tab bar in current window if any of the -`tabbar-inhibit-functions' return non-nil." - (cond - ((run-hook-with-args-until-success 'tabbar-inhibit-functions) - ;; Don't show the tab bar. - (setq header-line-format nil)) - ((tabbar-current-tabset t) - ;; When available, use a cached tab bar value, else recompute it. - (or (tabbar-template tabbar-current-tabset) - (tabbar-line-format tabbar-current-tabset))))) - -(defconst tabbar-header-line-format '(:eval (tabbar-line)) - "The tab bar header line format.") - -(defun tabbar-default-inhibit-function () - "Inhibit display of the tab bar in specified windows. -That is dedicated windows, and `checkdoc' status windows." - (or (window-dedicated-p (selected-window)) - (member (buffer-name) - (list " *Checkdoc Status*" - (if (boundp 'ispell-choices-buffer) - ispell-choices-buffer - "*Choices*"))))) - -;;; Cyclic navigation through tabs -;; -(defun tabbar-cycle (&optional backward type) - "Cycle to the next available tab. -The scope of the cyclic navigation through tabs is specified by the -option `tabbar-cycle-scope'. -If optional argument BACKWARD is non-nil, cycle to the previous tab -instead. -Optional argument TYPE is a mouse event type (see the function -`tabbar-make-mouse-event' for details)." - (let* ((tabset (tabbar-current-tabset t)) - (ttabset (tabbar-get-tabsets-tabset)) - ;; If navigation through groups is requested, and there is - ;; only one group, navigate through visible tabs. - (cycle (if (and (eq tabbar-cycle-scope 'groups) - (not (cdr (tabbar-tabs ttabset)))) - 'tabs - tabbar-cycle-scope)) - selected tab) - (when tabset - (setq selected (tabbar-selected-tab tabset)) - (cond - ;; Cycle through visible tabs only. - ((eq cycle 'tabs) - (setq tab (tabbar-tab-next tabset selected backward)) - ;; When there is no tab after/before the selected one, cycle - ;; to the first/last visible tab. - (unless tab - (setq tabset (tabbar-tabs tabset) - tab (car (if backward (last tabset) tabset)))) - ) - ;; Cycle through tab groups only. - ((eq cycle 'groups) - (setq tab (tabbar-tab-next ttabset selected backward)) - ;; When there is no group after/before the selected one, cycle - ;; to the first/last available group. - (unless tab - (setq tabset (tabbar-tabs ttabset) - tab (car (if backward (last tabset) tabset)))) - ) - (t - ;; Cycle through visible tabs then tab groups. - (setq tab (tabbar-tab-next tabset selected backward)) - ;; When there is no visible tab after/before the selected one, - ;; cycle to the next/previous available group. - (unless tab - (setq tab (tabbar-tab-next ttabset selected backward)) - ;; When there is no next/previous group, cycle to the - ;; first/last available group. - (unless tab - (setq tabset (tabbar-tabs ttabset) - tab (car (if backward (last tabset) tabset)))) - ;; Select the first/last visible tab of the new group. - (setq tabset (tabbar-tabs (tabbar-tab-tabset tab)) - tab (car (if backward (last tabset) tabset)))) - )) - (tabbar-click-on-tab tab type)))) - -;;;###autoload -(defun tabbar-backward () - "Select the previous available tab. -Depend on the setting of the option `tabbar-cycle-scope'." - (interactive) - (tabbar-cycle t)) - -;;;###autoload -(defun tabbar-forward () - "Select the next available tab. -Depend on the setting of the option `tabbar-cycle-scope'." - (interactive) - (tabbar-cycle)) - -;;;###autoload -(defun tabbar-backward-group () - "Go to selected tab in the previous available group." - (interactive) - (let ((tabbar-cycle-scope 'groups)) - (tabbar-cycle t))) - -;;;###autoload -(defun tabbar-forward-group () - "Go to selected tab in the next available group." - (interactive) - (let ((tabbar-cycle-scope 'groups)) - (tabbar-cycle))) - -;;;###autoload -(defun tabbar-backward-tab () - "Select the previous visible tab." - (interactive) - (let ((tabbar-cycle-scope 'tabs)) - (tabbar-cycle t))) - -;;;###autoload -(defun tabbar-forward-tab () - "Select the next visible tab." - (interactive) - (let ((tabbar-cycle-scope 'tabs)) - (tabbar-cycle))) - -;;; Button press commands -;; -(defsubst tabbar--mouse (number) - "Return a mouse button symbol from NUMBER. -That is mouse-2, or mouse-3 when NUMBER is respectively 2, or 3. -Return mouse-1 otherwise." - (cond ((eq number 2) 'mouse-2) - ((eq number 3) 'mouse-3) - ('mouse-1))) - -;;;###autoload -(defun tabbar-press-home (&optional arg) - "Press the tab bar home button. -That is, simulate a mouse click on that button. -A numeric prefix ARG value of 2, or 3, respectively simulates a -mouse-2, or mouse-3 click. The default is a mouse-1 click." - (interactive "p") - (tabbar-click-on-button 'home (tabbar--mouse arg))) - -;;;###autoload -(defun tabbar-press-scroll-left (&optional arg) - "Press the tab bar scroll-left button. -That is, simulate a mouse click on that button. -A numeric prefix ARG value of 2, or 3, respectively simulates a -mouse-2, or mouse-3 click. The default is a mouse-1 click." - (interactive "p") - (tabbar-click-on-button 'scroll-left (tabbar--mouse arg))) - -;;;###autoload -(defun tabbar-press-scroll-right (&optional arg) - "Press the tab bar scroll-right button. -That is, simulate a mouse click on that button. -A numeric prefix ARG value of 2, or 3, respectively simulates a -mouse-2, or mouse-3 click. The default is a mouse-1 click." - (interactive "p") - (tabbar-click-on-button 'scroll-right (tabbar--mouse arg))) - -;;; Mouse-wheel support -;; -(require 'mwheel) - -;;; Compatibility -;; -(defconst tabbar--mwheel-up-event - (symbol-value (if (boundp 'mouse-wheel-up-event) - 'mouse-wheel-up-event - 'mouse-wheel-up-button))) - -(defconst tabbar--mwheel-down-event - (symbol-value (if (boundp 'mouse-wheel-down-event) - 'mouse-wheel-down-event - 'mouse-wheel-down-button))) - -(defsubst tabbar--mwheel-key (event-type) - "Return a mouse wheel key symbol from EVENT-TYPE. -When EVENT-TYPE is a symbol return it. -When it is a button number, return symbol `mouse-<EVENT-TYPE>'." - (if (symbolp event-type) - event-type - (intern (format "mouse-%s" event-type)))) - -(defsubst tabbar--mwheel-up-p (event) - "Return non-nil if EVENT is a mouse-wheel up event." - (let ((x (event-basic-type event))) - (if (eq 'mouse-wheel x) - (< (car (cdr (cdr event))) 0) ;; Emacs 21.3 - ;; Emacs > 21.3 - (eq x tabbar--mwheel-up-event)))) - -;;; Basic commands -;; -;;;###autoload -(defun tabbar-mwheel-backward (event) - "Select the previous available tab. -EVENT is the mouse event that triggered this command. -Mouse-enabled equivalent of the command `tabbar-backward'." - (interactive "@e") - (tabbar-cycle t event)) - -;;;###autoload -(defun tabbar-mwheel-forward (event) - "Select the next available tab. -EVENT is the mouse event that triggered this command. -Mouse-enabled equivalent of the command `tabbar-forward'." - (interactive "@e") - (tabbar-cycle nil event)) - -;;;###autoload -(defun tabbar-mwheel-backward-group (event) - "Go to selected tab in the previous available group. -If there is only one group, select the previous visible tab. -EVENT is the mouse event that triggered this command. -Mouse-enabled equivalent of the command `tabbar-backward-group'." - (interactive "@e") - (let ((tabbar-cycle-scope 'groups)) - (tabbar-cycle t event))) - -;;;###autoload -(defun tabbar-mwheel-forward-group (event) - "Go to selected tab in the next available group. -If there is only one group, select the next visible tab. -EVENT is the mouse event that triggered this command. -Mouse-enabled equivalent of the command `tabbar-forward-group'." - (interactive "@e") - (let ((tabbar-cycle-scope 'groups)) - (tabbar-cycle nil event))) - -;;;###autoload -(defun tabbar-mwheel-backward-tab (event) - "Select the previous visible tab. -EVENT is the mouse event that triggered this command. -Mouse-enabled equivalent of the command `tabbar-backward-tab'." - (interactive "@e") - (let ((tabbar-cycle-scope 'tabs)) - (tabbar-cycle t event))) - -;;;###autoload -(defun tabbar-mwheel-forward-tab (event) - "Select the next visible tab. -EVENT is the mouse event that triggered this command. -Mouse-enabled equivalent of the command `tabbar-forward-tab'." - (interactive "@e") - (let ((tabbar-cycle-scope 'tabs)) - (tabbar-cycle nil event))) - -;;; Wrappers when there is only one generic mouse-wheel event -;; -;;;###autoload -(defun tabbar-mwheel-switch-tab (event) - "Select the next or previous tab according to EVENT." - (interactive "@e") - (if (tabbar--mwheel-up-p event) - (tabbar-mwheel-forward-tab event) - (tabbar-mwheel-backward-tab event))) - -;;;###autoload -(defun tabbar-mwheel-switch-group (event) - "Select the next or previous group of tabs according to EVENT." - (interactive "@e") - (if (tabbar--mwheel-up-p event) - (tabbar-mwheel-forward-group event) - (tabbar-mwheel-backward-group event))) - -;;; Minor modes -;; -(defsubst tabbar-mode-on-p () - "Return non-nil if Tabbar mode is on." - (eq (default-value 'header-line-format) - tabbar-header-line-format)) - -;;; Tabbar-Local mode -;; -(defvar tabbar--local-hlf nil) - -;;;###autoload -(define-minor-mode tabbar-local-mode - "Toggle local display of the tab bar. -With prefix argument ARG, turn on if positive, otherwise off. -Returns non-nil if the new state is enabled. -When turned on, if a local header line is shown, it is hidden to show -the tab bar. The tab bar is locally hidden otherwise. When turned -off, if a local header line is hidden or the tab bar is locally -hidden, it is shown again. Signal an error if Tabbar mode is off." - :group 'tabbar - :global nil - (unless (tabbar-mode-on-p) - (error "Tabbar mode must be enabled")) -;;; ON - (if tabbar-local-mode - (if (and (local-variable-p 'header-line-format) - header-line-format) - ;; A local header line exists, hide it to show the tab bar. - (progn - ;; Fail in case of an inconsistency because another local - ;; header line is already hidden. - (when (local-variable-p 'tabbar--local-hlf) - (error "Another local header line is already hidden")) - (set (make-local-variable 'tabbar--local-hlf) - header-line-format) - (kill-local-variable 'header-line-format)) - ;; Otherwise hide the tab bar in this buffer. - (setq header-line-format nil)) -;;; OFF - (if (local-variable-p 'tabbar--local-hlf) - ;; A local header line is hidden, show it again. - (progn - (setq header-line-format tabbar--local-hlf) - (kill-local-variable 'tabbar--local-hlf)) - ;; The tab bar is locally hidden, show it again. - (kill-local-variable 'header-line-format)))) - -;;; Tabbar mode -;; -(defvar tabbar-prefix-key [(control ?c)] - "The common prefix key used in Tabbar mode.") - -(defvar tabbar-prefix-map - (let ((km (make-sparse-keymap))) - (define-key km [(control home)] 'tabbar-press-home) - (define-key km [(control left)] 'tabbar-backward) - (define-key km [(control right)] 'tabbar-forward) - (define-key km [(control up)] 'tabbar-backward-group) - (define-key km [(control down)] 'tabbar-forward-group) - (define-key km [(control prior)] 'tabbar-press-scroll-left) - (define-key km [(control next)] 'tabbar-press-scroll-right) - (define-key km [(control f10)] 'tabbar-local-mode) - km) - "The key bindings provided in Tabbar mode.") - -(defvar tabbar-mode-map - (let ((km (make-sparse-keymap))) - (define-key km tabbar-prefix-key tabbar-prefix-map) - km) - "Keymap to use in Tabbar mode.") - -(defvar tabbar--global-hlf nil) - -;;;###autoload -(define-minor-mode tabbar-mode - "Toggle display of a tab bar in the header line. -With prefix argument ARG, turn on if positive, otherwise off. -Returns non-nil if the new state is enabled. - -\\{tabbar-mode-map}" - :group 'tabbar - :require 'tabbar - :global t - :keymap tabbar-mode-map - (if tabbar-mode -;;; ON - (unless (tabbar-mode-on-p) - ;; Save current default value of `header-line-format'. - (setq tabbar--global-hlf (default-value 'header-line-format)) - (tabbar-init-tabsets-store) - (setq-default header-line-format tabbar-header-line-format)) -;;; OFF - (when (tabbar-mode-on-p) - ;; Turn off Tabbar-Local mode globally. - (mapc #'(lambda (b) - (condition-case nil - (with-current-buffer b - (and tabbar-local-mode - (tabbar-local-mode -1))) - (error nil))) - (buffer-list)) - ;; Restore previous `header-line-format'. - (setq-default header-line-format tabbar--global-hlf) - (tabbar-free-tabsets-store)) - )) - -;;; Tabbar-Mwheel mode -;; -(defvar tabbar-mwheel-mode-map - (let ((km (make-sparse-keymap))) - (if (get 'mouse-wheel 'event-symbol-elements) - ;; Use one generic mouse wheel event - (define-key km [A-mouse-wheel] - 'tabbar-mwheel-switch-group) - ;; Use separate up/down mouse wheel events - (let ((up (tabbar--mwheel-key tabbar--mwheel-up-event)) - (down (tabbar--mwheel-key tabbar--mwheel-down-event))) - (define-key km `[header-line ,down] - 'tabbar-mwheel-backward-group) - (define-key km `[header-line ,up] - 'tabbar-mwheel-forward-group) - (define-key km `[header-line (control ,down)] - 'tabbar-mwheel-backward-tab) - (define-key km `[header-line (control ,up)] - 'tabbar-mwheel-forward-tab) - (define-key km `[header-line (shift ,down)] - 'tabbar-mwheel-backward) - (define-key km `[header-line (shift ,up)] - 'tabbar-mwheel-forward) - )) - km) - "Keymap to use in Tabbar-Mwheel mode.") - -;;;###autoload -(define-minor-mode tabbar-mwheel-mode - "Toggle use of the mouse wheel to navigate through tabs or groups. -With prefix argument ARG, turn on if positive, otherwise off. -Returns non-nil if the new state is enabled. - -\\{tabbar-mwheel-mode-map}" - :group 'tabbar - :require 'tabbar - :global t - :keymap tabbar-mwheel-mode-map - (when tabbar-mwheel-mode - (unless (and mouse-wheel-mode tabbar-mode) - (tabbar-mwheel-mode -1)))) - -(defun tabbar-mwheel-follow () - "Toggle Tabbar-Mwheel following Tabbar and Mouse-Wheel modes." - (tabbar-mwheel-mode (if (and mouse-wheel-mode tabbar-mode) 1 -1))) - -(add-hook 'tabbar-mode-hook 'tabbar-mwheel-follow) -(add-hook 'mouse-wheel-mode-hook 'tabbar-mwheel-follow) - -;;; Buffer tabs -;; -(defgroup tabbar-buffer nil - "Display buffers in the tab bar." - :group 'tabbar) - -(defcustom tabbar-buffer-home-button - (cons (cons "[+]" tabbar-home-button-enabled-image) - (cons "[-]" tabbar-home-button-disabled-image)) - "The home button displayed when showing buffer tabs. -The enabled button value is displayed when showing tabs for groups of -buffers, and the disabled button value is displayed when showing -buffer tabs. -The variable `tabbar-button-widget' gives details on this widget." - :group 'tabbar-buffer - :type tabbar-button-widget - :set '(lambda (variable value) - (custom-set-default variable value) - ;; Schedule refresh of button value. - (setq tabbar-home-button-value nil))) - -(defvar tabbar-buffer-list-function 'tabbar-buffer-list - "Function that returns the list of buffers to show in tabs. -That function is called with no arguments and must return a list of -buffers.") - -(defvar tabbar-buffer-groups-function 'tabbar-buffer-groups - "Function that gives the group names the current buffer belongs to. -It must return a list of group names, or nil if the buffer has no -group. Notice that it is better that a buffer belongs to one group.") - -(defun tabbar-buffer-list () - "Return the list of buffers to show in tabs. -Exclude buffers whose name starts with a space, when they are not -visiting a file. The current buffer is always included." - (delq nil - (mapcar #'(lambda (b) - (cond - ;; Always include the current buffer. - ((eq (current-buffer) b) b) - ((buffer-file-name b) b) - ((char-equal ?\ (aref (buffer-name b) 0)) nil) - ((buffer-live-p b) b))) - (buffer-list)))) - -(defun tabbar-buffer-mode-derived-p (mode parents) - "Return non-nil if MODE derives from a mode in PARENTS." - (let (derived) - (while (and (not derived) mode) - (if (memq mode parents) - (setq derived t) - (setq mode (get mode 'derived-mode-parent)))) - derived)) - -(defun tabbar-buffer-groups () - "Return the list of group names the current buffer belongs to. -Return a list of one element based on major mode." - (list - (cond - ((or (get-buffer-process (current-buffer)) - ;; Check if the major mode derives from `comint-mode' or - ;; `compilation-mode'. - (tabbar-buffer-mode-derived-p - major-mode '(comint-mode compilation-mode))) - "Process" - ) - ((member (buffer-name) - '("*scratch*" "*Messages*")) - "Common" - ) - ((eq major-mode 'dired-mode) - "Dired" - ) - ((memq major-mode - '(help-mode apropos-mode Info-mode Man-mode)) - "Help" - ) - ((memq major-mode - '(rmail-mode - rmail-edit-mode vm-summary-mode vm-mode mail-mode - mh-letter-mode mh-show-mode mh-folder-mode - gnus-summary-mode message-mode gnus-group-mode - gnus-article-mode score-mode gnus-browse-killed-mode)) - "Mail" - ) - (t - ;; Return `mode-name' if not blank, `major-mode' otherwise. - (if (and (stringp mode-name) - ;; Take care of preserving the match-data because this - ;; function is called when updating the header line. - (save-match-data (string-match "[^ ]" mode-name))) - mode-name - (symbol-name major-mode)) - )))) - -;;; Group buffers in tab sets. -;; -(defvar tabbar--buffers nil) - -(defun tabbar-buffer-update-groups () - "Update tab sets from groups of existing buffers. -Return the the first group where the current buffer is." - (let ((bl (sort - (mapcar - #'(lambda (b) - (with-current-buffer b - (list (current-buffer) - (buffer-name) - (if tabbar-buffer-groups-function - (funcall tabbar-buffer-groups-function) - '("Common"))))) - (and tabbar-buffer-list-function - (funcall tabbar-buffer-list-function))) - #'(lambda (e1 e2) - (string-lessp (nth 1 e1) (nth 1 e2)))))) - ;; If the cache has changed, update the tab sets. - (unless (equal bl tabbar--buffers) - ;; Add new buffers, or update changed ones. - (dolist (e bl) - (dolist (g (nth 2 e)) - (let ((tabset (tabbar-get-tabset g))) - (if tabset - (unless (equal e (assq (car e) tabbar--buffers)) - ;; This is a new buffer, or a previously existing - ;; buffer that has been renamed, or moved to another - ;; group. Update the tab set, and the display. - (tabbar-add-tab tabset (car e) t) - (tabbar-set-template tabset nil)) - (tabbar-make-tabset g (car e)))))) - ;; Remove tabs for buffers not found in cache or moved to other - ;; groups, and remove empty tabsets. - (mapc 'tabbar-delete-tabset - (tabbar-map-tabsets - #'(lambda (tabset) - (dolist (tab (tabbar-tabs tabset)) - (let ((e (assq (tabbar-tab-value tab) bl))) - (or (and e (memq tabset - (mapcar 'tabbar-get-tabset - (nth 2 e)))) - (tabbar-delete-tab tab)))) - ;; Return empty tab sets - (unless (tabbar-tabs tabset) - tabset)))) - ;; The new cache becomes the current one. - (setq tabbar--buffers bl))) - ;; Return the first group the current buffer belongs to. - (car (nth 2 (assq (current-buffer) tabbar--buffers)))) - -;;; Tab bar callbacks -;; -(defvar tabbar--buffer-show-groups nil) - -(defsubst tabbar-buffer-show-groups (flag) - "Set display of tabs for groups of buffers to FLAG." - (setq tabbar--buffer-show-groups flag - ;; Redisplay the home button. - tabbar-home-button-value nil)) - -(defun tabbar-buffer-tabs () - "Return the buffers to display on the tab bar, in a tab set." - (let ((tabset (tabbar-get-tabset (tabbar-buffer-update-groups)))) - (tabbar-select-tab-value (current-buffer) tabset) - (when tabbar--buffer-show-groups - (setq tabset (tabbar-get-tabsets-tabset)) - (tabbar-select-tab-value (current-buffer) tabset)) - tabset)) - -(defun tabbar-buffer-button-label (name) - "Return a label for button NAME. -That is a pair (ENABLED . DISABLED), where ENABLED and DISABLED are -respectively the appearance of the button when enabled and disabled. -They are propertized strings which could display images, as specified -by the variable `tabbar-button-label'. -When NAME is 'home, return a different ENABLED button if showing tabs -or groups. Call the function `tabbar-button-label' otherwise." - (let ((lab (tabbar-button-label name))) - (when (eq name 'home) - (let* ((btn tabbar-buffer-home-button) - (on (tabbar-find-image (cdar btn))) - (off (tabbar-find-image (cddr btn)))) - ;; When `tabbar-buffer-home-button' does not provide a value, - ;; default to the enabled value of `tabbar-home-button'. - (if on - (tabbar-normalize-image on 1) - (setq on (get-text-property 0 'display (car lab)))) - (if off - (tabbar-normalize-image off 1) - (setq off (get-text-property 0 'display (car lab)))) - (setcar lab - (if tabbar--buffer-show-groups - (propertize (or (caar btn) (car lab)) 'display on) - (propertize (or (cadr btn) (car lab)) 'display off))) - )) - lab)) - -(defun tabbar-buffer-tab-label (tab) - "Return a label for TAB. -That is, a string used to represent it on the tab bar." - (let ((label (if tabbar--buffer-show-groups - (format "[%s]" (tabbar-tab-tabset tab)) - (format "%s" (tabbar-tab-value tab))))) - ;; Unless the tab bar auto scrolls to keep the selected tab - ;; visible, shorten the tab label to keep as many tabs as possible - ;; in the visible area of the tab bar. - (if tabbar-auto-scroll-flag - label - (tabbar-shorten - label (max 1 (/ (window-width) - (length (tabbar-view - (tabbar-current-tabset))))))))) - -(defun tabbar-buffer-help-on-tab (tab) - "Return the help string shown when mouse is onto TAB." - (if tabbar--buffer-show-groups - (let* ((tabset (tabbar-tab-tabset tab)) - (tab (tabbar-selected-tab tabset))) - (format "mouse-1: switch to buffer %S in group [%s]" - (buffer-name (tabbar-tab-value tab)) tabset)) - (format "mouse-1: switch to buffer %S\n\ -mouse-2: pop to buffer, mouse-3: delete other windows" - (buffer-name (tabbar-tab-value tab))) - )) - -(defun tabbar-buffer-select-tab (event tab) - "On mouse EVENT, select TAB." - (let ((mouse-button (event-basic-type event)) - (buffer (tabbar-tab-value tab))) - (cond - ((eq mouse-button 'mouse-2) - (pop-to-buffer buffer t)) - ((eq mouse-button 'mouse-3) - (delete-other-windows)) - (t - (switch-to-buffer buffer))) - ;; Don't show groups. - (tabbar-buffer-show-groups nil) - )) - -(defun tabbar-buffer-click-on-home (event) - "Handle a mouse click EVENT on the tab bar home button. -mouse-1, toggle the display of tabs for groups of buffers. -mouse-3, close the current buffer." - (let ((mouse-button (event-basic-type event))) - (cond - ((eq mouse-button 'mouse-1) - (tabbar-buffer-show-groups (not tabbar--buffer-show-groups))) - ((eq mouse-button 'mouse-3) - (kill-buffer nil)) - ))) - -(defun tabbar-buffer-help-on-home () - "Return the help string shown when mouse is onto the toggle button." - (concat - (if tabbar--buffer-show-groups - "mouse-1: show buffers in selected group" - "mouse-1: show groups of buffers") - ", mouse-3: close current buffer")) - -(defun tabbar-buffer-track-killed () - "Hook run just before actually killing a buffer. -In Tabbar mode, try to switch to a buffer in the current tab bar, -after the current buffer has been killed. Try first the buffer in tab -after the current one, then the buffer in tab before. On success, put -the sibling buffer in front of the buffer list, so it will be selected -first." - (and (eq header-line-format tabbar-header-line-format) - (eq tabbar-current-tabset-function 'tabbar-buffer-tabs) - (eq (current-buffer) (window-buffer (selected-window))) - (let ((bl (tabbar-tab-values (tabbar-current-tabset))) - (b (current-buffer)) - found sibling) - (while (and bl (not found)) - (if (eq b (car bl)) - (setq found t) - (setq sibling (car bl))) - (setq bl (cdr bl))) - (when (and (setq sibling (or (car bl) sibling)) - (buffer-live-p sibling)) - ;; Move sibling buffer in front of the buffer list. - (save-current-buffer - (switch-to-buffer sibling)))))) - -;;; Tab bar buffer setup -;; -(defun tabbar-buffer-init () - "Initialize tab bar buffer data. -Run as `tabbar-init-hook'." - (setq tabbar--buffers nil - tabbar--buffer-show-groups nil - tabbar-current-tabset-function 'tabbar-buffer-tabs - tabbar-tab-label-function 'tabbar-buffer-tab-label - tabbar-select-tab-function 'tabbar-buffer-select-tab - tabbar-help-on-tab-function 'tabbar-buffer-help-on-tab - tabbar-button-label-function 'tabbar-buffer-button-label - tabbar-home-function 'tabbar-buffer-click-on-home - tabbar-home-help-function 'tabbar-buffer-help-on-home - ) - (add-hook 'kill-buffer-hook 'tabbar-buffer-track-killed)) - -(defun tabbar-buffer-quit () - "Quit tab bar buffer. -Run as `tabbar-quit-hook'." - (setq tabbar--buffers nil - tabbar--buffer-show-groups nil - tabbar-current-tabset-function nil - tabbar-tab-label-function nil - tabbar-select-tab-function nil - tabbar-help-on-tab-function nil - tabbar-button-label-function nil - tabbar-home-function nil - tabbar-home-help-function nil - ) - (remove-hook 'kill-buffer-hook 'tabbar-buffer-track-killed)) - -(add-hook 'tabbar-init-hook 'tabbar-buffer-init) -(add-hook 'tabbar-quit-hook 'tabbar-buffer-quit) - -(provide 'tabbar) - -(run-hooks 'tabbar-load-hook) - -;;; tabbar.el ends here diff --git a/elisp/emacs-goodies-el/tail.el b/elisp/emacs-goodies-el/tail.el deleted file mode 100755 index b1c1efb..0000000 --- a/elisp/emacs-goodies-el/tail.el +++ /dev/null @@ -1,206 +0,0 @@ -;;; tail.el --- Tail files within Emacs - -;; Copyright (C) 1989, 1990, 1994, 1998 Free Software Foundation, Inc. -;; (For appt.el code) -;; Copyright (C) 2000 Benjamin Drieu - -;; Author: Benjamin Drieu <bdrieu@april.org> -;; Keywords: tools - -;; This file is NOT part of GNU Emacs. - -;; This program as GNU Emacs are free software; you can redistribute -;; them and/or modify them 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. - -;; They are distributed in the hope that they 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 them; see the file COPYING. If not, write to the Free -;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -;; 02111-1307, USA. - -;; $Id: tail.el,v 1.4 2010-07-28 15:50:01 psg Exp $ - -;;; Commentary: - -;; This program displays ``tailed'' contents of files inside transients -;; windows of Emacs. It is primarily meant to keep an eye on logs within -;; Emacs instead of using additional terminals. - -;; Historical URL for tail.el is -;; http://inferno.cs.univ-paris8.fr/~drieu/emacs/ -;; Active developement URL is -;; http://cvs.alioth.debian.org/cgi-bin/cvsweb.cgi/emacs-goodies-el/elisp/emacs-goodies-el/?cvsroot=pkg-goodies-el - -;;; History: -;; -;; 2003-10-09 Peter S Galbraith <psg@debian.org> -;; - minor checkdoc-suggested changes. -;; - tail-hide-window: Bug fix. Would kill all but one window when more than -;; one window was visible prior to the tail window being displayed. -;; copied code from appt.el appt-delete-window. -;; - Fix boolean defcustoms. -;; - Make it work on XEmacs (only briefly tested). -;; -;; 2010-06-05 Kevin Ryde <user42@zip.com.au> -;; - timer object in a per-buffer variable for new output (Closes: #584598). - -;;; Code: - -;; Custom variables (may be set by the user) - -(defgroup tail nil - "Tail files or commands into Emacs buffers." - :prefix "tail-" - :group 'environment) - -(defcustom tail-volatile t - "Whether to erase previous output." - :type 'boolean - :group 'tail) - -(defcustom tail-audible nil - "Whether to produce a bell when some output is displayed." - :type 'boolean - :group 'tail) - -(defcustom tail-raise nil - "Whether to raise current frame when displaying (could be *very* annoying)." - :type 'boolean - :group 'tail) - -(defcustom tail-hide-delay 5 - "Time in seconds before a tail window is deleted." - :type 'integer - :group 'tail) - -(defcustom tail-max-size 5 - "Maximum size of the window." - :type 'integer - :group 'tail) - - -;; Functions - -(defvar tail-timer nil) -(make-variable-buffer-local 'tail-timer) - -;; Taken from calendar/appt.el -(defun tail-disp-window (tail-buffer tail-msg) - "Display some content specified by TAIL-MSG inside buffer TAIL-BUFFER. -Create this buffer if necessary and put it inside a newly created window on -the lowest side of the frame." - - (require 'electric) - - ;; Make sure we're not in the minibuffer - ;; before splitting the window. - - (if (equal (selected-window) (minibuffer-window)) - (if (other-window 1) - (select-window (other-window 1)) - (if window-system - (select-frame (other-frame 1))))) - - (let* ((this-buffer (current-buffer)) - (this-window (selected-window)) - (tail-disp-buf (set-buffer (get-buffer-create tail-buffer)))) - - (if (cdr (assq 'unsplittable (frame-parameters))) - ;; In an unsplittable frame, use something somewhere else. - (display-buffer tail-disp-buf) - (unless (or (and (fboundp 'special-display-p) - (special-display-p (buffer-name tail-disp-buf))) - (and (fboundp 'same-window-p) - (same-window-p (buffer-name tail-disp-buf))) - (get-buffer-window tail-buffer)) - ;; By default, split the bottom window and use the lower part. - (tail-select-lowest-window) - (split-window)) - (pop-to-buffer tail-disp-buf)) - - (toggle-read-only 0) - (if tail-volatile - (erase-buffer)) - (insert-string tail-msg) - (toggle-read-only 1) - (shrink-window-if-larger-than-buffer (get-buffer-window tail-disp-buf t)) - (if (> (window-height (get-buffer-window tail-disp-buf t)) tail-max-size) - (shrink-window (- (window-height (get-buffer-window tail-disp-buf t)) tail-max-size))) - (set-buffer-modified-p nil) - (if tail-raise - (raise-frame (selected-frame))) - (select-window this-window) - (if tail-audible - (beep 1)) - (when tail-hide-delay - (if tail-timer - (cancel-timer tail-timer)) - (setq tail-timer (run-with-timer tail-hide-delay nil - 'tail-hide-window tail-buffer))))) - -(defun tail-hide-window (buffer) - (with-current-buffer buffer - (kill-local-variable 'tail-timer)) ;; the now expired timer object - (let ((window (get-buffer-window buffer t))) - (and window - (or (eq window (frame-root-window (window-frame window))) - (delete-window window))))) - -(defun tail-select-lowest-window () - "Select the lowest window on the frame." - (if (fboundp 'frame-lowest-window) - (select-window (frame-lowest-window)) - (let* ((lowest-window (selected-window)) - (bottom-edge (car (cdr (cdr (cdr (window-edges)))))) - (last-window (previous-window)) - (window-search t)) - (while window-search - (let* ((this-window (next-window)) - (next-bottom-edge (cadr (cddr (window-edges this-window))))) - (when (< bottom-edge next-bottom-edge) - (setq bottom-edge next-bottom-edge) - (setq lowest-window this-window)) - (select-window this-window) - (when (eq last-window this-window) - (select-window lowest-window) - (setq window-search nil))))))) - -;;;###autoload -(defun tail-file (file) - "Tails FILE specified with argument FILE inside a new buffer. -FILE *cannot* be a remote file specified with ange-ftp syntax because it is -passed to the Unix tail command." - (interactive "Ftail file: ") - ;; TODO: what if file is remote (i.e. via ange-ftp) - (tail-command "tail" "-f" file)) - -;;;###autoload -(defun tail-command (command &rest args) - "Tails COMMAND with arguments ARGS inside a new buffer. -It is also called by `tail-file'" - (interactive "sTail command: \neToto: ") - (let ((process - (apply 'start-process-shell-command - command - (concat "*Tail: " - command - (if args " " "") - (mapconcat 'identity args " ") - "*") - command - args))) - (set-process-filter process 'tail-filter))) - -(defun tail-filter (process line) - "Tail filter called when some output comes." - (tail-disp-window (process-buffer process) line)) - -(provide 'tail) - -;;; tail.el ends here diff --git a/elisp/emacs-goodies-el/tc.el b/elisp/emacs-goodies-el/tc.el index cbb6201..cbb6201 100755..100644 --- a/elisp/emacs-goodies-el/tc.el +++ b/elisp/emacs-goodies-el/tc.el diff --git a/elisp/emacs-goodies-el/thinks.el b/elisp/emacs-goodies-el/thinks.el deleted file mode 100755 index 004f100..0000000 --- a/elisp/emacs-goodies-el/thinks.el +++ /dev/null @@ -1,271 +0,0 @@ -;;; thinks.el --- Insert text in a think bubble. -;; Copyright 2000-2008 by Dave Pearson <davep@davep.org> -;; $Revision: 1.2 $ - -;; thinks.el is free software distributed under the terms of the GNU General -;; Public Licence, version 2 or (at your option) any later version. For -;; details see the file COPYING. - -;;; Commentary: - -;; thinks.el is a little bit of silliness inspired by the think bubbles you -;; see in cartoons. It allows you to -;; -;; . o O ( insert text that looks like this ) -;; -;; into a buffer. This could possibly be handy for use in email and usenet -;; postings. -;; -;; Note that the code can handle multiple lines -;; -;; . o O ( like this. That is, a body of text where the number of characters ) -;; ( exceeds the bounds of what you might consider to be a acceptable ) -;; ( line length (he says, waffling on to fill a couple of lines). ) -;; -;; You can also control how the bubble looks with `thinks-from'. The above -;; had it set to `top'. You can have `middle': -;; -;; ( like this. That is, a body of text where the number of characters ) -;; . o O ( exceeds the bounds of what you might consider to be a acceptable ) -;; ( line length (he says, waffling on to fill a couple of lines). ) -;; -;; `bottom': -;; -;; ( like this. That is, a body of text where the number of characters ) -;; ( exceeds the bounds of what you might consider to be a acceptable ) -;; . o O ( line length (he says, waffling on to fill a couple of lines). ) -;; -;; and `bottom-diagonal': -;; -;; ( like this. That is, a body of text where the number of characters ) -;; ( exceeds the bounds of what you might consider to be a acceptable ) -;; ( line length (he says, waffling on to fill a couple of lines). ) -;; O -;; o -;; . -;; -;; By default all of the thinking functions will fill (word wrap) the text -;; taking into account the value of `fill-column' minus the space required -;; for the bubble. Prefix a call to any of the functions with C-u to turn -;; off this behaviour. -;; -;; The latest thinks.el is always available from: -;; -;; <URL:http://www.davep.org/emacs/#thinks.el> - -;;; Thanks: - -;; Special thanks go to Gareth Owen for being barmy enough to be (as far as -;; we know) the first person to post to Usenet using thinks.el. If not the -;; first posting to Usenet at least the first posting to gnu.emacs.soruces. -;; -;; Thanks also go to Gareth for inspiring the extra-silliness option. -;; -;; Thanks to Jason Rumney for suggesting the diagonal option. -;; -;; Thanks to Martin Blais for `thinks-maybe-region'. - -;;; Code: - -;; Things we need: - -(eval-when-compile - (require 'cl)) - -;; Attempt to handle older/other emacs. - -(eval-and-compile - - ;; If customize isn't available just use defvar instead. - (unless (fboundp 'defgroup) - (defmacro defgroup (&rest rest) nil) - (defmacro defcustom (symbol init docstring &rest rest) - `(defvar ,symbol ,init ,docstring))) - - ;; If `line-beginning-position' isn't available provide one. - (unless (fboundp 'line-beginning-position) - (defun line-beginning-position (&optional n) - "Return the `point' of the beginning of the current line." - (save-excursion - (beginning-of-line n) - (point)))) - - ;; If `line-end-position' isn't available provide one. - (unless (fboundp 'line-end-position) - (defun line-end-position (&optional n) - "Return the `point' of the end of the current line." - (save-excursion - (end-of-line n) - (point))))) - -;; Customize options. - -(defgroup thinks nil - "Insert text in a think bubble." - :group 'editing - :prefix "thinks-") - -(defcustom thinks-bubbles ". o O " - "*The lead-in think bubbles. - -Note that parts of the code assume that the string with always have even -length and that every second character is a space. If you want to modify -this string it is best that you stick to this format." - :type 'string - :group 'thinks) - -(defcustom thinks-main-bubble-left "( " - "*The characters to use for the left hand side of the main bubble." - :type 'string - :group 'thinks) - -(defcustom thinks-main-bubble-right " )" - "*The characters to use for the right hand side of the main bubble." - :type 'string - :group 'thinks) - -(defcustom thinks-from 'top - "*Do we think from the TOP or the BOTTOM?" - :type '(choice - (const :tag "Think from the top of the bubble" top) - (const :tag "Think from the middle of the bubble" middle) - (const :tag "Think from the bottom of the bubble" bottom) - (const :tag "Think diagonally from the bottom of the bubble" bottom-diagonal)) - :group 'thinks) - -(defcustom thinks-extra-silliness nil - "*Do we want some extra silliness? - -Note that the extra silliness only kicks in when `thinks-from' is set to -`bottom' or `bottom-diagonal'." - :type '(choice - (const :tag "Yes, let's get really silly" t) - (const :tag "No, I actually have a serious use for this" nil)) - :group 'thinks) - -;; Support code for working in different flavours of emacs. - -(defun thinks-xemacs-p () - "Are we running in XEmacs?" - (and (boundp 'running-xemacs) (symbol-value 'running-xemacs))) - -(defun thinks-mark-active-p () - "Is there a mark active?" - (if (thinks-xemacs-p) - (funcall (symbol-function 'region-active-p)) - (symbol-value 'mark-active))) - -;; Main code: - -(defun thinks-bubble-wrap (text &optional no-filling) - "Bubble wrap TEXT, don't fill if NO-FILLING is non-nil." - (with-temp-buffer - (let* ((extra-silly (and thinks-extra-silliness (or (eq thinks-from 'bottom) - (eq thinks-from 'bottom-diagonal)))) - (thinks-bubbles (concat (if extra-silly " " "") thinks-bubbles))) - (insert text) - (unless no-filling - (let ((fill-column (- fill-column (+ (length thinks-bubbles) - (length thinks-main-bubble-left) - (length thinks-main-bubble-right))))) - (fill-region (point-min) (point-max)))) - (setf (point) (point-min)) - (let ((max-line-width 0)) - (save-excursion - (while (not (eobp)) - (setq max-line-width (max max-line-width (- (line-end-position) (point)))) - (forward-line))) - (let ((current-line 1) - (total-lines (count-lines (point-min) (point-max))) - (filler (make-string (length thinks-bubbles) 32))) - (while (not (eobp)) - (insert (cond ((and (eq thinks-from 'top) - (= current-line 1)) - thinks-bubbles) - ((and (eq thinks-from 'bottom) - (= current-line total-lines)) - thinks-bubbles) - ((and (eq thinks-from 'middle) - (= current-line (truncate (/ (1+ total-lines) 2)))) - thinks-bubbles) - (t - filler)) - thinks-main-bubble-left) - (save-excursion - (end-of-line) - (insert (make-string (- max-line-width - (- (- (point) (line-beginning-position)) - (+ (length thinks-bubbles) - (length thinks-main-bubble-left)))) - 32)) - (insert thinks-main-bubble-right)) - (incf current-line) - (forward-line)))) - (when (eq thinks-from 'bottom-diagonal) - (unless (bolp) - (insert "\n")) - (loop for n downfrom (- (length thinks-bubbles) 2) to (if extra-silly 2 0) by 2 - do (insert (make-string n 32) - (substring thinks-bubbles n (1+ n)) - "\n"))) - (when extra-silly - (setf (point) (point-max)) - (unless (bolp) - (insert "\n")) - (insert " o\n/|\\\n |\n/ \\\n")) - (buffer-string)))) - -;;;###autoload -(defun thinks (text) - "Insert TEXT wrapped in a think bubble. - -Prefix a call to this function with \\[universal-argument] if you don't want -the text to be filled for you." - (interactive "sThinks: ") - (unless (bolp) - (insert "\n")) - (insert (thinks-bubble-wrap text current-prefix-arg)) - (insert "\n")) - -;;;###autoload -(defun thinks-region (start end) - "Bubble wrap region bounding START and END. - -Prefix a call to this function with \\[universal-argument] if you don't want -the text to be filled for you." - (interactive "r") - (let ((text (buffer-substring start end))) - (save-excursion - (delete-region start end) - (setf (point) start) - (insert (flet ((bolp-string (n) - (save-excursion - (setf (point) n) - (if (bolp) "" "\n")))) - (concat (bolp-string start) - (thinks-bubble-wrap text current-prefix-arg) - (bolp-string end))))))) - -;;;###autoload -(defun thinks-yank () - "Do a `yank' and bubble wrap the yanked text. - -Prefix a call to this function with \\[universal-argument] if you don't want -the text to be filled for you." - (interactive) - (thinks (with-temp-buffer - (yank) - (buffer-string)))) - -;;;###autoload -(defun thinks-maybe-region () - "If region is active, bubble wrap region bounding START and END. -If not, query for text to insert in bubble." - (interactive) - (if (thinks-mark-active-p) - (call-interactively #'thinks-region) - (call-interactively #'thinks))) - -(provide 'thinks) - -;;; thinks.el ends here. diff --git a/elisp/emacs-goodies-el/tlc.el b/elisp/emacs-goodies-el/tlc.el index a362c77..a362c77 100755..100644 --- a/elisp/emacs-goodies-el/tlc.el +++ b/elisp/emacs-goodies-el/tlc.el diff --git a/elisp/emacs-goodies-el/tld.el b/elisp/emacs-goodies-el/tld.el index 5f2ef0d..5f2ef0d 100755..100644 --- a/elisp/emacs-goodies-el/tld.el +++ b/elisp/emacs-goodies-el/tld.el diff --git a/elisp/emacs-goodies-el/todoo.el b/elisp/emacs-goodies-el/todoo.el index b074763..b074763 100755..100644 --- a/elisp/emacs-goodies-el/todoo.el +++ b/elisp/emacs-goodies-el/todoo.el diff --git a/elisp/emacs-goodies-el/toggle-option.el b/elisp/emacs-goodies-el/toggle-option.el index d0958ba..d0958ba 100755..100644 --- a/elisp/emacs-goodies-el/toggle-option.el +++ b/elisp/emacs-goodies-el/toggle-option.el diff --git a/elisp/emacs-goodies-el/twiddle.el b/elisp/emacs-goodies-el/twiddle.el index bf80d3f..bf80d3f 100755..100644 --- a/elisp/emacs-goodies-el/twiddle.el +++ b/elisp/emacs-goodies-el/twiddle.el diff --git a/elisp/emacs-goodies-el/under.el b/elisp/emacs-goodies-el/under.el index 79a2967..79a2967 100755..100644 --- a/elisp/emacs-goodies-el/under.el +++ b/elisp/emacs-goodies-el/under.el diff --git a/elisp/emacs-goodies-el/upstart-mode.el b/elisp/emacs-goodies-el/upstart-mode.el deleted file mode 100755 index d7a0384..0000000 --- a/elisp/emacs-goodies-el/upstart-mode.el +++ /dev/null @@ -1,83 +0,0 @@ -;;; upstart-mode.el --- Syntax highlighting for upstart -;;; -;;; Copyright © 2010 Stig Sandbeck Mathisen <ssm@debian.org> - -;;; This program 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 of the -;;; License, or (at your option) any later version. -;;; -;;; This program 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 this program; if not, write to the Free Software -;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA -;;; 02110-1301, USA. - -;;; Commentary: -;; - -;;; Required: Copy this file to your load path, and add the following -;;; statement to your Emacs init file (typically ~/.emacs) -;; -;; (require 'upstart-mode) - -;;; Optional: Add MMM-mode for highlighting the embedded shell scripts -;;; inside the script blocks (Note: indentation does not work inside -;;; the mmm blocks. Any assistance would be welcome. -;; -;; (require 'mmm-auto) -;; (setq mmm-global-mode 'maybe) -;; (mmm-add-classes -;; '((upstart-sh -;; :submode sh-mode -;; :face mmm-submode-decoration-level "code" -;; :front "^\\(\\(pre\\|post\\)-\\(start\\|stop\\) \\)?script" -;; :front-offset (end-of-line 1) -;; :back "end script" -;; :end-not-begin t))) -;; (mmm-add-mode-ext-class 'upstart-mode nil 'upstart-sh) - - -;;; History: -;; -;; This file is published on github. To see a list of changes, see -;; http://github.com/ssm/elisp/blob/master/upstart-mode.el - -;;; Code: - -;; Add a major mode called "upstart mode", based on generic-mode -(define-generic-mode 'upstart-mode - '("#") ; comments - '(;; Event definition - "start on" "stop on" "and" "or" - ;; Job environment - "env" "export" - ;; Services tasks and respawning - "task" "respawn" "respawn limit" "normal exit" - ;; Instances - "instance" - ;; Process environment - "console output" "console owner" "umask" "nice" "oom" "chroot" - "chdir" "limit" - ;; Documentation - "description" "author" "version" "emits" - ;; Miscellaneous - "kill timeout" "expect stop" "expect daemon" "expect fork" - ;; Process definitions - "exec" "script" "end script" - "pre-start exec" "pre-start script" - "post-start exec" "post-start script" - "pre-stop exec" "pre-stop script" - "post-stop exec" "post-stop script") - nil - '("\\.upstart$") - nil - "A mode for upstart files") - -(provide 'upstart-mode) - -;;; upstart-mode.el ends here diff --git a/elisp/emacs-goodies-el/xrdb-mode.el b/elisp/emacs-goodies-el/xrdb-mode.el index 002117a..002117a 100755..100644 --- a/elisp/emacs-goodies-el/xrdb-mode.el +++ b/elisp/emacs-goodies-el/xrdb-mode.el |