# HG changeset patch # User Dave Love # Date 978636096 0 # Node ID 5c3a343fb1ce72d74260487153aac2c726ede5a4 # Parent 3168ff2c349bfb93e109b694ad055b2c0570fcf4 Obsolete. diff -r 3168ff2c349b -r 5c3a343fb1ce lisp/hilit19.el --- a/lisp/hilit19.el Thu Jan 04 19:17:21 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1515 +0,0 @@ -;;; hilit19.el --- customizable highlighting for Emacs19 - -;; Copyright (c) 1993, 1994 Free Software Foundation, Inc. - -;; Author: Jonathan Stigelman -;; Maintainer: FSF -;; (actually no longer maintained) -;; Keywords: faces - -;; This file is part of GNU Emacs. - -;; GNU Emacs 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. - -;; 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 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: - -;; Hilit19.el is a customizable highlighting package for Emacs19. It supports -;; not only source code highlighting, but also Info, RMAIL, VM, gnus... -;; Hilit19 knows (or thinks it knows) how to highlight emacs buffers in -;; about 25 different modes. -;; -;; WHERE TO GET THE LATEST VERSIONS OF HILIT19.EL (beta and release): -;; -;; http://hackvan.com/pub/stig/src/elisp/ -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; TO SUBMIT BUG REPORTS (or feedback of any sort)... -;; -;; M-x hilit-submit-feedback RET -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; hilit19.el,v 2.19 1993/09/08 18:44:10 stig Release -;; -;; LCD Archive Entry: -;; hilit19|Jonathan Stigelman|stig@hackvan.com| -;; Comprehensive (and comparatively fast) regex-based highlighting for Emacs 19| -;; 1993/09/08 18:44:10|Release 2.19|~/packages/hilit19.el.Z| -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; GENERAL OVERVIEW -;; -;; This package installs numerous hooks to colorfully highlight your -;; source code buffers as well as mail and news buffers. Most -;; programming languages have predefined highlighting patterns. -;; Just load hilit19 and files will be automatically highlighted as -;; they're loaded. -;; -;; Rehighlight a buffer by typing C-S-l (control-shift-lowercase-L). -;; -;; If, when you edit the buffer, the coloring gets messed up, just -;; redraw and the coloring will be adjusted. If automatic highlighting -;; in the current buffer has been turned off, then typing C-u C-S-l will -;; force a rehighlight of the entire buffer. -;; -;; Hilit19 can build faces by examining the names that you give to them -;; For example, green/black-bold-italic-underline would be created as -;; a face with a green foreground, and a black background, using a -;; bold-italic font...with underlining for good measure. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; SETUP -- In your .emacs: -;; -;; -;; (cond (window-system -;; (setq hilit-mode-enable-list '(not text-mode) -;; hilit-background-mode 'light -;; hilit-inhibit-hooks nil -;; hilit-inhibit-rebinding nil) -;; -;; (require 'hilit19) -;; )) -;; -;; If you like font-lock-mode and want to use both packages, then you can -;; disable hilit for the modes in which you want to use font-lock by listing -;; said modes in hilit-mode-enable-list. -;; -;; (hilit-translate type 'RoyalBlue ; enable highlighting in C/C++ -;; string nil) ; disable string highlighting -;; -;; To get 100% of the utility of hilit19, you may also have to apply the -;; patches below for info.el and vm5.33L_19/vm-summary.el -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; SETUP -- Are you using the right font for Emacs? -;; -;; Emacs cannot properly find bold and italic fonts unless you specify a -;; verbose X11 font name. If you specify a font for emacs in your -;; .Xdefaults, it *MUST* be specified using the long form of the font name. -;; Here's a good font menu: -;; -;; (setq -;; x-fixed-font-alist -;; '("Font Menu" -;; ("Misc" -;; ("6x12" "-misc-fixed-medium-r-semicondensed--12-110-75-75-c-60-*-1") -;; ("6x13" "-misc-fixed-medium-r-semicondensed--13-120-75-75-c-60-*-1") -;; ("lucida 13" -;; "-b&h-lucidatypewriter-medium-r-normal-sans-0-0-0-0-m-0-*-1") -;; ("7x13" "-misc-fixed-medium-r-normal--13-120-75-75-c-70-*-1") -;; ("7x14" "-misc-fixed-medium-r-normal--14-130-75-75-c-70-*-1") -;; ("9x15" "-misc-fixed-medium-r-normal--15-140-*-*-c-*-*-1") -;; ("") -;; ("clean 8x8" "-schumacher-clean-medium-r-normal--*-80-*-*-c-*-*-1") -;; ("clean 8x14" "-schumacher-clean-medium-r-normal--*-140-*-*-c-*-*-1") -;; ("clean 8x10" "-schumacher-clean-medium-r-normal--*-100-*-*-c-*-*-1") -;; ("clean 8x16" "-schumacher-clean-medium-r-normal--*-160-*-*-c-*-*-1") -;; ("") -;; ("sony 8x16" "-sony-fixed-medium-r-normal--16-120-100-100-c-80-*-1") -;; ("") -;; ("-- Courier --") -;; ("Courier 10" "-adobe-courier-medium-r-normal--*-100-*-*-m-*-*-1") -;; ("Courier 12" "-adobe-courier-medium-r-normal--*-120-*-*-m-*-*-1") -;; ("Courier 14" "-adobe-courier-medium-r-normal--*-140-*-*-m-*-*-1") -;; ("Courier 18" "-adobe-courier-medium-r-normal--*-180-*-*-m-*-*-1") -;; ("Courier 18-b" "-adobe-courier-bold-r-normal--*-180-*-*-m-*-*-1") -;; ))) -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; KNOWN BUGS/TO DO LIST/HELP WANTED/APPLY WITHIN -;; -;; * unbalanced, unescaped double quote characters can confuse hilit19. -;; This will be fixed someday, so don't bug me about it. -;; -;; * ALTHOUGH HILIT19 IS FASTER THAN FONT-LOCK-MODE... -;; For various reasons, the speed of the package could still stand to be -;; improved. If you care to do a little profiling and make things tighter... -;; -;; * hilit-toggle-highlight is flaky when auto-rehighlight is neither t nor nil. -;; Does anyone actually USE this? I think I might just remove it. -;; -;; PROJECTS THAT YOU CAN TAKE OVER BECAUSE I DON'T MUCH CARE ABOUT THEM... -;; -;; * Moved hilit-wysiwyg-replace here from my version of man.el, this is not -;; a bug. The bug is that I don't have a reverse operation yet...just a -;; stub Wysiwyg-anything really belongs in a package of its own. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Thanks to the following people for their input: -;; ebert@enpc.enpc.fr (Rolf EBERT), ada, LaTeX & bibtex highlights -;; Vivek Khera , gnus hooks + random advice & patches -;; brian@athe.WUstl.EDU (Brian Dunford-Shore), prolog highlights -;; John Ladwig , 1st pass nroff highlights -;; campo@sunthpi3.difi.unipi.it (Massimo Campostrini), fortran highlights -;; jayb@laplace.MATH.ColoState.EDU (Jay Bourland), 1st pass dired -;; Yoshio Turner , modula 2 highlights -;; Fritz Knabe , advice & patches -;; Alon Albert , advice & patches -;; dana@thumper.bellcore.com (Dana A. Chee), working on the multi-frame bug -;; derway@ndc.com (Don Erway), for breaking it... -;; moss_r@summer.chem.su.oz.au (Richard Moss), first pass at add-pattern -;; Olivier Lecarme , Pascal & Icon patterns -;; -;; With suggestions and minor regex patches from numerous others... -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; hilit19.el,v -;; Revision 2.19 1993/09/08 18:44:10 stig -;; installed patch for elusive bug in hilit-rehighlight-region that caused -;; hilit-unhighlight-region to hang in an infinite loop. -;; -;; Revision 2.18 1993/08/27 03:51:00 stig -;; minor mods to lisp-mode and c/c++ mode patterns -;; -;; Revision 2.17 1993/08/25 02:19:17 stig -;; work-around for bug in next-overlay-change that caused dired and jargon-mode -;; to hang in an endless loop. Perhaps other modes were doing this too. -;; -;; Revision 2.16 1993/08/22 19:46:00 stig -;; bug fix for next-overlay-change and accompanying change to -;; hilit-unhighlight-region -;; -;; Revision 2.15 1993/08/20 12:16:22 stig -;; minor change to fortran patterns -;; -;; Revision 2.14 1993/08/17 14:12:10 stig -;; added default face mapping for 'formula' which is needed for new latex -;; patterns. -;; -;; twiddled the calendar-mode patterns a bit. -;; -;; Revision 2.13 1993/08/16 04:33:54 stig -;; hilit-set-mode-patterns was screwing up two part patterns. it doesn't now. -;; -;; Revision 2.12 1993/08/16 00:16:41 stig -;; changed references to default-bold-italic to just bold-italic because the -;; font for that face is maintained by emacs. -;; -;; the pattern matcher now starts its searches from the end of the most -;; recently highlighted region (which is not necessarily the end of the most -;; recently matched regex). -;; -;; multiple errors in pattern matcher now just give an error instead of lots of -;; annoying messages and dings. -;; -;; no longer use vm-summary-mode-hooks. -;; -;; some code moved from hilit-highlight-region to hilit-set-mode-patterns. -;; This will affect you if you pass your patterns directly to -;; hilit-highlight-region....use a pseudo-mode instead. -;; -;; pattern changes to C/C++, latex, texinfo, fortran, nroff, etc. -;; -;; Revision 2.11 1993/08/13 12:12:37 stig -;; removed some crufty commented-out code -;; -;; diverged lisp-mode and emacs-lisp-mode...also added lisp keywords. -;; -;; Revision 2.10 1993/08/13 09:47:06 stig -;; added calendar-mode, icon-mode and pascal-mode patterns -;; -;; commented out hilit-toggle-highlight because I want to phase it out entirely -;; -;; Revision 2.9 1993/08/13 08:44:22 stig -;; added optional case-fold argument to hilit-set-mode-patterns, this case-fold -;; parameter is now stored in hilit-patterns-alist. -;; -;; Revision 2.8 1993/08/12 22:05:03 stig -;; fixed some typos in documentation -;; -;; twiddled some of the color defaults for dark backgrounds -;; -;; always get 'mono color defaults if (not (x-display-color-p)) -;; -;; added hilit-rehighlight-buffer-quietly to dired-after-readin-hook -;; -;; fixed bug in hilit-string-find that mishandled strings of the form: "\\" -;; -;; NEW FUNCTION: hilit-add-mode-pattern... kinda like add-hook for patterns -;; -;; fixed minor pattern bugs for latex-mode and emacs-lisp-mode -;; -;; Revision 2.7 1993/07/30 02:43:01 stig -;; added const to the list of modifiers for C/C++ types -;; -;; Revision 2.6 1993/07/30 00:30:54 stig -;; now permit selection of arbitrary subexpressions for highlighting... -;; fixed keyword patterns for C/C++ using this technique. -;; -;; Revision 2.5 1993/07/28 05:02:56 stig -;; improvements to makefile regular expressions -;; removed about 130 lines just by compacting the big defconst for -;; hilit-face-translation-table into a mapcar and defining a separate table -;; of default faces. -;; -;; Revision 2.4 1993/07/27 14:09:05 stig -;; documented another "known problem" to "head off gripe mail at the pass." -;; -;; Revision 2.3 1993/07/27 02:15:49 stig -;; (hilit-lookup-face-create) incorporated patch which improves its behavior -;; with more than one frame... Still can't have bold on the same face in two -;; different fonts sizes at the same time... -;; -;; Revision 2.2 1993/07/27 02:02:59 stig -;; vastly improved the makefile patterns -;; added hook for mh-show-mode -;; -;; Revision 2.1 1993/07/24 17:46:21 stig -;; Phasing out Info-select-hook... Version 19.18 will use Info-selection-hook. -;; -;; Revision 2.0 1993/07/24 13:50:10 stig -;; better documentation and added the function hilit-submit-feedback. -;; C-S-l (control shift l) repaints the buffer. Other bindings are optional. -;; multi-line highlights no longer cause problems when -;; hilit-auto-rehighlight is 'visible -;; added hilit-predefined-face-list... -;; changed name of hilit-mode-alist to hilit-patterns-alist -;; added hilit-message-quietly to mail-setup-hook -;; added hilit-parser-alist which can be used to apply different patterns to -;; different parts of a buffer. This could be integrated in a far more -;; elegant manner, but it presently serves the purpose of not applying -;; message header patterns to message bodies in mail-mode and its kin. -;; hilit-set-mode-patterns now takes a list of modes and an optional parse-fn -;; - -;;;;;; AND THIS CAN BE APPLIED TO VM 5.33L_19 -;; -;; *** ../site/vm5.33L_19/vm-summary.el Fri Jun 4 22:17:11 1993 -;; --- ./vm-summary.el Tue Jun 22 16:39:30 1993 -;; *************** -;; *** 152,158 **** -;; (insert "->") -;; (delete-char 2) -;; (forward-char -2) -;; ! (and w vm-auto-center-summary (vm-auto-center-summary)))) -;; (and old-window (select-window old-window))))))) -;; -;; (defun vm-mark-for-display-update (message) -;; --- 152,159 ---- -;; (insert "->") -;; (delete-char 2) -;; (forward-char -2) -;; ! (and w vm-auto-center-summary (vm-auto-center-summary)) -;; ! (run-hooks 'vm-summary-pointer-hook))) -;; (and old-window (select-window old-window))))))) -;; -;; (defun vm-mark-for-display-update (message) -;; -;;;;;; - -;;; Code: - -;; User Options: - -(defvar hilit-quietly nil - "* If non-nil, this inhibits progress indicators during highlighting") - -(defvar hilit-auto-highlight t - "* T if we should highlight all buffers as we find 'em, nil to disable - automatic highlighting by the find-file hook.") - -(defvar hilit-auto-highlight-maxout 60000 ; hilit19 keeps getting bigger... - "* auto-highlight is disabled in buffers larger than this") - -(defvar hilit-auto-rehighlight t - "* If this is non-nil, then hilit-redraw and hilit-recenter will also - rehighlight part or all of the current buffer. T will rehighlight the - whole buffer, a NUMBER will rehighlight that many lines before and after - the cursor, and the symbol 'visible' will rehighlight only the visible - portion of the current buffer. This variable is buffer-local.") - -(make-variable-buffer-local 'hilit-auto-rehighlight) - -(defvar hilit-auto-rehighlight-fallback '(20000 . 100) - "* Cons of the form (THRESHOLD . FALLBACK), where FALLBACK is assigned to - hilit-auto-rehighlight if the size of a newly opened buffer is larger than - THRESHOLD.") - -(defvar hilit-face-check t - "* T slows down highlighting but permits the user to change fonts without - losing bold and italic faces... T causes hilit-lookup-face-create to dig - through the frame parameters for the current window every time it's called. - If you never change fonts in emacs, set this to NIL.") - -;; Variables which must be set before loading hilit19. - -(defvar hilit-inhibit-rebinding nil - "If non-nil, this inhibits replacement of recenter, yank, and yank-pop.") - -(defvar hilit-inhibit-hooks nil - "If non-nil, this inhibits installation of hooks for Info, gnus, & vm.") - -(defvar hilit-background-mode 'light - "'mono inhibits color, 'dark or 'light indicate the background brightness.") - -(defvar hilit-mode-enable-list nil - "If a list of modes to exclusively enable or specifically disable. -The sense of the list is negated if it begins with the symbol 'not'. -Set this variable before you load hilit19. - -Ex: (perl-mode jargon-mode c-mode) ; just perl, C, and jargon modes - (not text-mode) ; all modes except text mode") - -;; Variables that are not generally modified directly - -(defvar hilit-parser-alist nil - "alist of major-mode values and parsers called by hilit-rehighlight-buffer. - -Parsers for a given mode are IGNORED for partial rehighlights...maybe you'd -like to make this more universal?") - -(defvar hilit-patterns-alist nil - "alist of major-mode values and default highlighting patterns - -A highlighting pattern is a list of the form (start end face), where -start is a regex, end is either a regex or a match number for start, and face -is the name of an entry in hilit-face-translation-table, the name of a face, -or nil (which disables the pattern). - -Each entry in the alist is of the form: - (mode . (case-fold pattern [pattern ...])) - -See the hilit-lookup-face-create documentation for valid face names.") - -(defvar hilit-predefined-face-list (face-list) - "List of faces with which hilit-lookup-face-create will NOT tamper. - -If hilit19 is dumped into emacs at your site, you may have to set this in -your init file.") - -(eval-when-compile (setq byte-optimize t)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Use this to report bugs: - -(eval-when-compile (require 'reporter)) ; no compilation gripes - -(defun hilit-submit-feedback () - "Submit feedback on hilit19 to hilit@hackvan.com" - (interactive) - (require 'reporter) - (and (y-or-n-p "Do you really want to submit a report on hilit19? ") - (reporter-submit-bug-report - "Jonathan Stigelman " - "hilit19.el (Release 2.19)" - (and (y-or-n-p "Do you need to include a dump hilit variables? ") - (append - '( - hilit-quietly hilit-inhibit-hooks - hilit-background-mode hilit-mode-enable-list - hilit-auto-highlight hilit-auto-highlight-maxout - hilit-auto-rehighlight hilit-auto-rehighlight-fallback - hilit-face-check - ) - (and (y-or-n-p "Have you modified the standard patterns? ") - (yes-or-no-p "Are your patterns *REALLY* relevant? ") - '(hilit-parser-alist - hilit-patterns-alist - hilit-predefined-face-list - )))) - (function - (lambda () - (and (y-or-n-p "Is this a problem with font display? ") - (insert "\nFrame Configuration:\n====================\n" - (prin1-to-string (frame-configuration-to-register ?F)) - "\n" - )))) - nil - (concat - "This is (check all that apply, and delete what's irrelevant):\n" - " [ ] a _MASSIVE_THANK_YOU_ for writing hilit19.el\n" - " [ ] An invitation to attend the next Hackers Conference\n" - " [ ] You're a RIGHTEOUS HACKER, what are your rates?\n" - " [ ] I've used the force and read the source, but I'M CONFUSED\n" - " [ ] a PATCH. (output of 'diff -uw old.el new.el' or 'diff -cw')\n" - " [ ] a SERIOUS AND REPRODUCIBLE BUG that is not an EMACS bug\n" - " - I *swear* that it's not already mentioned in the KNOWN BUGS\n" - " - I HAVE CHECKED ftp.hackvan.com:/pub/stig/src/elisp/hilit19.el.gz\n" - " for a newer release that fixes the problem.\n" - " >> I HAVE ALSO CHECKED ftp.hackvan.com:/pub/stig/src/elisp/hl319.el.gz\n" - " This is the alpha version...what will become hilit19 (Beta 3.0).\n" - "\n" - "Hey Stig, I *know* you're busy but...\n")))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; These faces are either a valid face name, or nil -;; if you want to change them, you must do so AFTER hilit19 is loaded - -(defconst hilit-default-face-table - '( - ;; used for C/C++ and Emacs Lisp and perl - (comment firebrick-italic moccasin italic) - (include purple Plum1 bold-italic) - (define ForestGreen-bold green bold) - (defun blue-bold cyan-bold bold-italic) - (decl RoyalBlue cyan bold) - (type nil yellow nil) - (keyword RoyalBlue cyan bold-italic) - (label red-underline orange-underlined underline) - (string grey40 orange underline) - - ;; some further faces for Ada - (struct black-bold white-bold bold) - (glob-struct magenta Plum1 default-bold-underline) - (named-param DarkGoldenrod Goldenrod underline) - - ;; and another one for LaTeX - (crossref DarkGoldenrod Goldenrod underline) - (formula Goldenrod DarkGoldenrod underline) - - ;; compilation buffers - (active-error default/pink-bold default/DeepPink-bold default-underline) - (error red-bold yellow bold) - (warning blue-italic green italic) - - ;; Makefiles (some faces borrowed from C/C++ too) - (rule blue-bold-underline cyan-underline default-bold-underline) - - ;; VM, GNUS and Text mode - (msg-subject blue-bold yellow bold) - (msg-from purple-bold green bold) - (msg-header firebrick-bold cyan italic) - (msg-separator black/tan-bold black/lightblue nil) - (msg-quote ForestGreen pink italic) - - (summary-seen grey40 white nil) - (summary-killed grey50 white nil) - (summary-Xed OliveDrab2 green nil) - (summary-deleted firebrick white italic) - (summary-unread RoyalBlue yellow bold) - (summary-new blue-bold yellow-bold bold-italic) - (summary-current default/skyblue-bold green/dimgrey-bold reverse-default) - - (gnus-group-unsubscribed grey50 white nil) - (gnus-group-empty nil nil nil) - (gnus-group-full ForestGreen green italic) - (gnus-group-overflowing firebrick red bold-italic) - - ;; dired mode - (dired-directory blue-bold cyan bold) - (dired-link firebrick-italic green italic) - (dired-ignored ForestGreen moccasin nil) - (dired-deleted red-bold-italic orange bold-italic) - (dired-marked purple Plum1 nil) - - ;; Info-mode, and jargon-mode.el and prep.ai.mit.edu:/pub/gnu/jargon* - (jargon-entry blue-bold cyan bold) - (jargon-xref purple-bold Plum1 italic) - (jargon-keyword firebrick-underline yellow underline) - ) - "alist of default faces (face . (light-default dark-default mono-default)) - -There is no way for the user to modify this table such that it will have any -effect upon the translations used by hilit19. Instead, use the function -hilit-translate AFTER hilit19 has been loaded. - -See also the documentation for hilit-lookup-face-create.") - -(defconst hilit-face-translation-table - (let ((index (or (and (x-display-color-p) - (cdr (assq hilit-background-mode - '((light . 1) (dark . 2))))) - 3))) - (mapcar (function (lambda (x) (cons (car x) (nth index x)))) - hilit-default-face-table)) - "alist that maps symbolic face-names to real face names") - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; To translate one face to another... -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defmacro hilit-translate (&rest args) - "(hilit-translate FROM TO FROM TO ...): translate each face FROM to the -value of its TO face. This is like setq for faces. - -The function hilit-lookup-face-create will repeatedly translate until no more -translations for the face exist in the translation table. - -See the documentation for hilit-lookup-face-create for names of valid faces." - (or (zerop (% (length args) 2)) - (error "wrong number of args")) - (let (cmdl from to) - (while args - (setq from (car args) to (nth 1 args) args (nthcdr 2 args) - cmdl (cons (list 'hilit-associate ''hilit-face-translation-table - (list 'quote from) to) - cmdl))) - (cons 'progn cmdl))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; This function actually translates and then creates the faces... -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun hilit-lookup-face-create (face &optional force) - "Get a FACE, or create it if it doesn't exist. In order for it to -properly create the face, the following naming convention must be used: - [reverse-](fgcolor[/bgcolor])[-bold][-italic][-underline] -Example: (hilit-lookup-face-create 'comment-face) might create and return 'red - -Each color is either the name of an X color (see .../X11/lib/X11/rgb.txt), -a hexadecimal specification of the form \"hex-[0-9A-Fa-f]+\", or \"default\". - -An optional argument, FORCE, will cause the face to be recopied from the -default...which is probably of use only if you've changed fonts. - -See the documentation for hilit-translate and hilit-face-translation-table." - -;; translate the face ... - (let ((trec t) visited) - (while trec - (cond ((memq face visited) (error "face translation loop: %S" visited)) - (t (setq visited (cons face visited) - trec (assq face hilit-face-translation-table)) - (and trec (setq face (cdr trec))))))) - - ;; make the face if we need to... - (let* ((fn (symbol-name face)) - (frame (selected-frame)) - (basefont (cdr (assq 'font (frame-parameters frame)))) - error fgcolor bgcolor) - (cond - ((or (null face) - (memq face hilit-predefined-face-list)) - ;; do nothing if the face is nil or if it's predefined. - ) - ((or force - (not (memq face (face-list))) - (and hilit-face-check - (not (string= (get face 'basefont) basefont)))) - (copy-face 'default 'scratch-face) - (if (string-match "^reverse-?" fn) - (progn (invert-face 'scratch-face) - (setq fn (substring fn (match-end 0))))) - - ;; parse foreground color - (if (string-match "^\\(hex-\\)?\\([A-Za-z0-9]+\\)" fn) - (setq fgcolor (concat - (if (match-beginning 1) "#") - (substring fn (match-beginning 2) (match-end 2))) - fn (substring fn (match-end 0))) - (error "bad face name %S" face)) - - ;; parse background color - (if (string-match "^/\\(hex-\\)?\\([A-Za-z0-9]+\\)" fn) - (setq bgcolor (concat - (and (match-beginning 1) "#") - (substring fn (match-beginning 2) (match-end 2))) - fn (substring fn (match-end 0)))) - - (and (string= "default" fgcolor) (setq fgcolor nil)) - (and (string= "default" bgcolor) (setq bgcolor nil)) - - ;; catch errors if we can't allocate the color(s) - (condition-case nil - (progn (and fgcolor (set-face-foreground 'scratch-face fgcolor)) - (and bgcolor (set-face-background 'scratch-face bgcolor)) - (copy-face 'scratch-face face) - (put face 'basefont basefont)) - (error (message "couldn't allocate color for '%s'" - (symbol-name face)) - (setq face 'default) - (setq error t))) - (or error - ;; don't bother w/ bold or italic if we didn't get the color - ;; we wanted, but ignore errors making the face bold or italic - ;; if the font isn't available, there's nothing to do about it... - (progn - (set-face-font face basefont frame) - (set-face-underline-p face (string-match "underline" fn)) - (if (string-match ".*bold" fn) - ;; make face bold in all frames - (make-face-bold face nil 'noerr)) - (if (string-match ".*italic" fn) - ;; make face italic in all frames - (make-face-italic face nil 'noerr)) - )) - ))) - face) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Region Highlight/Unhighlight code (Both overlay and text-property versions) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defsubst hilit-region-set-face (start end face-name &optional prio prop) - "Highlight region from START to END using FACE and, optionally, PRIO. -The optional 5th arg, PROP is a property to set instead of 'hilit." - (let ((overlay (make-overlay start end))) - (overlay-put overlay 'face face-name) - (overlay-put overlay (or prop 'hilit) t) - (and prio (overlay-put overlay 'priority prio)))) - -(defun hilit-unhighlight-region (start end &optional quietly) - "Unhighlights the region from START to END, optionally in a QUIET way" - (interactive "r") - (or quietly hilit-quietly (message "Unhighlighting")) - (let ((lstart 0)) - (while (and start (> start lstart) (< start end)) - (mapcar (function (lambda (ovr) - (and (overlay-get ovr 'hilit) (delete-overlay ovr)))) - (overlays-at start)) - (setq lstart start start (next-overlay-change start)))) - (or quietly hilit-quietly (message "Done unhighlighting"))) - -;;;; These functions use text properties instead of overlays. Text properties -;;;; are copied through kill and yank...which might be convenient, but is not -;;;; terribly efficient as of 19.12, ERGO it's been disabled -;; -;;(defsubst hilit-region-set-face (start end face-name &optional prio prop) -;; "Highlight region from START to END using FACE and, optionally, PRIO. -;;The optional 5th arg, PROP is a property to set instead of 'hilit." -;; (put-text-property start end 'face face-name) -;; ) -;; -;;(defun hilit-unhighlight-region (start end &optional quietly) -;; "Unhighlights the region from START to END, optionally in a QUIET way" -;; (interactive "r") -;; (let ((buffer-read-only nil) -;; (bm (buffer-modified-p))) -;; (remove-text-properties start end '(face)) -;; (set-buffer-modified-p bm))) -;;;; - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Pattern Application code and user functions -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun hilit-highlight-region (start end &optional patterns quietly) - "Highlights the area of the buffer between START and END (the region when -interactive). Without the optional PATTERNS argument, the pattern for -major-mode is used. If PATTERNS is a symbol, then the patterns associated -with that symbol are used. QUIETLY suppresses progress messages if -non-nil." - (interactive "r") - (cond ((null patterns) - (setq patterns (cdr (assq major-mode hilit-patterns-alist)))) - ((symbolp patterns) - (setq patterns (cdr (assq patterns hilit-patterns-alist))))) - ;; txt prop: (setq patterns (reverse patterns)) - (let ((case-fold-search (car patterns)) - (prio (1- (length patterns))) - ;; txt prop: (buffer-read-only nil) - ;; txt prop: (bm (buffer-modified-p)) - p pstart pend face mstart (puke-count 0)) - ;; txt prop: (unwind-protect - (setq patterns (cdr patterns)) ; remove case-fold from head of pattern - (save-excursion - (save-restriction - (narrow-to-region start end) - (while patterns - (setq p (car patterns)) - (setq pstart (car p) - pend (nth 1 p) - face (hilit-lookup-face-create (nth 2 p))) - (if (not face) ; skipped if nil - nil - (or quietly hilit-quietly - (message "highlighting %d: %s%s" prio pstart - (if (stringp pend) (concat " ... " pend) ""))) - (goto-char (point-min)) - (condition-case msg - (cond - ((symbolp pstart) - ;; inner loop -- special function to find pattern - (let (region) - (while (setq region (funcall pstart pend)) - (hilit-region-set-face (car region) (cdr region) - face prio)))) - ((stringp pend) - ;; inner loop -- regex-start ... regex-end - (while (re-search-forward pstart nil t nil) - (goto-char (setq mstart (match-beginning 0))) - (if (re-search-forward pend nil t nil) - (hilit-region-set-face mstart (match-end 0) - face prio) - (forward-char 1)))) - ((numberp pend) - ;; inner loop -- just one regex to match whole pattern - (while (re-search-forward pstart nil t nil) - (goto-char (match-end pend)) - (hilit-region-set-face (match-beginning pend) - (match-end pend) face prio))) - (t (error "malformed pattern"))) - (error (if (> (setq puke-count (1+ puke-count)) 1) - (error msg) - (message "Error: '%s'" msg) - (ding) (sit-for 4))))) - (setq prio (1- prio) - patterns (cdr patterns))) - )) - (or quietly hilit-quietly (message "")) ; "Done highlighting" - ;; txt prop: (set-buffer-modified-p bm)) ; unwind protection - )) - -(defun hilit-rehighlight-region (start end &optional quietly) - "Re-highlights the region, optionally in a QUIET way" - (interactive "r") - (save-restriction - (widen) - (setq start (apply 'min start (mapcar 'overlay-start (overlays-at start))) - end (apply 'max end (mapcar 'overlay-end (overlays-at end)))) - (hilit-unhighlight-region start end quietly) - (hilit-highlight-region start end nil quietly))) - -(defun hilit-rehighlight-buffer (&optional quietly) - "Re-highlights the buffer, optionally in a QUIET way" - (interactive "") - (let ((parse-fn (cdr (assq major-mode hilit-parser-alist)))) - (if parse-fn - (funcall parse-fn quietly) - (hilit-rehighlight-region (point-min) (point-max) quietly))) - nil) - -(defun hilit-rehighlight-buffer-quietly () - (hilit-rehighlight-buffer t)) - -(defun hilit-rehighlight-message (quietly) - "Highlight a buffer containing a news article or mail message." - (save-excursion - (goto-char (point-min)) - ;; find separation between headers and body (either a blank line or - ;; the message separator line in mail-mode) - (re-search-forward "^\\(\\|--text follows this line--\\)$" nil 'noerr) - (hilit-unhighlight-region (point-min) (point-max) quietly) - (hilit-highlight-region (point-min) (point) 'msg-header quietly) - (hilit-highlight-region (point) (point-max) 'msg-body quietly))) - -(defalias 'hilit-highlight-buffer 'hilit-rehighlight-buffer) - -;; Well, I want to remove this function...there's one sure way to find out if -;; anyone uses it or not...and that's to comment it out. -;; -;; (defun hilit-toggle-highlight (arg) -;; "Locally toggle highlighting. With arg, forces highlighting off." -;; (interactive "P") -;; ;; FIXME -- this loses numeric information in hilit-auto-rehighlight -;; (setq hilit-auto-rehighlight -;; (and (not arg) (not hilit-auto-rehighlight))) -;; (if hilit-auto-rehighlight -;; (hilit-rehighlight-buffer) -;; (hilit-unhighlight-region (point-min) (point-max))) -;; (message "Rehighlighting is set to %s" hilit-auto-rehighlight)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; HOOKS -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun hilit-find-file-hook () - "Find-file hook for hilit package. See the variable hilit-auto-highlight." - (cond ((and hilit-auto-highlight - (assq major-mode hilit-patterns-alist)) - (if (> buffer-saved-size (car hilit-auto-rehighlight-fallback)) - (setq hilit-auto-rehighlight - (cdr hilit-auto-rehighlight-fallback))) - (if (> buffer-saved-size hilit-auto-highlight-maxout) - nil - (let ((bm (buffer-modified-p))) - (hilit-rehighlight-buffer) - (set-buffer-modified-p bm)))))) - -(defun hilit-repaint-command (arg) - "Rehighlights according to the value of hilit-auto-rehighlight, or the -prefix argument if that is specified. -\t\\[hilit-repaint-command]\t\trepaint according to hilit-auto-rehighlight -\t^U \\[hilit-repaint-command]\trepaint entire buffer -\t^U - \\[hilit-repaint-command]\trepaint visible portion of buffer -\t^U n \\[hilit-repaint-command]\trepaint n lines to either side of point" - (interactive "P") - (let (st en quietly) - (or arg (setq arg hilit-auto-rehighlight)) - (cond ((or (eq arg 'visible) (eq arg '-)) - (setq st (window-start) en (window-end) quietly t)) - ((numberp arg) - (setq st (save-excursion (forward-line (- arg)) (point)) - en (save-excursion (forward-line arg) (point)))) - (arg - (hilit-rehighlight-buffer))) - (if st - (hilit-rehighlight-region st en quietly)))) - -(defun hilit-recenter (arg) - "Recenter, then rehighlight according to hilit-auto-rehighlight. If called -with an unspecified prefix argument (^U but no number), then a rehighlight of -the entire buffer is forced." - (interactive "P") - (recenter arg) - ;; force display update - (sit-for 0) - (hilit-repaint-command (consp arg))) - -(defun hilit-yank (arg) - "Yank with rehighlighting" - (interactive "*P") - (let ((transient-mark-mode nil)) - (yank arg) - (and hilit-auto-rehighlight - (hilit-rehighlight-region (region-beginning) (region-end) t)) - (setq this-command 'yank))) - -(defun hilit-yank-pop (arg) - "Yank-pop with rehighlighting" - (interactive "*p") - (let ((transient-mark-mode nil)) - (yank-pop arg) - (and hilit-auto-rehighlight - (hilit-rehighlight-region (region-beginning) (region-end) t)) - (setq this-command 'yank))) - -;;; this line highlighting stuff is untested. play with it only if you feel -;;; adventurous...don't ask me to fix it...though you're welcome to. -- Stig -;; -;; (defun hilit-rehighlight-line-quietly (&rest args) -;; "Quietly rehighlight just this line. -;; Useful as an after change hook in VM/gnus summary buffers and dired buffers. -;; If only there were an after-change-function, that is..." -;; (save-excursion -;; (push-mark nil t) -;; (hilit-rehighlight-yank-region) -;; (and orig-achange-function (apply orig-achange-function args)))) -;; -;; (defun hilit-install-line-hooks () -;; (make-variable-buffer-local 'after-change-function) -;; (make-local-variable 'orig-achange-function) -;; (setq orig-achange-function after-change-function) -;; (setq after-change-function 'hilit-rehighlight-line-quietly)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Wysiwyg Stuff... take it away and build a whole package around it! -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; ; For the Jargon-impaired, WYSIWYG === What You See Is What You Get -;; ; Sure, it sucks to type. Oh, well. -;; (defun hilit-wysiwyg-replace () -;; "Replace overstruck text with normal text that's been overlaid with the -;; appropriate text attribute. Suitable for a find-file hook." -;; (save-excursion -;; (goto-char (point-min)) -;; (let ((wysb (hilit-lookup-face-create 'wysiwyg-bold)) -;; (wysu (hilit-lookup-face-create 'wysiwyg-underline)) -;; (bmod (buffer-modified-p))) -;; (while (re-search-forward "\\(.\b.\\)+" nil t) -;; (let ((st (match-beginning 0)) (en (match-end 0))) -;; (goto-char st) -;; (if (looking-at "_") -;; (hilit-region-set-face st en wysu 100 'wysiwyg) -;; (hilit-region-set-face st en wysb 100 'wysiwyg)) -;; (while (and (< (point) en) (looking-at ".\b")) -;; (replace-match "") (forward-char)) -;; )) -;; (set-buffer-modified-p bmod)))) -;; -;; ; is this more appropriate as a write-file-hook or a write-contents-hook? -;; (defun hilit-wysiwyg-write-repair () -;; "Replace wysiwyg overlays with overstrike text." -;; (message "*sigh* hilit-wysiwyg-write-repair not implemented yet") -;; -;; For efficiency, this hook should copy the current buffer to a scratch -;; buffer and do its overstriking there. Overlays are not copied, so it'll -;; be necessary to hop back and forth. This is OK since you're not fiddling -;; with--making or deleting--any overlays. THEN write the new buffer, -;; delete it, and RETURN T. << important -;; -;; Just so you know...there is already an emacs function called -;; underline-region that does underlining. I think that the thing to do is -;; extend that to do overstriking as well. -;; -;; (while (< start end) -;; (mapcar (function (lambda (ovr) -;; (and (overlay-get ovr 'hilit) (delete-overlay ovr)))) -;; (overlays-at start)) -;; (setq start (next-overlay-change start))) -;; nil) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Initialization. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(and (not hilit-inhibit-rebinding) - window-system - (progn - (substitute-key-definition 'yank 'hilit-yank - (current-global-map)) - (substitute-key-definition 'yank-pop 'hilit-yank-pop - (current-global-map)) - (substitute-key-definition 'recenter 'hilit-recenter - (current-global-map)))) - -(global-set-key [?\C-\S-l] 'hilit-repaint-command) - -(and window-system - (add-hook 'find-file-hooks 'hilit-find-file-hook t)) - -(eval-when-compile (require 'gnus)) ; no compilation gripes - -(and (not hilit-inhibit-hooks) - window-system - (condition-case c - (progn - - ;; BUFFER highlights... - (mapcar (function - (lambda (hook) - (add-hook hook 'hilit-rehighlight-buffer-quietly))) - '( - Info-selection-hook - -;; runs too early vm-summary-mode-hooks - vm-summary-pointer-hook - vm-preview-message-hook - vm-show-message-hook - - rmail-show-message-hook - mail-setup-hook - mh-show-mode-hook - - dired-after-readin-hook - )) - ) - (error (message "Error loading highlight hooks: %s" c) - (ding) (sit-for 1)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Default patterns for various modes. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; do I need this? I changed the defconst to a defvar because defconst is -;;; inappropriate, but I don't know why I wanted hilit-patterns-alist to be -;;; reset on every reload... - -(setq hilit-patterns-alist nil) - -(defun hilit-associate (alist key val) - "creates, or destructively replaces, the pair (key . val) in alist" - (let ((oldentry (assq key (eval alist)))) - (if oldentry - (setcdr oldentry val) - (set alist (cons (cons key val) (eval alist)))))) - -(defun hilit-set-mode-patterns (modelist patterns - &optional parse-fn case-fold) - "Sets the default highlighting patterns for MODE to PATTERNS. -See the variable hilit-mode-enable-list. - -Takes optional arguments PARSE-FN and CASE-FOLD." - ;; change pattern - (mapcar (function (lambda (p) - (and (stringp (car p)) - (null (nth 1 p)) - (setcar (cdr p) 0)))) - patterns) - (setq patterns (cons case-fold patterns)) - - (or (consp modelist) (setq modelist (list modelist))) - (let (ok (flip (eq (car hilit-mode-enable-list) 'not))) - (mapcar (function - (lambda (m) - (setq ok (or (null hilit-mode-enable-list) - (memq m hilit-mode-enable-list))) - (and flip (setq ok (not ok))) - (and ok - (progn - (and parse-fn - (hilit-associate 'hilit-parser-alist m parse-fn)) - (hilit-associate 'hilit-patterns-alist m patterns))))) - modelist))) - -(defun hilit-add-pattern (pstart pend face &optional mode first) - "Highlight pstart with face for the current major-mode. -Optionally, place the new pattern first in the pattern list" - (interactive "sPattern start regex: \nsPattern end regex (default none): \nxFace: ") - - (and (equal pstart "") (error "Must specify starting regex")) - (cond ((equal pend "") (setq pend 0)) - ((string-match "^[0-9]+$" pend) (setq pend (string-to-int pend)))) - (or mode (setq mode major-mode)) - (let ((old-patterns (cdr (assq mode hilit-patterns-alist))) - (new-pat (list pstart pend face))) - (cond ((not old-patterns) - (hilit-set-mode-patterns mode (list new-pat))) - (first - (setcdr old-patterns (cons new-pat (cdr old-patterns)))) - (t - (nconc old-patterns (list new-pat))))) - (and (interactive-p) (hilit-rehighlight-buffer))) - -(defun hilit-string-find (qchar) - "looks for a string and returns (start . end) or NIL. The argument QCHAR -is the character that would precede a character constant double quote. -Finds strings delimited by double quotes. The first double quote may not be -preceded by QCHAR and the closing double quote may not be preceded by an odd -number of backslashes." - (let (st en) - (while (and (search-forward "\"" nil t) - (eq qchar (char-after (1- (setq st (match-beginning 0))))))) - (while (and (search-forward "\"" nil t) - (save-excursion - (setq en (point)) - (forward-char -1) - (skip-chars-backward "\\\\") - (forward-char 1) - (not (zerop (% (- en (point)) 2)))))) - (and en (cons st en)))) - -;; return types on same line... -;; ("^[a-zA-z].*\\(\\w\\|[$_]\\)+\\s *\\(\\(\\w\\|[$_]\\)+\\s *((\\|(\\)[^)]*)+" nil defun) - -;; On another note, a working pattern for grabbing function definitions for C is -;; -;; ("^[a-zA-Z_]+.*[;{]$" nil ForestGreen) ; global defns ( start at col 1 ) -;; ("^[a-zA-Z_]+.*(" ")" defun) -;; ; defuns assumed to start at col 1, not with # or { -;; -;; this will make external declarations/definitions green, and function -;; definitions the defun face. Hmmm - seems to work for me anyway. - -(let ((comments '(("/\\*" "\\*/" comment))) - (c++-comments '(("//.*$" nil comment) - ("^/.*$" nil comment))) - (strings '((hilit-string-find ?' string))) - (preprocessor '(("^#[ \t]*\\(undef\\|define\\).*$" "[^\\]$" define) - ("^#.*$" nil include)))) - - (hilit-set-mode-patterns - '(c-mode c++-c-mode elec-c-mode) - (append - comments strings preprocessor - '( - ;; function decls are expected to have types on the previous line - ("^\\(\\w\\|[$_]\\)+\\s *\\(\\(\\w\\|[$_]\\)+\\s *((\\|(\\)[^)]*)+" nil defun) - ("^\\(typedef\\|struct\\|union\\|enum\\).*$" nil decl) - ;; datatype -- black magic regular expression - ("[ \n\t({]\\(\\(const\\|register\\|volatile\\|unsigned\\|extern\\|static\\)\\s +\\)*\\(\\(\\w\\|[$_]\\)+_t\\|float\\|double\\|void\\|char\\|short\\|int\\|long\\|FILE\\|\\(\\(struct\\|union\\|enum\\)\\([ \t]+\\(\\w\\|[$_]\\)*\\)\\)\\)\\(\\s +\\*+)?\\|[ \n\t;()]\\)" nil type) - ;; key words - ("[^_]\\<\\(return\\|goto\\|if\\|else\\|case\\|default\\|switch\\|break\\|continue\\|while\\|do\\|for\\)\\>[^_]" 1 keyword) - ))) - - (hilit-set-mode-patterns - 'c++-mode - (append - comments c++-comments strings preprocessor - '( - ;; function decls are expected to have types on the previous line - ("^\\(\\(\\w\\|[$_]\\)+::\\)?\\(\\w\\|[$_]\\)+\\s *\\(\\(\\w\\|[$_]\\)+\\s *((\\|(\\)[^)]*)+" nil defun) - ("^\\(\\(\\w\\|[$_]\\)+[ \t]*::[ \t]*\\)?\\(\\(\\w\\|[$_]\\)+\\|operator.*\\)\\s *\\(\\(\\w\\|[$_]\\)+\\s *((\\|(\\)[^)]*)+" nil defun) - ("^\\(template\\|typedef\\|struct\\|union\\|class\\|enum\\|public\\|private\\|protected\\).*$" nil decl) - ;; datatype -- black magic regular expression - ("[ \n\t({]\\(\\(const\\|register\\|volatile\\|unsigned\\|extern\\|static\\)\\s +\\)*\\(\\(\\w\\|[$_]\\)+_t\\|float\\|double\\|void\\|char\\|short\\|int\\|long\\|FILE\\|\\(\\(struct\\|union\\|enum\\|class\\)\\([ \t]+\\(\\w\\|[$_]\\)*\\)\\)\\)\\(\\s +\\*+)?\\|[ \n\t;()]\\)" nil type) - ;; key words - ("[^_]\\<\\(return\\|goto\\|if\\|else\\|case\\|default\\|switch\\|break\\|continue\\|while\\|do\\|for\\|public\\|protected\\|private\\|delete\\|new\\)\\>[^_]" - 1 keyword)))) - - (hilit-set-mode-patterns - '(objc-mode objective-C-mode) - (append - comments c++-comments strings preprocessor - '( - ;; function decls are expected to have types on the previous line - ("^\\(\\(\\w\\|[$_]\\)+::\\)?\\(\\w\\|[$_]\\)+\\s *\\(\\(\\w\\|[$_]\\)+\\s *((\\|(\\)[^)]*)+" nil defun) - ("^\\(\\(\\w\\|[$_]\\)+[ \t]*::[ \t]*\\)?\\(\\(\\w\\|[$_]\\)+\\|operator.*\\)\\s *\\(\\(\\w\\|[$_]\\)+\\s *((\\|(\\)[^)]*)+" nil defun) - - ("^\\(template\\|typedef\\|struct\\|union\\|class\\|enum\\|public\\|private\\|protected\\).*$" nil decl) - ;; datatype -- black magic regular expression - ("[ \n\t({]\\(\\(const\\|register\\|volatile\\|unsigned\\|extern\\|static\\)\\s +\\)*\\(\\(\\w\\|[$_]\\)+_t\\|float\\|double\\|void\\|char\\|short\\|int\\|long\\|FILE\\|\\(\\(struct\\|union\\|enum\\|class\\)\\([ \t]+\\(\\w\\|[$_]\\)*\\)\\)\\)\\(\\s +\\*+)?\\|[ \n\t;()]\\)" nil type) - ;; key words - ("[^_]\\<\\(return\\|goto\\|if\\|else\\|case\\|default\\|switch\\|break\\|continue\\|while\\|do\\|for\\|public\\|protected\\|private\\|interface\\|implementation\\|end\\|super\\|self\\)\\>[^_]" - 1 keyword)))) - ) - -(hilit-set-mode-patterns - 'perl-mode - '(("\\s #.*$" nil comment) - ("^#.*$" nil comment) - ("\"[^\\\"]*\\(\\\\\\(.\\|\n\\)[^\\\"]*\\)*\"" nil string) - ("^\\(__....?__\\|\\s *\\sw+:\\)" nil label) - ("^require.*$" nil include) - ("^package.*$" nil decl) - ("^\\s *sub\\s +\\(\\w\\|[_']\\)+" nil defun) - ("\\b\\(do\\|if\\|unless\\|while\\|until\\|else\\|elsif\\|for\\|foreach\\|continue\\|next\\|redo\\|last\\|goto\\|return\\|die\\|exit\\)\\b" nil keyword))) - -(hilit-set-mode-patterns - 'ada-mode - '(;; comments - ("--.*$" nil comment) - ;; main structure - ("[ \t\n]procedure[ \t]" "\\([ \t]\\(is\\|renames\\)\\|);\\)" glob-struct) - ("[ \t\n]task[ \t]" "[ \t]is" glob-struct) - ("[ \t\n]function[ \t]" "return[ \t]+[A-Za-z_0-9]+[ \t]*\\(is\\|;\\|renames\\)" glob-struct) - ("[ \t\n]package[ \t]" "[ \t]\\(is\\|renames\\)" glob-struct) - ;; if there is nothing before "private", it is part of the structure - ("^[ \t]*private[ \t\n]" nil glob-struct) - ;; if there is no indentation before the "end", then it is most - ;; probably the end of the package - ("^end.*$" ";" glob-struct) - ;; program structure -- "null", "delay" and "terminate" omitted - ("[ \n\t]\\(in\\|out\\|select\\|if\\|else\\|case\\|when\\|and\\|or\\|not\\|accept\\|loop\\|do\\|then\\|elsif\\|else\\|for\\|while\\|exit\\)[ \n\t;]" nil struct) - ;; block structure - ("[ \n\t]\\(begin\\|end\\|declare\\|exception\\|generic\\|raise\\|return\\|package\\|body\\)[ \n\t;]" nil struct) - ;; type declaration - ("^[ \t]*\\(type\\|subtype\\).*$" ";" decl) - ("[ \t]+is record.*$" "end record;" decl) - ;; "pragma", "with", and "use" are close to C cpp directives - ("^[ \t]*\\(with\\|pragma\\|use\\)" ";" include) - ;; nice for named parameters, but not so beautiful in case statements - ("[A-Za-z_0-9.]+[ \t]*=>" nil named-param) - ;; string constants probably not everybody likes this one - ("\"" ".*\"" string))) - -(hilit-set-mode-patterns - 'fortran-mode - '(("^[*Cc].*$" nil comment) - ("'[^'\n]*'" nil string) - ("\\(^[ \t]*[0-9]+\\|[ \t]continue[ \t\n]\\|format\\)" nil define) - ("[ \t]\\(do\\|do[ \t]*[0-9]+\\|go[ \t]*to[ \t]*[0-9]+\\|end[ \t]*do\\|if\\|else[ \t]*if\\|then\\|else\\|end[ \t]*if\\)[ \t\n(]" nil define) - ("[ \t]\\(call\\|program\\|subroutine\\|function\\|stop\\|return\\|end\\|include\\)[ \t\n]" nil include) - ("[ \t]\\(parameter[\t\n ]*([^)]*)\\|data\\|save\\|common[ \t\n]*/[^/]*/\\)" - nil decl) - ("^ ." nil type) - ("implicit[ \t]*none" nil decl) - ("\\([ \t]\\|implicit[ \t]*\\)\\(dimension\\|integer\\|real\\|double[ \t]*precision\\|character\\|logical\\|complex\\|double[ \t]*complex\\)\\([*][0-9]*\\|[ \t\n]\\)" nil keyword) - ) - nil 'case-insensitive) - -(hilit-set-mode-patterns - '(m2-mode modula-2-mode) - '(("(\\*" "\\*)" comment) - (hilit-string-find ?\\ string) - ("^[ \t]*PROCEDURE[ \t]+\\w+[^ \t(;]*" nil defun) - ("\\<\\(RECORD\\|ARRAY\\|OF\\|POINTER\\|TO\\|BEGIN\\|END\\|FOR\\|IF\\|THEN\\|ELSE\\|ELSIF\\|CASE\\|WHILE\\|DO\\|MODULE\\|FROM\\|RETURN\\|IMPORT\\|EXPORT\\|VAR\\|LOOP\\|UNTIL\\|\\DEFINITION\\|IMPLEMENTATION\\|AND\\|OR\\|NOT\\|CONST\\|TYPE\\|QUALIFIED\\)\\>" nil keyword) - ) - nil 'case-insensitive) - -(hilit-set-mode-patterns 'prolog-mode - '(("/\\*" "\\*/" comment) - ("%.*$" nil comment) - (":-" nil defun) - ("!" nil label) - ("\"[^\\\"]*\\(\\\\\\(.\\|\n\\)[^\\\"]*\\)*\"" nil string) - ("\\b\\(is\\|mod\\)\\b" nil keyword) - ("\\(->\\|-->\\|;\\|==\\|\\\\==\\|=<\\|>=\\|<\\|>\\|=\\|\\\\=\\|=:=\\|=\\\.\\\.\\|\\\\\\\+\\)" nil decl) - ("\\(\\\[\\||\\|\\\]\\)" nil include))) - -(hilit-set-mode-patterns - '( - LaTeX-mode japanese-LaTeX-mode SliTeX-mode - japanese-SliTeX-mode FoilTeX-mode latex-mode - ) - '( - ;; comments - ("[^\\]%.*$" nil comment) - - ;; the following two match \foo[xx]{xx} or \foo*{xx} or \foo{xx} - ("\\\\\\(sub\\)*\\(paragraph\\|section\\)\\(\*\\|\\[.*\\]\\)?{" "}" - keyword) - ("\\\\\\(chapter\\|part\\)\\(\*\\|\\[.*\\]\\)?{" "}" keyword) - ("\\\\footnote\\(mark\\|text\\)?{" "}" keyword) - ("\\\\[a-z]+box" nil keyword) - ("\\\\\\(v\\|h\\)space\\(\*\\)?{" "}" keyword) - - ;; (re-)define new commands/environments/counters - ("\\\\\\(re\\)?new\\(environment\\|command\\){" "}" defun) - ("\\\\new\\(length\\|theorem\\|counter\\){" "}" defun) - - ;; various declarations/definitions - ("\\\\\\(setlength\\|settowidth\\|addtolength\\|setcounter\\|addtocounter\\)" nil define) - ("\\\\\\(title\\|author\\|date\\|thanks\\){" "}" define) - - ("\\\\documentstyle\\(\\[.*\\]\\)?{" "}" decl) - ("\\\\\\(begin\\|end\\|nofiles\\|includeonly\\){" "}" decl) - ("\\\\\\(raggedright\\|makeindex\\|makeglossary\\|maketitle\\)\\b" nil - decl) - ("\\\\\\(pagestyle\\|thispagestyle\\|pagenumbering\\){" "}" decl) - ("\\\\\\(normalsize\\|small\\|footnotesize\\|scriptsize\\|tiny\\|large\\|Large\\|LARGE\\|huge\\|Huge\\)\\b" nil decl) - ("\\\\\\(appendix\\|tableofcontents\\|listoffigures\\|listoftables\\)\\b" - nil decl) - ("\\\\\\(bf\\|em\\|it\\|rm\\|sf\\|sl\\|ss\\|tt\\)\\b" nil decl) - - ;; label-like things - ("\\\\item\\(\\[[^]]*\\]\\)?" nil label) - ("\\\\caption\\(\\[[^]]*\\]\\)?{" "}" label) - - ;; formulas - ("[^\\]\\\\(" "\\\\)" formula) ; \( \) - ("[^\\]\\\\\\[" "\\\\\\]" formula) ; \[ \] - ("[^\\$]\\(\\$\\(\\$[^$]*\\$\\|[^$]*\\)\\$\\)" 1 formula) ; '$...$' or '$$...$$' - - ;; things that bring in external files - ("\\\\\\(include\\|input\\|bibliography\\){" "}" include) - - ;; "wysiwyg" emphasis -- these don't work with nested expressions - ;; ("{\\\\\\(em\\|it\\|sl\\)" "}" italic) - ;; ("{\\\\bf" "}" bold) - - ("``" "''" string) - - ;; things that do some sort of cross-reference - ("\\\\\\(\\(no\\)?cite\\|\\(page\\)?ref\\|label\\|index\\|glossary\\){" "}" crossref) - )) - -(hilit-set-mode-patterns - 'bibtex-mode - '(;;(";.*$" nil comment) - ("%.*$" nil comment) - ("@[a-zA-Z]+" nil keyword) - ("{[ \t]*[-a-z:_A-Z0-9]+," nil label) ; is wrong sometimes - ("^[ \t]*[a-zA-Z]+[ \t]*=" nil define))) - -(hilit-set-mode-patterns - 'compilation-mode - '( - ("^[-_.\"A-Za-z0-9]+\\(:\\|, line \\)[0-9]+: warning:.*$" nil warning) - ("^[-_.\"A-Za-z0-9]+\\(:\\|, line \\)[0-9]+:.*$" nil error) - )) - -(hilit-set-mode-patterns - 'makefile-mode - '(("^#.*$" nil comment) - ("[^$]#.*$" nil comment) - ;; rules - ("^[^ \t\n]*%[^ \t\n]*[ \t]*::?[ \t]*[^ \t\n]*[ \t]*\\(#.*\\)?$" nil rule) - ("^[.][A-Za-z][A-Za-z]?\..*$" nil rule) - ;; variable definition - ("^[_A-Za-z0-9]+[ \t]*\+?=" nil define) - ("\\( \\|:=\\)[_A-Za-z0-9]+[ \t]*\\+=" nil define) - ;; variable references - ("\\$\\([^ \t\n{(]\\|[{(]@?[_A-Za-z0-9:.,%/=]+[)}]\\)" nil keyword) - ("^[A-Za-z0-9.,/_-]+[ \t]*:.*$" nil defun) - ("^include " nil include))) - -(let* ((header-patterns '(("^Subject:.*$" nil msg-subject) - ("^From:.*$" nil msg-from) - ("^--text follows this line--$" nil msg-separator) - ("^[A-Za-z][A-Za-z0-9-]+:" nil msg-header))) - (body-patterns '(("^\\(In article\\|[ \t]*\\w*[]<>}|]\\).*$" - nil msg-quote))) - (message-patterns (append header-patterns body-patterns))) - (hilit-set-mode-patterns 'msg-header header-patterns) - (hilit-set-mode-patterns 'msg-body body-patterns) - (hilit-set-mode-patterns '(vm-mode text-mode mail-mode rmail-mode - gnus-article-mode news-reply-mode mh-show-mode) - message-patterns - 'hilit-rehighlight-message)) - -(hilit-set-mode-patterns - 'gnus-group-mode - '(("^ U.*$" nil gnus-group-unsubscribed) - ("^\\*? +[01]?[0-9]:.*$" nil gnus-group-empty) - ("^ +[2-9][0-9]:.*$" nil gnus-group-full) - ("^ +[0-9][0-9][0-9]+:.*$" nil gnus-group-overflowing))) - -(hilit-set-mode-patterns - 'vm-summary-mode - '(("^ .*$" nil summary-seen) - ("^->.*$" nil summary-current) - ("^ D.*$" nil summary-deleted) - ("^ U.*$" nil summary-unread) - ("^ N.*$" nil summary-new))) - - -;;; this will match only comments w/ an even (zero is even) number of quotes... -;;; which is still inadequate because it matches comments in multi-line strings -;;; how anal do you want to get about never highlighting comments in strings? -;;; I could twiddle with this forever and still it wouldn't be perfect. -;;; (";\\([^\"\n]*\"[^\"\n]*\"\\)*[^\"\n]*$" nil comment) - -(hilit-set-mode-patterns - '(emacs-lisp-mode lisp-interaction-mode) - '( - (";.*" nil comment) - -;;; This almost works...but I think I'll stick with the parser function -;;;("[^?]\\(\"\\(\"\\||\\([^\"]+\\|[\\]\\([\\][\\]\\)*\"\\)*\"\\)\\)" 1 string) - (hilit-string-find ?\\ string) - - ("^\\s *(def\\(un\\|macro\\|advice\\|alias\\|subst\\)[ \t\n]" - "\\()\\|nil\\)" defun) - ("^\\s *(defvar\\s +\\S +" nil decl) - ("^\\s *(defconst\\s +\\S +" nil define) - ("^\\s *(\\(provide\\|require\\|\\(auto\\)?load\\).*$" nil include) - ("\\s *\\&\\(rest\\|optional\\)\\s *" nil keyword) - ("(\\(let\\*?\\|cond\\|if\\|or\\|and\\|map\\(car\\|concat\\)\\|prog[n1*]?\\|while\\|lambda\\|function\\|set\\([qf]\\|car\\|cdr\\)?\\|nconc\\|eval-when-compile\\|condition-case\\|unwind-protect\\|catch\\|throw\\|error\\)[ \t\n]" 1 keyword) - )) - -(hilit-set-mode-patterns - '(lisp-mode ilisp-mode) - '( - (";.*" nil comment) - ("#|" "|#" comment) -;;; This almost works...but I think I'll stick with the parser function -;;;("[^?]\\(\"\\(\"\\||\\([^\"]+\\|[\\]\\([\\][\\]\\)*\"\\)*\"\\)\\)" 1 string) - (hilit-string-find ?\\ string) - - ;; this is waaaaaaaay too slow - ;; ("^\\s *(def\\(un\\|macro\\|advice\\|alias\\|method\\|subst\\)\\s \\S +[ \t\n]+\\(nil\\|(\\(([^()]*)\\|[^()]+\\)*)\\)" nil defun) - ("^\\s *(def\\(un\\|macro\\|advice\\|subst\\|method\\)\\s " "\\()\\|nil\\)" defun) - - ("^\\s *(\\(def\\(var\\|type\\|parameter\\)\\|declare\\)\\s +\\S +" nil decl) - ("^\\s *(def\\(const\\(ant\\)?\\|class\\|struct\\)\\s \\S +[ \t\n]+" nil define) - ("^\\s *(\\(provide\\|require\\|\\(auto\\)?load\\).*$" nil include) - ("[ \t]\\&\\(key\\|rest\\|optional\\|aux\\)\\s *" nil keyword) - ("(\\(let\\*?\\|locally\\|cond\\|if\\*?\\|or\\|and\\|map\\(car\\|c[ao]n\\)?\\|prog[nv1*]?\\|while\\|when\\|unless\\|do\\(\\*\\|list\\|times\\)\\|list\\|lambda\\|function\\|values\\|set\\([qf]\\|car\\|cdr\\)?\\|rplac[ad]\\|nconc\\|block\\|go\\|return\\(-from\\)?\\|[ec]?\\(type\\)?case\\|multiple-value-\\(bind\\|setq\\|list\\|call\\|prog1\\)\\|unwind-protect\\|handler-case\\|catch\\|throw\\|eval-when\\(-compile\\)?\\)[ \t\n]" 1 keyword) - )) - - -(hilit-set-mode-patterns - 'plain-tex-mode - '(("^%%.*$" nil comment) - ("{\\\\em\\([^}]+\\)}" nil comment) - ("\\(\\\\\\w+\\)" nil keyword) - ("{\\\\bf\\([^}]+\\)}" nil keyword) - ("^[ \t\n]*\\\\def[\\\\@]\\(\\w+\\)" nil defun) - ("\\\\\\(begin\\|end\\){\\([A-Za-z0-9\\*]+\\)}" nil defun) - ;; ("[^\\\\]\\$\\([^$]*\\)\\$" nil string) - ("\\$\\([^$]*\\)\\$" nil string) - )) - -;; Reasonable extensions would include smarter parameter handling for such -;; things as the .IX and .I macros, which alternate the handling of following -;; arguments. - -(hilit-set-mode-patterns - 'nroff-mode - '(("^\\.[\\\][\\\"].*$" nil comment) - ("^\\.so .*$" nil include) - ("^\\.[ST]H.*$" nil defun) -;; ("^[^\\.].*\"[^\\\"]*\\(\\\\\\(.\\)[^\\\"]*\\)*\"" nil string) - ("\"" "[^\\]\"" string) - ("^\\.[A-Z12\\\\].*$" nil define) - ("\\([\\\][^ ]*\\)" nil keyword) - ("^\\.[A-Z].*$" nil keyword)) - nil 'case-insensitive) - -(hilit-set-mode-patterns - 'texinfo-mode - '(("^\\(@c\\|@comment\\)\\>.*$" nil comment) - ("@\\(emph\\|strong\\|b\\|i\\){[^}]+}" nil comment) -;; seems broken -;; ("\\$[^$]*\\$" nil string) - ("@\\(file\\|kbd\\|key\\){[^}]+}" nil string) - ("^\\*.*$" nil defun) - ("@\\(if\\w+\\|format\\|item\\)\\b.*$" nil defun) - ("@end +[A-Za-z0-9]+[ \t]*$" nil defun) - ("@\\(samp\\|code\\|var\\){[^}]+}" nil defun) - ("@\\w+\\({[^}]+}\\)?" nil keyword) - )) - -(hilit-set-mode-patterns - 'dired-mode - (append - '(("^D.*$" nil dired-deleted) - ("^\\*.*$" nil dired-marked) - ("^ d.*$" nil dired-directory) - ("^ l.*$" nil dired-link) - ("^ -.*#.*#$" nil dired-ignored)) - (list (cons - (concat "^ .*\\(" - (mapconcat 'regexp-quote completion-ignored-extensions "\\|") - "\\)$") - '(nil dired-ignored))))) - -(hilit-set-mode-patterns - 'jargon-mode - '(("^:[^:]*:" nil jargon-entry) - ("{[^}]*}+" nil jargon-xref))) - -(hilit-set-mode-patterns - 'Info-mode - '(("^\\* [^:]+:+" nil jargon-entry) - ("\\*[Nn]ote\\b[^:]+:+" nil jargon-xref) - (" \\(Next\\|Prev\\|Up\\):" nil jargon-xref) - ("- \\(Variable\\|Function\\|Macro\\|Command\\|Special Form\\|User Option\\):.*$" - nil jargon-keyword))) ; lisp manual - -(hilit-set-mode-patterns - 'calendar-mode - '(("[A-Z][a-z]+ [0-9]+" nil define) ; month and year - ("S M Tu W Th F S" nil label))) ; week days - -(hilit-set-mode-patterns - 'asm-mode - '(("/\\*" "\\*/" comment) - ("^#[ \t]*\\(undef\\|define\\).*$" "[^\\]$" define) - ("^#.*$" nil include) - ;; labels - ("^.+:" nil defun) - ;; assembler directives - ("^[ \t]*\\..*$" nil decl) - ;; register names - ("\\$[a-z0-9]+" nil string) - ;; mnemonics - ("^[ \t]*[a-z]+" nil struct))) - -(hilit-set-mode-patterns - 'pascal-mode - '(("(\\*" "\\*)" comment) - ("{" "}" comment) - ;; Doesn't work when there are strings in comments.... - ;; ("'[^']*'" nil string) - ("^#.*$" nil include) - ("^[ \t]*\\(procedure\\|function\\)[ \t]+\\w+[^ \t(;]*" nil defun) - ("\\<\\(program\\|begin\\|end\\)\\>" nil defun) - ("\\<\\(external\\|forward\\)\\>" nil include) - ("\\<\\(label\\|const\\|type\\|var\\)\\>" nil define) - ("\\<\\(record\\|array\\|file\\)\\>" nil type) - ("\\<\\(of\\|to\\|for\\|if\\|then\\|else\\|case\\|while\\|do\\|until\\|and\\|or\\|not\\|with\\|repeat\\)\\>" nil keyword) - ) - nil 'case-insensitive) - -(hilit-set-mode-patterns - 'icon-mode - '(("#.*$" nil comment) - ("\"[^\\\"]*\\(\\\\.[^\\\"]*\\)*\"" nil string) - ;; charsets: these do not work because of a conflict with strings - ;; ("'[^\\']*\\(\\\\.[^\\']*\\)*'" nil string) - ("^[ \t]*procedure[ \t]+\\w+[ \t]*(" ")" defun) - ("^[ \t]*record.*(" ")" include) - ("^[ \t]*\\(global\\|link\\)[ \t\n]+[A-Za-z_0-9]+\\([ \t\n]*,[ \t\n]*[A-Za-z_0-9]+\\)*" nil include) - ("^[ \t]*\\(local\\|static\\)[ \t\n]+[A-Za-z_0-9]+\\([ \t\n]*,[ \t\n]*[A-Za-z_0-9]+\\)*" nil decl) - ("\\<\\(initial\\|end\\)\\>" nil glob-struct) - ("\\<\\(while\\|until\\|return\\|every\\|if\\|then\\|else\\|to\\|case\\|of\\|suspend\\|create\\|do\\|repeat\\|break\\)\\>" nil keyword) - )) - -;; as you can see, I had two similar problems for Pascal and Icon. In -;; Pascal, strings are delimited with ' and an embedded quote is doubled, -;; thus string syntax would be extremely simple. However, if a string -;; occurs within a comment, the following text is considered a string. -;; -;; In Icon, strings are similar to C ones, but there are also charsets, -;; delimited with simple quotes. I could not manage to use both regexps at -;; the same time. - -;; The problem I have with my patterns for Icon is that this language has a -;; string similar constant to the C one (but a string can be cut on several -;; lines, if terminated by a dash and continued with initial blanks, like -;; this: -;; "This is a somewhat long - -;; string, written on three - -;; successive lines" -;; in order to insert a double quote in a string, you have to escape it -;; with a \), bu also a character set constant (named a charset), which -;; uses single quotes instead of double ones. It would seem intuitive to -;; highlight both constants in the same way. - - -(provide 'hilit19) - -;;; hilit19 ends here. diff -r 3168ff2c349b -r 5c3a343fb1ce lisp/mail/rnews.el --- a/lisp/mail/rnews.el Thu Jan 04 19:17:21 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,985 +0,0 @@ -;;; rnews.el --- USENET news reader for gnu emacs - -;; Copyright (C) 1985, 1986, 1987 Free Software Foundation, Inc. - -;; Maintainer: FSF -;; Keywords: news - -;; This file is part of GNU Emacs. - -;; GNU Emacs 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. - -;; 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 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. - -;;; Change Log: - -;; Created Sun Mar 10,1985 at 21:35:01 ads and sundar@hernes.ai.mit.edu -;; Should do the point pdl stuff sometime -;; finito except pdl.... Sat Mar 16,1985 at 06:43:44 -;; lets keep the summary stuff out until we get it working .. -;; sundar@hermes.ai.mit.edu Wed Apr 10,1985 at 16:32:06 -;; hack slash maim. mly@gnu.org Thu 18 Apr, 1985 06:11:14 -;; modified to correct reentrance bug, to not bother with groups that -;; received no new traffic since last read completely, to find out -;; what traffic a group has available much more quickly when -;; possible, to do some completing reads for group names - should -;; be much faster... -;; KING@KESTREL.arpa, Thu Mar 13 09:03:28 1986 -;; made news-{next,previous}-group skip groups with no new messages; and -;; added checking for unsubscribed groups to news-add-news-group -;; tower@gnu.org Jul 18 1986 -;; bound rmail-output to C-o; and changed header-field commands binding to -;; agree with the new C-c C-f usage in sendmail -;; tower@gnu.org Sep 3 1986 -;; added news-rotate-buffer-body -;; tower@gnu.org Oct 17 1986 -;; made messages more user friendly, cleaned up news-inews -;; move posting and mail code to new file rnewpost.el -;; tower@gnu.org Oct 29 1986 -;; added caesar-region, rename news-caesar-buffer-body, hacked accordingly -;; tower@gnu.org Nov 21 1986 -;; added tower@gnu.org 22 Apr 87 - -;;; Code: - -(require 'mail-utils) -(require 'sendmail) - -(autoload 'rmail-output "rmailout" - "Append this message to Unix mail file named FILE-NAME." - t) - -(autoload 'news-reply "rnewspost" - "Compose and post a reply to the current article on USENET. -While composing the reply, use \\[mail-yank-original] to yank the original -message into it." - t) - -(autoload 'news-mail-other-window "rnewspost" - "Send mail in another window. -While composing the message, use \\[mail-yank-original] to yank the -original message into it." - t) - -(autoload 'news-post-news "rnewspost" - "Begin editing a new USENET news article to be posted." - t) - -(autoload 'news-mail-reply "rnewspost" - "Mail a reply to the author of the current article. -While composing the reply, use \\[mail-yank-original] to yank the original -message into it." - t) - -(defvar news-group-hook-alist nil - "Alist of (GROUP-REGEXP . HOOK) pairs. -Just before displaying a message, each HOOK is called -if its GROUP-REGEXP matches the current newsgroup name.") - -(defvar rmail-last-file (expand-file-name "~/mbox.news")) - -;Now in paths.el. -;(defvar news-path "/usr/spool/news/" -; "The root directory below which all news files are stored.") - -(defvar news-startup-file "$HOME/.newsrc" "Contains ~/.newsrc") -(defvar news-certification-file "$HOME/.news-dates" "Contains ~/.news-dates") - -;; random headers that we decide to ignore. -(defvar news-ignored-headers - "^Path:\\|^Posting-Version:\\|^Article-I.D.:\\|^Expires:\\|^Date-Received:\\|^References:\\|^Control:\\|^Xref:\\|^Lines:\\|^Posted:\\|^Relay-Version:\\|^Message-ID:\\|^Nf-ID:\\|^Nf-From:\\|^Approved:\\|^Sender:" - "All random fields within the header of a message.") - -(defvar news-mode-map nil) -(defvar news-read-first-time-p t) -;; Contains the (dotified) news groups of which you are a member. -(defvar news-user-group-list nil) - -(defvar news-current-news-group nil) -(defvar news-current-group-begin nil) -(defvar news-current-group-end nil) -(defvar news-current-certifications nil - "An assoc list of a group name and the time at which it is -known that the group had no new traffic") -(defvar news-current-certifiable nil - "The time when the directory we are now working on was written") - -(defvar news-message-filter nil - "User specifiable filter function that will be called during -formatting of the news file") - -;(defvar news-mode-group-string "Starting-Up" -; "Mode line group name info is held in this variable") -(defvar news-list-of-files nil - "Global variable in which we store the list of files -associated with the current newsgroup") -(defvar news-list-of-files-possibly-bogus nil - "variable indicating we only are guessing at which files are available. -Not currently used.") - -;; association list in which we store lists of the form -;; (pointified-group-name (first last old-last)) -(defvar news-group-article-assoc nil) - -(defvar news-current-message-number 0 "Displayed Article Number") -(defvar news-total-current-group 0 "Total no of messages in group") - -(defvar news-unsubscribe-groups ()) -(defvar news-point-pdl () "List of visited news messages.") -(defvar news-no-jumps-p t) -(defvar news-buffer () "Buffer into which news files are read.") - -(defmacro news-push (item ref) - (list 'setq ref (list 'cons item ref))) - -(defmacro news-cadr (x) (list 'car (list 'cdr x))) -(defmacro news-cdar (x) (list 'cdr (list 'car x))) -(defmacro news-caddr (x) (list 'car (list 'cdr (list 'cdr x)))) -(defmacro news-cadar (x) (list 'car (list 'cdr (list 'car x)))) -(defmacro news-caadr (x) (list 'car (list 'car (list 'cdr x)))) -(defmacro news-cdadr (x) (list 'cdr (list 'car (list 'cdr x)))) - -(defmacro news-wins (pfx index) - `(file-exists-p (concat ,pfx "/" (int-to-string ,index)))) - -(defvar news-max-plausible-gap 2 - "* In an rnews directory, the maximum possible gap size. -A gap is a sequence of missing messages between two messages that exist. -An empty file does not contribute to a gap -- it ends one.") - -(defun news-find-first-and-last (prefix base) - (and (news-wins prefix base) - (cons (news-find-first-or-last prefix base -1) - (news-find-first-or-last prefix base 1)))) - -(defmacro news-/ (a1 a2) -;; a form of / that guarantees that (/ -1 2) = 0 - (if (zerop (/ -1 2)) - `(/ ,a1 ,a2) - `(if (< ,a1 0) - (- (/ (- ,a1) ,a2)) - (/ ,a1 ,a2)))) - -(defun news-find-first-or-last (pfx base dirn) - ;; first use powers of two to find a plausible ceiling - (let ((original-dir dirn)) - (while (news-wins pfx (+ base dirn)) - (setq dirn (* dirn 2))) - (setq dirn (news-/ dirn 2)) - ;; Then use a binary search to find the high water mark - (let ((offset (news-/ dirn 2))) - (while (/= offset 0) - (if (news-wins pfx (+ base dirn offset)) - (setq dirn (+ dirn offset))) - (setq offset (news-/ offset 2)))) - ;; If this high-water mark is bogus, recurse. - (let ((offset (* news-max-plausible-gap original-dir))) - (while (and (/= offset 0) (not (news-wins pfx (+ base dirn offset)))) - (setq offset (- offset original-dir))) - (if (= offset 0) - (+ base dirn) - (news-find-first-or-last pfx (+ base dirn offset) original-dir))))) - -(defun rnews () -"Read USENET news for groups for which you are a member and add or -delete groups. -You can reply to articles posted and send articles to any group. - -Type \\[describe-mode] once reading news to get a list of rnews commands." - (interactive) - (let ((last-buffer (buffer-name))) - (make-local-variable 'rmail-last-file) - (switch-to-buffer (setq news-buffer (get-buffer-create "*news*"))) - (news-mode) - (setq news-buffer-save last-buffer) - (setq buffer-read-only nil) - (erase-buffer) - (setq buffer-read-only t) - (set-buffer-modified-p t) - (sit-for 0) - (message "Getting new USENET news...") - (news-set-mode-line) - (news-get-certifications) - (news-get-new-news))) - -(defun news-group-certification (group) - (cdr-safe (assoc group news-current-certifications))) - - -(defun news-set-current-certifiable () - ;; Record the date that corresponds to the directory you are about to check - (let ((file (concat news-path - (string-subst-char ?/ ?. news-current-news-group)))) - (setq news-current-certifiable - (nth 5 (file-attributes - (or (file-symlink-p file) file)))))) - -(defun news-get-certifications () - ;; Read the certified-read file from last session - (save-excursion - (save-window-excursion - (setq news-current-certifications - (car-safe - (condition-case var - (let* - ((file (substitute-in-file-name news-certification-file)) - (buf (find-file-noselect file))) - (and (file-exists-p file) - (progn - (switch-to-buffer buf 'norecord) - (unwind-protect - (read-from-string (buffer-string)) - (kill-buffer buf))))) - (error nil))))))) - -(defun news-write-certifications () - ;; Write a certification file. - ;; This is an assoc list of group names with doubletons that represent - ;; mod times of the directory when group is read completely. - (save-excursion - (save-window-excursion - (with-output-to-temp-buffer - "*CeRtIfIcAtIoNs*" - (print news-current-certifications)) - (let ((buf (get-buffer "*CeRtIfIcAtIoNs*"))) - (switch-to-buffer buf) - (write-file (substitute-in-file-name news-certification-file)) - (kill-buffer buf))))) - -(defun news-set-current-group-certification () - (let ((cgc (assoc news-current-news-group news-current-certifications))) - (if cgc (setcdr cgc news-current-certifiable) - (news-push (cons news-current-news-group news-current-certifiable) - news-current-certifications)))) - -(defun news-set-minor-modes () - "Creates a minor mode list that has group name, total articles, -and attribute for current article." - (setq news-minor-modes (list (cons 'foo - (concat news-current-message-number - "/" - news-total-current-group - (news-get-attribute-string))))) - ;; Detect Emacs versions 18.16 and up, which display - ;; directly from news-minor-modes by using a list for mode-name. - (or (boundp 'minor-mode-alist) - (setq minor-modes news-minor-modes))) - -(defun news-set-message-counters () - "Scan through current news-groups filelist to figure out how many messages -are there. Set counters for use with minor mode display." - (if (null news-list-of-files) - (setq news-current-message-number 0))) - -(if news-mode-map - nil - (setq news-mode-map (make-keymap)) - (suppress-keymap news-mode-map) - (define-key news-mode-map "." 'beginning-of-buffer) - (define-key news-mode-map " " 'scroll-up) - (define-key news-mode-map "\177" 'scroll-down) - (define-key news-mode-map "n" 'news-next-message) - (define-key news-mode-map "c" 'news-make-link-to-message) - (define-key news-mode-map "p" 'news-previous-message) - (define-key news-mode-map "j" 'news-goto-message) - (define-key news-mode-map "q" 'news-exit) - (define-key news-mode-map "e" 'news-exit) - (define-key news-mode-map "\ej" 'news-goto-news-group) - (define-key news-mode-map "\en" 'news-next-group) - (define-key news-mode-map "\ep" 'news-previous-group) - (define-key news-mode-map "l" 'news-list-news-groups) - (define-key news-mode-map "?" 'describe-mode) - (define-key news-mode-map "g" 'news-get-new-news) - (define-key news-mode-map "f" 'news-reply) - (define-key news-mode-map "m" 'news-mail-other-window) - (define-key news-mode-map "a" 'news-post-news) - (define-key news-mode-map "r" 'news-mail-reply) - (define-key news-mode-map "o" 'news-save-item-in-file) - (define-key news-mode-map "\C-o" 'rmail-output) - (define-key news-mode-map "t" 'news-show-all-headers) - (define-key news-mode-map "x" 'news-force-update) - (define-key news-mode-map "A" 'news-add-news-group) - (define-key news-mode-map "u" 'news-unsubscribe-current-group) - (define-key news-mode-map "U" 'news-unsubscribe-group) - (define-key news-mode-map "\C-c\C-r" 'news-caesar-buffer-body)) - -(defun news-mode () - "News Mode is used by M-x rnews for reading USENET Newsgroups articles. -New readers can find additional help in newsgroup: news.announce.newusers . -All normal editing commands are turned off. -Instead, these commands are available: - -. move point to front of this news article (same as Meta-<). -Space scroll to next screen of this news article. -Delete scroll down previous page of this news article. -n move to next news article, possibly next group. -p move to previous news article, possibly previous group. -j jump to news article specified by numeric position. -M-j jump to news group. -M-n goto next news group. -M-p goto previous news group. -l list all the news groups with current status. -? print this help message. -C-c C-r caesar rotate all letters by 13 places in the article's body (rot13). -g get new USENET news. -f post a reply article to USENET. -a post an original news article. -A add a newsgroup. -o save the current article in the named file (append if file exists). -C-o output this message to a Unix-format mail file (append it). -c \"copy\" (actually link) current or prefix-arg msg to file. - warning: target directory and message file must be on same device - (UNIX magic) -t show all the headers this news article originally had. -q quit reading news after updating .newsrc file. -e exit updating .newsrc file. -m mail a news article. Same as C-x 4 m. -x update last message seen to be the current message. -r mail a reply to this news article. Like m but initializes some fields. -u unsubscribe from current newsgroup. -U unsubscribe from specified newsgroup." - (interactive) - (kill-all-local-variables) - (make-local-variable 'news-read-first-time-p) - (setq news-read-first-time-p t) - (make-local-variable 'news-current-news-group) -; (setq news-current-news-group "??") - (make-local-variable 'news-current-group-begin) - (setq news-current-group-begin 0) - (make-local-variable 'news-current-message-number) - (setq news-current-message-number 0) - (make-local-variable 'news-total-current-group) - (make-local-variable 'news-buffer-save) - (make-local-variable 'version-control) - (setq version-control 'never) - (make-local-variable 'news-point-pdl) -; This breaks it. I don't have time to figure out why. -- RMS -; (make-local-variable 'news-group-article-assoc) - (setq major-mode 'news-mode) - (setq mode-line-process '(news-minor-modes)) - (setq mode-name "NEWS") - (news-set-mode-line) - (set-syntax-table text-mode-syntax-table) - (use-local-map news-mode-map) - (setq local-abbrev-table text-mode-abbrev-table) - (run-hooks 'news-mode-hook)) - -(defun string-subst-char (new old string) - (let (index) - (setq old (regexp-quote (char-to-string old)) - string (substring string 0)) - (while (setq index (string-match old string)) - (aset string index new))) - string) - -;; update read message number -(defmacro news-update-message-read (ngroup nno) - (list 'setcar - (list 'news-cdadr - (list 'assoc ngroup 'news-group-article-assoc)) - nno)) - -(defun news-parse-range (number-string) - "Parse string representing range of numbers of he form - -to a list (a . b)" - (let ((n (string-match "-" number-string))) - (if n - (cons (string-to-int (substring number-string 0 n)) - (string-to-int (substring number-string (1+ n)))) - (setq n (string-to-int number-string)) - (cons n n)))) - -;(defun is-in (elt lis) -; (catch 'foo -; (while lis -; (if (equal (car lis) elt) -; (throw 'foo t) -; (setq lis (cdr lis)))))) - -(defun news-get-new-news () - "Get new USENET news, if there is any for the current user." - (interactive) - (if (not (null news-user-group-list)) - (news-update-newsrc-file)) - (setq news-group-article-assoc ()) - (setq news-user-group-list ()) - (message "Looking up %s file..." news-startup-file) - (let ((file (substitute-in-file-name news-startup-file)) - (temp-user-groups ())) - (save-excursion - (let ((newsrcbuf (find-file-noselect file)) - start end endofline tem) - (set-buffer newsrcbuf) - (goto-char 0) - (while (search-forward ": " nil t) - (setq end (point)) - (beginning-of-line) - (setq start (point)) - (end-of-line) - (setq endofline (point)) - (setq tem (buffer-substring start (- end 2))) - (let ((range (news-parse-range - (buffer-substring end endofline)))) - (if (assoc tem news-group-article-assoc) - (message "You are subscribed twice to %s; I ignore second" - tem) - (setq temp-user-groups (cons tem temp-user-groups) - news-group-article-assoc - (cons (list tem (list (car range) - (cdr range) - (cdr range))) - news-group-article-assoc))))) - (kill-buffer newsrcbuf))) - (setq temp-user-groups (nreverse temp-user-groups)) - (message "Prefrobnicating...") - (switch-to-buffer news-buffer) - (setq news-user-group-list temp-user-groups) - (while (and temp-user-groups - (not (news-read-files-into-buffer - (car temp-user-groups) nil))) - (setq temp-user-groups (cdr temp-user-groups))) - (if (null temp-user-groups) - (message "No news is good news.") - (message "")))) - -(defun news-list-news-groups () - "Display all the news groups to which you belong." - (interactive) - (with-output-to-temp-buffer "*Newsgroups*" - (save-excursion - (set-buffer standard-output) - (insert - "News Group Msg No. News Group Msg No.\n") - (insert - "------------------------- -------------------------\n") - (let ((temp news-user-group-list) - (flag nil)) - (while temp - (let ((item (assoc (car temp) news-group-article-assoc))) - (insert (car item)) - (indent-to (if flag 52 20)) - (insert (int-to-string (news-cadr (news-cadr item)))) - (if flag - (insert "\n") - (indent-to 33)) - (setq temp (cdr temp) flag (not flag)))))))) - -;; Mode line hack -(defun news-set-mode-line () - "Set mode line string to something useful." - (setq mode-line-process - (concat " " - (if (integerp news-current-message-number) - (int-to-string news-current-message-number) - "??") - "/" - (if (integerp news-current-group-end) - (int-to-string news-current-group-end) - news-current-group-end))) - (setq mode-line-buffer-identification - (concat "NEWS: " - news-current-news-group - ;; Enough spaces to pad group name to 17 positions. - (substring " " - 0 (max 0 (- 17 (length news-current-news-group)))))) - (set-buffer-modified-p t) - (sit-for 0)) - -(defun news-goto-news-group (gp) - "Takes a string and goes to that news group." - (interactive (list (completing-read "NewsGroup: " - news-group-article-assoc))) - (message "Jumping to news group %s..." gp) - (news-select-news-group gp) - (message "Jumping to news group %s... done." gp)) - -(defun news-select-news-group (gp) - (let ((grp (assoc gp news-group-article-assoc))) - (if (null grp) - (error "Group %s not subscribed to" gp) - (progn - (news-update-message-read news-current-news-group - (news-cdar news-point-pdl)) - (news-read-files-into-buffer (car grp) nil) - (news-set-mode-line))))) - -(defun news-goto-message (arg) - "Goes to the article ARG in current newsgroup." - (interactive "p") - (if (null current-prefix-arg) - (setq arg (read-no-blanks-input "Go to article: " ""))) - (news-select-message arg)) - -(defun news-select-message (arg) - (if (stringp arg) (setq arg (string-to-int arg))) - (let ((file (concat news-path - (string-subst-char ?/ ?. news-current-news-group) - "/" arg))) - (if (= arg - (or (news-cadr (memq (news-cdar news-point-pdl) news-list-of-files)) - 0)) - (setcdr (car news-point-pdl) arg)) - (setq news-current-message-number arg) - (if (file-exists-p file) - (let ((buffer-read-only nil)) - (news-read-in-file file) - (news-set-mode-line)) - (news-set-mode-line) - (error "Article %d nonexistent" arg)))) - -(defun news-force-update () - "updates the position of last article read in the current news group" - (interactive) - (setcdr (car news-point-pdl) news-current-message-number) - (message "Updated to %d" news-current-message-number)) - -(defun news-next-message (arg) - "Move ARG messages forward within one newsgroup. -Negative ARG moves backward. -If ARG is 1 or -1, moves to next or previous newsgroup if at end." - (interactive "p") - (let ((no (+ arg news-current-message-number))) - (if (or (< no news-current-group-begin) - (> no news-current-group-end)) - (cond ((= arg 1) - (news-set-current-group-certification) - (news-next-group)) - ((= arg -1) - (news-previous-group)) - (t (error "Article out of range"))) - (let ((plist (news-get-motion-lists - news-current-message-number - news-list-of-files))) - (if (< arg 0) - (news-select-message (nth (1- (- arg)) (car (cdr plist)))) - (news-select-message (nth (1- arg) (car plist)))))))) - -(defun news-previous-message (arg) - "Move ARG messages backward in current newsgroup. -With no arg or arg of 1, move one message -and move to previous newsgroup if at beginning. -A negative ARG means move forward." - (interactive "p") - (news-next-message (- arg))) - -(defun news-move-to-group (arg) - "Given arg move forward or backward to a new newsgroup." - (let ((cg news-current-news-group)) - (let ((plist (news-get-motion-lists cg news-user-group-list)) - ngrp) - (if (< arg 0) - (or (setq ngrp (nth (1- (- arg)) (news-cadr plist))) - (error "No previous news groups")) - (or (setq ngrp (nth arg (car plist))) - (error "No more news groups"))) - (news-select-news-group ngrp)))) - -(defun news-next-group () - "Moves to the next user group." - (interactive) -; (message "Moving to next group...") - (news-move-to-group 0) - (while (null news-list-of-files) - (news-move-to-group 0))) -; (message "Moving to next group... done.") - -(defun news-previous-group () - "Moves to the previous user group." - (interactive) -; (message "Moving to previous group...") - (news-move-to-group -1) - (while (null news-list-of-files) - (news-move-to-group -1))) -; (message "Moving to previous group... done.") - -(defun news-get-motion-lists (arg listy) - "Given a msgnumber/group this will return a list of two lists; -one for moving forward and one for moving backward." - (let ((temp listy) - (result ())) - (catch 'out - (while temp - (if (equal (car temp) arg) - (throw 'out (cons (cdr temp) (list result))) - (setq result (nconc (list (car temp)) result)) - (setq temp (cdr temp))))))) - -;; miscellaneous io routines -(defun news-read-in-file (filename) - (erase-buffer) - (let ((start (point))) - (insert-file-contents filename) - (news-convert-format) - ;; Run each hook that applies to the current newsgroup. - (let ((hooks news-group-hook-alist)) - (while hooks - (goto-char start) - (if (string-match (car (car hooks)) news-group-name) - (funcall (cdr (car hooks)))) - (setq hooks (cdr hooks)))) - (goto-char start) - (forward-line 1) - (if (eobp) - (message "(Empty file?)") - (goto-char start)))) - -(defun news-convert-format () - (save-excursion - (save-restriction - (let* ((start (point)) - (end (condition-case () - (progn (search-forward "\n\n") (point)) - (error nil))) - has-from has-date) - (cond (end - (narrow-to-region start end) - (goto-char start) - (setq has-from (search-forward "\nFrom:" nil t)) - (cond ((and (not has-from) has-date) - (goto-char start) - (search-forward "\nDate:") - (beginning-of-line) - (kill-line) (kill-line))) - (news-delete-headers start) - (goto-char start))))))) - -(defun news-show-all-headers () - "Redisplay current news item with all original headers" - (interactive) - (let (news-ignored-headers - (buffer-read-only ())) - (erase-buffer) - (news-set-mode-line) - (news-read-in-file - (concat news-path - (string-subst-char ?/ ?. news-current-news-group) - "/" (int-to-string news-current-message-number))))) - -(defun news-delete-headers (pos) - (goto-char pos) - (and (stringp news-ignored-headers) - (while (re-search-forward news-ignored-headers nil t) - (beginning-of-line) - (delete-region (point) - (progn (re-search-forward "\n[^ \t]") - (forward-char -1) - (point)))))) - -(defun news-exit () - "Quit news reading session and update the .newsrc file." - (interactive) - (if (y-or-n-p "Do you really wanna quit reading news ? ") - (progn (message "Updating %s..." news-startup-file) - (news-update-newsrc-file) - (news-write-certifications) - (message "Updating %s... done" news-startup-file) - (message "Now do some real work") - (quit-window) - (switch-to-buffer news-buffer-save) - (setq news-user-group-list ())) - (message ""))) - -(defun news-update-newsrc-file () - "Updates the .newsrc file in the users home dir." - (let ((newsrcbuf (find-file-noselect - (substitute-in-file-name news-startup-file))) - (tem news-user-group-list) - group) - (save-excursion - (if (not (null news-current-news-group)) - (news-update-message-read news-current-news-group - (news-cdar news-point-pdl))) - (set-buffer newsrcbuf) - (while tem - (setq group (assoc (car tem) news-group-article-assoc)) - (if (= (news-cadr (news-cadr group)) (news-caddr (news-cadr group))) - nil - (goto-char 0) - (if (search-forward (concat (car group) ": ") nil t) - (kill-line nil) - (insert (car group) ": \n") (backward-char 1)) - (insert (int-to-string (car (news-cadr group))) "-" - (int-to-string (news-cadr (news-cadr group))))) - (setq tem (cdr tem))) - (while news-unsubscribe-groups - (setq group (assoc (car news-unsubscribe-groups) - news-group-article-assoc)) - (goto-char 0) - (if (search-forward (concat (car group) ": ") nil t) - (progn - (backward-char 2) - (kill-line nil) - (insert "! " (int-to-string (car (news-cadr group))) - "-" (int-to-string (news-cadr (news-cadr group)))))) - (setq news-unsubscribe-groups (cdr news-unsubscribe-groups))) - (save-buffer) - (kill-buffer (current-buffer))))) - - -(defun news-unsubscribe-group (group) - "Removes you from newgroup GROUP." - (interactive (list (completing-read "Unsubscribe from group: " - news-group-article-assoc))) - (news-unsubscribe-internal group)) - -(defun news-unsubscribe-current-group () - "Removes you from the newsgroup you are now reading." - (interactive) - (if (y-or-n-p "Do you really want to unsubscribe from this group ? ") - (news-unsubscribe-internal news-current-news-group))) - -(defun news-unsubscribe-internal (group) - (let ((tem (assoc group news-group-article-assoc))) - (if tem - (progn - (setq news-unsubscribe-groups (cons group news-unsubscribe-groups)) - (news-update-message-read group (news-cdar news-point-pdl)) - (if (equal group news-current-news-group) - (news-next-group)) - (message "")) - (error "Not subscribed to group: %s" group)))) - -(defun news-save-item-in-file (file) - "Save the current article that is being read by appending to a file." - (interactive "FSave item in file: ") - (append-to-file (point-min) (point-max) file)) - -(defun news-get-pruned-list-of-files (gp-list end-file-no) - "Given a news group it finds all files in the news group. -The arg must be in slashified format. -Using ls was found to be too slow in a previous version." - (let - ((answer - (and - (not (and end-file-no - (equal (news-set-current-certifiable) - (news-group-certification gp-list)) - (setq news-list-of-files nil - news-list-of-files-possibly-bogus t))) - (let* ((file-directory (concat news-path - (string-subst-char ?/ ?. gp-list))) - tem - (last-winner - (and end-file-no - (news-wins file-directory end-file-no) - (news-find-first-or-last file-directory end-file-no 1)))) - (setq news-list-of-files-possibly-bogus t news-list-of-files nil) - (if last-winner - (progn - (setq news-list-of-files-possibly-bogus t - news-current-group-end last-winner) - (while (> last-winner end-file-no) - (news-push last-winner news-list-of-files) - (setq last-winner (1- last-winner))) - news-list-of-files) - (if (or (not (file-directory-p file-directory)) - (not (file-readable-p file-directory))) - nil - (setq news-list-of-files - (condition-case error - (directory-files file-directory) - (file-error - (if (string= (nth 2 error) "permission denied") - (message "Newsgroup %s is read-protected" - gp-list) - (signal 'file-error (cdr error))) - nil))) - (setq tem news-list-of-files) - (while tem - (if (or (not (string-match "^[0-9]*$" (car tem))) - ;; don't get confused by directories that look like numbers - (file-directory-p - (concat file-directory "/" (car tem))) - (<= (string-to-int (car tem)) end-file-no)) - (setq news-list-of-files - (delq (car tem) news-list-of-files))) - (setq tem (cdr tem))) - (if (null news-list-of-files) - (progn (setq news-current-group-end 0) - nil) - (setq news-list-of-files - (mapcar 'string-to-int news-list-of-files)) - (setq news-list-of-files (sort news-list-of-files '<)) - (setq news-current-group-end - (elt news-list-of-files - (1- (length news-list-of-files)))) - news-list-of-files))))))) - (or answer (progn (news-set-current-group-certification) nil)))) - -(defun news-read-files-into-buffer (group reversep) - (let* ((files-start-end (news-cadr (assoc group news-group-article-assoc))) - (start-file-no (car files-start-end)) - (end-file-no (news-cadr files-start-end)) - (buffer-read-only nil)) - (setq news-current-news-group group) - (setq news-current-message-number nil) - (setq news-current-group-end nil) - (news-set-mode-line) - (news-get-pruned-list-of-files group end-file-no) - (news-set-mode-line) - ;; @@ should be a lot smarter than this if we have to move - ;; @@ around correctly. - (setq news-point-pdl (list (cons (car files-start-end) - (news-cadr files-start-end)))) - (if (null news-list-of-files) - (progn (erase-buffer) - (setq news-current-group-end end-file-no) - (setq news-current-group-begin end-file-no) - (setq news-current-message-number end-file-no) - (news-set-mode-line) -; (message "No new articles in " group " group.") - nil) - (setq news-current-group-begin (car news-list-of-files)) - (if reversep - (setq news-current-message-number news-current-group-end) - (if (> (car news-list-of-files) end-file-no) - (setcdr (car news-point-pdl) (car news-list-of-files))) - (setq news-current-message-number news-current-group-begin)) - (news-set-message-counters) - (news-set-mode-line) - (news-read-in-file (concat news-path - (string-subst-char ?/ ?. group) - "/" - (int-to-string - news-current-message-number))) - (news-set-message-counters) - (news-set-mode-line) - t))) - -(defun news-add-news-group (gp) - "Resubscribe to or add a USENET news group named GROUP (a string)." -; @@ (completing-read ...) -; @@ could be based on news library file ../active (slightly fascist) -; @@ or (expensive to compute) all directories under the news spool directory - (interactive "sAdd news group: ") - (let ((file-dir (concat news-path (string-subst-char ?/ ?. gp)))) - (save-excursion - (if (null (assoc gp news-group-article-assoc)) - (let ((newsrcbuf (find-file-noselect - (substitute-in-file-name news-startup-file)))) - (if (file-directory-p file-dir) - (progn - (switch-to-buffer newsrcbuf) - (goto-char 0) - (if (search-forward (concat gp "! ") nil t) - (progn - (message "Re-subscribing to group %s." gp) - ;;@@ news-unsubscribe-groups isn't being used - ;;(setq news-unsubscribe-groups - ;; (delq gp news-unsubscribe-groups)) - (backward-char 2) - (delete-char 1) - (insert ":")) - (progn - (message - "Added %s to your list of newsgroups." gp) - (end-of-buffer) - (insert gp ": 1-1\n"))) - (search-backward gp nil t) - (let (start end endofline tem) - (search-forward ": " nil t) - (setq end (point)) - (beginning-of-line) - (setq start (point)) - (end-of-line) - (setq endofline (point)) - (setq tem (buffer-substring start (- end 2))) - (let ((range (news-parse-range - (buffer-substring end endofline)))) - (setq news-group-article-assoc - (cons (list tem (list (car range) - (cdr range) - (cdr range))) - news-group-article-assoc)))) - (save-buffer) - (kill-buffer (current-buffer))) - (message "Newsgroup %s doesn't exist." gp))) - (message "Already subscribed to group %s." gp))))) - -(defun news-make-link-to-message (number newname) - "Forges a link to an rnews message numbered number (current if no arg) -Good for hanging on to a message that might or might not be -automatically deleted." - (interactive "P -FName to link to message: ") - (add-name-to-file - (concat news-path - (string-subst-char ?/ ?. news-current-news-group) - "/" (if number - (prefix-numeric-value number) - news-current-message-number)) - newname)) - -;;; caesar-region written by phr@gnu.org Nov 86 -;;; modified by tower@gnu.org Nov 86 -(defun caesar-region (&optional n) - "Caesar rotation of region by N, default 13, for decrypting netnews." - (interactive (if current-prefix-arg ; Was there a prefix arg? - (list (prefix-numeric-value current-prefix-arg)) - (list nil))) - (cond ((not (numberp n)) (setq n 13)) - (t (setq n (mod n 26)))) ;canonicalize N - (if (not (zerop n)) ; no action needed for a rot of 0 - (progn - (if (or (not (boundp 'caesar-translate-table)) - (/= (aref caesar-translate-table ?a) (+ ?a n))) - (let ((i 0) (lower "abcdefghijklmnopqrstuvwxyz") upper) - (message "Building caesar-translate-table...") - (setq caesar-translate-table (make-vector 256 0)) - (while (< i 256) - (aset caesar-translate-table i i) - (setq i (1+ i))) - (setq lower (concat lower lower) upper (upcase lower) i 0) - (while (< i 26) - (aset caesar-translate-table (+ ?a i) (aref lower (+ i n))) - (aset caesar-translate-table (+ ?A i) (aref upper (+ i n))) - (setq i (1+ i))) - (message "Building caesar-translate-table... done"))) - (let ((from (region-beginning)) - (to (region-end)) - (i 0) str len) - (setq str (buffer-substring from to)) - (setq len (length str)) - (while (< i len) - (aset str i (aref caesar-translate-table (aref str i))) - (setq i (1+ i))) - (goto-char from) - (kill-region from to) - (insert str))))) - -;;; news-caesar-buffer-body written by paul@media-lab.mit.edu Wed Oct 1, 1986 -;;; hacked further by tower@gnu.org -(defun news-caesar-buffer-body (&optional rotnum) - "Caesar rotates all letters in the current buffer by 13 places. -Used to encode/decode possibly offensive messages (commonly in net.jokes). -With prefix arg, specifies the number of places to rotate each letter forward. -Mail and USENET news headers are not rotated." - (interactive (if current-prefix-arg ; Was there a prefix arg? - (list (prefix-numeric-value current-prefix-arg)) - (list nil))) - (save-excursion - (let ((buffer-status buffer-read-only)) - (setq buffer-read-only nil) - ;; setup the region - (set-mark (if (equal major-mode 'news-mode) - (progn (goto-char (point-min)) - (search-forward "\n\n" nil t)) - (mail-text-start))) - (goto-char (point-max)) - (caesar-region rotnum) - (setq buffer-read-only buffer-status)))) - -(provide 'rnews) - -;;; rnews.el ends here diff -r 3168ff2c349b -r 5c3a343fb1ce lisp/mail/rnewspost.el --- a/lisp/mail/rnewspost.el Thu Jan 04 19:17:21 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,441 +0,0 @@ -;;; rnewspost.el --- USENET news poster/mailer for GNU Emacs - -;; Copyright (C) 1985, 1986, 1987, 1995 Free Software Foundation, Inc. - -;; Maintainer: FSF -;; Keywords: mail, news - -;; This file is part of GNU Emacs. - -;; GNU Emacs 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. - -;; 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 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. - -;;; Change Log: - -;; moved posting and mail code from rnews.el -;; tower@gnu.org Wed Oct 29 1986 -;; brought posting code almost up to the revision of RFC 850 for News 2.11 -;; - couldn't see handling the special meaning of the Keyword: poster -;; - not worth the code space to support the old A news Title: (which -;; Subject: replaced) and Article-I.D.: (which Message-ID: replaced) -;; tower@gnu.org Nov 86 -;; changed C-c C-r key-binding due to rename of news-caesar-buffer-body -;; tower@gnu.org 21 Nov 86 -;; added (require 'rnews) tower@gnu.org 22 Apr 87 -;; restricted call of news-show-all-headers in news-post-news & news-reply -;; tower@gnu.org 28 Apr 87 -;; commented out Posting-Front-End to save USENET bytes tower@gnu.org Jul 31 87 -;; commented out -n and -t args in news-inews tower@gnu.org 15 Oct 87 - -;Now in paths.el. -;(defvar news-inews-program "inews" -; "Function to post news.") - -;; Replying and posting news items are done by these functions. -;; imported from rmail and modified to work with rnews ... -;; Mon Mar 25,1985 at 03:07:04 ads@mit-hermes. -;; this is done so that rnews can operate independently from rmail.el and -;; sendmail and doesn't have to autoload these functions. -;; -;;; >> Nuked by Mly to autoload those functions again, as the duplication of -;;; >> code was making maintenance too difficult. - -;;; Code: - -(require 'sendmail) -(require 'rnews) - -(defvar news-reply-mode-map () "Mode map used by news-reply.") - -(or news-reply-mode-map - (progn - (setq news-reply-mode-map (make-keymap)) - (define-key news-reply-mode-map "\C-c\C-f\C-d" 'news-reply-distribution) - (define-key news-reply-mode-map "\C-c\C-f\C-k" 'news-reply-keywords) - (define-key news-reply-mode-map "\C-c\C-f\C-n" 'news-reply-newsgroups) - (define-key news-reply-mode-map "\C-c\C-f\C-f" 'news-reply-followup-to) - (define-key news-reply-mode-map "\C-c\C-f\C-s" 'mail-subject) - (define-key news-reply-mode-map "\C-c\C-f\C-a" 'news-reply-summary) - (define-key news-reply-mode-map "\C-c\C-t" 'mail-text) - (define-key news-reply-mode-map "\C-c\C-r" 'news-caesar-buffer-body) - (define-key news-reply-mode-map "\C-c\C-w" 'news-reply-signature) - (define-key news-reply-mode-map "\C-c\C-y" 'news-reply-yank-original) - (define-key news-reply-mode-map "\C-c\C-q" 'mail-fill-yanked-message) - (define-key news-reply-mode-map "\C-c\C-c" 'news-inews) - (define-key news-reply-mode-map "\C-c\C-s" 'news-inews) - (define-key news-reply-mode-map [menu-bar] (make-sparse-keymap)) - (define-key news-reply-mode-map [menu-bar fields] - (cons "Fields" (make-sparse-keymap "Fields"))) - (define-key news-reply-mode-map [menu-bar fields news-reply-distribution] - '("Distribution" . news-reply-distribution)) - (define-key news-reply-mode-map [menu-bar fields news-reply-keywords] - '("Keywords" . news-reply-keywords)) - (define-key news-reply-mode-map [menu-bar fields news-reply-newsgroups] - '("Newsgroups" . news-reply-newsgroups)) - (define-key news-reply-mode-map [menu-bar fields news-reply-followup-to] - '("Followup-to" . news-reply-followup-to)) - (define-key news-reply-mode-map [menu-bar fields mail-subject] - '("Subject" . mail-subject)) - (define-key news-reply-mode-map [menu-bar fields news-reply-summary] - '("Summary" . news-reply-summary)) - (define-key news-reply-mode-map [menu-bar fields mail-text] - '("Text" . mail-text)) - (define-key news-reply-mode-map [menu-bar news] - (cons "News" (make-sparse-keymap "News"))) - (define-key news-reply-mode-map [menu-bar news news-caesar-buffer-body] - '("Rot13" . news-caesar-buffer-body)) - (define-key news-reply-mode-map [menu-bar news news-reply-yank-original] - '("Yank Original" . news-reply-yank-original)) - (define-key news-reply-mode-map [menu-bar news mail-fill-yanked-message] - '("Fill Yanked Messages" . mail-fill-yanked-message)) - (define-key news-reply-mode-map [menu-bar news news-inews] - '("Send" . news-inews)))) - -(defun news-reply-mode () - "Major mode for editing news to be posted on USENET. -First-time posters are asked to please read the articles in newsgroup: - news.announce.newusers . -Like Text Mode but with these additional commands: - -C-c C-s news-inews (post the message) C-c C-c news-inews -C-c C-f move to a header field (and create it if there isn't): - C-c C-f C-n move to Newsgroups: C-c C-f C-s move to Subj: - C-c C-f C-f move to Followup-To: C-c C-f C-k move to Keywords: - C-c C-f C-d move to Distribution: C-c C-f C-a move to Summary: -C-c C-y news-reply-yank-original (insert current message, in NEWS). -C-c C-q mail-fill-yanked-message (fill what was yanked). -C-c C-r caesar rotate all letters by 13 places in the article's body (rot13)." - (interactive) - (kill-all-local-variables) - (make-local-variable 'mail-reply-buffer) - (setq mail-reply-buffer nil) - (set-syntax-table text-mode-syntax-table) - (use-local-map news-reply-mode-map) - (setq local-abbrev-table text-mode-abbrev-table) - (setq major-mode 'news-reply-mode) - (setq mode-name "News Reply") - (make-local-variable 'paragraph-separate) - (make-local-variable 'paragraph-start) - (run-hooks 'text-mode-hook 'news-reply-mode-hook)) - -(defvar news-reply-yank-from "" - "Save `From:' field for `news-reply-yank-original'.") - -(defvar news-reply-yank-message-id "" - "Save `Message-Id:' field for `news-reply-yank-original'.") - -(defun news-reply-yank-original (arg) - "Insert the message being replied to, if any (in Mail mode). -Puts point before the text and mark after. -Indents each nonblank line ARG spaces (default 3). -Just \\[universal-argument] as argument means don't indent -and don't delete any header fields." - (interactive "P") - (mail-yank-original arg) - (exchange-point-and-mark) - (run-hooks 'news-reply-header-hook)) - -(defvar news-reply-header-hook - (lambda () - (insert "In article " news-reply-yank-message-id - " " news-reply-yank-from " writes:\n\n")) - "Hook for inserting a header at the top of a yanked message.") - -(defun news-reply-newsgroups () - "Move point to end of `Newsgroups:' field. -RFC 850 constrains the `Newsgroups:' field to be a comma-separated list -of valid newsgroup names at your site. For example, - Newsgroups: news.misc,comp.misc,rec.misc" - (interactive) - (expand-abbrev) - (goto-char (point-min)) - (mail-position-on-field "Newsgroups")) - -(defun news-reply-followup-to () - "Move point to end of `Followup-To:' field. Create the field if none. -One usually requests followups to only one newsgroup. -RFC 850 constrains the `Followup-To:' field to be a comma-separated list -of valid newsgroups names at your site, and it must be a subset of the -`Newsgroups:' field. For example: - Newsgroups: news.misc,comp.misc,rec.misc,misc.misc,soc.misc - Followup-To: news.misc,comp.misc,rec.misc" - (interactive) - (expand-abbrev) - (or (mail-position-on-field "Followup-To" t) - (progn (mail-position-on-field "newsgroups") - (insert "\nFollowup-To: "))) - ;; @@ could do a completing read based on the Newsgroups: field to - ;; @@ fill in the Followup-To: field -) - -(defun news-reply-distribution () - "Move point to end of `Distribution:' optional field. -Create the field if none. Without this field the posting goes to all of -USENET. The field is used to restrict the posting to parts of USENET." - (interactive) - (expand-abbrev) - (mail-position-on-field "Distribution") - ;; @@could do a completing read based on the news library file: - ;; @@ ../distributions to fill in the field. - ) - -(defun news-reply-keywords () - "Move point to end of `Keywords:' optional field. Create the field if none. -Used as an aid to the news reader, it can contain a few, well selected keywords -identifying the message." - (interactive) - (expand-abbrev) - (mail-position-on-field "Keywords")) - -(defun news-reply-summary () - "Move point to end of `Summary:' optional field. Create the field if none. -Used as an aid to the news reader, it can contain a succinct -summary (abstract) of the message." - (interactive) - (expand-abbrev) - (mail-position-on-field "Summary")) - -(defun news-reply-signature () - "The inews program appends `~/.signature' automatically." - (interactive) - (message "Posting news will append your signature automatically.")) - -(defun news-setup (to subject in-reply-to newsgroups replybuffer) - "Set up the news reply or posting buffer with the proper headers and mode." - (setq mail-reply-buffer replybuffer) - (let ((mail-setup-hook nil) - ;; Avoid inserting a signature. - (mail-signature)) - (if (null to) - ;; this hack is needed so that inews wont be confused by - ;; the fcc: and bcc: fields - (let ((mail-self-blind nil) - (mail-archive-file-name nil)) - (mail-setup to subject in-reply-to nil replybuffer nil) - (beginning-of-line) - (delete-region (point) (progn (forward-line 1) (point))) - (goto-char (point-max))) - (mail-setup to subject in-reply-to nil replybuffer nil)) - ;;;(mail-position-on-field "Posting-Front-End") - ;;;(insert (emacs-version)) - (goto-char (point-max)) - (if (let ((case-fold-search t)) - (re-search-backward "^Subject:" (point-min) t)) - (progn (beginning-of-line) - (insert "Newsgroups: " (or newsgroups "") "\n") - (if (not newsgroups) - (backward-char 1) - (goto-char (point-max))))) - (let (actual-header-separator) - (rfc822-goto-eoh) - (setq actual-header-separator (buffer-substring - (point) - (save-excursion (end-of-line) (point)))) - (setq paragraph-start - (concat "^" actual-header-separator "$\\|" paragraph-start)) - (setq paragraph-separate - (concat "^" actual-header-separator "$\\|" paragraph-separate))) - (run-hooks 'news-setup-hook))) - -(defun news-inews () - "Send a news message using inews." - (interactive) - (let* (newsgroups subject - (case-fold-search nil)) - (save-excursion - (save-restriction - (narrow-to-region (point-min) (mail-header-end)) - (setq newsgroups (mail-fetch-field "newsgroups") - subject (mail-fetch-field "subject"))) - (widen) - (goto-char (point-min)) - (run-hooks 'news-inews-hook) - (mail-sendmail-undelimit-header) - (goto-char (point-max)) - ;; require a newline at the end for inews to append .signature to - (or (= (preceding-char) ?\n) - (insert ?\n)) - (message "Posting to USENET...") - (unwind-protect - (if (not (eq 0 - (call-process-region (point-min) (point-max) - news-inews-program nil 0 nil - "-h"))) ; take all header lines! - ;@@ setting of subject and newsgroups still needed? - ;"-t" subject - ;"-n" newsgroups - (error "Posting to USENET failed") - (message "Posting to USENET... done")) - (mail-sendmail-delimit-header) - (set-buffer-modified-p nil))) - (bury-buffer))) - -;@@ shares some code with news-reply and news-post-news -(defun news-mail-reply () - "Mail a reply to the author of the current article. -While composing the reply, use \\[news-reply-yank-original] to yank the -original message into it." - (interactive) - (let (from cc subject date to reply-to message-id - (buffer (current-buffer))) - (save-restriction - (narrow-to-region (point-min) (progn (goto-line (point-min)) - (search-forward "\n\n") - (- (point) 1))) - (setq from (mail-fetch-field "from") - subject (mail-fetch-field "subject") - reply-to (mail-fetch-field "reply-to") - date (mail-fetch-field "date") - message-id (mail-fetch-field "message-id"))) - (setq to from) - (pop-to-buffer "*mail*") - (mail nil - (if reply-to reply-to to) - subject - (let ((stop-pos (string-match " *at \\| *@ \\| *(\\| *<" from))) - (concat (if stop-pos (substring from 0 stop-pos) from) - "'s message " - (if message-id - (concat message-id " of ") - "of ") - date)) - nil - buffer))) - -;@@ the guts of news-reply and news-post-news should be combined. -tower -(defun news-reply () - "Compose and post a reply (aka a followup) to the current article on USENET. -While composing the followup, use \\[news-reply-yank-original] to yank the -original message into it." - (interactive) - (if (y-or-n-p "Are you sure you want to followup to all of USENET? ") - (let (from cc subject date to followup-to newsgroups message-of - references distribution message-id - (buffer (current-buffer))) - (save-restriction - (and (not (= 0 (buffer-size))) ;@@real problem is non-existence of - ;@@ of article file - (equal major-mode 'news-mode) ;@@ if rmail-mode, - ;@@ should show full headers - (progn - (news-show-all-headers) ;@@ should save/restore header state, - ;@@ but rnews.el lacks support - (narrow-to-region (point-min) (progn (goto-char (point-min)) - (search-forward "\n\n") - (- (point) 1))))) - (setq from (mail-fetch-field "from") - news-reply-yank-from from - ;; @@ not handling old Title: field - subject (mail-fetch-field "subject") - date (mail-fetch-field "date") - followup-to (mail-fetch-field "followup-to") - newsgroups (or followup-to - (mail-fetch-field "newsgroups")) - references (mail-fetch-field "references") - ;; @@ not handling old Article-I.D.: field - distribution (mail-fetch-field "distribution") - message-id (mail-fetch-field "message-id") - news-reply-yank-message-id message-id) - (pop-to-buffer "*post-news*") - (news-reply-mode) - (if (and (buffer-modified-p) - (not - (y-or-n-p "Unsent article being composed; erase it? "))) - () - (progn - (erase-buffer) - (and subject - (progn (if (string-match "\\`Re: " subject) - (while (string-match "\\`Re: " subject) - (setq subject (substring subject 4)))) - (setq subject (concat "Re: " subject)))) - (and from - (progn - (let ((stop-pos - (string-match " *at \\| *@ \\| *(\\| *<" from))) - (setq message-of - (concat - (if stop-pos (substring from 0 stop-pos) from) - "'s message " - (if message-id - (concat message-id " of ") - "of ") - date))))) - (news-setup - nil - subject - message-of - newsgroups - buffer) - (if followup-to - (progn (news-reply-followup-to) - (insert followup-to))) - (if distribution - (progn - (mail-position-on-field "Distribution") - (insert distribution))) - (mail-position-on-field "References") - (if references - (insert references)) - (if (and references message-id) - (insert " ")) - (if message-id - (insert message-id)) - (goto-char (point-max)))))) - (message ""))) - -;@@ the guts of news-reply and news-post-news should be combined. -tower -;;;###autoload -(defun news-post-news (&optional noquery) - "Begin editing a new USENET news article to be posted. -Type \\[describe-mode] once editing the article to get a list of commands. -If NOQUERY is non-nil, we do not query before doing the work." - (interactive) - (if (or noquery - (y-or-n-p "Are you sure you want to post to all of USENET? ")) - (let ((buffer (current-buffer))) - (save-restriction - (and (not (= 0 (buffer-size))) ;@@real problem is non-existence of - ;@@ of article file - (equal major-mode 'news-mode) ;@@ if rmail-mode, - ;@@ should show full headers - (progn - (news-show-all-headers) ;@@ should save/restore header state, - ;@@ but rnews.el lacks support - (narrow-to-region (point-min) (progn (goto-char (point-min)) - (search-forward "\n\n") - (- (point) 1))))) - (setq news-reply-yank-from (mail-fetch-field "from") - ;; @@ not handling old Article-I.D.: field - news-reply-yank-message-id (mail-fetch-field "message-id"))) - (pop-to-buffer "*post-news*") - (news-reply-mode) - (if (and (buffer-modified-p) - (not (y-or-n-p "Unsent article being composed; erase it? "))) - () ;@@ not saving point from last time - (progn (erase-buffer) - (news-setup () () () () buffer)))) - (message ""))) - -(defun news-mail-other-window () - "Send mail in another window. -While composing the message, use \\[news-reply-yank-original] to yank the -original message into it." - (interactive) - (mail-other-window nil nil nil nil nil (current-buffer))) - -(provide 'rnewspost) - -;;; rnewspost.el ends here diff -r 3168ff2c349b -r 5c3a343fb1ce lisp/obsolete/hilit19.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/obsolete/hilit19.el Thu Jan 04 19:21:36 2001 +0000 @@ -0,0 +1,1515 @@ +;;; hilit19.el --- customizable highlighting for Emacs19 + +;; Copyright (c) 1993, 1994 Free Software Foundation, Inc. + +;; Author: Jonathan Stigelman +;; Maintainer: FSF +;; (actually no longer maintained) +;; Keywords: faces + +;; This file is part of GNU Emacs. + +;; GNU Emacs 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. + +;; 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 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: + +;; Hilit19.el is a customizable highlighting package for Emacs19. It supports +;; not only source code highlighting, but also Info, RMAIL, VM, gnus... +;; Hilit19 knows (or thinks it knows) how to highlight emacs buffers in +;; about 25 different modes. +;; +;; WHERE TO GET THE LATEST VERSIONS OF HILIT19.EL (beta and release): +;; +;; http://hackvan.com/pub/stig/src/elisp/ +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; TO SUBMIT BUG REPORTS (or feedback of any sort)... +;; +;; M-x hilit-submit-feedback RET +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; hilit19.el,v 2.19 1993/09/08 18:44:10 stig Release +;; +;; LCD Archive Entry: +;; hilit19|Jonathan Stigelman|stig@hackvan.com| +;; Comprehensive (and comparatively fast) regex-based highlighting for Emacs 19| +;; 1993/09/08 18:44:10|Release 2.19|~/packages/hilit19.el.Z| +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; GENERAL OVERVIEW +;; +;; This package installs numerous hooks to colorfully highlight your +;; source code buffers as well as mail and news buffers. Most +;; programming languages have predefined highlighting patterns. +;; Just load hilit19 and files will be automatically highlighted as +;; they're loaded. +;; +;; Rehighlight a buffer by typing C-S-l (control-shift-lowercase-L). +;; +;; If, when you edit the buffer, the coloring gets messed up, just +;; redraw and the coloring will be adjusted. If automatic highlighting +;; in the current buffer has been turned off, then typing C-u C-S-l will +;; force a rehighlight of the entire buffer. +;; +;; Hilit19 can build faces by examining the names that you give to them +;; For example, green/black-bold-italic-underline would be created as +;; a face with a green foreground, and a black background, using a +;; bold-italic font...with underlining for good measure. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; SETUP -- In your .emacs: +;; +;; +;; (cond (window-system +;; (setq hilit-mode-enable-list '(not text-mode) +;; hilit-background-mode 'light +;; hilit-inhibit-hooks nil +;; hilit-inhibit-rebinding nil) +;; +;; (require 'hilit19) +;; )) +;; +;; If you like font-lock-mode and want to use both packages, then you can +;; disable hilit for the modes in which you want to use font-lock by listing +;; said modes in hilit-mode-enable-list. +;; +;; (hilit-translate type 'RoyalBlue ; enable highlighting in C/C++ +;; string nil) ; disable string highlighting +;; +;; To get 100% of the utility of hilit19, you may also have to apply the +;; patches below for info.el and vm5.33L_19/vm-summary.el +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; SETUP -- Are you using the right font for Emacs? +;; +;; Emacs cannot properly find bold and italic fonts unless you specify a +;; verbose X11 font name. If you specify a font for emacs in your +;; .Xdefaults, it *MUST* be specified using the long form of the font name. +;; Here's a good font menu: +;; +;; (setq +;; x-fixed-font-alist +;; '("Font Menu" +;; ("Misc" +;; ("6x12" "-misc-fixed-medium-r-semicondensed--12-110-75-75-c-60-*-1") +;; ("6x13" "-misc-fixed-medium-r-semicondensed--13-120-75-75-c-60-*-1") +;; ("lucida 13" +;; "-b&h-lucidatypewriter-medium-r-normal-sans-0-0-0-0-m-0-*-1") +;; ("7x13" "-misc-fixed-medium-r-normal--13-120-75-75-c-70-*-1") +;; ("7x14" "-misc-fixed-medium-r-normal--14-130-75-75-c-70-*-1") +;; ("9x15" "-misc-fixed-medium-r-normal--15-140-*-*-c-*-*-1") +;; ("") +;; ("clean 8x8" "-schumacher-clean-medium-r-normal--*-80-*-*-c-*-*-1") +;; ("clean 8x14" "-schumacher-clean-medium-r-normal--*-140-*-*-c-*-*-1") +;; ("clean 8x10" "-schumacher-clean-medium-r-normal--*-100-*-*-c-*-*-1") +;; ("clean 8x16" "-schumacher-clean-medium-r-normal--*-160-*-*-c-*-*-1") +;; ("") +;; ("sony 8x16" "-sony-fixed-medium-r-normal--16-120-100-100-c-80-*-1") +;; ("") +;; ("-- Courier --") +;; ("Courier 10" "-adobe-courier-medium-r-normal--*-100-*-*-m-*-*-1") +;; ("Courier 12" "-adobe-courier-medium-r-normal--*-120-*-*-m-*-*-1") +;; ("Courier 14" "-adobe-courier-medium-r-normal--*-140-*-*-m-*-*-1") +;; ("Courier 18" "-adobe-courier-medium-r-normal--*-180-*-*-m-*-*-1") +;; ("Courier 18-b" "-adobe-courier-bold-r-normal--*-180-*-*-m-*-*-1") +;; ))) +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; KNOWN BUGS/TO DO LIST/HELP WANTED/APPLY WITHIN +;; +;; * unbalanced, unescaped double quote characters can confuse hilit19. +;; This will be fixed someday, so don't bug me about it. +;; +;; * ALTHOUGH HILIT19 IS FASTER THAN FONT-LOCK-MODE... +;; For various reasons, the speed of the package could still stand to be +;; improved. If you care to do a little profiling and make things tighter... +;; +;; * hilit-toggle-highlight is flaky when auto-rehighlight is neither t nor nil. +;; Does anyone actually USE this? I think I might just remove it. +;; +;; PROJECTS THAT YOU CAN TAKE OVER BECAUSE I DON'T MUCH CARE ABOUT THEM... +;; +;; * Moved hilit-wysiwyg-replace here from my version of man.el, this is not +;; a bug. The bug is that I don't have a reverse operation yet...just a +;; stub Wysiwyg-anything really belongs in a package of its own. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Thanks to the following people for their input: +;; ebert@enpc.enpc.fr (Rolf EBERT), ada, LaTeX & bibtex highlights +;; Vivek Khera , gnus hooks + random advice & patches +;; brian@athe.WUstl.EDU (Brian Dunford-Shore), prolog highlights +;; John Ladwig , 1st pass nroff highlights +;; campo@sunthpi3.difi.unipi.it (Massimo Campostrini), fortran highlights +;; jayb@laplace.MATH.ColoState.EDU (Jay Bourland), 1st pass dired +;; Yoshio Turner , modula 2 highlights +;; Fritz Knabe , advice & patches +;; Alon Albert , advice & patches +;; dana@thumper.bellcore.com (Dana A. Chee), working on the multi-frame bug +;; derway@ndc.com (Don Erway), for breaking it... +;; moss_r@summer.chem.su.oz.au (Richard Moss), first pass at add-pattern +;; Olivier Lecarme , Pascal & Icon patterns +;; +;; With suggestions and minor regex patches from numerous others... +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; hilit19.el,v +;; Revision 2.19 1993/09/08 18:44:10 stig +;; installed patch for elusive bug in hilit-rehighlight-region that caused +;; hilit-unhighlight-region to hang in an infinite loop. +;; +;; Revision 2.18 1993/08/27 03:51:00 stig +;; minor mods to lisp-mode and c/c++ mode patterns +;; +;; Revision 2.17 1993/08/25 02:19:17 stig +;; work-around for bug in next-overlay-change that caused dired and jargon-mode +;; to hang in an endless loop. Perhaps other modes were doing this too. +;; +;; Revision 2.16 1993/08/22 19:46:00 stig +;; bug fix for next-overlay-change and accompanying change to +;; hilit-unhighlight-region +;; +;; Revision 2.15 1993/08/20 12:16:22 stig +;; minor change to fortran patterns +;; +;; Revision 2.14 1993/08/17 14:12:10 stig +;; added default face mapping for 'formula' which is needed for new latex +;; patterns. +;; +;; twiddled the calendar-mode patterns a bit. +;; +;; Revision 2.13 1993/08/16 04:33:54 stig +;; hilit-set-mode-patterns was screwing up two part patterns. it doesn't now. +;; +;; Revision 2.12 1993/08/16 00:16:41 stig +;; changed references to default-bold-italic to just bold-italic because the +;; font for that face is maintained by emacs. +;; +;; the pattern matcher now starts its searches from the end of the most +;; recently highlighted region (which is not necessarily the end of the most +;; recently matched regex). +;; +;; multiple errors in pattern matcher now just give an error instead of lots of +;; annoying messages and dings. +;; +;; no longer use vm-summary-mode-hooks. +;; +;; some code moved from hilit-highlight-region to hilit-set-mode-patterns. +;; This will affect you if you pass your patterns directly to +;; hilit-highlight-region....use a pseudo-mode instead. +;; +;; pattern changes to C/C++, latex, texinfo, fortran, nroff, etc. +;; +;; Revision 2.11 1993/08/13 12:12:37 stig +;; removed some crufty commented-out code +;; +;; diverged lisp-mode and emacs-lisp-mode...also added lisp keywords. +;; +;; Revision 2.10 1993/08/13 09:47:06 stig +;; added calendar-mode, icon-mode and pascal-mode patterns +;; +;; commented out hilit-toggle-highlight because I want to phase it out entirely +;; +;; Revision 2.9 1993/08/13 08:44:22 stig +;; added optional case-fold argument to hilit-set-mode-patterns, this case-fold +;; parameter is now stored in hilit-patterns-alist. +;; +;; Revision 2.8 1993/08/12 22:05:03 stig +;; fixed some typos in documentation +;; +;; twiddled some of the color defaults for dark backgrounds +;; +;; always get 'mono color defaults if (not (x-display-color-p)) +;; +;; added hilit-rehighlight-buffer-quietly to dired-after-readin-hook +;; +;; fixed bug in hilit-string-find that mishandled strings of the form: "\\" +;; +;; NEW FUNCTION: hilit-add-mode-pattern... kinda like add-hook for patterns +;; +;; fixed minor pattern bugs for latex-mode and emacs-lisp-mode +;; +;; Revision 2.7 1993/07/30 02:43:01 stig +;; added const to the list of modifiers for C/C++ types +;; +;; Revision 2.6 1993/07/30 00:30:54 stig +;; now permit selection of arbitrary subexpressions for highlighting... +;; fixed keyword patterns for C/C++ using this technique. +;; +;; Revision 2.5 1993/07/28 05:02:56 stig +;; improvements to makefile regular expressions +;; removed about 130 lines just by compacting the big defconst for +;; hilit-face-translation-table into a mapcar and defining a separate table +;; of default faces. +;; +;; Revision 2.4 1993/07/27 14:09:05 stig +;; documented another "known problem" to "head off gripe mail at the pass." +;; +;; Revision 2.3 1993/07/27 02:15:49 stig +;; (hilit-lookup-face-create) incorporated patch which improves its behavior +;; with more than one frame... Still can't have bold on the same face in two +;; different fonts sizes at the same time... +;; +;; Revision 2.2 1993/07/27 02:02:59 stig +;; vastly improved the makefile patterns +;; added hook for mh-show-mode +;; +;; Revision 2.1 1993/07/24 17:46:21 stig +;; Phasing out Info-select-hook... Version 19.18 will use Info-selection-hook. +;; +;; Revision 2.0 1993/07/24 13:50:10 stig +;; better documentation and added the function hilit-submit-feedback. +;; C-S-l (control shift l) repaints the buffer. Other bindings are optional. +;; multi-line highlights no longer cause problems when +;; hilit-auto-rehighlight is 'visible +;; added hilit-predefined-face-list... +;; changed name of hilit-mode-alist to hilit-patterns-alist +;; added hilit-message-quietly to mail-setup-hook +;; added hilit-parser-alist which can be used to apply different patterns to +;; different parts of a buffer. This could be integrated in a far more +;; elegant manner, but it presently serves the purpose of not applying +;; message header patterns to message bodies in mail-mode and its kin. +;; hilit-set-mode-patterns now takes a list of modes and an optional parse-fn +;; + +;;;;;; AND THIS CAN BE APPLIED TO VM 5.33L_19 +;; +;; *** ../site/vm5.33L_19/vm-summary.el Fri Jun 4 22:17:11 1993 +;; --- ./vm-summary.el Tue Jun 22 16:39:30 1993 +;; *************** +;; *** 152,158 **** +;; (insert "->") +;; (delete-char 2) +;; (forward-char -2) +;; ! (and w vm-auto-center-summary (vm-auto-center-summary)))) +;; (and old-window (select-window old-window))))))) +;; +;; (defun vm-mark-for-display-update (message) +;; --- 152,159 ---- +;; (insert "->") +;; (delete-char 2) +;; (forward-char -2) +;; ! (and w vm-auto-center-summary (vm-auto-center-summary)) +;; ! (run-hooks 'vm-summary-pointer-hook))) +;; (and old-window (select-window old-window))))))) +;; +;; (defun vm-mark-for-display-update (message) +;; +;;;;;; + +;;; Code: + +;; User Options: + +(defvar hilit-quietly nil + "* If non-nil, this inhibits progress indicators during highlighting") + +(defvar hilit-auto-highlight t + "* T if we should highlight all buffers as we find 'em, nil to disable + automatic highlighting by the find-file hook.") + +(defvar hilit-auto-highlight-maxout 60000 ; hilit19 keeps getting bigger... + "* auto-highlight is disabled in buffers larger than this") + +(defvar hilit-auto-rehighlight t + "* If this is non-nil, then hilit-redraw and hilit-recenter will also + rehighlight part or all of the current buffer. T will rehighlight the + whole buffer, a NUMBER will rehighlight that many lines before and after + the cursor, and the symbol 'visible' will rehighlight only the visible + portion of the current buffer. This variable is buffer-local.") + +(make-variable-buffer-local 'hilit-auto-rehighlight) + +(defvar hilit-auto-rehighlight-fallback '(20000 . 100) + "* Cons of the form (THRESHOLD . FALLBACK), where FALLBACK is assigned to + hilit-auto-rehighlight if the size of a newly opened buffer is larger than + THRESHOLD.") + +(defvar hilit-face-check t + "* T slows down highlighting but permits the user to change fonts without + losing bold and italic faces... T causes hilit-lookup-face-create to dig + through the frame parameters for the current window every time it's called. + If you never change fonts in emacs, set this to NIL.") + +;; Variables which must be set before loading hilit19. + +(defvar hilit-inhibit-rebinding nil + "If non-nil, this inhibits replacement of recenter, yank, and yank-pop.") + +(defvar hilit-inhibit-hooks nil + "If non-nil, this inhibits installation of hooks for Info, gnus, & vm.") + +(defvar hilit-background-mode 'light + "'mono inhibits color, 'dark or 'light indicate the background brightness.") + +(defvar hilit-mode-enable-list nil + "If a list of modes to exclusively enable or specifically disable. +The sense of the list is negated if it begins with the symbol 'not'. +Set this variable before you load hilit19. + +Ex: (perl-mode jargon-mode c-mode) ; just perl, C, and jargon modes + (not text-mode) ; all modes except text mode") + +;; Variables that are not generally modified directly + +(defvar hilit-parser-alist nil + "alist of major-mode values and parsers called by hilit-rehighlight-buffer. + +Parsers for a given mode are IGNORED for partial rehighlights...maybe you'd +like to make this more universal?") + +(defvar hilit-patterns-alist nil + "alist of major-mode values and default highlighting patterns + +A highlighting pattern is a list of the form (start end face), where +start is a regex, end is either a regex or a match number for start, and face +is the name of an entry in hilit-face-translation-table, the name of a face, +or nil (which disables the pattern). + +Each entry in the alist is of the form: + (mode . (case-fold pattern [pattern ...])) + +See the hilit-lookup-face-create documentation for valid face names.") + +(defvar hilit-predefined-face-list (face-list) + "List of faces with which hilit-lookup-face-create will NOT tamper. + +If hilit19 is dumped into emacs at your site, you may have to set this in +your init file.") + +(eval-when-compile (setq byte-optimize t)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Use this to report bugs: + +(eval-when-compile (require 'reporter)) ; no compilation gripes + +(defun hilit-submit-feedback () + "Submit feedback on hilit19 to hilit@hackvan.com" + (interactive) + (require 'reporter) + (and (y-or-n-p "Do you really want to submit a report on hilit19? ") + (reporter-submit-bug-report + "Jonathan Stigelman " + "hilit19.el (Release 2.19)" + (and (y-or-n-p "Do you need to include a dump hilit variables? ") + (append + '( + hilit-quietly hilit-inhibit-hooks + hilit-background-mode hilit-mode-enable-list + hilit-auto-highlight hilit-auto-highlight-maxout + hilit-auto-rehighlight hilit-auto-rehighlight-fallback + hilit-face-check + ) + (and (y-or-n-p "Have you modified the standard patterns? ") + (yes-or-no-p "Are your patterns *REALLY* relevant? ") + '(hilit-parser-alist + hilit-patterns-alist + hilit-predefined-face-list + )))) + (function + (lambda () + (and (y-or-n-p "Is this a problem with font display? ") + (insert "\nFrame Configuration:\n====================\n" + (prin1-to-string (frame-configuration-to-register ?F)) + "\n" + )))) + nil + (concat + "This is (check all that apply, and delete what's irrelevant):\n" + " [ ] a _MASSIVE_THANK_YOU_ for writing hilit19.el\n" + " [ ] An invitation to attend the next Hackers Conference\n" + " [ ] You're a RIGHTEOUS HACKER, what are your rates?\n" + " [ ] I've used the force and read the source, but I'M CONFUSED\n" + " [ ] a PATCH. (output of 'diff -uw old.el new.el' or 'diff -cw')\n" + " [ ] a SERIOUS AND REPRODUCIBLE BUG that is not an EMACS bug\n" + " - I *swear* that it's not already mentioned in the KNOWN BUGS\n" + " - I HAVE CHECKED ftp.hackvan.com:/pub/stig/src/elisp/hilit19.el.gz\n" + " for a newer release that fixes the problem.\n" + " >> I HAVE ALSO CHECKED ftp.hackvan.com:/pub/stig/src/elisp/hl319.el.gz\n" + " This is the alpha version...what will become hilit19 (Beta 3.0).\n" + "\n" + "Hey Stig, I *know* you're busy but...\n")))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; These faces are either a valid face name, or nil +;; if you want to change them, you must do so AFTER hilit19 is loaded + +(defconst hilit-default-face-table + '( + ;; used for C/C++ and Emacs Lisp and perl + (comment firebrick-italic moccasin italic) + (include purple Plum1 bold-italic) + (define ForestGreen-bold green bold) + (defun blue-bold cyan-bold bold-italic) + (decl RoyalBlue cyan bold) + (type nil yellow nil) + (keyword RoyalBlue cyan bold-italic) + (label red-underline orange-underlined underline) + (string grey40 orange underline) + + ;; some further faces for Ada + (struct black-bold white-bold bold) + (glob-struct magenta Plum1 default-bold-underline) + (named-param DarkGoldenrod Goldenrod underline) + + ;; and another one for LaTeX + (crossref DarkGoldenrod Goldenrod underline) + (formula Goldenrod DarkGoldenrod underline) + + ;; compilation buffers + (active-error default/pink-bold default/DeepPink-bold default-underline) + (error red-bold yellow bold) + (warning blue-italic green italic) + + ;; Makefiles (some faces borrowed from C/C++ too) + (rule blue-bold-underline cyan-underline default-bold-underline) + + ;; VM, GNUS and Text mode + (msg-subject blue-bold yellow bold) + (msg-from purple-bold green bold) + (msg-header firebrick-bold cyan italic) + (msg-separator black/tan-bold black/lightblue nil) + (msg-quote ForestGreen pink italic) + + (summary-seen grey40 white nil) + (summary-killed grey50 white nil) + (summary-Xed OliveDrab2 green nil) + (summary-deleted firebrick white italic) + (summary-unread RoyalBlue yellow bold) + (summary-new blue-bold yellow-bold bold-italic) + (summary-current default/skyblue-bold green/dimgrey-bold reverse-default) + + (gnus-group-unsubscribed grey50 white nil) + (gnus-group-empty nil nil nil) + (gnus-group-full ForestGreen green italic) + (gnus-group-overflowing firebrick red bold-italic) + + ;; dired mode + (dired-directory blue-bold cyan bold) + (dired-link firebrick-italic green italic) + (dired-ignored ForestGreen moccasin nil) + (dired-deleted red-bold-italic orange bold-italic) + (dired-marked purple Plum1 nil) + + ;; Info-mode, and jargon-mode.el and prep.ai.mit.edu:/pub/gnu/jargon* + (jargon-entry blue-bold cyan bold) + (jargon-xref purple-bold Plum1 italic) + (jargon-keyword firebrick-underline yellow underline) + ) + "alist of default faces (face . (light-default dark-default mono-default)) + +There is no way for the user to modify this table such that it will have any +effect upon the translations used by hilit19. Instead, use the function +hilit-translate AFTER hilit19 has been loaded. + +See also the documentation for hilit-lookup-face-create.") + +(defconst hilit-face-translation-table + (let ((index (or (and (x-display-color-p) + (cdr (assq hilit-background-mode + '((light . 1) (dark . 2))))) + 3))) + (mapcar (function (lambda (x) (cons (car x) (nth index x)))) + hilit-default-face-table)) + "alist that maps symbolic face-names to real face names") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; To translate one face to another... +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defmacro hilit-translate (&rest args) + "(hilit-translate FROM TO FROM TO ...): translate each face FROM to the +value of its TO face. This is like setq for faces. + +The function hilit-lookup-face-create will repeatedly translate until no more +translations for the face exist in the translation table. + +See the documentation for hilit-lookup-face-create for names of valid faces." + (or (zerop (% (length args) 2)) + (error "wrong number of args")) + (let (cmdl from to) + (while args + (setq from (car args) to (nth 1 args) args (nthcdr 2 args) + cmdl (cons (list 'hilit-associate ''hilit-face-translation-table + (list 'quote from) to) + cmdl))) + (cons 'progn cmdl))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; This function actually translates and then creates the faces... +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun hilit-lookup-face-create (face &optional force) + "Get a FACE, or create it if it doesn't exist. In order for it to +properly create the face, the following naming convention must be used: + [reverse-](fgcolor[/bgcolor])[-bold][-italic][-underline] +Example: (hilit-lookup-face-create 'comment-face) might create and return 'red + +Each color is either the name of an X color (see .../X11/lib/X11/rgb.txt), +a hexadecimal specification of the form \"hex-[0-9A-Fa-f]+\", or \"default\". + +An optional argument, FORCE, will cause the face to be recopied from the +default...which is probably of use only if you've changed fonts. + +See the documentation for hilit-translate and hilit-face-translation-table." + +;; translate the face ... + (let ((trec t) visited) + (while trec + (cond ((memq face visited) (error "face translation loop: %S" visited)) + (t (setq visited (cons face visited) + trec (assq face hilit-face-translation-table)) + (and trec (setq face (cdr trec))))))) + + ;; make the face if we need to... + (let* ((fn (symbol-name face)) + (frame (selected-frame)) + (basefont (cdr (assq 'font (frame-parameters frame)))) + error fgcolor bgcolor) + (cond + ((or (null face) + (memq face hilit-predefined-face-list)) + ;; do nothing if the face is nil or if it's predefined. + ) + ((or force + (not (memq face (face-list))) + (and hilit-face-check + (not (string= (get face 'basefont) basefont)))) + (copy-face 'default 'scratch-face) + (if (string-match "^reverse-?" fn) + (progn (invert-face 'scratch-face) + (setq fn (substring fn (match-end 0))))) + + ;; parse foreground color + (if (string-match "^\\(hex-\\)?\\([A-Za-z0-9]+\\)" fn) + (setq fgcolor (concat + (if (match-beginning 1) "#") + (substring fn (match-beginning 2) (match-end 2))) + fn (substring fn (match-end 0))) + (error "bad face name %S" face)) + + ;; parse background color + (if (string-match "^/\\(hex-\\)?\\([A-Za-z0-9]+\\)" fn) + (setq bgcolor (concat + (and (match-beginning 1) "#") + (substring fn (match-beginning 2) (match-end 2))) + fn (substring fn (match-end 0)))) + + (and (string= "default" fgcolor) (setq fgcolor nil)) + (and (string= "default" bgcolor) (setq bgcolor nil)) + + ;; catch errors if we can't allocate the color(s) + (condition-case nil + (progn (and fgcolor (set-face-foreground 'scratch-face fgcolor)) + (and bgcolor (set-face-background 'scratch-face bgcolor)) + (copy-face 'scratch-face face) + (put face 'basefont basefont)) + (error (message "couldn't allocate color for '%s'" + (symbol-name face)) + (setq face 'default) + (setq error t))) + (or error + ;; don't bother w/ bold or italic if we didn't get the color + ;; we wanted, but ignore errors making the face bold or italic + ;; if the font isn't available, there's nothing to do about it... + (progn + (set-face-font face basefont frame) + (set-face-underline-p face (string-match "underline" fn)) + (if (string-match ".*bold" fn) + ;; make face bold in all frames + (make-face-bold face nil 'noerr)) + (if (string-match ".*italic" fn) + ;; make face italic in all frames + (make-face-italic face nil 'noerr)) + )) + ))) + face) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Region Highlight/Unhighlight code (Both overlay and text-property versions) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defsubst hilit-region-set-face (start end face-name &optional prio prop) + "Highlight region from START to END using FACE and, optionally, PRIO. +The optional 5th arg, PROP is a property to set instead of 'hilit." + (let ((overlay (make-overlay start end))) + (overlay-put overlay 'face face-name) + (overlay-put overlay (or prop 'hilit) t) + (and prio (overlay-put overlay 'priority prio)))) + +(defun hilit-unhighlight-region (start end &optional quietly) + "Unhighlights the region from START to END, optionally in a QUIET way" + (interactive "r") + (or quietly hilit-quietly (message "Unhighlighting")) + (let ((lstart 0)) + (while (and start (> start lstart) (< start end)) + (mapcar (function (lambda (ovr) + (and (overlay-get ovr 'hilit) (delete-overlay ovr)))) + (overlays-at start)) + (setq lstart start start (next-overlay-change start)))) + (or quietly hilit-quietly (message "Done unhighlighting"))) + +;;;; These functions use text properties instead of overlays. Text properties +;;;; are copied through kill and yank...which might be convenient, but is not +;;;; terribly efficient as of 19.12, ERGO it's been disabled +;; +;;(defsubst hilit-region-set-face (start end face-name &optional prio prop) +;; "Highlight region from START to END using FACE and, optionally, PRIO. +;;The optional 5th arg, PROP is a property to set instead of 'hilit." +;; (put-text-property start end 'face face-name) +;; ) +;; +;;(defun hilit-unhighlight-region (start end &optional quietly) +;; "Unhighlights the region from START to END, optionally in a QUIET way" +;; (interactive "r") +;; (let ((buffer-read-only nil) +;; (bm (buffer-modified-p))) +;; (remove-text-properties start end '(face)) +;; (set-buffer-modified-p bm))) +;;;; + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Pattern Application code and user functions +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun hilit-highlight-region (start end &optional patterns quietly) + "Highlights the area of the buffer between START and END (the region when +interactive). Without the optional PATTERNS argument, the pattern for +major-mode is used. If PATTERNS is a symbol, then the patterns associated +with that symbol are used. QUIETLY suppresses progress messages if +non-nil." + (interactive "r") + (cond ((null patterns) + (setq patterns (cdr (assq major-mode hilit-patterns-alist)))) + ((symbolp patterns) + (setq patterns (cdr (assq patterns hilit-patterns-alist))))) + ;; txt prop: (setq patterns (reverse patterns)) + (let ((case-fold-search (car patterns)) + (prio (1- (length patterns))) + ;; txt prop: (buffer-read-only nil) + ;; txt prop: (bm (buffer-modified-p)) + p pstart pend face mstart (puke-count 0)) + ;; txt prop: (unwind-protect + (setq patterns (cdr patterns)) ; remove case-fold from head of pattern + (save-excursion + (save-restriction + (narrow-to-region start end) + (while patterns + (setq p (car patterns)) + (setq pstart (car p) + pend (nth 1 p) + face (hilit-lookup-face-create (nth 2 p))) + (if (not face) ; skipped if nil + nil + (or quietly hilit-quietly + (message "highlighting %d: %s%s" prio pstart + (if (stringp pend) (concat " ... " pend) ""))) + (goto-char (point-min)) + (condition-case msg + (cond + ((symbolp pstart) + ;; inner loop -- special function to find pattern + (let (region) + (while (setq region (funcall pstart pend)) + (hilit-region-set-face (car region) (cdr region) + face prio)))) + ((stringp pend) + ;; inner loop -- regex-start ... regex-end + (while (re-search-forward pstart nil t nil) + (goto-char (setq mstart (match-beginning 0))) + (if (re-search-forward pend nil t nil) + (hilit-region-set-face mstart (match-end 0) + face prio) + (forward-char 1)))) + ((numberp pend) + ;; inner loop -- just one regex to match whole pattern + (while (re-search-forward pstart nil t nil) + (goto-char (match-end pend)) + (hilit-region-set-face (match-beginning pend) + (match-end pend) face prio))) + (t (error "malformed pattern"))) + (error (if (> (setq puke-count (1+ puke-count)) 1) + (error msg) + (message "Error: '%s'" msg) + (ding) (sit-for 4))))) + (setq prio (1- prio) + patterns (cdr patterns))) + )) + (or quietly hilit-quietly (message "")) ; "Done highlighting" + ;; txt prop: (set-buffer-modified-p bm)) ; unwind protection + )) + +(defun hilit-rehighlight-region (start end &optional quietly) + "Re-highlights the region, optionally in a QUIET way" + (interactive "r") + (save-restriction + (widen) + (setq start (apply 'min start (mapcar 'overlay-start (overlays-at start))) + end (apply 'max end (mapcar 'overlay-end (overlays-at end)))) + (hilit-unhighlight-region start end quietly) + (hilit-highlight-region start end nil quietly))) + +(defun hilit-rehighlight-buffer (&optional quietly) + "Re-highlights the buffer, optionally in a QUIET way" + (interactive "") + (let ((parse-fn (cdr (assq major-mode hilit-parser-alist)))) + (if parse-fn + (funcall parse-fn quietly) + (hilit-rehighlight-region (point-min) (point-max) quietly))) + nil) + +(defun hilit-rehighlight-buffer-quietly () + (hilit-rehighlight-buffer t)) + +(defun hilit-rehighlight-message (quietly) + "Highlight a buffer containing a news article or mail message." + (save-excursion + (goto-char (point-min)) + ;; find separation between headers and body (either a blank line or + ;; the message separator line in mail-mode) + (re-search-forward "^\\(\\|--text follows this line--\\)$" nil 'noerr) + (hilit-unhighlight-region (point-min) (point-max) quietly) + (hilit-highlight-region (point-min) (point) 'msg-header quietly) + (hilit-highlight-region (point) (point-max) 'msg-body quietly))) + +(defalias 'hilit-highlight-buffer 'hilit-rehighlight-buffer) + +;; Well, I want to remove this function...there's one sure way to find out if +;; anyone uses it or not...and that's to comment it out. +;; +;; (defun hilit-toggle-highlight (arg) +;; "Locally toggle highlighting. With arg, forces highlighting off." +;; (interactive "P") +;; ;; FIXME -- this loses numeric information in hilit-auto-rehighlight +;; (setq hilit-auto-rehighlight +;; (and (not arg) (not hilit-auto-rehighlight))) +;; (if hilit-auto-rehighlight +;; (hilit-rehighlight-buffer) +;; (hilit-unhighlight-region (point-min) (point-max))) +;; (message "Rehighlighting is set to %s" hilit-auto-rehighlight)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; HOOKS +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun hilit-find-file-hook () + "Find-file hook for hilit package. See the variable hilit-auto-highlight." + (cond ((and hilit-auto-highlight + (assq major-mode hilit-patterns-alist)) + (if (> buffer-saved-size (car hilit-auto-rehighlight-fallback)) + (setq hilit-auto-rehighlight + (cdr hilit-auto-rehighlight-fallback))) + (if (> buffer-saved-size hilit-auto-highlight-maxout) + nil + (let ((bm (buffer-modified-p))) + (hilit-rehighlight-buffer) + (set-buffer-modified-p bm)))))) + +(defun hilit-repaint-command (arg) + "Rehighlights according to the value of hilit-auto-rehighlight, or the +prefix argument if that is specified. +\t\\[hilit-repaint-command]\t\trepaint according to hilit-auto-rehighlight +\t^U \\[hilit-repaint-command]\trepaint entire buffer +\t^U - \\[hilit-repaint-command]\trepaint visible portion of buffer +\t^U n \\[hilit-repaint-command]\trepaint n lines to either side of point" + (interactive "P") + (let (st en quietly) + (or arg (setq arg hilit-auto-rehighlight)) + (cond ((or (eq arg 'visible) (eq arg '-)) + (setq st (window-start) en (window-end) quietly t)) + ((numberp arg) + (setq st (save-excursion (forward-line (- arg)) (point)) + en (save-excursion (forward-line arg) (point)))) + (arg + (hilit-rehighlight-buffer))) + (if st + (hilit-rehighlight-region st en quietly)))) + +(defun hilit-recenter (arg) + "Recenter, then rehighlight according to hilit-auto-rehighlight. If called +with an unspecified prefix argument (^U but no number), then a rehighlight of +the entire buffer is forced." + (interactive "P") + (recenter arg) + ;; force display update + (sit-for 0) + (hilit-repaint-command (consp arg))) + +(defun hilit-yank (arg) + "Yank with rehighlighting" + (interactive "*P") + (let ((transient-mark-mode nil)) + (yank arg) + (and hilit-auto-rehighlight + (hilit-rehighlight-region (region-beginning) (region-end) t)) + (setq this-command 'yank))) + +(defun hilit-yank-pop (arg) + "Yank-pop with rehighlighting" + (interactive "*p") + (let ((transient-mark-mode nil)) + (yank-pop arg) + (and hilit-auto-rehighlight + (hilit-rehighlight-region (region-beginning) (region-end) t)) + (setq this-command 'yank))) + +;;; this line highlighting stuff is untested. play with it only if you feel +;;; adventurous...don't ask me to fix it...though you're welcome to. -- Stig +;; +;; (defun hilit-rehighlight-line-quietly (&rest args) +;; "Quietly rehighlight just this line. +;; Useful as an after change hook in VM/gnus summary buffers and dired buffers. +;; If only there were an after-change-function, that is..." +;; (save-excursion +;; (push-mark nil t) +;; (hilit-rehighlight-yank-region) +;; (and orig-achange-function (apply orig-achange-function args)))) +;; +;; (defun hilit-install-line-hooks () +;; (make-variable-buffer-local 'after-change-function) +;; (make-local-variable 'orig-achange-function) +;; (setq orig-achange-function after-change-function) +;; (setq after-change-function 'hilit-rehighlight-line-quietly)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Wysiwyg Stuff... take it away and build a whole package around it! +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; ; For the Jargon-impaired, WYSIWYG === What You See Is What You Get +;; ; Sure, it sucks to type. Oh, well. +;; (defun hilit-wysiwyg-replace () +;; "Replace overstruck text with normal text that's been overlaid with the +;; appropriate text attribute. Suitable for a find-file hook." +;; (save-excursion +;; (goto-char (point-min)) +;; (let ((wysb (hilit-lookup-face-create 'wysiwyg-bold)) +;; (wysu (hilit-lookup-face-create 'wysiwyg-underline)) +;; (bmod (buffer-modified-p))) +;; (while (re-search-forward "\\(.\b.\\)+" nil t) +;; (let ((st (match-beginning 0)) (en (match-end 0))) +;; (goto-char st) +;; (if (looking-at "_") +;; (hilit-region-set-face st en wysu 100 'wysiwyg) +;; (hilit-region-set-face st en wysb 100 'wysiwyg)) +;; (while (and (< (point) en) (looking-at ".\b")) +;; (replace-match "") (forward-char)) +;; )) +;; (set-buffer-modified-p bmod)))) +;; +;; ; is this more appropriate as a write-file-hook or a write-contents-hook? +;; (defun hilit-wysiwyg-write-repair () +;; "Replace wysiwyg overlays with overstrike text." +;; (message "*sigh* hilit-wysiwyg-write-repair not implemented yet") +;; +;; For efficiency, this hook should copy the current buffer to a scratch +;; buffer and do its overstriking there. Overlays are not copied, so it'll +;; be necessary to hop back and forth. This is OK since you're not fiddling +;; with--making or deleting--any overlays. THEN write the new buffer, +;; delete it, and RETURN T. << important +;; +;; Just so you know...there is already an emacs function called +;; underline-region that does underlining. I think that the thing to do is +;; extend that to do overstriking as well. +;; +;; (while (< start end) +;; (mapcar (function (lambda (ovr) +;; (and (overlay-get ovr 'hilit) (delete-overlay ovr)))) +;; (overlays-at start)) +;; (setq start (next-overlay-change start))) +;; nil) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Initialization. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(and (not hilit-inhibit-rebinding) + window-system + (progn + (substitute-key-definition 'yank 'hilit-yank + (current-global-map)) + (substitute-key-definition 'yank-pop 'hilit-yank-pop + (current-global-map)) + (substitute-key-definition 'recenter 'hilit-recenter + (current-global-map)))) + +(global-set-key [?\C-\S-l] 'hilit-repaint-command) + +(and window-system + (add-hook 'find-file-hooks 'hilit-find-file-hook t)) + +(eval-when-compile (require 'gnus)) ; no compilation gripes + +(and (not hilit-inhibit-hooks) + window-system + (condition-case c + (progn + + ;; BUFFER highlights... + (mapcar (function + (lambda (hook) + (add-hook hook 'hilit-rehighlight-buffer-quietly))) + '( + Info-selection-hook + +;; runs too early vm-summary-mode-hooks + vm-summary-pointer-hook + vm-preview-message-hook + vm-show-message-hook + + rmail-show-message-hook + mail-setup-hook + mh-show-mode-hook + + dired-after-readin-hook + )) + ) + (error (message "Error loading highlight hooks: %s" c) + (ding) (sit-for 1)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Default patterns for various modes. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; do I need this? I changed the defconst to a defvar because defconst is +;;; inappropriate, but I don't know why I wanted hilit-patterns-alist to be +;;; reset on every reload... + +(setq hilit-patterns-alist nil) + +(defun hilit-associate (alist key val) + "creates, or destructively replaces, the pair (key . val) in alist" + (let ((oldentry (assq key (eval alist)))) + (if oldentry + (setcdr oldentry val) + (set alist (cons (cons key val) (eval alist)))))) + +(defun hilit-set-mode-patterns (modelist patterns + &optional parse-fn case-fold) + "Sets the default highlighting patterns for MODE to PATTERNS. +See the variable hilit-mode-enable-list. + +Takes optional arguments PARSE-FN and CASE-FOLD." + ;; change pattern + (mapcar (function (lambda (p) + (and (stringp (car p)) + (null (nth 1 p)) + (setcar (cdr p) 0)))) + patterns) + (setq patterns (cons case-fold patterns)) + + (or (consp modelist) (setq modelist (list modelist))) + (let (ok (flip (eq (car hilit-mode-enable-list) 'not))) + (mapcar (function + (lambda (m) + (setq ok (or (null hilit-mode-enable-list) + (memq m hilit-mode-enable-list))) + (and flip (setq ok (not ok))) + (and ok + (progn + (and parse-fn + (hilit-associate 'hilit-parser-alist m parse-fn)) + (hilit-associate 'hilit-patterns-alist m patterns))))) + modelist))) + +(defun hilit-add-pattern (pstart pend face &optional mode first) + "Highlight pstart with face for the current major-mode. +Optionally, place the new pattern first in the pattern list" + (interactive "sPattern start regex: \nsPattern end regex (default none): \nxFace: ") + + (and (equal pstart "") (error "Must specify starting regex")) + (cond ((equal pend "") (setq pend 0)) + ((string-match "^[0-9]+$" pend) (setq pend (string-to-int pend)))) + (or mode (setq mode major-mode)) + (let ((old-patterns (cdr (assq mode hilit-patterns-alist))) + (new-pat (list pstart pend face))) + (cond ((not old-patterns) + (hilit-set-mode-patterns mode (list new-pat))) + (first + (setcdr old-patterns (cons new-pat (cdr old-patterns)))) + (t + (nconc old-patterns (list new-pat))))) + (and (interactive-p) (hilit-rehighlight-buffer))) + +(defun hilit-string-find (qchar) + "looks for a string and returns (start . end) or NIL. The argument QCHAR +is the character that would precede a character constant double quote. +Finds strings delimited by double quotes. The first double quote may not be +preceded by QCHAR and the closing double quote may not be preceded by an odd +number of backslashes." + (let (st en) + (while (and (search-forward "\"" nil t) + (eq qchar (char-after (1- (setq st (match-beginning 0))))))) + (while (and (search-forward "\"" nil t) + (save-excursion + (setq en (point)) + (forward-char -1) + (skip-chars-backward "\\\\") + (forward-char 1) + (not (zerop (% (- en (point)) 2)))))) + (and en (cons st en)))) + +;; return types on same line... +;; ("^[a-zA-z].*\\(\\w\\|[$_]\\)+\\s *\\(\\(\\w\\|[$_]\\)+\\s *((\\|(\\)[^)]*)+" nil defun) + +;; On another note, a working pattern for grabbing function definitions for C is +;; +;; ("^[a-zA-Z_]+.*[;{]$" nil ForestGreen) ; global defns ( start at col 1 ) +;; ("^[a-zA-Z_]+.*(" ")" defun) +;; ; defuns assumed to start at col 1, not with # or { +;; +;; this will make external declarations/definitions green, and function +;; definitions the defun face. Hmmm - seems to work for me anyway. + +(let ((comments '(("/\\*" "\\*/" comment))) + (c++-comments '(("//.*$" nil comment) + ("^/.*$" nil comment))) + (strings '((hilit-string-find ?' string))) + (preprocessor '(("^#[ \t]*\\(undef\\|define\\).*$" "[^\\]$" define) + ("^#.*$" nil include)))) + + (hilit-set-mode-patterns + '(c-mode c++-c-mode elec-c-mode) + (append + comments strings preprocessor + '( + ;; function decls are expected to have types on the previous line + ("^\\(\\w\\|[$_]\\)+\\s *\\(\\(\\w\\|[$_]\\)+\\s *((\\|(\\)[^)]*)+" nil defun) + ("^\\(typedef\\|struct\\|union\\|enum\\).*$" nil decl) + ;; datatype -- black magic regular expression + ("[ \n\t({]\\(\\(const\\|register\\|volatile\\|unsigned\\|extern\\|static\\)\\s +\\)*\\(\\(\\w\\|[$_]\\)+_t\\|float\\|double\\|void\\|char\\|short\\|int\\|long\\|FILE\\|\\(\\(struct\\|union\\|enum\\)\\([ \t]+\\(\\w\\|[$_]\\)*\\)\\)\\)\\(\\s +\\*+)?\\|[ \n\t;()]\\)" nil type) + ;; key words + ("[^_]\\<\\(return\\|goto\\|if\\|else\\|case\\|default\\|switch\\|break\\|continue\\|while\\|do\\|for\\)\\>[^_]" 1 keyword) + ))) + + (hilit-set-mode-patterns + 'c++-mode + (append + comments c++-comments strings preprocessor + '( + ;; function decls are expected to have types on the previous line + ("^\\(\\(\\w\\|[$_]\\)+::\\)?\\(\\w\\|[$_]\\)+\\s *\\(\\(\\w\\|[$_]\\)+\\s *((\\|(\\)[^)]*)+" nil defun) + ("^\\(\\(\\w\\|[$_]\\)+[ \t]*::[ \t]*\\)?\\(\\(\\w\\|[$_]\\)+\\|operator.*\\)\\s *\\(\\(\\w\\|[$_]\\)+\\s *((\\|(\\)[^)]*)+" nil defun) + ("^\\(template\\|typedef\\|struct\\|union\\|class\\|enum\\|public\\|private\\|protected\\).*$" nil decl) + ;; datatype -- black magic regular expression + ("[ \n\t({]\\(\\(const\\|register\\|volatile\\|unsigned\\|extern\\|static\\)\\s +\\)*\\(\\(\\w\\|[$_]\\)+_t\\|float\\|double\\|void\\|char\\|short\\|int\\|long\\|FILE\\|\\(\\(struct\\|union\\|enum\\|class\\)\\([ \t]+\\(\\w\\|[$_]\\)*\\)\\)\\)\\(\\s +\\*+)?\\|[ \n\t;()]\\)" nil type) + ;; key words + ("[^_]\\<\\(return\\|goto\\|if\\|else\\|case\\|default\\|switch\\|break\\|continue\\|while\\|do\\|for\\|public\\|protected\\|private\\|delete\\|new\\)\\>[^_]" + 1 keyword)))) + + (hilit-set-mode-patterns + '(objc-mode objective-C-mode) + (append + comments c++-comments strings preprocessor + '( + ;; function decls are expected to have types on the previous line + ("^\\(\\(\\w\\|[$_]\\)+::\\)?\\(\\w\\|[$_]\\)+\\s *\\(\\(\\w\\|[$_]\\)+\\s *((\\|(\\)[^)]*)+" nil defun) + ("^\\(\\(\\w\\|[$_]\\)+[ \t]*::[ \t]*\\)?\\(\\(\\w\\|[$_]\\)+\\|operator.*\\)\\s *\\(\\(\\w\\|[$_]\\)+\\s *((\\|(\\)[^)]*)+" nil defun) + + ("^\\(template\\|typedef\\|struct\\|union\\|class\\|enum\\|public\\|private\\|protected\\).*$" nil decl) + ;; datatype -- black magic regular expression + ("[ \n\t({]\\(\\(const\\|register\\|volatile\\|unsigned\\|extern\\|static\\)\\s +\\)*\\(\\(\\w\\|[$_]\\)+_t\\|float\\|double\\|void\\|char\\|short\\|int\\|long\\|FILE\\|\\(\\(struct\\|union\\|enum\\|class\\)\\([ \t]+\\(\\w\\|[$_]\\)*\\)\\)\\)\\(\\s +\\*+)?\\|[ \n\t;()]\\)" nil type) + ;; key words + ("[^_]\\<\\(return\\|goto\\|if\\|else\\|case\\|default\\|switch\\|break\\|continue\\|while\\|do\\|for\\|public\\|protected\\|private\\|interface\\|implementation\\|end\\|super\\|self\\)\\>[^_]" + 1 keyword)))) + ) + +(hilit-set-mode-patterns + 'perl-mode + '(("\\s #.*$" nil comment) + ("^#.*$" nil comment) + ("\"[^\\\"]*\\(\\\\\\(.\\|\n\\)[^\\\"]*\\)*\"" nil string) + ("^\\(__....?__\\|\\s *\\sw+:\\)" nil label) + ("^require.*$" nil include) + ("^package.*$" nil decl) + ("^\\s *sub\\s +\\(\\w\\|[_']\\)+" nil defun) + ("\\b\\(do\\|if\\|unless\\|while\\|until\\|else\\|elsif\\|for\\|foreach\\|continue\\|next\\|redo\\|last\\|goto\\|return\\|die\\|exit\\)\\b" nil keyword))) + +(hilit-set-mode-patterns + 'ada-mode + '(;; comments + ("--.*$" nil comment) + ;; main structure + ("[ \t\n]procedure[ \t]" "\\([ \t]\\(is\\|renames\\)\\|);\\)" glob-struct) + ("[ \t\n]task[ \t]" "[ \t]is" glob-struct) + ("[ \t\n]function[ \t]" "return[ \t]+[A-Za-z_0-9]+[ \t]*\\(is\\|;\\|renames\\)" glob-struct) + ("[ \t\n]package[ \t]" "[ \t]\\(is\\|renames\\)" glob-struct) + ;; if there is nothing before "private", it is part of the structure + ("^[ \t]*private[ \t\n]" nil glob-struct) + ;; if there is no indentation before the "end", then it is most + ;; probably the end of the package + ("^end.*$" ";" glob-struct) + ;; program structure -- "null", "delay" and "terminate" omitted + ("[ \n\t]\\(in\\|out\\|select\\|if\\|else\\|case\\|when\\|and\\|or\\|not\\|accept\\|loop\\|do\\|then\\|elsif\\|else\\|for\\|while\\|exit\\)[ \n\t;]" nil struct) + ;; block structure + ("[ \n\t]\\(begin\\|end\\|declare\\|exception\\|generic\\|raise\\|return\\|package\\|body\\)[ \n\t;]" nil struct) + ;; type declaration + ("^[ \t]*\\(type\\|subtype\\).*$" ";" decl) + ("[ \t]+is record.*$" "end record;" decl) + ;; "pragma", "with", and "use" are close to C cpp directives + ("^[ \t]*\\(with\\|pragma\\|use\\)" ";" include) + ;; nice for named parameters, but not so beautiful in case statements + ("[A-Za-z_0-9.]+[ \t]*=>" nil named-param) + ;; string constants probably not everybody likes this one + ("\"" ".*\"" string))) + +(hilit-set-mode-patterns + 'fortran-mode + '(("^[*Cc].*$" nil comment) + ("'[^'\n]*'" nil string) + ("\\(^[ \t]*[0-9]+\\|[ \t]continue[ \t\n]\\|format\\)" nil define) + ("[ \t]\\(do\\|do[ \t]*[0-9]+\\|go[ \t]*to[ \t]*[0-9]+\\|end[ \t]*do\\|if\\|else[ \t]*if\\|then\\|else\\|end[ \t]*if\\)[ \t\n(]" nil define) + ("[ \t]\\(call\\|program\\|subroutine\\|function\\|stop\\|return\\|end\\|include\\)[ \t\n]" nil include) + ("[ \t]\\(parameter[\t\n ]*([^)]*)\\|data\\|save\\|common[ \t\n]*/[^/]*/\\)" + nil decl) + ("^ ." nil type) + ("implicit[ \t]*none" nil decl) + ("\\([ \t]\\|implicit[ \t]*\\)\\(dimension\\|integer\\|real\\|double[ \t]*precision\\|character\\|logical\\|complex\\|double[ \t]*complex\\)\\([*][0-9]*\\|[ \t\n]\\)" nil keyword) + ) + nil 'case-insensitive) + +(hilit-set-mode-patterns + '(m2-mode modula-2-mode) + '(("(\\*" "\\*)" comment) + (hilit-string-find ?\\ string) + ("^[ \t]*PROCEDURE[ \t]+\\w+[^ \t(;]*" nil defun) + ("\\<\\(RECORD\\|ARRAY\\|OF\\|POINTER\\|TO\\|BEGIN\\|END\\|FOR\\|IF\\|THEN\\|ELSE\\|ELSIF\\|CASE\\|WHILE\\|DO\\|MODULE\\|FROM\\|RETURN\\|IMPORT\\|EXPORT\\|VAR\\|LOOP\\|UNTIL\\|\\DEFINITION\\|IMPLEMENTATION\\|AND\\|OR\\|NOT\\|CONST\\|TYPE\\|QUALIFIED\\)\\>" nil keyword) + ) + nil 'case-insensitive) + +(hilit-set-mode-patterns 'prolog-mode + '(("/\\*" "\\*/" comment) + ("%.*$" nil comment) + (":-" nil defun) + ("!" nil label) + ("\"[^\\\"]*\\(\\\\\\(.\\|\n\\)[^\\\"]*\\)*\"" nil string) + ("\\b\\(is\\|mod\\)\\b" nil keyword) + ("\\(->\\|-->\\|;\\|==\\|\\\\==\\|=<\\|>=\\|<\\|>\\|=\\|\\\\=\\|=:=\\|=\\\.\\\.\\|\\\\\\\+\\)" nil decl) + ("\\(\\\[\\||\\|\\\]\\)" nil include))) + +(hilit-set-mode-patterns + '( + LaTeX-mode japanese-LaTeX-mode SliTeX-mode + japanese-SliTeX-mode FoilTeX-mode latex-mode + ) + '( + ;; comments + ("[^\\]%.*$" nil comment) + + ;; the following two match \foo[xx]{xx} or \foo*{xx} or \foo{xx} + ("\\\\\\(sub\\)*\\(paragraph\\|section\\)\\(\*\\|\\[.*\\]\\)?{" "}" + keyword) + ("\\\\\\(chapter\\|part\\)\\(\*\\|\\[.*\\]\\)?{" "}" keyword) + ("\\\\footnote\\(mark\\|text\\)?{" "}" keyword) + ("\\\\[a-z]+box" nil keyword) + ("\\\\\\(v\\|h\\)space\\(\*\\)?{" "}" keyword) + + ;; (re-)define new commands/environments/counters + ("\\\\\\(re\\)?new\\(environment\\|command\\){" "}" defun) + ("\\\\new\\(length\\|theorem\\|counter\\){" "}" defun) + + ;; various declarations/definitions + ("\\\\\\(setlength\\|settowidth\\|addtolength\\|setcounter\\|addtocounter\\)" nil define) + ("\\\\\\(title\\|author\\|date\\|thanks\\){" "}" define) + + ("\\\\documentstyle\\(\\[.*\\]\\)?{" "}" decl) + ("\\\\\\(begin\\|end\\|nofiles\\|includeonly\\){" "}" decl) + ("\\\\\\(raggedright\\|makeindex\\|makeglossary\\|maketitle\\)\\b" nil + decl) + ("\\\\\\(pagestyle\\|thispagestyle\\|pagenumbering\\){" "}" decl) + ("\\\\\\(normalsize\\|small\\|footnotesize\\|scriptsize\\|tiny\\|large\\|Large\\|LARGE\\|huge\\|Huge\\)\\b" nil decl) + ("\\\\\\(appendix\\|tableofcontents\\|listoffigures\\|listoftables\\)\\b" + nil decl) + ("\\\\\\(bf\\|em\\|it\\|rm\\|sf\\|sl\\|ss\\|tt\\)\\b" nil decl) + + ;; label-like things + ("\\\\item\\(\\[[^]]*\\]\\)?" nil label) + ("\\\\caption\\(\\[[^]]*\\]\\)?{" "}" label) + + ;; formulas + ("[^\\]\\\\(" "\\\\)" formula) ; \( \) + ("[^\\]\\\\\\[" "\\\\\\]" formula) ; \[ \] + ("[^\\$]\\(\\$\\(\\$[^$]*\\$\\|[^$]*\\)\\$\\)" 1 formula) ; '$...$' or '$$...$$' + + ;; things that bring in external files + ("\\\\\\(include\\|input\\|bibliography\\){" "}" include) + + ;; "wysiwyg" emphasis -- these don't work with nested expressions + ;; ("{\\\\\\(em\\|it\\|sl\\)" "}" italic) + ;; ("{\\\\bf" "}" bold) + + ("``" "''" string) + + ;; things that do some sort of cross-reference + ("\\\\\\(\\(no\\)?cite\\|\\(page\\)?ref\\|label\\|index\\|glossary\\){" "}" crossref) + )) + +(hilit-set-mode-patterns + 'bibtex-mode + '(;;(";.*$" nil comment) + ("%.*$" nil comment) + ("@[a-zA-Z]+" nil keyword) + ("{[ \t]*[-a-z:_A-Z0-9]+," nil label) ; is wrong sometimes + ("^[ \t]*[a-zA-Z]+[ \t]*=" nil define))) + +(hilit-set-mode-patterns + 'compilation-mode + '( + ("^[-_.\"A-Za-z0-9]+\\(:\\|, line \\)[0-9]+: warning:.*$" nil warning) + ("^[-_.\"A-Za-z0-9]+\\(:\\|, line \\)[0-9]+:.*$" nil error) + )) + +(hilit-set-mode-patterns + 'makefile-mode + '(("^#.*$" nil comment) + ("[^$]#.*$" nil comment) + ;; rules + ("^[^ \t\n]*%[^ \t\n]*[ \t]*::?[ \t]*[^ \t\n]*[ \t]*\\(#.*\\)?$" nil rule) + ("^[.][A-Za-z][A-Za-z]?\..*$" nil rule) + ;; variable definition + ("^[_A-Za-z0-9]+[ \t]*\+?=" nil define) + ("\\( \\|:=\\)[_A-Za-z0-9]+[ \t]*\\+=" nil define) + ;; variable references + ("\\$\\([^ \t\n{(]\\|[{(]@?[_A-Za-z0-9:.,%/=]+[)}]\\)" nil keyword) + ("^[A-Za-z0-9.,/_-]+[ \t]*:.*$" nil defun) + ("^include " nil include))) + +(let* ((header-patterns '(("^Subject:.*$" nil msg-subject) + ("^From:.*$" nil msg-from) + ("^--text follows this line--$" nil msg-separator) + ("^[A-Za-z][A-Za-z0-9-]+:" nil msg-header))) + (body-patterns '(("^\\(In article\\|[ \t]*\\w*[]<>}|]\\).*$" + nil msg-quote))) + (message-patterns (append header-patterns body-patterns))) + (hilit-set-mode-patterns 'msg-header header-patterns) + (hilit-set-mode-patterns 'msg-body body-patterns) + (hilit-set-mode-patterns '(vm-mode text-mode mail-mode rmail-mode + gnus-article-mode news-reply-mode mh-show-mode) + message-patterns + 'hilit-rehighlight-message)) + +(hilit-set-mode-patterns + 'gnus-group-mode + '(("^ U.*$" nil gnus-group-unsubscribed) + ("^\\*? +[01]?[0-9]:.*$" nil gnus-group-empty) + ("^ +[2-9][0-9]:.*$" nil gnus-group-full) + ("^ +[0-9][0-9][0-9]+:.*$" nil gnus-group-overflowing))) + +(hilit-set-mode-patterns + 'vm-summary-mode + '(("^ .*$" nil summary-seen) + ("^->.*$" nil summary-current) + ("^ D.*$" nil summary-deleted) + ("^ U.*$" nil summary-unread) + ("^ N.*$" nil summary-new))) + + +;;; this will match only comments w/ an even (zero is even) number of quotes... +;;; which is still inadequate because it matches comments in multi-line strings +;;; how anal do you want to get about never highlighting comments in strings? +;;; I could twiddle with this forever and still it wouldn't be perfect. +;;; (";\\([^\"\n]*\"[^\"\n]*\"\\)*[^\"\n]*$" nil comment) + +(hilit-set-mode-patterns + '(emacs-lisp-mode lisp-interaction-mode) + '( + (";.*" nil comment) + +;;; This almost works...but I think I'll stick with the parser function +;;;("[^?]\\(\"\\(\"\\||\\([^\"]+\\|[\\]\\([\\][\\]\\)*\"\\)*\"\\)\\)" 1 string) + (hilit-string-find ?\\ string) + + ("^\\s *(def\\(un\\|macro\\|advice\\|alias\\|subst\\)[ \t\n]" + "\\()\\|nil\\)" defun) + ("^\\s *(defvar\\s +\\S +" nil decl) + ("^\\s *(defconst\\s +\\S +" nil define) + ("^\\s *(\\(provide\\|require\\|\\(auto\\)?load\\).*$" nil include) + ("\\s *\\&\\(rest\\|optional\\)\\s *" nil keyword) + ("(\\(let\\*?\\|cond\\|if\\|or\\|and\\|map\\(car\\|concat\\)\\|prog[n1*]?\\|while\\|lambda\\|function\\|set\\([qf]\\|car\\|cdr\\)?\\|nconc\\|eval-when-compile\\|condition-case\\|unwind-protect\\|catch\\|throw\\|error\\)[ \t\n]" 1 keyword) + )) + +(hilit-set-mode-patterns + '(lisp-mode ilisp-mode) + '( + (";.*" nil comment) + ("#|" "|#" comment) +;;; This almost works...but I think I'll stick with the parser function +;;;("[^?]\\(\"\\(\"\\||\\([^\"]+\\|[\\]\\([\\][\\]\\)*\"\\)*\"\\)\\)" 1 string) + (hilit-string-find ?\\ string) + + ;; this is waaaaaaaay too slow + ;; ("^\\s *(def\\(un\\|macro\\|advice\\|alias\\|method\\|subst\\)\\s \\S +[ \t\n]+\\(nil\\|(\\(([^()]*)\\|[^()]+\\)*)\\)" nil defun) + ("^\\s *(def\\(un\\|macro\\|advice\\|subst\\|method\\)\\s " "\\()\\|nil\\)" defun) + + ("^\\s *(\\(def\\(var\\|type\\|parameter\\)\\|declare\\)\\s +\\S +" nil decl) + ("^\\s *(def\\(const\\(ant\\)?\\|class\\|struct\\)\\s \\S +[ \t\n]+" nil define) + ("^\\s *(\\(provide\\|require\\|\\(auto\\)?load\\).*$" nil include) + ("[ \t]\\&\\(key\\|rest\\|optional\\|aux\\)\\s *" nil keyword) + ("(\\(let\\*?\\|locally\\|cond\\|if\\*?\\|or\\|and\\|map\\(car\\|c[ao]n\\)?\\|prog[nv1*]?\\|while\\|when\\|unless\\|do\\(\\*\\|list\\|times\\)\\|list\\|lambda\\|function\\|values\\|set\\([qf]\\|car\\|cdr\\)?\\|rplac[ad]\\|nconc\\|block\\|go\\|return\\(-from\\)?\\|[ec]?\\(type\\)?case\\|multiple-value-\\(bind\\|setq\\|list\\|call\\|prog1\\)\\|unwind-protect\\|handler-case\\|catch\\|throw\\|eval-when\\(-compile\\)?\\)[ \t\n]" 1 keyword) + )) + + +(hilit-set-mode-patterns + 'plain-tex-mode + '(("^%%.*$" nil comment) + ("{\\\\em\\([^}]+\\)}" nil comment) + ("\\(\\\\\\w+\\)" nil keyword) + ("{\\\\bf\\([^}]+\\)}" nil keyword) + ("^[ \t\n]*\\\\def[\\\\@]\\(\\w+\\)" nil defun) + ("\\\\\\(begin\\|end\\){\\([A-Za-z0-9\\*]+\\)}" nil defun) + ;; ("[^\\\\]\\$\\([^$]*\\)\\$" nil string) + ("\\$\\([^$]*\\)\\$" nil string) + )) + +;; Reasonable extensions would include smarter parameter handling for such +;; things as the .IX and .I macros, which alternate the handling of following +;; arguments. + +(hilit-set-mode-patterns + 'nroff-mode + '(("^\\.[\\\][\\\"].*$" nil comment) + ("^\\.so .*$" nil include) + ("^\\.[ST]H.*$" nil defun) +;; ("^[^\\.].*\"[^\\\"]*\\(\\\\\\(.\\)[^\\\"]*\\)*\"" nil string) + ("\"" "[^\\]\"" string) + ("^\\.[A-Z12\\\\].*$" nil define) + ("\\([\\\][^ ]*\\)" nil keyword) + ("^\\.[A-Z].*$" nil keyword)) + nil 'case-insensitive) + +(hilit-set-mode-patterns + 'texinfo-mode + '(("^\\(@c\\|@comment\\)\\>.*$" nil comment) + ("@\\(emph\\|strong\\|b\\|i\\){[^}]+}" nil comment) +;; seems broken +;; ("\\$[^$]*\\$" nil string) + ("@\\(file\\|kbd\\|key\\){[^}]+}" nil string) + ("^\\*.*$" nil defun) + ("@\\(if\\w+\\|format\\|item\\)\\b.*$" nil defun) + ("@end +[A-Za-z0-9]+[ \t]*$" nil defun) + ("@\\(samp\\|code\\|var\\){[^}]+}" nil defun) + ("@\\w+\\({[^}]+}\\)?" nil keyword) + )) + +(hilit-set-mode-patterns + 'dired-mode + (append + '(("^D.*$" nil dired-deleted) + ("^\\*.*$" nil dired-marked) + ("^ d.*$" nil dired-directory) + ("^ l.*$" nil dired-link) + ("^ -.*#.*#$" nil dired-ignored)) + (list (cons + (concat "^ .*\\(" + (mapconcat 'regexp-quote completion-ignored-extensions "\\|") + "\\)$") + '(nil dired-ignored))))) + +(hilit-set-mode-patterns + 'jargon-mode + '(("^:[^:]*:" nil jargon-entry) + ("{[^}]*}+" nil jargon-xref))) + +(hilit-set-mode-patterns + 'Info-mode + '(("^\\* [^:]+:+" nil jargon-entry) + ("\\*[Nn]ote\\b[^:]+:+" nil jargon-xref) + (" \\(Next\\|Prev\\|Up\\):" nil jargon-xref) + ("- \\(Variable\\|Function\\|Macro\\|Command\\|Special Form\\|User Option\\):.*$" + nil jargon-keyword))) ; lisp manual + +(hilit-set-mode-patterns + 'calendar-mode + '(("[A-Z][a-z]+ [0-9]+" nil define) ; month and year + ("S M Tu W Th F S" nil label))) ; week days + +(hilit-set-mode-patterns + 'asm-mode + '(("/\\*" "\\*/" comment) + ("^#[ \t]*\\(undef\\|define\\).*$" "[^\\]$" define) + ("^#.*$" nil include) + ;; labels + ("^.+:" nil defun) + ;; assembler directives + ("^[ \t]*\\..*$" nil decl) + ;; register names + ("\\$[a-z0-9]+" nil string) + ;; mnemonics + ("^[ \t]*[a-z]+" nil struct))) + +(hilit-set-mode-patterns + 'pascal-mode + '(("(\\*" "\\*)" comment) + ("{" "}" comment) + ;; Doesn't work when there are strings in comments.... + ;; ("'[^']*'" nil string) + ("^#.*$" nil include) + ("^[ \t]*\\(procedure\\|function\\)[ \t]+\\w+[^ \t(;]*" nil defun) + ("\\<\\(program\\|begin\\|end\\)\\>" nil defun) + ("\\<\\(external\\|forward\\)\\>" nil include) + ("\\<\\(label\\|const\\|type\\|var\\)\\>" nil define) + ("\\<\\(record\\|array\\|file\\)\\>" nil type) + ("\\<\\(of\\|to\\|for\\|if\\|then\\|else\\|case\\|while\\|do\\|until\\|and\\|or\\|not\\|with\\|repeat\\)\\>" nil keyword) + ) + nil 'case-insensitive) + +(hilit-set-mode-patterns + 'icon-mode + '(("#.*$" nil comment) + ("\"[^\\\"]*\\(\\\\.[^\\\"]*\\)*\"" nil string) + ;; charsets: these do not work because of a conflict with strings + ;; ("'[^\\']*\\(\\\\.[^\\']*\\)*'" nil string) + ("^[ \t]*procedure[ \t]+\\w+[ \t]*(" ")" defun) + ("^[ \t]*record.*(" ")" include) + ("^[ \t]*\\(global\\|link\\)[ \t\n]+[A-Za-z_0-9]+\\([ \t\n]*,[ \t\n]*[A-Za-z_0-9]+\\)*" nil include) + ("^[ \t]*\\(local\\|static\\)[ \t\n]+[A-Za-z_0-9]+\\([ \t\n]*,[ \t\n]*[A-Za-z_0-9]+\\)*" nil decl) + ("\\<\\(initial\\|end\\)\\>" nil glob-struct) + ("\\<\\(while\\|until\\|return\\|every\\|if\\|then\\|else\\|to\\|case\\|of\\|suspend\\|create\\|do\\|repeat\\|break\\)\\>" nil keyword) + )) + +;; as you can see, I had two similar problems for Pascal and Icon. In +;; Pascal, strings are delimited with ' and an embedded quote is doubled, +;; thus string syntax would be extremely simple. However, if a string +;; occurs within a comment, the following text is considered a string. +;; +;; In Icon, strings are similar to C ones, but there are also charsets, +;; delimited with simple quotes. I could not manage to use both regexps at +;; the same time. + +;; The problem I have with my patterns for Icon is that this language has a +;; string similar constant to the C one (but a string can be cut on several +;; lines, if terminated by a dash and continued with initial blanks, like +;; this: +;; "This is a somewhat long - +;; string, written on three - +;; successive lines" +;; in order to insert a double quote in a string, you have to escape it +;; with a \), bu also a character set constant (named a charset), which +;; uses single quotes instead of double ones. It would seem intuitive to +;; highlight both constants in the same way. + + +(provide 'hilit19) + +;;; hilit19 ends here. diff -r 3168ff2c349b -r 5c3a343fb1ce lisp/obsolete/rnews.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/obsolete/rnews.el Thu Jan 04 19:21:36 2001 +0000 @@ -0,0 +1,985 @@ +;;; rnews.el --- USENET news reader for gnu emacs + +;; Copyright (C) 1985, 1986, 1987 Free Software Foundation, Inc. + +;; Maintainer: FSF +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs 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. + +;; 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 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. + +;;; Change Log: + +;; Created Sun Mar 10,1985 at 21:35:01 ads and sundar@hernes.ai.mit.edu +;; Should do the point pdl stuff sometime +;; finito except pdl.... Sat Mar 16,1985 at 06:43:44 +;; lets keep the summary stuff out until we get it working .. +;; sundar@hermes.ai.mit.edu Wed Apr 10,1985 at 16:32:06 +;; hack slash maim. mly@gnu.org Thu 18 Apr, 1985 06:11:14 +;; modified to correct reentrance bug, to not bother with groups that +;; received no new traffic since last read completely, to find out +;; what traffic a group has available much more quickly when +;; possible, to do some completing reads for group names - should +;; be much faster... +;; KING@KESTREL.arpa, Thu Mar 13 09:03:28 1986 +;; made news-{next,previous}-group skip groups with no new messages; and +;; added checking for unsubscribed groups to news-add-news-group +;; tower@gnu.org Jul 18 1986 +;; bound rmail-output to C-o; and changed header-field commands binding to +;; agree with the new C-c C-f usage in sendmail +;; tower@gnu.org Sep 3 1986 +;; added news-rotate-buffer-body +;; tower@gnu.org Oct 17 1986 +;; made messages more user friendly, cleaned up news-inews +;; move posting and mail code to new file rnewpost.el +;; tower@gnu.org Oct 29 1986 +;; added caesar-region, rename news-caesar-buffer-body, hacked accordingly +;; tower@gnu.org Nov 21 1986 +;; added tower@gnu.org 22 Apr 87 + +;;; Code: + +(require 'mail-utils) +(require 'sendmail) + +(autoload 'rmail-output "rmailout" + "Append this message to Unix mail file named FILE-NAME." + t) + +(autoload 'news-reply "rnewspost" + "Compose and post a reply to the current article on USENET. +While composing the reply, use \\[mail-yank-original] to yank the original +message into it." + t) + +(autoload 'news-mail-other-window "rnewspost" + "Send mail in another window. +While composing the message, use \\[mail-yank-original] to yank the +original message into it." + t) + +(autoload 'news-post-news "rnewspost" + "Begin editing a new USENET news article to be posted." + t) + +(autoload 'news-mail-reply "rnewspost" + "Mail a reply to the author of the current article. +While composing the reply, use \\[mail-yank-original] to yank the original +message into it." + t) + +(defvar news-group-hook-alist nil + "Alist of (GROUP-REGEXP . HOOK) pairs. +Just before displaying a message, each HOOK is called +if its GROUP-REGEXP matches the current newsgroup name.") + +(defvar rmail-last-file (expand-file-name "~/mbox.news")) + +;Now in paths.el. +;(defvar news-path "/usr/spool/news/" +; "The root directory below which all news files are stored.") + +(defvar news-startup-file "$HOME/.newsrc" "Contains ~/.newsrc") +(defvar news-certification-file "$HOME/.news-dates" "Contains ~/.news-dates") + +;; random headers that we decide to ignore. +(defvar news-ignored-headers + "^Path:\\|^Posting-Version:\\|^Article-I.D.:\\|^Expires:\\|^Date-Received:\\|^References:\\|^Control:\\|^Xref:\\|^Lines:\\|^Posted:\\|^Relay-Version:\\|^Message-ID:\\|^Nf-ID:\\|^Nf-From:\\|^Approved:\\|^Sender:" + "All random fields within the header of a message.") + +(defvar news-mode-map nil) +(defvar news-read-first-time-p t) +;; Contains the (dotified) news groups of which you are a member. +(defvar news-user-group-list nil) + +(defvar news-current-news-group nil) +(defvar news-current-group-begin nil) +(defvar news-current-group-end nil) +(defvar news-current-certifications nil + "An assoc list of a group name and the time at which it is +known that the group had no new traffic") +(defvar news-current-certifiable nil + "The time when the directory we are now working on was written") + +(defvar news-message-filter nil + "User specifiable filter function that will be called during +formatting of the news file") + +;(defvar news-mode-group-string "Starting-Up" +; "Mode line group name info is held in this variable") +(defvar news-list-of-files nil + "Global variable in which we store the list of files +associated with the current newsgroup") +(defvar news-list-of-files-possibly-bogus nil + "variable indicating we only are guessing at which files are available. +Not currently used.") + +;; association list in which we store lists of the form +;; (pointified-group-name (first last old-last)) +(defvar news-group-article-assoc nil) + +(defvar news-current-message-number 0 "Displayed Article Number") +(defvar news-total-current-group 0 "Total no of messages in group") + +(defvar news-unsubscribe-groups ()) +(defvar news-point-pdl () "List of visited news messages.") +(defvar news-no-jumps-p t) +(defvar news-buffer () "Buffer into which news files are read.") + +(defmacro news-push (item ref) + (list 'setq ref (list 'cons item ref))) + +(defmacro news-cadr (x) (list 'car (list 'cdr x))) +(defmacro news-cdar (x) (list 'cdr (list 'car x))) +(defmacro news-caddr (x) (list 'car (list 'cdr (list 'cdr x)))) +(defmacro news-cadar (x) (list 'car (list 'cdr (list 'car x)))) +(defmacro news-caadr (x) (list 'car (list 'car (list 'cdr x)))) +(defmacro news-cdadr (x) (list 'cdr (list 'car (list 'cdr x)))) + +(defmacro news-wins (pfx index) + `(file-exists-p (concat ,pfx "/" (int-to-string ,index)))) + +(defvar news-max-plausible-gap 2 + "* In an rnews directory, the maximum possible gap size. +A gap is a sequence of missing messages between two messages that exist. +An empty file does not contribute to a gap -- it ends one.") + +(defun news-find-first-and-last (prefix base) + (and (news-wins prefix base) + (cons (news-find-first-or-last prefix base -1) + (news-find-first-or-last prefix base 1)))) + +(defmacro news-/ (a1 a2) +;; a form of / that guarantees that (/ -1 2) = 0 + (if (zerop (/ -1 2)) + `(/ ,a1 ,a2) + `(if (< ,a1 0) + (- (/ (- ,a1) ,a2)) + (/ ,a1 ,a2)))) + +(defun news-find-first-or-last (pfx base dirn) + ;; first use powers of two to find a plausible ceiling + (let ((original-dir dirn)) + (while (news-wins pfx (+ base dirn)) + (setq dirn (* dirn 2))) + (setq dirn (news-/ dirn 2)) + ;; Then use a binary search to find the high water mark + (let ((offset (news-/ dirn 2))) + (while (/= offset 0) + (if (news-wins pfx (+ base dirn offset)) + (setq dirn (+ dirn offset))) + (setq offset (news-/ offset 2)))) + ;; If this high-water mark is bogus, recurse. + (let ((offset (* news-max-plausible-gap original-dir))) + (while (and (/= offset 0) (not (news-wins pfx (+ base dirn offset)))) + (setq offset (- offset original-dir))) + (if (= offset 0) + (+ base dirn) + (news-find-first-or-last pfx (+ base dirn offset) original-dir))))) + +(defun rnews () +"Read USENET news for groups for which you are a member and add or +delete groups. +You can reply to articles posted and send articles to any group. + +Type \\[describe-mode] once reading news to get a list of rnews commands." + (interactive) + (let ((last-buffer (buffer-name))) + (make-local-variable 'rmail-last-file) + (switch-to-buffer (setq news-buffer (get-buffer-create "*news*"))) + (news-mode) + (setq news-buffer-save last-buffer) + (setq buffer-read-only nil) + (erase-buffer) + (setq buffer-read-only t) + (set-buffer-modified-p t) + (sit-for 0) + (message "Getting new USENET news...") + (news-set-mode-line) + (news-get-certifications) + (news-get-new-news))) + +(defun news-group-certification (group) + (cdr-safe (assoc group news-current-certifications))) + + +(defun news-set-current-certifiable () + ;; Record the date that corresponds to the directory you are about to check + (let ((file (concat news-path + (string-subst-char ?/ ?. news-current-news-group)))) + (setq news-current-certifiable + (nth 5 (file-attributes + (or (file-symlink-p file) file)))))) + +(defun news-get-certifications () + ;; Read the certified-read file from last session + (save-excursion + (save-window-excursion + (setq news-current-certifications + (car-safe + (condition-case var + (let* + ((file (substitute-in-file-name news-certification-file)) + (buf (find-file-noselect file))) + (and (file-exists-p file) + (progn + (switch-to-buffer buf 'norecord) + (unwind-protect + (read-from-string (buffer-string)) + (kill-buffer buf))))) + (error nil))))))) + +(defun news-write-certifications () + ;; Write a certification file. + ;; This is an assoc list of group names with doubletons that represent + ;; mod times of the directory when group is read completely. + (save-excursion + (save-window-excursion + (with-output-to-temp-buffer + "*CeRtIfIcAtIoNs*" + (print news-current-certifications)) + (let ((buf (get-buffer "*CeRtIfIcAtIoNs*"))) + (switch-to-buffer buf) + (write-file (substitute-in-file-name news-certification-file)) + (kill-buffer buf))))) + +(defun news-set-current-group-certification () + (let ((cgc (assoc news-current-news-group news-current-certifications))) + (if cgc (setcdr cgc news-current-certifiable) + (news-push (cons news-current-news-group news-current-certifiable) + news-current-certifications)))) + +(defun news-set-minor-modes () + "Creates a minor mode list that has group name, total articles, +and attribute for current article." + (setq news-minor-modes (list (cons 'foo + (concat news-current-message-number + "/" + news-total-current-group + (news-get-attribute-string))))) + ;; Detect Emacs versions 18.16 and up, which display + ;; directly from news-minor-modes by using a list for mode-name. + (or (boundp 'minor-mode-alist) + (setq minor-modes news-minor-modes))) + +(defun news-set-message-counters () + "Scan through current news-groups filelist to figure out how many messages +are there. Set counters for use with minor mode display." + (if (null news-list-of-files) + (setq news-current-message-number 0))) + +(if news-mode-map + nil + (setq news-mode-map (make-keymap)) + (suppress-keymap news-mode-map) + (define-key news-mode-map "." 'beginning-of-buffer) + (define-key news-mode-map " " 'scroll-up) + (define-key news-mode-map "\177" 'scroll-down) + (define-key news-mode-map "n" 'news-next-message) + (define-key news-mode-map "c" 'news-make-link-to-message) + (define-key news-mode-map "p" 'news-previous-message) + (define-key news-mode-map "j" 'news-goto-message) + (define-key news-mode-map "q" 'news-exit) + (define-key news-mode-map "e" 'news-exit) + (define-key news-mode-map "\ej" 'news-goto-news-group) + (define-key news-mode-map "\en" 'news-next-group) + (define-key news-mode-map "\ep" 'news-previous-group) + (define-key news-mode-map "l" 'news-list-news-groups) + (define-key news-mode-map "?" 'describe-mode) + (define-key news-mode-map "g" 'news-get-new-news) + (define-key news-mode-map "f" 'news-reply) + (define-key news-mode-map "m" 'news-mail-other-window) + (define-key news-mode-map "a" 'news-post-news) + (define-key news-mode-map "r" 'news-mail-reply) + (define-key news-mode-map "o" 'news-save-item-in-file) + (define-key news-mode-map "\C-o" 'rmail-output) + (define-key news-mode-map "t" 'news-show-all-headers) + (define-key news-mode-map "x" 'news-force-update) + (define-key news-mode-map "A" 'news-add-news-group) + (define-key news-mode-map "u" 'news-unsubscribe-current-group) + (define-key news-mode-map "U" 'news-unsubscribe-group) + (define-key news-mode-map "\C-c\C-r" 'news-caesar-buffer-body)) + +(defun news-mode () + "News Mode is used by M-x rnews for reading USENET Newsgroups articles. +New readers can find additional help in newsgroup: news.announce.newusers . +All normal editing commands are turned off. +Instead, these commands are available: + +. move point to front of this news article (same as Meta-<). +Space scroll to next screen of this news article. +Delete scroll down previous page of this news article. +n move to next news article, possibly next group. +p move to previous news article, possibly previous group. +j jump to news article specified by numeric position. +M-j jump to news group. +M-n goto next news group. +M-p goto previous news group. +l list all the news groups with current status. +? print this help message. +C-c C-r caesar rotate all letters by 13 places in the article's body (rot13). +g get new USENET news. +f post a reply article to USENET. +a post an original news article. +A add a newsgroup. +o save the current article in the named file (append if file exists). +C-o output this message to a Unix-format mail file (append it). +c \"copy\" (actually link) current or prefix-arg msg to file. + warning: target directory and message file must be on same device + (UNIX magic) +t show all the headers this news article originally had. +q quit reading news after updating .newsrc file. +e exit updating .newsrc file. +m mail a news article. Same as C-x 4 m. +x update last message seen to be the current message. +r mail a reply to this news article. Like m but initializes some fields. +u unsubscribe from current newsgroup. +U unsubscribe from specified newsgroup." + (interactive) + (kill-all-local-variables) + (make-local-variable 'news-read-first-time-p) + (setq news-read-first-time-p t) + (make-local-variable 'news-current-news-group) +; (setq news-current-news-group "??") + (make-local-variable 'news-current-group-begin) + (setq news-current-group-begin 0) + (make-local-variable 'news-current-message-number) + (setq news-current-message-number 0) + (make-local-variable 'news-total-current-group) + (make-local-variable 'news-buffer-save) + (make-local-variable 'version-control) + (setq version-control 'never) + (make-local-variable 'news-point-pdl) +; This breaks it. I don't have time to figure out why. -- RMS +; (make-local-variable 'news-group-article-assoc) + (setq major-mode 'news-mode) + (setq mode-line-process '(news-minor-modes)) + (setq mode-name "NEWS") + (news-set-mode-line) + (set-syntax-table text-mode-syntax-table) + (use-local-map news-mode-map) + (setq local-abbrev-table text-mode-abbrev-table) + (run-hooks 'news-mode-hook)) + +(defun string-subst-char (new old string) + (let (index) + (setq old (regexp-quote (char-to-string old)) + string (substring string 0)) + (while (setq index (string-match old string)) + (aset string index new))) + string) + +;; update read message number +(defmacro news-update-message-read (ngroup nno) + (list 'setcar + (list 'news-cdadr + (list 'assoc ngroup 'news-group-article-assoc)) + nno)) + +(defun news-parse-range (number-string) + "Parse string representing range of numbers of he form - +to a list (a . b)" + (let ((n (string-match "-" number-string))) + (if n + (cons (string-to-int (substring number-string 0 n)) + (string-to-int (substring number-string (1+ n)))) + (setq n (string-to-int number-string)) + (cons n n)))) + +;(defun is-in (elt lis) +; (catch 'foo +; (while lis +; (if (equal (car lis) elt) +; (throw 'foo t) +; (setq lis (cdr lis)))))) + +(defun news-get-new-news () + "Get new USENET news, if there is any for the current user." + (interactive) + (if (not (null news-user-group-list)) + (news-update-newsrc-file)) + (setq news-group-article-assoc ()) + (setq news-user-group-list ()) + (message "Looking up %s file..." news-startup-file) + (let ((file (substitute-in-file-name news-startup-file)) + (temp-user-groups ())) + (save-excursion + (let ((newsrcbuf (find-file-noselect file)) + start end endofline tem) + (set-buffer newsrcbuf) + (goto-char 0) + (while (search-forward ": " nil t) + (setq end (point)) + (beginning-of-line) + (setq start (point)) + (end-of-line) + (setq endofline (point)) + (setq tem (buffer-substring start (- end 2))) + (let ((range (news-parse-range + (buffer-substring end endofline)))) + (if (assoc tem news-group-article-assoc) + (message "You are subscribed twice to %s; I ignore second" + tem) + (setq temp-user-groups (cons tem temp-user-groups) + news-group-article-assoc + (cons (list tem (list (car range) + (cdr range) + (cdr range))) + news-group-article-assoc))))) + (kill-buffer newsrcbuf))) + (setq temp-user-groups (nreverse temp-user-groups)) + (message "Prefrobnicating...") + (switch-to-buffer news-buffer) + (setq news-user-group-list temp-user-groups) + (while (and temp-user-groups + (not (news-read-files-into-buffer + (car temp-user-groups) nil))) + (setq temp-user-groups (cdr temp-user-groups))) + (if (null temp-user-groups) + (message "No news is good news.") + (message "")))) + +(defun news-list-news-groups () + "Display all the news groups to which you belong." + (interactive) + (with-output-to-temp-buffer "*Newsgroups*" + (save-excursion + (set-buffer standard-output) + (insert + "News Group Msg No. News Group Msg No.\n") + (insert + "------------------------- -------------------------\n") + (let ((temp news-user-group-list) + (flag nil)) + (while temp + (let ((item (assoc (car temp) news-group-article-assoc))) + (insert (car item)) + (indent-to (if flag 52 20)) + (insert (int-to-string (news-cadr (news-cadr item)))) + (if flag + (insert "\n") + (indent-to 33)) + (setq temp (cdr temp) flag (not flag)))))))) + +;; Mode line hack +(defun news-set-mode-line () + "Set mode line string to something useful." + (setq mode-line-process + (concat " " + (if (integerp news-current-message-number) + (int-to-string news-current-message-number) + "??") + "/" + (if (integerp news-current-group-end) + (int-to-string news-current-group-end) + news-current-group-end))) + (setq mode-line-buffer-identification + (concat "NEWS: " + news-current-news-group + ;; Enough spaces to pad group name to 17 positions. + (substring " " + 0 (max 0 (- 17 (length news-current-news-group)))))) + (set-buffer-modified-p t) + (sit-for 0)) + +(defun news-goto-news-group (gp) + "Takes a string and goes to that news group." + (interactive (list (completing-read "NewsGroup: " + news-group-article-assoc))) + (message "Jumping to news group %s..." gp) + (news-select-news-group gp) + (message "Jumping to news group %s... done." gp)) + +(defun news-select-news-group (gp) + (let ((grp (assoc gp news-group-article-assoc))) + (if (null grp) + (error "Group %s not subscribed to" gp) + (progn + (news-update-message-read news-current-news-group + (news-cdar news-point-pdl)) + (news-read-files-into-buffer (car grp) nil) + (news-set-mode-line))))) + +(defun news-goto-message (arg) + "Goes to the article ARG in current newsgroup." + (interactive "p") + (if (null current-prefix-arg) + (setq arg (read-no-blanks-input "Go to article: " ""))) + (news-select-message arg)) + +(defun news-select-message (arg) + (if (stringp arg) (setq arg (string-to-int arg))) + (let ((file (concat news-path + (string-subst-char ?/ ?. news-current-news-group) + "/" arg))) + (if (= arg + (or (news-cadr (memq (news-cdar news-point-pdl) news-list-of-files)) + 0)) + (setcdr (car news-point-pdl) arg)) + (setq news-current-message-number arg) + (if (file-exists-p file) + (let ((buffer-read-only nil)) + (news-read-in-file file) + (news-set-mode-line)) + (news-set-mode-line) + (error "Article %d nonexistent" arg)))) + +(defun news-force-update () + "updates the position of last article read in the current news group" + (interactive) + (setcdr (car news-point-pdl) news-current-message-number) + (message "Updated to %d" news-current-message-number)) + +(defun news-next-message (arg) + "Move ARG messages forward within one newsgroup. +Negative ARG moves backward. +If ARG is 1 or -1, moves to next or previous newsgroup if at end." + (interactive "p") + (let ((no (+ arg news-current-message-number))) + (if (or (< no news-current-group-begin) + (> no news-current-group-end)) + (cond ((= arg 1) + (news-set-current-group-certification) + (news-next-group)) + ((= arg -1) + (news-previous-group)) + (t (error "Article out of range"))) + (let ((plist (news-get-motion-lists + news-current-message-number + news-list-of-files))) + (if (< arg 0) + (news-select-message (nth (1- (- arg)) (car (cdr plist)))) + (news-select-message (nth (1- arg) (car plist)))))))) + +(defun news-previous-message (arg) + "Move ARG messages backward in current newsgroup. +With no arg or arg of 1, move one message +and move to previous newsgroup if at beginning. +A negative ARG means move forward." + (interactive "p") + (news-next-message (- arg))) + +(defun news-move-to-group (arg) + "Given arg move forward or backward to a new newsgroup." + (let ((cg news-current-news-group)) + (let ((plist (news-get-motion-lists cg news-user-group-list)) + ngrp) + (if (< arg 0) + (or (setq ngrp (nth (1- (- arg)) (news-cadr plist))) + (error "No previous news groups")) + (or (setq ngrp (nth arg (car plist))) + (error "No more news groups"))) + (news-select-news-group ngrp)))) + +(defun news-next-group () + "Moves to the next user group." + (interactive) +; (message "Moving to next group...") + (news-move-to-group 0) + (while (null news-list-of-files) + (news-move-to-group 0))) +; (message "Moving to next group... done.") + +(defun news-previous-group () + "Moves to the previous user group." + (interactive) +; (message "Moving to previous group...") + (news-move-to-group -1) + (while (null news-list-of-files) + (news-move-to-group -1))) +; (message "Moving to previous group... done.") + +(defun news-get-motion-lists (arg listy) + "Given a msgnumber/group this will return a list of two lists; +one for moving forward and one for moving backward." + (let ((temp listy) + (result ())) + (catch 'out + (while temp + (if (equal (car temp) arg) + (throw 'out (cons (cdr temp) (list result))) + (setq result (nconc (list (car temp)) result)) + (setq temp (cdr temp))))))) + +;; miscellaneous io routines +(defun news-read-in-file (filename) + (erase-buffer) + (let ((start (point))) + (insert-file-contents filename) + (news-convert-format) + ;; Run each hook that applies to the current newsgroup. + (let ((hooks news-group-hook-alist)) + (while hooks + (goto-char start) + (if (string-match (car (car hooks)) news-group-name) + (funcall (cdr (car hooks)))) + (setq hooks (cdr hooks)))) + (goto-char start) + (forward-line 1) + (if (eobp) + (message "(Empty file?)") + (goto-char start)))) + +(defun news-convert-format () + (save-excursion + (save-restriction + (let* ((start (point)) + (end (condition-case () + (progn (search-forward "\n\n") (point)) + (error nil))) + has-from has-date) + (cond (end + (narrow-to-region start end) + (goto-char start) + (setq has-from (search-forward "\nFrom:" nil t)) + (cond ((and (not has-from) has-date) + (goto-char start) + (search-forward "\nDate:") + (beginning-of-line) + (kill-line) (kill-line))) + (news-delete-headers start) + (goto-char start))))))) + +(defun news-show-all-headers () + "Redisplay current news item with all original headers" + (interactive) + (let (news-ignored-headers + (buffer-read-only ())) + (erase-buffer) + (news-set-mode-line) + (news-read-in-file + (concat news-path + (string-subst-char ?/ ?. news-current-news-group) + "/" (int-to-string news-current-message-number))))) + +(defun news-delete-headers (pos) + (goto-char pos) + (and (stringp news-ignored-headers) + (while (re-search-forward news-ignored-headers nil t) + (beginning-of-line) + (delete-region (point) + (progn (re-search-forward "\n[^ \t]") + (forward-char -1) + (point)))))) + +(defun news-exit () + "Quit news reading session and update the .newsrc file." + (interactive) + (if (y-or-n-p "Do you really wanna quit reading news ? ") + (progn (message "Updating %s..." news-startup-file) + (news-update-newsrc-file) + (news-write-certifications) + (message "Updating %s... done" news-startup-file) + (message "Now do some real work") + (quit-window) + (switch-to-buffer news-buffer-save) + (setq news-user-group-list ())) + (message ""))) + +(defun news-update-newsrc-file () + "Updates the .newsrc file in the users home dir." + (let ((newsrcbuf (find-file-noselect + (substitute-in-file-name news-startup-file))) + (tem news-user-group-list) + group) + (save-excursion + (if (not (null news-current-news-group)) + (news-update-message-read news-current-news-group + (news-cdar news-point-pdl))) + (set-buffer newsrcbuf) + (while tem + (setq group (assoc (car tem) news-group-article-assoc)) + (if (= (news-cadr (news-cadr group)) (news-caddr (news-cadr group))) + nil + (goto-char 0) + (if (search-forward (concat (car group) ": ") nil t) + (kill-line nil) + (insert (car group) ": \n") (backward-char 1)) + (insert (int-to-string (car (news-cadr group))) "-" + (int-to-string (news-cadr (news-cadr group))))) + (setq tem (cdr tem))) + (while news-unsubscribe-groups + (setq group (assoc (car news-unsubscribe-groups) + news-group-article-assoc)) + (goto-char 0) + (if (search-forward (concat (car group) ": ") nil t) + (progn + (backward-char 2) + (kill-line nil) + (insert "! " (int-to-string (car (news-cadr group))) + "-" (int-to-string (news-cadr (news-cadr group)))))) + (setq news-unsubscribe-groups (cdr news-unsubscribe-groups))) + (save-buffer) + (kill-buffer (current-buffer))))) + + +(defun news-unsubscribe-group (group) + "Removes you from newgroup GROUP." + (interactive (list (completing-read "Unsubscribe from group: " + news-group-article-assoc))) + (news-unsubscribe-internal group)) + +(defun news-unsubscribe-current-group () + "Removes you from the newsgroup you are now reading." + (interactive) + (if (y-or-n-p "Do you really want to unsubscribe from this group ? ") + (news-unsubscribe-internal news-current-news-group))) + +(defun news-unsubscribe-internal (group) + (let ((tem (assoc group news-group-article-assoc))) + (if tem + (progn + (setq news-unsubscribe-groups (cons group news-unsubscribe-groups)) + (news-update-message-read group (news-cdar news-point-pdl)) + (if (equal group news-current-news-group) + (news-next-group)) + (message "")) + (error "Not subscribed to group: %s" group)))) + +(defun news-save-item-in-file (file) + "Save the current article that is being read by appending to a file." + (interactive "FSave item in file: ") + (append-to-file (point-min) (point-max) file)) + +(defun news-get-pruned-list-of-files (gp-list end-file-no) + "Given a news group it finds all files in the news group. +The arg must be in slashified format. +Using ls was found to be too slow in a previous version." + (let + ((answer + (and + (not (and end-file-no + (equal (news-set-current-certifiable) + (news-group-certification gp-list)) + (setq news-list-of-files nil + news-list-of-files-possibly-bogus t))) + (let* ((file-directory (concat news-path + (string-subst-char ?/ ?. gp-list))) + tem + (last-winner + (and end-file-no + (news-wins file-directory end-file-no) + (news-find-first-or-last file-directory end-file-no 1)))) + (setq news-list-of-files-possibly-bogus t news-list-of-files nil) + (if last-winner + (progn + (setq news-list-of-files-possibly-bogus t + news-current-group-end last-winner) + (while (> last-winner end-file-no) + (news-push last-winner news-list-of-files) + (setq last-winner (1- last-winner))) + news-list-of-files) + (if (or (not (file-directory-p file-directory)) + (not (file-readable-p file-directory))) + nil + (setq news-list-of-files + (condition-case error + (directory-files file-directory) + (file-error + (if (string= (nth 2 error) "permission denied") + (message "Newsgroup %s is read-protected" + gp-list) + (signal 'file-error (cdr error))) + nil))) + (setq tem news-list-of-files) + (while tem + (if (or (not (string-match "^[0-9]*$" (car tem))) + ;; don't get confused by directories that look like numbers + (file-directory-p + (concat file-directory "/" (car tem))) + (<= (string-to-int (car tem)) end-file-no)) + (setq news-list-of-files + (delq (car tem) news-list-of-files))) + (setq tem (cdr tem))) + (if (null news-list-of-files) + (progn (setq news-current-group-end 0) + nil) + (setq news-list-of-files + (mapcar 'string-to-int news-list-of-files)) + (setq news-list-of-files (sort news-list-of-files '<)) + (setq news-current-group-end + (elt news-list-of-files + (1- (length news-list-of-files)))) + news-list-of-files))))))) + (or answer (progn (news-set-current-group-certification) nil)))) + +(defun news-read-files-into-buffer (group reversep) + (let* ((files-start-end (news-cadr (assoc group news-group-article-assoc))) + (start-file-no (car files-start-end)) + (end-file-no (news-cadr files-start-end)) + (buffer-read-only nil)) + (setq news-current-news-group group) + (setq news-current-message-number nil) + (setq news-current-group-end nil) + (news-set-mode-line) + (news-get-pruned-list-of-files group end-file-no) + (news-set-mode-line) + ;; @@ should be a lot smarter than this if we have to move + ;; @@ around correctly. + (setq news-point-pdl (list (cons (car files-start-end) + (news-cadr files-start-end)))) + (if (null news-list-of-files) + (progn (erase-buffer) + (setq news-current-group-end end-file-no) + (setq news-current-group-begin end-file-no) + (setq news-current-message-number end-file-no) + (news-set-mode-line) +; (message "No new articles in " group " group.") + nil) + (setq news-current-group-begin (car news-list-of-files)) + (if reversep + (setq news-current-message-number news-current-group-end) + (if (> (car news-list-of-files) end-file-no) + (setcdr (car news-point-pdl) (car news-list-of-files))) + (setq news-current-message-number news-current-group-begin)) + (news-set-message-counters) + (news-set-mode-line) + (news-read-in-file (concat news-path + (string-subst-char ?/ ?. group) + "/" + (int-to-string + news-current-message-number))) + (news-set-message-counters) + (news-set-mode-line) + t))) + +(defun news-add-news-group (gp) + "Resubscribe to or add a USENET news group named GROUP (a string)." +; @@ (completing-read ...) +; @@ could be based on news library file ../active (slightly fascist) +; @@ or (expensive to compute) all directories under the news spool directory + (interactive "sAdd news group: ") + (let ((file-dir (concat news-path (string-subst-char ?/ ?. gp)))) + (save-excursion + (if (null (assoc gp news-group-article-assoc)) + (let ((newsrcbuf (find-file-noselect + (substitute-in-file-name news-startup-file)))) + (if (file-directory-p file-dir) + (progn + (switch-to-buffer newsrcbuf) + (goto-char 0) + (if (search-forward (concat gp "! ") nil t) + (progn + (message "Re-subscribing to group %s." gp) + ;;@@ news-unsubscribe-groups isn't being used + ;;(setq news-unsubscribe-groups + ;; (delq gp news-unsubscribe-groups)) + (backward-char 2) + (delete-char 1) + (insert ":")) + (progn + (message + "Added %s to your list of newsgroups." gp) + (end-of-buffer) + (insert gp ": 1-1\n"))) + (search-backward gp nil t) + (let (start end endofline tem) + (search-forward ": " nil t) + (setq end (point)) + (beginning-of-line) + (setq start (point)) + (end-of-line) + (setq endofline (point)) + (setq tem (buffer-substring start (- end 2))) + (let ((range (news-parse-range + (buffer-substring end endofline)))) + (setq news-group-article-assoc + (cons (list tem (list (car range) + (cdr range) + (cdr range))) + news-group-article-assoc)))) + (save-buffer) + (kill-buffer (current-buffer))) + (message "Newsgroup %s doesn't exist." gp))) + (message "Already subscribed to group %s." gp))))) + +(defun news-make-link-to-message (number newname) + "Forges a link to an rnews message numbered number (current if no arg) +Good for hanging on to a message that might or might not be +automatically deleted." + (interactive "P +FName to link to message: ") + (add-name-to-file + (concat news-path + (string-subst-char ?/ ?. news-current-news-group) + "/" (if number + (prefix-numeric-value number) + news-current-message-number)) + newname)) + +;;; caesar-region written by phr@gnu.org Nov 86 +;;; modified by tower@gnu.org Nov 86 +(defun caesar-region (&optional n) + "Caesar rotation of region by N, default 13, for decrypting netnews." + (interactive (if current-prefix-arg ; Was there a prefix arg? + (list (prefix-numeric-value current-prefix-arg)) + (list nil))) + (cond ((not (numberp n)) (setq n 13)) + (t (setq n (mod n 26)))) ;canonicalize N + (if (not (zerop n)) ; no action needed for a rot of 0 + (progn + (if (or (not (boundp 'caesar-translate-table)) + (/= (aref caesar-translate-table ?a) (+ ?a n))) + (let ((i 0) (lower "abcdefghijklmnopqrstuvwxyz") upper) + (message "Building caesar-translate-table...") + (setq caesar-translate-table (make-vector 256 0)) + (while (< i 256) + (aset caesar-translate-table i i) + (setq i (1+ i))) + (setq lower (concat lower lower) upper (upcase lower) i 0) + (while (< i 26) + (aset caesar-translate-table (+ ?a i) (aref lower (+ i n))) + (aset caesar-translate-table (+ ?A i) (aref upper (+ i n))) + (setq i (1+ i))) + (message "Building caesar-translate-table... done"))) + (let ((from (region-beginning)) + (to (region-end)) + (i 0) str len) + (setq str (buffer-substring from to)) + (setq len (length str)) + (while (< i len) + (aset str i (aref caesar-translate-table (aref str i))) + (setq i (1+ i))) + (goto-char from) + (kill-region from to) + (insert str))))) + +;;; news-caesar-buffer-body written by paul@media-lab.mit.edu Wed Oct 1, 1986 +;;; hacked further by tower@gnu.org +(defun news-caesar-buffer-body (&optional rotnum) + "Caesar rotates all letters in the current buffer by 13 places. +Used to encode/decode possibly offensive messages (commonly in net.jokes). +With prefix arg, specifies the number of places to rotate each letter forward. +Mail and USENET news headers are not rotated." + (interactive (if current-prefix-arg ; Was there a prefix arg? + (list (prefix-numeric-value current-prefix-arg)) + (list nil))) + (save-excursion + (let ((buffer-status buffer-read-only)) + (setq buffer-read-only nil) + ;; setup the region + (set-mark (if (equal major-mode 'news-mode) + (progn (goto-char (point-min)) + (search-forward "\n\n" nil t)) + (mail-text-start))) + (goto-char (point-max)) + (caesar-region rotnum) + (setq buffer-read-only buffer-status)))) + +(provide 'rnews) + +;;; rnews.el ends here diff -r 3168ff2c349b -r 5c3a343fb1ce lisp/obsolete/rnewspost.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/obsolete/rnewspost.el Thu Jan 04 19:21:36 2001 +0000 @@ -0,0 +1,441 @@ +;;; rnewspost.el --- USENET news poster/mailer for GNU Emacs + +;; Copyright (C) 1985, 1986, 1987, 1995 Free Software Foundation, Inc. + +;; Maintainer: FSF +;; Keywords: mail, news + +;; This file is part of GNU Emacs. + +;; GNU Emacs 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. + +;; 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 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. + +;;; Change Log: + +;; moved posting and mail code from rnews.el +;; tower@gnu.org Wed Oct 29 1986 +;; brought posting code almost up to the revision of RFC 850 for News 2.11 +;; - couldn't see handling the special meaning of the Keyword: poster +;; - not worth the code space to support the old A news Title: (which +;; Subject: replaced) and Article-I.D.: (which Message-ID: replaced) +;; tower@gnu.org Nov 86 +;; changed C-c C-r key-binding due to rename of news-caesar-buffer-body +;; tower@gnu.org 21 Nov 86 +;; added (require 'rnews) tower@gnu.org 22 Apr 87 +;; restricted call of news-show-all-headers in news-post-news & news-reply +;; tower@gnu.org 28 Apr 87 +;; commented out Posting-Front-End to save USENET bytes tower@gnu.org Jul 31 87 +;; commented out -n and -t args in news-inews tower@gnu.org 15 Oct 87 + +;Now in paths.el. +;(defvar news-inews-program "inews" +; "Function to post news.") + +;; Replying and posting news items are done by these functions. +;; imported from rmail and modified to work with rnews ... +;; Mon Mar 25,1985 at 03:07:04 ads@mit-hermes. +;; this is done so that rnews can operate independently from rmail.el and +;; sendmail and doesn't have to autoload these functions. +;; +;;; >> Nuked by Mly to autoload those functions again, as the duplication of +;;; >> code was making maintenance too difficult. + +;;; Code: + +(require 'sendmail) +(require 'rnews) + +(defvar news-reply-mode-map () "Mode map used by news-reply.") + +(or news-reply-mode-map + (progn + (setq news-reply-mode-map (make-keymap)) + (define-key news-reply-mode-map "\C-c\C-f\C-d" 'news-reply-distribution) + (define-key news-reply-mode-map "\C-c\C-f\C-k" 'news-reply-keywords) + (define-key news-reply-mode-map "\C-c\C-f\C-n" 'news-reply-newsgroups) + (define-key news-reply-mode-map "\C-c\C-f\C-f" 'news-reply-followup-to) + (define-key news-reply-mode-map "\C-c\C-f\C-s" 'mail-subject) + (define-key news-reply-mode-map "\C-c\C-f\C-a" 'news-reply-summary) + (define-key news-reply-mode-map "\C-c\C-t" 'mail-text) + (define-key news-reply-mode-map "\C-c\C-r" 'news-caesar-buffer-body) + (define-key news-reply-mode-map "\C-c\C-w" 'news-reply-signature) + (define-key news-reply-mode-map "\C-c\C-y" 'news-reply-yank-original) + (define-key news-reply-mode-map "\C-c\C-q" 'mail-fill-yanked-message) + (define-key news-reply-mode-map "\C-c\C-c" 'news-inews) + (define-key news-reply-mode-map "\C-c\C-s" 'news-inews) + (define-key news-reply-mode-map [menu-bar] (make-sparse-keymap)) + (define-key news-reply-mode-map [menu-bar fields] + (cons "Fields" (make-sparse-keymap "Fields"))) + (define-key news-reply-mode-map [menu-bar fields news-reply-distribution] + '("Distribution" . news-reply-distribution)) + (define-key news-reply-mode-map [menu-bar fields news-reply-keywords] + '("Keywords" . news-reply-keywords)) + (define-key news-reply-mode-map [menu-bar fields news-reply-newsgroups] + '("Newsgroups" . news-reply-newsgroups)) + (define-key news-reply-mode-map [menu-bar fields news-reply-followup-to] + '("Followup-to" . news-reply-followup-to)) + (define-key news-reply-mode-map [menu-bar fields mail-subject] + '("Subject" . mail-subject)) + (define-key news-reply-mode-map [menu-bar fields news-reply-summary] + '("Summary" . news-reply-summary)) + (define-key news-reply-mode-map [menu-bar fields mail-text] + '("Text" . mail-text)) + (define-key news-reply-mode-map [menu-bar news] + (cons "News" (make-sparse-keymap "News"))) + (define-key news-reply-mode-map [menu-bar news news-caesar-buffer-body] + '("Rot13" . news-caesar-buffer-body)) + (define-key news-reply-mode-map [menu-bar news news-reply-yank-original] + '("Yank Original" . news-reply-yank-original)) + (define-key news-reply-mode-map [menu-bar news mail-fill-yanked-message] + '("Fill Yanked Messages" . mail-fill-yanked-message)) + (define-key news-reply-mode-map [menu-bar news news-inews] + '("Send" . news-inews)))) + +(defun news-reply-mode () + "Major mode for editing news to be posted on USENET. +First-time posters are asked to please read the articles in newsgroup: + news.announce.newusers . +Like Text Mode but with these additional commands: + +C-c C-s news-inews (post the message) C-c C-c news-inews +C-c C-f move to a header field (and create it if there isn't): + C-c C-f C-n move to Newsgroups: C-c C-f C-s move to Subj: + C-c C-f C-f move to Followup-To: C-c C-f C-k move to Keywords: + C-c C-f C-d move to Distribution: C-c C-f C-a move to Summary: +C-c C-y news-reply-yank-original (insert current message, in NEWS). +C-c C-q mail-fill-yanked-message (fill what was yanked). +C-c C-r caesar rotate all letters by 13 places in the article's body (rot13)." + (interactive) + (kill-all-local-variables) + (make-local-variable 'mail-reply-buffer) + (setq mail-reply-buffer nil) + (set-syntax-table text-mode-syntax-table) + (use-local-map news-reply-mode-map) + (setq local-abbrev-table text-mode-abbrev-table) + (setq major-mode 'news-reply-mode) + (setq mode-name "News Reply") + (make-local-variable 'paragraph-separate) + (make-local-variable 'paragraph-start) + (run-hooks 'text-mode-hook 'news-reply-mode-hook)) + +(defvar news-reply-yank-from "" + "Save `From:' field for `news-reply-yank-original'.") + +(defvar news-reply-yank-message-id "" + "Save `Message-Id:' field for `news-reply-yank-original'.") + +(defun news-reply-yank-original (arg) + "Insert the message being replied to, if any (in Mail mode). +Puts point before the text and mark after. +Indents each nonblank line ARG spaces (default 3). +Just \\[universal-argument] as argument means don't indent +and don't delete any header fields." + (interactive "P") + (mail-yank-original arg) + (exchange-point-and-mark) + (run-hooks 'news-reply-header-hook)) + +(defvar news-reply-header-hook + (lambda () + (insert "In article " news-reply-yank-message-id + " " news-reply-yank-from " writes:\n\n")) + "Hook for inserting a header at the top of a yanked message.") + +(defun news-reply-newsgroups () + "Move point to end of `Newsgroups:' field. +RFC 850 constrains the `Newsgroups:' field to be a comma-separated list +of valid newsgroup names at your site. For example, + Newsgroups: news.misc,comp.misc,rec.misc" + (interactive) + (expand-abbrev) + (goto-char (point-min)) + (mail-position-on-field "Newsgroups")) + +(defun news-reply-followup-to () + "Move point to end of `Followup-To:' field. Create the field if none. +One usually requests followups to only one newsgroup. +RFC 850 constrains the `Followup-To:' field to be a comma-separated list +of valid newsgroups names at your site, and it must be a subset of the +`Newsgroups:' field. For example: + Newsgroups: news.misc,comp.misc,rec.misc,misc.misc,soc.misc + Followup-To: news.misc,comp.misc,rec.misc" + (interactive) + (expand-abbrev) + (or (mail-position-on-field "Followup-To" t) + (progn (mail-position-on-field "newsgroups") + (insert "\nFollowup-To: "))) + ;; @@ could do a completing read based on the Newsgroups: field to + ;; @@ fill in the Followup-To: field +) + +(defun news-reply-distribution () + "Move point to end of `Distribution:' optional field. +Create the field if none. Without this field the posting goes to all of +USENET. The field is used to restrict the posting to parts of USENET." + (interactive) + (expand-abbrev) + (mail-position-on-field "Distribution") + ;; @@could do a completing read based on the news library file: + ;; @@ ../distributions to fill in the field. + ) + +(defun news-reply-keywords () + "Move point to end of `Keywords:' optional field. Create the field if none. +Used as an aid to the news reader, it can contain a few, well selected keywords +identifying the message." + (interactive) + (expand-abbrev) + (mail-position-on-field "Keywords")) + +(defun news-reply-summary () + "Move point to end of `Summary:' optional field. Create the field if none. +Used as an aid to the news reader, it can contain a succinct +summary (abstract) of the message." + (interactive) + (expand-abbrev) + (mail-position-on-field "Summary")) + +(defun news-reply-signature () + "The inews program appends `~/.signature' automatically." + (interactive) + (message "Posting news will append your signature automatically.")) + +(defun news-setup (to subject in-reply-to newsgroups replybuffer) + "Set up the news reply or posting buffer with the proper headers and mode." + (setq mail-reply-buffer replybuffer) + (let ((mail-setup-hook nil) + ;; Avoid inserting a signature. + (mail-signature)) + (if (null to) + ;; this hack is needed so that inews wont be confused by + ;; the fcc: and bcc: fields + (let ((mail-self-blind nil) + (mail-archive-file-name nil)) + (mail-setup to subject in-reply-to nil replybuffer nil) + (beginning-of-line) + (delete-region (point) (progn (forward-line 1) (point))) + (goto-char (point-max))) + (mail-setup to subject in-reply-to nil replybuffer nil)) + ;;;(mail-position-on-field "Posting-Front-End") + ;;;(insert (emacs-version)) + (goto-char (point-max)) + (if (let ((case-fold-search t)) + (re-search-backward "^Subject:" (point-min) t)) + (progn (beginning-of-line) + (insert "Newsgroups: " (or newsgroups "") "\n") + (if (not newsgroups) + (backward-char 1) + (goto-char (point-max))))) + (let (actual-header-separator) + (rfc822-goto-eoh) + (setq actual-header-separator (buffer-substring + (point) + (save-excursion (end-of-line) (point)))) + (setq paragraph-start + (concat "^" actual-header-separator "$\\|" paragraph-start)) + (setq paragraph-separate + (concat "^" actual-header-separator "$\\|" paragraph-separate))) + (run-hooks 'news-setup-hook))) + +(defun news-inews () + "Send a news message using inews." + (interactive) + (let* (newsgroups subject + (case-fold-search nil)) + (save-excursion + (save-restriction + (narrow-to-region (point-min) (mail-header-end)) + (setq newsgroups (mail-fetch-field "newsgroups") + subject (mail-fetch-field "subject"))) + (widen) + (goto-char (point-min)) + (run-hooks 'news-inews-hook) + (mail-sendmail-undelimit-header) + (goto-char (point-max)) + ;; require a newline at the end for inews to append .signature to + (or (= (preceding-char) ?\n) + (insert ?\n)) + (message "Posting to USENET...") + (unwind-protect + (if (not (eq 0 + (call-process-region (point-min) (point-max) + news-inews-program nil 0 nil + "-h"))) ; take all header lines! + ;@@ setting of subject and newsgroups still needed? + ;"-t" subject + ;"-n" newsgroups + (error "Posting to USENET failed") + (message "Posting to USENET... done")) + (mail-sendmail-delimit-header) + (set-buffer-modified-p nil))) + (bury-buffer))) + +;@@ shares some code with news-reply and news-post-news +(defun news-mail-reply () + "Mail a reply to the author of the current article. +While composing the reply, use \\[news-reply-yank-original] to yank the +original message into it." + (interactive) + (let (from cc subject date to reply-to message-id + (buffer (current-buffer))) + (save-restriction + (narrow-to-region (point-min) (progn (goto-line (point-min)) + (search-forward "\n\n") + (- (point) 1))) + (setq from (mail-fetch-field "from") + subject (mail-fetch-field "subject") + reply-to (mail-fetch-field "reply-to") + date (mail-fetch-field "date") + message-id (mail-fetch-field "message-id"))) + (setq to from) + (pop-to-buffer "*mail*") + (mail nil + (if reply-to reply-to to) + subject + (let ((stop-pos (string-match " *at \\| *@ \\| *(\\| *<" from))) + (concat (if stop-pos (substring from 0 stop-pos) from) + "'s message " + (if message-id + (concat message-id " of ") + "of ") + date)) + nil + buffer))) + +;@@ the guts of news-reply and news-post-news should be combined. -tower +(defun news-reply () + "Compose and post a reply (aka a followup) to the current article on USENET. +While composing the followup, use \\[news-reply-yank-original] to yank the +original message into it." + (interactive) + (if (y-or-n-p "Are you sure you want to followup to all of USENET? ") + (let (from cc subject date to followup-to newsgroups message-of + references distribution message-id + (buffer (current-buffer))) + (save-restriction + (and (not (= 0 (buffer-size))) ;@@real problem is non-existence of + ;@@ of article file + (equal major-mode 'news-mode) ;@@ if rmail-mode, + ;@@ should show full headers + (progn + (news-show-all-headers) ;@@ should save/restore header state, + ;@@ but rnews.el lacks support + (narrow-to-region (point-min) (progn (goto-char (point-min)) + (search-forward "\n\n") + (- (point) 1))))) + (setq from (mail-fetch-field "from") + news-reply-yank-from from + ;; @@ not handling old Title: field + subject (mail-fetch-field "subject") + date (mail-fetch-field "date") + followup-to (mail-fetch-field "followup-to") + newsgroups (or followup-to + (mail-fetch-field "newsgroups")) + references (mail-fetch-field "references") + ;; @@ not handling old Article-I.D.: field + distribution (mail-fetch-field "distribution") + message-id (mail-fetch-field "message-id") + news-reply-yank-message-id message-id) + (pop-to-buffer "*post-news*") + (news-reply-mode) + (if (and (buffer-modified-p) + (not + (y-or-n-p "Unsent article being composed; erase it? "))) + () + (progn + (erase-buffer) + (and subject + (progn (if (string-match "\\`Re: " subject) + (while (string-match "\\`Re: " subject) + (setq subject (substring subject 4)))) + (setq subject (concat "Re: " subject)))) + (and from + (progn + (let ((stop-pos + (string-match " *at \\| *@ \\| *(\\| *<" from))) + (setq message-of + (concat + (if stop-pos (substring from 0 stop-pos) from) + "'s message " + (if message-id + (concat message-id " of ") + "of ") + date))))) + (news-setup + nil + subject + message-of + newsgroups + buffer) + (if followup-to + (progn (news-reply-followup-to) + (insert followup-to))) + (if distribution + (progn + (mail-position-on-field "Distribution") + (insert distribution))) + (mail-position-on-field "References") + (if references + (insert references)) + (if (and references message-id) + (insert " ")) + (if message-id + (insert message-id)) + (goto-char (point-max)))))) + (message ""))) + +;@@ the guts of news-reply and news-post-news should be combined. -tower +;;;###autoload +(defun news-post-news (&optional noquery) + "Begin editing a new USENET news article to be posted. +Type \\[describe-mode] once editing the article to get a list of commands. +If NOQUERY is non-nil, we do not query before doing the work." + (interactive) + (if (or noquery + (y-or-n-p "Are you sure you want to post to all of USENET? ")) + (let ((buffer (current-buffer))) + (save-restriction + (and (not (= 0 (buffer-size))) ;@@real problem is non-existence of + ;@@ of article file + (equal major-mode 'news-mode) ;@@ if rmail-mode, + ;@@ should show full headers + (progn + (news-show-all-headers) ;@@ should save/restore header state, + ;@@ but rnews.el lacks support + (narrow-to-region (point-min) (progn (goto-char (point-min)) + (search-forward "\n\n") + (- (point) 1))))) + (setq news-reply-yank-from (mail-fetch-field "from") + ;; @@ not handling old Article-I.D.: field + news-reply-yank-message-id (mail-fetch-field "message-id"))) + (pop-to-buffer "*post-news*") + (news-reply-mode) + (if (and (buffer-modified-p) + (not (y-or-n-p "Unsent article being composed; erase it? "))) + () ;@@ not saving point from last time + (progn (erase-buffer) + (news-setup () () () () buffer)))) + (message ""))) + +(defun news-mail-other-window () + "Send mail in another window. +While composing the message, use \\[news-reply-yank-original] to yank the +original message into it." + (interactive) + (mail-other-window nil nil nil nil nil (current-buffer))) + +(provide 'rnewspost) + +;;; rnewspost.el ends here