Thanks so much for tracking all this down! Il make a quilt patch and this will be in the next upload.
Peter Gijs Hillenius <g...@hillenius.net> wrote: > Hello Peter, > > > I tried my fix (in previous message) again, and now it seems to work in > Emacs25. Have not tested in Emacs24.. > > > Here is my changed version of tc.el > > I dropped those four lines at the top of the code > *and* > I replaced all the save-excursion into save-mark-and-excursion. > > > ;;; trivial-cite -- cite text with proper filling > ;; > ;; TrivialCite v0.13.4 > ;; This is my attempt at making a sensible citer. > ;; > ;; This program is copyright (c) 1998 Lars R. Clausen > ;; > ;; Time-stamp: <2003-05-14 16:21:59 lrclause> > ;; > ;; Author: Lars R. Clausen <lrcla...@cs.uiuc.edu> > ;; Created: March 1998 > ;; Keywords: Citing, filling, mail, news > ;; X-URL: http://shasta.cs.uiuc.edu/~lrclause/tc.html > ;; > ;; trivial-cite 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. > > ;; trivial-cite 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 trivial-cite; see the file COPYING. If not, write to the > ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, > ;; Boston, MA 02111-1307, USA. > > ;;; Commentary: > ;; > ;; Trivial-Cite is an Emacs package with the same purpose as Supercite: > ;; Cite text for mail and posting, but with different > ;; objectives. Trivial-Cite tries hard to do the following correctly: > ;; > ;; 1. Fill paragraphs of previously cited text correctly, even when > ;; encountering strange citing marks. > ;; 2. Parse the cited headers to allow attribution in a configurable way. > ;; 3. Allow the user to undo formatting. > ;; 4. Remove the signature as the last undoable action. > ;; 5. Allow the user to cite and fill cited text in other contexts. > ;; 6. Fix odd-looking citemarks to look nice (optional with > ;; `tc-normalize-cite-marks'). > ;; > ;; Furthermore, it follows the suggestions of Son-of-RFC1036 and cites with > ;; a >, and sensibly so. > ;; > ;; No, I will not make it quote with name abbreviations like SuperCite does. > ;; That style is annoying and unreadable, goes against the RFC's (or rather, > ;; the sons of them:), and have generally been the most problematic thing to > ;; deal with. Trivial-cite can handle them, but is better at 'normal' > ;; citation marking. > ;; > ;; To use, add the following to your .emacs: > ;; > ;; (autoload 'trivial-cite "tc" t t) > ;; > ;; ;; For Gnus: > ;; > ;; (setq message-cite-function 'trivial-cite) > ;; > ;; ;; For MH-E > ;; (add-hook 'mail-citation-hook 'trivial-cite) > ;; (setq mh-yank-from-start-of-msg t) > ;; ;; -> then use `C-cC-y' in your draft. > > ;; TODO: Good way to undo fillings without mouse. > ;; More funny functions:) > ;; Add space after cite-marks if old citing doesn't have it? > ;; Make tc-fill-cited-paragraph faster by re-inserting all at once. > ;; Generally optimize -- font-lock wastes time. > ;; Some simpler way to generate attributions? > ;; Follow Stallmans advice: Better docs, what's different from > ;; SuperCite, better comments, how is the filling different > ;; from standard Emacs filling. > > ;; Reminder: > ;; When mail-citation-hook is run, the cite is in current-buffer, (point) at > ;; start and (mark t) at end. > > ;;; Code: > (eval-when-compile > (when (< emacs-major-version 25) > (defmacro save-mark-and-excursion (&rest body) > `(save-excursion ,@body)))) > > ;;; ************************************************************ > ;;; External requirements here > ;;; ************************************************************ > > (require 'mail-extr) > (if (featurep 'xemacs) > (require 'overlay)) > > ;;; ************************************************************ > ;;; Meta-parameters here > ;;; ************************************************************ > > (defconst tc-maintainer "lrcla...@cs.uiuc.edu") > > (defconst tc-version "0.13.3") > > (defvar tc-debug-level 0 > "How much debugging output `trivial-cite' should give.") > > ;;; ************************************************************ > ;;; Normal user-settable parameters here > ;;; ************************************************************ > > (defgroup tc nil "Insert cited text in a nice manner") > > (defcustom tc-remove-signature "^\\(-- \\|--\\)$" > "If non-nil, specify a regexp that finds the signature divider. > The lines below the first match of this regexp will be removed, but > immediately available in the undo buffer. If nil, the signature will > not be removed." > :type 'regexp > :group 'tc) > > (defcustom tc-fill-column t > "If t means attempt to fill paragraphs with long lines. > Trivial-cite attempts to guess citation marks and fill the cited > paragraphs accordingly, when there are lines of more than `fill-column' > characters including citation marks. If you wish to undo the > filling, each paragraph filling can be undone with > \\[tc-unfill-paragraph]. > An integer argument means wrap at that column instead of at `fill-column'" > :type '(radio (const :tag "Fill at `fill-column'" t) > (integer :tag "Fill at this column") > (const :tag "Don't fill" nil)) > :group 'tc) > > (defcustom tc-mouse-overlays nil > "Non-nil means mark filled paragraphs with a mouse overlay. > Right-clicking such an overlay toggles filling of that paragraph, > like with \\[tc-unfill-paragraph]." > :type 'boolean > :group 'tc) > > ; Not ready yet > ; (defcustom tc-cleanup-cited-marks nil > ; "Non-nil means uniform citation marks are substituted in cited text. > ; Thus any sequence of cite-marks such as \"> |: }\" will be replace with a > ; uniform string of the citemarks of your choice, e.g. \">>>> \"." > ; :type 'boolean > ; :group 'tc) > > (defcustom tc-make-attribution 'tc-simple-attribution > "The function used to generate a attribution for a citation. > `tc-simple-attribution' is primitive, but easy to use. > `tc-tiny-attribution' is a minimal attribution. > `tc-simple-attribution-kai' uses the real name if found. > `tc-fancy-attribution' can be used to personalize the attribution." > :type '(radio > (const :tag "On 3 Sep 2003, email wrote:" tc-simple-attribution) > (const :tag "Real Name wrote:" tc-tiny-attribution) > (const :tag "Real Name <email> wrote:" > tc-attribution-name-and-email-wrote) > (const :tag "On 3 Sep 2003, Real Name wrote:" > tc-simple-attribution-kai) > (const :tag "On 3 Sep 2003, Real Name spake thusly:" > tc-fancy-attribution) > (function :tag "Other custom function")) > :group 'tc) > > (defcustom tc-time-format "%e %b %Y" > "The time format used for the date part in the attribution. > The date is taken from the header fields. The format is passed to > `format-time-string', see that function for more information." > :type 'string > :group 'tc) > > (defcustom tc-normal-citemarks ">" > "The characters that should always be considered citation marks. > This would normally just be '>', but if you often cite text with other > regular characters used for citing, you can ease the life for both > `trivial-cite' and yourself by adding them here." > :type 'string > :group 'tc) > > (defcustom tc-guess-cite-marks 'ask > "*Non-nil means try to guess at non-standard cite-marks. > The guess it made from a list of characters `tc-guess-marks-regexp' > which might be used for it. If the value is 'ask, trivial-cite will > ask if the marks found are correct." > :type '(choice (const nil) (const t) (const ask)) > :group 'tc) > > (defcustom tc-guess-marks-regexp "\\=[]>};:|#$@ ]*[]>};:|#$@]" > (concat "The regexp used for guessing at non-standard cite-marks. > If you see anyone using other characters (not alphanumeric) for citing, > plese tell " tc-maintainer " so they can be added to the list in the > distribution.") > :type 'regexp > :group 'tc) > > (defcustom tc-normalize-cite-marks t > "Non-nil means normalize other peoples citation marks to match yours." > :type 'boolean > :group 'tc) > > (defcustom tc-citation-string ">" > "The string that `trivial-cite' inserts to make a citation. > The standard string (as noted in son-of-RFC1036) is '>'. You should > not change this, as that makes it more difficult for citers (even > `trivial-cite') to identify citings correctly. An extra space is > inserted after the string, if the cited text does not seem to be cited > already. See `tc-normal-citemarks' and `tc-guess-marks-regexp' for > how cite marks are found." > :type 'string > :group 'tc) > > (defcustom tc-gnus-nntp-header-hack nil > "Non-nil means check for Gnus 5.8.7 odd header insertion. > Gnus 5.8.7 inserts an NNTP header line that's odd (haven't seen it myself, > but got a report from <kai.grossjoh...@cs.uni-dortmund.de> about it), > and this hack removes the line. It may conceivably do damage to other lines, > too, so I'm looking for a better solution." > :type 'boolean > :group 'tc) > > (defcustom tc-pre-hook nil > "*Hook called in the very beginning of `trivial-cite'." > :type 'hook > :group 'tc) > > (defcustom tc-post-hook nil > "*Hook called in the very end of `trivial-cite'." > :type 'hook > :group 'tc) > > ;;; ************************************************************ > ;;; Functions that parse the cited headers to allow attribution. > ;;; ************************************************************ > > (defvar tc-strings-list () > "An association list containing the parsed headers. > Typical entries are (\"subject\".\"Re: tc bug\"), (\"real-name\".\"John > Doe\"), > \(\"email-addr\".\"elasc...@daimi.aau.dk\") etc., but there is no fixed > format.") > > (defvar tc-header-funs > (list > (cons "From" 'tc-parse-from) > ;; The Subject: field - just put text into tc-strings-list > (cons "Subject" '(lambda (x) > (setq tc-strings-list > (cons (cons "subject" x) tc-strings-list)))) > (cons "Date" 'tc-parse-date) > (cons "Newsgroups" 'tc-parse-groups)) > "An association list used by `trivial-cite'. > It contains the various functions for decoding headers. The function gets > a string as argument, which is the contents of that header (possibly > including newlines, but excluding starting spaces). Any return value is > ignored. `tc-strings-list' is an association list destined to hold the > parsed data." ) > > ;; parse the headers in the quote, calling funcs > (defun tc-parse-headers () > "Parse the headers of a mail message. > Also calls the functions defined in `tc-header-funs' on the respective > fields." > ;; Still a header here? > (let ((header-start (point))) > (if tc-gnus-nntp-header-hack > ;; From <kai.grossjoh...@cs.uni-dortmund.de>, to deal with > ;; Gnus 5.8.7 putting the NNTP header into the buffer > (while (looking-at "2[0-9][0-9] ") > (delete-region (point) (progn (forward-line 1) (point))) > (setq header-start (point)))) > (while (not (looking-at "\012")) > ;; Find field name > (if (not (looking-at "\\\([!-9;-~]+\\\):[ ]*\\\([^ ]?.*\\\)")) > (message "Malformed field") > (let > ((field-name (buffer-substring-no-properties > (match-beginning 1) (match-end 1))) > (field-contents (buffer-substring-no-properties > (match-beginning 2) (match-end 2)))) > ;; Unfold > (forward-line 1) > (while (looking-at "[ \011]") > (let ((beg (point))) > (end-of-line) > (setq field-contents (concat field-contents > (buffer-substring-no-properties > beg (point)))) > (forward-line 1))) > > (if (string-match "[^ \011].*$" field-contents) > (setq field-contents > (substring field-contents > (match-beginning 0))) > (setq field-contents "")) > > ;; Find function for this field name > (let ((field-func (assoc field-name tc-header-funs))) > (if field-func > (progn > (setq field-func (cdr field-func)) > (funcall field-func field-contents))))))) > > (forward-line 1);; Skip past one blank line seperating headers and body > (delete-region header-start (point)))) > > ;;; Functions to parse individual headers into appropriate structures here > > (defun tc-parse-date (str) > "Use `tc-time-format' to parse the date STR for use in attributions. > The resulting string is inserted into `tc-strings-list'." > (let* ((time (date-to-time str)) > (date (format-time-string tc-time-format time))) > (setq tc-strings-list (cons (cons "date" date) tc-strings-list)))) > > ;; Parse a From:-style field from str into tc-strings-list under key > (defun tc-parse-from (str) > "Use mail-extr to get email-addr and real-name into `tc-strings-list' from > STR." > (if (> tc-debug-level 0) > (message "%s" (concat "Parsing from string '" str "'"))) > (let ((names (mail-extract-address-components str))) > (if names > (progn > (if (car names) > (setq tc-strings-list (cons (cons "real-name" (car names)) > tc-strings-list))) > (if (car (cdr names)) > (setq tc-strings-list (cons (cons "email-addr" (car (cdr names))) > tc-strings-list))))))) > > (defun tc-parse-groups (str) > (if (> tc-debug-level 0) > (message "%s" (concat "Parsing groups string '" str "'"))) > (let ((pos 0) > groups) > (while (string-match ",[ \012]*" str pos) > (setq groups (cons (substring str pos (1- (match-end 0))) groups)) > (setq pos (match-end 0))) > (setq tc-strings-list > (cons (cons "newsgroups" > (nreverse (cons (substring str pos (length str)) > groups))) > tc-strings-list)))) > > ;;; Functions to make various default attributions here > ;; My simple (but nice:) attribution function > (defun tc-simple-attribution () > "Make an attribution from email address and date." > (let ((date (assoc "date" tc-strings-list)) > (name (assoc "email-addr" tc-strings-list))) > (if (null name) > "An unnamed person wrote:\n\n" > (if (null date) > (concat (cdr name) " wrote:\n\n") > (concat "On " (cdr date) ", " (cdr name) " wrote:\n\n"))))) > > (defun tc-attribution-name-and-email-wrote () > "Produce attribution string, using the real name and email address." > (let ((email (assoc "email-addr" tc-strings-list)) > (realname (assoc "real-name" tc-strings-list))) > (cond > ((and (null realname)(null email)) > "An unnamed person wrote:\n\n") > ((null realname) > (format "%s wrote:\n\n" (cdr email))) > (t > (format "%s <%s> wrote:\n\n" (cdr realname) (cdr email)))))) > > ;; A simple attribution by Kai Großjohann <kai.grossjoh...@cs.uni-dortmund.de> > (defun tc-simple-attribution-kai () > "Produce the standard attribution string, using the real name." > (let ((date (assoc "date" tc-strings-list)) > (email (assoc "email-addr" tc-strings-list)) > (name (assoc "real-name" tc-strings-list))) > (if (and (null name) (null email)) > "An unnamed person wrote:\n\n" > (if (null date) > (concat (cdr (or name email)) " wrote:\n\n") > (concat "On " (cdr date) ", " (cdr (or name email)) " wrote:\n\n"))))) > > ;; A very small attribution, using real name or email > (defun tc-tiny-attribution () > "Produce a very small attribution string." > (let ((email (assoc "email-addr" tc-strings-list)) > (name (assoc "real-name" tc-strings-list))) > (concat (cdr (or name email '(t . "Somebody"))) " wrote:\n\n"))) > > ;;; ************************************************************ > ;;; Deal with the signature and other minor fuzz. > ;;; ************************************************************ > > ;; Normally, the signature should be removed, if we can find > ;; it. But we want it to be ready for the first undo. > (defvar tc-removed-sig nil > "The signature removed from the last mailing.") > (defvar tc-removed-sig-marker nil > "Marks the place where the signature was removed from the last mailing.") > > (defun tc-do-remove-sig () > "Attempt to remove the signature from already quoted text. > Warns if it is longer than 4 lines (5 including signature mark '-- ')." > (save-mark-and-excursion > (setq tc-removed-sig nil) > (setq tc-removed-sig-marker nil) > (exchange-point-and-mark) > (let ((msgend (point))) > (if (re-search-backward tc-remove-signature 0 t) > ;; Found it > (let ((lines (count-lines (point) msgend))) > (setq tc-removed-sig (buffer-substring (point) msgend)) > (delete-region (point) msgend) > (setq tc-removed-sig-marker (point-marker)) > (if (> lines 5);; Remember to include the '-- ' mark > (message (concat "Signature was very large (" > (int-to-string (- lines 1)) " lines).")))))))) > > (defun tc-fix-signature-undo () > "Make the signature be after filling in undo list, and quoted." > (if tc-removed-sig > (progn > (save-mark-and-excursion > (goto-char (marker-position tc-removed-sig-marker)) > (insert tc-removed-sig) > (let ((sig-end (point-marker))) > (goto-char (marker-position tc-removed-sig-marker)) > (while (< (point) (marker-position sig-end)) > (insert tc-citation-string " ") > (forward-line 1))) > (undo-boundary) > (delete-region (marker-position tc-removed-sig-marker) > (point)))))) > > ;; Simple nested indentation, as defined in son-of-rfc1036 (plus one space > ;; after > before non-cited text for readability). > > (defvar tc-cite-marks nil > "Cite-marks that are recognised by trivial-cites functions. > These are deleted after each citing.") > > ;; Give some extra characters that have been used for indention, so we know > ;; to handle them. > (defun tc-extra-cite-marks (str) > "Specify extra cite-marks STR (apart from '>') that are used for citing. > They remain valid for one citing only." > (interactive "sExtra cite-marks: ") > (if (not (equal str "")) > (setq tc-cite-marks str))) > > ;; Thanks to Matthias Wiehl for this function > (defun tc-cleanup-cite-marks (start end) > "Substitute uniform citation marks in the region between START and END. > Replaces any sequence of cite-marks such as \"> |: }\" with a uniform string > of the citemarks of your choice, e.g. \">>>> \"." > (interactive "r") > (save-mark-and-excursion > (goto-char start) > (let ((end-marker (set-marker (make-marker) end))) > (while (< (point) (marker-position end-marker)) > (if (looking-at " ") > (delete-char 1) > (if (looking-at (concat "[" tc-cite-marks "]")) > (progn > (insert tc-citation-string) > (delete-char 1)) > (progn > (if (and (not (eq (preceding-char) ?\ )) > (not (looking-at "$"))) > (insert " ")) > (forward-line 1)))))))) > > (defun tc-indent-citation () > "Indent the current region with `tc-citation-string'. > It inserts an extra space before text that is not already cited (with > `tc-cite-marks'), except on empty lines (to avoid dangling space)." > (while (< (point) (mark t)) > (cond ((re-search-forward (concat "[" tc-cite-marks "]") (1+ (point)) t) > (forward-char -1) > (insert tc-citation-string)) > ((looking-at "^$") > (insert tc-citation-string)) > (t (insert tc-citation-string " "))) > (forward-line 1))) > > (defun tc-remove-trailing-whitespace () > "Remove trailing whitespace." > ;; First remove trailing empty lines > (save-mark-and-excursion > (if (< (point) (mark t)) > (exchange-point-and-mark)) > (let ((end-cite (point))) > (re-search-backward "[^ \t\n]" 0 t);; Skip empty lines > (forward-line 1);; Whoops, got one line too far > (delete-region (point) end-cite)))) > > (defun tc-combine-cite-marks (cm1 cm2) > "Combine two sets of cite-marks so that there are no duplicates. > In fact, it checks if CM1 contains CM2, and if not, makes it so." > (if (not (string-match (regexp-quote cm1) cm2)) > (concat cm1 cm2) > cm1)) > > (defvar tc-old-yank nil) > > (defvar tc-prefix-max-lines t > "If t, `message-yank-original' takes a prefix max number of lines.") > > ; (defun tc-message-yank-original (&optional lines) > ; "Insert the message being replied to, if any. > ; Puts point before the text and mark after. > ; Indents the text using trivial-cite (cv). > ; A numeric prefix is the maximal number of (body) lines to cite. > > ; This function uses `message-cite-function' to do the actual citing. > ; " > ; (interactive "P") > ; (message (concat "Prefix is '" lines "'")) > ; (if lines > ; (setq tc-max-lines lines) > ; (setq tc-max-lines nil)) > ; (tc-old-yank)) > > ;; Replace the normal message-yank-original with a version that uses > ;; the prefix to limit the number of lines. Somewhat of a hack, but I like to > ;; be able to do this:) > ;; Now uses advice > (if tc-prefix-max-lines > (defadvice message-yank-original (before max-lines-advice first > (&optional lines) activate) > "A numeric prefix is the maximal number of (body) lines to cite. > " > (interactive "P") > (if lines > (setq tc-max-lines lines) > (setq tc-max-lines nil)) > (setq lines nil) ; Make message-yank-original happy > )) > > (defvar tc-max-lines nil > "*Maximum number of lines that should be quoted by `trivial-cite'. > If `tc-max-lines-reset' is non-nil (the default), `tc-max-lines' is set to nil > \(meaning no limit) after each cite.") > > (defvar tc-max-lines-reset t > "*Whether `tc-max-lines' should be reset after use. > Normally, `tc-max-lines' is set to limit the citation of very long mails (e.g. > citations).") > > (defun tc-indent-region (start end) > "*Cite the region like `trivial-cite', but without parsing headers. > Doesn't cut the signature either. Region is between START and END." > (interactive "r") > (save-mark-and-excursion > (if (> start end) > (let ((tmp start)) (setq start end) (setq end tmp))) > (goto-char start) > (set-mark end) > (setq tc-strings-list ()) > ;; Get the correct set of cite-marks, guessing if necessary > ;; (delayed until now to allow sig to be removed) > (if tc-cite-marks > (setq tc-cite-marks (tc-combine-cite-marks > tc-normal-citemarks tc-cite-marks)) > (if tc-guess-cite-marks > (setq tc-cite-marks (tc-combine-cite-marks > tc-normal-citemarks (tc-guess-cite-marks))) > (setq tc-cite-marks tc-normal-citemarks))) > ;; Escape any cite-marks that would cause problems in a regexp > (setq tc-cite-marks (tc-escape-char-range tc-cite-marks)) > ;; Do the actual citation > (tc-indent-citation) > ;; Normalize cite marks if so wanted > (if tc-normalize-cite-marks > (tc-cleanup-cite-marks start end)) > ;; Fill paragraphs > (if tc-fill-column > (tc-fill-cited-text start end)) > (setq tc-cite-marks nil))) > > (defun tc-fix-final-newline () > "Add a newline if there is not one at the end of the cited text." > (save-mark-and-excursion > (exchange-point-and-mark) > (if (not (bolp)) > (insert "\n")))) > > ;;; ************************************************************ > ;;; The main citation engine > ;;; ************************************************************ > ;;;###autoload > (defun trivial-cite () > "A simple citation function for use in news/mailreaders. > It parses the headers via the functions defined in `tc-header-funs', then > makes a attribution for the citation using `tc-make-attribution' and indents > the inserted text with `tc-indent-citation'. > Numeric prefix arguments is how many lines of body to cite (useful for citing > mails with long attachments). > Usage: (auto-load 'trivial-cite \"tc\" t t) > (add-hook 'mail-citation-hook 'trivial-cite) > Bugs: Not very intelligent about old citation marks other than '>'. > Customization: See variables tc-fill-column, tc-remove-signature, > tc-citation-string, tc-make-attribution and tc-header-funs." > (run-hooks 'tc-pre-hook) > (save-mark-and-excursion > (if (< (mark t) (point)) (exchange-point-and-mark)) > (let ((start (point))) > ;; Initialize some fields > (setq tc-strings-list ()) > ;; Allow undo to show the unformatted text > (undo-boundary) > (tc-fix-final-newline) > ;; Parse the headers - assumes point at first header > (tc-parse-headers) > ;; Insert a attribution ("XXX wrote...:" etc) > (if tc-make-attribution > (let ((start-marker (point-marker)) > (fill-prefix)) > (insert (funcall tc-make-attribution)) > (fill-region (marker-position start-marker) (point)) > (setq start (point)))) > (tc-remove-trailing-whitespace) > ;; Remove signature (if so wanted) > (if tc-remove-signature > (tc-do-remove-sig)) > (tc-remove-trailing-whitespace) > (if tc-max-lines > (save-mark-and-excursion > (message (concat "Only citing " > (int-to-string tc-max-lines) " lines")) > (goto-char start) > (forward-line tc-max-lines) > (kill-region (point) (mark t)) > (if tc-max-lines-reset (setq tc-max-lines nil)))) > ;; Get the correct set of cite-marks, guessing if necessary > ;; (delayed until now to allow sig to be removed) > (if tc-cite-marks > (setq tc-cite-marks (tc-combine-cite-marks > tc-normal-citemarks tc-cite-marks)) > (if tc-guess-cite-marks > (setq tc-cite-marks (tc-combine-cite-marks > tc-normal-citemarks (tc-guess-cite-marks))) > (setq tc-cite-marks tc-normal-citemarks))) > ;; Escape any cite-marks that would cause problems in a regexp > (setq tc-cite-marks (tc-escape-char-range tc-cite-marks)) > ;; Do the actual citation > (tc-indent-citation) > ;; Normalize cite marks if so wanted > (if tc-normalize-cite-marks > (tc-cleanup-cite-marks start (mark-marker))) > ;; Fill paragraphs > (if tc-fill-column > (tc-fill-cited-text start (mark-marker))) > (setq tc-cite-marks nil) > (tc-fix-signature-undo))) > (run-hooks 'tc-post-hook)) > > ;;; ************************************************************ > ;;; Reformatting cited text > ;;; ************************************************************ > > (defun tc-fill-column () > "Return the fill column that tc uses (explicit, `fill-column' or nil)." > (cond ((integerp tc-fill-column) tc-fill-column) > (tc-fill-column fill-column) > (t nil))) > > (defun tc-fill-cited-paragraphs (cite-len) > "Fill cited paragraphs, keeping cite-marks in their correct places. > Used internally in tc-fill-cited-text. Returns the end of the last filled > paragraph." > (interactive "nLength of citation marks: ") > (let (fill-end) > (save-mark-and-excursion > (save-restriction > (beginning-of-line) > (let ((cite-marks (buffer-substring (point) (+ (point) cite-len))) > (fill-line (point))) > (if (>= tc-debug-level 1) > (message (concat "Citing marked with " > cite-marks ", extra marks are " tc-cite-marks))) > (let ((cite-regexp (concat "^" cite-marks > " *[^\n" tc-cite-marks " ]"))) > ;; Look backward while properly cited > (while (and (not (bobp)) (looking-at cite-regexp)) > (forward-line -1)) > (if (not (looking-at cite-regexp)) > (forward-line 1)) > (let ((cite-start (point)) > (fill-column (- (tc-fill-column) cite-len))) > (goto-char fill-line) > (while (and (not (eobp)) (looking-at cite-regexp)) > (forward-line 1)) > (if (looking-at cite-regexp) > (end-of-line)) > (narrow-to-region cite-start (point)) > (forward-line -1) > (forward-char cite-len) > (let ((cut-text (buffer-substring (point-min) (point-max)))) > (delete-extract-rectangle cite-start (point)) > (goto-char fill-line) > (while (not (eobp)) > (fill-paragraph nil) > (forward-paragraph)) > (goto-char cite-start) > (while (not (eobp)) > (insert cite-marks) > (forward-line 1)) > (setq fill-end (point)) > (let ((reformat-overlay > (make-overlay (point-min) (point-max)))) > (overlay-put reformat-overlay > 'tc-reformat (cons cut-text reformat-overlay)) > ;; Should check for mouse > (local-set-key "\C-c\C-p" 'tc-unfill-paragraph) > (if tc-mouse-overlays > (progn > (overlay-put reformat-overlay > 'mouse-face 'secondary-selection) > (local-set-key [(shift button2)] > 'tc-unfill-paragraph-mouse)))))))))) > fill-end)) > > (defun tc-escape-char-range (str) > "Escape any characters in STR that cause problems in a regexp char range. > This, is not the same as `regexp-quote', as we need to treat ^ and ] very > specially." > (if (string-match "\\(-.*]\\|].*-\\)" str) > ;; - and ] in a string -- got to seperate them > (message "Can't have both - and ] in a regular expression (yet).") > (when (string-match "-" str) > ;; Move a "-" to start of the string > (while (string-match "-" str) > (setq str (replace-match "" nil nil str))) > (setq str (concat "-" str))) > (when (string-match "]" str) > ;; Move a "]" to the start of the string > (while (string-match "]" str) > (setq str (replace-match "" nil nil str))) > (setq str (concat "]" str))) > (when (string-match "^\\^" str) > ;; Move the "^" to not be at the start of the string > (replace-match "" nil nil str) > (setq str (concat str "^")))) > str) > > (defun tc-find-cite-len (p) > "Find the length of the citation marking at point P. > This is so we can fix it when filling. > Used internally in `tc-fill-cited-text'." > (save-mark-and-excursion > (goto-char p) > (forward-line 1) > (let ((forward-prefix-length (tc-line-common-prefix-length p (point)))) > (forward-line -2) > (let ((backward-prefix-length (tc-line-common-prefix-length p (point)))) > (goto-char p) > (beginning-of-line) > (let ((prefix-length > (max forward-prefix-length backward-prefix-length)) > (line-start (point))) > (end-of-line) > (let ((line-end (point))) > (beginning-of-line) > ;; Check if this is a one-line cite with good cite-marks > (if (and (re-search-forward > (concat "^[" tc-cite-marks " ]*[" tc-cite-marks "][" > tc-cite-marks " ]*") line-end t) > (> (- (match-end 0) (match-beginning 0)) prefix-length)) > (- (match-end 0) (match-beginning 0)) > (forward-char prefix-length) > (if (re-search-backward > (concat "[" tc-cite-marks "][" tc-cite-marks " ]*") > line-start t) > (- (match-end 0) line-start) > 0)))))))) > > ;; Find all lines that are too long and fill them > (defun tc-fill-cited-text (start end) > "Fill all lines in region that are too long, keeping track of cite-marks. > Done on region between START and END. > Uses a seperate undo-mechanism (with overlays) to allow partial undo." > (interactive "r") > (save-mark-and-excursion > (goto-char start) > (while (< (point) end) > (beginning-of-line) > (end-of-line) > (if (> (current-column) (tc-fill-column)) > (progn > (let ((cite-len (tc-find-cite-len (point)))) > (if (> cite-len 0) > (if (< cite-len (tc-fill-column)) > (goto-char (tc-fill-cited-paragraphs cite-len)) > (message (concat "Very long cite mark (" > (int-to-string cite-len) " chars)")) > (forward-line 1)) > (message (concat "Mysterious zero cite-len at " > (int-to-string (point)))) > (forward-line 1)))) > (forward-line 1))))) > > ;; A couple utility functions. > > (defun tc-line-common-prefix-length (p1 p2) > "Return the number of characters the two lines have as common prefix. > The two lines are at point P1 and P2." > (save-mark-and-excursion > (let ((line1 (progn (goto-char p1) (beginning-of-line) > (let ((line-start (point))) > (end-of-line) > (buffer-substring line-start (point))))) > (line2 (progn (goto-char p2) (beginning-of-line) > (let ((line-start (point))) > (end-of-line) > (buffer-substring line-start (point)))))) > (tc-string-common-prefix-length line1 line2)))) > > (defun tc-string-common-prefix-length (s1 s2) > "Return how many characters in S1 and S2 are equal." > (let ((len (min (length s1) (length s2))) > (x 0)) > (while (and (< x len) > (equal (aref s1 x) (aref s2 x))) > (setq x (1+ x))) > x)) > > (defun tc-fill-cited-region (start end) > "Fill all lines in the region, but keep the overall citation intact. > The region is between START and END. > This function assumes that all lines in the region have the same citation > marks, as it regards the shortest common prefix of the lines as citation > marks." > (interactive "r") > ;;(save-mark-and-excursion > (goto-char start) > (beginning-of-line) > (let ((line-start (point))) > (end-of-line) > (let ((cite-marks (buffer-substring line-start (point)))) > (forward-line 1) > (while (< (point) end) > (let ((other-line > (buffer-substring (point) (+ (length cite-marks) (point))))) > (if (not (string-equal cite-marks other-line)) > (setq cite-marks > (substring cite-marks 0 > (tc-string-common-prefix-length > cite-marks other-line))))) > (forward-line 1)) > (goto-char start) > (save-restriction > (narrow-to-region start end) > (tc-fill-cited-paragraphs (length cite-marks)))))) > > (defun tc-fill-cited-region-uniformly (start end) > "Fill all lines in the region, making the overall citation uniform. > The region is between START and END. > This function finds the longest possible citemark and wraps all lines as > if they had that amount of citemarks." > (interactive "r") > ;;(save-mark-and-excursion > (goto-char end) > (let ((end-mark (point-marker)) > (cite-marks "")) > (goto-char start) > (beginning-of-line) > (while (< (point) (marker-position end-mark)) > (end-of-line) > (let ((line-end (point))) > (beginning-of-line) > (re-search-forward tc-guess-marks-regexp line-end t) > (let ((marks-here (buffer-substring (match-beginning 0) > (match-end 0)))) > (if (> (length marks-here) (length cite-marks)) > (setq cite-marks marks-here)) > (delete-region (match-beginning 0) (match-end 0)))) > (forward-line 1)) > (goto-char start) > (beginning-of-line) > (while (< (point) (marker-position end-mark)) > (insert cite-marks) > (forward-line 1)) > (goto-char start) > (save-restriction > (narrow-to-region start (marker-position end-mark)) > (tc-fill-cited-paragraphs (length cite-marks))))) > > (defun tc-unfill-paragraph-mouse (e) > "Unfill the paragraph at mouse event E." > (interactive "e") > (if (eventp e) > ;; Why do you have to disagree? Grr. Arg. > (if (featurep 'xemacs) > (tc-unfill-paragraph (event-point e)) > (tc-unfill-paragraph (posn-point (event-start e))))) > ;; (tc-unfill-paragraph (car (cdr (car (cdr e))))) > ) > > (defun tc-unfill-paragraph (at) > "Undo filling of cited text in the paragraph containing point AT. > Calling the function several times will toggle the paragrap between > the filled and the unfilled version. `tc-fill-cited-region' may be able > to fill the paragraph better." > (interactive "d") > (let ((reformatted (get-char-property at 'tc-reformat))) > (if reformatted > (save-mark-and-excursion > (let ((removed-region (buffer-substring > (overlay-start (cdr reformatted)) > (overlay-end (cdr reformatted))))) > (goto-char (overlay-start (cdr reformatted))) > (insert (car reformatted)) > (delete-region (point) > (overlay-end (cdr reformatted))) > (setcar reformatted removed-region))) > (message "No formatted paragraph here.")))) > > ;;; ************************************************************ > ;;; Guessing at the right set of citation marks > ;;; ************************************************************ > (defun tc-trim-best-prefix (prefix) > "Remove from the PREFIX newlines, known marks and duplicates." > (let ((known-marks (concat "\n " tc-normal-citemarks)) > (i 0)) > (while (< i (length prefix)) > (if (not (string-match (regexp-quote (substring prefix i (1+ i))) > known-marks)) > (setq known-marks (concat known-marks (substring prefix i (1+ i))))) > (setq i (1+ i))) > (substring known-marks (length (concat "\n " tc-normal-citemarks))))) > > (defun tc-guess-cite-marks () > (save-mark-and-excursion > (let ((best-prefix "\n") > guessed-marks > marks-begin marks-end) > (while (search-forward best-prefix (mark t) t) > (let ((prefix-start (match-beginning 0))) > (if (re-search-forward tc-guess-marks-regexp nil t) > (progn > (setq marks-begin prefix-start) > (setq marks-end (match-end 0)) > (setq best-prefix (buffer-substring marks-begin marks-end)) > (if (> tc-debug-level 0) > (message best-prefix)))))) > (setq guessed-marks (tc-trim-best-prefix best-prefix)) > (if (and (eq tc-guess-cite-marks 'ask) > (not (equal "" guessed-marks))) > (let ((marks-overlay (make-overlay (1+ marks-begin) marks-end))) > (overlay-put marks-overlay 'face 'highlight) > (setq guessed-marks > (read-from-minibuffer > "Guessed these citemarks: " guessed-marks)) > (delete-overlay marks-overlay))) > guessed-marks))) > > (defun tc-citemarks-need-guessing () > (save-mark-and-excursion > (let ((max-line-len (- (tc-fill-column) (length tc-citation-string) 1)) > needed) > (beginning-of-line) > (while (and (not needed) > (< (point) (mark t))) > (end-of-line) > (if (> (current-column) max-line-len) > (setq needed t)) > (forward-line 1)) > needed))) > > ;;; ************************************************************ > ;;; More fancy attribution generation functions > ;;; ************************************************************ > > ;; Doesn't work yet. *sniff* > (defun tc-reply-to-citee-p (email) > "Whether the mail being composed is for the person being cited." > (save-mark-and-excursion > (beginning-of-buffer) > (if (re-search-forward "^To:[ \t]+\\(.*\\)\n" nil t) > (if (equal email (buffer-substring (match-beginning 1) (match-end 1))) > t > nil) > nil))) > > (defvar tc-groups-functions > '( ( "" . tc-simple-attributor ) ) > "An alist of of functions to make an attribution in various groups. > The key of each assoc pair is a group prefix or regex for the groups > where this should be used. Earlier group matches override later ones. > A key that starts with a letter is assumed to be a group prefix, > anything else is a regex. To have a regexp start with a letter, start > it with the trivial range, e.g [c]omp. > > Each function takes a date (day, date year) and a name (\"you\", name > or email address) and should return the attribution as a string > without newlines. It will be reformatted. > > Some example attribution functions (attributors) are: > `tc-simple-attributor', `tc-random-attributor', > `tc-rhod-group-attributor', `tc-java-group-attributor', and > `tc-local-group-attributor'.") > > ;; This function due to Kai Großjohann > (defun tc-simple-attributor (date name) > "A simple attribution function suitable as default for > `tc-groups-functions'. > Uses DATE and NAME arguments." > (concat "On " date ", " name " wrote:")) > > ;;; ************************************************************ > ;;; These are more examples of how to make personalized attributions. > ;;; If you use tc-fancy-attributions, you should change these to suit > ;;; your style. > ;;; ************************************************************ > > (defun tc-random-attributor (date name) > "Generate a random attribution suitable for any context. > Uses DATE and NAME arguments." > (let ((style (random 7))) > (cond ((= style 0) > (concat "On " date ", " name " stated:")) > ((= style 1) > (concat "On " date ", " name " spake thusly:")) > ((= style 2) > (concat "On " date ", " name " uttered the following:")) > ((= style 3) > (concat "On " date ", " name " outgrape:")) > ((= style 4) > (concat "On " date ", " name " said:")) > ((= style 5) > (concat "On " date ", " name " verbalised:")) > ((= style 6) > (concat "On " date ", " name " told this:")) > (t > (concat "On " date ", " name " wrote:"))))) > > (defalias 'tc-generic-attribution 'tc-random-attributor) > > (defun tc-rhod-group-attributor (date name) > (let ((style (random 3))) > (cond ((= style 0) > (concat "On " date ", " name > " thusly discussed the words of the Internet Oracle:")) > ((= style 1) > (concat "Paul Kelly can witness that " name " on " date " wrote:")) > ((= style 2) > (concat "On " date ", " name > " wrote, without the least grovelling:"))))) > > (defun tc-java-group-attributor (date name) > (concat "On " date ", " name " used System.out.println with:")) > > (defun tc-local-group-attributor (date name) > (concat name " wrote this:")) > > (defun tc-fancy-attribution () > "Make a personalized attribution. > The Newsgroups: field is examined to find appropriate sayings, and the real > name is used when available. If you use this, you probably want to change > `tc-groups-functions' to reflect your favorite newsgroups." > (let ((date (cdr-safe (assoc "date" tc-strings-list))) > (email (cdr-safe (assoc "email-addr" tc-strings-list))) > (name (cdr-safe (assoc "real-name" tc-strings-list))) > (groups (cdr-safe (assoc "newsgroups" tc-strings-list)))) > (let ((date-part (if date date "an unknown date")) > (name-part (if nil ;(tc-reply-to-citee-p email) > "you" > (if name > name > (if email > email > "somebody@somewhere"))))) > (concat > (if groups ;; This is sent to a newsgroup, not a person > (tc-group-attribution groups date-part name-part) > (let ((default-function (tc-find-with-predicate > '(lambda (group) (null (car group))) > tc-groups-functions))) > (if default-function > (apply (cdr default-function) date-part name-part '()) > (tc-generic-attribution date-part name-part)))) "\n\n")))) > > ;; General function to find an element satisfying pred in list > (defun tc-find-with-predicate (pred list) > (let ((found nil)) > (while (and list (not found)) > (if (apply pred (car list) ()) > (setq found (car list)) > (setq list (cdr list)))) > found)) > > (defun tc-group-attribution (groups date name) > (let ((group-function > (tc-find-with-predicate > '(lambda (group) > (let ((group-name (car group))) > (if (or (not group-name) (= 0 (length group-name))) > t > (tc-find-with-predicate > (if (= (char-syntax (string-to-char group-name)) ?w) > '(lambda (cited-group) > (if (>= tc-debug-level 1) > (message (concat "Checking " cited-group > " vs " group-name))) > (eq t (compare-strings > group-name 0 (length group-name) > cited-group 0 (length group-name)))) > '(lambda (cited-group) > (if (>= tc-debug-level 1) > (message (concat "Regexp checking " cited-group > " vs " group-name))) > (string-match group-name cited-group))) > groups)))) > tc-groups-functions))) > (message name) > (if group-function > (apply (cdr group-function) date name ()) > (tc-generic-attribution date name)))) > > ;; Acknowledgements > ;; Patches and bug reports have been sent by the following people. > ;; My thanks to all of them for helping me improve trivial-cite > ;; Klaus Berndl <klaus.ber...@sdm.de> > ;; Colin Walters <walter...@cis.ohio-state.edu> > ;; Christoph Rohland <c...@sap.com> > ;; Matthias Wiehl <mwi...@gmx.de> > ;; Kai Großjohann <kai.grossjoh...@cs.uni-dortmund.de> > ;; Knut Anders Hatlen <kahat...@online.no> > ;; Tommi Vainikainen <t...@iki.fi> > ;; Colin Rafferty <co...@xemacs.org> > ;; Juergen Kreileder <j...@blackdown.de> > ;; Daniel Pittman <dan...@rimspace.net> > ;; Vasily Korytov <desk...@myrealbox.com> > ;; Benjamin Lewis <bcle...@cs.sfu.ca> > > ;; My apologies to any I may have forgotten > > ;;; Version history: > ;;; 0.0: Trivial version > ;;; 0.2: Added documentation, changed name from simple-quote to trivial-cite. > ;;; 0.3: Streamlined header parsing, updated documentation. Now leaves > ;;; (point) at start as mail-citation-hook wants it. > ;;; 0.4: Parsing is now RFC822 compliant. Removes empty lines at end of > ;;; citation. Can remove signatures. > ;;; 0.5: Can now fill paragraphs when the lines are too long, with one undo > ;;; per filling. Works like a charm:) > ;;; 0.6: Debugged filling, added overlays to mark undoable fillings. > ;;; Tries to find ^--$ sig marker if the correct ^-- $ fails. > ;;; Is not fooled by bad cites that have inserted extra spaces before > ;;; old cites. > ;;; 0.7: New version of find-cite-len, which should be faster and > ;;; can handle cite-marks not ending in a space. Also fills single- > ;;; line quotes, if the quote-marks are simple. Added user-setting > ;;; for mouse-sensitive overlays. Fixed signature removal so that > ;;; an immediate undo gives the quoted signature. Added guessing > ;;; at unusual cite-marks. Added distribution setup handling and > ;;; and maintainer variable. Made group-sensitive attributions > ;;; work better. Reorganized a lot. Improved string-char-index. > ;;; 0.7.1: Uses a new marker instead of push-mark now. > ;;; 0.8: Now possibility of limiting the number of lines cited (good for > ;;; citing extremely long mails). > ;;; 0.8.1: Bug fix of prefix parsing. > ;;; 0.9: New user-function tc-cite-region that cites like tc, but without > ;;; parsing headers or removing signature. > ;;; 0.10: Customization added. My, this is neat. > ;;; 0.10.1: Cut >80 char lines split. > ;;; 0.10.2: Renamed tc-unformat-area[-mouse] to tc-unfill-paragraph[-mouse]. > ;;; 0.10.3: Bug fix from kahat...@online.no > ;;; 0.10.4: Added } as quote char. > ;;; 0.11: Added tc-fill-cited-region-uniformly > ;;; 0.11.1: Fixed bug with space-only header fields. > ;;; 0.11.2-4: Minor contributed bugfixes > ;;; 0.11.5: Trailing whitespace remove by suggestion from Brett Randall, > ;;; XEmacs compatability with help from Sebastian Kaps and others > ;;; 0.11.6: Cite-mark fixup thanks to Matthias Wiehl > ;;; Changed to using C-c C-p for undo formatting. > ;;; Added fix to avoid the signature being messed up by mails with > ;;; no final newline. > ;;; 0.12: Numerous patches, including (mark t). > ;;; Also rework of fancy-attributes, renaming of subfunctions to > ;;; `attributor', fix of too long cite lines breaking fill. > ;;; 0.12.1: Small fixes in tc-fancy-attributor after trying it out:) > ;;; 0.12.2: Fixes of two compilation problems, thanks to Steve Evans > ;;; 0.12.3: Updated license text > ;;; 0.12.4: Typo fixed. Made date parsing use date-to-time and > ;;; format-time-string, allowing easier customization. > ;;; 0.13: Stuff from Vasily Korytov <desk...@myrealbox.com>: Before > ;;; and after hooks, no spurious extra trailing spaces, > ;;; tc-fill-long-lines morphed into tc-fill-column. > ;;; 0.13.1: Use guessed marks in normalizing citation marks. > ;;; 0.13.2: Use a local let instead of setting fill-column. > ;;; 0.13.3: Moving a parenthesis fixed a missing space problem. > ;;; 0.13.4: Peter S. Galbraith <p...@debian.org> > ;;; Checkdoc edits. > ;;; New tc-make-attribution defcustom. > ;;; Reorder functions for cleaner byte-compilation. > ;;; Added tc-attribution-name-and-email-wrote. > ;;; Changed end bracket style with Lars' okay. > ;;; Renamed functions note prefixed with tc-. > ;; end of tc.el > > (provide 'tc) > > ;;; tc.el ends here
