diff options
| author | Ken Raeburn <raeburn@raeburn.org> | 2001-07-06 08:41:36 +0000 |
|---|---|---|
| committer | Ken Raeburn <raeburn@raeburn.org> | 2001-07-06 08:41:36 +0000 |
| commit | ad782551325b7c694ee234b5ff4c5688d90e561c (patch) | |
| tree | f4355f141142b6018183518fa1761b53e295ede2 /lisp | |
| parent | f25cfe53951f57e1b2c3972877297df3d86bb980 (diff) | |
| download | emacs-ad782551325b7c694ee234b5ff4c5688d90e561c.tar.gz | |
properly mark Attic files as deleted
Diffstat (limited to 'lisp')
38 files changed, 0 insertions, 22492 deletions
diff --git a/lisp/ada.el b/lisp/ada.el deleted file mode 100644 index bf7633bf82d..00000000000 --- a/lisp/ada.el +++ /dev/null @@ -1,734 +0,0 @@ -;;; ada.el --- Ada editing support package in GNUlisp. v1.0 - -;; Copyright (C) 1985, 1986, 1987 Free Software Foundation, Inc. - -;; Author: Vincent Broman <broman@bugs.nosc.mil> -;; Keywords: languages - -;; 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, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; Commentary: - -;; Created May 1987. -;; (borrows heavily from Mick Jordan's Modula-2 package for GNU, -;; as modified by Peter Robinson, Michael Schmidt, and Tom Perrine.) - -;;; Code: - -(defvar ada-mode-syntax-table nil - "Syntax table in use in Ada-mode buffers.") - -(let ((table (make-syntax-table))) - (modify-syntax-entry ?_ "_" table) - (modify-syntax-entry ?\# "_" table) - (modify-syntax-entry ?\( "()" table) - (modify-syntax-entry ?\) ")(" table) - (modify-syntax-entry ?$ "." table) - (modify-syntax-entry ?* "." table) - (modify-syntax-entry ?/ "." table) - (modify-syntax-entry ?+ "." table) - (modify-syntax-entry ?- ". 12" table) - (modify-syntax-entry ?= "." table) - (modify-syntax-entry ?\& "." table) - (modify-syntax-entry ?\| "." table) - (modify-syntax-entry ?< "." table) - (modify-syntax-entry ?> "." table) - (modify-syntax-entry ?\[ "." table) - (modify-syntax-entry ?\] "." table) - (modify-syntax-entry ?\{ "." table) - (modify-syntax-entry ?\} "." table) - (modify-syntax-entry ?. "." table) - (modify-syntax-entry ?\\ "." table) - (modify-syntax-entry ?: "." table) - (modify-syntax-entry ?\; "." table) - (modify-syntax-entry ?\' "." table) - (modify-syntax-entry ?\" "\"" table) - (modify-syntax-entry ?\n ">" table) - (setq ada-mode-syntax-table table)) - -;; Strings are a real pain in Ada because both ' and " can appear in a -;; non-string quote context (the former as an operator, the latter as a -;; character string). We follow the least losing solution, in which only " is -;; a string quote. Therefore a character string of the form '"' will throw -;; fontification off on the wrong track. - -(defconst ada-font-lock-keywords-1 - (list - ;; - ;; Function, package (body), pragma, procedure, task (body) plus name. - (list (concat "\\<\\(" - "function\\|" - "p\\(ackage\\(\\|[ \t]+body\\)\\|r\\(agma\\|ocedure\\)\\)\\|" - "task\\(\\|[ \t]+body\\)" - "\\)\\>[ \t]*\\(\\sw+\\(\\.\\sw*\\)*\\)?") - '(1 font-lock-keyword-face) '(6 font-lock-function-name-face nil t))) - "For consideration as a value of `ada-font-lock-keywords'. -This does fairly subdued highlighting.") - -(defconst ada-font-lock-keywords-2 - (append ada-font-lock-keywords-1 - (list - ;; - ;; Main keywords, except those treated specially below. - (concat "\\<\\(" -; ("abort" "abs" "abstract" "accept" "access" "aliased" "all" -; "and" "array" "at" "begin" "case" "declare" "delay" "delta" -; "digits" "do" "else" "elsif" "entry" "exception" "exit" "for" -; "generic" "if" "in" "is" "limited" "loop" "mod" "not" -; "null" "or" "others" "private" "protected" -; "range" "record" "rem" "renames" "requeue" "return" "reverse" -; "select" "separate" "tagged" "task" "terminate" "then" "until" -; "while" "xor") - "a\\(b\\(ort\\|s\\(\\|tract\\)\\)\\|cce\\(pt\\|ss\\)\\|" - "l\\(iased\\|l\\)\\|nd\\|rray\\|t\\)\\|begin\\|case\\|" - "d\\(e\\(clare\\|l\\(ay\\|ta\\)\\)\\|igits\\|o\\)\\|" - "e\\(ls\\(e\\|if\\)\\|ntry\\|x\\(ception\\|it\\)\\)\\|for\\|" - "generic\\|i[fns]\\|l\\(imited\\|oop\\)\\|mod\\|n\\(ot\\|ull\\)\\|" - "o\\(r\\|thers\\)\\|pr\\(ivate\\|otected\\)\\|" - "r\\(ange\\|e\\(cord\\|m\\|names\\|queue\\|turn\\|verse\\)\\)\\|" - "se\\(lect\\|parate\\)\\|" - "t\\(a\\(gged\\|sk\\)\\|erminate\\|hen\\)\\|until\\|while\\|xor" - "\\)\\>") - ;; - ;; Anything following end and not already fontified is a body name. - '("\\<\\(end\\)\\>[ \t]*\\(\\sw+\\)?" - (1 font-lock-keyword-face) (2 font-lock-function-name-face nil t)) -; ;; -; ;; Variable name plus optional keywords followed by a type name. Slow. -; (list (concat "\\<\\(\\sw+\\)\\>[ \t]*:" -; "[ \t]*\\(constant\\|in\\|in[ \t]+out\\|out\\)?[ \t]*" -; "\\(\\sw+\\(\\.\\sw*\\)*\\)?") -; '(1 font-lock-variable-name-face) -; '(2 font-lock-keyword-face nil t) '(3 font-lock-type-face nil t)) - ;; - ;; Optional keywords followed by a type name. - (list (concat ":[ \t]*\\<\\(constant\\|in\\|in[ \t]+out\\|out\\)\\>?[ \t]*" - "\\(\\sw+\\(\\.\\sw*\\)*\\)?") - '(1 font-lock-keyword-face nil t) '(2 font-lock-type-face nil t)) - ;; - ;; Keywords followed by a type or function name. - (list (concat "\\<\\(" - "new\\|of\\|subtype\\|type" - "\\)\\>[ \t]*\\(\\sw+\\(\\.\\sw*\\)*\\)?[ \t]*\\((\\)?") - '(1 font-lock-keyword-face) - '(2 (if (match-beginning 4) - font-lock-function-name-face - font-lock-type-face) nil t)) - ;; - ;; Keywords followed by a reference. - (list (concat "\\<\\(goto\\|raise\\|use\\|when\\|with\\)\\>" - "[ \t]*\\(\\sw+\\(\\.\\sw*\\)*\\)?") - '(1 font-lock-keyword-face) '(2 font-lock-reference-face nil t)) - ;; - ;; Goto tags. - '("<<\\(\\sw+\\(\\.\\sw*\\)*\\)>>" 1 font-lock-reference-face) - )) - "For consideration as a value of `ada-font-lock-keywords'. -This does a lot more highlighting.") - -(defvar ada-font-lock-keywords (if font-lock-maximum-decoration - ada-font-lock-keywords-2 - ada-font-lock-keywords-1) - "Additional expressions to highlight in Ada mode.") - -(defvar ada-mode-map nil - "Keymap used in Ada mode.") - -(let ((map (make-sparse-keymap))) - (define-key map "\C-m" 'ada-newline) - (define-key map "\C-?" 'backward-delete-char-untabify) - (define-key map "\C-i" 'ada-tab) - (define-key map "\C-c\C-i" 'ada-untab) - (define-key map "\C-c<" 'ada-backward-to-same-indent) - (define-key map "\C-c>" 'ada-forward-to-same-indent) - (define-key map "\C-ch" 'ada-header) - (define-key map "\C-c(" 'ada-paired-parens) - (define-key map "\C-c-" 'ada-inline-comment) - (define-key map "\C-c\C-a" 'ada-array) - (define-key map "\C-cb" 'ada-exception-block) - (define-key map "\C-cd" 'ada-declare-block) - (define-key map "\C-c\C-e" 'ada-exception) - (define-key map "\C-cc" 'ada-case) - (define-key map "\C-c\C-k" 'ada-package-spec) - (define-key map "\C-ck" 'ada-package-body) - (define-key map "\C-c\C-p" 'ada-procedure-spec) - (define-key map "\C-cp" 'ada-subprogram-body) - (define-key map "\C-c\C-f" 'ada-function-spec) - (define-key map "\C-cf" 'ada-for-loop) - (define-key map "\C-cl" 'ada-loop) - (define-key map "\C-ci" 'ada-if) - (define-key map "\C-cI" 'ada-elsif) - (define-key map "\C-ce" 'ada-else) - (define-key map "\C-c\C-v" 'ada-private) - (define-key map "\C-c\C-r" 'ada-record) - (define-key map "\C-c\C-s" 'ada-subtype) - (define-key map "\C-cs" 'ada-separate) - (define-key map "\C-c\C-t" 'ada-type) - (define-key map "\C-ct" 'ada-tabsize) -;; (define-key map "\C-c\C-u" 'ada-use) -;; (define-key map "\C-c\C-w" 'ada-with) - (define-key map "\C-cw" 'ada-while-loop) - (define-key map "\C-c\C-w" 'ada-when) - (define-key map "\C-cx" 'ada-exit) - (define-key map "\C-cC" 'ada-compile) - (define-key map "\C-cB" 'ada-bind) - (define-key map "\C-cE" 'ada-find-listing) - (define-key map "\C-cL" 'ada-library-name) - (define-key map "\C-cO" 'ada-options-for-bind) - (setq ada-mode-map map)) - -(defvar ada-indent 4 "*Value is the number of columns to indent in Ada-Mode.") - -(defvar ada-comment-end-column) - -(defun ada-mode () -"This is a mode intended to support program development in Ada. -Most control constructs and declarations of Ada can be inserted in the buffer -by typing Control-C followed by a character mnemonic for the construct. - -\\<ada-mode-map>\\[ada-array] array \\[ada-exception-block] exception block -\\[ada-exception] exception \\[ada-declare-block] declare block -\\[ada-package-spec] package spec \\[ada-package-body] package body -\\[ada-procedure-spec] procedure spec \\[ada-subprogram-body] proc/func body -\\[ada-function-spec] func spec \\[ada-for-loop] for loop - \\[ada-if] if - \\[ada-elsif] elsif - \\[ada-else] else -\\[ada-private] private \\[ada-loop] loop -\\[ada-record] record \\[ada-case] case -\\[ada-subtype] subtype \\[ada-separate] separate -\\[ada-type] type \\[ada-tabsize] tab spacing for indents -\\[ada-when] when \\[ada-while] while - \\[ada-exit] exit -\\[ada-paired-parens] paired parens \\[ada-inline-comment] inline comment - \\[ada-header] header spec -\\[ada-compile] compile \\[ada-bind] bind -\\[ada-find-listing] find error list -\\[ada-library-name] name library \\[ada-options-for-bind] options for bind - -\\[ada-backward-to-same-indent] and \\[ada-forward-to-same-indent] move backward and forward respectively to the next line -having the same (or lesser) level of indentation. - -Variable `ada-indent' controls the number of spaces for indent/undent." - (interactive) - (kill-all-local-variables) - (use-local-map ada-mode-map) - (setq major-mode 'ada-mode) - (setq mode-name "Ada") - (make-local-variable 'comment-column) - (setq comment-column 41) - (make-local-variable 'ada-comment-end-column) - (setq ada-comment-end-column 72) - (set-syntax-table ada-mode-syntax-table) - (make-local-variable 'paragraph-start) - (setq paragraph-start (concat "$\\|" page-delimiter)) - (make-local-variable 'paragraph-separate) - (setq paragraph-separate paragraph-start) - (make-local-variable 'paragraph-ignore-fill-prefix) - (setq paragraph-ignore-fill-prefix t) -; (make-local-variable 'indent-line-function) -; (setq indent-line-function 'c-indent-line) - (make-local-variable 'require-final-newline) - (setq require-final-newline t) - (make-local-variable 'comment-start) - (setq comment-start "--") - (make-local-variable 'comment-end) - (setq comment-end "") - (make-local-variable 'comment-column) - (setq comment-column 41) - (make-local-variable 'comment-start-skip) - (setq comment-start-skip "--+ *") - (make-local-variable 'comment-indent-function) - (setq comment-indent-function 'c-comment-indent) - (make-local-variable 'parse-sexp-ignore-comments) - (setq parse-sexp-ignore-comments t) - (make-local-variable 'font-lock-defaults) - (setq font-lock-defaults '(ada-font-lock-keywords nil t ((?\_ . "w")))) - (run-hooks 'ada-mode-hook)) - -(defun ada-tabsize (s) - "Changes spacing used for indentation. -The prefix argument is used as the new spacing." - (interactive "p") - (setq ada-indent s)) - -(defun ada-newline () - "Start new line and indent to current tab stop." - (interactive) - (let ((ada-cc (current-indentation))) - (newline) - (indent-to ada-cc))) - -(defun ada-tab () - "Indent to next tab stop." - (interactive) - (indent-to (* (1+ (/ (current-indentation) ada-indent)) ada-indent))) - -(defun ada-untab () - "Delete backwards to previous tab stop." - (interactive) - (backward-delete-char-untabify ada-indent nil)) - -(defun ada-go-to-this-indent (step indent-level) - "Move point repeatedly by STEP lines until the current line has -given INDENT-LEVEL or less, or the start or end of the buffer is reached. -Ignore blank lines, statement labels and block or loop names." - (while (and - (zerop (forward-line step)) - (or (looking-at "^[ ]*$") - (looking-at "^[ ]*--") - (looking-at "^<<[A-Za-z0-9_]+>>") - (looking-at "^[A-Za-z0-9_]+:") - (> (current-indentation) indent-level))) - nil)) - -(defun ada-backward-to-same-indent () - "Move point backwards to nearest line with same indentation or less. -If not found, point is left at the top of the buffer." - (interactive) - (ada-go-to-this-indent -1 (current-indentation)) - (back-to-indentation)) - -(defun ada-forward-to-same-indent () - "Move point forwards to nearest line with same indentation or less. -If not found, point is left at the start of the last line in the buffer." - (interactive) - (ada-go-to-this-indent 1 (current-indentation)) - (back-to-indentation)) - -(defun ada-array () - "Insert array type definition. Uses the minibuffer to prompt -for component type and index subtypes." - (interactive) - (insert "array ()") - (backward-char) - (insert (read-string "index subtype[s]: ")) - (end-of-line) - (insert " of ;") - (backward-char) - (insert (read-string "component-type: ")) - (end-of-line)) - -(defun ada-case () - "Build skeleton case statement. -Uses the minibuffer to prompt for the selector expression. -Also builds the first when clause." - (interactive) - (insert "case ") - (insert (read-string "selector expression: ") " is") - (ada-newline) - (ada-newline) - (insert "end case;") - (end-of-line 0) - (ada-tab) - (ada-tab) - (ada-when)) - -(defun ada-declare-block () - "Insert a block with a declare part. -Indent for the first declaration." - (interactive) - (let ((ada-block-name (read-string "[block name]: "))) - (insert "declare") - (cond - ( (not (string-equal ada-block-name "")) - (beginning-of-line) - (open-line 1) - (insert ada-block-name ":") - (next-line 1) - (end-of-line))) - (ada-newline) - (ada-newline) - (insert "begin") - (ada-newline) - (ada-newline) - (if (string-equal ada-block-name "") - (insert "end;") - (insert "end " ada-block-name ";")) - ) - (end-of-line -2) - (ada-tab)) - -(defun ada-exception-block () - "Insert a block with an exception part. -Indent for the first line of code." - (interactive) - (let ((block-name (read-string "[block name]: "))) - (insert "begin") - (cond - ( (not (string-equal block-name "")) - (beginning-of-line) - (open-line 1) - (insert block-name ":") - (next-line 1) - (end-of-line))) - (ada-newline) - (ada-newline) - (insert "exception") - (ada-newline) - (ada-newline) - (cond - ( (string-equal block-name "") - (insert "end;")) - ( t - (insert "end " block-name ";"))) - ) - (end-of-line -2) - (ada-tab)) - -(defun ada-exception () - "Insert an indented exception part into a block." - (interactive) - (ada-untab) - (insert "exception") - (ada-newline) - (ada-tab)) - -(defun ada-else () - "Add an else clause inside an if-then-end-if clause." - (interactive) - (ada-untab) - (insert "else") - (ada-newline) - (ada-tab)) - -(defun ada-exit () - "Insert an exit statement, prompting for loop name and condition." - (interactive) - (insert "exit") - (let ((ada-loop-name (read-string "[name of loop to exit]: "))) - (if (not (string-equal ada-loop-name "")) (insert " " ada-loop-name))) - (let ((ada-exit-condition (read-string "[exit condition]: "))) - (if (not (string-equal ada-exit-condition "")) - (if (string-match "^ *[Ww][Hh][Ee][Nn] +" ada-exit-condition) - (insert " " ada-exit-condition) - (insert " when " ada-exit-condition)))) - (insert ";")) - -(defun ada-when () - "Start a case statement alternative with a when clause." - (interactive) - (ada-untab) ; we were indented in code for the last alternative. - (insert "when ") - (insert (read-string "'|'-delimited choice list: ") " =>") - (ada-newline) - (ada-tab)) - -(defun ada-for-loop () - "Build a skeleton for-loop statement, prompting for the loop parameters." - (interactive) - (insert "for ") - (let* ((ada-loop-name (read-string "[loop name]: ")) - (ada-loop-is-named (not (string-equal ada-loop-name "")))) - (if ada-loop-is-named - (progn - (beginning-of-line) - (open-line 1) - (insert ada-loop-name ":") - (next-line 1) - (end-of-line 1))) - (insert (read-string "loop variable: ") " in ") - (insert (read-string "range: ") " loop") - (ada-newline) - (ada-newline) - (insert "end loop") - (if ada-loop-is-named (insert " " ada-loop-name)) - (insert ";")) - (end-of-line 0) - (ada-tab)) - -(defun ada-header () - "Insert a comment block containing the module title, author, etc." - (interactive) - (insert "--\n-- Title: \t") - (insert (read-string "Title: ")) - (insert "\n-- Created:\t" (current-time-string)) - (insert "\n-- Author: \t" (user-full-name)) - (insert "\n--\t\t<" (user-login-name) "@" (system-name) ">\n--\n")) - -(defun ada-if () - "Insert skeleton if statment, prompting for a boolean-expression." - (interactive) - (insert "if ") - (insert (read-string "condition: ") " then") - (ada-newline) - (ada-newline) - (insert "end if;") - (end-of-line 0) - (ada-tab)) - -(defun ada-elsif () - "Add an elsif clause to an if statement, prompting for the boolean-expression." - (interactive) - (ada-untab) - (insert "elsif ") - (insert (read-string "condition: ") " then") - (ada-newline) - (ada-tab)) - -(defun ada-loop () - "Insert a skeleton loop statement. The exit statement is added by hand." - (interactive) - (insert "loop ") - (let* ((ada-loop-name (read-string "[loop name]: ")) - (ada-loop-is-named (not (string-equal ada-loop-name "")))) - (if ada-loop-is-named - (progn - (beginning-of-line) - (open-line 1) - (insert ada-loop-name ":") - (forward-line 1) - (end-of-line 1))) - (ada-newline) - (ada-newline) - (insert "end loop") - (if ada-loop-is-named (insert " " ada-loop-name)) - (insert ";")) - (end-of-line 0) - (ada-tab)) - -(defun ada-package-spec () - "Insert a skeleton package specification." - (interactive) - (insert "package ") - (let ((ada-package-name (read-string "package name: " ))) - (insert ada-package-name " is") - (ada-newline) - (ada-newline) - (insert "end " ada-package-name ";") - (end-of-line 0) - (ada-tab))) - -(defun ada-package-body () - "Insert a skeleton package body -- includes a begin statement." - (interactive) - (insert "package body ") - (let ((ada-package-name (read-string "package name: " ))) - (insert ada-package-name " is") - (ada-newline) - (ada-newline) - (insert "begin") - (ada-newline) - (insert "end " ada-package-name ";") - (end-of-line -1) - (ada-tab))) - -(defun ada-private () - "Undent and start a private section of a package spec. Reindent." - (interactive) - (ada-untab) - (insert "private") - (ada-newline) - (ada-tab)) - -(defun ada-get-arg-list () - "Read from the user a procedure or function argument list. -Add parens unless arguments absent, and insert into buffer. -Individual arguments are arranged vertically if entered one at a time. -Arguments ending with `;' are presumed single and stacked." - (insert " (") - (let ((ada-arg-indent (current-column)) - (ada-args (read-string "[arguments]: "))) - (if (string-equal ada-args "") - (backward-delete-char 2) - (progn - (while (string-match ";$" ada-args) - (insert ada-args) - (newline) - (indent-to ada-arg-indent) - (setq ada-args (read-string "next argument: "))) - (insert ada-args ")"))))) - -(defun ada-function-spec () - "Insert a function specification. Prompts for name and arguments." - (interactive) - (insert "function ") - (insert (read-string "function name: ")) - (ada-get-arg-list) - (insert " return ") - (insert (read-string "result type: "))) - -(defun ada-procedure-spec () - "Insert a procedure specification, prompting for its name and arguments." - (interactive) - (insert "procedure ") - (insert (read-string "procedure name: " )) - (ada-get-arg-list)) - -(defun get-ada-subprogram-name () - "Return (without moving point or mark) a pair whose CAR is the name of -the function or procedure whose spec immediately precedes point, and whose -CDR is the column number where the procedure/function keyword was found." - (save-excursion - (let ((ada-proc-indent 0)) - (if (re-search-backward - ;;;; Unfortunately, comments are not ignored in this string search. - "[PpFf][RrUu][OoNn][Cc][EeTt][DdIi][UuOo][RrNn]" nil t) - (if (or (looking-at "\\<[Pp][Rr][Oo][Cc][Ee][Dd][Uu][Rr][Ee]\\>") - (looking-at "\\<[Ff][Uu][Nn][Cc][Tt][Ii][Oo][Nn]\\>")) - (progn - (setq ada-proc-indent (current-column)) - (forward-word 2) - (let ((p2 (point))) - (forward-word -1) - (cons (buffer-substring (point) p2) ada-proc-indent))) - (get-ada-subprogram-name)) - (cons "NAME?" ada-proc-indent))))) - -(defun ada-subprogram-body () - "Insert frame for subprogram body. -Invoke right after `ada-function-spec' or `ada-procedure-spec'." - (interactive) - (insert " is") - (let ((ada-subprogram-name-col (get-ada-subprogram-name))) - (newline) - (indent-to (cdr ada-subprogram-name-col)) - (ada-newline) - (insert "begin") - (ada-newline) - (ada-newline) - (insert "end " (car ada-subprogram-name-col) ";")) - (end-of-line -2) - (ada-tab)) - -(defun ada-separate () - "Finish a body stub with `is separate'." - (interactive) - (insert " is") - (ada-newline) - (ada-tab) - (insert "separate;") - (ada-newline) - (ada-untab)) - -;(defun ada-with () -; "Inserts a with clause, prompting for the list of units depended upon." -; (interactive) -; (insert "with ") -; (insert (read-string "list of units depended upon: ") ";")) -; -;(defun ada-use () -; "Inserts a use clause, prompting for the list of packages used." -; (interactive) -; (insert "use ") -; (insert (read-string "list of packages to use: ") ";")) - -(defun ada-record () - "Insert a skeleton record type declaration." - (interactive) - (insert "record") - (ada-newline) - (ada-newline) - (insert "end record;") - (end-of-line 0) - (ada-tab)) - -(defun ada-subtype () - "Start insertion of a subtype declaration, prompting for the subtype name." - (interactive) - (insert "subtype " (read-string "subtype name: ") " is ;") - (backward-char) - (message "insert subtype indication.")) - -(defun ada-type () - "Start insertion of a type declaration, prompting for the type name." - (interactive) - (insert "type " (read-string "type name: ")) - (let ((disc-part (read-string "discriminant specs: "))) - (if (not (string-equal disc-part "")) - (insert "(" disc-part ")"))) - (insert " is ") - (message "insert type definition.")) - -(defun ada-while-loop () - (interactive) - (insert "while ") - (let* ((ada-loop-name (read-string "loop name: ")) - (ada-loop-is-named (not (string-equal ada-loop-name "")))) - (if ada-loop-is-named - (progn - (beginning-of-line) - (open-line 1) - (insert ada-loop-name ":") - (next-line 1) - (end-of-line 1))) - (insert (read-string "entry condition: ") " loop") - (ada-newline) - (ada-newline) - (insert "end loop") - (if ada-loop-is-named (insert " " ada-loop-name)) - (insert ";")) - (end-of-line 0) - (ada-tab)) - -(defun ada-paired-parens () - "Insert a pair of round parentheses, placing point between them." - (interactive) - (insert "()") - (backward-char)) - -(defun ada-inline-comment () - "Start a comment after the end of the line, indented at least -`comment-column' spaces. If starting after `end-comment-column', -start a new line." - (interactive) - (end-of-line) - (if (> (current-column) ada-comment-end-column) (newline)) - (if (< (current-column) comment-column) (indent-to comment-column)) - (insert " -- ")) - -(defun ada-display-comment () -"Inserts three comment lines, making a display comment." - (interactive) - (insert "--\n-- \n--") - (end-of-line 0)) - -;; Much of this is specific to Ada-Ed - -(defvar ada-lib-dir-name "lib" "*Current Ada program library directory.") -(defvar ada-bind-opts "" "*Options to supply for binding.") - -(defun ada-library-name (ada-lib-name) - "Specify name of Ada library directory for later compilations." - (interactive "DName of Ada library directory: ") - (setq ada-lib-dir-name ada-lib-name)) - -(defun ada-options-for-bind () - "Specify options, such as -m and -i, needed for `ada-bind'." - (setq ada-bind-opts (read-string "-m and -i options for `ada-bind': "))) - -(defun ada-compile (arg) - "Save the current buffer and compile it into the current program library. -Initialize the library if a prefix arg is given." - (interactive "P") - (let* ((ada-init (if (null arg) "" "-n ")) - (ada-source-file (buffer-name))) - (compile - (concat "adacomp " ada-init "-l " ada-lib-dir-name " " ada-source-file)))) - -(defun ada-find-listing () - "Find listing file for ada source in current buffer, using other window." - (interactive) - (find-file-other-window (concat (substring (buffer-name) 0 -4) ".lis")) - (search-forward "*** ERROR")) - -(defun ada-bind () - "Bind the current program library, using the current binding options." - (interactive) - (compile (concat "adabind " ada-bind-opts " " ada-lib-dir-name))) - -;;; ada.el ends here diff --git a/lisp/batmode.el b/lisp/batmode.el deleted file mode 100644 index 72a0735c6a6..00000000000 --- a/lisp/batmode.el +++ /dev/null @@ -1,165 +0,0 @@ -;;; batmode.el --- Simple mode for Windows BAT files - -;; Copyright (C) 1996 Free Software Foundation, Inc. - -;; Author: Peter Breton <pbreton@i-kinetics.com> -;; Created: Thu Jul 25 1996 -;; Keywords: BAT, DOS, Windows - -;; 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: -;; -;; USAGE: Byte-compile this file, and add the following lines to your -;; emacs initialization file (.emacs/_emacs): -;; -;; (setq auto-mode-alist -;; (append -;; (list (cons "\\.[bB][aA][tT]$" 'bat-mode)) -;; ;; For DOS init files -;; (list (cons "CONFIG\\." 'bat-mode)) -;; (list (cons "AUTOEXEC\\." 'bat-mode)) -;; auto-mode-alist)) -;; -;; (autoload 'bat-mode "batmode" -;; "DOS and WIndows BAT files" t) - -;; TODO: -;; -;; Support "compiles" ? -;; Imenu? Don't have real functions..... - -;;; Change log: -;; $Log: batmode.el,v $ -;; Revision 1.3 1996/08/22 02:31:47 peter -;; Added Usage message, credit to folks from NTEmacs mailing list, -;; Syntax table, New font-lock keywords -;; -;; Revision 1.2 1996/08/18 16:27:13 peter -;; Added preliminary global-font-lock support -;; -;; Revision 1.1 1996/08/18 16:14:18 peter -;; Initial revision -;; - -;; Credit for suggestions, patches and bug-fixes: -;; Robert Brodersen <rbrodersen@siebel.com> -;; ACorreir@pervasive-sw.com (Alfred Correira) - -;;; Code: - -(defvar bat-mode-map nil "Local keymap for bat-mode buffers.") - -;; Make this lowercase if you like -(defvar bat-mode-comment-start "REM " - "Comment string to use in BAT mode") - -(defvar bat-mode-syntax-table nil - "Syntax table in use in Bat-mode buffers.") - -(if bat-mode-map - nil - (setq bat-mode-map (copy-keymap global-map)) -) - -;; Make underscores count as words -(if bat-mode-syntax-table - () - (setq bat-mode-syntax-table (make-syntax-table)) - (modify-syntax-entry ?_ "w" bat-mode-syntax-table) -) - -(defun bat-mode () - "Mode for DOS and Windows BAT files" - (interactive) - (kill-all-local-variables) - (use-local-map bat-mode-map) - (set-syntax-table bat-mode-syntax-table) - - (make-local-variable 'parse-sexp-ignore-comments) - (make-local-variable 'comment-start) - (make-local-variable 'comment-start-skip) - (make-local-variable 'comment-end) - (make-local-variable 'executable-command) - (make-local-variable 'font-lock-defaults) - - (setq major-mode 'bat-mode - mode-name "bat" - - comment-end "" - - comment-start bat-mode-comment-start - comment-start-skip "[Rr][Ee][Mm] *" - - parse-sexp-ignore-comments t - - ) - - ;; Global font-lock support - ;; (setq font-lock-defaults (list 'bat-font-lock-keywords nil t nil nil)) - (setq font-lock-defaults (list 'bat-font-lock-keywords nil)) - - (run-hooks 'bat-mode-hook)) - -(defvar bat-font-lock-keywords - (list - ;; Make this one first in the list, otherwise comments will - ;; be over-written by other variables - (list "^[@ \t]*\\([rR][eE][mM].*\\)" 1 'font-lock-comment-face t) - (list "^[ \t]*\\(::-.*\\)" 1 'font-lock-comment-face t) - (list - (concat "\\(\\<" - (mapconcat 'identity - '( - "call" - "echo" - "exist" - "errorlevel" - "for" - "goto" - "if" - "not" - "path" - "pause" - "prompt" - "set" - "start" - ) - "\\>\\|\\<") - "\\>\\)") 1 'font-lock-keyword-face) - (list "^[ \t]*\\(:\\sw+\\)" 1 'font-lock-function-name-face t) - (list "\\(%\\sw+%\\)" 1 'font-lock-reference-face) - (list "\\(%[0-9]\\)" 1 'font-lock-reference-face) - (list "\\(/[^/ \t\n]+\\)" 1 'font-lock-type-face) - (list "\\<\\(goto\\)\\>[ \t]*\\(\\sw+\\)?" - '(1 font-lock-keyword-face) - '(2 font-lock-function-name-face nil t)) - - ) - "Keywords to hilight in BAT mode") - -;;; don't do it in Win-Emacs -(if (boundp 'font-lock-defaults-alist) - (add-to-list - 'font-lock-defaults-alist - (cons 'bat-mode - (list 'bat-font-lock-keywords nil t nil nil)))) - -(provide 'bat-mode) - -;;; batmode.el ends here diff --git a/lisp/bytecpat.el b/lisp/bytecpat.el deleted file mode 100644 index 1698b2659ba..00000000000 --- a/lisp/bytecpat.el +++ /dev/null @@ -1,15 +0,0 @@ -;;; bytecpat.el --- do recompilation for Emacs patch files. -;;; This function is used by the patch files to update Emacs releases. - -(defun batch-byte-recompile-emacs () - "Recompile the Emacs `lisp' directory. -This is used after installing the patches for a new version." - (let ((load-path (list (expand-file-name "lisp")))) - (byte-recompile-directory "lisp"))) - -(defun batch-byte-compile-emacs () - "Compile new files installed in the Emacs `lisp' directory. -This is used after installing the patches for a new version. -It uses the command line arguments to specify the files to compile." - (let ((load-path (list (expand-file-name "lisp")))) - (batch-byte-compile))) diff --git a/lisp/cl.el b/lisp/cl.el deleted file mode 100644 index 1a6a385e3ee..00000000000 --- a/lisp/cl.el +++ /dev/null @@ -1,3162 +0,0 @@ -;;; cl.el --- Common-Lisp extensions for GNU Emacs Lisp. - -;; Copyright (C) 1987, 1988, 1989, 1992 Free Software Foundation, Inc. - -;; Author: Cesar Quiroz <quiroz@cs.rochester.edu> -;; Keywords: extensions - -(defvar cl-version "3.0 07-February-1993") - -;; This file is part of GNU Emacs. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY. No author or distributor -;; accepts responsibility to anyone for the consequences of using it -;; or for whether it serves any particular purpose or works at all, -;; unless he says so in writing. Refer to the GNU Emacs General Public -;; License for full details. - -;; Everyone is granted permission to copy, modify and redistribute -;; GNU Emacs, but only under the conditions described in the -;; GNU Emacs General Public License. A copy of this license is -;; supposed to have been given to you along with GNU Emacs so you -;; can know your rights and responsibilities. It should be in a -;; file named COPYING. Among other things, the copyright notice -;; and this notice must be preserved on all copies. - -;;; Commentary: - -;;; Notes from Rob Austein on his mods -;; yaya:/usr/u/sra/cl/cl.el, 5-May-1991 16:01:34, sra -;; -;; Slightly hacked copy of cl.el 2.0 beta 27. -;; -;; Various minor performance improvements: -;; a) Don't use MAPCAR when we're going to discard its results. -;; b) Make various macros a little more clever about optimizing -;; generated code in common cases. -;; c) Fix DEFSETF to expand to the right code at compile-time. -;; d) Make various macros cleverer about generating reasonable -;; code when compiled, particularly forms like DEFSTRUCT which -;; are usually used at top-level and thus are only compiled if -;; you use Hallvard Furuseth's hacked bytecomp.el. -;; -;; New features: GETF, REMF, and REMPROP. -;; -;; Notes: -;; 1) I'm sceptical about the FBOUNDP checks in SETF. Why should -;; the SETF expansion fail because the SETF method isn't defined -;; at compile time? Lisp is going to check for a binding at run-time -;; anyway, so maybe we should just assume the user's right here. - -;;;; These are extensions to Emacs Lisp that provide some form of -;;;; Common Lisp compatibility, beyond what is already built-in -;;;; in Emacs Lisp. -;;;; -;;;; When developing them, I had the code spread among several files. -;;;; This file 'cl.el' is a concatenation of those original files, -;;;; minus some declarations that became redundant. The marks between -;;;; the original files can be found easily, as they are lines that -;;;; begin with four semicolons (as this does). The names of the -;;;; original parts follow the four semicolons in uppercase, those -;;;; names are GLOBAL, SYMBOLS, LISTS, SEQUENCES, CONDITIONALS, -;;;; ITERATIONS, MULTIPLE VALUES, ARITH, SETF and DEFSTRUCT. If you -;;;; add functions to this file, you might want to put them in a place -;;;; that is compatible with the division above (or invent your own -;;;; categories). -;;;; -;;;; To compile this file, make sure you load it first. This is -;;;; because many things are implemented as macros and now that all -;;;; the files are concatenated together one cannot ensure that -;;;; declaration always precedes use. -;;;; -;;;; Bug reports, suggestions and comments, -;;;; to quiroz@cs.rochester.edu - - -;;;; GLOBAL -;;;; This file provides utilities and declarations that are global -;;;; to Common Lisp and so might be used by more than one of the -;;;; other libraries. Especially, I intend to keep here some -;;;; utilities that help parsing/destructuring some difficult calls. -;;;; -;;;; -;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986 -;;;; (quiroz@cs.rochester.edu) - -;;; Too many pieces of the rest of this package use psetq. So it is unwise to -;;; use here anything but plain Emacs Lisp! There is a neater recursive form -;;; for the algorithm that deals with the bodies. - -;;; Code: - -;;; This version is due to Hallvard Furuseth (hallvard@ifi.uio.no, 6 Jul 91) -(defmacro psetq (&rest args) - "(psetq {VARIABLE VALUE}...): In parallel, set each VARIABLE to its VALUE. -All the VALUEs are evaluated, and then all the VARIABLEs are set. -Aside from order of evaluation, this is the same as `setq'." - ;; check there is a reasonable number of forms - (if (/= (% (length args) 2) 0) - (error "Odd number of arguments to `psetq'")) - (setq args (copy-sequence args)) ;for safety below - (prog1 (cons 'setq args) - (while (progn (if (not (symbolp (car args))) - (error "`psetq' expected a symbol, found '%s'." - (prin1-to-string (car args)))) - (cdr (cdr args))) - (setcdr args (list (list 'prog1 (nth 1 args) - (cons 'setq - (setq args (cdr (cdr args)))))))))) - -;;; utilities -;;; -;;; pair-with-newsyms takes a list and returns a list of lists of the -;;; form (newsym form), such that a let* can then bind the evaluation -;;; of the forms to the newsyms. The idea is to guarantee correct -;;; order of evaluation of the subforms of a setf. It also returns a -;;; list of the newsyms generated, in the corresponding order. - -(defun pair-with-newsyms (oldforms) - "PAIR-WITH-NEWSYMS OLDFORMS -The top-level components of the list oldforms are paired with fresh -symbols, the pairings list and the newsyms list are returned." - (do ((ptr oldforms (cdr ptr)) - (bindings '()) - (newsyms '())) - ((endp ptr) (values (nreverse bindings) (nreverse newsyms))) - (let ((newsym (gentemp))) - (setq bindings (cons (list newsym (car ptr)) bindings)) - (setq newsyms (cons newsym newsyms))))) - -(defun zip-lists (evens odds) - "Merge two lists EVENS and ODDS, taking elts from each list alternatingly. -EVENS and ODDS are two lists. ZIP-LISTS constructs a new list, whose -even numbered elements (0,2,...) come from EVENS and whose odd -numbered elements (1,3,...) come from ODDS. -The construction stops when the shorter list is exhausted." - (do* ((p0 evens (cdr p0)) - (p1 odds (cdr p1)) - (even (car p0) (car p0)) - (odd (car p1) (car p1)) - (result '())) - ((or (endp p0) (endp p1)) - (nreverse result)) - (setq result - (cons odd (cons even result))))) - -(defun unzip-list (list) - "Extract even and odd elements of LIST into two separate lists. -The argument LIST is separated in two strands, the even and the odd -numbered elements. Numbering starts with 0, so the first element -belongs in EVENS. No check is made that there is an even number of -elements to start with." - (do* ((ptr list (cddr ptr)) - (this (car ptr) (car ptr)) - (next (cadr ptr) (cadr ptr)) - (evens '()) - (odds '())) - ((endp ptr) - (values (nreverse evens) (nreverse odds))) - (setq evens (cons this evens)) - (setq odds (cons next odds)))) - -(defun reassemble-argslists (argslists) - "(reassemble-argslists ARGSLISTS) => a list of lists -ARGSLISTS is a list of sequences. Return a list of lists, the first -sublist being all the entries coming from ELT 0 of the original -sublists, the next those coming from ELT 1 and so on, until the -shortest list is exhausted." - (let* ((minlen (apply 'min (mapcar 'length argslists))) - (result '())) - (dotimes (i minlen (nreverse result)) - ;; capture all the elements at index i - (setq result - (cons (mapcar (function (lambda (sublist) (elt sublist i))) - argslists) - result))))) - - -;;; Checking that a list of symbols contains no duplicates is a common -;;; task when checking the legality of some macros. The check for 'eq -;;; pairs can be too expensive, as it is quadratic on the length of -;;; the list. I use a 4-pass, linear, counting approach. It surely -;;; loses on small lists (less than 5 elements?), but should win for -;;; larger lists. The fourth pass could be eliminated. -;;; 10 dec 1986. Emacs Lisp has no REMPROP, so I just eliminated the -;;; 4th pass. -;;; -;;; [22 April 1991, sra] REMPROP now in library, so restored 4th pass. -(defun duplicate-symbols-p (list) - "Find all symbols appearing more than once in LIST. -Return a list of all such duplicates; `nil' if there are no duplicates." - (let ((duplicates '()) ;result built here - (propname (gensym)) ;we use a fresh property - ) - ;; check validity - (unless (and (listp list) - (every 'symbolp list)) - (error "a list of symbols is needed")) - ;; pass 1: mark - (dolist (x list) - (put x propname 0)) - ;; pass 2: count - (dolist (x list) - (put x propname (1+ (get x propname)))) - ;; pass 3: collect - (dolist (x list) - (if (> (get x propname) 1) - (setq duplicates (cons x duplicates)))) - ;; pass 4: unmark. - (dolist (x list) - (remprop x propname)) - ;; return result - duplicates)) - -;;;; end of cl-global.el - -;;;; SYMBOLS -;;;; This file provides the gentemp function, which generates fresh -;;;; symbols, plus some other minor Common Lisp symbol tools. -;;;; -;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986 -;;;; (quiroz@cs.rochester.edu) - -;;; Keywords. There are no packages in Emacs Lisp, so this is only a -;;; kludge around to let things be "as if" a keyword package was around. - -(defmacro defkeyword (x &optional docstring) - "Make symbol X a keyword (symbol whose value is itself). -Optional second argument is a documentation string for it." - (cond ((symbolp x) - (list 'defconst x (list 'quote x) docstring)) - (t - (error "`%s' is not a symbol" (prin1-to-string x))))) - -(defun keywordp (sym) - "t if SYM is a keyword." - (if (and (symbolp sym) (char-equal (aref (symbol-name sym) 0) ?\:)) - ;; looks like one, make sure value is right - (set sym sym) - nil)) - -(defun keyword-of (sym) - "Return a keyword that is naturally associated with symbol SYM. -If SYM is keyword, the value is SYM. -Otherwise it is a keyword whose name is `:' followed by SYM's name." - (cond ((keywordp sym) - sym) - ((symbolp sym) - (let ((newsym (intern (concat ":" (symbol-name sym))))) - (set newsym newsym))) - (t - (error "expected a symbol, not `%s'" (prin1-to-string sym))))) - -;;; Temporary symbols. -;;; - -(defvar *gentemp-index* 0 - "Integer used by gentemp to produce new names.") - -(defvar *gentemp-prefix* "T$$_" - "Names generated by gentemp begin with this string by default.") - -(defun gentemp (&optional prefix oblist) - "Generate a fresh interned symbol. -There are 2 optional arguments, PREFIX and OBLIST. PREFIX is the -string that begins the new name, OBLIST is the obarray used to search for -old names. The defaults are just right, YOU SHOULD NEVER NEED THESE -ARGUMENTS IN YOUR OWN CODE." - (if (null prefix) - (setq prefix *gentemp-prefix*)) - (if (null oblist) - (setq oblist obarray)) ;default for the intern functions - (let ((newsymbol nil) - (newname)) - (while (not newsymbol) - (setq newname (concat prefix *gentemp-index*)) - (setq *gentemp-index* (+ *gentemp-index* 1)) - (if (not (intern-soft newname oblist)) - (setq newsymbol (intern newname oblist)))) - newsymbol)) - -(defvar *gensym-index* 0 - "Integer used by gensym to produce new names.") - -(defvar *gensym-prefix* "G$$_" - "Names generated by gensym begin with this string by default.") - -(defun gensym (&optional prefix) - "Generate a fresh uninterned symbol. -There is an optional argument, PREFIX. PREFIX is the -string that begins the new name. Most people take just the default, -except when debugging needs suggest otherwise." - (if (null prefix) - (setq prefix *gensym-prefix*)) - (let ((newsymbol nil) - (newname "")) - (while (not newsymbol) - (setq newname (concat prefix *gensym-index*)) - (setq *gensym-index* (+ *gensym-index* 1)) - (if (not (intern-soft newname)) - (setq newsymbol (make-symbol newname)))) - newsymbol)) - -;;;; end of cl-symbols.el - -;;;; CONDITIONALS -;;;; This file provides some of the conditional constructs of -;;;; Common Lisp. Total compatibility is again impossible, as the -;;;; 'if' form is different in both languages, so only a good -;;;; approximation is desired. -;;;; -;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986 -;;;; (quiroz@cs.rochester.edu) - -;;; indentation info -(put 'case 'lisp-indent-hook 1) -(put 'ecase 'lisp-indent-hook 1) -(put 'when 'lisp-indent-hook 1) -(put 'unless 'lisp-indent-hook 1) - -;;; WHEN and UNLESS -;;; These two forms are simplified ifs, with a single branch. - -(defmacro when (condition &rest body) - "(when CONDITION . BODY) => evaluate BODY if CONDITION is true." - (list* 'if (list 'not condition) '() body)) - -(defmacro unless (condition &rest body) - "(unless CONDITION . BODY) => evaluate BODY if CONDITION is false." - (list* 'if condition '() body)) - -;;; CASE and ECASE -;;; CASE selects among several clauses, based on the value (evaluated) -;;; of a expression and a list of (unevaluated) key values. ECASE is -;;; the same, but signals an error if no clause is activated. - -(defmacro case (expr &rest cases) - "(case EXPR . CASES) => evals EXPR, chooses from CASES on that value. -EXPR -> any form -CASES -> list of clauses, non empty -CLAUSE -> HEAD . BODY -HEAD -> t = catch all, must be last clause - -> otherwise = same as t - -> nil = illegal - -> atom = activated if (eql EXPR HEAD) - -> list of atoms = activated if (memq EXPR HEAD) -BODY -> list of forms, implicit PROGN is built around it. -EXPR is evaluated only once." - (let* ((newsym (gentemp)) - (clauses (case-clausify cases newsym))) - ;; convert case into a cond inside a let - (list 'let - (list (list newsym expr)) - (list* 'cond (nreverse clauses))))) - -(defmacro ecase (expr &rest cases) - "(ecase EXPR . CASES) => like `case', but error if no case fits. -`t'-clauses are not allowed." - (let* ((newsym (gentemp)) - (clauses (case-clausify cases newsym))) - ;; check that no 't clause is present. - ;; case-clausify would put one such at the beginning of clauses - (if (eq (caar clauses) t) - (error "no clause-head should be `t' or `otherwise' for `ecase'")) - ;; insert error-catching clause - (setq clauses - (cons - (list 't (list 'error - "ecase on %s = %s failed to take any branch" - (list 'quote expr) - (list 'prin1-to-string newsym))) - clauses)) - ;; generate code as usual - (list 'let - (list (list newsym expr)) - (list* 'cond (nreverse clauses))))) - - -(defun case-clausify (cases newsym) - "CASE-CLAUSIFY CASES NEWSYM => clauses for a 'cond' -Converts the CASES of a [e]case macro into cond clauses to be -evaluated inside a let that binds NEWSYM. Returns the clauses in -reverse order." - (do* ((currentpos cases (cdr currentpos)) - (nextpos (cdr cases) (cdr nextpos)) - (curclause (car cases) (car currentpos)) - (result '())) - ((endp currentpos) result) - (let ((head (car curclause)) - (body (cdr curclause))) - ;; construct a cond-clause according to the head - (cond ((null head) - (error "case clauses cannot have null heads: `%s'" - (prin1-to-string curclause))) - ((or (eq head 't) - (eq head 'otherwise)) - ;; check it is the last clause - (if (not (endp nextpos)) - (error "clause with `t' or `otherwise' head must be last")) - ;; accept this clause as a 't' for cond - (setq result (cons (cons 't body) result))) - ((atom head) - (setq result - (cons (cons (list 'eql newsym (list 'quote head)) body) - result))) - ((listp head) - (setq result - (cons (cons (list 'memq newsym (list 'quote head)) body) - result))) - (t - ;; catch-all for this parser - (error "don't know how to parse case clause `%s'" - (prin1-to-string head))))))) - -;;;; end of cl-conditionals.el - -;;;; ITERATIONS -;;;; This file provides simple iterative macros (a la Common Lisp) -;;;; constructed on the basis of let, let* and while, which are the -;;;; primitive binding/iteration constructs of Emacs Lisp -;;;; -;;;; The Common Lisp iterations use to have a block named nil -;;;; wrapped around them, and allow declarations at the beginning -;;;; of their bodies and you can return a value using (return ...). -;;;; Nothing of the sort exists in Emacs Lisp, so I haven't tried -;;;; to imitate these behaviors. -;;;; -;;;; Other than the above, the semantics of Common Lisp are -;;;; correctly reproduced to the extent this was reasonable. -;;;; -;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986 -;;;; (quiroz@cs.rochester.edu) - -;;; some lisp-indentation information -(put 'do 'lisp-indent-hook 2) -(put 'do* 'lisp-indent-hook 2) -(put 'dolist 'lisp-indent-hook 1) -(put 'dotimes 'lisp-indent-hook 1) -(put 'do-symbols 'lisp-indent-hook 1) -(put 'do-all-symbols 'lisp-indent-hook 1) - - -(defmacro do (stepforms endforms &rest body) - "(do STEPFORMS ENDFORMS . BODY): Iterate BODY, stepping some local variables. -STEPFORMS must be a list of symbols or lists. In the second case, the -lists must start with a symbol and contain up to two more forms. In -the STEPFORMS, a symbol is the same as a (symbol). The other 2 forms -are the initial value (def. NIL) and the form to step (def. itself). -The values used by initialization and stepping are computed in parallel. -The ENDFORMS are a list (CONDITION . ENDBODY). If the CONDITION -evaluates to true in any iteration, ENDBODY is evaluated and the last -form in it is returned. -The BODY (which may be empty) is evaluated at every iteration, with -the symbols of the STEPFORMS bound to the initial or stepped values." - ;; check the syntax of the macro - (and (check-do-stepforms stepforms) - (check-do-endforms endforms)) - ;; construct emacs-lisp equivalent - (let ((initlist (extract-do-inits stepforms)) - (steplist (extract-do-steps stepforms)) - (endcond (car endforms)) - (endbody (cdr endforms))) - (cons 'let (cons initlist - (cons (cons 'while (cons (list 'not endcond) - (append body steplist))) - (append endbody)))))) - - -(defmacro do* (stepforms endforms &rest body) - "`do*' is to `do' as `let*' is to `let'. -STEPFORMS must be a list of symbols or lists. In the second case, the -lists must start with a symbol and contain up to two more forms. In -the STEPFORMS, a symbol is the same as a (symbol). The other 2 forms -are the initial value (def. NIL) and the form to step (def. itself). -Initializations and steppings are done in the sequence they are written. -The ENDFORMS are a list (CONDITION . ENDBODY). If the CONDITION -evaluates to true in any iteration, ENDBODY is evaluated and the last -form in it is returned. -The BODY (which may be empty) is evaluated at every iteration, with -the symbols of the STEPFORMS bound to the initial or stepped values." - ;; check the syntax of the macro - (and (check-do-stepforms stepforms) - (check-do-endforms endforms)) - ;; construct emacs-lisp equivalent - (let ((initlist (extract-do-inits stepforms)) - (steplist (extract-do*-steps stepforms)) - (endcond (car endforms)) - (endbody (cdr endforms))) - (cons 'let* (cons initlist - (cons (cons 'while (cons (list 'not endcond) - (append body steplist))) - (append endbody)))))) - - -;;; DO and DO* share the syntax checking functions that follow. - -(defun check-do-stepforms (forms) - "True if FORMS is a valid stepforms for the do[*] macro (q.v.)" - (if (nlistp forms) - (error "init/step form for do[*] should be a list, not `%s'" - (prin1-to-string forms)) - (mapcar - (function - (lambda (entry) - (if (not (or (symbolp entry) - (and (listp entry) - (symbolp (car entry)) - (< (length entry) 4)))) - (error "init/step must be %s, not `%s'" - "symbol or (symbol [init [step]])" - (prin1-to-string entry))))) - forms))) - -(defun check-do-endforms (forms) - "True if FORMS is a valid endforms for the do[*] macro (q.v.)" - (if (nlistp forms) - (error "termination form for do macro should be a list, not `%s'" - (prin1-to-string forms)))) - -(defun extract-do-inits (forms) - "Returns a list of the initializations (for do) in FORMS ---a stepforms, see the do macro--. FORMS is assumed syntactically valid." - (mapcar - (function - (lambda (entry) - (cond ((symbolp entry) - (list entry nil)) - ((listp entry) - (list (car entry) (cadr entry)))))) - forms)) - -;;; There used to be a reason to deal with DO differently than with -;;; DO*. The writing of PSETQ has made it largely unnecessary. - -(defun extract-do-steps (forms) - "EXTRACT-DO-STEPS FORMS => an s-expr -FORMS is the stepforms part of a DO macro (q.v.). This function -constructs an s-expression that does the stepping at the end of an -iteration." - (list (cons 'psetq (select-stepping-forms forms)))) - -(defun extract-do*-steps (forms) - "EXTRACT-DO*-STEPS FORMS => an s-expr -FORMS is the stepforms part of a DO* macro (q.v.). This function -constructs an s-expression that does the stepping at the end of an -iteration." - (list (cons 'setq (select-stepping-forms forms)))) - -(defun select-stepping-forms (forms) - "Separate only the forms that cause stepping." - (let ((result '()) ;ends up being (... var form ...) - (ptr forms) ;to traverse the forms - entry ;to explore each form in turn - ) - (while ptr ;(not (endp entry)) might be safer - (setq entry (car ptr)) - (cond ((and (listp entry) (= (length entry) 3)) - (setq result (append ;append in reverse order! - (list (caddr entry) (car entry)) - result)))) - (setq ptr (cdr ptr))) ;step in the list of forms - (nreverse result))) - -;;; Other iterative constructs - -(defmacro dolist (stepform &rest body) - "(dolist (VAR LIST [RESULTFORM]) . BODY): do BODY for each elt of LIST. -The RESULTFORM defaults to nil. The VAR is bound to successive -elements of the value of LIST and remains bound (to the nil value) when the -RESULTFORM is evaluated." - ;; check sanity - (cond - ((nlistp stepform) - (error "stepform for `dolist' should be (VAR LIST [RESULT]), not `%s'" - (prin1-to-string stepform))) - ((not (symbolp (car stepform))) - (error "first component of stepform should be a symbol, not `%s'" - (prin1-to-string (car stepform)))) - ((> (length stepform) 3) - (error "too many components in stepform `%s'" - (prin1-to-string stepform)))) - ;; generate code - (let* ((var (car stepform)) - (listform (cadr stepform)) - (resultform (caddr stepform)) - (listsym (gentemp))) - (nconc - (list 'let (list var (list listsym listform)) - (nconc - (list 'while listsym - (list 'setq - var (list 'car listsym) - listsym (list 'cdr listsym))) - body)) - (and resultform - (cons (list 'setq var nil) - (list resultform)))))) - -(defmacro dotimes (stepform &rest body) - "(dotimes (VAR COUNTFORM [RESULTFORM]) . BODY): Repeat BODY, counting in VAR. -The COUNTFORM should return a positive integer. The VAR is bound to -successive integers from 0 to COUNTFORM-1 and the BODY is repeated for -each of them. At the end, the RESULTFORM is evaluated and its value -returned. During this last evaluation, the VAR is still bound, and its -value is the number of times the iteration occurred. An omitted RESULTFORM -defaults to nil." - ;; check sanity - (cond - ((nlistp stepform) - (error "stepform for `dotimes' should be (VAR COUNT [RESULT]), not `%s'" - (prin1-to-string stepform))) - ((not (symbolp (car stepform))) - (error "first component of stepform should be a symbol, not `%s'" - (prin1-to-string (car stepform)))) - ((> (length stepform) 3) - (error "too many components in stepform `%s'" - (prin1-to-string stepform)))) - ;; generate code - (let* ((var (car stepform)) - (countform (cadr stepform)) - (resultform (caddr stepform)) - (testsym (if (consp countform) (gentemp) countform))) - (nconc - (list - 'let (cons (list var -1) - (and (not (eq countform testsym)) - (list (list testsym countform)))) - (nconc - (list 'while (list '< (list 'setq var (list '1+ var)) testsym)) - body)) - (and resultform (list resultform))))) - -(defmacro do-symbols (stepform &rest body) - "(do_symbols (VAR [OBARRAY [RESULTFORM]]) . BODY) -The VAR is bound to each of the symbols in OBARRAY (def. obarray) and -the BODY is repeatedly performed for each of those bindings. At the -end, RESULTFORM (def. nil) is evaluated and its value returned. -During this last evaluation, the VAR is still bound and its value is nil. -See also the function `mapatoms'." - ;; check sanity - (cond - ((nlistp stepform) - (error "stepform for `do-symbols' should be (VAR OBARRAY [RESULT]), not `%s'" - (prin1-to-string stepform))) - ((not (symbolp (car stepform))) - (error "first component of stepform should be a symbol, not `%s'" - (prin1-to-string (car stepform)))) - ((> (length stepform) 3) - (error "too many components in stepform `%s'" - (prin1-to-string stepform)))) - ;; generate code - (let* ((var (car stepform)) - (oblist (cadr stepform)) - (resultform (caddr stepform))) - (list 'progn - (list 'mapatoms - (list 'function - (cons 'lambda (cons (list var) body))) - oblist) - (list 'let - (list (list var nil)) - resultform)))) - - -(defmacro do-all-symbols (stepform &rest body) - "(do-all-symbols (VAR [RESULTFORM]) . BODY) -Is the same as (do-symbols (VAR obarray RESULTFORM) . BODY)." - (list* - 'do-symbols - (list (car stepform) 'obarray (cadr stepform)) - body)) - -(defmacro loop (&rest body) - "(loop . BODY) repeats BODY indefinitely and does not return. -Normally BODY uses `throw' or `signal' to cause an exit. -The forms in BODY should be lists, as non-lists are reserved for new features." - ;; check that the body doesn't have atomic forms - (if (nlistp body) - (error "body of `loop' should be a list of lists or nil") - ;; ok, it is a list, check for atomic components - (mapcar - (function (lambda (component) - (if (nlistp component) - (error "components of `loop' should be lists")))) - body) - ;; build the infinite loop - (cons 'while (cons 't body)))) - -;;;; end of cl-iterations.el - -;;;; LISTS -;;;; This file provides some of the lists machinery of Common-Lisp -;;;; in a way compatible with Emacs Lisp. Especially, see the the -;;;; typical c[ad]*r functions. -;;;; -;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986 -;;;; (quiroz@cs.rochester.edu) - -;;; Synonyms for list functions -(defsubst first (x) - "Synonym for `car'" - (car x)) - -(defsubst second (x) - "Return the second element of the list LIST." - (nth 1 x)) - -(defsubst third (x) - "Return the third element of the list LIST." - (nth 2 x)) - -(defsubst fourth (x) - "Return the fourth element of the list LIST." - (nth 3 x)) - -(defsubst fifth (x) - "Return the fifth element of the list LIST." - (nth 4 x)) - -(defsubst sixth (x) - "Return the sixth element of the list LIST." - (nth 5 x)) - -(defsubst seventh (x) - "Return the seventh element of the list LIST." - (nth 6 x)) - -(defsubst eighth (x) - "Return the eighth element of the list LIST." - (nth 7 x)) - -(defsubst ninth (x) - "Return the ninth element of the list LIST." - (nth 8 x)) - -(defsubst tenth (x) - "Return the tenth element of the list LIST." - (nth 9 x)) - -(defsubst rest (x) - "Synonym for `cdr'" - (cdr x)) - -(defsubst endp (x) - "t if X is nil, nil if X is a cons; error otherwise." - (if (listp x) - (null x) - (error "endp received a non-cons, non-null argument `%s'" - (prin1-to-string x)))) - -(defun last (x) - "Returns the last link in the list LIST." - (if (nlistp x) - (error "arg to `last' must be a list")) - (do ((current-cons x (cdr current-cons)) - (next-cons (cdr x) (cdr next-cons))) - ((endp next-cons) current-cons))) - -(defun list-length (x) ;taken from CLtL sect. 15.2 - "Returns the length of a non-circular list, or `nil' for a circular one." - (do ((n 0) ;counter - (fast x (cddr fast)) ;fast pointer, leaps by 2 - (slow x (cdr slow)) ;slow pointer, leaps by 1 - (ready nil)) ;indicates termination - (ready n) - (cond ((endp fast) - (setq ready t)) ;return n - ((endp (cdr fast)) - (setq n (+ n 1)) - (setq ready t)) ;return n+1 - ((and (eq fast slow) (> n 0)) - (setq n nil) - (setq ready t)) ;return nil - (t - (setq n (+ n 2)))))) ;just advance counter - -(defun butlast (list &optional n) - "Return a new list like LIST but sans the last N elements. -N defaults to 1. If the list doesn't have N elements, nil is returned." - (if (null n) (setq n 1)) - (nreverse (nthcdr n (reverse list)))) ;optim. due to macrakis@osf.org - -;;; This version due to Aaron Larson (alarson@src.honeywell.com, 26 Jul 91) -(defun list* (arg &rest others) - "Return a new list containing the first arguments consed onto the last arg. -Thus, (list* 1 2 3 '(a b)) returns (1 2 3 a b)." - (if (null others) - arg - (let* ((others (cons arg (copy-sequence others))) - (a others)) - (while (cdr (cdr a)) - (setq a (cdr a))) - (setcdr a (car (cdr a))) - others))) - -(defun adjoin (item list) - "Return a list which contains ITEM but is otherwise like LIST. -If ITEM occurs in LIST, the value is LIST. Otherwise it is (cons ITEM LIST). -When comparing ITEM against elements, `eql' is used." - (if (memq item list) - list - (cons item list))) - -(defun ldiff (list sublist) - "Return a new list like LIST but sans SUBLIST. -SUBLIST must be one of the links in LIST; otherwise the value is LIST itself." - (do ((result '()) - (curcons list (cdr curcons))) - ((or (endp curcons) (eq curcons sublist)) - (reverse result)) - (setq result (cons (car curcons) result)))) - -;;; The popular c[ad]*r functions and other list accessors. - -;;; To implement this efficiently, a new byte compile handler is used to -;;; generate the minimal code, saving one function call. - -(defsubst caar (X) - "Return the car of the car of X." - (car (car X))) - -(defsubst cadr (X) - "Return the car of the cdr of X." - (car (cdr X))) - -(defsubst cdar (X) - "Return the cdr of the car of X." - (cdr (car X))) - -(defsubst cddr (X) - "Return the cdr of the cdr of X." - (cdr (cdr X))) - -(defsubst caaar (X) - "Return the car of the car of the car of X." - (car (car (car X)))) - -(defsubst caadr (X) - "Return the car of the car of the cdr of X." - (car (car (cdr X)))) - -(defsubst cadar (X) - "Return the car of the cdr of the car of X." - (car (cdr (car X)))) - -(defsubst cdaar (X) - "Return the cdr of the car of the car of X." - (cdr (car (car X)))) - -(defsubst caddr (X) - "Return the car of the cdr of the cdr of X." - (car (cdr (cdr X)))) - -(defsubst cdadr (X) - "Return the cdr of the car of the cdr of X." - (cdr (car (cdr X)))) - -(defsubst cddar (X) - "Return the cdr of the cdr of the car of X." - (cdr (cdr (car X)))) - -(defsubst cdddr (X) - "Return the cdr of the cdr of the cdr of X." - (cdr (cdr (cdr X)))) - -(defsubst caaaar (X) - "Return the car of the car of the car of the car of X." - (car (car (car (car X))))) - -(defsubst caaadr (X) - "Return the car of the car of the car of the cdr of X." - (car (car (car (cdr X))))) - -(defsubst caadar (X) - "Return the car of the car of the cdr of the car of X." - (car (car (cdr (car X))))) - -(defsubst cadaar (X) - "Return the car of the cdr of the car of the car of X." - (car (cdr (car (car X))))) - -(defsubst cdaaar (X) - "Return the cdr of the car of the car of the car of X." - (cdr (car (car (car X))))) - -(defsubst caaddr (X) - "Return the car of the car of the cdr of the cdr of X." - (car (car (cdr (cdr X))))) - -(defsubst cadadr (X) - "Return the car of the cdr of the car of the cdr of X." - (car (cdr (car (cdr X))))) - -(defsubst cdaadr (X) - "Return the cdr of the car of the car of the cdr of X." - (cdr (car (car (cdr X))))) - -(defsubst caddar (X) - "Return the car of the cdr of the cdr of the car of X." - (car (cdr (cdr (car X))))) - -(defsubst cdadar (X) - "Return the cdr of the car of the cdr of the car of X." - (cdr (car (cdr (car X))))) - -(defsubst cddaar (X) - "Return the cdr of the cdr of the car of the car of X." - (cdr (cdr (car (car X))))) - -(defsubst cadddr (X) - "Return the car of the cdr of the cdr of the cdr of X." - (car (cdr (cdr (cdr X))))) - -(defsubst cddadr (X) - "Return the cdr of the cdr of the car of the cdr of X." - (cdr (cdr (car (cdr X))))) - -(defsubst cdaddr (X) - "Return the cdr of the car of the cdr of the cdr of X." - (cdr (car (cdr (cdr X))))) - -(defsubst cdddar (X) - "Return the cdr of the cdr of the cdr of the car of X." - (cdr (cdr (cdr (car X))))) - -(defsubst cddddr (X) - "Return the cdr of the cdr of the cdr of the cdr of X." - (cdr (cdr (cdr (cdr X))))) - -;;; some inverses of the accessors are needed for setf purposes - -(defsubst setnth (n list newval) - "Set (nth N LIST) to NEWVAL. Returns NEWVAL." - (rplaca (nthcdr n list) newval)) - -(defun setnthcdr (n list newval) - "(setnthcdr N LIST NEWVAL) => NEWVAL -As a side effect, sets the Nth cdr of LIST to NEWVAL." - (when (< n 0) - (error "N must be 0 or greater, not %d" n)) - (while (> n 0) - (setq list (cdr list) - n (- n 1))) - ;; here only if (zerop n) - (rplaca list (car newval)) - (rplacd list (cdr newval)) - newval) - -;;; A-lists machinery - -(defsubst acons (key item alist) - "Return a new alist with KEY paired with ITEM; otherwise like ALIST. -Does not copy ALIST." - (cons (cons key item) alist)) - -(defun pairlis (keys data &optional alist) - "Return a new alist with each elt of KEYS paired with an elt of DATA; -optional 3rd arg ALIST is nconc'd at the end. KEYS and DATA must -have the same length." - (unless (= (length keys) (length data)) - (error "keys and data should be the same length")) - (do* ;;collect keys and data in front of alist - ((kptr keys (cdr kptr)) ;traverses the keys - (dptr data (cdr dptr)) ;traverses the data - (key (car kptr) (car kptr)) ;current key - (item (car dptr) (car dptr)) ;current data item - (result alist)) - ((endp kptr) result) - (setq result (acons key item result)))) - -;;;; end of cl-lists.el - -;;;; SEQUENCES -;;;; Emacs Lisp provides many of the 'sequences' functionality of -;;;; Common Lisp. This file provides a few things that were left out. -;;;; - - -(defkeyword :test "Used to designate positive (selection) tests.") -(defkeyword :test-not "Used to designate negative (rejection) tests.") -(defkeyword :key "Used to designate component extractions.") -(defkeyword :predicate "Used to define matching of sequence components.") -(defkeyword :start "Inclusive low index in sequence") -(defkeyword :end "Exclusive high index in sequence") -(defkeyword :start1 "Inclusive low index in first of two sequences.") -(defkeyword :start2 "Inclusive low index in second of two sequences.") -(defkeyword :end1 "Exclusive high index in first of two sequences.") -(defkeyword :end2 "Exclusive high index in second of two sequences.") -(defkeyword :count "Number of elements to affect.") -(defkeyword :from-end "T when counting backwards.") -(defkeyword :initial-value "For the syntax of #'reduce") - -(defun some (pred seq &rest moreseqs) - "Test PREDICATE on each element of SEQUENCE; is it ever non-nil? -Extra args are additional sequences; PREDICATE gets one arg from each -sequence and we advance down all the sequences together in lock-step. -A sequence means either a list or a vector." - (let ((args (reassemble-argslists (list* seq moreseqs)))) - (do* ((ready nil) ;flag: return when t - (result nil) ;resulting value - (applyval nil) ;result of applying pred once - (remaining args - (cdr remaining)) ;remaining argument sets - (current (car remaining) ;current argument set - (car remaining))) - ((or ready (endp remaining)) result) - (setq applyval (apply pred current)) - (when applyval - (setq ready t) - (setq result applyval))))) - -(defun every (pred seq &rest moreseqs) - "Test PREDICATE on each element of SEQUENCE; is it always non-nil? -Extra args are additional sequences; PREDICATE gets one arg from each -sequence and we advance down all the sequences together in lock-step. -A sequence means either a list or a vector." - (let ((args (reassemble-argslists (list* seq moreseqs)))) - (do* ((ready nil) ;flag: return when t - (result t) ;resulting value - (applyval nil) ;result of applying pred once - (remaining args - (cdr remaining)) ;remaining argument sets - (current (car remaining) ;current argument set - (car remaining))) - ((or ready (endp remaining)) result) - (setq applyval (apply pred current)) - (unless applyval - (setq ready t) - (setq result nil))))) - -(defun notany (pred seq &rest moreseqs) - "Test PREDICATE on each element of SEQUENCE; is it always nil? -Extra args are additional sequences; PREDICATE gets one arg from each -sequence and we advance down all the sequences together in lock-step. -A sequence means either a list or a vector." - (let ((args (reassemble-argslists (list* seq moreseqs)))) - (do* ((ready nil) ;flag: return when t - (result t) ;resulting value - (applyval nil) ;result of applying pred once - (remaining args - (cdr remaining)) ;remaining argument sets - (current (car remaining) ;current argument set - (car remaining))) - ((or ready (endp remaining)) result) - (setq applyval (apply pred current)) - (when applyval - (setq ready t) - (setq result nil))))) - -(defun notevery (pred seq &rest moreseqs) - "Test PREDICATE on each element of SEQUENCE; is it sometimes nil? -Extra args are additional sequences; PREDICATE gets one arg from each -sequence and we advance down all the sequences together in lock-step. -A sequence means either a list or a vector." - (let ((args (reassemble-argslists (list* seq moreseqs)))) - (do* ((ready nil) ;flag: return when t - (result nil) ;resulting value - (applyval nil) ;result of applying pred once - (remaining args - (cdr remaining)) ;remaining argument sets - (current (car remaining) ;current argument set - (car remaining))) - ((or ready (endp remaining)) result) - (setq applyval (apply pred current)) - (unless applyval - (setq ready t) - (setq result t))))) - -;;; More sequence functions that don't need keyword arguments - -(defun concatenate (type &rest sequences) - "(concatenate TYPE &rest SEQUENCES) => a sequence -The sequence returned is of type TYPE (must be 'list, 'string, or 'vector) and -contains the concatenation of the elements of all the arguments, in the order -given." - (let ((sequences (append sequences '(())))) - (case type - (list - (apply (function append) sequences)) - (string - (apply (function concat) sequences)) - (vector - (apply (function vector) (apply (function append) sequences))) - (t - (error "type for concatenate `%s' not 'list, 'string or 'vector" - (prin1-to-string type)))))) - -(defun map (type function &rest sequences) - "(map TYPE FUNCTION &rest SEQUENCES) => a sequence -The FUNCTION is called on each set of elements from the SEQUENCES \(stopping -when the shortest sequence is terminated\) and the results are possibly -returned in a sequence of type TYPE \(one of 'list, 'vector, 'string, or nil\) -giving NIL for TYPE gets rid of the values." - (if (not (memq type (list 'list 'string 'vector nil))) - (error "type for map `%s' not 'list, 'string, 'vector or nil" - (prin1-to-string type))) - (let ((argslists (reassemble-argslists sequences)) - results) - (if (null type) - (while argslists ;don't bother accumulating - (apply function (car argslists)) - (setq argslists (cdr argslists))) - (setq results (mapcar (function (lambda (args) (apply function args))) - argslists)) - (case type - (list - results) - (string - (funcall (function concat) results)) - (vector - (apply (function vector) results)))))) - -;;; an inverse of elt is needed for setf purposes - -(defun setelt (seq n newval) - "In SEQUENCE, set the Nth element to NEWVAL. Returns NEWVAL. -A sequence means either a list or a vector." - (let ((l (length seq))) - (if (or (< n 0) (>= n l)) - (error "N(%d) should be between 0 and %d" n l) - ;; only two cases need be considered valid, as strings are arrays - (cond ((listp seq) - (setnth n seq newval)) - ((arrayp seq) - (aset seq n newval)) - (t - (error "SEQ should be a sequence, not `%s'" - (prin1-to-string seq))))))) - -;;; Testing with keyword arguments. -;;; -;;; Many of the sequence functions use keywords to denote some stylized -;;; form of selecting entries in a sequence. The involved arguments -;;; are collected with a &rest marker (as Emacs Lisp doesn't have a &key -;;; marker), then they are passed to build-klist, who -;;; constructs an association list. That association list is used to -;;; test for satisfaction and matching. - -;;; DON'T USE MEMBER, NOR ANY FUNCTION THAT COULD TAKE KEYWORDS HERE!!! - -(defun build-klist (argslist acceptable &optional allow-other-keys) - "Decode a keyword argument list ARGSLIST for keywords in ACCEPTABLE. -ARGSLIST is a list, presumably the &rest argument of a call, whose -even numbered elements must be keywords. -ACCEPTABLE is a list of keywords, the only ones that are truly acceptable. -The result is an alist containing the arguments named by the keywords -in ACCEPTABLE, or an error is signalled, if something failed. -If the third argument (an optional) is non-nil, other keys are acceptable." - ;; check legality of the arguments, then destructure them - (unless (and (listp argslist) - (evenp (length argslist))) - (error "build-klist: odd number of keyword-args")) - (unless (and (listp acceptable) - (every 'keywordp acceptable)) - (error "build-klist: second arg should be a list of keywords")) - (multiple-value-bind - (keywords forms) - (unzip-list argslist) - (unless (every 'keywordp keywords) - (error "build-klist: expected keywords, found `%s'" - (prin1-to-string keywords))) - (unless (or allow-other-keys - (every (function (lambda (keyword) - (memq keyword acceptable))) - keywords)) - (error "bad keyword[s]: %s not in %s" - (prin1-to-string (mapcan (function (lambda (keyword) - (if (memq keyword acceptable) - nil - (list keyword)))) - keywords)) - (prin1-to-string acceptable))) - (do* ;;pick up the pieces - ((auxlist ;auxiliary a-list, may - (pairlis keywords forms)) ;contain repetitions and junk - (ptr acceptable (cdr ptr)) ;pointer in acceptable - (this (car ptr) (car ptr)) ;current acceptable keyword - (auxval nil) ;used to move values around - (alist '())) ;used to build the result - ((endp ptr) alist) - ;; if THIS appears in auxlist, use its value - (when (setq auxval (assq this auxlist)) - (setq alist (cons auxval alist)))))) - - -(defun extract-from-klist (klist key &optional default) - "(extract-from-klist KLIST KEY [DEFAULT]) => value of KEY or DEFAULT -Extract value associated with KEY in KLIST (return DEFAULT if nil)." - (let ((retrieved (cdr (assq key klist)))) - (or retrieved default))) - -(defun keyword-argument-supplied-p (klist key) - "(keyword-argument-supplied-p KLIST KEY) => nil or something -NIL if KEY (a keyword) does not appear in the KLIST." - (assq key klist)) - -(defun add-to-klist (key item klist) - "(ADD-TO-KLIST KEY ITEM KLIST) => new KLIST -Add association (KEY . ITEM) to KLIST." - (setq klist (acons key item klist))) - -(defun elt-satisfies-test-p (item elt klist) - "(elt-satisfies-test-p ITEM ELT KLIST) => t or nil -KLIST encodes a keyword-arguments test, as in CH. 14 of CLtL. -True if the given ITEM and ELT satisfy the test." - (let ((test (extract-from-klist klist :test)) - (test-not (extract-from-klist klist :test-not)) - (keyfn (extract-from-klist klist :key 'identity))) - (cond (test - (funcall test item (funcall keyfn elt))) - (test-not - (not (funcall test-not item (funcall keyfn elt)))) - (t ;should never happen - (error "neither :test nor :test-not in `%s'" - (prin1-to-string klist)))))) - -(defun elt-satisfies-if-p (item klist) - "(elt-satisfies-if-p ITEM KLIST) => t or nil -True if an -if style function was called and ITEM satisfies the -predicate under :predicate in KLIST." - (let ((predicate (extract-from-klist klist :predicate)) - (keyfn (extract-from-klist klist :key 'identity))) - (funcall predicate (funcall keyfn item)))) - -(defun elt-satisfies-if-not-p (item klist) - "(elt-satisfies-if-not-p ITEM KLIST) => t or nil -KLIST encodes a keyword-arguments test, as in CH. 14 of CLtL. -True if an -if-not style function was called and ITEM does not satisfy -the predicate under :predicate in KLIST." - (let ((predicate (extract-from-klist klist :predicate)) - (keyfn (extract-from-klist klist :key 'identity))) - (not (funcall predicate (funcall keyfn item))))) - -(defun elts-match-under-klist-p (e1 e2 klist) - "(elts-match-under-klist-p E1 E2 KLIST) => t or nil -KLIST encodes a keyword-arguments test, as in CH. 14 of CLtL. -True if elements E1 and E2 match under the tests encoded in KLIST." - (let ((test (extract-from-klist klist :test)) - (test-not (extract-from-klist klist :test-not)) - (keyfn (extract-from-klist klist :key 'identity))) - (if (and test test-not) - (error "both :test and :test-not in `%s'" - (prin1-to-string klist))) - (cond (test - (funcall test (funcall keyfn e1) (funcall keyfn e2))) - (test-not - (not (funcall test-not (funcall keyfn e1) (funcall keyfn e2)))) - (t ;should never happen - (error "neither :test nor :test-not in `%s'" - (prin1-to-string klist)))))) - -;;; This macro simplifies using keyword args. It is less clumsy than using -;;; the primitives build-klist, etc... For instance, member could be written -;;; this way: - -;;; (defun member (item list &rest kargs) -;;; (with-keyword-args kargs (test test-not (key 'identity)) -;;; ...)) - -;;; Suggested by Robert Potter (potter@cs.rochester.edu, 15 Nov 1989) - -(defmacro with-keyword-args (keyargslist vardefs &rest body) - "(WITH-KEYWORD-ARGS KEYARGSLIST VARDEFS . BODY) -KEYARGSLIST can be either a symbol or a list of one or two symbols. -In the second case, the second symbol is either T or NIL, indicating whether -keywords other than the mentioned ones are tolerable. - -VARDEFS is a list. Each entry is either a VAR (symbol) or matches -\(VAR [DEFAULT [KEYWORD]]). Just giving VAR is the same as giving -\(VAR nil :VAR). - -The BODY is executed in an environment where each VAR (a symbol) is bound to -the value present in the KEYARGSLIST provided, or to the DEFAULT. The value -is searched by using the keyword form of VAR (i.e., :VAR) or the optional -keyword if provided. - -Notice that this macro doesn't distinguish between a default value given -explicitly by the user and one provided by default. See also the more -primitive functions build-klist, add-to-klist, extract-from-klist, -keyword-argument-supplied-p, elt-satisfies-test-p, elt-satisfies-if-p, -elt-satisfies-if-not-p, elts-match-under-klist-p. They provide more complete, -if clumsier, control over this feature." - (let (allow-other-keys) - (if (listp keyargslist) - (if (> (length keyargslist) 2) - (error - "`%s' should be SYMBOL, (SYMBOL), or (SYMBOL t-OR-nil)" - (prin1-to-string keyargslist)) - (setq allow-other-keys (cadr keyargslist) - keyargslist (car keyargslist)) - (if (not (and - (symbolp keyargslist) - (memq allow-other-keys '(t nil)))) - (error - "first subform should be SYMBOL, (SYMBOL), or (SYMBOL t-OR-nil)" - ))) - (if (symbolp keyargslist) - (setq allow-other-keys nil) - (error - "first subform should be SYMBOL, (SYMBOL), or (SYMBOL t-OR-nil)"))) - (let (vars defaults keywords forms - (klistname (gensym "KLIST_"))) - (mapcar (function (lambda (entry) - (if (symbolp entry) ;defaulty case - (setq entry (list entry nil (keyword-of entry)))) - (let* ((l (length entry)) - (v (car entry)) - (d (cadr entry)) - (k (caddr entry))) - (if (or (< l 1) (> l 3)) - (error - "`%s' must match (VAR [DEFAULT [KEYWORD]])" - (prin1-to-string entry))) - (if (or (null v) (not (symbolp v))) - (error - "bad variable `%s': must be non-null symbol" - (prin1-to-string v))) - (setq vars (cons v vars)) - (setq defaults (cons d defaults)) - (if (< l 3) - (setq k (keyword-of v))) - (if (and (= l 3) - (or (null k) - (not (keywordp k)))) - (error - "bad keyword `%s'" (prin1-to-string k))) - (setq keywords (cons k keywords)) - (setq forms (cons (list v (list 'extract-from-klist - klistname - k - d)) - forms))))) - vardefs) - (append - (list 'let* (nconc (list (list klistname - (list 'build-klist keyargslist - (list 'quote keywords) - allow-other-keys))) - (nreverse forms))) - body)))) -(put 'with-keyword-args 'lisp-indent-hook 1) - - -;;; REDUCE -;;; It is here mostly as an example of how to use KLISTs. -;;; -;;; First of all, you need to declare the keywords (done elsewhere in this -;;; file): -;;; (defkeyword :from-end "syntax of sequence functions") -;;; (defkeyword :start "syntax of sequence functions") -;;; etc... -;;; -;;; Then, you capture all the possible keyword arguments with a &rest -;;; argument. You can pass that list downward again, of course, but -;;; internally you need to parse it into a KLIST (an alist, really). One uses -;;; (build-klist REST-ARGS ACCEPTABLE-KEYWORDS [ALLOW-OTHER]). You can then -;;; test for presence by using (keyword-argument-supplied-p KLIST KEY) and -;;; extract a value with (extract-from-klist KLIST KEY [DEFAULT]). - -(defun reduce (function sequence &rest kargs) - "Apply FUNCTION (a function of two arguments) to successive pairs of elements -from SEQUENCE. Some keyword arguments are valid after FUNCTION and SEQUENCE: -:from-end If non-nil, process the values backwards -:initial-value If given, prefix it to the SEQUENCE. Suffix, if :from-end -:start Restrict reduction to the subsequence from this index -:end Restrict reduction to the subsequence BEFORE this index. -If the sequence is empty and no :initial-value is given, the FUNCTION is -called on zero (not two) arguments. Otherwise, if there is exactly one -element in the combination of SEQUENCE and the initial value, that element is -returned." - (let* ((klist (build-klist kargs '(:from-end :start :end :initial-value))) - (length (length sequence)) - (from-end (extract-from-klist klist :from-end)) - (initial-value-given (keyword-argument-supplied-p - klist :initial-value)) - (start (extract-from-klist kargs :start 0)) - (end (extract-from-klist kargs :end length))) - (setq sequence (cl$subseq-as-list sequence start end)) - (if from-end - (setq sequence (reverse sequence))) - (if initial-value-given - (setq sequence (cons (extract-from-klist klist :initial-value) - sequence))) - (if (null sequence) - (funcall function) ;only use of 0 arguments - (let* ((result (car sequence)) - (sequence (cdr sequence))) - (while sequence - (setq result (if from-end - (funcall function (car sequence) result) - (funcall function result (car sequence))) - sequence (cdr sequence))) - result)))) - -(defun cl$subseq-as-list (sequence start end) - "(cl$subseq-as-list SEQUENCE START END) => a list" - (let ((list (append sequence nil)) - (length (length sequence)) - result) - (if (< start 0) - (error "start should be >= 0, not %d" start)) - (if (> end length) - (error "end should be <= %d, not %d" length end)) - (if (and (zerop start) (= end length)) - list - (let ((i start) - (vector (apply 'vector list))) - (while (/= i end) - (setq result (cons (elt vector i) result)) - (setq i (+ i 1))) - (nreverse result))))) - -;;;; end of cl-sequences.el - -;;;; Some functions with keyword arguments -;;;; -;;;; Both list and sequence functions are considered here together. This -;;;; doesn't fit any more with the original split of functions in files. - -(defun cl-member (item list &rest kargs) - "Look for ITEM in LIST; return first tail of LIST the car of whose first -cons cell tests the same as ITEM. Admits arguments :key, :test, and -:test-not." - (if (null kargs) ;treat this fast for efficiency - (memq item list) - (let* ((klist (build-klist kargs '(:test :test-not :key))) - (test (extract-from-klist klist :test)) - (testnot (extract-from-klist klist :test-not)) - (key (extract-from-klist klist :key 'identity))) - ;; another workaround allegedly for speed, BLAH - (if (and (or (eq test 'eq) (eq test 'eql) - (eq test (symbol-function 'eq)) - (eq test (symbol-function 'eql))) - (null testnot) - (or (eq key 'identity) ;either by default or so given - (eq key (function identity)) ;could this happen? - (eq key (symbol-function 'identity)) ;sheer paranoia - )) - (memq item list) - (if (and test testnot) - (error ":test and :test-not both specified for member")) - (if (not (or test testnot)) - (setq test 'eql)) - ;; final hack: remove the indirection through the function names - (if testnot - (if (symbolp testnot) - (setq testnot (symbol-function testnot))) - (if (symbolp test) - (setq test (symbol-function test)))) - (if (symbolp key) - (setq key (symbol-function key))) - ;; ok, go for it - (let ((ptr list) - (done nil) - (result '())) - (if testnot - (while (not (or done (endp ptr))) - (cond ((not (funcall testnot item (funcall key (car ptr)))) - (setq done t) - (setq result ptr))) - (setq ptr (cdr ptr))) - (while (not (or done (endp ptr))) - (cond ((funcall test item (funcall key (car ptr))) - (setq done t) - (setq result ptr))) - (setq ptr (cdr ptr)))) - result))))) - -;;;; MULTIPLE VALUES -;;;; This package approximates the behavior of the multiple-values -;;;; forms of Common Lisp. -;;;; -;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986 -;;;; (quiroz@cs.rochester.edu) - -;;; Lisp indentation information -(put 'multiple-value-bind 'lisp-indent-hook 2) -(put 'multiple-value-setq 'lisp-indent-hook 2) -(put 'multiple-value-list 'lisp-indent-hook nil) -(put 'multiple-value-call 'lisp-indent-hook 1) -(put 'multiple-value-prog1 'lisp-indent-hook 1) - -;;; Global state of the package is kept here -(defvar *mvalues-values* nil - "Most recently returned multiple-values") -(defvar *mvalues-count* nil - "Count of multiple-values returned, or nil if the mechanism was not used") - -;;; values is the standard multiple-value-return form. Must be the -;;; last thing evaluated inside a function. If the caller is not -;;; expecting multiple values, only the first one is passed. (values) -;;; is the same as no-values returned (unaware callers see nil). The -;;; alternative (values-list <list>) is just a convenient shorthand -;;; and complements multiple-value-list. - -(defun values (&rest val-forms) - "Produce multiple values (zero or more). Each arg is one value. -See also `multiple-value-bind', which is one way to examine the -multiple values produced by a form. If the containing form or caller -does not check specially to see multiple values, it will see only -the first value." - (setq *mvalues-values* val-forms) - (setq *mvalues-count* (length *mvalues-values*)) - (car *mvalues-values*)) - -(defun values-list (&optional val-forms) - "Produce multiple values (zero or more). Each element of LIST is one value. -This is equivalent to (apply 'values LIST)." - (cond ((nlistp val-forms) - (error "Argument to values-list must be a list, not `%s'" - (prin1-to-string val-forms)))) - (setq *mvalues-values* val-forms) - (setq *mvalues-count* (length *mvalues-values*)) - (car *mvalues-values*)) - -;;; Callers that want to see the multiple values use these macros. - -(defmacro multiple-value-list (form) - "Execute FORM and return a list of all the (multiple) values FORM produces. -See `values' and `multiple-value-bind'." - (list 'progn - (list 'setq '*mvalues-count* nil) - (list 'let (list (list 'it '(gensym))) - (list 'set 'it form) - (list 'if '*mvalues-count* - (list 'copy-sequence '*mvalues-values*) - (list 'progn - (list 'setq '*mvalues-count* 1) - (list 'setq '*mvalues-values* - (list 'list (list 'symbol-value 'it))) - (list 'copy-sequence '*mvalues-values*)))))) - -(defmacro multiple-value-call (function &rest args) - "Call FUNCTION on all the values produced by the remaining arguments. -(multiple-value-call '+ (values 1 2) (values 3 4)) is 10." - (let* ((result (gentemp)) - (arg (gentemp))) - (list 'apply (list 'function (eval function)) - (list 'let* (list (list result '())) - (list 'dolist (list arg (list 'quote args) result) - (list 'setq result - (list 'append - result - (list 'multiple-value-list - (list 'eval arg))))))))) - -(defmacro multiple-value-bind (vars form &rest body) - "Bind VARS to the (multiple) values produced by FORM, then do BODY. -VARS is a list of variables; each is bound to one of FORM's values. -If FORM doesn't make enough values, the extra variables are bound to nil. -(Ordinary forms produce only one value; to produce more, use `values'.) -Extra values are ignored. -BODY (zero or more forms) is executed with the variables bound, -then the bindings are unwound." - (let* ((vals (gentemp)) ;name for intermediate values - (clauses (mv-bind-clausify ;convert into clauses usable - vars vals))) ; in a let form - (list* 'let* - (cons (list vals (list 'multiple-value-list form)) - clauses) - body))) - -(defmacro multiple-value-setq (vars form) - "Set VARS to the (multiple) values produced by FORM. -VARS is a list of variables; each is set to one of FORM's values. -If FORM doesn't make enough values, the extra variables are set to nil. -(Ordinary forms produce only one value; to produce more, use `values'.) -Extra values are ignored." - (let* ((vals (gentemp)) ;name for intermediate values - (clauses (mv-bind-clausify ;convert into clauses usable - vars vals))) ; in a setq (after append). - (list 'let* - (list (list vals (list 'multiple-value-list form))) - (cons 'setq (apply (function append) clauses))))) - -(defmacro multiple-value-prog1 (form &rest body) - "Evaluate FORM, then BODY, then produce the same values FORM produced. -Thus, (multiple-value-prog1 (values 1 2) (foobar)) produces values 1 and 2. -This is like `prog1' except that `prog1' would produce only one value, -which would be the first of FORM's values." - (let* ((heldvalues (gentemp))) - (cons 'let* - (cons (list (list heldvalues (list 'multiple-value-list form))) - (append body (list (list 'values-list heldvalues))))))) - -;;; utility functions -;;; -;;; mv-bind-clausify makes the pairs needed to have the variables in -;;; the variable list correspond with the values returned by the form. -;;; vals is a fresh symbol that intervenes in all the bindings. - -(defun mv-bind-clausify (vars vals) - "MV-BIND-CLAUSIFY VARS VALS => Auxiliary list -Forms a list of pairs `(,(nth i vars) (nth i vals)) for i from 0 to -the length of VARS (a list of symbols). VALS is just a fresh symbol." - (if (or (nlistp vars) - (notevery 'symbolp vars)) - (error "expected a list of symbols, not `%s'" - (prin1-to-string vars))) - (let* ((nvars (length vars)) - (clauses '())) - (dotimes (n nvars clauses) - (setq clauses (cons (list (nth n vars) - (list 'nth n vals)) clauses))))) - -;;;; end of cl-multiple-values.el - -;;;; ARITH -;;;; This file provides integer arithmetic extensions. Although -;;;; Emacs Lisp doesn't really support anything but integers, that -;;;; has still to be made to look more or less standard. -;;;; -;;;; -;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986 -;;;; (quiroz@cs.rochester.edu) - - -(defsubst plusp (number) - "True if NUMBER is strictly greater than zero." - (> number 0)) - -(defsubst minusp (number) - "True if NUMBER is strictly less than zero." - (< number 0)) - -(defsubst oddp (number) - "True if INTEGER is not divisible by 2." - (/= (% number 2) 0)) - -(defsubst evenp (number) - "True if INTEGER is divisible by 2." - (= (% number 2) 0)) - -(defsubst abs (number) - "Return the absolute value of NUMBER." - (if (< number 0) - (- number) - number)) - -(defsubst signum (number) - "Return -1, 0 or 1 according to the sign of NUMBER." - (cond ((< number 0) - -1) - ((> number 0) - 1) - (t ;exactly zero - 0))) - -(defun gcd (&rest integers) - "Return the greatest common divisor of all the arguments. -The arguments must be integers. With no arguments, value is zero." - (let ((howmany (length integers))) - (cond ((= howmany 0) - 0) - ((= howmany 1) - (abs (car integers))) - ((> howmany 2) - (apply (function gcd) - (cons (gcd (nth 0 integers) (nth 1 integers)) - (nthcdr 2 integers)))) - (t ;howmany=2 - ;; essentially the euclidean algorithm - (when (zerop (* (nth 0 integers) (nth 1 integers))) - (error "a zero argument is invalid for `gcd'")) - (do* ((absa (abs (nth 0 integers))) ; better to operate only - (absb (abs (nth 1 integers))) ;on positives. - (dd (max absa absb)) ; setup correct order for the - (ds (min absa absb)) ;successive divisions. - ;; intermediate results - (q 0) - (r 0) - ;; final results - (done nil) ; flag: end of iterations - (result 0)) ; final value - (done result) - (setq q (/ dd ds)) - (setq r (% dd ds)) - (cond ((zerop r) (setq done t) (setq result ds)) - (t (setq dd ds) (setq ds r)))))))) - -(defun lcm (integer &rest more) - "Return the least common multiple of all the arguments. -The arguments must be integers and there must be at least one of them." - (let ((howmany (length more)) - (a integer) - (b (nth 0 more)) - prod ; intermediate product - (yetmore (nthcdr 1 more))) - (cond ((zerop howmany) - (abs a)) - ((> howmany 1) ; recursive case - (apply (function lcm) - (cons (lcm a b) yetmore))) - (t ; base case, just 2 args - (setq prod (* a b)) - (cond - ((zerop prod) - 0) - (t - (/ (abs prod) (gcd a b)))))))) - -(defun isqrt (number) - "Return the integer square root of NUMBER. -NUMBER must not be negative. Result is largest integer less than or -equal to the real square root of the argument." - ;; The method used here is essentially the Newtonian iteration - ;; x[n+1] <- (x[n] + Number/x[n]) / 2 - ;; suitably adapted to integer arithmetic. - ;; Thanks to Philippe Schnoebelen <phs@lifia.imag.fr> for suggesting the - ;; termination condition. - (cond ((minusp number) - (error "argument to `isqrt' (%d) must not be negative" - number)) - ((zerop number) - 0) - (t ;so (>= number 0) - (do* ((approx 1) ;any positive integer will do - (new 0) ;init value irrelevant - (done nil)) - (done (if (> (* approx approx) number) - (- approx 1) - approx)) - (setq new (/ (+ approx (/ number approx)) 2) - done (or (= new approx) (= new (+ approx 1))) - approx new))))) - -(defun cl-floor (number &optional divisor) - "Divide DIVIDEND by DIVISOR, rounding toward minus infinity. -DIVISOR defaults to 1. The remainder is produced as a second value." - (cond ((and (null divisor) ; trivial case - (numberp number)) - (values number 0)) - (t ; do the division - (multiple-value-bind - (q r s) - (safe-idiv number divisor) - (cond ((zerop s) - (values 0 0)) - ((plusp s) - (values q r)) - (t ;opposite-signs case - (if (zerop r) - (values (- q) 0) - (let ((q (- (+ q 1)))) - (values q (- number (* q divisor))))))))))) - -(defun cl-ceiling (number &optional divisor) - "Divide DIVIDEND by DIVISOR, rounding toward plus infinity. -DIVISOR defaults to 1. The remainder is produced as a second value." - (cond ((and (null divisor) ; trivial case - (numberp number)) - (values number 0)) - (t ; do the division - (multiple-value-bind - (q r s) - (safe-idiv number divisor) - (cond ((zerop s) - (values 0 0)) - ((plusp s) - (values (+ q 1) (- r divisor))) - (t - (values (- q) (+ number (* q divisor))))))))) - -(defun cl-truncate (number &optional divisor) - "Divide DIVIDEND by DIVISOR, rounding toward zero. -DIVISOR defaults to 1. The remainder is produced as a second value." - (cond ((and (null divisor) ; trivial case - (numberp number)) - (values number 0)) - (t ; do the division - (multiple-value-bind - (q r s) - (safe-idiv number divisor) - (cond ((zerop s) - (values 0 0)) - ((plusp s) ;same as floor - (values q r)) - (t ;same as ceiling - (values (- q) (+ number (* q divisor))))))))) - -(defun cl-round (number &optional divisor) - "Divide DIVIDEND by DIVISOR, rounding to nearest integer. -DIVISOR defaults to 1. The remainder is produced as a second value." - (cond ((and (null divisor) ; trivial case - (numberp number)) - (values number 0)) - (t ; do the division - (multiple-value-bind - (q r s) - (safe-idiv number divisor) - (setq r (abs r)) - ;; adjust magnitudes first, and then signs - (let ((other-r (- (abs divisor) r))) - (cond ((> r other-r) - (setq q (+ q 1))) - ((and (= r other-r) - (oddp q)) - ;; round to even is mandatory - (setq q (+ q 1)))) - (setq q (* s q)) - (setq r (- number (* q divisor))) - (values q r)))))) - -;;; These two functions access the implementation-dependent representation of -;;; the multiple value returns. - -(defun cl-mod (number divisor) - "Return remainder of X by Y (rounding quotient toward minus infinity). -That is, the remainder goes with the quotient produced by `cl-floor'. -Emacs Lisp hint: -If you know that both arguments are positive, use `%' instead for speed." - (cl-floor number divisor) - (cadr *mvalues-values*)) - -(defun rem (number divisor) - "Return remainder of X by Y (rounding quotient toward zero). -That is, the remainder goes with the quotient produced by `cl-truncate'. -Emacs Lisp hint: -If you know that both arguments are positive, use `%' instead for speed." - (cl-truncate number divisor) - (cadr *mvalues-values*)) - -;;; internal utilities -;;; -;;; safe-idiv performs an integer division with positive numbers only. -;;; It is known that some machines/compilers implement weird remainder -;;; computations when working with negatives, so the idea here is to -;;; make sure we know what is coming back to the caller in all cases. - -;;; Signum computation fixed by mad@math.keio.JUNET (MAEDA Atusi) - -(defun safe-idiv (a b) - "SAFE-IDIV A B => Q R S -Q=|A|/|B|, S is the sign of A/B, R is the rest A - S*Q*B." - ;; (unless (and (numberp a) (numberp b)) - ;; (error "arguments to `safe-idiv' must be numbers")) - ;; (when (zerop b) - ;; (error "cannot divide %d by zero" a)) - (let* ((q (/ (abs a) (abs b))) - (s (* (signum a) (signum b))) - (r (- a (* s q b)))) - (values q r s))) - -;;;; end of cl-arith.el - -;;;; SETF -;;;; This file provides the setf macro and friends. The purpose has -;;;; been modest, only the simplest defsetf forms are accepted. -;;;; Use it and enjoy. -;;;; -;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986 -;;;; (quiroz@cs.rochester.edu) - - -(defkeyword :setf-update-fn - "Property, its value is the function setf must invoke to update a -generalized variable whose access form is a function call of the -symbol that has this property.") - -(defkeyword :setf-update-doc - "Property of symbols that have a `defsetf' update function on them, -installed by the `defsetf' from its optional third argument.") - -(defmacro setf (&rest pairs) - "Generalized `setq' that can set things other than variable values. -A use of `setf' looks like (setf {PLACE VALUE}...). -The behavior of (setf PLACE VALUE) is to access the generalized variable -at PLACE and store VALUE there. It returns VALUE. If there is more -than one PLACE and VALUE, each PLACE is set from its VALUE before -the next PLACE is evaluated." - (let ((nforms (length pairs))) - ;; check the number of subforms - (cond ((/= (% nforms 2) 0) - (error "odd number of arguments to `setf'")) - ((= nforms 0) - nil) - ((> nforms 2) - ;; this is the recursive case - (cons 'progn - (do* ;collect the place-value pairs - ((args pairs (cddr args)) - (place (car args) (car args)) - (value (cadr args) (cadr args)) - (result '())) - ((endp args) (nreverse result)) - (setq result - (cons (list 'setf place value) - result))))) - (t ;i.e., nforms=2 - ;; this is the base case (SETF PLACE VALUE) - (let* ((place (car pairs)) - (value (cadr pairs)) - (head nil) - (updatefn nil)) - ;; dispatch on the type of the PLACE - (cond ((symbolp place) - (list 'setq place value)) - ((and (listp place) - (setq head (car place)) - (symbolp head) - (setq updatefn (get head :setf-update-fn))) - ;; dispatch on the type of update function - (cond ((and (consp updatefn) (eq (car updatefn) 'lambda)) - (cons 'funcall - (cons (list 'function updatefn) - (append (cdr place) (list value))))) - ((and (symbolp updatefn) - (fboundp updatefn) - (let ((defn (symbol-function updatefn))) - (or (subrp defn) - (and (consp defn) - (or (eq (car defn) 'lambda) - (eq (car defn) 'macro)))))) - (cons updatefn (append (cdr place) (list value)))) - (t - (multiple-value-bind - (bindings newsyms) - (pair-with-newsyms - (append (cdr place) (list value))) - ;; this let gets new symbols to ensure adequate - ;; order of evaluation of the subforms. - (list 'let - bindings - (cons updatefn newsyms)))))) - (t - (error "no `setf' update-function for `%s'" - (prin1-to-string place))))))))) - -(defmacro defsetf (accessfn updatefn &optional docstring) - "Define how `setf' works on a certain kind of generalized variable. -A use of `defsetf' looks like (defsetf ACCESSFN UPDATEFN [DOCSTRING]). -ACCESSFN is a symbol. UPDATEFN is a function or macro which takes -one more argument than ACCESSFN does. DEFSETF defines the translation -of (SETF (ACCESFN . ARGS) NEWVAL) to be a form like (UPDATEFN ARGS... NEWVAL). -The function UPDATEFN must return its last arg, after performing the -updating called for." - ;; reject ill-formed requests. too bad one can't test for functionp - ;; or macrop. - (when (not (symbolp accessfn)) - (error "first argument of `defsetf' must be a symbol, not `%s'" - (prin1-to-string accessfn))) - ;; update properties - (list 'progn - (list 'eval-and-compile - (list 'put (list 'quote accessfn) - :setf-update-fn (list 'function updatefn))) - (list 'put (list 'quote accessfn) :setf-update-doc docstring) - ;; any better thing to return? - (list 'quote accessfn))) - -;;; This section provides the "default" setfs for Common-Emacs-Lisp -;;; The user will not normally add anything to this, although -;;; defstruct will introduce new ones as a matter of fact. -;;; -;;; Apply is a special case. The Common Lisp -;;; standard makes the case of apply be useful when the user writes -;;; something like (apply #'name ...), Emacs Lisp doesn't have the # -;;; stuff, but it has (function ...). Notice that V18 includes a new -;;; apply: this file is compatible with V18 and pre-V18 Emacses. - -;;; INCOMPATIBILITY: the SETF macro evaluates its arguments in the -;;; (correct) left to right sequence *before* checking for apply -;;; methods (which should really be an special case inside setf). Due -;;; to this, the lambda expression defsetf'd to apply will succeed in -;;; applying the right function even if the name was not quoted, but -;;; computed! That extension is not Common Lisp (nor is particularly -;;; useful, I think). - -(defsetf apply - (lambda (&rest args) - ;; disassemble the calling form - ;; "(((quote fn) x1 x2 ... xn) val)" (function instead of quote, too) - (let* ((fnform (car args)) ;functional form - (applyargs (append ;arguments "to apply fnform" - (apply 'list* (butlast (cdr args))) - (last args))) - (newupdater nil)) ; its update-fn, if any - (if (and (symbolp fnform) - (setq newupdater (get fnform :setf-update-fn))) - (apply newupdater applyargs) - (error "can't `setf' to `%s'" - (prin1-to-string fnform))))) - "`apply' is a special case for `setf'") - - -(defsetf aref - aset - "`setf' inversion for `aref'") - -(defsetf nth - setnth - "`setf' inversion for `nth'") - -(defsetf nthcdr - setnthcdr - "`setf' inversion for `nthcdr'") - -(defsetf elt - setelt - "`setf' inversion for `elt'") - -(defsetf first - (lambda (list val) (setnth 0 list val)) - "`setf' inversion for `first'") - -(defsetf second - (lambda (list val) (setnth 1 list val)) - "`setf' inversion for `second'") - -(defsetf third - (lambda (list val) (setnth 2 list val)) - "`setf' inversion for `third'") - -(defsetf fourth - (lambda (list val) (setnth 3 list val)) - "`setf' inversion for `fourth'") - -(defsetf fifth - (lambda (list val) (setnth 4 list val)) - "`setf' inversion for `fifth'") - -(defsetf sixth - (lambda (list val) (setnth 5 list val)) - "`setf' inversion for `sixth'") - -(defsetf seventh - (lambda (list val) (setnth 6 list val)) - "`setf' inversion for `seventh'") - -(defsetf eighth - (lambda (list val) (setnth 7 list val)) - "`setf' inversion for `eighth'") - -(defsetf ninth - (lambda (list val) (setnth 8 list val)) - "`setf' inversion for `ninth'") - -(defsetf tenth - (lambda (list val) (setnth 9 list val)) - "`setf' inversion for `tenth'") - -(defsetf rest - (lambda (list val) (setcdr list val)) - "`setf' inversion for `rest'") - -(defsetf car setcar "Replace the car of a cons") - -(defsetf cdr setcdr "Replace the cdr of a cons") - -(defsetf caar - (lambda (list val) (setcar (nth 0 list) val)) - "`setf' inversion for `caar'") - -(defsetf cadr - (lambda (list val) (setcar (cdr list) val)) - "`setf' inversion for `cadr'") - -(defsetf cdar - (lambda (list val) (setcdr (car list) val)) - "`setf' inversion for `cdar'") - -(defsetf cddr - (lambda (list val) (setcdr (cdr list) val)) - "`setf' inversion for `cddr'") - -(defsetf caaar - (lambda (list val) (setcar (caar list) val)) - "`setf' inversion for `caaar'") - -(defsetf caadr - (lambda (list val) (setcar (cadr list) val)) - "`setf' inversion for `caadr'") - -(defsetf cadar - (lambda (list val) (setcar (cdar list) val)) - "`setf' inversion for `cadar'") - -(defsetf cdaar - (lambda (list val) (setcdr (caar list) val)) - "`setf' inversion for `cdaar'") - -(defsetf caddr - (lambda (list val) (setcar (cddr list) val)) - "`setf' inversion for `caddr'") - -(defsetf cdadr - (lambda (list val) (setcdr (cadr list) val)) - "`setf' inversion for `cdadr'") - -(defsetf cddar - (lambda (list val) (setcdr (cdar list) val)) - "`setf' inversion for `cddar'") - -(defsetf cdddr - (lambda (list val) (setcdr (cddr list) val)) - "`setf' inversion for `cdddr'") - -(defsetf caaaar - (lambda (list val) (setcar (caaar list) val)) - "`setf' inversion for `caaaar'") - -(defsetf caaadr - (lambda (list val) (setcar (caadr list) val)) - "`setf' inversion for `caaadr'") - -(defsetf caadar - (lambda (list val) (setcar (cadar list) val)) - "`setf' inversion for `caadar'") - -(defsetf cadaar - (lambda (list val) (setcar (cdaar list) val)) - "`setf' inversion for `cadaar'") - -(defsetf cdaaar - (lambda (list val) (setcdr (caar list) val)) - "`setf' inversion for `cdaaar'") - -(defsetf caaddr - (lambda (list val) (setcar (caddr list) val)) - "`setf' inversion for `caaddr'") - -(defsetf cadadr - (lambda (list val) (setcar (cdadr list) val)) - "`setf' inversion for `cadadr'") - -(defsetf cdaadr - (lambda (list val) (setcdr (caadr list) val)) - "`setf' inversion for `cdaadr'") - -(defsetf caddar - (lambda (list val) (setcar (cddar list) val)) - "`setf' inversion for `caddar'") - -(defsetf cdadar - (lambda (list val) (setcdr (cadar list) val)) - "`setf' inversion for `cdadar'") - -(defsetf cddaar - (lambda (list val) (setcdr (cdaar list) val)) - "`setf' inversion for `cddaar'") - -(defsetf cadddr - (lambda (list val) (setcar (cdddr list) val)) - "`setf' inversion for `cadddr'") - -(defsetf cddadr - (lambda (list val) (setcdr (cdadr list) val)) - "`setf' inversion for `cddadr'") - -(defsetf cdaddr - (lambda (list val) (setcdr (caddr list) val)) - "`setf' inversion for `cdaddr'") - -(defsetf cdddar - (lambda (list val) (setcdr (cddar list) val)) - "`setf' inversion for `cdddar'") - -(defsetf cddddr - (lambda (list val) (setcdr (cddr list) val)) - "`setf' inversion for `cddddr'") - -(defsetf get put "`setf' inversion for `get' is `put'") - -(defsetf symbol-function fset - "`setf' inversion for `symbol-function' is `fset'") - -(defsetf symbol-plist setplist - "`setf' inversion for `symbol-plist' is `setplist'") - -(defsetf symbol-value set - "`setf' inversion for `symbol-value' is `set'") - -(defsetf point goto-char - "To set (point) to N, use (goto-char N)") - -;; how about defsetfing other Emacs forms? - -;;; Modify macros -;;; -;;; It could be nice to implement define-modify-macro, but I don't -;;; think it really pays. - -(defmacro incf (ref &optional delta) - "(incf REF [DELTA]) -> increment the g.v. REF by DELTA (default 1)" - (if (null delta) - (setq delta 1)) - (list 'setf ref (list '+ ref delta))) - -(defmacro decf (ref &optional delta) - "(decf REF [DELTA]) -> decrement the g.v. REF by DELTA (default 1)" - (if (null delta) - (setq delta 1)) - (list 'setf ref (list '- ref delta))) - -(defmacro push (item ref) - "(push ITEM REF) -> cons ITEM at the head of the g.v. REF (a list)" - (list 'setf ref (list 'cons item ref))) - -(defmacro pushnew (item ref) - "(pushnew ITEM REF): adjoin ITEM at the head of the g.v. REF (a list)" - (list 'setf ref (list 'adjoin item ref))) - -(defmacro pop (ref) - "(pop REF) -> (prog1 (car REF) (setf REF (cdr REF)))" - (let ((listname (gensym))) - (list 'let (list (list listname ref)) - (list 'prog1 - (list 'car listname) - (list 'setf ref (list 'cdr listname)))))) - -;;; PSETF -;;; -;;; Psetf is the generalized variable equivalent of psetq. The right -;;; hand sides are evaluated and assigned (via setf) to the left hand -;;; sides. The evaluations are done in an environment where they -;;; appear to occur in parallel. - -(defmacro psetf (&rest body) - "(psetf {var value }...) => nil -Like setf, but all the values are computed before any assignment is made." - (let ((length (length body))) - (cond ((/= (% length 2) 0) - (error "psetf needs an even number of arguments, %d given" - length)) - ((null body) - '()) - (t - (list 'prog1 nil - (let ((setfs '()) - (bodyforms (reverse body))) - (while bodyforms - (let* ((value (car bodyforms)) - (place (cadr bodyforms))) - (setq bodyforms (cddr bodyforms)) - (if (null setfs) - (setq setfs (list 'setf place value)) - (setq setfs (list 'setf place - (list 'prog1 value - setfs)))))) - setfs)))))) - -;;; SHIFTF and ROTATEF -;;; - -(defmacro shiftf (&rest forms) - "(shiftf PLACE1 PLACE2... NEWVALUE) -Set PLACE1 to PLACE2, PLACE2 to PLACE3... -Each PLACE is set to the old value of the following PLACE, -and the last PLACE is set to the value NEWVALUE. -Returns the old value of PLACE1." - (unless (> (length forms) 1) - (error "`shiftf' needs more than one argument")) - (let ((places (butlast forms)) - (newvalue (car (last forms)))) - ;; the places are accessed to fresh symbols - (multiple-value-bind - (bindings newsyms) - (pair-with-newsyms places) - (list 'let bindings - (cons 'setf - (zip-lists places - (append (cdr newsyms) (list newvalue)))) - (car newsyms))))) - -(defmacro rotatef (&rest places) - "(rotatef PLACE...) sets each PLACE to the old value of the following PLACE. -The last PLACE is set to the old value of the first PLACE. -Thus, the values rotate through the PLACEs. Returns nil." - (if (null places) - nil - (multiple-value-bind - (bindings newsyms) - (pair-with-newsyms places) - (list - 'let bindings - (cons 'setf - (zip-lists places - (append (cdr newsyms) (list (car newsyms))))) - nil)))) - -;;; GETF, REMF, and REMPROP -;;; - -(defun getf (place indicator &optional default) - "Return PLACE's PROPNAME property, or DEFAULT if not present." - (while (and place (not (eq (car place) indicator))) - (setq place (cdr (cdr place)))) - (if place - (car (cdr place)) - default)) - -(defmacro getf$setf$method (place indicator default &rest newval) - "SETF method for GETF. Not for public use." - (case (length newval) - (0 (setq newval default default nil)) - (1 (setq newval (car newval))) - (t (error "Wrong number of arguments to (setf (getf ...)) form"))) - (let ((psym (gentemp)) (isym (gentemp)) (vsym (gentemp))) - (list 'let (list (list psym place) - (list isym indicator) - (list vsym newval)) - (list 'while - (list 'and psym - (list 'not - (list 'eq (list 'car psym) isym))) - (list 'setq psym (list 'cdr (list 'cdr psym)))) - (list 'if psym - (list 'setcar (list 'cdr psym) vsym) - (list 'setf place - (list 'nconc place (list 'list isym newval)))) - vsym))) - -(defsetf getf - getf$setf$method) - -(defmacro remf (place indicator) - "Remove from the property list at PLACE its PROPNAME property. -Returns non-nil if and only if the property existed." - (let ((psym (gentemp)) (isym (gentemp))) - (list 'let (list (list psym place) (list isym indicator)) - (list 'cond - (list (list 'eq isym (list 'car psym)) - (list 'setf place (list 'cdr (list 'cdr psym))) - t) - (list t - (list 'setq psym (list 'cdr psym)) - (list 'while - (list 'and (list 'cdr psym) - (list 'not - (list 'eq (list 'car (list 'cdr psym)) - isym))) - (list 'setq psym (list 'cdr (list 'cdr psym)))) - (list 'cond - (list (list 'cdr psym) - (list 'setcdr psym - (list 'cdr - (list 'cdr (list 'cdr psym)))) - t))))))) - -(defun remprop (symbol indicator) - "Remove SYMBOL's PROPNAME property, returning non-nil if it was present." - (remf (symbol-plist symbol) indicator)) - - -;;;; STRUCTS -;;;; This file provides the structures mechanism. See the -;;;; documentation for Common-Lisp's defstruct. Mine doesn't -;;;; implement all the functionality of the standard, although some -;;;; more could be grafted if so desired. More details along with -;;;; the code. -;;;; -;;;; -;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986 -;;;; (quiroz@cs.rochester.edu) - - -(defkeyword :include "Syntax of `defstruct'") -(defkeyword :named "Syntax of `defstruct'") -(defkeyword :conc-name "Syntax of `defstruct'") -(defkeyword :copier "Syntax of `defstruct'") -(defkeyword :predicate "Syntax of `defstruct'") -(defkeyword :print-function "Syntax of `defstruct'") -(defkeyword :type "Syntax of `defstruct'") -(defkeyword :initial-offset "Syntax of `defstruct'") - -(defkeyword :structure-doc "Documentation string for a structure.") -(defkeyword :structure-slotsn "Number of slots in structure") -(defkeyword :structure-slots "List of the slot's names") -(defkeyword :structure-indices "List of (KEYWORD-NAME . INDEX)") -(defkeyword :structure-initforms "List of (KEYWORD-NAME . INITFORM)") -(defkeyword :structure-includes - "() or list of a symbol, that this struct includes") -(defkeyword :structure-included-in - "List of the structs that include this") - - -(defmacro defstruct (&rest args) - "(defstruct NAME [DOC-STRING] . SLOTS) define NAME as structure type. -NAME must be a symbol, the name of the new structure. It could also -be a list (NAME . OPTIONS). - -Each option is either a symbol, or a list of a keyword symbol taken from the -list \{:conc-name, :copier, :constructor, :predicate, :include, -:print-function, :type, :initial-offset\}. The meanings of these are as in -CLtL, except that no BOA-constructors are provided, and the options -\{:print-function, :type, :initial-offset\} are ignored quietly. All these -structs are named, in the sense that their names can be used for type -discrimination. - -The DOC-STRING is established as the `structure-doc' property of NAME. - -The SLOTS are one or more of the following: -SYMBOL -- meaning the SYMBOL is the name of a SLOT of NAME -list of SYMBOL and VALUE -- meaning that VALUE is the initial value of -the slot. -`defstruct' defines functions `make-NAME', `NAME-p', `copy-NAME' for the -structure, and functions with the same name as the slots to access -them. `setf' of the accessors sets their values." - (multiple-value-bind - (name options docstring slotsn slots initlist) - (parse$defstruct$args args) - ;; Names for the member functions come from the options. The - ;; slots* stuff collects info about the slots declared explicitly. - (multiple-value-bind - (conc-name constructor copier predicate - moreslotsn moreslots moreinits included) - (parse$defstruct$options name options slots) - ;; The moreslots* stuff refers to slots gained as a consequence - ;; of (:include clauses). -- Oct 89: Only one :include tolerated - (when (and (numberp moreslotsn) - (> moreslotsn 0)) - (setf slotsn (+ slotsn moreslotsn)) - (setf slots (append moreslots slots)) - (setf initlist (append moreinits initlist))) - (unless (> slotsn 0) - (error "%s needs at least one slot" - (prin1-to-string name))) - (let ((dups (duplicate-symbols-p slots))) - (when dups - (error "`%s' are duplicates" - (prin1-to-string dups)))) - (setq initlist (simplify$inits slots initlist)) - (let (properties functions keywords accessors alterators returned) - ;; compute properties of NAME - (setq properties - (append - (list - (list 'put (list 'quote name) :structure-doc - docstring) - (list 'put (list 'quote name) :structure-slotsn - slotsn) - (list 'put (list 'quote name) :structure-slots - (list 'quote slots)) - (list 'put (list 'quote name) :structure-initforms - (list 'quote initlist)) - (list 'put (list 'quote name) :structure-indices - (list 'quote (extract$indices initlist)))) - ;; If this definition :includes another defstruct, - ;; modify both property lists. - (cond (included - (list - (list 'put - (list 'quote name) - :structure-includes - (list 'quote included)) - (list 'pushnew - (list 'quote name) - (list 'get (list 'quote (car included)) - :structure-included-in)))) - (t - (list - (let ((old (gensym))) - (list 'let - (list (list old - (list 'car - (list 'get - (list 'quote name) - :structure-includes)))) - (list 'when old - (list 'put - old - :structure-included-in - (list 'delq - (list 'quote name) - ;; careful with destructive - ;;manipulation! - (list - 'append - (list - 'get - old - :structure-included-in) - '()) - ))))) - (list 'put - (list 'quote name) - :structure-includes - '())))) - ;; If this definition used to be :included in another, warn - ;; that things make break. On the other hand, the redefinition - ;; may be trivial, so don't call it an error. - (let ((old (gensym))) - (list - (list 'let - (list (list old (list 'get - (list 'quote name) - :structure-included-in))) - (list 'when old - (list 'message - "`%s' redefined. Should redefine `%s'?" - (list 'quote name) - (list 'prin1-to-string old)))))))) - - ;; Compute functions associated with NAME. This is not - ;; handling BOA constructors yet, but here would be the place. - (setq functions - (list - (list 'fset (list 'quote constructor) - (list 'function - (list 'lambda (list '&rest 'args) - (list 'make$structure$instance - (list 'quote name) - 'args)))) - (list 'fset (list 'quote copier) - (list 'function 'copy-sequence)) - (let ((typetag (gensym))) - (list 'fset (list 'quote predicate) - (list - 'function - (list - 'lambda (list 'thing) - (list 'and - (list 'vectorp 'thing) - (list 'let - (list (list typetag - (list 'elt 'thing 0))) - (list 'or - (list - 'and - (list 'eq - typetag - (list 'quote name)) - (list '= - (list 'length 'thing) - (1+ slotsn))) - (list - 'memq - typetag - (list 'get - (list 'quote name) - :structure-included-in)))))) - ))))) - ;; compute accessors for NAME's slots - (multiple-value-setq - (accessors alterators keywords) - (build$accessors$for name conc-name predicate slots slotsn)) - ;; generate returned value -- not defined by the standard - (setq returned - (list - (cons 'vector - (mapcar - (function (lambda (x) (list 'quote x))) - (cons name slots))))) - ;; generate code - (cons 'progn - (nconc properties functions keywords - accessors alterators returned)))))) - -(defun parse$defstruct$args (args) - "(parse$defstruct$args ARGS) => NAME OPTIONS DOCSTRING SLOTSN SLOTS INITLIST -NAME=symbol, OPTIONS=list of, DOCSTRING=string, SLOTSN=count of slots, -SLOTS=list of their names, INITLIST=alist (keyword . initform)." - (let (name ;args=(symbol...) or ((symbol...)...) - options ;args=((symbol . options) ...) - (docstring "") ;args=(head docstring . slotargs) - slotargs ;second or third cdr of args - (slotsn 0) ;number of slots - (slots '()) ;list of slot names - (initlist '())) ;list of (slot keyword . initform) - ;; extract name and options - (cond ((symbolp (car args)) ;simple name - (setq name (car args) - options '())) - ((and (listp (car args)) ;(name . options) - (symbolp (caar args))) - (setq name (caar args) - options (cdar args))) - (t - (error "first arg to `defstruct' must be symbol or (symbol ...)"))) - (setq slotargs (cdr args)) - ;; is there a docstring? - (when (stringp (car slotargs)) - (setq docstring (car slotargs) - slotargs (cdr slotargs))) - ;; now for the slots - (multiple-value-bind - (slotsn slots initlist) - (process$slots slotargs) - (values name options docstring slotsn slots initlist)))) - -(defun process$slots (slots) - "(process$slots SLOTS) => SLOTSN SLOTSLIST INITLIST -Converts a list of symbols or lists of symbol and form into the last 3 -values returned by PARSE$DEFSTRUCT$ARGS." - (let ((slotsn (length slots)) ;number of slots - slotslist ;(slot1 slot2 ...) - initlist) ;((:slot1 . init1) ...) - (do* - ((ptr slots (cdr ptr)) - (this (car ptr) (car ptr))) - ((endp ptr)) - (cond ((symbolp this) - (setq slotslist (cons this slotslist)) - (setq initlist (acons (keyword-of this) nil initlist))) - ((and (listp this) - (symbolp (car this))) - (let ((name (car this)) - (form (cadr this))) - ;; this silently ignores any slot options. bad... - (setq slotslist (cons name slotslist)) - (setq initlist (acons (keyword-of name) form initlist)))) - (t - (error "slot should be symbol or (symbol ...), not `%s'" - (prin1-to-string this))))) - (values slotsn (nreverse slotslist) (nreverse initlist)))) - -(defun parse$defstruct$options (name options slots) - "(parse$defstruct$options name OPTIONS SLOTS) => many values -A defstruct named NAME, with options list OPTIONS, has already slots SLOTS. -Parse the OPTIONS and return the updated form of the struct's slots and other -information. The values returned are: - - CONC-NAME is the string to use as prefix/suffix in the methods, - CONST is the name of the official constructor, - COPIER is the name of the structure copier, - PRED is the name of the type predicate, - MORESLOTSN is the number of slots added by :include, - MORESLOTS is the list of slots added by :include, - MOREINITS is the list of initialization forms added by :include, - INCLUDED is nil, or the list of the symbol added by :include" - (let* ((namestring (symbol-name name)) - ;; to build the return values - (conc-name (concat namestring "-")) - (const (intern (concat "make-" namestring))) - (copier (intern (concat "copy-" namestring))) - (pred (intern (concat namestring "-p"))) - (moreslotsn 0) - (moreslots '()) - (moreinits '()) - ;; auxiliaries - option-head ;When an option is not a plain - option-second ; keyword, it must be a list of - option-rest ; the form (head second . rest) - these-slotsn ;When :include is found, the - these-slots ; info about the included - these-inits ; structure is added here. - included ;NIL or (list INCLUDED) - ) - ;; Values above are the defaults. Now we read the options themselves - (dolist (option options) - ;; 2 cases arise, as options must be a keyword or a list - (cond - ((keywordp option) - (case option - (:named - ) ;ignore silently - (t - (error "can't recognize option `%s'" - (prin1-to-string option))))) - ((and (listp option) - (keywordp (setq option-head (car option)))) - (setq option-second (second option)) - (setq option-rest (nthcdr 2 option)) - (case option-head - (:conc-name - (setq conc-name - (cond - ((stringp option-second) - option-second) - ((null option-second) - "") - (t - (error "`%s' is invalid as `conc-name'" - (prin1-to-string option-second)))))) - (:copier - (setq copier - (cond - ((and (symbolp option-second) - (null option-rest)) - option-second) - (t - (error "can't recognize option `%s'" - (prin1-to-string option)))))) - - (:constructor ;no BOA-constructors allowed - (setq const - (cond - ((and (symbolp option-second) - (null option-rest)) - option-second) - (t - (error "can't recognize option `%s'" - (prin1-to-string option)))))) - (:predicate - (setq pred - (cond - ((and (symbolp option-second) - (null option-rest)) - option-second) - (t - (error "can't recognize option `%s'" - (prin1-to-string option)))))) - (:include - (unless (symbolp option-second) - (error "arg to `:include' should be a symbol, not `%s'" - (prin1-to-string option-second))) - (setq these-slotsn (get option-second :structure-slotsn) - these-slots (get option-second :structure-slots) - these-inits (get option-second :structure-initforms)) - (unless (and (numberp these-slotsn) - (> these-slotsn 0)) - (error "`%s' is not a valid structure" - (prin1-to-string option-second))) - (if included - (error "`%s' already includes `%s', can't include `%s' too" - name (car included) option-second) - (push option-second included)) - (multiple-value-bind - (xtra-slotsn xtra-slots xtra-inits) - (process$slots option-rest) - (when (> xtra-slotsn 0) - (dolist (xslot xtra-slots) - (unless (memq xslot these-slots) - (error "`%s' is not a slot of `%s'" - (prin1-to-string xslot) - (prin1-to-string option-second)))) - (setq these-inits (append xtra-inits these-inits))) - (setq moreslotsn (+ moreslotsn these-slotsn)) - (setq moreslots (append these-slots moreslots)) - (setq moreinits (append these-inits moreinits)))) - ((:print-function :type :initial-offset) - ) ;ignore silently - (t - (error "can't recognize option `%s'" - (prin1-to-string option))))) - (t - (error "can't recognize option `%s'" - (prin1-to-string option))))) - ;; Return values found - (values conc-name const copier pred - moreslotsn moreslots moreinits - included))) - -(defun simplify$inits (slots initlist) - "(simplify$inits SLOTS INITLIST) => new INITLIST -Removes from INITLIST - an ALIST - any shadowed bindings." - (let ((result '()) ;built here - key ;from the slot - ) - (dolist (slot slots) - (setq key (keyword-of slot)) - (setq result (acons key (cdr (assoc key initlist)) result))) - (nreverse result))) - -(defun extract$indices (initlist) - "(extract$indices INITLIST) => indices list -Kludge. From a list of pairs (keyword . form) build a list of pairs -of the form (keyword . position in list from 0). Useful to precompute -some of the work of MAKE$STRUCTURE$INSTANCE." - (let ((result '()) - (index 0)) - (dolist (entry initlist (nreverse result)) - (setq result (acons (car entry) index result) - index (+ index 1))))) - -(defun build$accessors$for (name conc-name predicate slots slotsn) - "(build$accessors$for NAME PREDICATE SLOTS SLOTSN) => FSETS DEFSETFS KWDS -Generate the code for accesors and defsetfs of a structure called -NAME, whose slots are SLOTS. Also, establishes the keywords for the -slots names." - (do ((i 0 (1+ i)) - (accessors '()) - (alterators '()) - (keywords '()) - (canonic "")) ;slot name with conc-name prepended - ((>= i slotsn) - (values - (nreverse accessors) (nreverse alterators) (nreverse keywords))) - (setq canonic (intern (concat conc-name (symbol-name (nth i slots))))) - (setq accessors - (cons - (list 'fset (list 'quote canonic) - (list 'function - (list 'lambda (list 'object) - (list 'cond - (list (list predicate 'object) - (list 'aref 'object (1+ i))) - (list 't - (list 'error - "`%s' is not a struct %s" - (list 'prin1-to-string - 'object) - (list 'prin1-to-string - (list 'quote - name)))))))) - accessors)) - (setq alterators - (cons - (list 'defsetf canonic - (list 'lambda (list 'object 'newval) - (list 'cond - (list (list predicate 'object) - (list 'aset 'object (1+ i) 'newval)) - (list 't - (list 'error - "`%s' not a `%s'" - (list 'prin1-to-string - 'object) - (list 'prin1-to-string - (list 'quote - name))))))) - alterators)) - (setq keywords - (cons (list 'defkeyword (keyword-of (nth i slots))) - keywords)))) - -(defun make$structure$instance (name args) - "(make$structure$instance NAME ARGS) => new struct NAME -A struct of type NAME is created, some slots might be initialized -according to ARGS (the &rest argument of MAKE-name)." - (unless (symbolp name) - (error "`%s' is not a possible name for a structure" - (prin1-to-string name))) - (let ((initforms (get name :structure-initforms)) - (slotsn (get name :structure-slotsn)) - (indices (get name :structure-indices)) - initalist ;pairlis'd on initforms - initializers ;definitive initializers - ) - ;; check sanity of the request - (unless (and (numberp slotsn) - (> slotsn 0)) - (error "`%s' is not a defined structure" - (prin1-to-string name))) - (unless (evenp (length args)) - (error "slot initializers `%s' not of even length" - (prin1-to-string args))) - ;; analyze the initializers provided by the call - (multiple-value-bind - (speckwds specvals) ;keywords and values given - (unzip-list args) ; by the user - ;; check that all the arguments are introduced by keywords - (unless (every (function keywordp) speckwds) - (error "all of the names in `%s' should be keywords" - (prin1-to-string speckwds))) - ;; check that all the keywords are known - (dolist (kwd speckwds) - (unless (numberp (cdr (assoc kwd indices))) - (error "`%s' is not a valid slot name for %s" - (prin1-to-string kwd) (prin1-to-string name)))) - ;; update initforms - (setq initalist - (pairlis speckwds - (do* ;;protect values from further evaluation - ((ptr specvals (cdr ptr)) - (val (car ptr) (car ptr)) - (result '())) - ((endp ptr) (nreverse result)) - (setq result - (cons (list 'quote val) - result))) - (copy-sequence initforms))) - ;; compute definitive initializers - (setq initializers - (do* ;;gather the values of the most definitive forms - ((ptr indices (cdr ptr)) - (key (caar ptr) (caar ptr)) - (result '())) - ((endp ptr) (nreverse result)) - (setq result - (cons (eval (cdr (assoc key initalist))) result)))) - ;; do real initialization - (apply (function vector) - (cons name initializers))))) - -;;;; end of cl-structs.el - -;;; For lisp-interaction mode, so that multiple values can be seen when passed -;;; back. Lies every now and then... - -(defvar - nil "form currently under evaluation") -(defvar + nil "previous -") -(defvar ++ nil "previous +") -(defvar +++ nil "previous ++") -(defvar / nil "list of values returned by +") -(defvar // nil "list of values returned by ++") -(defvar /// nil "list of values returned by +++") -(defvar * nil "(first) value of +") -(defvar ** nil "(first) value of ++") -(defvar *** nil "(first) value of +++") - -(defun cl-eval-print-last-sexp () - "Evaluate sexp before point; print value\(s\) into current buffer. -If the evaled form returns multiple values, they are shown one to a line. -The variables -, +, ++, +++, *, **, ***, /, //, /// have their usual meaning. - -It clears the multiple-value passing mechanism, and does not pass back -multiple values. Use this only if you are debugging cl.el and understand well -how the multiple-value stuff works, because it can be fooled into believing -that multiple values have been returned when they actually haven't, for -instance - \(identity \(values nil 1\)\) -However, even when this fails, you can trust the first printed value to be -\(one of\) the returned value\(s\)." - (interactive) - ;; top level call, can reset mvalues - (setq *mvalues-count* nil - *mvalues-values* nil) - (setq - (car (read-from-string - (buffer-substring - (let ((stab (syntax-table))) - (unwind-protect - (save-excursion - (set-syntax-table emacs-lisp-mode-syntax-table) - (forward-sexp -1) - (point)) - (set-syntax-table stab))) - (point))))) - (setq *** ** - ** * - * (eval -)) - (setq /// // - // / - / *mvalues-values*) - (setq +++ ++ - ++ + - + -) - (cond ((or (null *mvalues-count*) ;mvalues mechanism not used - (not (eq * (car *mvalues-values*)))) - (print * (current-buffer))) - ((null /) ;no values returned - (terpri (current-buffer))) - (t ;more than zero mvalues - (terpri (current-buffer)) - (mapcar (function (lambda (value) - (prin1 value (current-buffer)) - (terpri (current-buffer)))) - /))) - (setq *mvalues-count* nil ;make sure - *mvalues-values* nil)) - -;;;; More LISTS functions -;;;; - -;;; Some mapping functions on lists, commonly useful. -;;; They take no extra sequences, to go along with Emacs Lisp's MAPCAR. - -(defun mapc (function list) - "(MAPC FUNCTION LIST) => LIST -Apply FUNCTION to each element of LIST, return LIST. -Like mapcar, but called only for effect." - (let ((args list)) - (while args - (funcall function (car args)) - (setq args (cdr args)))) - list) - -(defun maplist (function list) - "(MAPLIST FUNCTION LIST) => list'ed results of FUNCTION on cdrs of LIST -Apply FUNCTION to successive sublists of LIST, return the list of the results" - (let ((args list) - results '()) - (while args - (setq results (cons (funcall function args) results) - args (cdr args))) - (nreverse results))) - -(defun mapl (function list) - "(MAPL FUNCTION LIST) => LIST -Apply FUNCTION to successive cdrs of LIST, return LIST. -Like maplist, but called only for effect." - (let ((args list)) - (while args - (funcall function args) - (setq args (cdr args))) - list)) - -(defun mapcan (function list) - "(MAPCAN FUNCTION LIST) => nconc'd results of FUNCTION on LIST -Apply FUNCTION to each element of LIST, nconc the results. -Beware: nconc destroys its first argument! See copy-list." - (let ((args list) - (results '())) - (while args - (setq results (nconc (funcall function (car args)) results) - args (cdr args))) - (nreverse results))) - -(defun mapcon (function list) - "(MAPCON FUNCTION LIST) => nconc'd results of FUNCTION on cdrs of LIST -Apply FUNCTION to successive sublists of LIST, nconc the results. -Beware: nconc destroys its first argument! See copy-list." - (let ((args list) - (results '())) - (while args - (setq results (nconc (funcall function args) results) - args (cdr args))) - (nreverse results))) - -;;; Copiers - -(defsubst copy-list (list) - "Build a copy of LIST" - (append list '())) - -(defun copy-tree (tree) - "Build a copy of the tree of conses TREE -The argument is a tree of conses, it is recursively copied down to -non conses. Circularity and sharing of substructure are not -necessarily preserved." - (if (consp tree) - (cons (copy-tree (car tree)) - (copy-tree (cdr tree))) - tree)) - -;;; reversals, and destructive manipulations of a list's spine - -(defun revappend (x y) - "does what (append (reverse X) Y) would, only faster" - (if (endp x) - y - (revappend (cdr x) (cons (car x) y)))) - -(defun nreconc (x y) - "does (nconc (nreverse X) Y) would, only faster -Destructive on X, be careful." - (if (endp x) - y - ;; reuse the first cons of x, making it point to y - (nreconc (cdr x) (prog1 x (rplacd x y))))) - -(defun nbutlast (list &optional n) - "Side-effected LIST truncated N+1 conses from the end. -This is the destructive version of BUTLAST. Returns () and does not -modify the LIST argument if the length of the list is not at least N." - (when (null n) (setf n 1)) - (let ((length (list-length list))) - (cond ((null length) - list) - ((< length n) - '()) - (t - (setnthcdr (- length n) list nil) - list)))) - -;;; Substitutions - -(defun subst (new old tree) - "NEW replaces OLD in a copy of TREE -Uses eql for the test." - (subst-if new (function (lambda (x) (eql x old))) tree)) - -(defun subst-if-not (new test tree) - "NEW replaces any subtree or leaf that fails TEST in a copy of TREE" - ;; (subst-if new (function (lambda (x) (not (funcall test x)))) tree) - (cond ((not (funcall test tree)) - new) - ((atom tree) - tree) - (t ;no match so far - (let ((head (subst-if-not new test (car tree))) - (tail (subst-if-not new test (cdr tree)))) - ;; If nothing changed, return originals. Else use the new - ;; components to assemble a new tree. - (if (and (eql head (car tree)) - (eql tail (cdr tree))) - tree - (cons head tail)))))) - -(defun subst-if (new test tree) - "NEW replaces any subtree or leaf that satisfies TEST in a copy of TREE" - (cond ((funcall test tree) - new) - ((atom tree) - tree) - (t ;no match so far - (let ((head (subst-if new test (car tree))) - (tail (subst-if new test (cdr tree)))) - ;; If nothing changed, return originals. Else use the new - ;; components to assemble a new tree. - (if (and (eql head (car tree)) - (eql tail (cdr tree))) - tree - (cons head tail)))))) - -(defun sublis (alist tree) - "Use association list ALIST to modify a copy of TREE -If a subtree or leaf of TREE is a key in ALIST, it is replaced by the -associated value. Not exactly Common Lisp, but close in spirit and -compatible with the native Emacs Lisp ASSOC, which uses EQUAL." - (let ((toplevel (assoc tree alist))) - (cond (toplevel ;Bingo at top - (cdr toplevel)) - ((atom tree) ;Give up on this - tree) - (t - (let ((head (sublis alist (car tree))) - (tail (sublis alist (cdr tree)))) - (if (and (eql head (car tree)) - (eql tail (cdr tree))) - tree - (cons head tail))))))) - -(defun member-if (predicate list) - "PREDICATE is applied to the members of LIST. As soon as one of them -returns true, that tail of the list if returned. Else NIL." - (catch 'found-member-if - (while (not (endp list)) - (if (funcall predicate (car list)) - (throw 'found-member-if list) - (setq list (cdr list)))) - nil)) - -(defun member-if-not (predicate list) - "PREDICATE is applied to the members of LIST. As soon as one of them -returns false, that tail of the list if returned. Else NIL." - (catch 'found-member-if-not - (while (not (endp list)) - (if (funcall predicate (car list)) - (setq list (cdr list)) - (throw 'found-member-if-not list))) - nil)) - -(defun tailp (sublist list) - "(tailp SUBLIST LIST) => True if SUBLIST is a sublist of LIST." - (catch 'tailp-found - (while (not (endp list)) - (if (eq sublist list) - (throw 'tailp-found t) - (setq list (cdr list)))) - nil)) - -;;; Suggestion of phr%widow.Berkeley.EDU@lilac.berkeley.edu - -(defmacro declare (&rest decls) - "Ignore a Common-Lisp declaration." - "declarations are ignored in this implementation") - -(defun proclaim (&rest decls) - "Ignore a Common-Lisp proclamation." - "declarations are ignored in this implementation") - -(defmacro the (type form) - "(the TYPE FORM) macroexpands to FORM -No checking is even attempted. This is just for compatibility with -Common-Lisp codes." - form) - -;;; Due to Aaron Larson (alarson@src.honeywell.com, 26 Jul 91) -(put 'progv 'common-lisp-indent-hook '(4 4 &body)) -(defmacro progv (vars vals &rest body) - "progv vars vals &body forms -bind vars to vals then execute forms. -If there are more vars than vals, the extra vars are unbound, if -there are more vals than vars, the extra vals are just ignored." - (` (progv$runtime (, vars) (, vals) (function (lambda () (,@ body)))))) - -;;; To do this efficiently, it really needs to be a special form... -(defun progv$runtime (vars vals body) - (eval (let ((vars-n-vals nil) - (unbind-forms nil)) - (do ((r vars (cdr r)) - (l vals (cdr l))) - ((endp r)) - (push (list (car r) (list 'quote (car l))) vars-n-vals) - (if (null l) - (push (` (makunbound '(, (car r)))) unbind-forms))) - (` (let (, vars-n-vals) (,@ unbind-forms) (funcall '(, body))))))) - -(provide 'cl) - -;;;; end of cl.el diff --git a/lisp/cmulisp.el b/lisp/cmulisp.el deleted file mode 100644 index 1e49da84165..00000000000 --- a/lisp/cmulisp.el +++ /dev/null @@ -1,694 +0,0 @@ -;;; cmulisp.el --- improved version of standard inferior-lisp mode - -;;; Copyright Olin Shivers (1988). - -;; Keywords: processes, lisp - -;;; Please imagine a long, tedious, legalistic 5-page gnu-style copyright -;;; notice appearing here to the effect that you may use this code any -;;; way you like, as long as you don't charge money for it, remove this -;;; notice, or hold me liable for its results. - -;;; Commentary: - -;;; This replaces the standard inferior-lisp mode. -;;; Hacked from tea.el by Olin Shivers (shivers@cs.cmu.edu). 8/88 -;;; Please send me bug reports, bug fixes, and extensions, so that I can -;;; merge them into the master source. -;;; -;;; Change log at end of file. - -;;; This file defines a a lisp-in-a-buffer package (cmulisp mode) built on top -;;; of comint mode. Cmulisp mode is similar to, and intended to replace, its -;;; counterpart in the standard gnu emacs release. This replacements is more -;;; featureful, robust, and uniform than the released version. The key -;;; bindings are also more compatible with the bindings of Hemlock and Zwei -;;; (the Lisp Machine emacs). - -;;; Since this mode is built on top of the general command-interpreter-in- -;;; a-buffer mode (comint mode), it shares a common base functionality, -;;; and a common set of bindings, with all modes derived from comint mode. -;;; This makes these modes easier to use. - -;;; For documentation on the functionality provided by comint mode, and -;;; the hooks available for customising it, see the file comint.el. -;;; For further information on cmulisp mode, see the comments below. - -;;; Needs fixin: -;;; The load-file/compile-file default mechanism could be smarter -- it -;;; doesn't know about the relationship between filename extensions and -;;; whether the file is source or executable. If you compile foo.lisp -;;; with compile-file, then the next load-file should use foo.bin for -;;; the default, not foo.lisp. This is tricky to do right, particularly -;;; because the extension for executable files varies so much (.o, .bin, -;;; .lbin, .mo, .vo, .ao, ...). -;;; -;;; It would be nice if cmulisp (and inferior scheme, T, ...) modes -;;; had a verbose minor mode wherein sending or compiling defuns, etc. -;;; would be reflected in the transcript with suitable comments, e.g. -;;; ";;; redefining fact". Several ways to do this. Which is right? -;;; -;;; When sending text from a source file to a subprocess, the process-mark can -;;; move off the window, so you can lose sight of the process interactions. -;;; Maybe I should ensure the process mark is in the window when I send -;;; text to the process? Switch selectable? - -(require 'comint) -;; YOUR .EMACS FILE -;;============================================================================= -;; Some suggestions for your .emacs file. -;; -;; ; If cmulisp lives in some non-standard directory, you must tell emacs -;; ; where to get it. This may or may not be necessary. -;; (setq load-path (cons (expand-file-name "~jones/lib/emacs") load-path)) -;; -;; ; Autoload cmulisp from file cmulisp.el -;; (autoload 'cmulisp "cmulisp" -;; "Run an inferior Lisp process." -;; t) -;; -;; ; Define C-c t to run my favorite command in cmulisp mode: -;; (setq cmulisp-load-hook -;; '((lambda () -;; (define-key cmulisp-mode-map "\C-ct" 'favorite-cmd)))) - -;; Brief Command Documentation: -;;============================================================================ -;; Comint Mode Commands: (common to cmulisp and all comint-derived modes) -;; -;; m-p comint-previous-input Cycle backwards in input history -;; m-n comint-next-input Cycle forwards -;; m-c-r comint-previous-input-matching Search backwards in input history -;; return comint-send-input -;; c-a comint-bol Beginning of line; skip prompt. -;; c-d comint-delchar-or-maybe-eof Delete char unless at end of buff. -;; c-c c-u comint-kill-input ^u -;; c-c c-w backward-kill-word ^w -;; c-c c-c comint-interrupt-subjob ^c -;; c-c c-z comint-stop-subjob ^z -;; c-c c-\ comint-quit-subjob ^\ -;; c-c c-o comint-kill-output Delete last batch of process output -;; c-c c-r comint-show-output Show last batch of process output -;; send-invisible Read line w/o echo & send to proc -;; comint-continue-subjob Useful if you accidentally suspend -;; top-level job. -;; comint-mode-hook is the comint mode hook. - -;; CMU Lisp Mode Commands: -;; c-m-x lisp-send-defun This binding is a gnu convention. -;; c-c c-l lisp-load-file Prompt for file name; tell Lisp to load it. -;; c-c c-k lisp-compile-file Prompt for file name; tell Lisp to kompile it. -;; Filename completion is available, of course. -;; -;; Additionally, these commands are added to the key bindings of Lisp mode: -;; c-m-x lisp-eval-defun This binding is a gnu convention. -;; c-c c-e lisp-eval-defun Send the current defun to Lisp process. -;; c-x c-e lisp-eval-last-sexp Send the previous sexp to Lisp process. -;; c-c c-r lisp-eval-region Send the current region to Lisp process. -;; c-c c-c lisp-compile-defun Compile the current defun in Lisp process. -;; c-c c-z switch-to-lisp Switch to the Lisp process buffer. -;; c-c c-l lisp-load-file (See above. In a Lisp file buffer, default -;; c-c c-k lisp-compile-file is to load/compile the current file.) -;; c-c c-d lisp-describe-sym Query Lisp for a symbol's description. -;; c-c c-a lisp-show-arglist Query Lisp for function's arglist. -;; c-c c-f lisp-show-function-documentation Query Lisp for a function's doc. -;; c-c c-v lisp-show-variable-documentation Query Lisp for a variable's doc. - -;; cmulisp Fires up the Lisp process. -;; lisp-compile-region Compile all forms in the current region. -;; -;; CMU Lisp Mode Variables: -;; cmulisp-filter-regexp Match this => don't get saved on input hist -;; inferior-lisp-program Name of Lisp program run-lisp executes -;; inferior-lisp-load-command Customises lisp-load-file -;; cmulisp-mode-hook -;; inferior-lisp-prompt Initialises comint-prompt-regexp. -;; Backwards compatibility. -;; lisp-source-modes Anything loaded into a buffer that's in -;; one of these modes is considered Lisp -;; source by lisp-load/compile-file. - -;;; Code: - -(require 'comint) - -;;; Read the rest of this file for more information. - - -;;; Code: - -(defvar cmulisp-filter-regexp "\\`\\s *\\(:\\(\\w\\|\\s_\\)\\)?\\s *\\'" - "*What not to save on inferior Lisp's input history -Input matching this regexp is not saved on the input history in cmulisp -mode. Default is whitespace followed by 0 or 1 single-letter :keyword -(as in :a, :c, etc.)") - -(defvar cmulisp-mode-map nil) -(cond ((not cmulisp-mode-map) - (setq cmulisp-mode-map - (nconc (full-copy-sparse-keymap comint-mode-map) - shared-lisp-mode-map)) - (define-key cmulisp-mode-map "\C-x\C-e" 'lisp-eval-last-sexp) - (define-key cmulisp-mode-map "\C-c\C-l" 'lisp-load-file) - (define-key cmulisp-mode-map "\C-c\C-k" 'lisp-compile-file) - (define-key cmulisp-mode-map "\C-c\C-a" 'lisp-show-arglist) - (define-key cmulisp-mode-map "\C-c\C-d" 'lisp-describe-sym) - (define-key cmulisp-mode-map "\C-c\C-f" 'lisp-show-function-documentation) - (define-key cmulisp-mode-map "\C-c\C-v" 'lisp-show-variable-documentation))) - -;;; These commands augment Lisp mode, so you can process Lisp code in -;;; the source files. -(define-key lisp-mode-map "\M-\C-x" 'lisp-eval-defun) ; Gnu convention -(define-key lisp-mode-map "\C-x\C-e" 'lisp-eval-last-sexp) ; Gnu convention -(define-key lisp-mode-map "\C-c\C-e" 'lisp-eval-defun) -(define-key lisp-mode-map "\C-c\C-r" 'lisp-eval-region) -(define-key lisp-mode-map "\C-c\C-c" 'lisp-compile-defun) -(define-key lisp-mode-map "\C-c\C-z" 'switch-to-lisp) -(define-key lisp-mode-map "\C-c\C-l" 'lisp-load-file) -(define-key lisp-mode-map "\C-c\C-k" 'lisp-compile-file) ; "kompile" file -(define-key lisp-mode-map "\C-c\C-a" 'lisp-show-arglist) -(define-key lisp-mode-map "\C-c\C-d" 'lisp-describe-sym) -(define-key lisp-mode-map "\C-c\C-f" 'lisp-show-function-documentation) -(define-key lisp-mode-map "\C-c\C-v" 'lisp-show-variable-documentation) - -(defvar cmulisp-buffer) - -;;; This function exists for backwards compatibility. -;;; Previous versions of this package bound commands to C-c <letter> -;;; bindings, which is not allowed by the gnumacs standard. - -(defun cmulisp-install-letter-bindings () - "This function binds many cmulisp commands to C-c <letter> bindings, -where they are more accessible. C-c <letter> bindings are reserved for the -user, so these bindings are non-standard. If you want them, you should -have this function called by the cmulisp-load-hook: - (setq cmulisp-load-hook '(cmulisp-install-letter-bindings)) -You can modify this function to install just the bindings you want." - - (define-key lisp-mode-map "\C-ce" 'lisp-eval-defun-and-go) - (define-key lisp-mode-map "\C-cr" 'lisp-eval-region-and-go) - (define-key lisp-mode-map "\C-cc" 'lisp-compile-defun-and-go) - (define-key lisp-mode-map "\C-cz" 'switch-to-lisp) - (define-key lisp-mode-map "\C-cl" 'lisp-load-file) - (define-key lisp-mode-map "\C-ck" 'lisp-compile-file) - (define-key lisp-mode-map "\C-ca" 'lisp-show-arglist) - (define-key lisp-mode-map "\C-cd" 'lisp-describe-sym) - (define-key lisp-mode-map "\C-cf" 'lisp-show-function-documentation) - (define-key lisp-mode-map "\C-cv" 'lisp-show-variable-documentation) - - (define-key cmulisp-mode-map "\C-cl" 'lisp-load-file) - (define-key cmulisp-mode-map "\C-ck" 'lisp-compile-file) - (define-key cmulisp-mode-map "\C-ca" 'lisp-show-arglist) - (define-key cmulisp-mode-map "\C-cd" 'lisp-describe-sym) - (define-key cmulisp-mode-map "\C-cf" 'lisp-show-function-documentation) - (define-key cmulisp-mode-map "\C-cv" 'lisp-show-variable-documentation)) - - -(defvar inferior-lisp-program "lisp" - "*Program name for invoking an inferior Lisp with `cmulisp'.") - -(defvar inferior-lisp-load-command "(load \"%s\")\n" - "*Format-string for building a Lisp expression to load a file. -This format string should use %s to substitute a file name -and should result in a Lisp expression that will command the inferior Lisp -to load that file. The default works acceptably on most Lisps. -The string \"(progn (load \\\"%s\\\" :verbose nil :print t) (values))\\\n\" -produces cosmetically superior output for this application, -but it works only in Common Lisp.") - -(defvar inferior-lisp-prompt "^[^> ]*>+:? *" - "Regexp to recognise prompts in the inferior Lisp. -Defaults to \"^[^> ]*>+:? *\", which works pretty good for Lucid, kcl, -and franz. This variable is used to initialise comint-prompt-regexp in the -cmulisp buffer. - -More precise choices: -Lucid Common Lisp: \"^\\(>\\|\\(->\\)+\\) *\" -franz: \"^\\(->\\|<[0-9]*>:\\) *\" -kcl: \"^>+ *\" - -This is a fine thing to set in your .emacs file.") - -(defvar cmulisp-mode-hook '() - "*Hook for customising cmulisp mode") - -(defun cmulisp-mode () - "Major mode for interacting with an inferior Lisp process. -Runs a Lisp interpreter as a subprocess of Emacs, with Lisp I/O through an -Emacs buffer. Variable inferior-lisp-program controls which Lisp interpreter -is run. Variables inferior-lisp-prompt, cmulisp-filter-regexp and -inferior-lisp-load-command can customize this mode for different Lisp -interpreters. - -For information on running multiple processes in multiple buffers, see -documentation for variable cmulisp-buffer. - -\\{cmulisp-mode-map} - -Customisation: Entry to this mode runs the hooks on comint-mode-hook and -cmulisp-mode-hook (in that order). - -You can send text to the inferior Lisp process from other buffers containing -Lisp source. - switch-to-lisp switches the current buffer to the Lisp process buffer. - lisp-eval-defun sends the current defun to the Lisp process. - lisp-compile-defun compiles the current defun. - lisp-eval-region sends the current region to the Lisp process. - lisp-compile-region compiles the current region. - - Prefixing the lisp-eval/compile-defun/region commands with - a \\[universal-argument] causes a switch to the Lisp process buffer after sending - the text. - -Commands: -Return after the end of the process' output sends the text from the - end of process to point. -Return before the end of the process' output copies the sexp ending at point - to the end of the process' output, and sends it. -Delete converts tabs to spaces as it moves back. -Tab indents for Lisp; with argument, shifts rest - of expression rigidly with the current line. -C-M-q does Tab on each line starting within following expression. -Paragraphs are separated only by blank lines. Semicolons start comments. -If you accidentally suspend your process, use \\[comint-continue-subjob] -to continue it." - (interactive) - (comint-mode) - (setq comint-prompt-regexp inferior-lisp-prompt) - (setq major-mode 'cmulisp-mode) - (setq mode-name "CMU Lisp") - (setq mode-line-process '(": %s")) - (lisp-mode-variables t) - (use-local-map cmulisp-mode-map) ;c-c c-k for "kompile" file - (setq comint-get-old-input (function lisp-get-old-input)) - (setq comint-input-filter (function lisp-input-filter)) - (setq comint-input-sentinel 'ignore) - (run-hooks 'cmulisp-mode-hook)) - -(defun lisp-get-old-input () - "Snarf the sexp ending at point" - (save-excursion - (let ((end (point))) - (backward-sexp) - (buffer-substring (point) end)))) - -(defun lisp-input-filter (str) - "Don't save anything matching cmulisp-filter-regexp" - (not (string-match cmulisp-filter-regexp str))) - -(defun cmulisp (cmd) - "Run an inferior Lisp process, input and output via buffer *cmulisp*. -If there is a process already running in *cmulisp*, just switch to that buffer. -With argument, allows you to edit the command line (default is value -of inferior-lisp-program). Runs the hooks from cmulisp-mode-hook (after the -comint-mode-hook is run). -\(Type \\[describe-mode] in the process buffer for a list of commands.)" - (interactive (list (if current-prefix-arg - (read-string "Run lisp: " inferior-lisp-program) - inferior-lisp-program))) - (if (not (comint-check-proc "*cmulisp*")) - (let ((cmdlist (cmulisp-args-to-list cmd))) - (set-buffer (apply (function make-comint) "cmulisp" (car cmdlist) nil - (cdr cmdlist))) - (cmulisp-mode))) - (setq cmulisp-buffer "*cmulisp*") - (switch-to-buffer "*cmulisp*")) - -;;; Break a string up into a list of arguments. -;;; This will break if you have an argument with whitespace, as in -;;; string = "-ab +c -x 'you lose'". -(defun cmulisp-args-to-list (string) - (let ((where (string-match "[ \t]" string))) - (cond ((null where) (list string)) - ((not (= where 0)) - (cons (substring string 0 where) - (tea-args-to-list (substring string (+ 1 where) - (length string))))) - (t (let ((pos (string-match "[^ \t]" string))) - (if (null pos) - nil - (cmulisp-args-to-list (substring string pos - (length string))))))))) - -(defun lisp-eval-region (start end &optional and-go) - "Send the current region to the inferior Lisp process. -Prefix argument means switch-to-lisp afterwards." - (interactive "r\nP") - (comint-send-region (cmulisp-proc) start end) - (comint-send-string (cmulisp-proc) "\n") - (if and-go (switch-to-lisp t))) - -(defun lisp-eval-defun (&optional and-go) - "Send the current defun to the inferior Lisp process. -Prefix argument means switch-to-lisp afterwards." - (interactive "P") - (save-excursion - (end-of-defun) - (skip-chars-backward " \t\n\r\f") ; Makes allegro happy - (let ((end (point))) - (beginning-of-defun) - (lisp-eval-region (point) end))) - (if and-go (switch-to-lisp t))) - -(defun lisp-eval-last-sexp (&optional and-go) - "Send the previous sexp to the inferior Lisp process. -Prefix argument means switch-to-lisp afterwards." - (interactive "P") - (lisp-eval-region (save-excursion (backward-sexp) (point)) (point) and-go)) - -;;; Common Lisp COMPILE sux. -(defun lisp-compile-region (start end &optional and-go) - "Compile the current region in the inferior Lisp process. -Prefix argument means switch-to-lisp afterwards." - (interactive "r\nP") - (comint-send-string (cmulisp-proc) - (format "(funcall (compile nil `(lambda () (progn 'compile %s))))\n" - (buffer-substring start end))) - (if and-go (switch-to-lisp t))) - -(defun lisp-compile-defun (&optional and-go) - "Compile the current defun in the inferior Lisp process. -Prefix argument means switch-to-lisp afterwards." - (interactive "P") - (save-excursion - (end-of-defun) - (skip-chars-backward " \t\n\r\f") ; Makes allegro happy - (let ((e (point))) - (beginning-of-defun) - (lisp-compile-region (point) e))) - (if and-go (switch-to-lisp t))) - -(defun switch-to-lisp (eob-p) - "Switch to the inferior Lisp process buffer. -With argument, positions cursor at end of buffer." - (interactive "P") - (if (get-buffer cmulisp-buffer) - (pop-to-buffer cmulisp-buffer) - (error "No current process buffer. See variable cmulisp-buffer.")) - (cond (eob-p - (push-mark) - (goto-char (point-max))))) - - -;;; Now that lisp-compile/eval-defun/region takes an optional prefix arg, -;;; these commands are redundant. But they are kept around for the user -;;; to bind if he wishes, for backwards functionality, and because it's -;;; easier to type C-c e than C-u C-c C-e. - -(defun lisp-eval-region-and-go (start end) - "Send the current region to the inferior Lisp, -and switch to the process buffer." - (interactive "r") - (lisp-eval-region start end t)) - -(defun lisp-eval-defun-and-go () - "Send the current defun to the inferior Lisp, -and switch to the process buffer." - (interactive) - (lisp-eval-defun t)) - -(defun lisp-compile-region-and-go (start end) - "Compile the current region in the inferior Lisp, -and switch to the process buffer." - (interactive "r") - (lisp-compile-region start end t)) - -(defun lisp-compile-defun-and-go () - "Compile the current defun in the inferior Lisp, -and switch to the process buffer." - (interactive) - (lisp-compile-defun t)) - -;;; A version of the form in H. Shevis' soar-mode.el package. Less robust. -;(defun lisp-compile-sexp (start end) -; "Compile the s-expression bounded by START and END in the inferior lisp. -;If the sexp isn't a DEFUN form, it is evaluated instead." -; (cond ((looking-at "(defun\\s +") -; (goto-char (match-end 0)) -; (let ((name-start (point))) -; (forward-sexp 1) -; (process-send-string "cmulisp" (format "(compile '%s #'(lambda " -; (buffer-substring name-start -; (point))))) -; (let ((body-start (point))) -; (goto-char start) (forward-sexp 1) ; Can't use end-of-defun. -; (process-send-region "cmulisp" (buffer-substring body-start (point)))) -; (process-send-string "cmulisp" ")\n")) -; (t (lisp-eval-region start end))))) -; -;(defun lisp-compile-region (start end) -; "Each s-expression in the current region is compiled (if a DEFUN) -;or evaluated (if not) in the inferior lisp." -; (interactive "r") -; (save-excursion -; (goto-char start) (end-of-defun) (beginning-of-defun) ; error check -; (if (< (point) start) (error "region begins in middle of defun")) -; (goto-char start) -; (let ((s start)) -; (end-of-defun) -; (while (<= (point) end) ; Zip through -; (lisp-compile-sexp s (point)) ; compiling up defun-sized chunks. -; (setq s (point)) -; (end-of-defun)) -; (if (< s end) (lisp-compile-sexp s end))))) -;;; -;;; End of HS-style code - - -(defvar lisp-prev-l/c-dir/file nil - "Saves the (directory . file) pair used in the last lisp-load-file or -lisp-compile-file command. Used for determining the default in the -next one.") - -(defvar lisp-source-modes '(lisp-mode) - "*Used to determine if a buffer contains Lisp source code. -If it's loaded into a buffer that is in one of these major modes, it's -considered a Lisp source file by lisp-load-file and lisp-compile-file. -Used by these commands to determine defaults.") - -(defun lisp-load-file (file-name) - "Load a Lisp file into the inferior Lisp process." - (interactive (comint-get-source "Load Lisp file: " lisp-prev-l/c-dir/file - lisp-source-modes nil)) ; NIL because LOAD - ; doesn't need an exact name - (comint-check-source file-name) ; Check to see if buffer needs saved. - (setq lisp-prev-l/c-dir/file (cons (file-name-directory file-name) - (file-name-nondirectory file-name))) - (comint-send-string (cmulisp-proc) - (format inferior-lisp-load-command file-name)) - (switch-to-lisp t)) - - -(defun lisp-compile-file (file-name) - "Compile a Lisp file in the inferior Lisp process." - (interactive (comint-get-source "Compile Lisp file: " lisp-prev-l/c-dir/file - lisp-source-modes nil)) ; NIL = don't need - ; suffix .lisp - (comint-check-source file-name) ; Check to see if buffer needs saved. - (setq lisp-prev-l/c-dir/file (cons (file-name-directory file-name) - (file-name-nondirectory file-name))) - (comint-send-string (cmulisp-proc) (concat "(compile-file \"" - file-name - "\"\)\n")) - (switch-to-lisp t)) - - - -;;; Documentation functions: function doc, var doc, arglist, and -;;; describe symbol. -;;; =========================================================================== - -;;; Command strings -;;; =============== - -(defvar lisp-function-doc-command - "(let ((fn '%s)) - (format t \"Documentation for ~a:~&~a\" - fn (documentation fn 'function)) - (values))\n" - "Command to query inferior Lisp for a function's documentation.") - -(defvar lisp-var-doc-command - "(let ((v '%s)) - (format t \"Documentation for ~a:~&~a\" - v (documentation v 'variable)) - (values))\n" - "Command to query inferior Lisp for a variable's documentation.") - -(defvar lisp-arglist-command - "(let ((fn '%s)) - (format t \"Arglist for ~a: ~a\" fn (arglist fn)) - (values))\n" - "Command to query inferior Lisp for a function's arglist.") - -(defvar lisp-describe-sym-command - "(describe '%s)\n" - "Command to query inferior Lisp for a variable's documentation.") - - -;;; Ancillary functions -;;; =================== - -;;; Reads a string from the user. -(defun lisp-symprompt (prompt default) - (list (let* ((prompt (if default - (format "%s (default %s): " prompt default) - (concat prompt ": "))) - (ans (read-string prompt))) - (if (zerop (length ans)) default ans)))) - - -;;; Adapted from function-called-at-point in help.el. -(defun lisp-fn-called-at-pt () - "Returns the name of the function called in the current call. -Nil if it can't find one." - (condition-case nil - (save-excursion - (save-restriction - (narrow-to-region (max (point-min) (- (point) 1000)) (point-max)) - (backward-up-list 1) - (forward-char 1) - (let ((obj (read (current-buffer)))) - (and (symbolp obj) obj)))) - (error nil))) - - -;;; Adapted from variable-at-point in help.el. -(defun lisp-var-at-pt () - (condition-case () - (save-excursion - (forward-sexp -1) - (skip-chars-forward "'") - (let ((obj (read (current-buffer)))) - (and (symbolp obj) obj))) - (error nil))) - - -;;; Documentation functions: fn and var doc, arglist, and symbol describe. -;;; ====================================================================== - -(defun lisp-show-function-documentation (fn) - "Send a command to the inferior Lisp to give documentation for function FN. -See variable lisp-function-doc-command." - (interactive (lisp-symprompt "Function doc" (lisp-fn-called-at-pt))) - (comint-proc-query (cmulisp-proc) (format lisp-function-doc-command fn))) - -(defun lisp-show-variable-documentation (var) - "Send a command to the inferior Lisp to give documentation for function FN. -See variable lisp-var-doc-command." - (interactive (lisp-symprompt "Variable doc" (lisp-var-at-pt))) - (comint-proc-query (cmulisp-proc) (format lisp-var-doc-command var))) - -(defun lisp-show-arglist (fn) - "Sends an query to the inferior Lisp for the arglist for function FN. -See variable lisp-arglist-command." - (interactive (lisp-symprompt "Arglist" (lisp-fn-called-at-pt))) - (comint-proc-query (cmulisp-proc) (format lisp-arglist-command fn))) - -(defun lisp-describe-sym (sym) - "Send a command to the inferior Lisp to describe symbol SYM. -See variable lisp-describe-sym-command." - (interactive (lisp-symprompt "Describe" (lisp-var-at-pt))) - (comint-proc-query (cmulisp-proc) (format lisp-describe-sym-command sym))) - - -(defvar cmulisp-buffer nil "*The current cmulisp process buffer. - -MULTIPLE PROCESS SUPPORT -=========================================================================== -Cmulisp.el supports, in a fairly simple fashion, running multiple Lisp -processes. To run multiple Lisp processes, you start the first up with -\\[cmulisp]. It will be in a buffer named *cmulisp*. Rename this buffer -with \\[rename-buffer]. You may now start up a new process with another -\\[cmulisp]. It will be in a new buffer, named *cmulisp*. You can -switch between the different process buffers with \\[switch-to-buffer]. - -Commands that send text from source buffers to Lisp processes -- -like lisp-eval-defun or lisp-show-arglist -- have to choose a process -to send to, when you have more than one Lisp process around. This -is determined by the global variable cmulisp-buffer. Suppose you -have three inferior lisps running: - Buffer Process - foo cmulisp - bar cmulisp<2> - *cmulisp* cmulisp<3> -If you do a \\[lisp-eval-defun] command on some Lisp source code, -what process do you send it to? - -- If you're in a process buffer (foo, bar, or *cmulisp*), - you send it to that process. -- If you're in some other buffer (e.g., a source file), you - send it to the process attached to buffer cmulisp-buffer. -This process selection is performed by function cmulisp-proc. - -Whenever \\[cmulisp] fires up a new process, it resets cmulisp-buffer -to be the new process's buffer. If you only run one process, this will -do the right thing. If you run multiple processes, you can change -cmulisp-buffer to another process buffer with \\[set-variable]. - -More sophisticated approaches are, of course, possible. If you find yourself -needing to switch back and forth between multiple processes frequently, -you may wish to consider ilisp.el, a larger, more sophisticated package -for running inferior Lisp processes. The approach taken here is for a -minimal, simple implementation. Feel free to extend it.") - -(defun cmulisp-proc () - "Returns the current cmulisp process. See variable cmulisp-buffer." - (let ((proc (get-buffer-process (if (eq major-mode 'inferior-lisp-mode) - (current-buffer) - cmulisp-buffer)))) - (or proc - (error "No current process. See variable cmulisp-buffer")))) - - -;;; Do the user's customisation... -;;;=============================== -(defvar cmulisp-load-hook nil - "This hook is run when cmulisp is loaded in. -This is a good place to put keybindings.") - -(run-hooks 'cmulisp-load-hook) - -;;; CHANGE LOG -;;; =========================================================================== -;;; 5/24/90 Olin -;;; - Split cmulisp and cmushell modes into separate files. -;;; Not only is this a good idea, it's apparently the way it'll be rel 19. -;;; - Upgraded process sends to use comint-send-string instead of -;;; process-send-string. -;;; - Explicit references to process "cmulisp" have been replaced with -;;; (cmulisp-proc). This allows better handling of multiple process bufs. -;;; - Added process query and var/function/symbol documentation -;;; commands. Based on code written by Douglas Roberts. -;;; - Added lisp-eval-last-sexp, bound to C-x C-e. -;;; -;;; 9/20/90 Olin -;;; Added a save-restriction to lisp-fn-called-at-pt. This bug and fix -;;; reported by Lennart Staflin. -;;; -;;; 3/12/90 Olin -;;; - lisp-load-file and lisp-compile-file no longer switch-to-lisp. -;;; Tale suggested this. -;;; - Reversed this decision 7/15/91. You need the visual feedback. -;;; -;;; 7/25/91 Olin -;;; Changed all keybindings of the form C-c <letter>. These are -;;; supposed to be reserved for the user to bind. This affected -;;; mainly the compile/eval-defun/region[-and-go] commands. -;;; This was painful, but necessary to adhere to the gnumacs standard. -;;; For some backwards compatibility, see the -;;; cmulisp-install-letter-bindings -;;; function. -;;; -;;; 8/2/91 Olin -;;; - The lisp-compile/eval-defun/region commands now take a prefix arg, -;;; which means switch-to-lisp after sending the text to the Lisp process. -;;; This obsoletes all the -and-go commands. The -and-go commands are -;;; kept around for historical reasons, and because the user can bind -;;; them to key sequences shorter than C-u C-c C-<letter>. -;;; - If M-x cmulisp is invoked with a prefix arg, it allows you to -;;; edit the command line. - -(provide 'cmulisp) - -;;; cmulisp.el ends here diff --git a/lisp/custom.el b/lisp/custom.el deleted file mode 100644 index f8ffaeac1a1..00000000000 --- a/lisp/custom.el +++ /dev/null @@ -1,501 +0,0 @@ -;;; custom.el -- Tools for declaring and initializing options. -;; -;; Copyright (C) 1996, 1997, 1999, 2001 Free Software Foundation, Inc. -;; -;; Author: Per Abrahamsen <abraham@dina.kvl.dk> -;; Maintainer: FSF -;; Keywords: help, 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: -;; -;; This file only contain the code needed to declare and initialize -;; user options. The code to customize options is autoloaded from -;; `cus-edit.el' and is documented in the Emacs Lisp Reference manual. - -;; The code implementing face declarations is in `cus-face.el' - -;;; Code: - -(require 'widget) - -(defvar custom-define-hook nil - ;; Customize information for this option is in `cus-edit.el'. - "Hook called after defining each customize option.") - -;;; The `defcustom' Macro. - -(defun custom-initialize-default (symbol value) - "Initialize SYMBOL with VALUE. -This will do nothing if symbol already has a default binding. -Otherwise, if symbol has a `saved-value' property, it will evaluate -the car of that and used as the default binding for symbol. -Otherwise, VALUE will be evaluated and used as the default binding for -symbol." - (unless (default-boundp symbol) - ;; Use the saved value if it exists, otherwise the standard setting. - (set-default symbol (if (get symbol 'saved-value) - (eval (car (get symbol 'saved-value))) - (eval value))))) - -(defun custom-initialize-set (symbol value) - "Initialize SYMBOL based on VALUE. -If the symbol doesn't have a default binding already, -then set it using its `:set' function (or `set-default' if it has none). -The value is either the value in the symbol's `saved-value' property, -if any, or VALUE." - (unless (default-boundp symbol) - (funcall (or (get symbol 'custom-set) 'set-default) - symbol - (if (get symbol 'saved-value) - (eval (car (get symbol 'saved-value))) - (eval value))))) - -(defun custom-initialize-reset (symbol value) - "Initialize SYMBOL based on VALUE. -Set the symbol, using its `:set' function (or `set-default' if it has none). -The value is either the symbol's current value - \(as obtained using the `:get' function), if any, -or the value in the symbol's `saved-value' property if any, -or (last of all) VALUE." - (funcall (or (get symbol 'custom-set) 'set-default) - symbol - (cond ((default-boundp symbol) - (funcall (or (get symbol 'custom-get) 'default-value) - symbol)) - ((get symbol 'saved-value) - (eval (car (get symbol 'saved-value)))) - (t - (eval value))))) - -(defun custom-initialize-changed (symbol value) - "Initialize SYMBOL with VALUE. -Like `custom-initialize-reset', but only use the `:set' function if -not using the standard setting. -For the standard setting, use `set-default'." - (cond ((default-boundp symbol) - (funcall (or (get symbol 'custom-set) 'set-default) - symbol - (funcall (or (get symbol 'custom-get) 'default-value) - symbol))) - ((get symbol 'saved-value) - (funcall (or (get symbol 'custom-set) 'set-default) - symbol - (eval (car (get symbol 'saved-value))))) - (t - (set-default symbol (eval value))))) - -(defun custom-declare-variable (symbol default doc &rest args) - "Like `defcustom', but SYMBOL and DEFAULT are evaluated as normal arguments. -DEFAULT should be an expression to evaluate to compute the default value, -not the default value itself." - ;; Remember the standard setting. - (put symbol 'standard-value (list default)) - ;; Maybe this option was rogue in an earlier version. It no longer is. - (when (get symbol 'force-value) - (put symbol 'force-value nil)) - (when doc - (put symbol 'variable-documentation doc)) - (let ((initialize 'custom-initialize-reset) - (requests nil)) - (while args - (let ((arg (car args))) - (setq args (cdr args)) - (unless (symbolp arg) - (error "Junk in args %S" args)) - (let ((keyword arg) - (value (car args))) - (unless args - (error "Keyword %s is missing an argument" keyword)) - (setq args (cdr args)) - (cond ((eq keyword :initialize) - (setq initialize value)) - ((eq keyword :set) - (put symbol 'custom-set value)) - ((eq keyword :get) - (put symbol 'custom-get value)) - ((eq keyword :require) - (setq requests (cons value requests))) - ((eq keyword :type) - (put symbol 'custom-type (purecopy value))) - ((eq keyword :options) - (if (get symbol 'custom-options) - ;; Slow safe code to avoid duplicates. - (mapc (lambda (option) - (custom-add-option symbol option)) - value) - ;; Fast code for the common case. - (put symbol 'custom-options (copy-sequence value)))) - (t - (custom-handle-keyword symbol keyword value - 'custom-variable)))))) - (put symbol 'custom-requests requests) - ;; Do the actual initialization. - (funcall initialize symbol default)) - (setq current-load-list (cons symbol current-load-list)) - (run-hooks 'custom-define-hook) - symbol) - -(defmacro defcustom (symbol value doc &rest args) - "Declare SYMBOL as a customizable variable that defaults to VALUE. -DOC is the variable documentation. - -Neither SYMBOL nor VALUE needs to be quoted. -If SYMBOL is not already bound, initialize it to VALUE. -The remaining arguments should have the form - - [KEYWORD VALUE]... - -The following keywords are meaningful: - -:type VALUE should be a widget type for editing the symbols value. -:options VALUE should be a list of valid members of the widget type. -:group VALUE should be a customization group. - Add SYMBOL to that group. -:initialize - VALUE should be a function used to initialize the - variable. It takes two arguments, the symbol and value - given in the `defcustom' call. The default is - `custom-initialize-default' -:set VALUE should be a function to set the value of the symbol. - It takes two arguments, the symbol to set and the value to - give it. The default choice of function is `custom-set-default'. -:get VALUE should be a function to extract the value of symbol. - The function takes one argument, a symbol, and should return - the current value for that symbol. The default choice of function - is `custom-default-value'. -:require - VALUE should be a feature symbol. If you save a value - for this option, then when your `.emacs' file loads the value, - it does (require VALUE) first. -:version - VALUE should be a string specifying that the variable was - first introduced, or its default value was changed, in Emacs - version VERSION. - -Read the section about customization in the Emacs Lisp manual for more -information." - ;; It is better not to use backquote in this file, - ;; because that makes a bootstrapping problem - ;; if you need to recompile all the Lisp files using interpreted code. - (nconc (list 'custom-declare-variable - (list 'quote symbol) - (list 'quote value) - doc) - args)) - -;;; The `defface' Macro. - -(defmacro defface (face spec doc &rest args) - "Declare FACE as a customizable face that defaults to SPEC. -FACE does not need to be quoted. - -Third argument DOC is the face documentation. - -If FACE has been set with `custom-set-face', set the face attributes -as specified by that function, otherwise set the face attributes -according to SPEC. - -The remaining arguments should have the form - - [KEYWORD VALUE]... - -The following KEYWORDs are defined: - -:group VALUE should be a customization group. - Add FACE to that group. - -SPEC should be an alist of the form ((DISPLAY ATTS)...). - -The first element of SPEC where the DISPLAY matches the frame -is the one that takes effect in that frame. The ATTRs in this -element take effect; the other elements are ignored, on that frame. - -ATTS is a list of face attributes followed by their values: - (ATTR VALUE ATTR VALUE...) - -The possible attributes are `:family', `:width', `:height', `:weight', -`:slant', `:underline', `:overline', `:strike-through', `:box', -`:foreground', `:background', `:stipple', and `:inverse-video'. - -DISPLAY can either be the symbol t, which will match all frames, or an -alist of the form \((REQ ITEM...)...). For the DISPLAY to match a -FRAME, the REQ property of the frame must match one of the ITEM. The -following REQ are defined: - -`type' (the value of `window-system') - Under X, in addition to the values `window-system' can take, - `motif', `lucid' and `x-toolkit' are allowed, and match when - the Motif toolkit, Lucid toolkit, or any X toolkit is in use. - -`class' (the frame's color support) - Should be one of `color', `grayscale', or `mono'. - -`background' (what color is used for the background text) - Should be one of `light' or `dark'. - -Read the section about customization in the Emacs Lisp manual for more -information." - ;; It is better not to use backquote in this file, - ;; because that makes a bootstrapping problem - ;; if you need to recompile all the Lisp files using interpreted code. - (nconc (list 'custom-declare-face (list 'quote face) spec doc) args)) - -;;; The `defgroup' Macro. - -(defun custom-declare-group (symbol members doc &rest args) - "Like `defgroup', but SYMBOL is evaluated as a normal argument." - (while members - (apply 'custom-add-to-group symbol (car members)) - (setq members (cdr members))) - (put symbol 'custom-group (nconc members (get symbol 'custom-group))) - (when doc - ;; This text doesn't get into DOC. - (put symbol 'group-documentation (purecopy doc))) - (while args - (let ((arg (car args))) - (setq args (cdr args)) - (unless (symbolp arg) - (error "Junk in args %S" args)) - (let ((keyword arg) - (value (car args))) - (unless args - (error "Keyword %s is missing an argument" keyword)) - (setq args (cdr args)) - (cond ((eq keyword :prefix) - (put symbol 'custom-prefix value)) - (t - (custom-handle-keyword symbol keyword value - 'custom-group)))))) - (run-hooks 'custom-define-hook) - symbol) - -(defmacro defgroup (symbol members doc &rest args) - "Declare SYMBOL as a customization group containing MEMBERS. -SYMBOL does not need to be quoted. - -Third arg DOC is the group documentation. - -MEMBERS should be an alist of the form ((NAME WIDGET)...) where -NAME is a symbol and WIDGET is a widget for editing that symbol. -Useful widgets are `custom-variable' for editing variables, -`custom-face' for edit faces, and `custom-group' for editing groups. - -The remaining arguments should have the form - - [KEYWORD VALUE]... - -The following KEYWORDs are defined: - -:group VALUE should be a customization group. - Add SYMBOL to that group. - -:version VALUE should be a string specifying that the group was introduced - in Emacs version VERSION. - -Read the section about customization in the Emacs Lisp manual for more -information." - ;; It is better not to use backquote in this file, - ;; because that makes a bootstrapping problem - ;; if you need to recompile all the Lisp files using interpreted code. - (nconc (list 'custom-declare-group (list 'quote symbol) members doc) args)) - -(defun custom-add-to-group (group option widget) - "To existing GROUP add a new OPTION of type WIDGET. -If there already is an entry for OPTION and WIDGET, nothing is done." - (let ((members (get group 'custom-group)) - (entry (list option widget))) - (unless (member entry members) - (put group 'custom-group (nconc members (list entry)))))) - -;;; Properties. - -(defun custom-handle-all-keywords (symbol args type) - "For customization option SYMBOL, handle keyword arguments ARGS. -Third argument TYPE is the custom option type." - (while args - (let ((arg (car args))) - (setq args (cdr args)) - (unless (symbolp arg) - (error "Junk in args %S" args)) - (let ((keyword arg) - (value (car args))) - (unless args - (error "Keyword %s is missing an argument" keyword)) - (setq args (cdr args)) - (custom-handle-keyword symbol keyword value type))))) - -(defun custom-handle-keyword (symbol keyword value type) - "For customization option SYMBOL, handle KEYWORD with VALUE. -Fourth argument TYPE is the custom option type." - (if purify-flag - (setq value (purecopy value))) - (cond ((eq keyword :group) - (custom-add-to-group value symbol type)) - ((eq keyword :version) - (custom-add-version symbol value)) - ((eq keyword :link) - (custom-add-link symbol value)) - ((eq keyword :load) - (custom-add-load symbol value)) - ((eq keyword :tag) - (put symbol 'custom-tag value)) - ((eq keyword :set-after) - (custom-add-dependencies symbol value)) - (t - (error "Unknown keyword %s" keyword)))) - -(defun custom-add-dependencies (symbol value) - "To the custom option SYMBOL, add dependencies specified by VALUE. -VALUE should be a list of symbols. For each symbol in that list, -this specifies that SYMBOL should be set after the specified symbol, if -both appear in constructs like `custom-set-variables'." - (unless (listp value) - (error "Invalid custom dependency `%s'" value)) - (let* ((deps (get symbol 'custom-dependencies)) - (new-deps deps)) - (while value - (let ((dep (car value))) - (unless (symbolp dep) - (error "Invalid custom dependency `%s'" dep)) - (unless (memq dep new-deps) - (setq new-deps (cons dep new-deps))) - (setq value (cdr value)))) - (unless (eq deps new-deps) - (put symbol 'custom-dependencies new-deps)))) - -(defun custom-add-option (symbol option) - "To the variable SYMBOL add OPTION. - -If SYMBOL is a hook variable, OPTION should be a hook member. -For other types variables, the effect is undefined." - (let ((options (get symbol 'custom-options))) - (unless (member option options) - (put symbol 'custom-options (cons option options))))) - -(defun custom-add-link (symbol widget) - "To the custom option SYMBOL add the link WIDGET." - (let ((links (get symbol 'custom-links))) - (unless (member widget links) - (put symbol 'custom-links (cons (purecopy widget) links))))) - -(defun custom-add-version (symbol version) - "To the custom option SYMBOL add the version VERSION." - (put symbol 'custom-version (purecopy version))) - -(defun custom-add-load (symbol load) - "To the custom option SYMBOL add the dependency LOAD. -LOAD should be either a library file name, or a feature name." - (let ((loads (get symbol 'custom-loads))) - (unless (member load loads) - (put symbol 'custom-loads (cons (purecopy load) loads))))) - -;;; Initializing. - -(defvar custom-local-buffer nil - "Non-nil, in a Customization buffer, means customize a specific buffer. -If this variable is non-nil, it should be a buffer, -and it means customize the local bindings of that buffer. -This variable is a permanent local, and it normally has a local binding -in every Customization buffer.") -(put 'custom-local-buffer 'permanent-local t) - -(defun custom-set-variables (&rest args) - "Initialize variables according to user preferences. - -The arguments should be a list where each entry has the form: - - (SYMBOL VALUE [NOW [REQUEST [COMMENT]]]) - -The unevaluated VALUE is stored as the saved value for SYMBOL. -If NOW is present and non-nil, VALUE is also evaluated and bound as -the default value for the SYMBOL. -REQUEST is a list of features we must require for SYMBOL. -COMMENT is a comment string about SYMBOL." - (setq args - (sort args - (lambda (a1 a2) - (let* ((sym1 (car a1)) - (sym2 (car a2)) - (1-then-2 (memq sym1 (get sym2 'custom-dependencies))) - (2-then-1 (memq sym2 (get sym1 'custom-dependencies)))) - (cond ((and 1-then-2 2-then-1) - (error "Circular custom dependency between `%s' and `%s'" - sym1 sym2)) - (1-then-2 t) - (t nil)))))) - (while args - (let ((entry (car args))) - (if (listp entry) - (let* ((symbol (nth 0 entry)) - (value (nth 1 entry)) - (now (nth 2 entry)) - (requests (nth 3 entry)) - (comment (nth 4 entry)) - set) - (when requests - (put symbol 'custom-requests requests) - (mapc 'require requests)) - (setq set (or (get symbol 'custom-set) 'custom-set-default)) - (put symbol 'saved-value (list value)) - (put symbol 'saved-variable-comment comment) - ;; Allow for errors in the case where the setter has - ;; changed between versions, say, but let the user know. - (condition-case data - (cond (now - ;; Rogue variable, set it now. - (put symbol 'force-value t) - (funcall set symbol (eval value))) - ((default-boundp symbol) - ;; Something already set this, overwrite it. - (funcall set symbol (eval value)))) - (error - (message "Error setting %s: %s" symbol data))) - (setq args (cdr args)) - (and (or now (default-boundp symbol)) - (put symbol 'variable-comment comment))) - ;; Old format, a plist of SYMBOL VALUE pairs. - (message "Warning: old format `custom-set-variables'") - (ding) - (sit-for 2) - (let ((symbol (nth 0 args)) - (value (nth 1 args))) - (put symbol 'saved-value (list value))) - (setq args (cdr (cdr args))))))) - -(defun custom-set-default (variable value) - "Default :set function for a customizable variable. -Normally, this sets the default value of VARIABLE to VALUE, -but if `custom-local-buffer' is non-nil, -this sets the local binding in that buffer instead." - (if custom-local-buffer - (with-current-buffer custom-local-buffer - (set variable value)) - (set-default variable value))) - -;;; The End. - -;; Process the defcustoms for variables loaded before this file. -(while custom-declare-variable-list - (apply 'custom-declare-variable (car custom-declare-variable-list)) - (setq custom-declare-variable-list (cdr custom-declare-variable-list))) - -(provide 'custom) - -;;; custom.el ends here diff --git a/lisp/diary-ins.el b/lisp/diary-ins.el deleted file mode 100644 index d84bb260670..00000000000 --- a/lisp/diary-ins.el +++ /dev/null @@ -1,251 +0,0 @@ -;;; diary-ins.el --- calendar functions for adding diary entries. - -;; Copyright (C) 1990, 1994 Free Software Foundation, Inc. - -;; Author: Edward M. Reingold <reingold@cs.uiuc.edu> -;; Keywords: diary, calendar - -;; 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, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; Commentary: - -;; This collection of functions implements the diary insertion features as -;; described in calendar.el. - -;; Comments, corrections, and improvements should be sent to -;; Edward M. Reingold Department of Computer Science -;; (217) 333-6733 University of Illinois at Urbana-Champaign -;; reingold@cs.uiuc.edu 1304 West Springfield Avenue -;; Urbana, Illinois 61801 - -;;; Code: - -(require 'diary-lib) - -(defun make-diary-entry (string &optional nonmarking file) - "Insert a diary entry STRING which may be NONMARKING in FILE. -If omitted, NONMARKING defaults to nil and FILE defaults to diary-file." - (find-file-other-window - (substitute-in-file-name (if file file diary-file))) - (goto-char (point-max)) - (insert - (if (bolp) "" "\n") - (if nonmarking diary-nonmarking-symbol "") - string " ")) - -(defun insert-diary-entry (arg) - "Insert a diary entry for the date indicated by point. -Prefix arg will make the entry nonmarking." - (interactive "P") - (make-diary-entry (calendar-date-string (calendar-cursor-to-date t) t t) - arg)) - -(defun insert-weekly-diary-entry (arg) - "Insert a weekly diary entry for the day of the week indicated by point. -Prefix arg will make the entry nonmarking." - (interactive "P") - (make-diary-entry (calendar-day-name (calendar-cursor-to-date t)) - arg)) - -(defun insert-monthly-diary-entry (arg) - "Insert a monthly diary entry for the day of the month indicated by point. -Prefix arg will make the entry nonmarking." - (interactive "P") - (let* ((calendar-date-display-form - (if european-calendar-style - '(day " * ") - '("* " day)))) - (make-diary-entry (calendar-date-string (calendar-cursor-to-date t) t) - arg))) - -(defun insert-yearly-diary-entry (arg) - "Insert an annual diary entry for the day of the year indicated by point. -Prefix arg will make the entry nonmarking." - (interactive "P") - (let* ((calendar-date-display-form - (if european-calendar-style - '(day " " monthname) - '(monthname " " day)))) - (make-diary-entry (calendar-date-string (calendar-cursor-to-date t) t) - arg))) - -(defun insert-anniversary-diary-entry (arg) - "Insert an anniversary diary entry for the date given by point. -Prefix arg will make the entry nonmarking." - (interactive "P") - (let* ((calendar-date-display-form - (if european-calendar-style - '(day " " month " " year) - '(month " " day " " year)))) - (make-diary-entry - (format "%s(diary-anniversary %s)" - sexp-diary-entry-symbol - (calendar-date-string (calendar-cursor-to-date t) nil t)) - arg))) - -(defun insert-block-diary-entry (arg) - "Insert a block diary entry for the days between the point and marked date. -Prefix arg will make the entry nonmarking." - (interactive "P") - (let* ((calendar-date-display-form - (if european-calendar-style - '(day " " month " " year) - '(month " " day " " year))) - (cursor (calendar-cursor-to-date t)) - (mark (or (car calendar-mark-ring) - (error "No mark set in this buffer"))) - (start) - (end)) - (if (< (calendar-absolute-from-gregorian mark) - (calendar-absolute-from-gregorian cursor)) - (setq start mark - end cursor) - (setq start cursor - end mark)) - (make-diary-entry - (format "%s(diary-block %s %s)" - sexp-diary-entry-symbol - (calendar-date-string start nil t) - (calendar-date-string end nil t)) - arg))) - -(defun insert-cyclic-diary-entry (arg) - "Insert a cyclic diary entry starting at the date given by point. -Prefix arg will make the entry nonmarking." - (interactive "P") - (let* ((calendar-date-display-form - (if european-calendar-style - '(day " " month " " year) - '(month " " day " " year)))) - (make-diary-entry - (format "%s(diary-cyclic %d %s)" - sexp-diary-entry-symbol - (calendar-read "Repeat every how many days: " - '(lambda (x) (> x 0))) - (calendar-date-string (calendar-cursor-to-date t) nil t)) - arg))) - -(defun insert-hebrew-diary-entry (arg) - "Insert a diary entry. -For the Hebrew date corresponding to the date indicated by point. -Prefix arg will make the entry nonmarking." - (interactive "P") - (let* ((calendar-month-name-array - calendar-hebrew-month-name-array-leap-year)) - (make-diary-entry - (concat - hebrew-diary-entry-symbol - (calendar-date-string - (calendar-hebrew-from-absolute - (calendar-absolute-from-gregorian - (calendar-cursor-to-date t))) - nil t)) - arg))) - -(defun insert-monthly-hebrew-diary-entry (arg) - "Insert a monthly diary entry. -For the day of the Hebrew month corresponding to the date indicated by point. -Prefix arg will make the entry nonmarking." - (interactive "P") - (let* ((calendar-date-display-form - (if european-calendar-style '(day " * ") '("* " day ))) - (calendar-month-name-array - calendar-hebrew-month-name-array-leap-year)) - (make-diary-entry - (concat - hebrew-diary-entry-symbol - (calendar-date-string - (calendar-hebrew-from-absolute - (calendar-absolute-from-gregorian - (calendar-cursor-to-date t))))) - arg))) - -(defun insert-yearly-hebrew-diary-entry (arg) - "Insert an annual diary entry. -For the day of the Hebrew year corresponding to the date indicated by point. -Prefix arg will make the entry nonmarking." - (interactive "P") - (let* ((calendar-date-display-form - (if european-calendar-style - '(day " " monthname) - '(monthname " " day))) - (calendar-month-name-array - calendar-hebrew-month-name-array-leap-year)) - (make-diary-entry - (concat - hebrew-diary-entry-symbol - (calendar-date-string - (calendar-hebrew-from-absolute - (calendar-absolute-from-gregorian - (calendar-cursor-to-date t))))) - arg))) - -(defun insert-islamic-diary-entry (arg) - "Insert a diary entry. -For the Islamic date corresponding to the date indicated by point. -Prefix arg will make the entry nonmarking." - (interactive "P") - (let* ((calendar-month-name-array calendar-islamic-month-name-array)) - (make-diary-entry - (concat - islamic-diary-entry-symbol - (calendar-date-string - (calendar-islamic-from-absolute - (calendar-absolute-from-gregorian - (calendar-cursor-to-date t))) - nil t)) - arg))) - -(defun insert-monthly-islamic-diary-entry (arg) - "Insert a monthly diary entry. -For the day of the Islamic month corresponding to the date indicated by point. -Prefix arg will make the entry nonmarking." - (interactive "P") - (let* ((calendar-date-display-form - (if european-calendar-style '(day " * ") '("* " day ))) - (calendar-month-name-array calendar-islamic-month-name-array)) - (make-diary-entry - (concat - islamic-diary-entry-symbol - (calendar-date-string - (calendar-islamic-from-absolute - (calendar-absolute-from-gregorian - (calendar-cursor-to-date t))))) - arg))) - -(defun insert-yearly-islamic-diary-entry (arg) - "Insert an annual diary entry. -For the day of the Islamic year corresponding to the date indicated by point. -Prefix arg will make the entry nonmarking." - (interactive "P") - (let* ((calendar-date-display-form - (if european-calendar-style - '(day " " monthname) - '(monthname " " day))) - (calendar-month-name-array calendar-islamic-month-name-array)) - (make-diary-entry - (concat - islamic-diary-entry-symbol - (calendar-date-string - (calendar-islamic-from-absolute - (calendar-absolute-from-gregorian - (calendar-cursor-to-date t))))) - arg))) - -(provide 'diary-ins) - -;;; diary-ins.el ends here diff --git a/lisp/diary-lib.el b/lisp/diary-lib.el deleted file mode 100644 index a78475bc916..00000000000 --- a/lisp/diary-lib.el +++ /dev/null @@ -1,1919 +0,0 @@ -;;; diary-lib.el --- diary functions. - -;; Copyright (C) 1989, 1990, 1992, 1993, 1994 Free Software Foundation, Inc. - -;; Author: Edward M. Reingold <reingold@cs.uiuc.edu> -;; Keywords: calendar - -;; 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, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; Commentary: - -;; This collection of functions implements the diary features as described -;; in calendar.el. - -;; Comments, corrections, and improvements should be sent to -;; Edward M. Reingold Department of Computer Science -;; (217) 333-6733 University of Illinois at Urbana-Champaign -;; reingold@cs.uiuc.edu 1304 West Springfield Avenue -;; Urbana, Illinois 61801 - -;;; Code: - -(require 'calendar) - -;;;###autoload -(defun diary (&optional arg) - "Generate the diary window for ARG days starting with the current date. -If no argument is provided, the number of days of diary entries is governed -by the variable `number-of-diary-entries'. This function is suitable for -execution in a `.emacs' file." - (interactive "P") - (let ((d-file (substitute-in-file-name diary-file)) - (date (calendar-current-date))) - (if (and d-file (file-exists-p d-file)) - (if (file-readable-p d-file) - (list-diary-entries - date - (cond - (arg (prefix-numeric-value arg)) - ((vectorp number-of-diary-entries) - (aref number-of-diary-entries (calendar-day-of-week date))) - (t number-of-diary-entries))) - (error "Your diary file is not readable!")) - (error "You don't have a diary file!")))) - -(defun view-diary-entries (arg) - "Prepare and display a buffer with diary entries. -Searches the file named in `diary-file' for entries that -match ARG days starting with the date indicated by the cursor position -in the displayed three-month calendar." - (interactive "p") - (let ((d-file (substitute-in-file-name diary-file))) - (if (and d-file (file-exists-p d-file)) - (if (file-readable-p d-file) - (list-diary-entries (calendar-cursor-to-date t) arg) - (error "Diary file is not readable!")) - (error "You don't have a diary file!")))) - -(defun view-other-diary-entries (arg diary-file) - "Prepare and display buffer of diary entries from an alternative diary file. -Prompts for a file name and searches that file for entries that match ARG -days starting with the date indicated by the cursor position in the displayed -three-month calendar." - (interactive - (list (cond ((null current-prefix-arg) 1) - ((listp current-prefix-arg) (car current-prefix-arg)) - (t current-prefix-arg)) - (setq diary-file (read-file-name "Enter diary file name: " - default-directory nil t)))) - (view-diary-entries arg)) - -(autoload 'check-calendar-holidays "holidays" - "Check the list of holidays for any that occur on DATE. -The value returned is a list of strings of relevant holiday descriptions. -The holidays are those in the list `calendar-holidays'." - t) - -(autoload 'calendar-holiday-list "holidays" - "Form the list of holidays that occur on dates in the calendar window. -The holidays are those in the list `calendar-holidays'." - t) - -(autoload 'diary-french-date "cal-french" - "French calendar equivalent of date diary entry." - t) - -(autoload 'diary-mayan-date "cal-mayan" - "Mayan calendar equivalent of date diary entry." - t) - -(autoload 'diary-phases-of-moon "lunar" "Moon phases diary entry." t) - -(autoload 'diary-sunrise-sunset "solar" - "Local time of sunrise and sunset as a diary entry." - t) - -(autoload 'diary-sabbath-candles "solar" - "Local time of candle lighting diary entry--applies if date is a Friday. -No diary entry if there is no sunset on that date." - t) - -(defvar diary-syntax-table (copy-syntax-table (standard-syntax-table)) - "The syntax table used when parsing dates in the diary file. -It is the standard syntax table used in Fundamental mode, but with the -syntax of `*' changed to be a word constituent.") - -(modify-syntax-entry ?* "w" diary-syntax-table) - -(defun list-diary-entries (date number) - "Create and display a buffer containing the relevant lines in diary-file. -The arguments are DATE and NUMBER; the entries selected are those -for NUMBER days starting with date DATE. The other entries are hidden -using selective display. - -Returns a list of all relevant diary entries found, if any, in order by date. -The list entries have the form ((month day year) string). If the variable -`diary-list-include-blanks' is t, this list includes a dummy diary entry -\(consisting of the empty string) for a date with no diary entries. - -After the list is prepared, the hooks `nongregorian-diary-listing-hook', -`list-diary-entries-hook', `diary-display-hook', and `diary-hook' are run. -These hooks have the following distinct roles: - - `nongregorian-diary-listing-hook' can cull dates from the diary - and each included file. Usually used for Hebrew or Islamic - diary entries in files. Applied to *each* file. - - `list-diary-entries-hook' adds or manipulates diary entries from - external sources. Used, for example, to include diary entries - from other files or to sort the diary entries. Invoked *once* only, - before the display hook is run. - - `diary-display-hook' does the actual display of information. If this is - nil, simple-diary-display will be used. Use add-hook to set this to - fancy-diary-display, if desired. If you want no diary display, use - add-hook to set this to ignore. - - `diary-hook' is run last. This can be used for an appointment - notification function." - - (if (< 0 number) - (let* ((original-date date);; save for possible use in the hooks - (old-diary-syntax-table) - (diary-entries-list) - (date-string (calendar-date-string date)) - (d-file (substitute-in-file-name diary-file))) - (message "Preparing diary...") - (save-excursion - (let ((diary-buffer (get-file-buffer d-file))) - (set-buffer (if diary-buffer - diary-buffer - (find-file-noselect d-file t)))) - (setq selective-display t) - (setq selective-display-ellipses nil) - (setq old-diary-syntax-table (syntax-table)) - (set-syntax-table diary-syntax-table) - (unwind-protect - (let ((buffer-read-only nil) - (diary-modified (buffer-modified-p)) - (mark (regexp-quote diary-nonmarking-symbol))) - (goto-char (1- (point-max))) - (if (not (looking-at "\^M\\|\n")) - (progn - (forward-char 1) - (insert-string "\^M"))) - (goto-char (point-min)) - (if (not (looking-at "\^M\\|\n")) - (insert-string "\^M")) - (subst-char-in-region (point-min) (point-max) ?\n ?\^M t) - (calendar-for-loop i from 1 to number do - (let ((d diary-date-forms) - (month (extract-calendar-month date)) - (day (extract-calendar-day date)) - (year (extract-calendar-year date)) - (entry-found (list-sexp-diary-entries date))) - (while d - (let* - ((date-form (if (equal (car (car d)) 'backup) - (cdr (car d)) - (car d))) - (backup (equal (car (car d)) 'backup)) - (dayname - (concat - (calendar-day-name date) "\\|" - (substring (calendar-day-name date) 0 3) ".?")) - (monthname - (concat - "\\*\\|" - (calendar-month-name month) "\\|" - (substring (calendar-month-name month) 0 3) ".?")) - (month (concat "\\*\\|0*" (int-to-string month))) - (day (concat "\\*\\|0*" (int-to-string day))) - (year - (concat - "\\*\\|0*" (int-to-string year) - (if abbreviated-calendar-year - (concat "\\|" (int-to-string (% year 100))) - ""))) - (regexp - (concat - "\\(\\`\\|\^M\\|\n\\)" mark "?\\(" - (mapconcat 'eval date-form "\\)\\(") - "\\)")) - (case-fold-search t)) - (goto-char (point-min)) - (while (re-search-forward regexp nil t) - (if backup (re-search-backward "\\<" nil t)) - (if (and (or (char-equal (preceding-char) ?\^M) - (char-equal (preceding-char) ?\n)) - (not (looking-at " \\|\^I"))) - ;; Diary entry that consists only of date. - (backward-char 1) - ;; Found a nonempty diary entry--make it visible and - ;; add it to the list. - (setq entry-found t) - (let ((entry-start (point)) - (date-start)) - (re-search-backward "\^M\\|\n\\|\\`") - (setq date-start (point)) - (re-search-forward "\^M\\|\n" nil t 2) - (while (looking-at " \\|\^I") - (re-search-forward "\^M\\|\n" nil t)) - (backward-char 1) - (subst-char-in-region date-start - (point) ?\^M ?\n t) - (add-to-diary-list - date (buffer-substring entry-start (point))))))) - (setq d (cdr d))) - (or entry-found - (not diary-list-include-blanks) - (setq diary-entries-list - (append diary-entries-list - (list (list date ""))))) - (setq date - (calendar-gregorian-from-absolute - (1+ (calendar-absolute-from-gregorian date)))) - (setq entry-found nil))) - (set-buffer-modified-p diary-modified)) - (set-syntax-table old-diary-syntax-table)) - (goto-char (point-min)) - (run-hooks 'nongregorian-diary-listing-hook - 'list-diary-entries-hook) - (if diary-display-hook - (run-hooks 'diary-display-hook) - (simple-diary-display)) - (run-hooks 'diary-hook) - diary-entries-list)))) - -(defun include-other-diary-files () - "Include the diary entries from other diary files with those of diary-file. -This function is suitable for use in `list-diary-entries-hook'; -it enables you to use shared diary files together with your own. -The files included are specified in the diaryfile by lines of this form: - #include \"filename\" -This is recursive; that is, #include directives in diary files thus included -are obeyed. You can change the `#include' to some other string by -changing the variable `diary-include-string'." - (goto-char (point-min)) - (while (re-search-forward - (concat - "\\(\\`\\|\^M\\|\n\\)" - (regexp-quote diary-include-string) - " \"\\([^\"]*\\)\"") - nil t) - (let ((diary-file (substitute-in-file-name - (buffer-substring (match-beginning 2) (match-end 2)))) - (diary-list-include-blanks nil) - (list-diary-entries-hook 'include-other-diary-files) - (diary-display-hook 'ignore) - (diary-hook nil)) - (if (file-exists-p diary-file) - (if (file-readable-p diary-file) - (unwind-protect - (setq diary-entries-list - (append diary-entries-list - (list-diary-entries original-date number))) - (kill-buffer (get-file-buffer diary-file))) - (beep) - (message "Can't read included diary file %s" diary-file) - (sleep-for 2)) - (beep) - (message "Can't find included diary file %s" diary-file) - (sleep-for 2)))) - (goto-char (point-min))) - -(defun simple-diary-display () - "Display the diary buffer if there are any relevant entries or holidays." - (let* ((holiday-list (if holidays-in-diary-buffer - (check-calendar-holidays original-date))) - (msg (format "No diary entries for %s %s" - (concat date-string (if holiday-list ":" "")) - (mapconcat 'identity holiday-list "; ")))) - (if (or (not diary-entries-list) - (and (not (cdr diary-entries-list)) - (string-equal (car (cdr (car diary-entries-list))) ""))) - (if (<= (length msg) (frame-width)) - (message msg) - (set-buffer (get-buffer-create holiday-buffer)) - (setq buffer-read-only nil) - (calendar-set-mode-line date-string) - (erase-buffer) - (insert (mapconcat 'identity holiday-list "\n")) - (goto-char (point-min)) - (set-buffer-modified-p nil) - (setq buffer-read-only t) - (display-buffer holiday-buffer) - (message "No diary entries for %s" date-string)) - (calendar-set-mode-line - (concat "Diary for " date-string - (if holiday-list ": " "") - (mapconcat 'identity holiday-list "; "))) - (display-buffer (get-file-buffer d-file)) - (message "Preparing diary...done")))) - -(defun fancy-diary-display () - "Prepare a diary buffer with relevant entries in a fancy, noneditable form. -This function is provided for optional use as the `diary-display-hook'." - (save-excursion;; Turn off selective-display in the diary file's buffer. - (set-buffer (get-file-buffer (substitute-in-file-name diary-file))) - (let ((diary-modified (buffer-modified-p))) - (subst-char-in-region (point-min) (point-max) ?\^M ?\n t) - (setq selective-display nil) - (kill-local-variable 'mode-line-format) - (set-buffer-modified-p diary-modified))) - (if (or (not diary-entries-list) - (and (not (cdr diary-entries-list)) - (string-equal (car (cdr (car diary-entries-list))) ""))) - (let* ((holiday-list (if holidays-in-diary-buffer - (check-calendar-holidays original-date))) - (msg (format "No diary entries for %s %s" - (concat date-string (if holiday-list ":" "")) - (mapconcat 'identity holiday-list "; ")))) - (if (<= (length msg) (frame-width)) - (message msg) - (set-buffer (get-buffer-create holiday-buffer)) - (setq buffer-read-only nil) - (calendar-set-mode-line date-string) - (erase-buffer) - (insert (mapconcat 'identity holiday-list "\n")) - (goto-char (point-min)) - (set-buffer-modified-p nil) - (setq buffer-read-only t) - (display-buffer holiday-buffer) - (message "No diary entries for %s" date-string))) - (save-excursion;; Prepare the fancy diary buffer. - (set-buffer (make-fancy-diary-buffer)) - (setq buffer-read-only nil) - (let ((entry-list diary-entries-list) - (holiday-list) - (holiday-list-last-month 1) - (holiday-list-last-year 1) - (date (list 0 0 0))) - (while entry-list - (if (not (calendar-date-equal date (car (car entry-list)))) - (progn - (setq date (car (car entry-list))) - (and holidays-in-diary-buffer - (calendar-date-compare - (list (list holiday-list-last-month - (calendar-last-day-of-month - holiday-list-last-month - holiday-list-last-year) - holiday-list-last-year)) - (list date)) - ;; We need to get the holidays for the next 3 months. - (setq holiday-list-last-month - (extract-calendar-month date)) - (setq holiday-list-last-year - (extract-calendar-year date)) - (increment-calendar-month - holiday-list-last-month holiday-list-last-year 1) - (setq holiday-list - (let ((displayed-month holiday-list-last-month) - (displayed-year holiday-list-last-year)) - (calendar-holiday-list))) - (increment-calendar-month - holiday-list-last-month holiday-list-last-year 1)) - (let* ((date-string (calendar-date-string date)) - (date-holiday-list - (let ((h holiday-list) - (d)) - ;; Make a list of all holidays for date. - (while h - (if (calendar-date-equal date (car (car h))) - (setq d (append d (cdr (car h))))) - (setq h (cdr h))) - d))) - (insert (if (= (point) (point-min)) "" ?\n) date-string) - (if date-holiday-list (insert ": ")) - (let ((l (current-column))) - (insert (mapconcat 'identity date-holiday-list - (concat "\n" (make-string l ? ))))) - (let ((l (current-column))) - (insert ?\n (make-string l ?=) ?\n))))) - (if (< 0 (length (car (cdr (car entry-list))))) - (insert (car (cdr (car entry-list))) ?\n)) - (setq entry-list (cdr entry-list)))) - (set-buffer-modified-p nil) - (goto-char (point-min)) - (setq buffer-read-only t) - (display-buffer fancy-diary-buffer) - (message "Preparing diary...done")))) - -(defun make-fancy-diary-buffer () - "Create and return the initial fancy diary buffer." - (save-excursion - (set-buffer (get-buffer-create fancy-diary-buffer)) - (setq buffer-read-only nil) - (make-local-variable 'mode-line-format) - (calendar-set-mode-line "Diary Entries") - (erase-buffer) - (set-buffer-modified-p nil) - (setq buffer-read-only t) - (get-buffer fancy-diary-buffer))) - -(defun print-diary-entries () - "Print a hard copy of the diary display. - -If the simple diary display is being used, prepare a temp buffer with the -visible lines of the diary buffer, add a heading line composed from the mode -line, print the temp buffer, and destroy it. - -If the fancy diary display is being used, just print the buffer. - -The hooks given by the variable `print-diary-entries-hook' are called to do -the actual printing." - (interactive) - (if (bufferp (get-buffer fancy-diary-buffer)) - (save-excursion - (set-buffer (get-buffer fancy-diary-buffer)) - (run-hooks 'print-diary-entries-hook)) - (let ((diary-buffer - (get-file-buffer (substitute-in-file-name diary-file)))) - (if diary-buffer - (let ((temp-buffer (get-buffer-create "*Printable Diary Entries*")) - (heading)) - (save-excursion - (set-buffer diary-buffer) - (setq heading - (if (not (stringp mode-line-format)) - "All Diary Entries" - (string-match "^-*\\([^-].*[^-]\\)-*$" mode-line-format) - (substring mode-line-format - (match-beginning 1) (match-end 1)))) - (copy-to-buffer temp-buffer (point-min) (point-max)) - (set-buffer temp-buffer) - (while (re-search-forward "\^M.*$" nil t) - (replace-match "")) - (goto-char (point-min)) - (insert heading "\n" - (make-string (length heading) ?=) "\n") - (run-hooks 'print-diary-entries-hook) - (kill-buffer temp-buffer))) - (error "You don't have a diary buffer!"))))) - -(defun show-all-diary-entries () - "Show all of the diary entries in the diary file. -This function gets rid of the selective display of the diary file so that -all entries, not just some, are visible. If there is no diary buffer, one -is created." - (interactive) - (let ((d-file (substitute-in-file-name diary-file))) - (if (and d-file (file-exists-p d-file)) - (if (file-readable-p d-file) - (save-excursion - (let ((diary-buffer (get-file-buffer d-file))) - (set-buffer (if diary-buffer - diary-buffer - (find-file-noselect d-file t))) - (let ((buffer-read-only nil) - (diary-modified (buffer-modified-p))) - (subst-char-in-region (point-min) (point-max) ?\^M ?\n t) - (setq selective-display nil) - (make-local-variable 'mode-line-format) - (setq mode-line-format default-mode-line-format) - (display-buffer (current-buffer)) - (set-buffer-modified-p diary-modified)))) - (error "Your diary file is not readable!")) - (error "You don't have a diary file!")))) - -(defun diary-name-pattern (string-array &optional fullname) - "Convert an STRING-ARRAY, an array of strings to a pattern. -The pattern will match any of the strings, either entirely or abbreviated -to three characters. An abbreviated form will match with or without a period; -If the optional FULLNAME is t, abbreviations will not match, just the full -name." - (let ((pattern "")) - (calendar-for-loop i from 0 to (1- (length string-array)) do - (setq pattern - (concat - pattern - (if (string-equal pattern "") "" "\\|") - (aref string-array i) - (if fullname - "" - (concat - "\\|" - (substring (aref string-array i) 0 3) ".?"))))) - pattern)) - -(defun mark-diary-entries () - "Mark days in the calendar window that have diary entries. -Each entry in the diary file visible in the calendar window is marked. -After the entries are marked, the hooks `nongregorian-diary-marking-hook' and -`mark-diary-entries-hook' are run." - (interactive) - (setq mark-diary-entries-in-calendar t) - (let ((d-file (substitute-in-file-name diary-file))) - (if (and d-file (file-exists-p d-file)) - (if (file-readable-p d-file) - (save-excursion - (message "Marking diary entries...") - (set-buffer (find-file-noselect d-file t)) - (let ((d diary-date-forms) - (old-diary-syntax-table)) - (setq old-diary-syntax-table (syntax-table)) - (set-syntax-table diary-syntax-table) - (while d - (let* - ((date-form (if (equal (car (car d)) 'backup) - (cdr (car d)) - (car d)));; ignore 'backup directive - (dayname (diary-name-pattern calendar-day-name-array)) - (monthname - (concat - (diary-name-pattern calendar-month-name-array) - "\\|\\*")) - (month "[0-9]+\\|\\*") - (day "[0-9]+\\|\\*") - (year "[0-9]+\\|\\*") - (l (length date-form)) - (d-name-pos (- l (length (memq 'dayname date-form)))) - (d-name-pos (if (/= l d-name-pos) (+ 2 d-name-pos))) - (m-name-pos (- l (length (memq 'monthname date-form)))) - (m-name-pos (if (/= l m-name-pos) (+ 2 m-name-pos))) - (d-pos (- l (length (memq 'day date-form)))) - (d-pos (if (/= l d-pos) (+ 2 d-pos))) - (m-pos (- l (length (memq 'month date-form)))) - (m-pos (if (/= l m-pos) (+ 2 m-pos))) - (y-pos (- l (length (memq 'year date-form)))) - (y-pos (if (/= l y-pos) (+ 2 y-pos))) - (regexp - (concat - "\\(\\`\\|\^M\\|\n\\)\\(" - (mapconcat 'eval date-form "\\)\\(") - "\\)")) - (case-fold-search t)) - (goto-char (point-min)) - (while (re-search-forward regexp nil t) - (let* ((dd-name - (if d-name-pos - (buffer-substring - (match-beginning d-name-pos) - (match-end d-name-pos)))) - (mm-name - (if m-name-pos - (buffer-substring - (match-beginning m-name-pos) - (match-end m-name-pos)))) - (mm (string-to-int - (if m-pos - (buffer-substring - (match-beginning m-pos) - (match-end m-pos)) - ""))) - (dd (string-to-int - (if d-pos - (buffer-substring - (match-beginning d-pos) - (match-end d-pos)) - ""))) - (y-str (if y-pos - (buffer-substring - (match-beginning y-pos) - (match-end y-pos)))) - (yy (if (not y-str) - 0 - (if (and (= (length y-str) 2) - abbreviated-calendar-year) - (let* ((current-y - (extract-calendar-year - (calendar-current-date))) - (y (+ (string-to-int y-str) - (* 100 - (/ current-y 100))))) - (if (> (- y current-y) 50) - (- y 100) - (if (> (- current-y y) 50) - (+ y 100) - y))) - (string-to-int y-str))))) - (if dd-name - (mark-calendar-days-named - (cdr (assoc (capitalize (substring dd-name 0 3)) - (calendar-make-alist - calendar-day-name-array - 0 - '(lambda (x) (substring x 0 3)))))) - (if mm-name - (if (string-equal mm-name "*") - (setq mm 0) - (setq mm - (cdr (assoc - (capitalize - (substring mm-name 0 3)) - (calendar-make-alist - calendar-month-name-array - 1 - '(lambda (x) (substring x 0 3))) - ))))) - (mark-calendar-date-pattern mm dd yy)))) - (setq d (cdr d)))) - (mark-sexp-diary-entries) - (run-hooks 'nongregorian-diary-marking-hook - 'mark-diary-entries-hook) - (set-syntax-table old-diary-syntax-table) - (message "Marking diary entries...done"))) - (error "Your diary file is not readable!")) - (error "You don't have a diary file!")))) - -(defun mark-sexp-diary-entries () - "Mark days in the calendar window that have sexp diary entries. -Each entry in the diary file (or included files) visible in the calendar window -is marked. See the documentation for the function `list-sexp-diary-entries'." - (let* ((sexp-mark (regexp-quote sexp-diary-entry-symbol)) - (s-entry (concat "\\(\\`\\|\^M\\|\n\\)" sexp-mark "(")) - (m) - (y) - (first-date) - (last-date)) - (save-excursion - (set-buffer calendar-buffer) - (setq m displayed-month) - (setq y displayed-year)) - (increment-calendar-month m y -1) - (setq first-date - (calendar-absolute-from-gregorian (list m 1 y))) - (increment-calendar-month m y 2) - (setq last-date - (calendar-absolute-from-gregorian - (list m (calendar-last-day-of-month m y) y))) - (goto-char (point-min)) - (while (re-search-forward s-entry nil t) - (backward-char 1) - (let ((sexp-start (point)) - (sexp) - (entry) - (entry-start) - (line-start)) - (forward-sexp) - (setq sexp (buffer-substring sexp-start (point))) - (save-excursion - (re-search-backward "\^M\\|\n\\|\\`") - (setq line-start (point))) - (forward-char 1) - (if (and (or (char-equal (preceding-char) ?\^M) - (char-equal (preceding-char) ?\n)) - (not (looking-at " \\|\^I"))) - (progn;; Diary entry consists only of the sexp - (backward-char 1) - (setq entry "")) - (setq entry-start (point)) - (re-search-forward "\^M\\|\n" nil t) - (while (looking-at " \\|\^I") - (re-search-forward "\^M\\|\n" nil t)) - (backward-char 1) - (setq entry (buffer-substring entry-start (point))) - (while (string-match "[\^M]" entry) - (aset entry (match-beginning 0) ?\n ))) - (calendar-for-loop date from first-date to last-date do - (if (diary-sexp-entry sexp entry - (calendar-gregorian-from-absolute date)) - (mark-visible-calendar-date - (calendar-gregorian-from-absolute date)))))))) - -(defun mark-included-diary-files () - "Mark the diary entries from other diary files with those of the diary file. -This function is suitable for use as the `mark-diary-entries-hook'; it enables -you to use shared diary files together with your own. The files included are -specified in the diary-file by lines of this form: - #include \"filename\" -This is recursive; that is, #include directives in diary files thus included -are obeyed. You can change the `#include' to some other string by -changing the variable `diary-include-string'." - (goto-char (point-min)) - (while (re-search-forward - (concat - "\\(\\`\\|\^M\\|\n\\)" - (regexp-quote diary-include-string) - " \"\\([^\"]*\\)\"") - nil t) - (let ((diary-file (substitute-in-file-name - (buffer-substring (match-beginning 2) (match-end 2)))) - (mark-diary-entries-hook 'mark-included-diary-files)) - (if (file-exists-p diary-file) - (if (file-readable-p diary-file) - (progn - (mark-diary-entries) - (kill-buffer (get-file-buffer diary-file))) - (beep) - (message "Can't read included diary file %s" diary-file) - (sleep-for 2)) - (beep) - (message "Can't find included diary file %s" diary-file) - (sleep-for 2)))) - (goto-char (point-min))) - -(defun mark-calendar-days-named (dayname) - "Mark all dates in the calendar window that are day DAYNAME of the week. -0 means all Sundays, 1 means all Mondays, and so on." - (save-excursion - (set-buffer calendar-buffer) - (let ((prev-month displayed-month) - (prev-year displayed-year) - (succ-month displayed-month) - (succ-year displayed-year) - (last-day) - (day)) - (increment-calendar-month succ-month succ-year 1) - (increment-calendar-month prev-month prev-year -1) - (setq day (calendar-absolute-from-gregorian - (calendar-nth-named-day 1 dayname prev-month prev-year))) - (setq last-day (calendar-absolute-from-gregorian - (calendar-nth-named-day -1 dayname succ-month succ-year))) - (while (<= day last-day) - (mark-visible-calendar-date (calendar-gregorian-from-absolute day)) - (setq day (+ day 7)))))) - -(defun mark-calendar-date-pattern (month day year) - "Mark all dates in the calendar window that conform to MONTH/DAY/YEAR. -A value of 0 in any position is a wildcard." - (save-excursion - (set-buffer calendar-buffer) - (let ((m displayed-month) - (y displayed-year)) - (increment-calendar-month m y -1) - (calendar-for-loop i from 0 to 2 do - (mark-calendar-month m y month day year) - (increment-calendar-month m y 1))))) - -(defun mark-calendar-month (month year p-month p-day p-year) - "Mark dates in the MONTH/YEAR that conform to pattern P-MONTH/P_DAY/P-YEAR. -A value of 0 in any position of the pattern is a wildcard." - (if (or (and (= month p-month) - (or (= p-year 0) (= year p-year))) - (and (= p-month 0) - (or (= p-year 0) (= year p-year)))) - (if (= p-day 0) - (calendar-for-loop - i from 1 to (calendar-last-day-of-month month year) do - (mark-visible-calendar-date (list month i year))) - (mark-visible-calendar-date (list month p-day year))))) - -(defun sort-diary-entries () - "Sort the list of diary entries by time of day." - (setq diary-entries-list (sort diary-entries-list 'diary-entry-compare))) - -(defun diary-entry-compare (e1 e2) - "Returns t if E1 is earlier than E2." - (or (calendar-date-compare e1 e2) - (and (calendar-date-equal (car e1) (car e2)) - (< (diary-entry-time (car (cdr e1))) - (diary-entry-time (car (cdr e2))))))) - -(defun diary-entry-time (s) - "Time at the beginning of the string S in a military-style integer. -For example, returns 1325 for 1:25pm. Returns -9999 if no time is recognized. -The recognized forms are XXXX or X:XX or XX:XX (military time), XXam or XXpm, -and XX:XXam or XX:XXpm." - (cond ((string-match;; Military time - "^[ \t]*\\([0-9]?[0-9]\\):?\\([0-9][0-9]\\)\\(\\>\\|[^ap]\\)" s) - (+ (* 100 (string-to-int - (substring s (match-beginning 1) (match-end 1)))) - (string-to-int (substring s (match-beginning 2) (match-end 2))))) - ((string-match;; Hour only XXam or XXpm - "^[ \t]*\\([0-9]?[0-9]\\)\\([ap]\\)m\\>" s) - (+ (* 100 (% (string-to-int - (substring s (match-beginning 1) (match-end 1))) - 12)) - (if (string-equal "a" - (substring s (match-beginning 2) (match-end 2))) - 0 1200))) - ((string-match;; Hour and minute XX:XXam or XX:XXpm - "^[ \t]*\\([0-9]?[0-9]\\):\\([0-9][0-9]\\)\\([ap]\\)m\\>" s) - (+ (* 100 (% (string-to-int - (substring s (match-beginning 1) (match-end 1))) - 12)) - (string-to-int (substring s (match-beginning 2) (match-end 2))) - (if (string-equal "a" - (substring s (match-beginning 3) (match-end 3))) - 0 1200))) - (t -9999)));; Unrecognizable - -(defun list-hebrew-diary-entries () - "Add any Hebrew date entries from the diary file to `diary-entries-list'. -Hebrew date diary entries must be prefaced by `hebrew-diary-entry-symbol' -\(normally an `H'). The same diary date forms govern the style of the Hebrew -calendar entries, except that the Hebrew month names must be spelled in full. -The Hebrew months are numbered from 1 to 13 with Nisan being 1, 12 being -Adar I and 13 being Adar II; you must use `Adar I' if you want Adar of a -common Hebrew year. If a Hebrew date diary entry begins with a -`diary-nonmarking-symbol', the entry will appear in the diary listing, but will -not be marked in the calendar. This function is provided for use with the -`nongregorian-diary-listing-hook'." - (if (< 0 number) - (let ((buffer-read-only nil) - (diary-modified (buffer-modified-p)) - (gdate original-date) - (mark (regexp-quote diary-nonmarking-symbol))) - (calendar-for-loop i from 1 to number do - (let* ((d diary-date-forms) - (hdate (calendar-hebrew-from-absolute - (calendar-absolute-from-gregorian gdate))) - (month (extract-calendar-month hdate)) - (day (extract-calendar-day hdate)) - (year (extract-calendar-year hdate))) - (while d - (let* - ((date-form (if (equal (car (car d)) 'backup) - (cdr (car d)) - (car d))) - (backup (equal (car (car d)) 'backup)) - (dayname - (concat - (calendar-day-name gdate) "\\|" - (substring (calendar-day-name gdate) 0 3) ".?")) - (calendar-month-name-array - calendar-hebrew-month-name-array-leap-year) - (monthname - (concat - "\\*\\|" - (calendar-month-name month))) - (month (concat "\\*\\|0*" (int-to-string month))) - (day (concat "\\*\\|0*" (int-to-string day))) - (year - (concat - "\\*\\|0*" (int-to-string year) - (if abbreviated-calendar-year - (concat "\\|" (int-to-string (% year 100))) - ""))) - (regexp - (concat - "\\(\\`\\|\^M\\|\n\\)" mark "?" - (regexp-quote hebrew-diary-entry-symbol) - "\\(" - (mapconcat 'eval date-form "\\)\\(") - "\\)")) - (case-fold-search t)) - (goto-char (point-min)) - (while (re-search-forward regexp nil t) - (if backup (re-search-backward "\\<" nil t)) - (if (and (or (char-equal (preceding-char) ?\^M) - (char-equal (preceding-char) ?\n)) - (not (looking-at " \\|\^I"))) - ;; Diary entry that consists only of date. - (backward-char 1) - ;; Found a nonempty diary entry--make it visible and - ;; add it to the list. - (let ((entry-start (point)) - (date-start)) - (re-search-backward "\^M\\|\n\\|\\`") - (setq date-start (point)) - (re-search-forward "\^M\\|\n" nil t 2) - (while (looking-at " \\|\^I") - (re-search-forward "\^M\\|\n" nil t)) - (backward-char 1) - (subst-char-in-region date-start (point) ?\^M ?\n t) - (add-to-diary-list - gdate (buffer-substring entry-start (point))))))) - (setq d (cdr d)))) - (setq gdate - (calendar-gregorian-from-absolute - (1+ (calendar-absolute-from-gregorian gdate))))) - (set-buffer-modified-p diary-modified)) - (goto-char (point-min)))) - -(defun mark-hebrew-diary-entries () - "Mark days in the calendar window that have Hebrew date diary entries. -Each entry in diary-file (or included files) visible in the calendar window -is marked. Hebrew date entries are prefaced by a hebrew-diary-entry-symbol -\(normally an `H'). The same diary-date-forms govern the style of the Hebrew -calendar entries, except that the Hebrew month names must be spelled in full. -The Hebrew months are numbered from 1 to 13 with Nisan being 1, 12 being -Adar I and 13 being Adar II; you must use `Adar I' if you want Adar of a -common Hebrew year. Hebrew date diary entries that begin with a -diary-nonmarking symbol will not be marked in the calendar. This function -is provided for use as part of the nongregorian-diary-marking-hook." - (let ((d diary-date-forms)) - (while d - (let* - ((date-form (if (equal (car (car d)) 'backup) - (cdr (car d)) - (car d)));; ignore 'backup directive - (dayname (diary-name-pattern calendar-day-name-array)) - (monthname - (concat - (diary-name-pattern calendar-hebrew-month-name-array-leap-year t) - "\\|\\*")) - (month "[0-9]+\\|\\*") - (day "[0-9]+\\|\\*") - (year "[0-9]+\\|\\*") - (l (length date-form)) - (d-name-pos (- l (length (memq 'dayname date-form)))) - (d-name-pos (if (/= l d-name-pos) (+ 2 d-name-pos))) - (m-name-pos (- l (length (memq 'monthname date-form)))) - (m-name-pos (if (/= l m-name-pos) (+ 2 m-name-pos))) - (d-pos (- l (length (memq 'day date-form)))) - (d-pos (if (/= l d-pos) (+ 2 d-pos))) - (m-pos (- l (length (memq 'month date-form)))) - (m-pos (if (/= l m-pos) (+ 2 m-pos))) - (y-pos (- l (length (memq 'year date-form)))) - (y-pos (if (/= l y-pos) (+ 2 y-pos))) - (regexp - (concat - "\\(\\`\\|\^M\\|\n\\)" - (regexp-quote hebrew-diary-entry-symbol) - "\\(" - (mapconcat 'eval date-form "\\)\\(") - "\\)")) - (case-fold-search t)) - (goto-char (point-min)) - (while (re-search-forward regexp nil t) - (let* ((dd-name - (if d-name-pos - (buffer-substring - (match-beginning d-name-pos) - (match-end d-name-pos)))) - (mm-name - (if m-name-pos - (buffer-substring - (match-beginning m-name-pos) - (match-end m-name-pos)))) - (mm (string-to-int - (if m-pos - (buffer-substring - (match-beginning m-pos) - (match-end m-pos)) - ""))) - (dd (string-to-int - (if d-pos - (buffer-substring - (match-beginning d-pos) - (match-end d-pos)) - ""))) - (y-str (if y-pos - (buffer-substring - (match-beginning y-pos) - (match-end y-pos)))) - (yy (if (not y-str) - 0 - (if (and (= (length y-str) 2) - abbreviated-calendar-year) - (let* ((current-y - (extract-calendar-year - (calendar-hebrew-from-absolute - (calendar-absolute-from-gregorian - (calendar-current-date))))) - (y (+ (string-to-int y-str) - (* 100 (/ current-y 100))))) - (if (> (- y current-y) 50) - (- y 100) - (if (> (- current-y y) 50) - (+ y 100) - y))) - (string-to-int y-str))))) - (if dd-name - (mark-calendar-days-named - (cdr (assoc (capitalize (substring dd-name 0 3)) - (calendar-make-alist - calendar-day-name-array - 0 - '(lambda (x) (substring x 0 3)))))) - (if mm-name - (if (string-equal mm-name "*") - (setq mm 0) - (setq - mm - (cdr - (assoc - (capitalize mm-name) - (calendar-make-alist - calendar-hebrew-month-name-array-leap-year)))))) - (mark-hebrew-calendar-date-pattern mm dd yy))))) - (setq d (cdr d))))) - -(defun mark-hebrew-calendar-date-pattern (month day year) - "Mark dates in calendar window that conform to Hebrew date MONTH/DAY/YEAR. -A value of 0 in any position is a wildcard." - (save-excursion - (set-buffer calendar-buffer) - (if (and (/= 0 month) (/= 0 day)) - (if (/= 0 year) - ;; Fully specified Hebrew date. - (let ((date (calendar-gregorian-from-absolute - (calendar-absolute-from-hebrew - (list month day year))))) - (if (calendar-date-is-visible-p date) - (mark-visible-calendar-date date))) - ;; Month and day in any year--this taken from the holiday stuff. - (if (memq displayed-month;; This test is only to speed things up a - (list ;; bit; it works fine without the test too. - (if (< 11 month) (- month 11) (+ month 1)) - (if (< 10 month) (- month 10) (+ month 2)) - (if (< 9 month) (- month 9) (+ month 3)) - (if (< 8 month) (- month 8) (+ month 4)) - (if (< 7 month) (- month 7) (+ month 5)))) - (let ((m1 displayed-month) - (y1 displayed-year) - (m2 displayed-month) - (y2 displayed-year) - (year)) - (increment-calendar-month m1 y1 -1) - (increment-calendar-month m2 y2 1) - (let* ((start-date (calendar-absolute-from-gregorian - (list m1 1 y1))) - (end-date (calendar-absolute-from-gregorian - (list m2 - (calendar-last-day-of-month m2 y2) - y2))) - (hebrew-start - (calendar-hebrew-from-absolute start-date)) - (hebrew-end (calendar-hebrew-from-absolute end-date)) - (hebrew-y1 (extract-calendar-year hebrew-start)) - (hebrew-y2 (extract-calendar-year hebrew-end))) - (setq year (if (< 6 month) hebrew-y2 hebrew-y1)) - (let ((date (calendar-gregorian-from-absolute - (calendar-absolute-from-hebrew - (list month day year))))) - (if (calendar-date-is-visible-p date) - (mark-visible-calendar-date date))))))) - ;; Not one of the simple cases--check all visible dates for match. - ;; Actually, the following code takes care of ALL of the cases, but - ;; it's much too slow to be used for the simple (common) cases. - (let ((m displayed-month) - (y displayed-year) - (first-date) - (last-date)) - (increment-calendar-month m y -1) - (setq first-date - (calendar-absolute-from-gregorian - (list m 1 y))) - (increment-calendar-month m y 2) - (setq last-date - (calendar-absolute-from-gregorian - (list m (calendar-last-day-of-month m y) y))) - (calendar-for-loop date from first-date to last-date do - (let* ((h-date (calendar-hebrew-from-absolute date)) - (h-month (extract-calendar-month h-date)) - (h-day (extract-calendar-day h-date)) - (h-year (extract-calendar-year h-date))) - (and (or (zerop month) - (= month h-month)) - (or (zerop day) - (= day h-day)) - (or (zerop year) - (= year h-year)) - (mark-visible-calendar-date - (calendar-gregorian-from-absolute date))))))))) - -(defun list-sexp-diary-entries (date) - "Add sexp entries for DATE from the diary file to `diary-entries-list'. -Also, Make them visible in the diary file. Returns t if any entries were -found. - -Sexp diary entries must be prefaced by a `sexp-diary-entry-symbol' (normally -`%%'). The form of a sexp diary entry is - - %%(SEXP) ENTRY - -Both ENTRY and DATE are globally available when the SEXP is evaluated. If the -SEXP yields the value nil, the diary entry does not apply. If it yields a -non-nil value, ENTRY will be taken to apply to DATE; if the non-nil value is a -string, that string will be the diary entry in the fancy diary display. - -For example, the following diary entry will apply to the 21st of the month -if it is a weekday and the Friday before if the 21st is on a weekend: - - &%%(let ((dayname (calendar-day-of-week date)) - (day (extract-calendar-day date))) - (or - (and (= day 21) (memq dayname '(1 2 3 4 5))) - (and (memq day '(19 20)) (= dayname 5))) - ) UIUC pay checks deposited - -A number of built-in functions are available for this type of diary entry: - - %%(diary-float MONTH DAYNAME N) text - Entry will appear on the Nth DAYNAME of MONTH. - (DAYNAME=0 means Sunday, 1 means Monday, and so on; - if N is negative it counts backward from the end of - the month. MONTH can be a list of months, a single - month, or t to specify all months. - - %%(diary-block M1 D1 Y1 M2 D2 Y2) text - Entry will appear on dates between M1/D1/Y1 and M2/D2/Y2, - inclusive. (If `european-calendar-style' is t, the - order of the parameters should be changed to D1, M1, Y1, - D2, M2, Y2.) - - %%(diary-anniversary MONTH DAY YEAR) text - Entry will appear on anniversary dates of MONTH DAY, YEAR. - (If `european-calendar-style' is t, the order of the - parameters should be changed to DAY, MONTH, YEAR.) Text - can contain %d or %d%s; %d will be replaced by the number - of years since the MONTH DAY, YEAR and %s will be replaced - by the ordinal ending of that number (that is, `st', `nd', - `rd' or `th', as appropriate. The anniversary of February - 29 is considered to be March 1 in a non-leap year. - - %%(diary-cyclic N MONTH DAY YEAR) text - Entry will appear every N days, starting MONTH DAY, YEAR. - (If `european-calendar-style' is t, the order of the - parameters should be changed to N, DAY, MONTH, YEAR.) Text - can contain %d or %d%s; %d will be replaced by the number - of repetitions since the MONTH DAY, YEAR and %s will - be replaced by the ordinal ending of that number (that is, - `st', `nd', `rd' or `th', as appropriate. - - %%(diary-day-of-year) - Diary entries giving the day of the year and the number of - days remaining in the year will be made every day. Note - that since there is no text, it makes sense only if the - fancy diary display is used. - - %%(diary-iso-date) - Diary entries giving the corresponding ISO commercial date - will be made every day. Note that since there is no text, - it makes sense only if the fancy diary display is used. - - %%(diary-french-date) - Diary entries giving the corresponding French Revolutionary - date will be made every day. Note that since there is no - text, it makes sense only if the fancy diary display is used. - - %%(diary-islamic-date) - Diary entries giving the corresponding Islamic date will be - made every day. Note that since there is no text, it - makes sense only if the fancy diary display is used. - - %%(diary-hebrew-date) - Diary entries giving the corresponding Hebrew date will be - made every day. Note that since there is no text, it - makes sense only if the fancy diary display is used. - - %%(diary-astro-day-number) Diary entries giving the corresponding - astronomical (Julian) day number will be made every day. - Note that since there is no text, it makes sense only if the - fancy diary display is used. - - %%(diary-julian-date) Diary entries giving the corresponding - Julian date will be made every day. Note that since - there is no text, it makes sense only if the fancy diary - display is used. - - %%(diary-sunrise-sunset) - Diary entries giving the local times of sunrise and sunset - will be made every day. Note that since there is no text, - it makes sense only if the fancy diary display is used. - Floating point required. - - %%(diary-phases-of-moon) - Diary entries giving the times of the phases of the moon - will be when appropriate. Note that since there is no text, - it makes sense only if the fancy diary display is used. - Floating point required. - - %%(diary-yahrzeit MONTH DAY YEAR) text - Text is assumed to be the name of the person; the date is - the date of death on the *civil* calendar. The diary entry - will appear on the proper Hebrew-date anniversary and on the - day before. (If `european-calendar-style' is t, the order - of the parameters should be changed to DAY, MONTH, YEAR.) - - %%(diary-rosh-hodesh) - Diary entries will be made on the dates of Rosh Hodesh on - the Hebrew calendar. Note that since there is no text, it - makes sense only if the fancy diary display is used. - - %%(diary-parasha) - Diary entries giving the weekly parasha will be made on - every Saturday. Note that since there is no text, it - makes sense only if the fancy diary display is used. - - %%(diary-omer) - Diary entries giving the omer count will be made every day - from Passover to Shavuoth. Note that since there is no text, - it makes sense only if the fancy diary display is used. - -Marking these entries is *extremely* time consuming, so these entries are -best if they are nonmarking." - (let* ((mark (regexp-quote diary-nonmarking-symbol)) - (sexp-mark (regexp-quote sexp-diary-entry-symbol)) - (s-entry (concat "\\(\\`\\|\^M\\|\n\\)" mark "?" sexp-mark "(")) - (entry-found)) - (goto-char (point-min)) - (while (re-search-forward s-entry nil t) - (backward-char 1) - (let ((sexp-start (point)) - (sexp) - (entry) - (entry-start) - (line-start)) - (forward-sexp) - (setq sexp (buffer-substring sexp-start (point))) - (save-excursion - (re-search-backward "\^M\\|\n\\|\\`") - (setq line-start (point))) - (forward-char 1) - (if (and (or (char-equal (preceding-char) ?\^M) - (char-equal (preceding-char) ?\n)) - (not (looking-at " \\|\^I"))) - (progn;; Diary entry consists only of the sexp - (backward-char 1) - (setq entry "")) - (setq entry-start (point)) - (re-search-forward "\^M\\|\n" nil t) - (while (looking-at " \\|\^I") - (re-search-forward "\^M\\|\n" nil t)) - (backward-char 1) - (setq entry (buffer-substring entry-start (point))) - (while (string-match "[\^M]" entry) - (aset entry (match-beginning 0) ?\n ))) - (let ((diary-entry (diary-sexp-entry sexp entry date))) - (if diary-entry - (subst-char-in-region line-start (point) ?\^M ?\n t)) - (add-to-diary-list date diary-entry) - (setq entry-found (or entry-found diary-entry))))) - entry-found)) - -(defun diary-sexp-entry (sexp entry date) - "Process a SEXP diary ENTRY for DATE." - (let ((result (if calendar-debug-sexp - (let ((stack-trace-on-error t)) - (eval (car (read-from-string sexp)))) - (condition-case nil - (eval (car (read-from-string sexp))) - (error - (beep) - (message "Bad sexp at line %d in %s: %s" - (save-excursion - (save-restriction - (narrow-to-region 1 (point)) - (goto-char (point-min)) - (let ((lines 1)) - (while (re-search-forward "\n\\|\^M" nil t) - (setq lines (1+ lines))) - lines))) - diary-file sexp) - (sleep-for 2)))))) - (if (stringp result) - result - (if result - entry - nil)))) - -(defun diary-block (m1 d1 y1 m2 d2 y2) - "Block diary entry. -Entry applies if date is between two dates. Order of the parameters is -M1, D1, Y1, M2, D2, Y2 `european-calendar-style' is nil, and -D1, M1, Y1, D2, M2, Y2 if `european-calendar-style' is t." - (let ((date1 (calendar-absolute-from-gregorian - (if european-calendar-style - (list d1 m1 y1) - (list m1 d1 y1)))) - (date2 (calendar-absolute-from-gregorian - (if european-calendar-style - (list d2 m2 y2) - (list m2 d2 y2)))) - (d (calendar-absolute-from-gregorian date))) - (if (and (<= date1 d) (<= d date2)) - entry))) - -(defun diary-float (month dayname n) - "Floating diary entry--entry applies if date is the nth dayname of month. -Parameters are MONTH, DAYNAME, N. MONTH can be a list of months, the constant -t, or an integer. The constant t means all months. If N is negative, count -backward from the end of the month." - (let ((m (extract-calendar-month date)) - (y (extract-calendar-year date))) - (if (and - (or (and (listp month) (memq m month)) - (equal m month) - (eq month t)) - (calendar-date-equal date (calendar-nth-named-day n dayname m y))) - entry))) - -(defun diary-anniversary (month day year) - "Anniversary diary entry. -Entry applies if date is the anniversary of MONTH, DAY, YEAR if -`european-calendar-style' is nil, and DAY, MONTH, YEAR if -`european-calendar-style' is t. Diary entry can contain `%d' or `%d%s'; the -%d will be replaced by the number of years since the MONTH DAY, YEAR and the -%s will be replaced by the ordinal ending of that number (that is, `st', `nd', -`rd' or `th', as appropriate. The anniversary of February 29 is considered -to be March 1 in non-leap years." - (let* ((d (if european-calendar-style - month - day)) - (m (if european-calendar-style - day - month)) - (y (extract-calendar-year date)) - (diff (- y year))) - (if (and (= m 2) (= d 29) (not (calendar-leap-year-p y))) - (setq m 3 - d 1)) - (if (and (> diff 0) (calendar-date-equal (list m d y) date)) - (format entry diff (diary-ordinal-suffix diff))))) - -(defun diary-cyclic (n month day year) - "Cycle diary entry--entry applies every N days starting at MONTH, DAY, YEAR. -If `european-calendar-style' is t, parameters are N, DAY, MONTH, YEAR. -ENTRY can contain `%d' or `%d%s'; the %d will be replaced by the number of -years since the MONTH DAY, YEAR and the %s will be replaced by the ordinal -ending of that number (that is, `st', `nd', `rd' or `th', as appropriate." - (let* ((d (if european-calendar-style - month - day)) - (m (if european-calendar-style - day - month)) - (diff (- (calendar-absolute-from-gregorian date) - (calendar-absolute-from-gregorian - (list m d year)))) - (cycle (/ diff n))) - (if (and (>= diff 0) (zerop (% diff n))) - (format entry cycle (diary-ordinal-suffix cycle))))) - -(defun diary-ordinal-suffix (n) - "Ordinal suffix for N. (That is, `st', `nd', `rd', or `th', as appropriate.)" - (if (or (memq (% n 100) '(11 12 13)) - (< 3 (% n 10))) - "th" - (aref ["th" "st" "nd" "rd"] (% n 10)))) - -(defun diary-day-of-year () - "Day of year and number of days remaining in the year of date diary entry." - (calendar-day-of-year-string date)) - -(defun diary-iso-date () - "ISO calendar equivalent of date diary entry." - (format "ISO date: %s" (calendar-iso-date-string date))) - -(defun diary-islamic-date () - "Islamic calendar equivalent of date diary entry." - (let ((i (calendar-islamic-date-string (calendar-cursor-to-date t)))) - (if (string-equal i "") - "Date is pre-Islamic" - (format "Islamic date (until sunset): %s" i)))) - -(defun diary-hebrew-date () - "Hebrew calendar equivalent of date diary entry." - (format "Hebrew date (until sunset): %s" (calendar-hebrew-date-string date))) - -(defun diary-julian-date () - "Julian calendar equivalent of date diary entry." - (format "Julian date: %s" (calendar-julian-date-string date))) - -(defun diary-astro-day-number () - "Astronomical (Julian) day number diary entry." - (format "Astronomical (Julian) day number %s" - (calendar-astro-date-string date))) - -(defun diary-omer () - "Omer count diary entry. -Entry applies if date is within 50 days after Passover." - (let* ((passover - (calendar-absolute-from-hebrew - (list 1 15 (+ (extract-calendar-year date) 3760)))) - (omer (- (calendar-absolute-from-gregorian date) passover)) - (week (/ omer 7)) - (day (% omer 7))) - (if (and (> omer 0) (< omer 50)) - (format "Day %d%s of the omer (until sunset)" - omer - (if (zerop week) - "" - (format ", that is, %d week%s%s" - week - (if (= week 1) "" "s") - (if (zerop day) - "" - (format " and %d day%s" - day (if (= day 1) "" "s"))))))))) - -(defun diary-yahrzeit (death-month death-day death-year) - "Yahrzeit diary entry--entry applies if date is yahrzeit or the day before. -Parameters are DEATH-MONTH, DEATH-DAY, DEATH-YEAR; the diary entry is assumed -to be the name of the person. Date of death is on the *civil* calendar; -although the date of death is specified by the civil calendar, the proper -Hebrew calendar yahrzeit is determined. If `european-calendar-style' is t, the -order of the parameters is changed to DEATH-DAY, DEATH-MONTH, DEATH-YEAR." - (let* ((h-date (calendar-hebrew-from-absolute - (calendar-absolute-from-gregorian - (if european-calendar-style - (list death-day death-month death-year) - (list death-month death-day death-year))))) - (h-month (extract-calendar-month h-date)) - (h-day (extract-calendar-day h-date)) - (h-year (extract-calendar-year h-date)) - (d (calendar-absolute-from-gregorian date)) - (yr (extract-calendar-year (calendar-hebrew-from-absolute d))) - (diff (- yr h-year)) - (y (hebrew-calendar-yahrzeit h-date yr))) - (if (and (> diff 0) (or (= y d) (= y (1+ d)))) - (format "Yahrzeit of %s%s: %d%s anniversary" - entry - (if (= y d) "" " (evening)") - diff - (cond ((= (% diff 10) 1) "st") - ((= (% diff 10) 2) "nd") - ((= (% diff 10) 3) "rd") - (t "th")))))) - -(defun diary-rosh-hodesh () - "Rosh Hodesh diary entry. -Entry applies if date is Rosh Hodesh, the day before, or the Saturday before." - (let* ((d (calendar-absolute-from-gregorian date)) - (h-date (calendar-hebrew-from-absolute d)) - (h-month (extract-calendar-month h-date)) - (h-day (extract-calendar-day h-date)) - (h-year (extract-calendar-year h-date)) - (leap-year (hebrew-calendar-leap-year-p h-year)) - (last-day (hebrew-calendar-last-day-of-month h-month h-year)) - (h-month-names - (if leap-year - calendar-hebrew-month-name-array-leap-year - calendar-hebrew-month-name-array-common-year)) - (this-month (aref h-month-names (1- h-month))) - (h-yesterday (extract-calendar-day - (calendar-hebrew-from-absolute (1- d))))) - (if (or (= h-day 30) (and (= h-day 1) (/= h-month 7))) - (format - "Rosh Hodesh %s" - (if (= h-day 30) - (format - "%s (first day)" - ;; next month must be in the same year since this - ;; month can't be the last month of the year since - ;; it has 30 days - (aref h-month-names h-month)) - (if (= h-yesterday 30) - (format "%s (second day)" this-month) - this-month))) - (if (= (% d 7) 6);; Saturday--check for Shabbat Mevarhim - (cond ((and (> h-day 22) (/= h-month 6) (= 29 last-day)) - (format "Mevarhim Rosh Hodesh %s (%s)" - (aref h-month-names - (if (= h-month - (hebrew-calendar-last-month-of-year - h-year)) - 0 h-month)) - (aref calendar-day-name-array (- 29 h-day)))) - ((and (< h-day 30) (> h-day 22) (= 30 last-day)) - (format "Mevarhim Rosh Hodesh %s (%s-%s)" - (aref h-month-names h-month) - (if (= h-day 29) - "tomorrow" - (aref calendar-day-name-array (- 29 h-day))) - (aref calendar-day-name-array - (% (- 30 h-day) 7))))) - (if (and (= h-day 29) (/= h-month 6)) - (format "Erev Rosh Hodesh %s" - (aref h-month-names - (if (= h-month - (hebrew-calendar-last-month-of-year - h-year)) - 0 h-month)))))))) - -(defun diary-parasha () - "Parasha diary entry--entry applies if date is a Saturday." - (let ((d (calendar-absolute-from-gregorian date))) - (if (= (% d 7) 6);; Saturday - (let* - ((h-year (extract-calendar-year - (calendar-hebrew-from-absolute d))) - (rosh-hashannah - (calendar-absolute-from-hebrew (list 7 1 h-year))) - (passover - (calendar-absolute-from-hebrew (list 1 15 h-year))) - (rosh-hashannah-day - (aref calendar-day-name-array (% rosh-hashannah 7))) - (passover-day - (aref calendar-day-name-array (% passover 7))) - (long-h (hebrew-calendar-long-heshvan-p h-year)) - (short-k (hebrew-calendar-short-kislev-p h-year)) - (type (cond ((and long-h (not short-k)) "complete") - ((and (not long-h) short-k) "incomplete") - (t "regular"))) - (year-format - (symbol-value - (intern (format "hebrew-calendar-year-%s-%s-%s";; keviah - rosh-hashannah-day type passover-day)))) - (first-saturday;; of Hebrew year - (calendar-dayname-on-or-before 6 (+ 6 rosh-hashannah))) - (saturday;; which Saturday of the Hebrew year - (/ (- d first-saturday) 7)) - (parasha (aref year-format saturday))) - (if parasha - (format - "Parashat %s" - (if (listp parasha);; Israel differs from diaspora - (if (car parasha) - (format "%s (diaspora), %s (Israel)" - (hebrew-calendar-parasha-name (car parasha)) - (hebrew-calendar-parasha-name (cdr parasha))) - (format "%s (Israel)" - (hebrew-calendar-parasha-name (cdr parasha)))) - (hebrew-calendar-parasha-name parasha)))))))) - -(defun add-to-diary-list (date string) - "Add the entry (DATE STRING) to `diary-entries-list'. -Do nothing if DATE or STRING is nil." - (and date string - (setq diary-entries-list - (append diary-entries-list (list (list date string)))))) - -(defvar hebrew-calendar-parashiot-names -["Bereshith" "Noah" "Lech L'cha" "Vayera" "Hayei Sarah" "Toledoth" - "Vayetze" "Vayishlah" "Vayeshev" "Mikketz" "Vayiggash" "Vayhi" - "Shemoth" "Vaera" "Bo" "Beshallah" "Yithro" "Mishpatim" - "Terumah" "Tetzavveh" "Ki Tissa" "Vayakhel" "Pekudei" "Vayikra" - "Tzav" "Shemini" "Tazria" "Metzora" "Aharei Moth" "Kedoshim" - "Emor" "Behar" "Behukkotai" "Bemidbar" "Naso" "Behaalot'cha" - "Shelah L'cha" "Korah" "Hukkath" "Balak" "Pinhas" "Mattoth" - "Masei" "Devarim" "Vaethanan" "Ekev" "Reeh" "Shofetim" - "Ki Tetze" "Ki Tavo" "Nitzavim" "Vayelech" "Haazinu"] - "The names of the parashiot in the Torah.") - -;; The seven ordinary year types (keviot) - -(defconst hebrew-calendar-year-Saturday-incomplete-Sunday - [nil 52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22] - 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42] - 43 44 45 46 47 48 49 50] - "The structure of the parashiot. -Hebrew year starts on Saturday, is `incomplete' (Heshvan and Kislev each have -29 days), and has Passover start on Sunday.") - -(defconst hebrew-calendar-year-Saturday-complete-Tuesday - [nil 52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22] - 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42] - 43 44 45 46 47 48 49 [50 51]] - "The structure of the parashiot. -Hebrew year that starts on Saturday, is `complete' (Heshvan and Kislev each -have 30 days), and has Passover start on Tuesday.") - -(defconst hebrew-calendar-year-Monday-incomplete-Tuesday - [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22] - 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42] - 43 44 45 46 47 48 49 [50 51]] - "The structure of the parashiot. -Hebrew year that starts on Monday, is `incomplete' (Heshvan and Kislev each -have 29 days), and has Passover start on Tuesday.") - -(defconst hebrew-calendar-year-Monday-complete-Thursday - [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22] - 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 (nil . 34) (34 . 35) (35 . 36) - (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]] - "The structure of the parashiot. -Hebrew year that starts on Monday, is `complete' (Heshvan and Kislev each have -30 days), and has Passover start on Thursday.") - -(defconst hebrew-calendar-year-Tuesday-regular-Thursday - [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22] - 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 (nil . 34) (34 . 35) (35 . 36) - (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]] - "The structure of the parashiot. -Hebrew year that starts on Tuesday, is `regular' (Heshvan has 29 days and -Kislev has 30 days), and has Passover start on Thursday.") - -(defconst hebrew-calendar-year-Thursday-regular-Saturday - [52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22] 23 - 24 nil (nil . 25) (25 . [26 27]) ([26 27] . [28 29]) ([28 29] . 30) - (30 . 31) ([31 32] . 32) 33 34 35 36 37 38 39 40 [41 42] 43 44 45 46 47 48 - 49 50] - "The structure of the parashiot. -Hebrew year that starts on Thursday, is `regular' (Heshvan has 29 days and -Kislev has 30 days), and has Passover start on Saturday.") - -(defconst hebrew-calendar-year-Thursday-complete-Sunday - [52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 - 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42] - 43 44 45 46 47 48 49 50] - "The structure of the parashiot. -Hebrew year that starts on Thursday, is `complete' (Heshvan and Kislev each -have 30 days), and has Passover start on Sunday.") - -;; The seven leap year types (keviot) - -(defconst hebrew-calendar-year-Saturday-incomplete-Tuesday - [nil 52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 - 23 24 25 26 27 nil 28 29 30 31 32 33 34 35 36 37 38 39 40 [41 42] - 43 44 45 46 47 48 49 [50 51]] - "The structure of the parashiot. -Hebrew year that starts on Saturday, is `incomplete' (Heshvan and Kislev each -have 29 days), and has Passover start on Tuesday.") - -(defconst hebrew-calendar-year-Saturday-complete-Thursday - [nil 52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 - 23 24 25 26 27 nil 28 29 30 31 32 33 (nil . 34) (34 . 35) (35 . 36) - (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]] - "The structure of the parashiot. -Hebrew year that starts on Saturday, is `complete' (Heshvan and Kislev each -have 30 days), and has Passover start on Thursday.") - -(defconst hebrew-calendar-year-Monday-incomplete-Thursday - [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 - 23 24 25 26 27 nil 28 29 30 31 32 33 (nil . 34) (34 . 35) (35 . 36) - (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]] - "The structure of the parashiot. -Hebrew year that starts on Monday, is `incomplete' (Heshvan and Kislev each -have 29 days), and has Passover start on Thursday.") - -(defconst hebrew-calendar-year-Monday-complete-Saturday - [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 - 23 24 25 26 27 nil (nil . 28) (28 . 29) (29 . 30) (30 . 31) (31 . 32) - (32 . 33) (33 . 34) (34 . 35) (35 . 36) (36 . 37) (37 . 38) (38 . 39) - (39 . 40) (40 . 41) ([41 42] . 42) 43 44 45 46 47 48 49 50] - "The structure of the parashiot. -Hebrew year that starts on Monday, is `complete' (Heshvan and Kislev each have -30 days), and has Passover start on Saturday.") - -(defconst hebrew-calendar-year-Tuesday-regular-Saturday - [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 - 23 24 25 26 27 nil (nil . 28) (28 . 29) (29 . 30) (30 . 31) (31 . 32) - (32 . 33) (33 . 34) (34 . 35) (35 . 36) (36 . 37) (37 . 38) (38 . 39) - (39 . 40) (40 . 41) ([41 42] . 42) 43 44 45 46 47 48 49 50] - "The structure of the parashiot. -Hebrew year that starts on Tuesday, is `regular' (Heshvan has 29 days and -Kislev has 30 days), and has Passover start on Saturday.") - -(defconst hebrew-calendar-year-Thursday-incomplete-Sunday - [52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 - 23 24 25 26 27 28 nil 29 30 31 32 33 34 35 36 37 38 39 40 41 42 - 43 44 45 46 47 48 49 50] - "The structure of the parashiot. -Hebrew year that starts on Thursday, is `incomplete' (Heshvan and Kislev both -have 29 days), and has Passover start on Sunday.") - -(defconst hebrew-calendar-year-Thursday-complete-Tuesday - [52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 - 23 24 25 26 27 28 nil 29 30 31 32 33 34 35 36 37 38 39 40 41 42 - 43 44 45 46 47 48 49 [50 51]] - "The structure of the parashiot. -Hebrew year that starts on Thursday, is `complete' (Heshvan and Kislev both -have 30 days), and has Passover start on Tuesday.") - -(defun hebrew-calendar-parasha-name (p) - "Name(s) corresponding to parasha P." - (if (arrayp p);; combined parasha - (format "%s/%s" - (aref hebrew-calendar-parashiot-names (aref p 0)) - (aref hebrew-calendar-parashiot-names (aref p 1))) - (aref hebrew-calendar-parashiot-names p))) - -(defun list-islamic-diary-entries () - "Add any Islamic date entries from the diary file to `diary-entries-list'. -Islamic date diary entries must be prefaced by an `islamic-diary-entry-symbol' -\(normally an `I'). The same diary date forms govern the style of the Islamic -calendar entries, except that the Islamic month names must be spelled in full. -The Islamic months are numbered from 1 to 12 with Muharram being 1 and 12 being -Dhu al-Hijjah. If an Islamic date diary entry begins with a -`diary-nonmarking-symbol', the entry will appear in the diary listing, but will -not be marked in the calendar. This function is provided for use with the -`nongregorian-diary-listing-hook'." - (if (< 0 number) - (let ((buffer-read-only nil) - (diary-modified (buffer-modified-p)) - (gdate original-date) - (mark (regexp-quote diary-nonmarking-symbol))) - (calendar-for-loop i from 1 to number do - (let* ((d diary-date-forms) - (idate (calendar-islamic-from-absolute - (calendar-absolute-from-gregorian gdate))) - (month (extract-calendar-month idate)) - (day (extract-calendar-day idate)) - (year (extract-calendar-year idate))) - (while d - (let* - ((date-form (if (equal (car (car d)) 'backup) - (cdr (car d)) - (car d))) - (backup (equal (car (car d)) 'backup)) - (dayname - (concat - (calendar-day-name gdate) "\\|" - (substring (calendar-day-name gdate) 0 3) ".?")) - (calendar-month-name-array - calendar-islamic-month-name-array) - (monthname - (concat - "\\*\\|" - (calendar-month-name month))) - (month (concat "\\*\\|0*" (int-to-string month))) - (day (concat "\\*\\|0*" (int-to-string day))) - (year - (concat - "\\*\\|0*" (int-to-string year) - (if abbreviated-calendar-year - (concat "\\|" (int-to-string (% year 100))) - ""))) - (regexp - (concat - "\\(\\`\\|\^M\\|\n\\)" mark "?" - (regexp-quote islamic-diary-entry-symbol) - "\\(" - (mapconcat 'eval date-form "\\)\\(") - "\\)")) - (case-fold-search t)) - (goto-char (point-min)) - (while (re-search-forward regexp nil t) - (if backup (re-search-backward "\\<" nil t)) - (if (and (or (char-equal (preceding-char) ?\^M) - (char-equal (preceding-char) ?\n)) - (not (looking-at " \\|\^I"))) - ;; Diary entry that consists only of date. - (backward-char 1) - ;; Found a nonempty diary entry--make it visible and - ;; add it to the list. - (let ((entry-start (point)) - (date-start)) - (re-search-backward "\^M\\|\n\\|\\`") - (setq date-start (point)) - (re-search-forward "\^M\\|\n" nil t 2) - (while (looking-at " \\|\^I") - (re-search-forward "\^M\\|\n" nil t)) - (backward-char 1) - (subst-char-in-region date-start (point) ?\^M ?\n t) - (add-to-diary-list - gdate (buffer-substring entry-start (point))))))) - (setq d (cdr d)))) - (setq gdate - (calendar-gregorian-from-absolute - (1+ (calendar-absolute-from-gregorian gdate))))) - (set-buffer-modified-p diary-modified)) - (goto-char (point-min)))) - -(defun mark-islamic-diary-entries () - "Mark days in the calendar window that have Islamic date diary entries. -Each entry in diary-file (or included files) visible in the calendar window -is marked. Islamic date entries are prefaced by a islamic-diary-entry-symbol -\(normally an `I'). The same diary-date-forms govern the style of the Islamic -calendar entries, except that the Islamic month names must be spelled in full. -The Islamic months are numbered from 1 to 12 with Muharram being 1 and 12 being -Dhu al-Hijjah. Islamic date diary entries that begin with a -diary-nonmarking-symbol will not be marked in the calendar. This function is -provided for use as part of the nongregorian-diary-marking-hook." - (let ((d diary-date-forms)) - (while d - (let* - ((date-form (if (equal (car (car d)) 'backup) - (cdr (car d)) - (car d)));; ignore 'backup directive - (dayname (diary-name-pattern calendar-day-name-array)) - (monthname - (concat - (diary-name-pattern calendar-islamic-month-name-array t) - "\\|\\*")) - (month "[0-9]+\\|\\*") - (day "[0-9]+\\|\\*") - (year "[0-9]+\\|\\*") - (l (length date-form)) - (d-name-pos (- l (length (memq 'dayname date-form)))) - (d-name-pos (if (/= l d-name-pos) (+ 2 d-name-pos))) - (m-name-pos (- l (length (memq 'monthname date-form)))) - (m-name-pos (if (/= l m-name-pos) (+ 2 m-name-pos))) - (d-pos (- l (length (memq 'day date-form)))) - (d-pos (if (/= l d-pos) (+ 2 d-pos))) - (m-pos (- l (length (memq 'month date-form)))) - (m-pos (if (/= l m-pos) (+ 2 m-pos))) - (y-pos (- l (length (memq 'year date-form)))) - (y-pos (if (/= l y-pos) (+ 2 y-pos))) - (regexp - (concat - "\\(\\`\\|\^M\\|\n\\)" - (regexp-quote islamic-diary-entry-symbol) - "\\(" - (mapconcat 'eval date-form "\\)\\(") - "\\)")) - (case-fold-search t)) - (goto-char (point-min)) - (while (re-search-forward regexp nil t) - (let* ((dd-name - (if d-name-pos - (buffer-substring - (match-beginning d-name-pos) - (match-end d-name-pos)))) - (mm-name - (if m-name-pos - (buffer-substring - (match-beginning m-name-pos) - (match-end m-name-pos)))) - (mm (string-to-int - (if m-pos - (buffer-substring - (match-beginning m-pos) - (match-end m-pos)) - ""))) - (dd (string-to-int - (if d-pos - (buffer-substring - (match-beginning d-pos) - (match-end d-pos)) - ""))) - (y-str (if y-pos - (buffer-substring - (match-beginning y-pos) - (match-end y-pos)))) - (yy (if (not y-str) - 0 - (if (and (= (length y-str) 2) - abbreviated-calendar-year) - (let* ((current-y - (extract-calendar-year - (calendar-islamic-from-absolute - (calendar-absolute-from-gregorian - (calendar-current-date))))) - (y (+ (string-to-int y-str) - (* 100 (/ current-y 100))))) - (if (> (- y current-y) 50) - (- y 100) - (if (> (- current-y y) 50) - (+ y 100) - y))) - (string-to-int y-str))))) - (if dd-name - (mark-calendar-days-named - (cdr (assoc (capitalize (substring dd-name 0 3)) - (calendar-make-alist - calendar-day-name-array - 0 - '(lambda (x) (substring x 0 3)))))) - (if mm-name - (if (string-equal mm-name "*") - (setq mm 0) - (setq mm - (cdr (assoc - (capitalize mm-name) - (calendar-make-alist - calendar-islamic-month-name-array)))))) - (mark-islamic-calendar-date-pattern mm dd yy))))) - (setq d (cdr d))))) - -(defun mark-islamic-calendar-date-pattern (month day year) - "Mark dates in calendar window that conform to Islamic date MONTH/DAY/YEAR. -A value of 0 in any position is a wildcard." - (save-excursion - (set-buffer calendar-buffer) - (if (and (/= 0 month) (/= 0 day)) - (if (/= 0 year) - ;; Fully specified Islamic date. - (let ((date (calendar-gregorian-from-absolute - (calendar-absolute-from-islamic - (list month day year))))) - (if (calendar-date-is-visible-p date) - (mark-visible-calendar-date date))) - ;; Month and day in any year--this taken from the holiday stuff. - (let* ((islamic-date (calendar-islamic-from-absolute - (calendar-absolute-from-gregorian - (list displayed-month 15 displayed-year)))) - (m (extract-calendar-month islamic-date)) - (y (extract-calendar-year islamic-date)) - (date)) - (if (< m 1) - nil;; Islamic calendar doesn't apply. - (increment-calendar-month m y (- 10 month)) - (if (> m 7);; Islamic date might be visible - (let ((date (calendar-gregorian-from-absolute - (calendar-absolute-from-islamic - (list month day y))))) - (if (calendar-date-is-visible-p date) - (mark-visible-calendar-date date))))))) - ;; Not one of the simple cases--check all visible dates for match. - ;; Actually, the following code takes care of ALL of the cases, but - ;; it's much too slow to be used for the simple (common) cases. - (let ((m displayed-month) - (y displayed-year) - (first-date) - (last-date)) - (increment-calendar-month m y -1) - (setq first-date - (calendar-absolute-from-gregorian - (list m 1 y))) - (increment-calendar-month m y 2) - (setq last-date - (calendar-absolute-from-gregorian - (list m (calendar-last-day-of-month m y) y))) - (calendar-for-loop date from first-date to last-date do - (let* ((i-date (calendar-islamic-from-absolute date)) - (i-month (extract-calendar-month i-date)) - (i-day (extract-calendar-day i-date)) - (i-year (extract-calendar-year i-date))) - (and (or (zerop month) - (= month i-month)) - (or (zerop day) - (= day i-day)) - (or (zerop year) - (= year i-year)) - (mark-visible-calendar-date - (calendar-gregorian-from-absolute date))))))))) - -(provide 'diary-lib) - -;;; diary-lib.el ends here diff --git a/lisp/ftp.el b/lisp/ftp.el deleted file mode 100644 index 01186dda27a..00000000000 --- a/lisp/ftp.el +++ /dev/null @@ -1,392 +0,0 @@ -;;; ftp.el --- file input and output over Internet using FTP - -;; Copyright (C) 1987 Free Software Foundation, Inc. - -;; Author: Richard Mlynarik <mly@prep.ai.mit.edu> - -;; 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, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; Code: - -;; Prevent changes in major modes from altering these variables. -(put 'ftp-temp-file-name 'permanent-local t) -(put 'ftp-file 'permanent-local t) -(put 'ftp-host 'permanent-local t) - -;; you can turn this off by doing -;; (setq ftp-password-alist 'compulsory-urinalysis) -(defvar ftp-password-alist () "Security sucks") - -(defun read-ftp-user-password (host user new) - (let (tem) - (if (and (not new) - (listp ftp-password-alist) - (setq tem (cdr (assoc host ftp-password-alist))) - (or (null user) - (string= user (car tem)))) - tem - (or user - (progn - (setq tem (or (and (listp ftp-password-alist) - (car (cdr (assoc host ftp-password-alist)))) - (user-login-name))) - (setq user (read-string (format - "User-name for %s (default \"%s\"): " - host tem))) - (if (equal user "") (setq user tem)))) - (setq tem (cons user - ;; If you want to use some non-echoing string-reader, - ;; feel free to write it yourself. I don't care enough. - (read-string (format "Password for %s@%s: " user host) - (if (not (listp ftp-password-alist)) - "" - (or (cdr (cdr (assoc host ftp-password-alist))) - (let ((l ftp-password-alist)) - (catch 'foo - (while l - (if (string= (car (cdr (car l))) user) - (throw 'foo (cdr (cdr (car l)))) - (setq l (cdr l)))) - nil)) - ""))))) - (message "") - (if (and (listp ftp-password-alist) - (not (string= (cdr tem) ""))) - (setq ftp-password-alist (cons (cons host tem) - ftp-password-alist))) - tem))) - -(defun ftp-read-file-name (prompt) - (let ((s "")) - (while (not (string-match "\\`[ \t]*\\([^ \t:]+\\)[ \t]*:\\(.+\\)\\'" s)) - (setq s (read-string prompt s))) - (list (substring s (match-beginning 1) (match-end 1)) - (substring s (match-beginning 2) (match-end 2))))) - - -;;;###autoload -(defun ftp-find-file (host file &optional user password) - "FTP to HOST to get FILE, logging in as USER with password PASSWORD. -Interactively, HOST and FILE are specified by reading a string with - a colon character separating the host from the filename. -USER and PASSWORD are defaulted from the values used when - last ftping from HOST (unless password-remembering is disabled). - Supply a password of the symbol `t' to override this default - (interactively, this is done by giving a prefix arg)" - (interactive - (append (ftp-read-file-name "FTP get host:file: ") - (list nil (not (null current-prefix-arg))))) - (ftp-find-file-or-directory host file t user password)) - -;;;###autoload -(defun ftp-list-directory (host file &optional user password) - "FTP to HOST to list DIRECTORY, logging in as USER with password PASSWORD. -Interactively, HOST and FILE are specified by reading a string with - a colon character separating the host from the filename. -USER and PASSWORD are defaulted from the values used when - last ftping from HOST (unless password-remembering is disabled). - Supply a password of the symbol `t' to override this default - (interactively, this is done by giving a prefix arg)" - (interactive - (append (ftp-read-file-name "FTP get host:directory: ") - (list nil (not (null current-prefix-arg))))) - (ftp-find-file-or-directory host file nil user password)) - -(defun ftp-find-file-or-directory (host file filep &optional user password) - "FTP to HOST to get FILE. Third arg is t for file, nil for directory. -Log in as USER with PASSWORD. If USER is nil or PASSWORD is nil or t, -we prompt for the user name and password." - (or (and user password (not (eq password t))) - (progn (setq user (read-ftp-user-password host user (eq password t)) - password (cdr user) - user (car user)))) - (let ((buffer (get-buffer-create (format "*ftp%s %s:%s*" - (if filep "" "-directory") - host file)))) - (set-buffer buffer) - (let ((process nil) - (case-fold-search nil)) - (let ((win nil)) - (unwind-protect - (progn - (setq process (ftp-setup-buffer host file)) - (if (setq win (ftp-login process host user password)) - (message "Logged in") - (error "Ftp login failed"))) - (or win (and process (delete-process process))))) - (message "Opening %s %s:%s..." (if filep "file" "directory") - host file) - (if (ftp-command process - (format "%s \"%s\" -\nquit\n" (if filep "get" "dir") - file) - "\\(150\\|125\\).*\n" - "200.*\n") - (progn (forward-line 1) - (let ((buffer-read-only nil)) - (delete-region (point-min) (point))) - (message "Retrieving %s:%s in background. Bye!" host file) - (set-process-sentinel process - 'ftp-asynchronous-input-sentinel) - process) - (switch-to-buffer buffer) - (let ((buffer-read-only nil)) - (insert-before-markers "<<<Ftp lost>>>")) - (delete-process process) - (error "Ftp %s:%s lost" host file))))) - - -;;;###autoload -(defun ftp-write-file (host file &optional user password) - "FTP to HOST to write FILE, logging in as USER with password PASSWORD. -Interactively, HOST and FILE are specified by reading a string with colon -separating the host from the filename. -USER and PASSWORD are defaulted from the values used when - last ftping from HOST (unless `password-remembering' is disabled). - Supply a password of the symbol `t' to override this default - (interactively, this is done by giving a prefix arg)" - (interactive - (append (ftp-read-file-name "FTP write host:file: ") - (list nil (not (null current-prefix-arg))))) - (or (and user password (not (eq password t))) - (progn (setq user (read-ftp-user-password host user (eq password t)) - password (cdr user) - user (car user)))) - (let ((buffer (get-buffer-create (format "*ftp %s:%s*" host file))) - (tmp (make-temp-name "/tmp/emacsftp"))) - (write-region (point-min) (point-max) tmp) - (save-excursion - (set-buffer buffer) - (make-local-variable 'ftp-temp-file-name) - (setq ftp-temp-file-name tmp) - (let ((process (ftp-setup-buffer host file)) - (case-fold-search nil)) - (let ((win nil)) - (unwind-protect - (if (setq win (ftp-login process host user password)) - (message "Logged in") - (error "Ftp login lost")) - (or win (delete-process process)))) - (message "Opening file %s:%s..." host file) - (if (ftp-command process - (format "send \"%s\" \"%s\"\nquit\n" tmp file) - "\\(150\\|125\\).*\n" - "200.*\n") - (progn (forward-line 1) - (setq foo1 (current-buffer)) - (let ((buffer-read-only nil)) - (delete-region (point-min) (point))) - (message "Saving %s:%s in background. Bye!" host file) - (set-process-sentinel process - 'ftp-asynchronous-output-sentinel) - process) - (switch-to-buffer buffer) - (setq foo2 (current-buffer)) - (let ((buffer-read-only nil)) - (insert-before-markers "<<<Ftp lost>>>")) - (delete-process process) - (error "Ftp write %s:%s lost" host file)))))) - - -(defun ftp-setup-buffer (host file) - (fundamental-mode) - (and (get-buffer-process (current-buffer)) - (progn (discard-input) - (if (y-or-n-p (format "Kill process \"%s\" in %s? " - (process-name (get-buffer-process - (current-buffer))) - (buffer-name (current-buffer)))) - (while (get-buffer-process (current-buffer)) - (kill-process (get-buffer-process (current-buffer)))) - (error "Foo")))) - ;(buffer-disable-undo (current-buffer)) - (setq buffer-read-only nil) - (erase-buffer) - (make-local-variable 'ftp-host) - (setq ftp-host host) - (make-local-variable 'ftp-file) - (setq ftp-file file) - (setq foo3 (current-buffer)) - (setq buffer-read-only t) - (start-process "ftp" (current-buffer) "ftp" "-i" "-n" "-g")) - - -(defun ftp-login (process host user password) - (message "FTP logging in as %s@%s..." user host) - (if (ftp-command process - (format "open %s\nuser %s %s\n" host user password) - "230.*\n" - "\\(Connected to \\|220\\|331\\|Remote system type\\|Using.*mode\\|Remember to set\\).*\n") - t - (switch-to-buffer (process-buffer process)) - (delete-process process) - (if (listp ftp-password-alist) - (setq ftp-password-alist (delq (assoc host ftp-password-alist) - ftp-password-alist))) - nil)) - -(defun ftp-command (process command win ignore) - (process-send-string process command) - (let ((p 1)) - (while (numberp p) - (cond ;((not (bolp))) - ((looking-at "^[0-9]+-") - (while (not (re-search-forward "^[0-9]+ " nil t)) - (save-excursion - (accept-process-output process))) - (beginning-of-line)) - ((looking-at win) - (goto-char (point-max)) - (setq p t)) - ((looking-at "^ftp> \\|^\n") - (goto-char (match-end 0))) - ((looking-at ignore) - ;; Ignore status messages whose codes indicate no problem. - (forward-line 1)) - ((looking-at "^[^0-9]") - ;; Ignore any lines that don't have status codes. - (forward-line 1)) - ((not (search-forward "\n" nil t)) - ;; the way asynchronous process-output works with (point) - ;; is really really disgusting. - (setq p (point)) - (condition-case () - (accept-process-output process) - (error nil)) - (goto-char p)) - (t - (setq p nil)))) - p)) - - -(defun ftp-asynchronous-input-sentinel (process msg) - (ftp-sentinel process msg t t)) -(defun ftp-synchronous-input-sentinel (process msg) - (ftp-sentinel process msg nil t)) -(defun ftp-asynchronous-output-sentinel (process msg) - (ftp-sentinel process msg t nil)) -(defun ftp-synchronous-output-sentinel (process msg) - (ftp-sentinel process msg nil nil)) - -(defun ftp-sentinel (process msg asynchronous input) - (cond ((null (buffer-name (process-buffer process))) - ;; deleted buffer - (set-process-buffer process nil)) - ((and (eq (process-status process) 'exit) - (= (process-exit-status process) 0)) - (save-excursion - (set-buffer (process-buffer process)) - (let (msg - (r (if input "[0-9]+ bytes received in [0-9]+\\.[0-9]+ seconds.*$" "[0-9]+ bytes sent in [0-9]+\\.[0-9]+ seconds.*$"))) - (goto-char (point-max)) - (search-backward "226 ") - (if (looking-at r) - (search-backward "226 ")) - (let ((p (point))) - (setq msg (concat (format "ftp %s %s:%s done" - (if input "read" "write") - ftp-host ftp-file) - (if (re-search-forward r nil t) - (concat ": " (buffer-substring - (match-beginning 0) - (match-end 0))) - ""))) - (delete-region p (point-max)) - (save-excursion - (set-buffer (get-buffer-create "*ftp log*")) - (let ((buffer-read-only nil)) - (insert msg ?\n)))) - ;; Note the preceding let must end here - ;; so it doesn't cross the (kill-buffer (current-buffer)). - (if (not input) - (progn - (condition-case () - (and (boundp 'ftp-temp-file-name) - ftp-temp-file-name - (delete-file ftp-temp-file-name)) - (error nil)) - ;; Kill the temporary buffer which the ftp process - ;; puts its output in. - (kill-buffer (current-buffer))) - ;; You don't want to look at this. - (let ((kludge (generate-new-buffer (format "%s:%s (ftp)" - ftp-host ftp-file)))) - (setq kludge (prog1 (buffer-name kludge) (kill-buffer kludge))) - (rename-buffer kludge) - ;; ok, you can look again now. - (set-buffer-modified-p nil) - (ftp-setup-write-file-hooks))) - (if (and asynchronous - ;(waiting-for-user-input-p) - ) - (progn (message "%s" msg) - (sleep-for 2)))))) - ((memq (process-status process) '(exit signal)) - (save-excursion - (set-buffer (process-buffer process)) - (setq msg (format "Ftp died (buffer %s): %s" - (buffer-name (current-buffer)) - msg)) - (let ((buffer-read-only nil)) - (goto-char (point-max)) - (insert ?\n ?\n msg)) - (delete-process proc) - (set-buffer (get-buffer-create "*ftp log*")) - (let ((buffer-read-only nil)) - (goto-char (point-max)) - (insert msg)) - (if (waiting-for-user-input-p) - (error "%s" msg)))))) - -(defun ftp-setup-write-file-hooks () - (let ((hooks write-file-hooks)) - (make-local-variable 'write-file-hooks) - (setq write-file-hooks (append write-file-hooks - '(ftp-write-file-hook)))) - (make-local-variable 'revert-buffer-function) - (setq revert-buffer-function 'ftp-revert-buffer) - (setq default-directory "/tmp/") - (setq buffer-file-name (concat default-directory - (make-temp-name - (buffer-name (current-buffer))))) - (setq buffer-read-only nil)) - -(defun ftp-write-file-hook () - (let ((process (ftp-write-file ftp-host ftp-file))) - (set-process-sentinel process 'ftp-synchronous-output-sentinel) - (message "FTP writing %s:%s..." ftp-host ftp-file) - (while (eq (process-status process) 'run) - (condition-case () - (accept-process-output process) - (error nil))) - (set-buffer-modified-p nil) - (message "FTP writing %s:%s...done" ftp-host ftp-file)) - t) - -(defun ftp-revert-buffer (&rest ignore) - (let ((process (ftp-find-file ftp-host ftp-file))) - (set-process-sentinel process 'ftp-synchronous-input-sentinel) - (message "FTP reverting %s:%s" ftp-host ftp-file) - (while (eq (process-status process) 'run) - (condition-case () - (accept-process-output process) - (error nil))) - (and (eq (process-status process) 'exit) - (= (process-exit-status process) 0) - (set-buffer-modified-p nil)) - (message "Reverted"))) - -;;; ftp.el ends here diff --git a/lisp/gnus/md5.el b/lisp/gnus/md5.el deleted file mode 100644 index c27fc4afdda..00000000000 --- a/lisp/gnus/md5.el +++ /dev/null @@ -1,409 +0,0 @@ -;;; md5.el -- MD5 Message Digest Algorithm -;;; Gareth Rees <gdr11@cl.cam.ac.uk> - -;; LCD Archive Entry: -;; md5|Gareth Rees|gdr11@cl.cam.ac.uk| -;; MD5 cryptographic message digest algorithm| -;; 13-Nov-95|1.0|~/misc/md5.el.Z| - -;;; Details: ------------------------------------------------------------------ - -;; This is a direct translation into Emacs LISP of the reference C -;; implementation of the MD5 Message-Digest Algorithm written by RSA -;; Data Security, Inc. -;; -;; The algorithm takes a message (that is, a string of bytes) and -;; computes a 16-byte checksum or "digest" for the message. This digest -;; is supposed to be cryptographically strong in the sense that if you -;; are given a 16-byte digest D, then there is no easier way to -;; construct a message whose digest is D than to exhaustively search the -;; space of messages. However, the robustness of the algorithm has not -;; been proven, and a similar algorithm (MD4) was shown to be unsound, -;; so treat with caution! -;; -;; The C algorithm uses 32-bit integers; because GNU Emacs -;; implementations provide 28-bit integers (with 24-bit integers on -;; versions prior to 19.29), the code represents a 32-bit integer as the -;; cons of two 16-bit integers. The most significant word is stored in -;; the car and the least significant in the cdr. The algorithm requires -;; at least 17 bits of integer representation in order to represent the -;; carry from a 16-bit addition. - -;;; Usage: -------------------------------------------------------------------- - -;; To compute the MD5 Message Digest for a message M (represented as a -;; string or as a vector of bytes), call -;; -;; (md5-encode M) -;; -;; which returns the message digest as a vector of 16 bytes. If you -;; need to supply the message in pieces M1, M2, ... Mn, then call -;; -;; (md5-init) -;; (md5-update M1) -;; (md5-update M2) -;; ... -;; (md5-update Mn) -;; (md5-final) - -;;; Copyright and licence: ---------------------------------------------------- - -;; Copyright (C) 1995 by Gareth Rees -;; Derived from the RSA Data Security, Inc. MD5 Message-Digest Algorithm -;; -;; md5.el is free software; you can redistribute it and/or modify it -;; under the terms of the GNU General Public License as published by the -;; Free Software Foundation; either version 2, or (at your option) any -;; later version. -;; -;; md5.el is distributed in the hope that it will be useful, but WITHOUT -;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -;; for more details. -;; -;; The original copyright notice is given below, as required by the -;; licence for the original code. This code is distributed under *both* -;; RSA's original licence and the GNU General Public Licence. (There -;; should be no problems, as the former is more liberal than the -;; latter). - -;;; Original copyright notice: ------------------------------------------------ - -;; Copyright (C) 1990, RSA Data Security, Inc. All rights reserved. -;; -;; License to copy and use this software is granted provided that it is -;; identified as the "RSA Data Security, Inc. MD5 Message- Digest -;; Algorithm" in all material mentioning or referencing this software or -;; this function. -;; -;; License is also granted to make and use derivative works provided -;; that such works are identified as "derived from the RSA Data -;; Security, Inc. MD5 Message-Digest Algorithm" in all material -;; mentioning or referencing the derived work. -;; -;; RSA Data Security, Inc. makes no representations concerning either -;; the merchantability of this software or the suitability of this -;; software for any particular purpose. It is provided "as is" without -;; express or implied warranty of any kind. -;; -;; These notices must be retained in any copies of any part of this -;; documentation and/or software. - -;;; Code: --------------------------------------------------------------------- - -(defvar md5-program "md5" - "*Program that reads a message on its standard input and writes an -MD5 digest on its output.") - -(defvar md5-maximum-internal-length 4096 - "*The maximum size of a piece of data that should use the MD5 routines -written in lisp. If a message exceeds this, it will be run through an -external filter for processing. Also see the `md5-program' variable. -This variable has no effect if you call the md5-init|update|final -functions - only used by the `md5' function's simpler interface.") - -(defvar md5-bits (make-vector 4 0) - "Number of bits handled, modulo 2^64. -Represented as four 16-bit numbers, least significant first.") -(defvar md5-buffer (make-vector 4 '(0 . 0)) - "Scratch buffer (four 32-bit integers).") -(defvar md5-input (make-vector 64 0) - "Input buffer (64 bytes).") - -(defun md5-unhex (x) - (if (> x ?9) - (if (>= x ?a) - (+ 10 (- x ?a)) - (+ 10 (- x ?A))) - (- x ?0))) - -(defun md5-encode (message) - "Encodes MESSAGE using the MD5 message digest algorithm. -MESSAGE must be a string or an array of bytes. -Returns a vector of 16 bytes containing the message digest." - (if (<= (length message) md5-maximum-internal-length) - (progn - (md5-init) - (md5-update message) - (md5-final)) - (save-excursion - (set-buffer (get-buffer-create " *md5-work*")) - (erase-buffer) - (insert message) - (call-process-region (point-min) (point-max) - (or shell-file-name "/bin/sh") - t (current-buffer) nil - "-c" md5-program) - ;; MD5 digest is 32 chars long - ;; mddriver adds a newline to make neaten output for tty - ;; viewing, make sure we leave it behind. - (let ((data (buffer-substring (point-min) (+ (point-min) 32))) - (vec (make-vector 16 0)) - (ctr 0)) - (while (< ctr 16) - (aset vec ctr (+ (* 16 (md5-unhex (aref data (* ctr 2)))) - (md5-unhex (aref data (1+ (* ctr 2)))))) - (setq ctr (1+ ctr))))))) - -(defsubst md5-add (x y) - "Return 32-bit sum of 32-bit integers X and Y." - (let ((m (+ (car x) (car y))) - (l (+ (cdr x) (cdr y)))) - (cons (logand 65535 (+ m (lsh l -16))) (logand l 65535)))) - -;; FF, GG, HH and II are basic MD5 functions, providing transformations -;; for rounds 1, 2, 3 and 4 respectively. Each function follows this -;; pattern of computation (where ROTATE(x,y) means rotate 32-bit value x -;; by y bits to the left): -;; -;; FF(a,b,c,d,x,s,ac) = ROTATE(a + F(b,c,d) + x + ac,s) + b -;; -;; so we use the macro `md5-make-step' to construct each one. The -;; helper functions F, G, H and I operate on 16-bit numbers; the full -;; operation splits its inputs, operates on the halves separately and -;; then puts the results together. - -(defsubst md5-F (x y z) (logior (logand x y) (logand (lognot x) z))) -(defsubst md5-G (x y z) (logior (logand x z) (logand y (lognot z)))) -(defsubst md5-H (x y z) (logxor x y z)) -(defsubst md5-I (x y z) (logxor y (logior x (logand 65535 (lognot z))))) - -(defmacro md5-make-step (name func) - (` - (defun (, name) (a b c d x s ac) - (let* - ((m1 (+ (car a) ((, func) (car b) (car c) (car d)) (car x) (car ac))) - (l1 (+ (cdr a) ((, func) (cdr b) (cdr c) (cdr d)) (cdr x) (cdr ac))) - (m2 (logand 65535 (+ m1 (lsh l1 -16)))) - (l2 (logand 65535 l1)) - (m3 (logand 65535 (if (> s 15) - (+ (lsh m2 (- s 32)) (lsh l2 (- s 16))) - (+ (lsh m2 s) (lsh l2 (- s 16)))))) - (l3 (logand 65535 (if (> s 15) - (+ (lsh l2 (- s 32)) (lsh m2 (- s 16))) - (+ (lsh l2 s) (lsh m2 (- s 16))))))) - (md5-add (cons m3 l3) b))))) - -(md5-make-step md5-FF md5-F) -(md5-make-step md5-GG md5-G) -(md5-make-step md5-HH md5-H) -(md5-make-step md5-II md5-I) - -(defun md5-init () - "Initialise the state of the message-digest routines." - (aset md5-bits 0 0) - (aset md5-bits 1 0) - (aset md5-bits 2 0) - (aset md5-bits 3 0) - (aset md5-buffer 0 '(26437 . 8961)) - (aset md5-buffer 1 '(61389 . 43913)) - (aset md5-buffer 2 '(39098 . 56574)) - (aset md5-buffer 3 '( 4146 . 21622))) - -(defun md5-update (string) - "Update the current MD5 state with STRING (an array of bytes)." - (let ((len (length string)) - (i 0) - (j 0)) - (while (< i len) - ;; Compute number of bytes modulo 64 - (setq j (% (/ (aref md5-bits 0) 8) 64)) - - ;; Store this byte (truncating to 8 bits to be sure) - (aset md5-input j (logand 255 (aref string i))) - - ;; Update number of bits by 8 (modulo 2^64) - (let ((c 8) (k 0)) - (while (and (> c 0) (< k 4)) - (let ((b (aref md5-bits k))) - (aset md5-bits k (logand 65535 (+ b c))) - (setq c (if (> b (- 65535 c)) 1 0) - k (1+ k))))) - - ;; Increment number of bytes processed - (setq i (1+ i)) - - ;; When 64 bytes accumulated, pack them into sixteen 32-bit - ;; integers in the array `in' and then tranform them. - (if (= j 63) - (let ((in (make-vector 16 (cons 0 0))) - (k 0) - (kk 0)) - (while (< k 16) - (aset in k (md5-pack md5-input kk)) - (setq k (+ k 1) kk (+ kk 4))) - (md5-transform in)))))) - -(defun md5-pack (array i) - "Pack the four bytes at ARRAY reference I to I+3 into a 32-bit integer." - (cons (+ (lsh (aref array (+ i 3)) 8) (aref array (+ i 2))) - (+ (lsh (aref array (+ i 1)) 8) (aref array (+ i 0))))) - -(defun md5-byte (array n b) - "Unpack byte B (0 to 3) from Nth member of ARRAY of 32-bit integers." - (let ((e (aref array n))) - (cond ((eq b 0) (logand 255 (cdr e))) - ((eq b 1) (lsh (cdr e) -8)) - ((eq b 2) (logand 255 (car e))) - ((eq b 3) (lsh (car e) -8))))) - -(defun md5-final () - (let ((in (make-vector 16 (cons 0 0))) - (j 0) - (digest (make-vector 16 0)) - (padding)) - - ;; Save the number of bits in the message - (aset in 14 (cons (aref md5-bits 1) (aref md5-bits 0))) - (aset in 15 (cons (aref md5-bits 3) (aref md5-bits 2))) - - ;; Compute number of bytes modulo 64 - (setq j (% (/ (aref md5-bits 0) 8) 64)) - - ;; Pad out computation to 56 bytes modulo 64 - (setq padding (make-vector (if (< j 56) (- 56 j) (- 120 j)) 0)) - (aset padding 0 128) - (md5-update padding) - - ;; Append length in bits and transform - (let ((k 0) (kk 0)) - (while (< k 14) - (aset in k (md5-pack md5-input kk)) - (setq k (+ k 1) kk (+ kk 4)))) - (md5-transform in) - - ;; Store the results in the digest - (let ((k 0) (kk 0)) - (while (< k 4) - (aset digest (+ kk 0) (md5-byte md5-buffer k 0)) - (aset digest (+ kk 1) (md5-byte md5-buffer k 1)) - (aset digest (+ kk 2) (md5-byte md5-buffer k 2)) - (aset digest (+ kk 3) (md5-byte md5-buffer k 3)) - (setq k (+ k 1) kk (+ kk 4)))) - - ;; Return digest - digest)) - -;; It says in the RSA source, "Note that if the Mysterious Constants are -;; arranged backwards in little-endian order and decrypted with the DES -;; they produce OCCULT MESSAGES!" Security through obscurity? - -(defun md5-transform (in) - "Basic MD5 step. Transform md5-buffer based on array IN." - (let ((a (aref md5-buffer 0)) - (b (aref md5-buffer 1)) - (c (aref md5-buffer 2)) - (d (aref md5-buffer 3))) - (setq - a (md5-FF a b c d (aref in 0) 7 '(55146 . 42104)) - d (md5-FF d a b c (aref in 1) 12 '(59591 . 46934)) - c (md5-FF c d a b (aref in 2) 17 '( 9248 . 28891)) - b (md5-FF b c d a (aref in 3) 22 '(49597 . 52974)) - a (md5-FF a b c d (aref in 4) 7 '(62844 . 4015)) - d (md5-FF d a b c (aref in 5) 12 '(18311 . 50730)) - c (md5-FF c d a b (aref in 6) 17 '(43056 . 17939)) - b (md5-FF b c d a (aref in 7) 22 '(64838 . 38145)) - a (md5-FF a b c d (aref in 8) 7 '(27008 . 39128)) - d (md5-FF d a b c (aref in 9) 12 '(35652 . 63407)) - c (md5-FF c d a b (aref in 10) 17 '(65535 . 23473)) - b (md5-FF b c d a (aref in 11) 22 '(35164 . 55230)) - a (md5-FF a b c d (aref in 12) 7 '(27536 . 4386)) - d (md5-FF d a b c (aref in 13) 12 '(64920 . 29075)) - c (md5-FF c d a b (aref in 14) 17 '(42617 . 17294)) - b (md5-FF b c d a (aref in 15) 22 '(18868 . 2081)) - a (md5-GG a b c d (aref in 1) 5 '(63006 . 9570)) - d (md5-GG d a b c (aref in 6) 9 '(49216 . 45888)) - c (md5-GG c d a b (aref in 11) 14 '( 9822 . 23121)) - b (md5-GG b c d a (aref in 0) 20 '(59830 . 51114)) - a (md5-GG a b c d (aref in 5) 5 '(54831 . 4189)) - d (md5-GG d a b c (aref in 10) 9 '( 580 . 5203)) - c (md5-GG c d a b (aref in 15) 14 '(55457 . 59009)) - b (md5-GG b c d a (aref in 4) 20 '(59347 . 64456)) - a (md5-GG a b c d (aref in 9) 5 '( 8673 . 52710)) - d (md5-GG d a b c (aref in 14) 9 '(49975 . 2006)) - c (md5-GG c d a b (aref in 3) 14 '(62677 . 3463)) - b (md5-GG b c d a (aref in 8) 20 '(17754 . 5357)) - a (md5-GG a b c d (aref in 13) 5 '(43491 . 59653)) - d (md5-GG d a b c (aref in 2) 9 '(64751 . 41976)) - c (md5-GG c d a b (aref in 7) 14 '(26479 . 729)) - b (md5-GG b c d a (aref in 12) 20 '(36138 . 19594)) - a (md5-HH a b c d (aref in 5) 4 '(65530 . 14658)) - d (md5-HH d a b c (aref in 8) 11 '(34673 . 63105)) - c (md5-HH c d a b (aref in 11) 16 '(28061 . 24866)) - b (md5-HH b c d a (aref in 14) 23 '(64997 . 14348)) - a (md5-HH a b c d (aref in 1) 4 '(42174 . 59972)) - d (md5-HH d a b c (aref in 4) 11 '(19422 . 53161)) - c (md5-HH c d a b (aref in 7) 16 '(63163 . 19296)) - b (md5-HH b c d a (aref in 10) 23 '(48831 . 48240)) - a (md5-HH a b c d (aref in 13) 4 '(10395 . 32454)) - d (md5-HH d a b c (aref in 0) 11 '(60065 . 10234)) - c (md5-HH c d a b (aref in 3) 16 '(54511 . 12421)) - b (md5-HH b c d a (aref in 6) 23 '( 1160 . 7429)) - a (md5-HH a b c d (aref in 9) 4 '(55764 . 53305)) - d (md5-HH d a b c (aref in 12) 11 '(59099 . 39397)) - c (md5-HH c d a b (aref in 15) 16 '( 8098 . 31992)) - b (md5-HH b c d a (aref in 2) 23 '(50348 . 22117)) - a (md5-II a b c d (aref in 0) 6 '(62505 . 8772)) - d (md5-II d a b c (aref in 7) 10 '(17194 . 65431)) - c (md5-II c d a b (aref in 14) 15 '(43924 . 9127)) - b (md5-II b c d a (aref in 5) 21 '(64659 . 41017)) - a (md5-II a b c d (aref in 12) 6 '(25947 . 22979)) - d (md5-II d a b c (aref in 3) 10 '(36620 . 52370)) - c (md5-II c d a b (aref in 10) 15 '(65519 . 62589)) - b (md5-II b c d a (aref in 1) 21 '(34180 . 24017)) - a (md5-II a b c d (aref in 8) 6 '(28584 . 32335)) - d (md5-II d a b c (aref in 15) 10 '(65068 . 59104)) - c (md5-II c d a b (aref in 6) 15 '(41729 . 17172)) - b (md5-II b c d a (aref in 13) 21 '(19976 . 4513)) - a (md5-II a b c d (aref in 4) 6 '(63315 . 32386)) - d (md5-II d a b c (aref in 11) 10 '(48442 . 62005)) - c (md5-II c d a b (aref in 2) 15 '(10967 . 53947)) - b (md5-II b c d a (aref in 9) 21 '(60294 . 54161))) - - (aset md5-buffer 0 (md5-add (aref md5-buffer 0) a)) - (aset md5-buffer 1 (md5-add (aref md5-buffer 1) b)) - (aset md5-buffer 2 (md5-add (aref md5-buffer 2) c)) - (aset md5-buffer 3 (md5-add (aref md5-buffer 3) d)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Here begins the merger with the XEmacs API and the md5.el from the URL -;;; package. Courtesy wmperry@spry.com -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defun md5 (object &optional start end) - "Return the MD5 (a secure message digest algorithm) of an object. -OBJECT is either a string or a buffer. -Optional arguments START and END denote buffer positions for computing the -hash of a portion of OBJECT." - (let ((buffer nil)) - (unwind-protect - (save-excursion - (setq buffer (generate-new-buffer " *md5-work*")) - (set-buffer buffer) - (cond - ((bufferp object) - (insert-buffer-substring object start end)) - ((stringp object) - (insert (if (or start end) - (substring object start end) - object))) - (t nil)) - (prog1 - (if (<= (point-max) md5-maximum-internal-length) - (mapconcat - (function (lambda (node) (format "%02x" node))) - (md5-encode (buffer-string)) - "") - (call-process-region (point-min) (point-max) - (or shell-file-name "/bin/sh") - t buffer nil - "-c" md5-program) - ;; MD5 digest is 32 chars long - ;; mddriver adds a newline to make neaten output for tty - ;; viewing, make sure we leave it behind. - (buffer-substring (point-min) (+ (point-min) 32))) - (kill-buffer buffer))) - (and buffer (kill-buffer buffer) nil)))) - -(provide 'md5) - -;;; md5.el ends here ---------------------------------------------------------- diff --git a/lisp/gnus/nnheaderxm.el b/lisp/gnus/nnheaderxm.el deleted file mode 100644 index 4ac2462f4d8..00000000000 --- a/lisp/gnus/nnheaderxm.el +++ /dev/null @@ -1,156 +0,0 @@ -;;; nnheaderxm.el --- making Gnus backends work under XEmacs -;; Copyright (C) 1996,97 Free Software Foundation, Inc. - -;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> -;; 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. - -;;; Commentary: - -;;; Code: - -(eval-and-compile - (autoload 'nnheader-insert-file-contents "nnheader")) - -(defun nnheader-xmas-run-at-time (time repeat function &rest args) - (start-itimer - "nnheader-run-at-time" - `(lambda () - (,function ,@args)) - time repeat)) - -(defun nnheader-xmas-cancel-timer (timer) - (delete-itimer timer)) - -(defun nnheader-xmas-cancel-function-timers (function) - ) - -(defun nnheader-xmas-find-file-noselect (filename &optional nowarn rawfile) - "Read file FILENAME into a buffer and return the buffer. -If a buffer exists visiting FILENAME, return that one, but -verify that the file has not changed since visited or saved. -The buffer is not selected, just returned to the caller." - (setq filename - (abbreviate-file-name - (expand-file-name filename))) - (if (file-directory-p filename) - (if find-file-run-dired - (dired-noselect filename) - (error "%s is a directory." filename)) - (let* ((buf (get-file-buffer filename)) - (truename (abbreviate-file-name (file-truename filename))) - (number (nthcdr 10 (file-attributes truename))) - ;; Find any buffer for a file which has same truename. - (other (and (not buf) - (get-file-buffer filename))) - error) - ;; Let user know if there is a buffer with the same truename. - (when other - (or nowarn - (string-equal filename (buffer-file-name other)) - (message "%s and %s are the same file" - filename (buffer-file-name other))) - ;; Optionally also find that buffer. - (when (or (and (boundp 'find-file-existing-other-name) - find-file-existing-other-name) - find-file-visit-truename) - (setq buf other))) - (if buf - (or nowarn - (verify-visited-file-modtime buf) - (cond ((not (file-exists-p filename)) - (error "File %s no longer exists!" filename)) - ((yes-or-no-p - (if (string= (file-name-nondirectory filename) - (buffer-name buf)) - (format - (if (buffer-modified-p buf) - "File %s changed on disk. Discard your edits? " - "File %s changed on disk. Reread from disk? ") - (file-name-nondirectory filename)) - (format - (if (buffer-modified-p buf) - "File %s changed on disk. Discard your edits in %s? " - "File %s changed on disk. Reread from disk into %s? ") - (file-name-nondirectory filename) - (buffer-name buf)))) - (save-excursion - (set-buffer buf) - (revert-buffer t t))))) - (save-excursion -;;; The truename stuff makes this obsolete. -;;; (let* ((link-name (car (file-attributes filename))) -;;; (linked-buf (and (stringp link-name) -;;; (get-file-buffer link-name)))) -;;; (if (bufferp linked-buf) -;;; (message "Symbolic link to file in buffer %s" -;;; (buffer-name linked-buf)))) - (setq buf (create-file-buffer filename)) - ;; (set-buffer-major-mode buf) - (set-buffer buf) - (erase-buffer) - (if rawfile - (condition-case () - (nnheader-insert-file-contents filename t) - (file-error - ;; Unconditionally set error - (setq error t))) - (condition-case () - (insert-file-contents filename t) - (file-error - ;; Run find-file-not-found-hooks until one returns non-nil. - (or t ; (run-hook-with-args-until-success 'find-file-not-found-hooks) - ;; If they fail too, set error. - (setq error t))))) - ;; Find the file's truename, and maybe use that as visited name. - (setq buffer-file-truename truename) - (setq buffer-file-number number) - ;; On VMS, we may want to remember which directory in a search list - ;; the file was found in. - (and (eq system-type 'vax-vms) - (let (logical) - (when (string-match ":" (file-name-directory filename)) - (setq logical (substring (file-name-directory filename) - 0 (match-beginning 0)))) - (not (member logical find-file-not-true-dirname-list))) - (setq buffer-file-name buffer-file-truename)) - (when find-file-visit-truename - (setq buffer-file-name - (setq filename - (expand-file-name buffer-file-truename)))) - ;; Set buffer's default directory to that of the file. - (setq default-directory (file-name-directory filename)) - ;; Turn off backup files for certain file names. Since - ;; this is a permanent local, the major mode won't eliminate it. - (when (not (funcall backup-enable-predicate buffer-file-name)) - (make-local-variable 'backup-inhibited) - (setq backup-inhibited t)) - (if rawfile - nil - (after-find-file error (not nowarn))))) - buf))) - -(fset 'nnheader-run-at-time 'nnheader-xmas-run-at-time) -(fset 'nnheader-cancel-timer 'nnheader-xmas-cancel-timer) -(fset 'nnheader-cancel-function-timers 'nnheader-xmas-cancel-function-timers) -(fset 'nnheader-find-file-noselect 'nnheader-xmas-find-file-noselect) - -(provide 'nnheaderxm) - -;;; nnheaderxm.el ends here. diff --git a/lisp/gnusmail.el b/lisp/gnusmail.el deleted file mode 100644 index 293bde54f4a..00000000000 --- a/lisp/gnusmail.el +++ /dev/null @@ -1,220 +0,0 @@ -;;; gnusmail.el --- mail reply commands for GNUS newsreader - -;; Copyright (C) 1990, 1993 Free Software Foundation, Inc. - -;; Author: Masanobu UMEDA <umerin@mse.kyutech.ac.jp> -;; 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, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; Commentary: - -;; Provides mail reply and mail other window command using usual mail -;; interface and mh-e interface. -;; -;; To use MAIL: set the variables gnus-mail-reply-method and -;; gnus-mail-other-window-method to gnus-mail-reply-using-mail and -;; gnus-mail-other-window-using-mail, respectively. -;; -;; To use MH-E: set the variables gnus-mail-reply-method and -;; gnus-mail-other-window-method to gnus-mail-reply-using-mhe and -;; gnus-mail-other-window-using-mhe, respectively. - -;;; Code: - -(require 'gnus) - -(autoload 'news-mail-reply "rnewspost") -(autoload 'news-mail-other-window "rnewspost") - -(autoload 'mh-send "mh-e") -(autoload 'mh-send-other-window "mh-e") -(autoload 'mh-find-path "mh-e") -(autoload 'mh-yank-cur-msg "mh-e") - -;;; Mail reply commands of GNUS Summary Mode - -(defun gnus-summary-reply (yank) - "Reply mail to news author. -If prefix argument YANK is non-nil, original article is yanked automatically. -Customize the variable gnus-mail-reply-method to use another mailer." - (interactive "P") - ;; Bug fix by jbw@bigbird.bu.edu (Joe Wells) - ;; Stripping headers should be specified with mail-yank-ignored-headers. - (gnus-summary-select-article t t) - (switch-to-buffer gnus-article-buffer) - (widen) - (delete-other-windows) - (bury-buffer gnus-article-buffer) - (funcall gnus-mail-reply-method yank)) - -(defun gnus-summary-reply-with-original () - "Reply mail to news author with original article. -Customize the variable gnus-mail-reply-method to use another mailer." - (interactive) - (gnus-summary-reply t)) - -(defun gnus-summary-mail-forward () - "Forward the current message to another user. -Customize the variable gnus-mail-forward-method to use another mailer." - (interactive) - (gnus-summary-select-article) - (switch-to-buffer gnus-article-buffer) - (widen) - (delete-other-windows) - (bury-buffer gnus-article-buffer) - (funcall gnus-mail-forward-method)) - -(defun gnus-summary-mail-other-window () - "Compose mail in other window. -Customize the variable gnus-mail-other-window-method to use another mailer." - (interactive) - (gnus-summary-select-article) - (switch-to-buffer gnus-article-buffer) - (widen) - (delete-other-windows) - (bury-buffer gnus-article-buffer) - (funcall gnus-mail-other-window-method)) - - -;;; Send mail using sendmail mail mode. - -(defun gnus-mail-reply-using-mail (&optional yank) - "Compose reply mail using mail. -Optional argument YANK means yank original article." - (news-mail-reply) - (gnus-overload-functions) - (if yank - (mail-yank-original nil))) - -(defun gnus-mail-forward-using-mail () - "Forward the current message to another user using mail." - ;; This is almost a carbon copy of rmail-forward in rmail.el. - (let ((forward-buffer (current-buffer)) - (subject - (concat "[" gnus-newsgroup-name "] " - ;;(mail-strip-quoted-names (gnus-fetch-field "From")) ": " - (or (gnus-fetch-field "Subject") "")))) - ;; If only one window, use it for the mail buffer. - ;; Otherwise, use another window for the mail buffer - ;; so that the Rmail buffer remains visible - ;; and sending the mail will get back to it. - (if (if (one-window-p t) - (mail nil nil subject) - (mail-other-window nil nil subject)) - (save-excursion - (goto-char (point-max)) - (insert "------- Start of forwarded message -------\n") - (insert-buffer forward-buffer) - (goto-char (point-max)) - (insert "------- End of forwarded message -------\n") - ;; You have a chance to arrange the message. - (run-hooks 'gnus-mail-forward-hook) - )))) - -(defun gnus-mail-other-window-using-mail () - "Compose mail other window using mail." - (news-mail-other-window) - (gnus-overload-functions)) - - -;;; Send mail using mh-e. - -;; The following mh-e interface is all cooperative works of -;; tanaka@flab.fujitsu.CO.JP (TANAKA Hiroshi), kawabe@sra.CO.JP -;; (Yoshikatsu Kawabe), and shingu@casund.cpr.canon.co.jp (Toshiaki -;; SHINGU). - -(defun gnus-mail-reply-using-mhe (&optional yank) - "Compose reply mail using mh-e. -Optional argument YANK means yank original article. -The command \\[mh-yank-cur-msg] yank the original message into current buffer." - ;; First of all, prepare mhe mail buffer. - (let (from cc subject date to reply-to (buffer (current-buffer))) - (save-restriction - (gnus-article-show-all-headers) ;I don't think this is really needed. - (setq from (gnus-fetch-field "from") - subject (let ((subject (or (gnus-fetch-field "subject") - "(None)"))) - (if (and subject - (not (string-match "^[Rr][Ee]:.+$" subject))) - (concat "Re: " subject) subject)) - reply-to (gnus-fetch-field "reply-to") - cc (gnus-fetch-field "cc") - date (gnus-fetch-field "date")) - (setq mh-show-buffer buffer) - (setq to (or reply-to from)) - (mh-find-path) - (mh-send to (or cc "") subject) - (save-excursion - (mh-insert-fields - "In-reply-to:" - (concat - (substring from 0 (string-match " *at \\| *@ \\| *(\\| *<" from)) - "'s message of " date))) - (setq mh-sent-from-folder buffer) - (setq mh-sent-from-msg 1) - )) - ;; Then, yank original article if requested. - (if yank - (let ((last (point))) - (mh-yank-cur-msg) - (goto-char last) - ))) - -;; gnus-mail-forward-using-mhe is contributed by Jun-ichiro Itoh -;; <itojun@ingram.mt.cs.keio.ac.jp> - -(defun gnus-mail-forward-using-mhe () - "Forward the current message to another user using mh-e." - ;; First of all, prepare mhe mail buffer. - (let ((to (read-string "To: ")) - (cc (read-string "Cc: ")) - (buffer (current-buffer)) - subject) - ;;(gnus-article-show-all-headers) - (setq subject - (concat "[" gnus-newsgroup-name "] " - ;;(mail-strip-quoted-names (gnus-fetch-field "From")) ": " - (or (gnus-fetch-field "subject") ""))) - (setq mh-show-buffer buffer) - (mh-find-path) - (mh-send to (or cc "") subject) - (save-excursion - (goto-char (point-max)) - (insert "\n------- Forwarded Message\n\n") - (insert-buffer buffer) - (goto-char (point-max)) - (insert "\n------- End of Forwarded Message\n") - (setq mh-sent-from-folder buffer) - (setq mh-sent-from-msg 1)))) - -(defun gnus-mail-other-window-using-mhe () - "Compose mail other window using mh-e." - (let ((to (read-string "To: ")) - (cc (read-string "Cc: ")) - (subject (read-string "Subject: " (gnus-fetch-field "subject")))) - (gnus-article-show-all-headers) ;I don't think this is really needed. - (setq mh-show-buffer (current-buffer)) - (mh-find-path) - (mh-send-other-window to cc subject) - (setq mh-sent-from-folder (current-buffer)) - (setq mh-sent-from-msg 1))) - -(provide 'gnusmail) - -;;; gnusmail.el ends here diff --git a/lisp/gnusmisc.el b/lisp/gnusmisc.el deleted file mode 100644 index df7b16f48d2..00000000000 --- a/lisp/gnusmisc.el +++ /dev/null @@ -1,294 +0,0 @@ -;;; gnusmisc.el --- miscellaneous commands for GNUS newsreader - -;; Copyright (C) 1989, 1990, 1993 Free Software Foundation, Inc. - -;; Author: Masanobu UMEDA <umerin@mse.kyutech.ac.jp> -;; 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, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; Code: - -(require 'gnus) - -;;; -;;; GNUS Browse-Killed Mode -;;; - -;; Some ideas are due to roland@wheaties.ai.mit.edu (Roland McGrath). -;; I'd like to thank him very much. - -(defvar gnus-browse-killed-mode-hook nil - "*A hook for GNUS Browse-Killed Mode.") - -(defvar gnus-browse-killed-buffer "*Killed Newsgroup*") -(defvar gnus-browse-killed-mode-map nil) -(defvar gnus-winconf-browse-killed nil) - -(autoload 'timezone-make-date-arpa-standard "timezone") - -(put 'gnus-browse-killed-mode 'mode-class 'special) - - -;;; -;;; GNUS Browse-Killed Mode -;;; - -;; Some ideas are due to roland@wheaties.ai.mit.edu (Roland McGrath). -;; I'd like to thank him very much. - -;; Make the buffer to be managed by GNUS. - -(or (memq gnus-browse-killed-buffer gnus-buffer-list) - (setq gnus-buffer-list - (cons gnus-browse-killed-buffer gnus-buffer-list))) - -(if gnus-browse-killed-mode-map - nil - (setq gnus-browse-killed-mode-map (make-keymap)) - (suppress-keymap gnus-browse-killed-mode-map t) - (define-key gnus-browse-killed-mode-map " " 'gnus-group-next-group) - (define-key gnus-browse-killed-mode-map "\177" 'gnus-group-prev-group) - (define-key gnus-browse-killed-mode-map "\C-n" 'gnus-group-next-group) - (define-key gnus-browse-killed-mode-map "\C-p" 'gnus-group-prev-group) - (define-key gnus-browse-killed-mode-map "n" 'gnus-group-next-group) - (define-key gnus-browse-killed-mode-map "p" 'gnus-group-prev-group) - (define-key gnus-browse-killed-mode-map "y" 'gnus-browse-killed-yank) - (define-key gnus-browse-killed-mode-map "\C-y" 'gnus-browse-killed-yank) - (define-key gnus-browse-killed-mode-map "l" 'gnus-list-killed-groups) - (define-key gnus-browse-killed-mode-map "q" 'gnus-browse-killed-exit) - (define-key gnus-browse-killed-mode-map "\C-c\C-c" 'gnus-browse-killed-exit) - (define-key gnus-browse-killed-mode-map "\C-c\C-i" 'gnus-info-find-node)) - -(defun gnus-browse-killed-mode () - "Major mode for browsing the killed newsgroups. -All normal editing commands are turned off. -Instead, these commands are available: -\\{gnus-browse-killed-mode-map} - -The killed newsgroups are saved in the quick startup file (.newsrc.el) -unless it against the options line in the startup file (.newsrc). - -Entry to this mode calls gnus-browse-killed-mode-hook with no arguments, -if that value is non-nil." - (interactive) - (kill-all-local-variables) - ;; Gee. Why don't you upgrade? - (cond ((boundp 'mode-line-modified) - (setq mode-line-modified "--- ")) - ((listp (default-value 'mode-line-format)) - (setq mode-line-format - (cons "--- " (cdr (default-value 'mode-line-format))))) - (t - (setq mode-line-format - "--- GNUS: Killed Newsgroups %[(%m)%]----%3p-%-"))) - (setq major-mode 'gnus-browse-killed-mode) - (setq mode-name "Browse-Killed") - (setq mode-line-buffer-identification "GNUS: Killed Newsgroups") - (use-local-map gnus-browse-killed-mode-map) - (buffer-flush-undo (current-buffer)) - (setq buffer-read-only t) ;Disable modification - (run-hooks 'gnus-browse-killed-mode-hook)) - -(defun gnus-list-killed-groups () - "List the killed newsgroups. -The keys y and C-y yank the newsgroup on the current line into the -Newsgroups buffer." - (interactive) - (or gnus-killed-assoc - (error "No killed newsgroups")) - ;; Save current window configuration if this is first invocation.. - (or (get-buffer-window gnus-browse-killed-buffer) - (setq gnus-winconf-browse-killed - (current-window-configuration))) - ;; Prepare browsing buffer. - (pop-to-buffer (get-buffer-create gnus-browse-killed-buffer)) - (gnus-browse-killed-mode) - (let ((buffer-read-only nil) - (killed-assoc gnus-killed-assoc)) - (erase-buffer) - (while killed-assoc - (insert (gnus-group-prepare-line (car killed-assoc))) - (setq killed-assoc (cdr killed-assoc))) - (goto-char (point-min)) - )) - -(defun gnus-browse-killed-yank () - "Yank current newsgroup to Newsgroup buffer." - (interactive) - (let ((group (gnus-group-group-name))) - (if group - (let* ((buffer-read-only nil) - (killed (gnus-gethash group gnus-killed-hashtb))) - (pop-to-buffer gnus-group-buffer) ;Needed to adjust point. - (if killed - (gnus-group-insert-group killed)) - (pop-to-buffer gnus-browse-killed-buffer) - (beginning-of-line) - (delete-region (point) - (progn (forward-line 1) (point))) - ))) - (gnus-browse-killed-check-buffer)) - -(defun gnus-browse-killed-check-buffer () - "Exit if the buffer is empty by deleting the window and killing the buffer." - (and (null gnus-killed-assoc) - (get-buffer gnus-browse-killed-buffer) - (gnus-browse-killed-exit))) - -(defun gnus-browse-killed-exit () - "Exit this mode by deleting the window and killing the buffer." - (interactive) - (and (get-buffer-window gnus-browse-killed-buffer) - (delete-window (get-buffer-window gnus-browse-killed-buffer))) - (kill-buffer gnus-browse-killed-buffer) - ;; Restore previous window configuration if available. - (and gnus-winconf-browse-killed - (set-window-configuration gnus-winconf-browse-killed)) - (setq gnus-winconf-browse-killed nil)) - - -;;; -;;; kill/yank newsgroup commands of GNUS Group Mode -;;; - -(defun gnus-group-transpose-groups (arg) - "Exchange current newsgroup and previous newsgroup. -With argument ARG, takes previous newsgroup and moves it past ARG newsgroup." - (interactive "p") - ;; BUG: last newsgroup and the last but one cannot be transposed - ;; since gnus-group-search-forward does not move forward beyond the - ;; last. If we instead use forward-line, no problem, but I don't - ;; want to use it for later extension. - (while (> arg 0) - (gnus-group-search-forward t t) - (gnus-group-kill-group 1) - (gnus-group-search-forward nil t) - (gnus-group-yank-group) - (gnus-group-search-forward nil t) - (setq arg (1- arg)) - )) - -(defun gnus-group-kill-region (begin end) - "Kill newsgroups in current region (excluding current point). -The killed newsgroups can be yanked by using \\[gnus-group-yank-group]." - (interactive "r") - (let ((lines - ;; Exclude a line where current point is on. - (1- - ;; Count lines. - (save-excursion - (count-lines - (progn - (goto-char begin) - (beginning-of-line) - (point)) - (progn - (goto-char end) - (end-of-line) - (point))))))) - (goto-char begin) - (beginning-of-line) ;Important when LINES < 1 - (gnus-group-kill-group lines))) - -(defun gnus-group-kill-group (n) - "Kill newsgroup on current line, repeated prefix argument N times. -The killed newsgroups can be yanked by using \\[gnus-group-yank-group]." - (interactive "p") - (let ((buffer-read-only nil) - (group nil)) - (while (> n 0) - (setq group (gnus-group-group-name)) - (or group - (signal 'end-of-buffer nil)) - (beginning-of-line) - (delete-region (point) - (progn (forward-line 1) (point))) - (gnus-kill-newsgroup group) - (setq n (1- n)) - ;; Add to killed newsgroups in the buffer if exists. - (if (get-buffer gnus-browse-killed-buffer) - (save-excursion - (set-buffer gnus-browse-killed-buffer) - (let ((buffer-read-only nil)) - (goto-char (point-min)) - (insert (gnus-group-prepare-line (car gnus-killed-assoc))) - ))) - ) - (search-forward ":" nil t) - )) - -(defun gnus-group-yank-group () - "Yank the last newsgroup killed with \\[gnus-group-kill-group], -inserting it before the newsgroup on the line containing point." - (interactive) - (gnus-group-insert-group (car gnus-killed-assoc)) - ;; Remove killed newsgroups from the buffer if exists. - (if (get-buffer gnus-browse-killed-buffer) - (save-excursion - (set-buffer gnus-browse-killed-buffer) - (let ((buffer-read-only nil)) - (goto-char (point-min)) - (delete-region (point-min) - (progn (forward-line 1) (point))) - ))) - (gnus-browse-killed-check-buffer)) - -(defun gnus-group-insert-group (info) - "Insert newsgroup at current line using gnus-newsrc-assoc INFO." - (if (null gnus-killed-assoc) - (error "No killed newsgroups")) - ;; Huuum. It this right? - ;;(if (not gnus-have-all-newsgroups) - ;; (error - ;; (substitute-command-keys - ;; "Not all newsgroups are displayed. Type \\[gnus-group-list-all-groups] to display all newsgroups."))) - (let ((buffer-read-only nil) - (group (gnus-group-group-name))) - (gnus-insert-newsgroup info group) - (beginning-of-line) - (insert (gnus-group-prepare-line info)) - (forward-line -1) - (search-forward ":" nil t) - )) - - -;;; Rewrite Date: field in GMT to local - -(defun gnus-gmt-to-local () - "Rewrite Date: field described in GMT to local in current buffer. -The variable gnus-local-timezone is used for local time zone. -Intended to be used with gnus-article-prepare-hook." - (save-excursion - (save-restriction - (widen) - (goto-char (point-min)) - (narrow-to-region (point-min) - (progn (search-forward "\n\n" nil 'move) (point))) - (goto-char (point-min)) - (if (re-search-forward "^Date:[ \t]\\(.*\\)$" nil t) - (let ((buffer-read-only nil) - (date (buffer-substring (match-beginning 1) (match-end 1)))) - (delete-region (match-beginning 1) (match-end 1)) - (insert - (timezone-make-date-arpa-standard date nil gnus-local-timezone)) - )) - ))) - -(provide 'gnusmisc) - -;;; gnusmisc.el ends here diff --git a/lisp/gnuspost.el b/lisp/gnuspost.el deleted file mode 100644 index 441feb245d2..00000000000 --- a/lisp/gnuspost.el +++ /dev/null @@ -1,842 +0,0 @@ -;;; gnuspost.el --- post news commands for GNUS newsreader - -;; Copyright (C) 1989, 1990, 1993, 1994 Free Software Foundation, Inc. - -;; Author: Masanobu UMEDA <umerin@mse.kyutech.ac.jp> -;; 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, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; Code: - -(require 'gnus) - -(defvar gnus-organization-file "/usr/lib/news/organization" - "*Local news organization file.") - -(defvar gnus-post-news-buffer "*post-news*") -(defvar gnus-winconf-post-news nil) - -(autoload 'news-reply-mode "rnewspost") -(autoload 'timezone-make-date-arpa-standard "timezone") - -;;; Post news commands of GNUS Group Mode and Summary Mode - -(defun gnus-group-post-news () - "Post an article." - (interactive) - ;; Save window configuration. - (setq gnus-winconf-post-news (current-window-configuration)) - (unwind-protect - (gnus-post-news) - (or (and (eq (current-buffer) (get-buffer gnus-post-news-buffer)) - (not (zerop (buffer-size)))) - ;; Restore last window configuration. - (set-window-configuration gnus-winconf-post-news))) - ;; We don't want to return to Summary buffer nor Article buffer later. - (if (get-buffer gnus-summary-buffer) - (bury-buffer gnus-summary-buffer)) - (if (get-buffer gnus-article-buffer) - (bury-buffer gnus-article-buffer))) - -(defun gnus-summary-post-news () - "Post an article." - (interactive) - (gnus-summary-select-article t nil) - ;; Save window configuration. - (setq gnus-winconf-post-news (current-window-configuration)) - (unwind-protect - (progn - (switch-to-buffer gnus-article-buffer) - (widen) - (delete-other-windows) - (gnus-post-news)) - (or (and (eq (current-buffer) (get-buffer gnus-post-news-buffer)) - (not (zerop (buffer-size)))) - ;; Restore last window configuration. - (set-window-configuration gnus-winconf-post-news))) - ;; We don't want to return to Article buffer later. - (bury-buffer gnus-article-buffer)) - -(defun gnus-summary-followup (yank) - "Post a reply article. -If prefix argument YANK is non-nil, original article is yanked automatically." - (interactive "P") - (gnus-summary-select-article t nil) - ;; Check Followup-To: poster. - (set-buffer gnus-article-buffer) - (if (and gnus-use-followup-to - (string-equal "poster" (gnus-fetch-field "followup-to")) - (or (not (eq gnus-use-followup-to t)) - (not (y-or-n-p "Do you want to ignore `Followup-To: poster'? ")))) - ;; Mail to the poster. GNUS is now RFC1036 compliant. - (gnus-summary-reply yank) - ;; Save window configuration. - (setq gnus-winconf-post-news (current-window-configuration)) - (unwind-protect - (progn - (switch-to-buffer gnus-article-buffer) - (widen) - (delete-other-windows) - (gnus-news-reply yank)) - (or (and (eq (current-buffer) (get-buffer gnus-post-news-buffer)) - (not (zerop (buffer-size)))) - ;; Restore last window configuration. - (set-window-configuration gnus-winconf-post-news))) - ;; We don't want to return to Article buffer later. - (bury-buffer gnus-article-buffer))) - -(defun gnus-summary-followup-with-original () - "Post a reply article with original article." - (interactive) - (gnus-summary-followup t)) - -(defun gnus-summary-cancel-article () - "Cancel an article you posted." - (interactive) - (gnus-summary-select-article t nil) - (gnus-eval-in-buffer-window gnus-article-buffer - (gnus-cancel-news))) - - -;;; Post a News using NNTP - -;;;###autoload -(defalias 'sendnews 'gnus-post-news) - -;;;###autoload -(defalias 'postnews 'gnus-post-news) - -;;;###autoload -(defun gnus-post-news () - "Begin editing a new USENET news article to be posted. -Type \\[describe-mode] once editing the article to get a list of commands." - (interactive) - (if (or (not gnus-novice-user) - (y-or-n-p "Are you sure you want to post to all of USENET? ")) - (let ((artbuf (current-buffer)) - (newsgroups ;Default newsgroup. - (if (eq major-mode 'gnus-article-mode) gnus-newsgroup-name)) - (subject nil) - ;; Get default distribution. - (distribution (car gnus-local-distributions)) - (followup-to nil)) - ;; Connect to NNTP server if not connected yet, and get - ;; several information. - (if (not (gnus-server-opened)) - (progn - (gnus-start-news-server t) ;Confirm server. - (gnus-setup-news))) - ;; Get current article information. - (save-restriction - (and (not (zerop (buffer-size))) - ;;(equal major-mode 'news-mode) - (equal major-mode 'gnus-article-mode) - (progn - ;;(news-show-all-headers) - (gnus-article-show-all-headers) - (narrow-to-region (point-min) - (progn (goto-char (point-min)) - (search-forward "\n\n") - (point))))) - (setq news-reply-yank-from (mail-fetch-field "from")) - (setq news-reply-yank-message-id (mail-fetch-field "message-id"))) - (pop-to-buffer gnus-post-news-buffer) - (news-reply-mode) - (gnus-overload-functions) - (if (and (buffer-modified-p) - (> (buffer-size) 0) - (not (y-or-n-p "Unsent article being composed; erase it? "))) - ;; Continue composition. - ;; Make news-reply-yank-original work on the current article. - (setq mail-reply-buffer artbuf) - (erase-buffer) - (if gnus-interactive-post - ;; Newsgroups, subject and distribution are asked for. - ;; Suggested by yuki@flab.fujitsu.junet. - (progn - ;; Subscribed newsgroup names are required for - ;; completing read of newsgroup. - (or gnus-newsrc-assoc - (gnus-read-newsrc-file)) - ;; Which do you like? (UMERIN) - ;; (setq newsgroups (read-string "Newsgroups: " "general")) - (or newsgroups ;Use the default newsgroup. - (let (group) - (while (not - (string= - (setq group - (completing-read "Newsgroup: " - gnus-newsrc-assoc - nil 'require-match)) - "")) - (or followup-to (setq followup-to group)) - (if newsgroups - (setq newsgroups (concat newsgroups "," group)) - (setq newsgroups group))))) - (setq subject (read-string "Subject: ")) - ;; Choose a distribution from gnus-distribution-list. - ;; completing-read should not be used with - ;; 'require-match functionality in order to allow use - ;; of unknow distribution. - (gnus-read-distributions-file) - (setq distribution - (if (consp gnus-distribution-list) - (completing-read "Distribution: " - gnus-distribution-list - nil nil ;Never 'require-match - distribution ;Default distribution. - ) - (read-string "Distribution: "))) - ;; Empty string is okay. - ;;(if (string-equal distribution "") - ;; (setq distribution nil)) - )) - (news-setup () subject () newsgroups artbuf) - ;; Make sure the article is posted by GNUS. - ;;(mail-position-on-field "Posting-Software") - ;;(insert "GNUS: NNTP-based News Reader for GNU Emacs") - ;; Insert Distribution: field. - ;; Suggested by ichikawa@flab.fujitsu.junet. - (mail-position-on-field "Distribution") - (insert (or distribution "")) - ;; Add Followup-To header - (if followup-to - (progn - (mail-position-on-field "Followup-To") - (insert followup-to))) - ;; Handle author copy using FCC field. - (if gnus-author-copy - (progn - (mail-position-on-field "FCC") - (insert gnus-author-copy))) - (if gnus-interactive-post - ;; All fields are filled in. - (goto-char (point-max)) - ;; Move point to Newsgroup: field. - (goto-char (point-min)) - (end-of-line)) - )) - (message ""))) - -(defun gnus-news-reply (&optional yank) - "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 (or (not gnus-novice-user) - (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 - (artbuf (current-buffer))) - (save-restriction - (and (not (zerop (buffer-size))) - ;;(equal major-mode 'news-mode) - (equal major-mode 'gnus-article-mode) - (progn - ;; (news-show-all-headers) - (gnus-article-show-all-headers) - (narrow-to-region (point-min) - (progn (goto-char (point-min)) - (search-forward "\n\n") - (point))))) - (setq from (mail-fetch-field "from")) - ;; Get reply-to working corrrectly for gnus-auto-mail-to-author (jpm) - (setq reply-to (mail-fetch-field "reply-to")) - (setq news-reply-yank-from from) - (setq subject (mail-fetch-field "subject")) - (setq date (mail-fetch-field "date")) - (setq followup-to (mail-fetch-field "followup-to")) - ;; Ignore Followup-To: poster. - (if (or (null gnus-use-followup-to) ;Ignore followup-to: field. - (string-equal "" followup-to) ;Bogus header. - (string-equal "poster" followup-to)) - (setq followup-to nil)) - (setq newsgroups (or followup-to (mail-fetch-field "newsgroups"))) - (setq references (mail-fetch-field "references")) - (setq distribution (mail-fetch-field "distribution")) - (setq message-id (mail-fetch-field "message-id")) - (setq news-reply-yank-message-id message-id)) - (pop-to-buffer gnus-post-news-buffer) - (news-reply-mode) - (gnus-overload-functions) - (if (and (buffer-modified-p) - (> (buffer-size) 0) - (not (y-or-n-p "Unsent article being composed; erase it? "))) - ;; Continue composition. - ;; Make news-reply-yank-original work on current article. - (setq mail-reply-buffer artbuf) - (erase-buffer) - (and subject - (setq subject - (concat "Re: " (gnus-simplify-subject subject 're-only)))) - (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 of " - date))))) - (news-setup nil subject message-of newsgroups artbuf) - (if followup-to - (progn (news-reply-followup-to) - (insert followup-to))) - ;; Fold long references line to follow RFC1036. - (mail-position-on-field "References") - (let ((begin (point)) - (fill-column 79) - (fill-prefix "\t")) - (if references - (insert references)) - (if (and references message-id) - (insert " ")) - (if message-id - (insert message-id)) - ;; The region must end with a newline to fill the region - ;; without inserting extra newline. - (fill-region-as-paragraph begin (1+ (point)))) - ;; Make sure the article is posted by GNUS. - ;;(mail-position-on-field "Posting-Software") - ;;(insert "GNUS: NNTP-based News Reader for GNU Emacs") - ;; Distribution must be the same as original article. - (mail-position-on-field "Distribution") - (insert (or distribution "")) - ;; Handle author copy using FCC field. - (if gnus-author-copy - (progn - (mail-position-on-field "FCC") - (insert gnus-author-copy))) - ;; Insert To: FROM field, which is expected to mail the - ;; message to the author of the article too. Use Reply-To - ;; field like gnus-mail-reply-using-m* (jpm). - (if (and gnus-auto-mail-to-author (or reply-to from)) - (progn - (goto-char (point-min)) - (insert "To: " (or reply-to from) "\n"))) - (goto-char (point-max))) - ;; Yank original article automatically. - (if yank - (let ((last (point))) - ;;(goto-char (point-max)) - ;; Insert at current point. - (news-reply-yank-original nil) - (goto-char last))) - ) - (message ""))) - -(defun gnus-inews-news () - "Send a news message." - (interactive) - (let* ((case-fold-search nil) - (server-running (gnus-server-opened))) - (save-excursion - ;; Connect to default NNTP server if necessary. - ;; Suggested by yuki@flab.fujitsu.junet. - (gnus-start-news-server) ;Use default server. - ;; NNTP server must be opened before current buffer is modified. - (widen) - (goto-char (point-min)) - (run-hooks 'news-inews-hook) - (save-restriction - (narrow-to-region - (point-min) - (progn - (goto-char (point-min)) - (search-forward (concat "\n" mail-header-separator "\n")) - (point))) - - ;; Correct newsgroups field: change sequence of spaces to comma and - ;; eliminate spaces around commas. Eliminate imbedded line breaks. - (goto-char (point-min)) - (if (search-forward-regexp "^Newsgroups: +" nil t) - (save-restriction - (narrow-to-region - (point) - (if (re-search-forward "^[^ \t]" nil 'end) - (match-beginning 0) - (point-max))) - (goto-char (point-min)) - (replace-regexp "\n[ \t]+" " ") ;No line breaks (too confusing) - (goto-char (point-min)) - (replace-regexp "[ \t\n]*,[ \t\n]*\\|[ \t]+" ",") - )) - - ;; Mail the message too if To: or Cc: exists. - (if (or (mail-fetch-field "to" nil t) - (mail-fetch-field "cc" nil t)) - (if gnus-mail-send-method - (progn - (message "Sending via mail...") - (widen) - (funcall gnus-mail-send-method) - (message "Sending via mail... done")) - (ding) - (message "No mailer defined. To: and/or Cc: fields ignored.") - (sit-for 1)))) - - ;; Send to NNTP server. - (message "Posting to USENET...") - (if (gnus-inews-article) - (message "Posting to USENET... done") - ;; We cannot signal an error. - (ding) (message "Article rejected: %s" (gnus-status-message))) - (set-buffer-modified-p nil)) - ;; If NNTP server is opened by gnus-inews-news, close it by myself. - (or server-running - (gnus-close-server)) - (and (fboundp 'bury-buffer) (bury-buffer)) - ;; Restore last window configuration. - (and gnus-winconf-post-news - (set-window-configuration gnus-winconf-post-news)) - (setq gnus-winconf-post-news nil) - )) - -(defun gnus-cancel-news () - "Cancel an article you posted." - (interactive) - (if (yes-or-no-p "Do you really want to cancel this article? ") - (let ((from nil) - (newsgroups nil) - (message-id nil) - (distribution nil)) - (save-excursion - ;; Get header info. from original article. - (save-restriction - (gnus-article-show-all-headers) - (goto-char (point-min)) - (search-forward "\n\n" nil 'move) - (narrow-to-region (point-min) (point)) - (setq from (mail-fetch-field "from")) - (setq newsgroups (mail-fetch-field "newsgroups")) - (setq message-id (mail-fetch-field "message-id")) - (setq distribution (mail-fetch-field "distribution"))) - ;; Verify if the article is absolutely user's by comparing - ;; user id with value of its From: field. - (if (not - (string-equal - (downcase (mail-strip-quoted-names from)) - (downcase (mail-strip-quoted-names (gnus-inews-user-name))))) - (progn - (ding) (message "This article is not yours.")) - ;; Make control article. - (set-buffer (get-buffer-create " *GNUS-canceling*")) - (buffer-disable-undo (current-buffer)) - (erase-buffer) - (insert "Newsgroups: " newsgroups "\n" - "Subject: cancel " message-id "\n" - "Control: cancel " message-id "\n" - ;; We should not use the first value of - ;; `gnus-distribution-list' as default value, - ;; because distribution must be as same as original - ;; article. - "Distribution: " (or distribution "") "\n" - mail-header-separator "\n" - ) - ;; Send the control article to NNTP server. - (message "Canceling your article...") - (if (gnus-inews-article) - (message "Canceling your article... done") - (ding) (message "Failed to cancel your article")) - ;; Kill the article buffer. - (kill-buffer (current-buffer)) - ))) - )) - - -;;; Lowlevel inews interface - -(defun gnus-inews-article () - "Post an article in current buffer using NNTP protocol." - (let ((artbuf (current-buffer)) - (tmpbuf (get-buffer-create " *GNUS-posting*"))) - (save-excursion - (set-buffer tmpbuf) - (buffer-disable-undo (current-buffer)) - (erase-buffer) - (insert-buffer-substring artbuf) - ;; Remove the header separator. - (goto-char (point-min)) - (search-forward (concat "\n" mail-header-separator "\n")) - (replace-match "\n\n") - (goto-char (point-max)) - ;; require a newline at the end for inews to append .signature to - (or (= (preceding-char) ?\n) - (insert ?\n)) - ;; This hook may insert a signature. - (run-hooks 'gnus-prepare-article-hook) - ;; Prepare article headers. All message body such as signature - ;; must be inserted before Lines: field is prepared. - (save-restriction - (goto-char (point-min)) - (search-forward "\n\n") - (narrow-to-region (point-min) (point)) - (gnus-inews-insert-headers)) - ;; Run final inews hooks. This hook may do FCC. - ;; The article must be saved before being posted because - ;; `gnus-request-post' modifies the buffer. - (run-hooks 'gnus-inews-article-hook) - ;; Post an article to NNTP server. - ;; Return NIL if post failed. - (prog1 - (gnus-request-post) - (kill-buffer (current-buffer))) - ))) - -(defun gnus-inews-insert-headers () - "Prepare article headers. -Fields already prepared in the buffer are not modified. -Fields in gnus-required-headers will be generated." - (save-excursion - (let ((date (gnus-inews-date)) - (message-id (gnus-inews-message-id)) - (organization (gnus-inews-organization))) - (goto-char (point-min)) - (or (mail-fetch-field "path") - (and (memq 'Path gnus-required-headers) - (insert "Path: " (gnus-inews-path) "\n"))) - (or (mail-fetch-field "from") - (and (memq 'From gnus-required-headers) - (insert "From: " (gnus-inews-user-name) "\n"))) - ;; If there is no subject, make Subject: field. - (or (mail-fetch-field "subject") - (and (memq 'Subject gnus-required-headers) - (insert "Subject: \n"))) - ;; If there is no newsgroups, make Newsgroups: field. - (or (mail-fetch-field "newsgroups") - (and (memq 'Newsgroups gnus-required-headers) - (insert "Newsgroups: \n"))) - (or (mail-fetch-field "message-id") - (and message-id - (memq 'Message-ID gnus-required-headers) - (insert "Message-ID: " message-id "\n"))) - (or (mail-fetch-field "date") - (and date - (memq 'Date gnus-required-headers) - (insert "Date: " date "\n"))) - ;; Optional fields in RFC977 and RFC1036 - (or (mail-fetch-field "organization") - (and organization - (memq 'Organization gnus-required-headers) - (let ((begin (point)) - (fill-column 79) - (fill-prefix "\t")) - (insert "Organization: " organization "\n") - (fill-region-as-paragraph begin (point))))) - (or (mail-fetch-field "distribution") - (and (memq 'Distribution gnus-required-headers) - (insert "Distribution: \n"))) - (or (mail-fetch-field "lines") - (and (memq 'Lines gnus-required-headers) - (insert "Lines: " (gnus-inews-lines) "\n"))) - ))) - - -;; Utility functions. - -(defun gnus-inews-insert-signature () - "Insert signature file in current article buffer. -If there is a file named .signature-DISTRIBUTION, it is used instead -of usual .signature when the distribution of the article is -DISTRIBUTION. Set the variable to nil to prevent appending the -signature file automatically. -Signature file is specified by the variable gnus-signature-file." - (save-excursion - (save-restriction - ;; Change signature file by distribution. - ;; Suggested by hyoko@flab.fujitsu.co.jp. - (let ((signature - (if gnus-signature-file - (expand-file-name gnus-signature-file nil))) - (distribution nil)) - (goto-char (point-min)) - (search-forward "\n\n") - (narrow-to-region (point-min) (point)) - (setq distribution (mail-fetch-field "distribution")) - (widen) - (if signature - (progn - (if (file-exists-p (concat signature "-" distribution)) - (setq signature (concat signature "-" distribution))) - ;; Insert signature. - (if (file-exists-p signature) - (progn - (goto-char (point-max)) - (insert "-- \n") - (insert-file-contents signature))) - )))))) - -(defun gnus-inews-do-fcc () - "Process FCC: fields in current article buffer. -Unless the first character of the field is `|', the article is saved -to the specified file using the function specified by the variable -gnus-author-copy-saver. The default function rmail-output saves in -Unix mailbox format. -If the first character is `|', the contents of the article is send to -a program specified by the rest of the value." - (let ((fcc-list nil) - (fcc-file nil) - (case-fold-search t)) ;Should ignore case. - (save-excursion - (save-restriction - (goto-char (point-min)) - (search-forward "\n\n") - (narrow-to-region (point-min) (point)) - (goto-char (point-min)) - (while (re-search-forward "^FCC:[ \t]*" nil t) - (setq fcc-list - (cons (buffer-substring - (point) - (progn - (end-of-line) - (skip-chars-backward " \t") - (point))) - fcc-list)) - (delete-region (match-beginning 0) - (progn (forward-line 1) (point)))) - ;; Process FCC operations. - (widen) - (while fcc-list - (setq fcc-file (car fcc-list)) - (setq fcc-list (cdr fcc-list)) - (cond ((string-match "^[ \t]*|[ \t]*\\(.*\\)[ \t]*$" fcc-file) - (let ((program (substring fcc-file - (match-beginning 1) (match-end 1)))) - ;; Suggested by yuki@flab.fujitsu.junet. - ;; Send article to named program. - (call-process-region (point-min) (point-max) shell-file-name - nil nil nil "-c" program) - )) - (t - ;; Suggested by hyoko@flab.fujitsu.junet. - ;; Save article in Unix mail format by default. - (if (and gnus-author-copy-saver - (not (eq gnus-author-copy-saver 'rmail-output))) - (funcall gnus-author-copy-saver fcc-file) - (if (and (file-readable-p fcc-file) - (mail-file-babyl-p fcc-file)) - (gnus-output-to-rmail fcc-file) - (rmail-output fcc-file 1 t t))) - )) - ) - )) - )) - -(defun gnus-inews-path () - "Return uucp path." - (let ((login-name (gnus-inews-login-name))) - (cond ((null gnus-use-generic-path) - (concat gnus-nntp-server "!" login-name)) - ((stringp gnus-use-generic-path) - ;; Support GENERICPATH. Suggested by vixie@decwrl.dec.com. - (concat gnus-use-generic-path "!" login-name)) - (t login-name)) - )) - -(defun gnus-inews-user-name () - "Return user's network address as `NAME@DOMAIN (FULLNAME)'." - (let ((full-name (gnus-inews-full-name))) - (concat (if (or gnus-user-login-name gnus-use-generic-from - gnus-local-domain (getenv "DOMAINNAME")) - (concat (gnus-inews-login-name) "@" - (gnus-inews-domain-name gnus-use-generic-from)) - user-mail-address) - ;; User's full name. - (cond ((string-equal full-name "") "") - ((string-equal full-name "&") ;Unix hack. - (concat " (" login-name ")")) - (t - (concat " (" full-name ")"))) - ))) - -(defun gnus-inews-login-name () - "Return user login name. -Got from the variable `gnus-user-login-name' and the function -`user-login-name'." - (or gnus-user-login-name (user-login-name))) - -(defun gnus-inews-full-name () - "Return user full name. -Got from the variable `gnus-user-full-name', the environment variable -NAME, and the function `user-full-name'." - (or gnus-user-full-name - (getenv "NAME") (user-full-name))) - -(defun gnus-inews-domain-name (&optional genericfrom) - "Return user's domain name. -If optional argument GENERICFROM is a string, use it as the domain -name; if it is non-nil, strip of local host name from the domain name. -If the function `system-name' returns full internet name and the -domain is undefined, the domain name is got from it." - (and (null gnus-local-domain) - (boundp 'gnus-your-domain) - (setq gnus-local-domain gnus-your-domain)) - (if (or genericfrom gnus-local-domain (getenv "DOMAINNAME")) - (let ((domain (or (if (stringp genericfrom) genericfrom) - (getenv "DOMAINNAME") - gnus-local-domain - ;; Function `system-name' may return full internet name. - ;; Suggested by Mike DeCorte <mrd@sun.soe.clarkson.edu>. - (if (string-match "\\." (system-name)) - (substring (system-name) (match-end 0))) - (read-string "Domain name (no host): "))) - (host (or (if (string-match "\\." (system-name)) - (substring (system-name) 0 (match-beginning 0))) - (system-name)))) - (if (string-equal "." (substring domain 0 1)) - (setq domain (substring domain 1))) - ;; Support GENERICFROM as same as standard Bnews system. - ;; Suggested by ohm@kaba.junet and vixie@decwrl.dec.com. - (cond ((null genericfrom) - (concat host "." domain)) - ;;((stringp genericfrom) genericfrom) - (t domain))) - (substring user-mail-address (1+ (string-match "@" user-mail-address))))) - -(defun gnus-inews-message-id () - "Generate unique Message-ID for user." - ;; Message-ID should not contain a slash and should be terminated by - ;; a number. I don't know the reason why it is so. - (concat "<" (gnus-inews-unique-id) "@" (gnus-inews-domain-name) ">")) - -(defun gnus-inews-unique-id () - "Generate unique ID from user name and current time." - (let ((date (current-time-string)) - (name (gnus-inews-login-name))) - (if (string-match "^[^ ]+ \\([^ ]+\\)[ ]+\\([0-9]+\\) \\([0-9]+\\):\\([0-9]+\\):\\([0-9]+\\) [0-9][0-9]\\([0-9][0-9]\\)" - date) - (concat (upcase name) "." - (substring date (match-beginning 6) (match-end 6)) ;Year - (substring date (match-beginning 1) (match-end 1)) ;Month - (substring date (match-beginning 2) (match-end 2)) ;Day - (substring date (match-beginning 3) (match-end 3)) ;Hour - (substring date (match-beginning 4) (match-end 4)) ;Minute - (substring date (match-beginning 5) (match-end 5)) ;Second - ) - (error "Cannot understand current-time-string: %s." date)) - )) - -(defun gnus-current-time-zone (time) - "The local time zone in effect at TIME, or nil if not known." - (let ((z (and (fboundp 'current-time-zone) (current-time-zone time)))) - (if (and z (car z)) z gnus-local-timezone))) - -(defun gnus-inews-date () - "Date string of today. -If `current-time-zone' works, or if `gnus-local-timezone' is set correctly, -this yields a date that conforms to RFC 822. Otherwise a buggy date will -be generated; this might work with some older news servers." - (let* ((now (and (fboundp 'current-time) (current-time))) - (zone (gnus-current-time-zone now))) - (if zone - (gnus-inews-valid-date now zone) - ;; No timezone info. - (gnus-inews-buggy-date now)))) - -(defun gnus-inews-valid-date (&optional time zone) - "A date string that represents TIME and conforms to the Usenet standard. -TIME is optional and defaults to the current time. -Some older versions of Emacs always act as if TIME is nil. -The optional argument ZONE specifies the local time zone (default GMT)." - (timezone-make-date-arpa-standard - (if (fboundp 'current-time) - (current-time-string time) - (current-time-string)) - zone "GMT")) - -(defun gnus-inews-buggy-date (&optional time) - "A buggy date string that represents TIME. -TIME is optional and defaults to the current time. -Some older versions of Emacs always act as if TIME is nil." - (let ((date (if (fboundp 'current-time) - (current-time-string time) - (current-time-string)))) - (if (string-match "^[^ ]+ \\([^ ]+\\)[ ]+\\([0-9]+\\) \\([0-9:]+\\) [0-9][0-9]\\([0-9][0-9]\\)" - date) - (concat (substring date (match-beginning 2) (match-end 2)) ;Day - " " - (substring date (match-beginning 1) (match-end 1)) ;Month - " " - (substring date (match-beginning 4) (match-end 4)) ;Year - " " - (substring date (match-beginning 3) (match-end 3))) ;Time - (error "Cannot understand current-time-string: %s." date)) - )) - -(defun gnus-inews-organization () - "Return user's organization. -The ORGANIZATION environment variable is used if defined. -If not, the variable gnus-local-organization is used instead. -If the value begins with a slash, it is taken as the name of a file -containing the organization." - ;; The organization must be got in this order since the ORGANIZATION - ;; environment variable is intended for user specific while - ;; gnus-local-organization is for machine or organization specific. - - ;; Note: compatibility hack. This will be removed in the next version. - (and (null gnus-local-organization) - (boundp 'gnus-your-organization) - (setq gnus-local-organization gnus-your-organization)) - ;; End of compatibility hack. - (let* ((private-file (expand-file-name "~/.organization" nil)) - (organization (or (getenv "ORGANIZATION") - gnus-local-organization - private-file))) - (and (stringp organization) - (> (length organization) 0) - (string-equal (substring organization 0 1) "/") - ;; Get it from the user and system file. - ;; Suggested by roland@wheaties.ai.mit.edu (Roland McGrath). - (let ((dist (mail-fetch-field "distribution"))) - (setq organization - (cond ((file-exists-p (concat organization "-" dist)) - (concat organization "-" dist)) - ((file-exists-p organization) organization) - ((file-exists-p gnus-organization-file) - gnus-organization-file) - (t organization))) - )) - (cond ((not (stringp organization)) nil) - ((and (string-equal (substring organization 0 1) "/") - (file-exists-p organization)) - ;; If the first character is `/', assume it is the name of - ;; a file containing the organization. - (save-excursion - (let ((tmpbuf (get-buffer-create " *GNUS organization*"))) - (set-buffer tmpbuf) - (erase-buffer) - (insert-file-contents organization) - (prog1 (buffer-string) - (kill-buffer tmpbuf)) - ))) - ((string-equal organization private-file) nil) ;No such file - (t organization)) - )) - -(defun gnus-inews-lines () - "Count the number of lines and return numeric string." - (save-excursion - (save-restriction - (widen) - (goto-char (point-min)) - (search-forward "\n\n" nil 'move) - (int-to-string (count-lines (point) (point-max)))))) - -(provide 'gnuspost) - -;;; gnuspost.el ends here diff --git a/lisp/gosmacs.el b/lisp/gosmacs.el deleted file mode 100644 index 93bbbaa5b80..00000000000 --- a/lisp/gosmacs.el +++ /dev/null @@ -1,117 +0,0 @@ -;;; gosmacs.el --- rebindings to imitate Gosmacs. - -;; Copyright (C) 1986 Free Software Foundation, Inc. - -;; Maintainer: FSF -;; Keywords: emulations - -;; 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, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; Commentary: - -;; Make GNU Emacs look like Gosling Emacs. `M-x set-gosmacs-bindings' -;; does this change; `M-x set-gnu-bindings' undoes it. - -;;; Code: - -(require 'mlsupport) - -(defvar non-gosmacs-binding-alist nil) - -;;;###autoload -(defun set-gosmacs-bindings () - "Rebind some keys globally to make GNU Emacs resemble Gosling Emacs. -Use \\[set-gnu-bindings] to restore previous global bindings." - (interactive) - (setq non-gosmacs-binding-alist - (rebind-and-record - '(("\C-x\C-e" compile) - ("\C-x\C-f" save-buffers-kill-emacs) - ("\C-x\C-i" insert-file) - ("\C-x\C-m" save-some-buffers) - ("\C-x\C-n" next-error) - ("\C-x\C-o" switch-to-buffer) - ("\C-x\C-r" insert-file) - ("\C-x\C-u" undo) - ("\C-x\C-v" find-file-other-window) - ("\C-x\C-z" shrink-window) - ("\C-x!" shell-command) - ("\C-xd" delete-window) - ("\C-xn" gosmacs-next-window) - ("\C-xp" gosmacs-previous-window) - ("\C-xz" enlarge-window) - ("\C-z" scroll-one-line-up) - ("\e\C-c" save-buffers-kill-emacs) - ("\e!" line-to-top-of-window) - ("\e(" backward-paragraph) - ("\e)" forward-paragraph) - ("\e?" apropos) - ("\eh" delete-previous-word) - ("\ej" indent-sexp) - ("\eq" query-replace) - ("\er" replace-string) - ("\ez" scroll-one-line-down) - ("\C-_" suspend-emacs))))) - -(defun rebind-and-record (bindings) - "Establish many new global bindings and record the bindings replaced. -Arg BINDINGS is an alist whose elements are (KEY DEFINITION). -Returns a similar alist whose elements describe the same KEYs -but each with the old definition that was replaced," - (let (old) - (while bindings - (let* ((this (car bindings)) - (key (car this)) - (newdef (nth 1 this))) - (setq old (cons (list key (lookup-key global-map key)) old)) - (global-set-key key newdef)) - (setq bindings (cdr bindings))) - (nreverse old))) - -(defun set-gnu-bindings () - "Restore the global bindings that were changed by \\[set-gosmacs-bindings]." - (interactive) - (rebind-and-record non-gosmacs-binding-alist)) - -(defun gosmacs-previous-window () - "Select the window above or to the left of the window now selected. -From the window at the upper left corner, select the one at the lower right." - (interactive) - (select-window (previous-window))) - -(defun gosmacs-next-window () - "Select the window below or to the right of the window now selected. -From the window at the lower right corner, select the one at the upper left." - (interactive) - (select-window (next-window))) - -(defun scroll-one-line-up (&optional arg) - "Scroll the selected window up (forward in the text) one line (or N lines)." - (interactive "p") - (scroll-up (or arg 1))) - -(defun scroll-one-line-down (&optional arg) - "Scroll the selected window down (backward in the text) one line (or N)." - (interactive "p") - (scroll-down (or arg 1))) - -(defun line-to-top-of-window () - "Scroll the selected window up so that the current line is at the top." - (interactive) - (recenter 0)) - -;;; gosmacs.el ends here diff --git a/lisp/grow-vers.el b/lisp/grow-vers.el deleted file mode 100644 index a7d03dd00bf..00000000000 --- a/lisp/grow-vers.el +++ /dev/null @@ -1,41 +0,0 @@ -;;; grow-vers.el --- increment Emacs version number - -;; Copyright (C) 1985 Free Software Foundation, Inc. - -;; Maintainer: FSF -;; Keywords: internal - -;; 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, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; Commentary: - -;; Load this file to add a new level (starting at zero) -;; to the Emacs version number recorded in version.el. - -;;; Code: - -(insert-file-contents "lisp/version.el") - -(re-search-forward "emacs-version \"[0-9.]*") -(insert ".0") - -;; Delete the share-link with the current version -;; so that we do not alter the current version. -(delete-file "lisp/version.el") -(write-region (point-min) (point-max) "lisp/version.el" nil 'nomsg) - -;;; grow-vers.el ends here diff --git a/lisp/inc-vers.el b/lisp/inc-vers.el deleted file mode 100644 index 0a4a43f0ea8..00000000000 --- a/lisp/inc-vers.el +++ /dev/null @@ -1,54 +0,0 @@ -;;; inc-vers.el --- load this to increment the recorded Emacs version number. - -;; Copyright (C) 1985, 1986 Free Software Foundation, Inc. - -;; Maintainer: FSF -;; Keywords: internal - -;; 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, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; Code: - -(insert-file-contents "../lisp/version.el") - -(re-search-forward "emacs-version \"[^\"]*[0-9]+\"") -(forward-char -1) -(save-excursion - (save-restriction - (narrow-to-region (point) - (progn (skip-chars-backward "0-9") (point))) - (goto-char (point-min)) - (let ((version (read (current-buffer)))) - (delete-region (point-min) (point-max)) - (prin1 (1+ version) (current-buffer))))) -(skip-chars-backward "^\"") -(message "New Emacs version will be %s" - (buffer-substring (point) - (progn (skip-chars-forward "^\"") (point)))) - - -(if (and (file-accessible-directory-p "../lisp/") - (null (file-writable-p "../lisp/version.el"))) - (delete-file "../lisp/version.el")) -(if (eq system-type 'ms-dos) (setq buffer-file-type t)) -(write-region (point-min) (point-max) "../lisp/version.el" nil 'nomsg) -(erase-buffer) -(set-buffer-modified-p nil) - -(kill-emacs) - -;;; inc-vers.el ends here diff --git a/lisp/isearch-old.el b/lisp/isearch-old.el deleted file mode 100644 index ee7a1b04476..00000000000 --- a/lisp/isearch-old.el +++ /dev/null @@ -1,608 +0,0 @@ -;;; isearch.el --- incremental search commands - -;; Copyright (C) 1985, 1986 Free Software Foundation, Inc. - -;; Maintainer: FSF - -;; 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, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; Code: - -(defvar search-last-string "" "\ -Last string search for by a non-regexp search command. -This does not include direct calls to the primitive search functions, -and does not include searches that are aborted.") - -(defvar search-last-regexp "" "\ -Last string searched for by a regexp search command. -This does not include direct calls to the primitive search functions, -and does not include searches that are aborted.") - - -(defconst search-repeat-char ?\C-s "\ -*Character to repeat incremental search forwards.") -(defconst search-reverse-char ?\C-r "\ -*Character to repeat incremental search backwards.") -(defconst search-exit-char ?\C-m "\ -*Character to exit incremental search.") -(defconst search-delete-char ?\177 "\ -*Character to delete from incremental search string.") -(defconst search-quote-char ?\C-q "\ -*Character to quote special characters for incremental search.") -(defconst search-yank-word-char ?\C-w "\ -*Character to pull next word from buffer into search string.") -(defconst search-yank-line-char ?\C-y "\ -*Character to pull rest of line from buffer into search string.") -(defconst search-ring-advance-char ?\M-n "\ -*Character to pull next (more recent) search string from the ring of same.") -(defconst search-ring-retreat-char ?\M-p "\ -*Character to pull previous (older) search string from the ring of same.") - -(defconst search-exit-option t "\ -*Non-nil means random control characters terminate incremental search.") - -(defvar search-slow-window-lines 1 "\ -*Number of lines in slow search display windows. -These are the short windows used during incremental search on slow terminals. -Negative means put the slow search window at the top (normally it's at bottom) -and the value is minus the number of lines.") - -(defvar search-slow-speed 1200 "\ -*Highest terminal speed at which to use \"slow\" style incremental search. -This is the style where a one-line window is created to show the line -that the search has reached.") - -(defconst search-upper-case t - "*Non-nil means an upper-case letter as search input means case-sensitive. -Any upper-case letter given explicitly as input to the incremental search -has the effect of turning off `case-fold-search' for the rest of this search. -Deleting the letter from the search string cancels the effect.") - -(fset 'search-forward-regexp 're-search-forward) -(fset 'search-backward-regexp 're-search-backward) - -(defvar search-ring nil - "List of recent non-regexp incremental searches. -Each element is a cons cell of the form (STRING . UPPERCASE-FLAG).") - -(defvar regexp-search-ring nil - "List of recent regexp incremental searches. -Each element is a cons cell of the form (STRING . UPPERCASE-FLAG).") - -(defconst search-ring-max 16 - "*Maximum length of search ring before oldest elements are thrown away.") - -(defvar search-ring-yank-pointer nil - "The tail of the search ring whose car is the last thing searched for.") - -(defvar regexp-search-ring-yank-pointer nil - "The tail of the regular expression search ring whose car is the last -thing searched for.") - - -(defun isearch-forward () - "Do incremental search forward. -As you type characters, they add to the search string and are found. -Type Delete to cancel characters from end of search string. -Type RET to exit, leaving point at location found. -Type C-s to search again forward, C-r to search again backward. -Type C-w to yank word from buffer onto end of search string and search for it. -Type C-y to yank rest of line onto end of search string, etc. -Type C-q to quote control character to search for it. -Other control and meta characters terminate the search - and are then executed normally. -The above special characters are mostly controlled by parameters; - do M-x apropos on search-.*-char to find them. -C-g while searching or when search has failed - cancels input back to what has been found successfully. -C-g when search is successful aborts and moves point to starting point." - (interactive) - (isearch t)) -(define-key global-map "\C-s" 'isearch-forward) - -(defun isearch-forward-regexp () - "Do incremental search forward for regular expression. -Like ordinary incremental search except that your input -is treated as a regexp. See \\[isearch-forward] for more info." - (interactive) - (isearch t t)) -(define-key esc-map "\C-s" 'isearch-forward-regexp) - -(defun isearch-backward () - "Do incremental search backward. -See \\[isearch-forward] for more information." - (interactive) - (isearch nil)) -(define-key global-map "\C-r" 'isearch-backward) - -(defun isearch-backward-regexp () - "Do incremental search backward for regular expression. -Like ordinary incremental search except that your input -is treated as a regexp. See \\[isearch-forward] for more info." - (interactive) - (isearch nil t)) -(define-key esc-map "\C-r" 'isearch-backward-regexp) - - -;; This function does all the work of incremental search. -;; The functions attached to ^R and ^S are trivial, -;; merely calling this one, but they are always loaded by default -;; whereas this file can optionally be autoloadable. -;; This is the only entry point in this file. - -;; OP-FUN is a function to be called after each input character is processed. -;; (It is not called after characters that exit the search.) - -(defun isearch (forward &optional regexp op-fun) - (let ((search-string "") - (search-message "") - ;; List of previous states during this search. - (history nil) - ;; t means search is currently successful. - (success t) - ;; Set once the search has wrapped around the end of the buffer. - (wrapped nil) - ;; Nominal starting point for searching - ;; Usually this is the same as the opoint, - ;; but it is changed by wrapping - ;; and also by repeating the search. - (barrier (point)) - ;; Set temporarily when adding a character to a regexp - ;; enables it to match more rather than fewer places in the buffer. - liberalized - ;; Set temporarily by yanking text into the search string. - yank-flag - (invalid-regexp nil) - ;; non-nil means an explicit uppercase letter seen in the input - (uppercase-flag nil) - ;; Non-nil means start using a small window - ;; if the search moves outside what is currently on the frame. - (slow-terminal-mode (and (<= baud-rate search-slow-speed) - (> (window-height) - (* 4 search-slow-window-lines)))) - ;; t means a small window is currently in use. - (small-window nil) ;if t, using a small window - ;; These variables preserve information from the small window - ;; through exit from the save-window-excursion. - (found-point nil) - (found-start nil) - ;; Point is at one end of the last match. - ;; This variable records the other end of that match. - (other-end nil) - ;; Value of point at start of search, - ;; for moving the cursor back on quitting. - (opoint (point)) - (inhibit-quit t) ;Prevent ^G from quitting, so we can read it. - ;; The frame we're working on; if this changes, we exit isearch. - (frame (if (fboundp 'selected-frame) (selected-frame)))) - - (isearch-push-state) - (save-window-excursion - (catch 'search-done - (while t - (or (and (numberp unread-command-char) (>= unread-command-char 0)) - (progn - (or (input-pending-p) - (isearch-message)) - (if (and slow-terminal-mode - (not (or small-window (pos-visible-in-window-p)))) - (progn - (setq small-window t) - (setq found-point (point)) - (move-to-window-line 0) - (let ((window-min-height 1)) - (split-window nil (if (< search-slow-window-lines 0) - (1+ (- search-slow-window-lines)) - (- (window-height) - (1+ search-slow-window-lines))))) - (if (< search-slow-window-lines 0) - (progn (vertical-motion (- 1 search-slow-window-lines)) - (set-window-start (next-window) (point)) - (set-window-hscroll (next-window) - (window-hscroll)) - (set-window-hscroll (selected-window) 0)) - (other-window 1)) - (goto-char found-point))))) - (let ((char (if quit-flag - ?\C-g - (read-event)))) - (setq quit-flag nil liberalized nil yank-flag nil) - (cond ((and (or (not (integerp char)) - (and (>= char 128) - (not (= char search-ring-advance-char)) - (not (= char search-ring-retreat-char)))) - search-exit-option) - (setq unread-command-char char) - (throw 'search-done t)) - - ;; If the user switches to a different frame, exit. - ((not (eq frame last-event-frame)) - (setq unread-command-char char) - (throw 'search-done t)) - - ((eq char search-exit-char) - ;; RET means exit search normally. - ;; Except, if first thing typed, it means do nonincremental - (if (= 0 (length search-string)) - (nonincremental-search forward regexp)) - (throw 'search-done t)) - ((= char ?\C-g) - ;; ^G means the user tried to quit. - (ding) - (discard-input) - (if success - ;; If search is successful, move back to starting point - ;; and really do quit. - (progn (goto-char opoint) - (signal 'quit nil)) - ;; If search is failing, rub out until it is once more - ;; successful. - (while (not success) (isearch-pop)))) - ((or (eq char search-repeat-char) - (eq char search-reverse-char)) - (if (eq forward (eq char search-repeat-char)) - ;; C-s in forward or C-r in reverse. - (if (equal search-string "") - ;; If search string is empty, use last one. - (isearch-get-string-from-ring) - ;; If already have what to search for, repeat it. - (or success - (progn (goto-char (if forward (point-min) (point-max))) - (setq wrapped t)))) - ;; C-s in reverse or C-r in forward, change direction. - (setq forward (not forward))) - (setq barrier (point)) ; For subsequent \| if regexp. - (setq success t) - (or (equal search-string "") - (progn - ;; If repeating a search that found an empty string, - ;; ensure we advance. Test history to make sure we - ;; actually have done a search already; otherwise, - ;; the match data will be random. - (if (and (cdr history) - (= (match-end 0) (match-beginning 0))) - (forward-char (if forward 1 -1))) - (isearch-search))) - (isearch-push-state)) - ((= char search-delete-char) - ;; Rubout means discard last input item and move point - ;; back. If buffer is empty, just beep. - (if (null (cdr history)) - (ding) - (isearch-pop))) - ((= char search-ring-advance-char) - (isearch-pop) - (if regexp - (let ((length (length regexp-search-ring))) - (if (zerop length) - () - (setq regexp-search-ring-yank-pointer - (nthcdr (% (+ 1 (- length (length regexp-search-ring-yank-pointer))) - length) - regexp-search-ring)) - (isearch-get-string-from-ring))) - (let ((length (length search-ring))) - (if (zerop length) - () - (setq search-ring-yank-pointer - (nthcdr (% (+ 1 (- length (length search-ring-yank-pointer))) - length) - search-ring)) - (isearch-get-string-from-ring)))) - (isearch-push-state) - (isearch-search)) - ((= char search-ring-retreat-char) - (isearch-pop) - (if regexp - (let ((length (length regexp-search-ring))) - (if (zerop length) - () - (setq regexp-search-ring-yank-pointer - (nthcdr (% (+ (- length (length regexp-search-ring-yank-pointer)) - (1- length)) - length) - regexp-search-ring)) - (isearch-get-string-from-ring))) - (let ((length (length search-ring))) - (if (zerop length) - () - (setq search-ring-yank-pointer - (nthcdr (% (+ (- length (length search-ring-yank-pointer)) - (1- length)) - length) - search-ring)) - (isearch-get-string-from-ring)))) - (isearch-push-state) - (isearch-search)) - (t - (cond ((or (eq char search-yank-word-char) - (eq char search-yank-line-char)) - ;; ^W means gobble next word from buffer. - ;; ^Y means gobble rest of line from buffer. - (let ((word (save-excursion - (and (not forward) other-end - (goto-char other-end)) - (buffer-substring - (point) - (save-excursion - (if (eq char search-yank-line-char) - (end-of-line) - (forward-word 1)) - (point)))))) - (if regexp - (setq word (regexp-quote word))) - (setq search-string (concat search-string word) - search-message - (concat search-message - (mapconcat 'text-char-description - word "")) - ;; Don't move cursor in reverse search. - yank-flag t))) - ;; Any other control char => - ;; unread it and exit the search normally. - ((and search-exit-option - (/= char search-quote-char) - (or (>= char ?\177) - (and (< char ? ) - (/= char ?\t) - (/= char ?\n)))) - (setq unread-command-char char) - (throw 'search-done t)) - (t - ;; Any other character => add it to the - ;; search string and search. - (cond ((= char search-quote-char) - (setq char (read-quoted-char - (isearch-message t)))) - ((= char ?\r) - ;; RET translates to newline. - (setq char ?\n))) - (setq search-string (concat search-string - (char-to-string char)) - search-message (concat search-message - (text-char-description char)) - uppercase-flag (or uppercase-flag - (not (= char (downcase char))))))) - (if (and (not success) - ;; unsuccessful regexp search may become - ;; successful by addition of characters which - ;; make search-string valid - (not regexp)) - nil - ;; Check for chars that can make a regexp more liberal. - ;; They can make a regexp match sooner - ;; or make it succeed instead of failing. - ;; So go back to place last successful search started - ;; or to the last ^S/^R (barrier), whichever is nearer. - (and regexp history - (cond ((and (memq char '(?* ??)) - ;; Don't treat *, ? as special - ;; within [] or after \. - (not (nth 6 (car history)))) - (setq liberalized t) - ;; This used to use element 2 - ;; in a reverse search, but it seems that 5 - ;; (which is the end of the old match) - ;; is better in that case too. - (let ((cs (nth 5 ; old other-end. - (car (cdr history))))) - ;; (car history) is after last search; - ;; (car (cdr history)) is from before it. - (setq cs (or cs barrier)) - (goto-char - (if forward - (max cs barrier) - (min cs barrier))))) - ((eq char ?\|) - (setq liberalized t) - (goto-char barrier)))) - ;; Turn off case-sensitivity if string requests it. - (let ((case-fold-search - (and case-fold-search - (not (and uppercase-flag - search-upper-case))))) - ;; In reverse search, adding stuff at - ;; the end may cause zero or many more chars to be - ;; matched, in the string following point. - ;; Allow all those possibilities without moving point as - ;; long as the match does not extend past search origin. - (if (and (not forward) (not liberalized) - (condition-case () - (looking-at (if regexp search-string - (regexp-quote search-string))) - (error nil)) - (or yank-flag - ;; Used to have (min opoint barrier) - ;; instead of barrier. - ;; This lost when wrapping. - (<= (match-end 0) barrier))) - (setq success t invalid-regexp nil - other-end (match-end 0)) - ;; Not regexp, not reverse, or no match at point. - (if (and other-end (not liberalized)) - (goto-char (if forward other-end - ;; Used to have opoint inside the min. - ;; This lost when wrapping. - (min barrier (1+ other-end))))) - (isearch-search)))) - (isearch-push-state)))) - (if op-fun (funcall op-fun)))) - (setq found-start (window-start (selected-window))) - (setq found-point (point))) - (if (> (length search-string) 0) - (if (and regexp (not (member search-string regexp-search-ring))) - (progn - (setq regexp-search-ring (cons (cons search-string uppercase-flag) - regexp-search-ring) - regexp-search-ring-yank-pointer regexp-search-ring) - (if (> (length regexp-search-ring) search-ring-max) - (setcdr (nthcdr (1- search-ring-max) regexp-search-ring) nil))) - (if (not (member search-string search-ring)) - (progn - (setq search-ring (cons (cons search-string uppercase-flag) - search-ring) - search-ring-yank-pointer search-ring) - (if (> (length search-ring) search-ring-max) - (setcdr (nthcdr (1- search-ring-max) search-ring) nil)))))) - ;; If we displayed a single-line window, set point in this window. - (if small-window - (goto-char found-point)) - ;; If there was movement, mark the starting position. - ;; Maybe should test difference between and set mark iff > threshold. - (if (/= (point) opoint) - (push-mark opoint) - (message "")) - (or small-window - ;; Exiting the save-window-excursion clobbers this; restore it. - (set-window-start (selected-window) found-start t)))) - -(defun isearch-message (&optional c-q-hack ellipsis) - ;; If about to search, and previous search regexp was invalid, - ;; check that it still is. If it is valid now, - ;; let the message we display while searching say that it is valid. - (and invalid-regexp ellipsis - (condition-case () - (progn (re-search-forward search-string (point) t) - (setq invalid-regexp nil)) - (error nil))) - ;; If currently failing, display no ellipsis. - (or success (setq ellipsis nil)) - (let ((m (concat (if success "" "failing ") - (if wrapped "wrapped ") - (if (or (not case-fold-search) - (and uppercase-flag search-upper-case)) - "case-sensitive ") - (if regexp "regexp " "") - "I-search" - (if forward ": " " backward: ") - search-message - (if c-q-hack "^Q" "") - (if invalid-regexp - (concat " [" invalid-regexp "]") - "")))) - (aset m 0 (upcase (aref m 0))) - (let ((cursor-in-echo-area ellipsis)) - (if c-q-hack m (message "%s" m))))) - -;; Get the search string from the "front" of the ring of previous searches. -(defun isearch-get-string-from-ring () - (let ((elt (car (if regexp - (or regexp-search-ring-yank-pointer regexp-search-ring) - (or search-ring-yank-pointer search-ring))))) - ;; ELT describes the most recent search or where we have rotated the ring. - (if elt - (setq search-string (car elt) - uppercase-flag (cdr elt)) - (setq search-string "" uppercase-flag nil))) - ;; Let's give this one the benefit of the doubt. - (setq invalid-regexp nil) - (setq search-message (mapconcat 'text-char-description search-string ""))) - -(defun isearch-pop () - (setq history (cdr history)) - (let ((cmd (car history))) - (setq search-string (car cmd) - search-message (car (cdr cmd)) - success (nth 3 cmd) - forward (nth 4 cmd) - other-end (nth 5 cmd) - invalid-regexp (nth 6 cmd) - wrapped (nth 7 cmd) - barrier (nth 8 cmd) - uppercase-flag (nth 9 cmd)) - (goto-char (car (cdr (cdr cmd)))))) - -(defun isearch-push-state () - (setq history (cons (list search-string search-message (point) - success forward other-end invalid-regexp - wrapped barrier uppercase-flag) - history))) - -(defun isearch-search () - (let ((case-fold-search - (and case-fold-search - (not (and uppercase-flag - search-upper-case))))) - (isearch-message nil t) - (condition-case lossage - (let ((inhibit-quit nil)) - (if regexp (setq invalid-regexp nil)) - (setq success - (funcall - (if regexp - (if forward 're-search-forward 're-search-backward) - (if forward 'search-forward 'search-backward)) - search-string nil t)) - (if success - (setq other-end - (if forward (match-beginning 0) (match-end 0))))) - (quit (setq unread-command-char ?\C-g) - (setq success nil)) - (invalid-regexp (setq invalid-regexp (car (cdr lossage))) - (if (string-match "\\`Premature \\|\\`Unmatched \\|\\`Invalid " - invalid-regexp) - (setq invalid-regexp "incomplete input")))) - (if success - nil - ;; Ding if failed this time after succeeding last time. - (and (nth 3 (car history)) - (ding)) - (goto-char (nth 2 (car history)))))) - -;; This is called from incremental-search -;; if the first input character is the exit character. -;; The interactive-arg-reader uses free variables `forward' and `regexp' -;; which are bound by `incremental-search'. - -;; We store the search string in `search-string' -;; which has been bound already by `incremental-search' -;; so that, when we exit, it is copied into `search-last-string'. - -(defun nonincremental-search (forward regexp) - (let (message char function string inhibit-quit) - (let ((cursor-in-echo-area t)) - ;; Prompt assuming not word search, - (setq message (if regexp - (if forward "Regexp search: " - "Regexp search backward: ") - (if forward "Search: " "Search backward: "))) - (message "%s" message) - ;; Read 1 char and switch to word search if it is ^W. - (setq char (read-event))) - (if (and (numberp char) (eq char search-yank-word-char)) - (setq message (if forward "Word search: " "Word search backward: ")) - ;; Otherwise let that 1 char be part of the search string. - (setq unread-command-char char)) - (setq function - (if (eq char search-yank-word-char) - (if forward 'word-search-forward 'word-search-backward) - (if regexp - (if forward 're-search-forward 're-search-backward) - (if forward 'search-forward 'search-backward)))) - ;; Read the search string with corrected prompt. - (setq string (read-string message)) - ;; Empty means use default. - (if (= 0 (length string)) - (setq string search-last-string) - ;; Set last search string now so it is set even if we fail. - (setq search-last-string string)) - ;; Since we used the minibuffer, we should be available for redo. - (setq command-history (cons (list function string) command-history)) - ;; Go ahead and search. - (funcall function string))) - -;;; isearch.el ends here diff --git a/lisp/iso8859-1.el b/lisp/iso8859-1.el deleted file mode 100644 index 34d0ac0d368..00000000000 --- a/lisp/iso8859-1.el +++ /dev/null @@ -1,104 +0,0 @@ -;;; iso8859-1.el --- set up case-conversion and syntax tables for ISO 8859/1 - -;; Copyright (C) 1988 Free Software Foundation, Inc. - -;; Author: Howard Gayle -;; Maintainer: FSF -;; Keywords: i18n - -;; 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, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; Commentary: - -;; Written by Howard Gayle. See case-table.el for details. - -;;; Code: - -(require 'case-table) - -(let ((table (car (standard-case-table)))) - (set-case-syntax 160 " " table) ; NBSP (no-break space) - (set-case-syntax 161 "." table) ; inverted exclamation mark - (set-case-syntax 162 "w" table) ; cent sign - (set-case-syntax 163 "w" table) ; pound sign - (set-case-syntax 164 "w" table) ; general currency sign - (set-case-syntax 165 "w" table) ; yen sign - (set-case-syntax 166 "_" table) ; broken vertical line - (set-case-syntax 167 "w" table) ; section sign - (set-case-syntax 168 "w" table) ; diaeresis - (set-case-syntax 169 "_" table) ; copyright sign - (set-case-syntax 170 "w" table) ; ordinal indicator, feminine - (set-case-syntax-delims 171 187 table) ; angle quotation marks - (set-case-syntax 172 "_" table) ; not sign - (set-case-syntax 173 "_" table) ; soft hyphen - (set-case-syntax 174 "_" table) ; registered sign - (set-case-syntax 175 "w" table) ; macron - (set-case-syntax 176 "_" table) ; degree sign - (set-case-syntax 177 "_" table) ; plus or minus sign - (set-case-syntax 178 "w" table) ; superscript two - (set-case-syntax 179 "w" table) ; superscript three - (set-case-syntax 180 "w" table) ; acute accent - (set-case-syntax 181 "_" table) ; micro sign - (set-case-syntax 182 "w" table) ; pilcrow - (set-case-syntax 183 "_" table) ; middle dot - (set-case-syntax 184 "w" table) ; cedilla - (set-case-syntax 185 "w" table) ; superscript one - (set-case-syntax 186 "w" table) ; ordinal indicator, masculine - ;; 187 ; See 171 above. - (set-case-syntax 188 "_" table) ; fraction one-quarter - (set-case-syntax 189 "_" table) ; fraction one-half - (set-case-syntax 190 "_" table) ; fraction three-quarters - (set-case-syntax 191 "." table) ; inverted question mark - (set-case-syntax-pair 192 224 table) ; A with grave accent - (set-case-syntax-pair 193 225 table) ; A with acute accent - (set-case-syntax-pair 194 226 table) ; A with circumflex accent - (set-case-syntax-pair 195 227 table) ; A with tilde - (set-case-syntax-pair 196 228 table) ; A with diaeresis or umlaut mark - (set-case-syntax-pair 197 229 table) ; A with ring - (set-case-syntax-pair 198 230 table) ; AE diphthong - (set-case-syntax-pair 199 231 table) ; C with cedilla - (set-case-syntax-pair 200 232 table) ; E with grave accent - (set-case-syntax-pair 201 233 table) ; E with acute accent - (set-case-syntax-pair 202 234 table) ; E with circumflex accent - (set-case-syntax-pair 203 235 table) ; E with diaeresis or umlaut mark - (set-case-syntax-pair 204 236 table) ; I with grave accent - (set-case-syntax-pair 205 237 table) ; I with acute accent - (set-case-syntax-pair 206 238 table) ; I with circumflex accent - (set-case-syntax-pair 207 239 table) ; I with diaeresis or umlaut mark - (set-case-syntax-pair 208 240 table) ; D with stroke, Icelandic eth - (set-case-syntax-pair 209 241 table) ; N with tilde - (set-case-syntax-pair 210 242 table) ; O with grave accent - (set-case-syntax-pair 211 243 table) ; O with acute accent - (set-case-syntax-pair 212 244 table) ; O with circumflex accent - (set-case-syntax-pair 213 245 table) ; O with tilde - (set-case-syntax-pair 214 246 table) ; O with diaeresis or umlaut mark - (set-case-syntax 215 "_" table) ; multiplication sign - (set-case-syntax-pair 216 248 table) ; O with slash - (set-case-syntax-pair 217 249 table) ; U with grave accent - (set-case-syntax-pair 218 250 table) ; U with acute accent - (set-case-syntax-pair 219 251 table) ; U with circumflex accent - (set-case-syntax-pair 220 252 table) ; U with diaeresis or umlaut mark - (set-case-syntax-pair 221 253 table) ; Y with acute accent - (set-case-syntax-pair 222 254 table) ; thorn, Icelandic - (set-case-syntax 223 "w" table) ; small sharp s, German - (set-case-syntax 247 "_" table) ; division sign - (set-case-syntax 255 "w" table) ; small y with diaeresis or umlaut mark - (set-standard-case-table (list table))) - -(provide 'iso8859-1) - -;;; iso8859-1.el ends here diff --git a/lisp/libc.el b/lisp/libc.el deleted file mode 100644 index 0ecb6db9030..00000000000 --- a/lisp/libc.el +++ /dev/null @@ -1,254 +0,0 @@ -;;; libc.el -- lookup C symbols in the GNU C Library Reference Manual. - -;; Copyright (C) 1995, 1996, 1997 Free Software Foundation, Inc. - -;;; Author: Ralph Schleicher <rs@purple.UL.BaWue.DE> -;;; Keywords: local c info - -;; 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: - -;; This code has a long history. It started as a minor -;; mode for C mode. This era ended with the release of version 2 -;; of the GNU C Library in 1997. The code was therefore rewritten -;; more or less from scratch so that all lookups are performed via -;; indices. Not finding an existing symbol in an index means that -;; there is an error in the manual. Long missed features like a -;; separate input history, symbol name completion in the mini-buffer, -;; highlighting of looked up symbol names in the Info buffer, and -;; implicitly prepending `struct', `union' or `enum' to data types -;; were added in this phase too. - -;;; Code: - -(require 'info) - - -(defvar libc-info-file-name "libc" - "Basename of the Info file of the GNU C Library Reference Manual.") - -(defvar libc-highlight-face 'highlight - "*Face for highlighting looked up symbol names in the Info buffer. -`nil' disables highlighting.") - -(defvar libc-highlight-overlay nil - "Overlay object used for highlighting.") - -(defconst libc-symbol-completions nil - "Alist of documented C symbols.") - -(defconst libc-file-completions nil - "Alist of documented programs or files.") - -(defvar libc-history nil - "History of previous input lines.") - -;;;###autoload -(defun libc-describe-symbol (symbol-name) - "Display the documentation of a C symbol in another window. -SYMBOL-NAME must be documented in the GNU C Library Reference Manual. - -If called interactively, SYMBOL-NAME will be read from the mini-buffer. -Optional prefix argument means insert the default symbol (if any) into -the mini-buffer so that it can be edited. The default symbol is the -one found at point. - -If SYMBOL-NAME is a public function, variable, or data type of the GNU -C Library but `libc-describe-symbol' fails to display it's documentation, -then you have found a bug in the manual. Please report that to the mail -address `bug-glibc-manual@prep.ai.mit.edu' so that it can be fixed." - (interactive - (let* ((completion-ignore-case nil) - (enable-recursive-minibuffers t) - (symbol (libc-symbol-at-point)) - (value (completing-read - (if symbol - (format "Describe symbol (default %s): " symbol) - (format "Describe symbol: ")) - libc-symbol-completions nil nil - (and current-prefix-arg symbol) 'libc-history))) - (list (if (equal value "") symbol value)))) - (or (assoc symbol-name libc-symbol-completions) - (error "Not documented as a C symbol: %s" (or symbol-name ""))) - (or (libc-lookup-function symbol-name) - (libc-lookup-variable symbol-name) - (libc-lookup-type symbol-name))) - -;;;###autoload -(defun libc-describe-file (file-name) - "Display the documentation of a program or file in another window. -FILE-NAME must be documented in the GNU C Library Reference Manual." - (interactive - (let* ((completion-ignore-case nil) - (enable-recursive-minibuffers t)) - (list (completing-read - "Describe program or file: " - libc-file-completions nil nil nil 'libc-history)))) - (or (assoc file-name libc-file-completions) - (error "Not documented as a program or file: %s" (or file-name ""))) - (libc-lookup-file file-name)) - -;;;###autoload -(defun libc-search (regexp &optional arg) - "Search in the GNU C Library Reference Manual for REGEXP. -Prefix argument means search should ignore case." - (interactive "sSearch `libc.info' for regexp: \nP") - (or (get-buffer "*info*") - (save-window-excursion - (info))) - (switch-to-buffer-other-window "*info*") - (Info-goto-node (concat "(" libc-info-file-name ")")) - (let ((case-fold-search arg)) - (Info-search regexp))) - - -(defun libc-make-completion-alist (info-nodes &optional regexp) - "Create a unique alist from all menu items in the Info nodes INFO-NODES -of the GNU C Reference Manual. - -Optional second argument REGEXP means include only menu items matching the -regular expression REGEXP." - (condition-case nil - (let (completions item) - (save-window-excursion - (info libc-info-file-name) - (while info-nodes - (Info-goto-node (car info-nodes)) - (goto-char (point-min)) - (and (search-forward "\n* Menu:" nil t) - (while (re-search-forward "\n\\* \\([^:\t\n]*\\):" nil t) - (setq item (buffer-substring - (match-beginning 1) (match-end 1))) - (and (not (assoc item completions)) - (if regexp (string-match regexp item) t) - (setq completions (cons (cons item nil) - completions))))) - (setq info-nodes (cdr info-nodes))) - (Info-directory)) - completions) - (error nil))) - -(defun libc-after-manual-update () - "This function must only be called after a new version of the -GNU C Library Reference Manual was installed on your system." - (setq libc-symbol-completions (libc-make-completion-alist - '("Function Index" - "Variable Index" - "Type Index")) - libc-file-completions (libc-make-completion-alist - '("File Index") "^[^ \t]+$"))) - -(or (and libc-symbol-completions - libc-file-completions) - (libc-after-manual-update)) - -(defun libc-symbol-at-point () - "Get the C symbol at point." - (condition-case nil - (save-excursion - (backward-sexp) - (let ((start (point)) - prefix name) - ;; Test for a leading `struct', `union', or `enum' keyword - ;; but ignore names like `foo_struct'. - (setq prefix (and (< (skip-chars-backward " \t\n") 0) - (< (skip-chars-backward "_a-zA-Z0-9") 0) - (looking-at "\\(struct\\|union\\|enum\\)\\s ") - (concat (buffer-substring - (match-beginning 1) (match-end 1)) - " "))) - (goto-char start) - (and (looking-at "[_a-zA-Z][_a-zA-Z0-9]*") - (setq name (buffer-substring - (match-beginning 0) (match-end 0)))) - ;; Caveat! Look forward if point is at `struct' etc. - (and (not prefix) - (or (string-equal name "struct") - (string-equal name "union") - (string-equal name "enum")) - (looking-at "[a-z]+\\s +\\([_a-zA-Z][_a-zA-Z0-9]*\\)") - (setq prefix (concat name " ") - name (buffer-substring - (match-beginning 1) (match-end 1)))) - (and (or prefix name) - (concat prefix name)))) - (error nil))) - -(defun libc-lookup-function (function) - (libc-search-index "Function Index" function - "^[ \t]+- \\(Function\\|Macro\\): .*\\<" "\\>")) - -(defun libc-lookup-variable (variable) - (libc-search-index "Variable Index" variable - "^[ \t]+- \\(Variable\\|Macro\\): .*\\<" "\\>")) - -(defun libc-lookup-type (data-type) - (libc-search-index "Type Index" data-type - "^[ \t]+- Data Type: \\<" "\\>")) - -(defun libc-lookup-file (file-name) - (libc-search-index "File Index" file-name)) - -(defun libc-search-index (index item &optional prefix suffix) - "Search ITEM in the Info index INDEX and go to that Info node. - -Value is ITEM or `nil' if an error occurs. - -If PREFIX and/or SUFFIX are non-`nil', then search the Info node for -the first occurrence of the regular expression `PREFIX ITEM SUFFIX' and -leave point at the beginning of the first line of the match. ITEM will -be highlighted with `libc-highlight-face' iff `libc-highlight-face' is -not `nil'." - (condition-case nil - (save-selected-window - (or (get-buffer "*info*") - (save-window-excursion - (info))) - (switch-to-buffer-other-window "*info*") - (Info-goto-node (concat "(" libc-info-file-name ")" index)) - (Info-menu item) - (if (or prefix suffix) - (let ((case-fold-search nil) - (buffer-read-only nil)) - (goto-char (point-min)) - (re-search-forward - (concat prefix (regexp-quote item) suffix)) - (goto-char (match-beginning 0)) - (and window-system libc-highlight-face - ;; Search again for ITEM so that the first - ;; occurence of ITEM will be highlighted. - (save-excursion - (re-search-forward (regexp-quote item)) - (let ((start (match-beginning 0)) - (end (match-end 0))) - (if (overlayp libc-highlight-overlay) - (move-overlay libc-highlight-overlay - start end (current-buffer)) - (setq libc-highlight-overlay - (make-overlay start end)))) - (overlay-put libc-highlight-overlay - 'face libc-highlight-face))) - (beginning-of-line))) - item) - (error nil))) - - -(provide 'libc) - -;;; libc.el ends here diff --git a/lisp/man.el b/lisp/man.el deleted file mode 100644 index 2454b48ded9..00000000000 --- a/lisp/man.el +++ /dev/null @@ -1,1186 +0,0 @@ -;;; man.el --- browse UNIX manual pages - -;; Copyright (C) 1993, 1994, 1996, 1997 Free Software Foundation, Inc. - -;; Author: Barry A. Warsaw <bwarsaw@cen.com> -;; Maintainer: FSF -;; Keywords: help -;; Adapted-By: ESR, pot - -;; 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: - -;; This code provides a function, `man', with which you can browse -;; UNIX manual pages. Formatting is done in background so that you -;; can continue to use your Emacs while processing is going on. -;; -;; The mode also supports hypertext-like following of manual page SEE -;; ALSO references, and other features. See below or do `?' in a -;; manual page buffer for details. - -;; ========== Credits and History ========== -;; In mid 1991, several people posted some interesting improvements to -;; man.el from the standard emacs 18.57 distribution. I liked many of -;; these, but wanted everything in one single package, so I decided -;; to incorporate them into a single manual browsing mode. While -;; much of the code here has been rewritten, and some features added, -;; these folks deserve lots of credit for providing the initial -;; excellent packages on which this one is based. - -;; Nick Duffek <duffek@chaos.cs.brandeis.edu>, posted a very nice -;; improvement which retrieved and cleaned the manpages in a -;; background process, and which correctly deciphered such options as -;; man -k. - -;; Eric Rose <erose@jessica.stanford.edu>, submitted manual.el which -;; provided a very nice manual browsing mode. - -;; This package was available as `superman.el' from the LCD package -;; for some time before it was accepted into Emacs 19. The entry -;; point and some other names have been changed to make it a drop-in -;; replacement for the old man.el package. - -;; Francesco Potorti` <pot@cnuce.cnr.it> cleaned it up thoroughly, -;; making it faster, more robust and more tolerant of different -;; systems' man idiosyncrasies. - -;; ========== Features ========== -;; + Runs "man" in the background and pipes the results through a -;; series of sed and awk scripts so that all retrieving and cleaning -;; is done in the background. The cleaning commands are configurable. -;; + Syntax is the same as Un*x man -;; + Functionality is the same as Un*x man, including "man -k" and -;; "man <section>", etc. -;; + Provides a manual browsing mode with keybindings for traversing -;; the sections of a manpage, following references in the SEE ALSO -;; section, and more. -;; + Multiple manpages created with the same man command are put into -;; a narrowed buffer circular list. - -;; ============= TODO =========== -;; - Add a command for printing. -;; - The awk script deletes multiple blank lines. This behaviour does -;; not allow to understand if there was indeed a blank line at the -;; end or beginning of a page (after the header, or before the -;; footer). A different algorithm should be used. It is easy to -;; compute how many blank lines there are before and after the page -;; headers, and after the page footer. But it is possible to compute -;; the number of blank lines before the page footer by euristhics -;; only. Is it worth doing? -;; - Allow a user option to mean that all the manpages should go in -;; the same buffer, where they can be browsed with M-n and M-p. -;; - Allow completion on the manpage name when calling man. This -;; requires a reliable list of places where manpages can be found. The -;; drawback would be that if the list is not complete, the user might -;; be led to believe that the manpages in the missing directories do -;; not exist. - - -;;; Code: - -(require 'assoc) - -;; vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv -;; empty defvars (keep the compiler quiet) - -(defgroup man nil - "Browse UNIX manual pages." - :prefix "Man-" - :group 'help) - - -(defvar Man-notify) -(defvar Man-current-page) -(defvar Man-page-list) -(defcustom Man-filter-list nil - "*Manpage cleaning filter command phrases. -This variable contains a list of the following form: - -'((command-string phrase-string*)*) - -Each phrase-string is concatenated onto the command-string to form a -command filter. The (standard) output (and standard error) of the Un*x -man command is piped through each command filter in the order the -commands appear in the association list. The final output is placed in -the manpage buffer." - :type '(repeat (list (string :tag "Command String") - (repeat :inline t - (string :tag "Phrase String")))) - :group 'man) - -(defvar Man-original-frame) -(defvar Man-arguments) -(defvar Man-sections-alist) -(defvar Man-refpages-alist) -(defvar Man-uses-untabify-flag t - "Non-nil means use `untabify' instead of `Man-untabify-command'.") -(defvar Man-page-mode-string) -(defvar Man-sed-script nil - "Script for sed to nuke backspaces and ANSI codes from manpages.") - -;; vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv -;; user variables - -(defcustom Man-fontify-manpage-flag t - "*Non-nil means make up the manpage with fonts." - :type 'boolean - :group 'man) - -(defcustom Man-overstrike-face 'bold - "*Face to use when fontifying overstrike." - :type 'face - :group 'man) - -(defcustom Man-underline-face 'underline - "*Face to use when fontifying underlining." - :type 'face - :group 'man) - -;; Use the value of the obsolete user option Man-notify, if set. -(defcustom Man-notify-method (if (boundp 'Man-notify) Man-notify 'friendly) - "*Selects the behavior when manpage is ready. -This variable may have one of the following values, where (sf) means -that the frames are switched, so the manpage is displayed in the frame -where the man command was called from: - -newframe -- put the manpage in its own frame (see `Man-frame-parameters') -pushy -- make the manpage the current buffer in the current window -bully -- make the manpage the current buffer and only window (sf) -aggressive -- make the manpage the current buffer in the other window (sf) -friendly -- display manpage in the other window but don't make current (sf) -polite -- don't display manpage, but prints message and beep when ready -quiet -- like `polite', but don't beep -meek -- make no indication that the manpage is ready - -Any other value of `Man-notify-method' is equivalent to `meek'." - :type '(radio (const newframe) (const pushy) (const bully) - (const aggressive) (const friendly) - (const polite) (const quiet) (const meek)) - :group 'man) - -(defcustom Man-frame-parameters nil - "*Frame parameter list for creating a new frame for a manual page." - :type 'sexp - :group 'man) - -(defcustom Man-downcase-section-letters-flag t - "*Non-nil means letters in sections are converted to lower case. -Some Un*x man commands can't handle uppercase letters in sections, for -example \"man 2V chmod\", but they are often displayed in the manpage -with the upper case letter. When this variable is t, the section -letter (e.g., \"2V\") is converted to lowercase (e.g., \"2v\") before -being sent to the man background process." - :type 'boolean - :group 'man) - -(defcustom Man-circular-pages-flag t - "*Non-nil means the manpage list is treated as circular for traversal." - :type 'boolean - :group 'man) - -(defcustom Man-section-translations-alist - (list - '("3C++" . "3") - ;; Some systems have a real 3x man section, so let's comment this. - ;; '("3X" . "3") ; Xlib man pages - '("3X11" . "3") - '("1-UCB" . "")) - "*Association list of bogus sections to real section numbers. -Some manpages (e.g. the Sun C++ 2.1 manpages) have section numbers in -their references which Un*x `man' does not recognize. This -association list is used to translate those sections, when found, to -the associated section number." - :type '(repeat (cons (string :tag "Bogus Section") - (string :tag "Real Section"))) - :group 'man) - -(defvar manual-program "man" - "The name of the program that produces man pages.") - -(defvar Man-untabify-command "pr" - "Command used for untabifying.") - -(defvar Man-untabify-command-args (list "-t" "-e") - "List of arguments to be passed to `Man-untabify-command' (which see).") - -(defvar Man-sed-command "sed" - "Command used for processing sed scripts.") - -(defvar Man-awk-command "awk" - "Command used for processing awk scripts.") - -(defvar Man-mode-line-format - '("-" - mode-line-mule-info - mode-line-modified - mode-line-frame-identification - mode-line-buffer-identification " " - global-mode-string - " " Man-page-mode-string - " %[(" mode-name mode-line-process minor-mode-alist "%n)%]--" - (line-number-mode "L%l--") - (column-number-mode "C%c--") - (-3 . "%p") "-%-") - "Mode line format for manual mode buffer.") - -(defvar Man-mode-map nil - "Keymap for Man mode.") - -(defvar Man-mode-hook nil - "Hook run when Man mode is enabled.") - -(defvar Man-cooked-hook nil - "Hook run after removing backspaces but before `Man-mode' processing.") - -(defvar Man-name-regexp "[-a-zA-Z0-9_][-a-zA-Z0-9_.]*" - "Regular expression describing the name of a manpage (without section).") - -(defvar Man-section-regexp "[0-9][a-zA-Z+]*\\|[LNln]" - "Regular expression describing a manpage section within parentheses.") - -(defvar Man-page-header-regexp - (if (and (string-match "-solaris2\\." system-configuration) - (not (string-match "-solaris2\\.[123435]$" system-configuration))) - (concat "^[-A-Za-z0-9_].*[ \t]\\(" Man-name-regexp - "(\\(" Man-section-regexp "\\))\\)$") - (concat "^[ \t]*\\(" Man-name-regexp - "(\\(" Man-section-regexp "\\))\\).*\\1")) - "Regular expression describing the heading of a page.") - -(defvar Man-heading-regexp "^\\([A-Z][A-Z ]+\\)$" - "Regular expression describing a manpage heading entry.") - -(defvar Man-see-also-regexp "SEE ALSO" - "Regular expression for SEE ALSO heading (or your equivalent). -This regexp should not start with a `^' character.") - -(defvar Man-first-heading-regexp "^[ \t]*NAME$\\|^[ \t]*No manual entry fo.*$" - "Regular expression describing first heading on a manpage. -This regular expression should start with a `^' character.") - -(defvar Man-reference-regexp - (concat "\\(" Man-name-regexp "\\)(\\(" Man-section-regexp "\\))") - "Regular expression describing a reference to another manpage.") - -;; This includes the section as an optional part to catch hyphenated -;; refernces to manpages. -(defvar Man-hyphenated-reference-regexp - (concat "\\(" Man-name-regexp "\\)\\((\\(" Man-section-regexp "\\))\\)?") - "Regular expression describing a reference in the SEE ALSO section.") - -(defvar Man-switches "" - "Switches passed to the man command, as a single string.") - -(defvar Man-specified-section-option - (if (string-match "-solaris[0-9.]*$" system-configuration) - "-s" - "") - "Option that indicates a specified a manual section name.") - -;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -;; end user variables - -;; other variables and keymap initializations -(make-variable-buffer-local 'Man-sections-alist) -(make-variable-buffer-local 'Man-refpages-alist) -(make-variable-buffer-local 'Man-page-list) -(make-variable-buffer-local 'Man-current-page) -(make-variable-buffer-local 'Man-page-mode-string) -(make-variable-buffer-local 'Man-original-frame) -(make-variable-buffer-local 'Man-arguments) - -(setq-default Man-sections-alist nil) -(setq-default Man-refpages-alist nil) -(setq-default Man-page-list nil) -(setq-default Man-current-page 0) -(setq-default Man-page-mode-string "1 of 1") - -(defconst Man-sysv-sed-script "\ -/\b/ { s/_\b//g - s/\b_//g - s/o\b+/o/g - s/+\bo/o/g - :ovstrk - s/\\(.\\)\b\\1/\\1/g - t ovstrk - } -/\e\\[[0-9][0-9]*m/ s///g" - "Script for sysV-like sed to nuke backspaces and ANSI codes from manpages.") - -(defconst Man-berkeley-sed-script "\ -/\b/ { s/_\b//g\\ - s/\b_//g\\ - s/o\b+/o/g\\ - s/+\bo/o/g\\ - :ovstrk\\ - s/\\(.\\)\b\\1/\\1/g\\ - t ovstrk\\ - }\\ -/\e\\[[0-9][0-9]*m/ s///g" - "Script for berkeley-like sed to nuke backspaces and ANSI codes from manpages.") - -(defvar man-mode-syntax-table - (let ((table (copy-syntax-table (standard-syntax-table)))) - (modify-syntax-entry ?. "w" table) - (modify-syntax-entry ?_ "w" table) - table) - "Syntax table used in Man mode buffers.") - -(if Man-mode-map - nil - (setq Man-mode-map (make-keymap)) - (suppress-keymap Man-mode-map) - (define-key Man-mode-map " " 'scroll-up) - (define-key Man-mode-map "\177" 'scroll-down) - (define-key Man-mode-map "n" 'Man-next-section) - (define-key Man-mode-map "p" 'Man-previous-section) - (define-key Man-mode-map "\en" 'Man-next-manpage) - (define-key Man-mode-map "\ep" 'Man-previous-manpage) - (define-key Man-mode-map ">" 'end-of-buffer) - (define-key Man-mode-map "<" 'beginning-of-buffer) - (define-key Man-mode-map "." 'beginning-of-buffer) - (define-key Man-mode-map "r" 'Man-follow-manual-reference) - (define-key Man-mode-map "g" 'Man-goto-section) - (define-key Man-mode-map "s" 'Man-goto-see-also-section) - (define-key Man-mode-map "k" 'Man-kill) - (define-key Man-mode-map "q" 'Man-quit) - (define-key Man-mode-map "m" 'man) - (define-key Man-mode-map "\r" 'man-follow) - (define-key Man-mode-map "?" 'describe-mode) - ) - - -;; ====================================================================== -;; utilities - -(defun Man-init-defvars () - "Used for initialising variables based on display's color support. -This is necessary if one wants to dump man.el with Emacs." - - ;; Avoid possible error in call-process by using a directory that must exist. - (let ((default-directory "/")) - (setq Man-sed-script - (cond - (Man-fontify-manpage-flag - nil) - ((= 0 (call-process Man-sed-command nil nil nil Man-sysv-sed-script)) - Man-sysv-sed-script) - ((= 0 (call-process Man-sed-command nil nil nil Man-berkeley-sed-script)) - Man-berkeley-sed-script) - (t - nil)))) - - (setq Man-filter-list - ;; Avoid trailing nil which confuses customize. - (apply 'list - (cons - Man-sed-command - (list - (if Man-sed-script - (concat "-e '" Man-sed-script "'") - "") - "-e '/^[\001-\032][\001-\032]*$/d'" - "-e '/\e[789]/s///g'" - "-e '/Reformatting page. Wait/d'" - "-e '/Reformatting entry. Wait/d'" - "-e '/^[ \t]*Hewlett-Packard[ \t]Company[ \t]*-[ \t][0-9]*[ \t]-/d'" - "-e '/^[ \t]*Hewlett-Packard[ \t]*-[ \t][0-9]*[ \t]-.*$/d'" - "-e '/^[ \t][ \t]*-[ \t][0-9]*[ \t]-[ \t]*Formatted:.*[0-9]$/d'" - "-e '/^[ \t]*Page[ \t][0-9]*.*(printed[ \t][0-9\\/]*)$/d'" - "-e '/^Printed[ \t][0-9].*[0-9]$/d'" - "-e '/^[ \t]*X[ \t]Version[ \t]1[01].*Release[ \t][0-9]/d'" - "-e '/^[A-Za-z].*Last[ \t]change:/d'" - "-e '/^Sun[ \t]Release[ \t][0-9].*[0-9]$/d'" - "-e '/[ \t]*Copyright [0-9]* UNIX System Laboratories, Inc.$/d'" - "-e '/^[ \t]*Rev\\..*Page [0-9][0-9]*$/d'" - )) - (cons - Man-awk-command - (list - "'\n" - "BEGIN { blankline=0; anonblank=0; }\n" - "/^$/ { if (anonblank==0) next; }\n" - "{ anonblank=1; }\n" - "/^$/ { blankline++; next; }\n" - "{ if (blankline>0) { print \"\"; blankline=0; } print $0; }\n" - "'" - )) - (if (not Man-uses-untabify-flag) - ;; The outer list will be stripped off by apply. - (list (cons - Man-untabify-command - Man-untabify-command-args)) - ))) -) - -(defsubst Man-match-substring (&optional n string) - "Return the substring matched by the last search. -Optional arg N means return the substring matched by the Nth paren -grouping. Optional second arg STRING means return a substring from -that string instead of from the current buffer." - (if (null n) (setq n 0)) - (if string - (substring string (match-beginning n) (match-end n)) - (buffer-substring (match-beginning n) (match-end n)))) - -(defsubst Man-make-page-mode-string () - "Formats part of the mode line for Man mode." - (format "%s page %d of %d" - (or (nth 2 (nth (1- Man-current-page) Man-page-list)) - "") - Man-current-page - (length Man-page-list))) - -(defsubst Man-build-man-command () - "Builds the entire background manpage and cleaning command." - (let ((command (concat manual-program " " Man-switches - ; Stock MS-DOS shells cannot redirect stderr; - ; `call-process' below sends it to /dev/null, - ; so we don't need `2>' even with DOS shells - ; which do support stderr redirection. - (if (not (fboundp 'start-process)) - " %s" - (concat " %s 2>" null-device)))) - (flist Man-filter-list)) - (while (and flist (car flist)) - (let ((pcom (car (car flist))) - (pargs (cdr (car flist)))) - (setq command - (concat command " | " pcom " " - (mapconcat (lambda (phrase) - (if (not (stringp phrase)) - (error "Malformed Man-filter-list")) - phrase) - pargs " "))) - (setq flist (cdr flist)))) - command)) - -(defun Man-translate-references (ref) - "Translates REF from \"chmod(2V)\" to \"2v chmod\" style. -Leave it as is if already in that style. Possibly downcase and -translate the section (see the Man-downcase-section-letters-flag -and the Man-section-translations-alist variables)." - (let ((name "") - (section "") - (slist Man-section-translations-alist)) - (cond - ;; "chmod(2V)" case ? - ((string-match (concat "^" Man-reference-regexp "$") ref) - (setq name (Man-match-substring 1 ref) - section (Man-match-substring 2 ref))) - ;; "2v chmod" case ? - ((string-match (concat "^\\(" Man-section-regexp - "\\) +\\(" Man-name-regexp "\\)$") ref) - (setq name (Man-match-substring 2 ref) - section (Man-match-substring 1 ref)))) - (if (string= name "") - ref ; Return the reference as is - (if Man-downcase-section-letters-flag - (setq section (downcase section))) - (while slist - (let ((s1 (car (car slist))) - (s2 (cdr (car slist)))) - (setq slist (cdr slist)) - (if Man-downcase-section-letters-flag - (setq s1 (downcase s1))) - (if (not (string= s1 section)) nil - (setq section (if Man-downcase-section-letters-flag - (downcase s2) - s2) - slist nil)))) - (concat Man-specified-section-option section " " name)))) - - -;; ====================================================================== -;; default man entry: get word under point - -(defsubst Man-default-man-entry () - "Make a guess at a default manual entry. -This guess is based on the text surrounding the cursor." - (let (word) - (save-excursion - ;; Default man entry title is any word the cursor is on, or if - ;; cursor not on a word, then nearest preceding word. - (setq word (current-word)) - (if (string-match "[._]+$" word) - (setq word (substring word 0 (match-beginning 0)))) - ;; If looking at something like ioctl(2) or brc(1M), include the - ;; section number in the returned value. Remove text properties. - (forward-word 1) - ;; Use `format' here to clear any text props from `word'. - (format "%s%s" - word - (if (looking-at - (concat "[ \t]*([ \t]*\\(" Man-section-regexp "\\)[ \t]*)")) - (format "(%s)" (Man-match-substring 1)) - ""))))) - - -;; ====================================================================== -;; Top level command and background process sentinel - -;; For compatibility with older versions. -;;;###autoload -(defalias 'manual-entry 'man) - -;;;###autoload -(defun man (man-args) - "Get a Un*x manual page and put it in a buffer. -This command is the top-level command in the man package. It runs a Un*x -command to retrieve and clean a manpage in the background and places the -results in a Man mode (manpage browsing) buffer. See variable -`Man-notify-method' for what happens when the buffer is ready. -If a buffer already exists for this man page, it will display immediately. - -To specify a man page from a certain section, type SUBJECT(SECTION) or -SECTION SUBJECT when prompted for a manual entry." - (interactive - (list (let* ((default-entry (Man-default-man-entry)) - (input (read-string - (format "Manual entry%s: " - (if (string= default-entry "") - "" - (format " (default %s)" default-entry)))))) - (if (string= input "") - (if (string= default-entry "") - (error "No man args given") - default-entry) - input)))) - - ;; Possibly translate the "subject(section)" syntax into the - ;; "section subject" syntax and possibly downcase the section. - (setq man-args (Man-translate-references man-args)) - - (Man-getpage-in-background man-args)) - -;;;###autoload -(defun man-follow (man-args) - "Get a Un*x manual page of the item under point and put it in a buffer." - (interactive (list (Man-default-man-entry))) - (if (or (not man-args) - (string= man-args "")) - (error "No item under point") - (man man-args))) - -(defun Man-getpage-in-background (topic) - "Use TOPIC to build and fire off the manpage and cleaning command." - (let* ((man-args topic) - (bufname (concat "*Man " man-args "*")) - (buffer (get-buffer bufname))) - (if buffer - (Man-notify-when-ready buffer) - (require 'env) - (message "Invoking %s %s in the background" manual-program man-args) - (setq buffer (generate-new-buffer bufname)) - (save-excursion - (set-buffer buffer) - (setq Man-original-frame (selected-frame)) - (setq Man-arguments man-args)) - (let ((process-environment (copy-sequence process-environment)) - ;; The following is so Awk script gets \n intact - ;; But don't prevent decoding of the outside. - (coding-system-for-write 'raw-text-unix) - ;; We must decode the output by a coding system that the - ;; system's locale suggests in multibyte mode. - (coding-system-for-read - (if default-enable-multibyte-characters - locale-coding-system 'raw-text-unix)) - ;; Avoid possible error by using a directory that always exists. - (default-directory "/")) - ;; Prevent any attempt to use display terminal fanciness. - (setenv "TERM" "dumb") - (if (fboundp 'start-process) - (set-process-sentinel - (start-process manual-program buffer "sh" "-c" - (format (Man-build-man-command) man-args)) - 'Man-bgproc-sentinel) - (progn - (let ((exit-status - (call-process shell-file-name nil (list buffer nil) nil "-c" - (format (Man-build-man-command) man-args))) - (msg "")) - (or (and (numberp exit-status) - (= exit-status 0)) - (and (numberp exit-status) - (setq msg - (format "exited abnormally with code %d" - exit-status))) - (setq msg exit-status)) - (Man-bgproc-sentinel bufname msg)))))))) - -(defun Man-notify-when-ready (man-buffer) - "Notify the user when MAN-BUFFER is ready. -See the variable `Man-notify-method' for the different notification behaviors." - (let ((saved-frame (save-excursion - (set-buffer man-buffer) - Man-original-frame))) - (cond - ((eq Man-notify-method 'newframe) - ;; Since we run asynchronously, perhaps while Emacs is waiting - ;; for input, we must not leave a different buffer current. We - ;; can't rely on the editor command loop to reselect the - ;; selected window's buffer. - (save-excursion - (let ((frame (make-frame Man-frame-parameters))) - (set-window-buffer (frame-selected-window frame) man-buffer) - (set-window-dedicated-p (frame-selected-window frame) t) - (or (display-multi-frame-p frame) - (select-frame frame))))) - ((eq Man-notify-method 'pushy) - (switch-to-buffer man-buffer)) - ((eq Man-notify-method 'bully) - (and (frame-live-p saved-frame) - (select-frame saved-frame)) - (pop-to-buffer man-buffer) - (delete-other-windows)) - ((eq Man-notify-method 'aggressive) - (and (frame-live-p saved-frame) - (select-frame saved-frame)) - (pop-to-buffer man-buffer)) - ((eq Man-notify-method 'friendly) - (and (frame-live-p saved-frame) - (select-frame saved-frame)) - (display-buffer man-buffer 'not-this-window)) - ((eq Man-notify-method 'polite) - (beep) - (message "Manual buffer %s is ready" (buffer-name man-buffer))) - ((eq Man-notify-method 'quiet) - (message "Manual buffer %s is ready" (buffer-name man-buffer))) - ((or (eq Man-notify-method 'meek) - t) - (message "")) - ))) - -(defun Man-softhyphen-to-minus () - ;; \255 is some kind of dash in Latin-N. Versions of Debian man, at - ;; least, emit it even when not in a Latin-N locale. - (unless (eq t (compare-strings "latin-" 0 nil - current-language-environment 0 6 t)) - (goto-char (point-min)) - (let ((str "\255")) - (if enable-multibyte-characters - (setq str (string-as-multibyte str))) - (while (search-forward str nil t) (replace-match "-"))))) - -(defun Man-fontify-manpage () - "Convert overstriking and underlining to the correct fonts. -Same for the ANSI bold and normal escape sequences." - (interactive) - (message "Please wait: making up the %s man page..." Man-arguments) - (goto-char (point-min)) - (while (search-forward "\e[1m" nil t) - (delete-backward-char 4) - (put-text-property (point) - (progn (if (search-forward "\e[0m" nil 'move) - (delete-backward-char 4)) - (point)) - 'face Man-overstrike-face)) - (if (< (buffer-size) (position-bytes (point-max))) - ;; Multibyte characters exist. - (progn - (goto-char (point-min)) - (while (search-forward "__\b\b" nil t) - (backward-delete-char 4) - (put-text-property (point) (1+ (point)) 'face Man-underline-face)) - (goto-char (point-min)) - (while (search-forward "\b\b__" nil t) - (backward-delete-char 4) - (put-text-property (1- (point)) (point) 'face Man-underline-face)))) - (goto-char (point-min)) - (while (search-forward "_\b" nil t) - (backward-delete-char 2) - (put-text-property (point) (1+ (point)) 'face Man-underline-face)) - (goto-char (point-min)) - (while (search-forward "\b_" nil t) - (backward-delete-char 2) - (put-text-property (1- (point)) (point) 'face Man-underline-face)) - (goto-char (point-min)) - (while (re-search-forward "\\(.\\)\\(\b+\\1\\)+" nil t) - (replace-match "\\1") - (put-text-property (1- (point)) (point) 'face Man-overstrike-face)) - (goto-char (point-min)) - (while (re-search-forward "o\b\\+\\|\\+\bo" nil t) - (replace-match "o") - (put-text-property (1- (point)) (point) 'face 'bold)) - (goto-char (point-min)) - (while (re-search-forward "[-|]\\(\b[-|]\\)+" nil t) - (replace-match "+") - (put-text-property (1- (point)) (point) 'face 'bold)) - (Man-softhyphen-to-minus) - (message "%s man page made up" Man-arguments)) - -(defun Man-cleanup-manpage () - "Remove overstriking and underlining from the current buffer." - (interactive) - (message "Please wait: cleaning up the %s man page..." - Man-arguments) - (if (or (interactive-p) (not Man-sed-script)) - (progn - (goto-char (point-min)) - (while (search-forward "_\b" nil t) (backward-delete-char 2)) - (goto-char (point-min)) - (while (search-forward "\b_" nil t) (backward-delete-char 2)) - (goto-char (point-min)) - (while (re-search-forward "\\(.\\)\\(\b\\1\\)+" nil t) - (replace-match "\\1")) - (goto-char (point-min)) - (while (re-search-forward "\e\\[[0-9]+m" nil t) (replace-match "")) - (goto-char (point-min)) - (while (re-search-forward "o\b\\+\\|\\+\bo" nil t) (replace-match "o")) - )) - (goto-char (point-min)) - (while (re-search-forward "[-|]\\(\b[-|]\\)+" nil t) (replace-match "+")) - (Man-softhyphen-to-minus) - (message "%s man page cleaned up" Man-arguments)) - -(defun Man-bgproc-sentinel (process msg) - "Manpage background process sentinel. -When manpage command is run asynchronously, PROCESS is the process -object for the manpage command; when manpage command is run -synchronously, PROCESS is the name of the buffer where the manpage -command is run. Second argument MSG is the exit message of the -manpage command." - (let ((Man-buffer (if (stringp process) (get-buffer process) - (process-buffer process))) - (delete-buff nil) - (err-mess nil)) - - (if (null (buffer-name Man-buffer)) ;; deleted buffer - (or (stringp process) - (set-process-buffer process nil)) - - (save-excursion - (set-buffer Man-buffer) - (let ((case-fold-search nil)) - (goto-char (point-min)) - (cond ((or (looking-at "No \\(manual \\)*entry for") - (looking-at "[^\n]*: nothing appropriate$")) - (setq err-mess (buffer-substring (point) - (progn - (end-of-line) (point))) - delete-buff t)) - ((or (stringp process) - (not (and (eq (process-status process) 'exit) - (= (process-exit-status process) 0)))) - (or (zerop (length msg)) - (progn - (setq err-mess - (concat (buffer-name Man-buffer) - ": process " - (let ((eos (1- (length msg)))) - (if (= (aref msg eos) ?\n) - (substring msg 0 eos) msg)))) - (goto-char (point-max)) - (insert (format "\nprocess %s" msg)))) - )) - (if delete-buff - (kill-buffer Man-buffer) - (if Man-fontify-manpage-flag - (Man-fontify-manpage) - (Man-cleanup-manpage)) - (run-hooks 'Man-cooked-hook) - (Man-mode) - (set-buffer-modified-p nil) - )) - ;; Restore case-fold-search before calling - ;; Man-notify-when-ready because it may switch buffers. - - (if (not delete-buff) - (Man-notify-when-ready Man-buffer)) - - (if err-mess - (error err-mess)) - )))) - - -;; ====================================================================== -;; set up manual mode in buffer and build alists - -(defun Man-mode () - "A mode for browsing Un*x manual pages. - -The following man commands are available in the buffer. Try -\"\\[describe-key] <key> RET\" for more information: - -\\[man] Prompt to retrieve a new manpage. -\\[Man-follow-manual-reference] Retrieve reference in SEE ALSO section. -\\[Man-next-manpage] Jump to next manpage in circular list. -\\[Man-previous-manpage] Jump to previous manpage in circular list. -\\[Man-next-section] Jump to next manpage section. -\\[Man-previous-section] Jump to previous manpage section. -\\[Man-goto-section] Go to a manpage section. -\\[Man-goto-see-also-section] Jumps to the SEE ALSO manpage section. -\\[Man-quit] Deletes the manpage window, bury its buffer. -\\[Man-kill] Deletes the manpage window, kill its buffer. -\\[describe-mode] Prints this help text. - -The following variables may be of some use. Try -\"\\[describe-variable] <variable-name> RET\" for more information: - -`Man-notify-method' What happens when manpage formatting is done. -`Man-downcase-section-letters-flag' Force section letters to lower case. -`Man-circular-pages-flag' Treat multiple manpage list as circular. -`Man-section-translations-alist' List of section numbers and their Un*x equiv. -`Man-filter-list' Background manpage filter command. -`Man-mode-line-format' Mode line format for Man mode buffers. -`Man-mode-map' Keymap bindings for Man mode buffers. -`Man-mode-hook' Normal hook run on entry to Man mode. -`Man-section-regexp' Regexp describing manpage section letters. -`Man-heading-regexp' Regexp describing section headers. -`Man-see-also-regexp' Regexp for SEE ALSO section (or your equiv). -`Man-first-heading-regexp' Regexp for first heading on a manpage. -`Man-reference-regexp' Regexp matching a references in SEE ALSO. -`Man-switches' Background `man' command switches. - -The following key bindings are currently in effect in the buffer: -\\{Man-mode-map}" - (interactive) - (setq major-mode 'Man-mode - mode-name "Man" - buffer-auto-save-file-name nil - mode-line-format Man-mode-line-format - truncate-lines t - buffer-read-only t) - (buffer-disable-undo (current-buffer)) - (auto-fill-mode -1) - (use-local-map Man-mode-map) - (set-syntax-table man-mode-syntax-table) - (Man-build-page-list) - (Man-strip-page-headers) - (Man-unindent) - (Man-goto-page 1) - (run-hooks 'Man-mode-hook)) - -(defsubst Man-build-section-alist () - "Build the association list of manpage sections." - (setq Man-sections-alist nil) - (goto-char (point-min)) - (let ((case-fold-search nil)) - (while (re-search-forward Man-heading-regexp (point-max) t) - (aput 'Man-sections-alist (Man-match-substring 1)) - (forward-line 1)))) - -(defsubst Man-build-references-alist () - "Build the association list of references (in the SEE ALSO section)." - (setq Man-refpages-alist nil) - (save-excursion - (if (Man-find-section Man-see-also-regexp) - (let ((start (progn (forward-line 1) (point))) - (end (progn - (Man-next-section 1) - (point))) - hyphenated - (runningpoint -1)) - (save-restriction - (narrow-to-region start end) - (goto-char (point-min)) - (back-to-indentation) - (while (and (not (eobp)) (/= (point) runningpoint)) - (setq runningpoint (point)) - (if (re-search-forward Man-hyphenated-reference-regexp end t) - (let* ((word (Man-match-substring 0)) - (len (1- (length word)))) - (if hyphenated - (setq word (concat hyphenated word) - hyphenated nil - ;; Update len, in case a reference spans - ;; more than two lines (paranoia). - len (1- (length word)))) - (if (= (aref word len) ?-) - (setq hyphenated (substring word 0 len))) - (if (string-match Man-reference-regexp word) - (aput 'Man-refpages-alist word)))) - (skip-chars-forward " \t\n,")))))) - (setq Man-refpages-alist (nreverse Man-refpages-alist))) - -(defun Man-build-page-list () - "Build the list of separate manpages in the buffer." - (setq Man-page-list nil) - (let ((page-start (point-min)) - (page-end (point-max)) - (header "")) - (goto-char page-start) - ;; (switch-to-buffer (current-buffer))(debug) - (while (not (eobp)) - (setq header - (if (looking-at Man-page-header-regexp) - (Man-match-substring 1) - nil)) - ;; Go past both the current and the next Man-first-heading-regexp - (if (re-search-forward Man-first-heading-regexp nil 'move 2) - (let ((p (progn (beginning-of-line) (point)))) - ;; We assume that the page header is delimited by blank - ;; lines and that it contains at most one blank line. So - ;; if we back by three blank lines we will be sure to be - ;; before the page header but not before the possible - ;; previous page header. - (search-backward "\n\n" nil t 3) - (if (re-search-forward Man-page-header-regexp p 'move) - (beginning-of-line)))) - (setq page-end (point)) - (setq Man-page-list (append Man-page-list - (list (list (copy-marker page-start) - (copy-marker page-end) - header)))) - (setq page-start page-end) - ))) - -(defun Man-strip-page-headers () - "Strip all the page headers but the first from the manpage." - (let ((buffer-read-only nil) - (case-fold-search nil) - (page-list Man-page-list) - (page ()) - (header "")) - (while page-list - (setq page (car page-list)) - (and (nth 2 page) - (goto-char (car page)) - (re-search-forward Man-first-heading-regexp nil t) - (setq header (buffer-substring (car page) (match-beginning 0))) - ;; Since the awk script collapses all successive blank - ;; lines into one, and since we don't want to get rid of - ;; the fast awk script, one must choose between adding - ;; spare blank lines between pages when there were none and - ;; deleting blank lines at page boundaries when there were - ;; some. We choose the first, so we comment the following - ;; line. - ;; (setq header (concat "\n" header))) - (while (search-forward header (nth 1 page) t) - (replace-match ""))) - (setq page-list (cdr page-list))))) - -(defun Man-unindent () - "Delete the leading spaces that indent the manpage." - (let ((buffer-read-only nil) - (case-fold-search nil) - (page-list Man-page-list)) - (while page-list - (let ((page (car page-list)) - (indent "") - (nindent 0)) - (narrow-to-region (car page) (car (cdr page))) - (if Man-uses-untabify-flag - (untabify (point-min) (point-max))) - (if (catch 'unindent - (goto-char (point-min)) - (if (not (re-search-forward Man-first-heading-regexp nil t)) - (throw 'unindent nil)) - (beginning-of-line) - (setq indent (buffer-substring (point) - (progn - (skip-chars-forward " ") - (point)))) - (setq nindent (length indent)) - (if (zerop nindent) - (throw 'unindent nil)) - (setq indent (concat indent "\\|$")) - (goto-char (point-min)) - (while (not (eobp)) - (if (looking-at indent) - (forward-line 1) - (throw 'unindent nil))) - (goto-char (point-min))) - (while (not (eobp)) - (or (eolp) - (delete-char nindent)) - (forward-line 1))) - (setq page-list (cdr page-list)) - )))) - - -;; ====================================================================== -;; Man mode commands - -(defun Man-next-section (n) - "Move point to Nth next section (default 1)." - (interactive "p") - (let ((case-fold-search nil)) - (if (looking-at Man-heading-regexp) - (forward-line 1)) - (if (re-search-forward Man-heading-regexp (point-max) t n) - (beginning-of-line) - (goto-char (point-max))))) - -(defun Man-previous-section (n) - "Move point to Nth previous section (default 1)." - (interactive "p") - (let ((case-fold-search nil)) - (if (looking-at Man-heading-regexp) - (forward-line -1)) - (if (re-search-backward Man-heading-regexp (point-min) t n) - (beginning-of-line) - (goto-char (point-min))))) - -(defun Man-find-section (section) - "Move point to SECTION if it exists, otherwise don't move point. -Returns t if section is found, nil otherwise." - (let ((curpos (point)) - (case-fold-search nil)) - (goto-char (point-min)) - (if (re-search-forward (concat "^" section) (point-max) t) - (progn (beginning-of-line) t) - (goto-char curpos) - nil) - )) - -(defun Man-goto-section () - "Query for section to move point to." - (interactive) - (aput 'Man-sections-alist - (let* ((default (aheadsym Man-sections-alist)) - (completion-ignore-case t) - chosen - (prompt (concat "Go to section: (default " default ") "))) - (setq chosen (completing-read prompt Man-sections-alist)) - (if (or (not chosen) - (string= chosen "")) - default - chosen))) - (Man-find-section (aheadsym Man-sections-alist))) - -(defun Man-goto-see-also-section () - "Move point the the \"SEE ALSO\" section. -Actually the section moved to is described by `Man-see-also-regexp'." - (interactive) - (if (not (Man-find-section Man-see-also-regexp)) - (error (concat "No " Man-see-also-regexp - " section found in the current manpage")))) - -(defun Man-possibly-hyphenated-word () - "Return a possibly hyphenated word at point. -If the word starts at the first non-whitespace column, and the -previous line ends with a hyphen, return the last word on the previous -line instead. Thus, if a reference to \"tcgetpgrp(3V)\" is hyphenated -as \"tcgetp-grp(3V)\", and point is at \"grp(3V)\", we return -\"tcgetp-\" instead of \"grp\"." - (save-excursion - (skip-syntax-backward "w()") - (skip-chars-forward " \t") - (let ((beg (point)) - (word (current-word))) - (when (eq beg (save-excursion - (back-to-indentation) - (point))) - (end-of-line 0) - (if (eq (char-before) ?-) - (setq word (current-word)))) - word))) - -(defun Man-follow-manual-reference (reference) - "Get one of the manpages referred to in the \"SEE ALSO\" section. -Specify which REFERENCE to use; default is based on word at point." - (interactive - (if (not Man-refpages-alist) - (error "There are no references in the current man page") - (list (let* ((default (or - (car (all-completions - (let ((word (Man-possibly-hyphenated-word))) - ;; strip a trailing '-': - (if (string-match "-$" word) - (substring word 0 - (match-beginning 0)) - word)) - Man-refpages-alist)) - (aheadsym Man-refpages-alist))) - chosen - (prompt (concat "Refer to: (default " default ") "))) - (setq chosen (completing-read prompt Man-refpages-alist nil t)) - (if (or (not chosen) - (string= chosen "")) - default - chosen))))) - (if (not Man-refpages-alist) - (error "Can't find any references in the current manpage") - (aput 'Man-refpages-alist reference) - (Man-getpage-in-background - (Man-translate-references (aheadsym Man-refpages-alist))))) - -(defun Man-kill () - "Kill the buffer containing the manpage." - (interactive) - (quit-window t)) - -(defun Man-quit () - "Bury the buffer containing the manpage." - (interactive) - (quit-window)) - -(defun Man-goto-page (page) - "Go to the manual page on page PAGE." - (interactive - (if (not Man-page-list) - (let ((args Man-arguments)) - (kill-buffer (current-buffer)) - (error "Can't find the %s manpage" args)) - (if (= (length Man-page-list) 1) - (error "You're looking at the only manpage in the buffer") - (list (read-minibuffer (format "Go to manpage [1-%d]: " - (length Man-page-list))))))) - (if (not Man-page-list) - (let ((args Man-arguments)) - (kill-buffer (current-buffer)) - (error "Can't find the %s manpage" args))) - (if (or (< page 1) - (> page (length Man-page-list))) - (error "No manpage %d found" page)) - (let* ((page-range (nth (1- page) Man-page-list)) - (page-start (car page-range)) - (page-end (car (cdr page-range)))) - (setq Man-current-page page - Man-page-mode-string (Man-make-page-mode-string)) - (widen) - (goto-char page-start) - (narrow-to-region page-start page-end) - (Man-build-section-alist) - (Man-build-references-alist) - (goto-char (point-min)))) - - -(defun Man-next-manpage () - "Find the next manpage entry in the buffer." - (interactive) - (if (= (length Man-page-list) 1) - (error "This is the only manpage in the buffer")) - (if (< Man-current-page (length Man-page-list)) - (Man-goto-page (1+ Man-current-page)) - (if Man-circular-pages-flag - (Man-goto-page 1) - (error "You're looking at the last manpage in the buffer")))) - -(defun Man-previous-manpage () - "Find the previous manpage entry in the buffer." - (interactive) - (if (= (length Man-page-list) 1) - (error "This is the only manpage in the buffer")) - (if (> Man-current-page 1) - (Man-goto-page (1- Man-current-page)) - (if Man-circular-pages-flag - (Man-goto-page (length Man-page-list)) - (error "You're looking at the first manpage in the buffer")))) - -;; Init the man package variables, if not already done. -(Man-init-defvars) - -(add-to-list 'debug-ignored-errors "^No manpage [0-9]* found$") -(add-to-list 'debug-ignored-errors "^Can't find the .* manpage$") - -(provide 'man) - -;;; man.el ends here diff --git a/lisp/medit.el b/lisp/medit.el deleted file mode 100644 index 985c9b27344..00000000000 --- a/lisp/medit.el +++ /dev/null @@ -1,123 +0,0 @@ -;;; medit.el --- front-end to the MEDIT package for editing MDL - -;; Copyright (C) 1985 Free Software Foundation, Inc. - -;; Author: K. Shane Hartman -;; Maintainer: FSF -;; Keywords: languages - -;; 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, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; Commentary: - -;; >> This package depends on two MDL packages: MEDIT and FORKS which -;; >> can be obtained from the public (network) library at mit-ajax. - -;;; Code: - -(require 'mim-mode) - -(defconst medit-zap-file (concat "/tmp/" (user-login-name) ".medit.mud") - "File name for data sent to MDL by Medit.") -(defconst medit-buffer "*MEDIT*" - "Name of buffer in which Medit accumulates data to send to MDL.") -(defconst medit-save-files t - "If non-nil, Medit offers to save files on return to MDL.") - -(defun medit-save-define () - "Mark the previous or surrounding toplevel object to be sent back to MDL." - (interactive) - (save-excursion - (beginning-of-DEFINE) - (let ((start (point))) - (forward-mim-object 1) - (append-to-buffer medit-buffer start (point)) - (goto-char start) - (message "%s" (buffer-substring start (progn (end-of-line) (point))))))) - -(defun medit-save-region (start end) - "Mark the current region to be sent to back to MDL." - (interactive "r") - (append-to-buffer medit-buffer start end) - (message "Current region saved for MDL.")) - -(defun medit-save-buffer () - "Mark the current buffer to be sent back to MDL." - (interactive) - (append-to-buffer medit-buffer (point-min) (point-max)) - (message "Current buffer saved for MDL.")) - -(defun medit-zap-define-to-mdl () - "Return to MDL with surrounding or previous toplevel MDL object." - (interactive) - (medit-save-define) - (medit-goto-mdl)) - -(defun medit-zap-region-mdl (start end) - "Return to MDL with current region." - (interactive) - (medit-save-region start end) - (medit-goto-mdl)) - -(defun medit-zap-buffer () - "Return to MDL with current buffer." - (interactive) - (medit-save-buffer) - (medit-goto-mdl)) - -(defun medit-goto-mdl () - "Return from Emacs to superior MDL, sending saved code. -Optionally, offers to save changed files." - (interactive) - (let ((buffer (get-buffer medit-buffer))) - (if buffer - (save-excursion - (set-buffer buffer) - (if (buffer-modified-p buffer) - (write-region (point-min) (point-max) medit-zap-file)) - (set-buffer-modified-p nil) - (erase-buffer))) - (if medit-save-files (save-some-buffers)) - ;; Note could handle parallel fork by giving argument "%xmdl". Then - ;; mdl would have to invoke with "%emacs". - (suspend-emacs))) - -(defconst medit-mode-map nil) -(if (not medit-mode-map) - (progn - (setq medit-mode-map (copy-keymap mim-mode-map)) - (define-key medit-mode-map "\e\z" 'medit-save-define) - (define-key medit-mode-map "\e\^z" 'medit-save-buffer) - (define-key medit-mode-map "\^xz" 'medit-goto-mdl) - (define-key medit-mode-map "\^xs" 'medit-zap-buffer))) - -(defconst medit-mode-hook (and (boundp 'mim-mode-hook) mim-mode-hook) "") -(setq mim-mode-hook '(lambda () (medit-mode))) - -(defun medit-mode (&optional state) - "Major mode for editing text and returning it to a superior MDL. -Like Mim mode, plus these special commands: -\\{medit-mode-map}" - (interactive) - (use-local-map medit-mode-map) - (run-hooks 'medit-mode-hook) - (setq major-mode 'medit-mode) - (setq mode-name "Medit")) - -(mim-mode) - -;;; medit.el ends here diff --git a/lisp/mh-e.el b/lisp/mh-e.el deleted file mode 100644 index 619556d260f..00000000000 --- a/lisp/mh-e.el +++ /dev/null @@ -1,2933 +0,0 @@ -;;; mh-e.el --- GNU Emacs interface to the MH mail system - -;;; Copyright (C) 1985, 86, 87, 88, 90, 92, 93 Free Software Foundation - -(defconst mh-e-time-stamp "Time-stamp: <93/05/30 18:37:43 gildea>") - -;; Maintainer: Stephen Gildea <gildea@lcs.mit.edu> -;; Version: 3.8.2 -;; Keywords: mail - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but without any warranty. No author or distributor -;; accepts responsibility to anyone for the consequences of using it -;; or for whether it serves any particular purpose or works at all, -;; unless he says so in writing. - -;; Everyone is granted permission to copy, modify and redistribute -;; GNU Emacs, but only under the conditions described in the -;; document "GNU Emacs copying permission notice". An exact copy -;; of the document is supposed to have been given to you along with -;; GNU Emacs so that you can know how you may redistribute it all. -;; It should be in a file named COPYING. Among other things, the -;; copyright notice and this notice must be preserved on all copies. - -;;; Commentary: - -;;; mh-e works with Emacs 18 or 19, and MH 5 or 6. - -;;; HOW TO USE: -;;; M-x mh-rmail to read mail. Type C-h m there for a list of commands. -;;; C-u M-x mh-rmail to visit any folder. -;;; M-x mh-smail to send mail. From within the mail reader, "m" works, too. -;;; Your .emacs might benefit from these bindings: -;;; (global-set-key "\C-xm" 'mh-smail) -;;; (global-set-key "\C-x4m" 'mh-smail-other-window) -;;; (global-set-key "\C-cr" 'mh-rmail) - -;;; MH (Message Handler) is a powerful mail reader. The MH newsgroup -;;; is comp.mail.mh; the mailing list is mh-users@ics.uci.edu (send to -;;; mh-users-request to be added). See the monthly Frequently Asked -;;; Questions posting there for information on getting MH. - -;;; NB. MH must have been compiled with the MHE compiler flag or several -;;; features necessary mh-e will be missing from MH commands, specifically -;;; the -build switch to repl and forw. - -;;; Original version for Gosling emacs by Brian Reid, Stanford, 1982. -;;; Modified by James Larus, BBN, July 1984 and UCB, 1984 & 1985. -;;; Rewritten for GNU Emacs, James Larus 1985. larus@ginger.berkeley.edu -;;; Modified by Stephen Gildea 1988. gildea@bbn.com -(defconst mh-e-RCS-id "$Header: /home/fsf/rms/e19/lisp/RCS/mh-e.el,v 1.15 1993/07/20 04:35:00 rms Exp rms $") - -;;; Code: - - - -;;; Constants: - -;;; Set for local environment: -;;;* These are now in paths.el. -;;;(defvar mh-progs "/usr/new/mh/" "Directory containing MH commands.") -;;;(defvar mh-lib "/usr/new/lib/mh/" "Directory of MH library.") - -(defvar mh-redist-full-contents nil - "Non-nil if the `dist' command needs whole letter for redistribution. -This is the case when `send' is compiled with the BERK option.") - - -;;; Hooks: - -(defvar mh-folder-mode-hook nil - "Invoked in `mh-folder mode' on a new folder.") - -(defvar mh-letter-mode-hook nil - "Invoked in `mh-letter-mode' on a new letter.") - -(defvar mh-compose-letter-function nil - "Invoked in `mh-compose-and-send-mail' on a draft letter. -It is passed three arguments: TO recipients, SUBJECT, and CC recipients.") - -(defvar mh-before-send-letter-hook nil - "Invoked at the beginning of the \\[mh-send-letter] command.") - -(defvar mh-inc-folder-hook nil - "Invoked after incorporating mail into a folder with \\[mh-inc-folder].") - -(defvar mh-before-quit-hook nil - "Invoked by \\[mh-quit] before quitting mh-e. See also mh-quit-hook") - -(defvar mh-quit-hook nil - "Invoked after quitting mh-e by \\[mh-quit]. See also mh-before-quit-hook") - - -(defvar mh-ins-string nil - "Temporarily set by `mh-insert-prefix' prior to running `mh-yank-hooks'.") - -(defvar mh-yank-hooks - '(lambda () - (save-excursion - (goto-char (point)) - (or (bolp) (forward-line 1)) - (while (< (point) (mark t)) - (insert mh-ins-string) - (forward-line 1)))) - "Hook to run citation function. -Expects POINT and MARK to be set to the region to cite.") - - -;;; Personal preferences: - -(defvar mh-clean-message-header nil - "*Non-nil means clean headers of messages that are displayed or inserted. -The variables `mh-visible-headers' and `mh-invisible-headers' control what -is removed.") - -(defvar mh-visible-headers nil - "*If non-nil, contains a regexp specifying the headers to keep when cleaning. -Only used if `mh-clean-message-header' is non-nil. Setting this variable -overrides `mh-invisible-headers'.") - -(defvar mhl-formfile nil - "*Name of format file to be used by mhl to show messages. -A value of T means use the default format file. -Nil means don't use mhl to format messages.") - -(defvar mh-lpr-command-format "lpr -p -J '%s'" - "*Format for Unix command that prints a message. -The string should be a Unix command line, with the string '%s' where -the job's name (folder and message number) should appear. The message text -is piped to this command.") - -(defvar mh-print-background nil - "*Print messages in the background if non-nil. -WARNING: do not delete the messages until printing is finished; -otherwise, your output may be truncated.") - -(defvar mh-summary-height 4 - "*Number of lines in summary window (including the mode line).") - -(defvar mh-recenter-summary-p nil - "*Recenter summary window when the show window is toggled off if non-nil.") - -(defvar mh-ins-buf-prefix "> " - "*String to put before each non-blank line of a yanked or inserted message. -Used when the message is inserted in an outgoing letter.") - -(defvar mh-do-not-confirm nil - "*Non-nil means do not prompt for confirmation before some commands. -Only affects certain innocuous commands.") - -(defvar mh-bury-show-buffer t - "*Non-nil means that the displayed show buffer for a folder is buried.") - -(defvar mh-delete-yanked-msg-window nil - "*Controls window display when a message is yanked by \\[mh-yank-cur-msg]. -If non-nil, yanking the current message into a draft letter deletes any -windows displaying the message.") - -(defvar mh-yank-from-start-of-msg t - "*Controls which part of a message is yanked by \\[mh-yank-cur-msg]. -If non-nil, include the entire message. If the symbol `body', then yank the -message minus the header. If nil, yank only the portion of the message -following the point. If the show buffer has a region, this variable is -ignored.") - -(defvar mh-reply-default-reply-to nil - "*Sets the person or persons to whom a reply will be sent. -If nil, prompt for recipient. If non-nil, then \\[mh-reply] will use this -value and it should be one of \"from\", \"to\", or \"cc\".") - -(defvar mh-recursive-folders nil - "*If non-nil, then commands which operate on folders do so recursively.") - -(defvar mh-unshar-default-directory "" - "*Default for directory name prompted for by mh-unshar-msg.") - -(defvar mh-signature-file-name "~/.signature" - "*Name of file containing the user's signature. -Inserted into message by \\<mh-letter-mode-map>\\[mh-insert-signature].") - - -;;; Parameterize mh-e to work with different scan formats. The defaults work -;;; with the standard MH scan listings. - -(defvar mh-cmd-note 4 - "Offset to insert notation.") - -(defvar mh-note-repl "-" - "String whose first character is used to notate replied to messages.") - -(defvar mh-note-forw "F" - "String whose first character is used to notate forwarded messages.") - -(defvar mh-note-dist "R" - "String whose first character is used to notate redistributed messages.") - -(defvar mh-good-msg-regexp "^....[^D^]" - "Regexp specifying the scan lines that are 'good' messages.") - -(defvar mh-deleted-msg-regexp "^....D" - "Regexp matching scan lines of deleted messages.") - -(defvar mh-refiled-msg-regexp "^....\\^" - "Regexp matching scan lines of refiled messages.") - -(defvar mh-valid-scan-line "^ *[0-9]" - "Regexp matching scan lines for messages (not error messages).") - -(defvar mh-msg-number-regexp "^ *\\([0-9]+\\)" - "Regexp to find the number of a message in a scan line. -The message's number must be surrounded with \\( \\)") - -(defvar mh-msg-search-regexp "^[^0-9]*%d[^0-9]" - "Format string containing a regexp matching the scan listing for a message. -The desired message's number will be an argument to format.") - -(defvar mh-flagged-scan-msg-regexp "^....\\D\\|^....\\^\\|^....\\+\\|^.....%" - "Regexp matching flagged scan lines. -Matches lines marked as deleted, refiled, in a sequence, or the cur message.") - -(defvar mh-cur-scan-msg-regexp "^....\\+" - "Regexp matching scan line for the cur message.") - -(defvar mh-show-buffer-mode-line-buffer-id "{%%b} %s/%d" - "Format string to produce `mode-line-buffer-id' for show buffers. -First argument is folder name. Second is message number.") - -(defvar mh-partial-folder-mode-line-annotation "select" - "Annotation when displaying part of a folder. -The string is displayed after the folder's name. NIL for no annotation.") - - -;;; Real constants: - -(defvar mh-invisible-headers - "^Received: \\|^Message-Id: \\|^Remailed-\\|^Via: \\|^Mail-from: \\|^Return-Path: \\|^In-Reply-To: \\|^Resent-" - "Regexp matching lines in a message header that are not to be shown. -If `mh-visible-headers' is non-nil, it is used instead to specify what -to keep.") - -(defvar mh-rejected-letter-start - (concat "^ ----- Unsent message follows -----$" ;from mail system - "\\|^------- Unsent Draft$" ;from MH itself - "\\|^ --- The unsent message follows ---$") ;from AIX mail system - "Regexp specifying the beginning of the wrapper around a returned letter. -This wrapper is generated by the mail system when rejecting a letter.") - -(defvar mh-to-field-choices '((?t . "To:") (?s . "Subject:") (?c . "Cc:") - (?b . "Bcc:") (?f . "Fcc:")) - "A-list of (character . field name) strings for mh-to-field.") - - -;;; Global variables: - -(defvar mh-user-path "" - "User's mail folder.") - -(defvar mh-last-destination nil - "Destination of last refile or write command.") - -(defvar mh-folder-mode-map (make-keymap) - "Keymap for MH folders.") - -(defvar mh-letter-mode-map (copy-keymap text-mode-map) - "Keymap for composing mail.") - -(defvar mh-pick-mode-map (make-sparse-keymap) - "Keymap for searching folder.") - -(defvar mh-searching-folder nil - "Folder this pick is searching.") - -(defvar mh-letter-mode-syntax-table nil - "Syntax table used while in mh-e letter mode.") - -(if mh-letter-mode-syntax-table - () - (setq mh-letter-mode-syntax-table - (make-syntax-table text-mode-syntax-table)) - (set-syntax-table mh-letter-mode-syntax-table) - (modify-syntax-entry ?% "." mh-letter-mode-syntax-table)) - -(defvar mh-folder-list nil - "List of folder names for completion.") - -(defvar mh-draft-folder nil - "Name of folder containing draft messages. -NIL means do not use draft folder.") - -(defvar mh-unseen-seq nil - "Name of the unseen sequence.") - -(defvar mh-previous-window-config nil - "Window configuration before mh-e command.") - -(defvar mh-previous-seq nil - "Name of the sequence to which a message was last added.") - - -;;; Macros and generic functions: - -(defmacro mh-push (v l) - (list 'setq l (list 'cons v l))) - - -(defmacro mh-when (pred &rest body) - (list 'cond (cons pred body))) - - -(defmacro with-mh-folder-updating (save-modification-flag-p &rest body) - ;; Format is (with-mh-folder-updating (SAVE-MODIFICATION-FLAG-P) &body BODY). - ;; Execute BODY, which can modify the folder buffer without having to - ;; worry about file locking or the read-only flag, and return its result. - ;; If SAVE-MODIFICATION-FLAG-P is non-nil, the buffer's modification - ;; flag is unchanged, otherwise it is cleared. - (setq save-modification-flag-p (car save-modification-flag-p)) ; CL style - (` (let ((folder-updating-mod-flag (buffer-modified-p))) - (prog1 - (let ((buffer-read-only nil) - (buffer-file-name nil)) ; don't let the buffer get locked - (,@ body)) - (, (if save-modification-flag-p - '(mh-set-folder-modified-p folder-updating-mod-flag) - '(mh-set-folder-modified-p nil))))))) - - -(defun mh-mapc (func list) - (while list - (funcall func (car list)) - (setq list (cdr list)))) - - - -;;; Entry points: - -;;;###autoload -(defun mh-rmail (&optional arg) - "Inc(orporate) new mail (no arg) or scan a MH mail box (arg given). -This front end uses the MH mail system, which uses different conventions -from the usual mail system." - (interactive "P") - (mh-find-path) - (if arg - (call-interactively 'mh-visit-folder) - (mh-inc-folder))) - - -;;;###autoload -(defun mh-smail () - "Compose and send mail with the MH mail system." - (interactive) - (mh-find-path) - (call-interactively 'mh-send)) - - -(defun mh-smail-other-window () - "Compose and send mail in other window with the MH mail system." - (interactive) - (mh-find-path) - (call-interactively 'mh-send-other-window)) - - - -;;; User executable mh-e commands: - -(defun mh-burst-digest () - "Burst apart the current message, which should be a digest. -The message is replaced by its table of contents and the letters from the -digest are inserted into the folder after that message." - (interactive) - (let ((digest (mh-get-msg-num t))) - (mh-process-or-undo-commands mh-current-folder) - (mh-set-folder-modified-p t) ; lock folder while bursting - (message "Bursting digest...") - (mh-exec-cmd "burst" mh-current-folder digest "-inplace") - (mh-scan-folder mh-current-folder (format "%d-last" mh-first-msg-num)) - (message "Bursting digest...done"))) - - -(defun mh-copy-msg (prefix-provided msg-or-seq dest) - "Copy specified MESSAGE(s) to another FOLDER without deleting them. -Default is the displayed message. If optional prefix argument is -provided, then prompt for the message sequence." - (interactive (list current-prefix-arg - (if current-prefix-arg - (mh-read-seq-default "Copy" t) - (mh-get-msg-num t)) - (mh-prompt-for-folder "Copy to" "" t))) - (mh-exec-cmd "refile" msg-or-seq "-link" "-src" mh-current-folder dest) - (if prefix-provided - (mh-notate-seq msg-or-seq ?C mh-cmd-note) - (mh-notate msg-or-seq ?C mh-cmd-note))) - - -(defun mh-delete-msg (msg-or-seq) - "Mark the specified MESSAGE(s) for subsequent deletion and move to the next. -Default is the displayed message. If optional prefix argument is -given then prompt for the message sequence." - (interactive (list (if current-prefix-arg - (mh-read-seq-default "Delete" t) - (mh-get-msg-num t)))) - (if (numberp msg-or-seq) - (mh-delete-a-msg msg-or-seq) - (mh-map-to-seq-msgs 'mh-delete-a-msg msg-or-seq)) - (mh-next-msg)) - - -(defun mh-delete-msg-no-motion (msg-or-seq) - "Mark the specified MESSAGE(s) for subsequent deletion. -Default is the displayed message. If optional prefix argument is -provided, then prompt for the message sequence." - (interactive (list (if current-prefix-arg - (mh-read-seq-default "Delete" t) - (mh-get-msg-num t)))) - (if (numberp msg-or-seq) - (mh-delete-a-msg msg-or-seq) - (mh-map-to-seq-msgs 'mh-delete-a-msg msg-or-seq))) - - -(defun mh-delete-msg-from-seq (prefix-provided msg-or-seq &optional from-seq) - "Delete MESSAGE (default: displayed message) from SEQUENCE. -If optional prefix argument provided, then delete all messages -from a sequence." - (interactive (let ((argp current-prefix-arg)) - (list argp - (if argp - (mh-read-seq-default "Delete" t) - (mh-get-msg-num t)) - (if (not argp) - (mh-read-seq-default "Delete from" t))))) - (if prefix-provided - (mh-remove-seq msg-or-seq) - (mh-remove-msg-from-seq msg-or-seq from-seq))) - - -(defun mh-edit-again (msg) - "Clean-up a draft or a message previously sent and make it resendable." - (interactive (list (mh-get-msg-num t))) - (let* ((from-folder mh-current-folder) - (config (current-window-configuration)) - (draft - (cond ((and mh-draft-folder (equal from-folder mh-draft-folder)) - (pop-to-buffer (find-file-noselect (mh-msg-filename msg)) t) - (rename-buffer (format "draft-%d" msg)) - (buffer-name)) - (t - (mh-read-draft "clean-up" (mh-msg-filename msg) nil))))) - (mh-clean-msg-header (point-min) - "^Date:\\|^Received:\\|^Message-Id:\\|^From:\\|^Delivery-Date:" - nil) - (goto-char (point-min)) - (set-buffer-modified-p nil) - (mh-compose-and-send-mail draft "" from-folder nil nil nil nil nil nil - config))) - - -(defun mh-execute-commands () - "Process outstanding delete and refile requests." - (interactive) - (if mh-narrowed-to-seq (mh-widen)) - (mh-process-commands mh-current-folder) - (mh-set-scan-mode) - (mh-goto-cur-msg) ; after mh-set-scan-mode for efficiency - (mh-make-folder-mode-line) - t) ; return t for write-file-hooks - - -(defun mh-extract-rejected-mail (msg) - "Extract a letter returned by the mail system and make it resendable. -Default is the displayed message." - (interactive (list (mh-get-msg-num t))) - (let ((from-folder mh-current-folder) - (config (current-window-configuration)) - (draft (mh-read-draft "extraction" (mh-msg-filename msg) nil))) - (goto-char (point-min)) - (cond ((re-search-forward mh-rejected-letter-start nil t) - (forward-char 1) - (delete-region (point-min) (point)) - (mh-clean-msg-header (point-min) - "^Date:\\|^Received:\\|^Message-Id:\\|^From:\\|^Sender:\\|^Return-Path:" - nil)) - (t - (message "Does not appear to be a rejected letter."))) - (goto-char (point-min)) - (set-buffer-modified-p nil) - (mh-compose-and-send-mail draft "" from-folder msg (mh-get-field "To") - (mh-get-field "From") (mh-get-field "cc") - nil nil config))) - - -(defun mh-first-msg () - "Move to the first message." - (interactive) - (goto-char (point-min))) - - -(defun mh-forward (prefix-provided msg-or-seq to cc) - "Forward MESSAGE(s) (default: displayed message). -If optional prefix argument provided, then prompt for the message sequence." - (interactive (list current-prefix-arg - (if current-prefix-arg - (mh-read-seq-default "Forward" t) - (mh-get-msg-num t)) - (read-string "To: ") - (read-string "Cc: "))) - (let* ((folder mh-current-folder) - (config (current-window-configuration)) - ;; forw always leaves file in "draft" since it doesn't have -draft - (draft-name (expand-file-name "draft" mh-user-path)) - (draft (cond ((or (not (file-exists-p draft-name)) - (y-or-n-p "The file 'draft' exists. Discard it? ")) - (mh-exec-cmd "forw" - "-build" mh-current-folder msg-or-seq) - (prog1 - (mh-read-draft "" draft-name t) - (mh-insert-fields "To:" to "Cc:" cc) - (set-buffer-modified-p nil))) - (t - (mh-read-draft "" draft-name nil))))) - (goto-char (point-min)) - (re-search-forward "^------- Forwarded Message") - (forward-line -1) - (narrow-to-region (point) (point-max)) - (let* ((subject (save-excursion (mh-get-field "From:"))) - (trim (string-match "<" subject)) - (forw-subject (save-excursion (mh-get-field "Subject:")))) - (if trim - (setq subject (substring subject 0 (1- trim)))) - (widen) - (save-excursion - (mh-insert-fields "Subject:" (format "[%s: %s]" subject forw-subject))) - (delete-other-windows) - (if prefix-provided - (mh-add-msgs-to-seq (mh-seq-to-msgs msg-or-seq) 'forwarded t) - (mh-add-msgs-to-seq msg-or-seq 'forwarded t)) - (mh-compose-and-send-mail draft "" folder msg-or-seq - to subject cc - mh-note-forw "Forwarded:" - config)))) - - -(defun mh-goto-msg (number &optional no-error-if-no-message dont-show) - "Position the cursor at message NUMBER. -Non-nil second argument means do not signal an error if message does not exist. -Non-nil third argument means not to show the message. -Return non-nil if cursor is at message." - (interactive "NGoto message: ") - (let ((cur-msg (mh-get-msg-num nil)) - (starting-place (point)) - (msg-pattern (mh-msg-search-pat number))) - (cond ((cond ((and cur-msg (= cur-msg number)) t) - ((and cur-msg - (< cur-msg number) - (re-search-forward msg-pattern nil t)) t) - ((and cur-msg - (> cur-msg number) - (re-search-backward msg-pattern nil t)) t) - (t ; Do thorough search of buffer - (goto-char (point-max)) - (re-search-backward msg-pattern nil t))) - (beginning-of-line) - (if (not dont-show) (mh-maybe-show number)) - t) - (t - (goto-char starting-place) - (if (not no-error-if-no-message) - (error "No message %d" number)) - nil)))) - - -(defun mh-inc-folder (&optional maildrop-name) - "Inc(orporate) new mail into +inbox. -Optional prefix argument specifies an alternate maildrop from the default. -If this is given, incorporate mail into the current folder, rather -than +inbox. Run `mh-inc-folder-hook' after incorporating new mail." - (interactive (list (if current-prefix-arg - (expand-file-name - (read-file-name "inc mail from file: " - mh-user-path))))) - (let ((config (current-window-configuration))) - (if (not maildrop-name) - (cond ((not (get-buffer "+inbox")) - (mh-make-folder "+inbox") - (setq mh-previous-window-config config)) - ((not (eq (current-buffer) (get-buffer "+inbox"))) - (switch-to-buffer "+inbox") - (setq mh-previous-window-config config))))) - (mh-get-new-mail maildrop-name) - (run-hooks 'mh-inc-folder-hook)) - - -(defun mh-kill-folder () - "Remove the current folder." - (interactive) - (if (or mh-do-not-confirm - (yes-or-no-p (format "Remove folder %s? " mh-current-folder))) - (let ((folder mh-current-folder)) - (mh-set-folder-modified-p t) ; lock folder to kill it - (mh-exec-cmd-daemon "rmf" folder) - (mh-remove-folder-from-folder-list folder) - (message "Folder %s removed" folder) - (mh-set-folder-modified-p nil) ; so kill-buffer doesn't complain - (if (get-buffer mh-show-buffer) - (kill-buffer mh-show-buffer)) - (kill-buffer folder)) - (message "Folder not removed"))) - - -(defun mh-last-msg () - "Move to the last message." - (interactive) - (goto-char (point-max)) - (while (and (not (bobp)) (looking-at "^$")) - (forward-line -1))) - - -(defun mh-list-folders () - "List mail folders." - (interactive) - (with-output-to-temp-buffer " *mh-temp*" - (save-excursion - (switch-to-buffer " *mh-temp*") - (erase-buffer) - (message "Listing folders...") - (mh-exec-cmd-output "folders" t (if mh-recursive-folders - "-recurse" - "-norecurse")) - (goto-char (point-min)) - (message "Listing folders...done")))) - - -(defun mh-msg-is-in-seq (msg) - "Display the sequences that contain MESSAGE (default: displayed message)." - (interactive (list (mh-get-msg-num t))) - (message "Message %d is in sequences: %s" - msg - (mapconcat 'concat - (mh-list-to-string (mh-seq-containing-msg msg)) - " "))) - - -(defun mh-narrow-to-seq (seq) - "Restrict display of this folder to just messages in a sequence. -Reads which sequence. Use \\[mh-widen] to undo this command." - (interactive (list (mh-read-seq "Narrow to" t))) - (let ((eob (point-max))) - (with-mh-folder-updating (t) - (cond ((mh-seq-to-msgs seq) - (mh-copy-seq-to-point seq eob) - (narrow-to-region eob (point-max)) - (mh-make-folder-mode-line (symbol-name seq)) - (mh-recenter nil) - (setq mh-narrowed-to-seq seq)) - (t - (error "No messages in sequence `%s'" (symbol-name seq))))))) - - -(defun mh-next-undeleted-msg (&optional arg) - "Move to next undeleted message in window." - (interactive "P") - (forward-line (prefix-numeric-value arg)) - (setq mh-next-direction 'forward) - (cond ((re-search-forward mh-good-msg-regexp nil 0 arg) - (beginning-of-line) - (mh-maybe-show)) - (t - (forward-line -1) - (if (get-buffer mh-show-buffer) - (delete-windows-on mh-show-buffer))))) - - -(defun mh-pack-folder (range) - "Renumber the messages of a folder to be 1..n. -First, offer to execute any outstanding commands for the current folder. -If optional prefix argument provided, prompt for the range of messages -to display after packing. Otherwise, show the entire folder." - (interactive (list (if current-prefix-arg - (mh-read-msg-range - "Range to scan after packing [all]? ") - "all"))) - (mh-pack-folder-1 range) - (mh-goto-cur-msg) - (message "Packing folder...done")) - - -(defun mh-pipe-msg (prefix-provided command) - "Pipe the current message through the given shell COMMAND. -If optional prefix argument is provided, send the entire message. -Otherwise just send the message's body." - (interactive - (list current-prefix-arg (read-string "Shell command on message: "))) - (save-excursion - (mh-display-msg (mh-get-msg-num t) mh-current-folder) ;update show buffer - (goto-char (point-min)) - (if (not prefix-provided) (search-forward "\n\n")) - (shell-command-on-region (point) (point-max) command nil))) - - -(defun mh-refile-msg (prefix-provided msg-or-seq dest) - "Refile MESSAGE(s) (default: displayed message) in FOLDER. -If optional prefix argument provided, then prompt for message sequence." - (interactive - (list current-prefix-arg - (if current-prefix-arg - (mh-read-seq-default "Refile" t) - (mh-get-msg-num t)) - (intern - (mh-prompt-for-folder "Destination" - (if (eq 'refile (car mh-last-destination)) - (symbol-name (cdr mh-last-destination)) - "") - t)))) - (setq mh-last-destination (cons 'refile dest)) - (if prefix-provided - (mh-map-to-seq-msgs 'mh-refile-a-msg msg-or-seq dest) - (mh-refile-a-msg msg-or-seq dest)) - (mh-next-msg)) - - -(defun mh-refile-or-write-again (msg) - "Re-execute the last refile or write command on the given MESSAGE. -Default is the displayed message. Use the same folder or file as the -previous refile or write command." - (interactive (list (mh-get-msg-num t))) - (if (null mh-last-destination) - (error "No previous refile or write")) - (cond ((eq (car mh-last-destination) 'refile) - (mh-refile-a-msg msg (cdr mh-last-destination)) - (message "Destination folder: %s" (cdr mh-last-destination))) - (t - (mh-write-msg-to-file msg (cdr mh-last-destination)) - (message "Destination: %s" (cdr mh-last-destination)))) - (mh-next-msg)) - - -(defun mh-reply (prefix-provided msg) - "Reply to a MESSAGE (default: displayed message). -If optional prefix argument provided, then include the message in the reply -using filter mhl.reply in your MH directory." - (interactive (list current-prefix-arg (mh-get-msg-num t))) - (let ((minibuffer-help-form - "from => Sender only\nto => Sender and primary recipients\ncc or all => Sender and all recipients")) - (let ((reply-to (or mh-reply-default-reply-to - (completing-read "Reply to whom: " - '(("from") ("to") ("cc") ("all")) - nil - t))) - (folder mh-current-folder) - (show-buffer mh-show-buffer) - (config (current-window-configuration))) - (message "Composing a reply...") - (cond ((or (equal reply-to "from") (equal reply-to "")) - (apply 'mh-exec-cmd - "repl" "-build" "-noquery" - "-nodraftfolder" mh-current-folder - msg - "-nocc" "all" - (if prefix-provided - (list "-filter" "mhl.reply")))) - ((equal reply-to "to") - (apply 'mh-exec-cmd - "repl" "-build" "-noquery" - "-nodraftfolder" mh-current-folder - msg - "-cc" "to" - (if prefix-provided - (list "-filter" "mhl.reply")))) - ((or (equal reply-to "cc") (equal reply-to "all")) - (apply 'mh-exec-cmd - "repl" "-build" "-noquery" - "-nodraftfolder" mh-current-folder - msg - "-cc" "all" "-nocc" "me" - (if prefix-provided - (list "-filter" "mhl.reply"))))) - - (let ((draft (mh-read-draft "reply" - (expand-file-name "reply" mh-user-path) - t))) - (delete-other-windows) - (set-buffer-modified-p nil) - - (let ((to (mh-get-field "To:")) - (subject (mh-get-field "Subject:")) - (cc (mh-get-field "Cc:"))) - (goto-char (point-min)) - (mh-goto-header-end 1) - (if (not prefix-provided) - (mh-display-msg msg folder)) - (mh-add-msgs-to-seq msg 'answered t) - (message "Composing a reply...done") - (mh-compose-and-send-mail draft "" folder msg to subject cc - mh-note-repl "Replied:" config)))))) - - -(defun mh-quit () - "Quit mh-e. -Start by running mh-before-quit-hook. Restore the previous window -configuration, if one exists. Finish by running mh-quit-hook." - (interactive) - (run-hooks 'mh-before-quit-hook) - (if mh-previous-window-config - (set-window-configuration mh-previous-window-config)) - (run-hooks 'mh-quit-hook)) - - -(defun mh-page-digest () - "Advance displayed message to next digested message." - (interactive) - (save-excursion - (mh-show-message-in-other-window) - ;; Go to top of screen (in case user moved point). - (move-to-window-line 0) - (let ((case-fold-search nil)) - ;; Search for blank line and then for From: - (mh-when (not (and (search-forward "\n\n" nil t) - (search-forward "From:" nil t))) - (other-window -1) - (error "No more messages"))) - ;; Go back to previous blank line, then forward to the first non-blank. - (search-backward "\n\n" nil t) - (forward-line 2) - (mh-recenter 0) - (other-window -1))) - - -(defun mh-page-digest-backwards () - "Back up displayed message to previous digested message." - (interactive) - (save-excursion - (mh-show-message-in-other-window) - ;; Go to top of screen (in case user moved point). - (move-to-window-line 0) - (let ((case-fold-search nil)) - (beginning-of-line) - (mh-when (not (and (search-backward "\n\n" nil t) - (search-backward "From:" nil t))) - (other-window -1) - (error "No more messages"))) - ;; Go back to previous blank line, then forward to the first non-blank. - (search-backward "\n\n" nil t) - (forward-line 2) - (mh-recenter 0) - (other-window -1))) - - -(defun mh-page-msg (&optional arg) - "Page the displayed message forwards. -Scrolls ARG lines or a full screen if no argument is supplied." - (interactive "P") - (scroll-other-window arg)) - - -(defun mh-previous-page (&optional arg) - "Page the displayed message backwards. -Scrolls ARG lines or a full screen if no argument is supplied." - (interactive "P") - (save-excursion - (mh-show-message-in-other-window) - (unwind-protect - (scroll-down arg) - (other-window -1)))) - - -(defun mh-previous-undeleted-msg (&optional arg) - "Move to previous undeleted message in window." - (interactive "p") - (setq mh-next-direction 'backward) - (beginning-of-line) - (cond ((re-search-backward mh-good-msg-regexp nil 0 arg) - (mh-maybe-show)) - (t - (if (get-buffer mh-show-buffer) - (delete-windows-on mh-show-buffer))))) - - -(defun mh-print-msg (prefix-provided msg-or-seq) - "Print MESSAGE(s) (default: displayed message) on a line printer. -If optional prefix argument provided, then prompt for the message sequence." - (interactive (list current-prefix-arg - (if current-prefix-arg - (reverse (mh-seq-to-msgs - (mh-read-seq-default "Print" t))) - (mh-get-msg-num t)))) - (if prefix-provided - (message "Printing sequence...") - (message "Printing message...")) - (let ((print-command - (if prefix-provided - (format "(scan -clear %s ; %s -nobell -clear %s %s) | %s" - (mapconcat (function (lambda (msg) msg)) msg-or-seq " ") - (expand-file-name "mhl" mh-lib) - (if (stringp mhl-formfile) - (format "-form %s" mhl-formfile) - "") - (mh-msg-filenames msg-or-seq) - (format mh-lpr-command-format - (if prefix-provided - (format "Sequence from %s" mh-current-folder) - (format "%s/%d" mh-current-folder - msg-or-seq)))) - (format "%s -nobell -clear %s %s | %s" - (expand-file-name "mhl" mh-lib) - (mh-msg-filename msg-or-seq) - (if (stringp mhl-formfile) - (format "-form %s" mhl-formfile) - "") - (format mh-lpr-command-format - (if prefix-provided - (format "Sequence from %s" mh-current-folder) - (format "%s/%d" mh-current-folder - msg-or-seq))))))) - (if mh-print-background - (mh-exec-cmd-daemon shell-file-name "-c" print-command) - (call-process shell-file-name nil nil nil "-c" print-command)) - (if prefix-provided - (mh-notate-seq msg-or-seq ?P mh-cmd-note) - (mh-notate msg-or-seq ?P mh-cmd-note)) - (mh-add-msgs-to-seq msg-or-seq 'printed t) - (if prefix-provided - (message "Printing sequence...done") - (message "Printing message...done")))) - - -(defun mh-put-msg-in-seq (prefix-provided from to) - "Add MESSAGE(s) (default: displayed message) to SEQUENCE. -If optional prefix argument provided, then prompt for the message sequence." - (interactive (list current-prefix-arg - (if current-prefix-arg - (mh-seq-to-msgs - (mh-read-seq-default "Add messages from" t)) - (mh-get-msg-num t)) - (mh-read-seq-default "Add to" nil))) - (setq mh-previous-seq to) - (mh-add-msgs-to-seq from to)) - - -(defun mh-rescan-folder (&optional range) - "Rescan a folder after optionally processing the outstanding commands. -If optional prefix argument is provided, prompt for the range of -messages to display. Otherwise show the entire folder." - (interactive (list (if current-prefix-arg - (mh-read-msg-range "Range to scan [all]? ") - nil))) - (setq mh-next-direction 'forward) - (mh-scan-folder mh-current-folder (or range "all"))) - - -(defun mh-redistribute (to cc msg) - "Redistribute a letter. -Depending on how your copy of MH was compiled, you may need to change the -setting of the variable mh-redist-full-contents. See its documentation." - (interactive (list (read-string "Redist-To: ") - (read-string "Redist-Cc: ") - (mh-get-msg-num t))) - (save-window-excursion - (let ((folder mh-current-folder) - (draft (mh-read-draft "redistribution" - (if mh-redist-full-contents - (mh-msg-filename msg) - nil) - nil))) - (mh-goto-header-end 0) - (insert "Resent-To: " to "\n") - (if (not (equal cc "")) (insert "Resent-cc: " cc "\n")) - (mh-clean-msg-header (point-min) - "^Message-Id:\\|^Received:\\|^Return-Path:\\|^Sender:\\|^Date:\\|^From:" - nil) - (save-buffer) - (message "Redistributing...") - (if mh-redist-full-contents - (call-process "/bin/sh" nil 0 nil "-c" - (format "mhdist=1 mhaltmsg=%s %s -push %s" - (buffer-file-name) - (expand-file-name "send" mh-progs) - (buffer-file-name))) - (call-process "/bin/sh" nil 0 nil "-c" - (format "mhdist=1 mhaltmsg=%s mhannotate=1 %s -push %s" - (mh-msg-filename msg folder) - (expand-file-name "send" mh-progs) - (buffer-file-name)))) - (mh-annotate-msg msg folder mh-note-dist - "-component" "Resent:" - "-text" (format "\"%s %s\"" to cc)) - (kill-buffer draft) - (message "Redistributing...done")))) - - -(defun mh-write-msg-to-file (msg file) - "Append MESSAGE to the end of a FILE." - (interactive - (list (mh-get-msg-num t) - (let ((default-dir (if (eq 'write (car mh-last-destination)) - (file-name-directory (cdr mh-last-destination)) - default-directory))) - (read-file-name "Save message in file: " default-dir - (expand-file-name "mail.out" default-dir))))) - (let ((file-name (mh-msg-filename msg)) - (output-file (mh-expand-file-name file))) - (setq mh-last-destination (cons 'write file)) - (save-excursion - (set-buffer (get-buffer-create " *mh-temp*")) - (erase-buffer) - (insert-file-contents file-name) - (append-to-file (point-min) (point-max) output-file)))) - - -(defun mh-search-folder (folder) - "Search FOLDER for messages matching a pattern." - (interactive (list (mh-prompt-for-folder "Search" - mh-current-folder - t))) - (switch-to-buffer-other-window "pick-pattern") - (if (or (zerop (buffer-size)) - (not (y-or-n-p "Reuse pattern? "))) - (mh-make-pick-template) - (message "")) - (setq mh-searching-folder folder)) - - -(defun mh-send (to cc subject) - "Compose and send a letter. -The letter is composed in mh-letter-mode; see its documentation for more -details. If `mh-compose-letter-function' is defined, it is called on the -draft and passed three arguments: to, subject, and cc." - (interactive "sTo: \nsCc: \nsSubject: ") - (let ((config (current-window-configuration))) - (delete-other-windows) - (mh-send-sub to cc subject config))) - - -(defun mh-send-other-window (to cc subject) - "Compose and send a letter in another window.." - (interactive "sTo: \nsCc: \nsSubject: ") - (let ((pop-up-windows t)) - (mh-send-sub to cc subject (current-window-configuration)))) - - -(defun mh-send-sub (to cc subject config) - "Do the real work of composing and sending a letter. -Expects the TO, CC, and SUBJECT fields as arguments. -CONFIG is the window configuration before sending mail." - (let ((folder mh-current-folder) - (msg-num (mh-get-msg-num nil))) - (message "Composing a message...") - (let ((draft (mh-read-draft - "message" - (if (file-exists-p - (expand-file-name "components" mh-user-path)) - (expand-file-name "components" mh-user-path) - (if (file-exists-p - (expand-file-name "components" mh-lib)) - (expand-file-name "components" mh-lib) - (error "Can't find components file"))) - nil))) - (mh-insert-fields "To:" to "Subject:" subject "Cc:" cc) - (set-buffer-modified-p nil) - (goto-char (point-max)) - (message "Composing a message...done") - (mh-compose-and-send-mail draft "" folder msg-num - to subject cc - nil nil config)))) - - -(defun mh-show (&optional msg) - "Show MESSAGE (default: displayed message). -Forces a two-window display with the folder window on top (size -mh-summary-height) and the show buffer below it." - (interactive) - (if (not msg) - (setq msg (mh-get-msg-num t))) - (setq mh-showing t) - (mh-set-mode-name "mh-e show") - (if (not (eql (next-window (minibuffer-window)) (selected-window))) - (delete-other-windows)) ; force ourself to the top window - (let ((folder mh-current-folder)) - (mh-show-message-in-other-window) - (mh-display-msg msg folder)) - (other-window -1) - (if (not (= (1+ (window-height)) (screen-height))) ;not horizontally split - (shrink-window (- (window-height) mh-summary-height))) - (mh-recenter nil) - (if (not (memq msg mh-seen-list)) (mh-push msg mh-seen-list))) - - -(defun mh-sort-folder () - "Sort the messages in the current folder by date." - (interactive) - (mh-process-or-undo-commands mh-current-folder) - (setq mh-next-direction 'forward) - (mh-set-folder-modified-p t) ; lock folder while sorting - (message "Sorting folder...") - (mh-exec-cmd "sortm" mh-current-folder) - (message "Sorting folder...done") - (mh-scan-folder mh-current-folder "all")) - - -(defun mh-toggle-showing () - "Toggle the scanning mode/showing mode of displaying messages." - (interactive) - (if mh-showing - (mh-set-scan-mode) - (mh-show))) - - -(defun mh-undo (prefix-provided msg-or-seq) - "Undo the deletion or refile of the specified MESSAGE(s). -Default is the displayed message. If optional prefix argument is -provided, then prompt for the message sequence." - (interactive (list current-prefix-arg - (if current-prefix-arg - (mh-read-seq-default "Undo" t) - (mh-get-msg-num t)))) - (cond (prefix-provided - (mh-mapc (function mh-undo-msg) (mh-seq-to-msgs msg-or-seq))) - (t - (let ((original-position (point))) - (beginning-of-line) - (while (not (or (looking-at mh-deleted-msg-regexp) - (looking-at mh-refiled-msg-regexp) - (and (eq mh-next-direction 'forward) (bobp)) - (and (eq mh-next-direction 'backward) - (save-excursion (forward-line) (eobp))))) - (forward-line (if (eq mh-next-direction 'forward) -1 1))) - (if (or (looking-at mh-deleted-msg-regexp) - (looking-at mh-refiled-msg-regexp)) - (progn - (mh-undo-msg (mh-get-msg-num t)) - (mh-maybe-show)) - (goto-char original-position) - (error "Nothing to undo"))))) - ;; update the mh-refile-list so mh-outstanding-commands-p will work - (mh-mapc (function - (lambda (elt) - (if (not (mh-seq-to-msgs elt)) - (setq mh-refile-list (delq elt mh-refile-list))))) - mh-refile-list) - (if (not (mh-outstanding-commands-p)) - (mh-set-folder-modified-p nil))) - - -(defun mh-undo-msg (msg) - ;; Undo the deletion or refile of one MESSAGE. - (cond ((memq msg mh-delete-list) - (setq mh-delete-list (delq msg mh-delete-list)) - (mh-remove-msg-from-seq msg 'deleted t)) - (t - (mh-mapc (function (lambda (dest) - (mh-remove-msg-from-seq msg dest t))) - mh-refile-list))) - (mh-notate msg ? mh-cmd-note)) - - -(defun mh-undo-folder (&rest ignore) - "Undo all commands in current folder." - (interactive) - (cond ((or mh-do-not-confirm - (yes-or-no-p "Undo all commands in folder? ")) - (setq mh-delete-list nil - mh-refile-list nil - mh-seq-list nil - mh-next-direction 'forward) - (with-mh-folder-updating (nil) - (mh-unmark-all-headers t))) - (t - (message "Commands not undone.") - (sit-for 2)))) - - -(defun mh-unshar-msg (dir) - "Unpack the shar file contained in the current message into directory DIR." - (interactive (list (read-file-name "Unshar message in directory: " - mh-unshar-default-directory - mh-unshar-default-directory nil))) - (mh-display-msg (mh-get-msg-num t) mh-current-folder) ;update show buffer - (mh-unshar-buffer dir)) - -(defun mh-unshar-buffer (dir) - ;; Unpack the shar file contained in the current buffer into directory DIR. - (goto-char (point-min)) - (if (or (re-search-forward "^#![ \t]*/bin/sh" nil t) - (and (re-search-forward "^[^a-z0-9\"]*cut here\b" nil t) - (forward-line 1)) - (re-search-forward "^#" nil t) - (re-search-forward "^: " nil t)) - (let ((default-directory (expand-file-name dir)) - (start (progn (beginning-of-line) (point))) - (log-buffer (get-buffer-create "*Unshar Output*"))) - (save-excursion - (set-buffer log-buffer) - (setq default-directory (expand-file-name dir)) - (erase-buffer) - (if (file-directory-p default-directory) - (insert "cd " dir "\n") - (insert "mkdir " dir "\n") - (call-process "mkdir" nil log-buffer t default-directory))) - (set-window-start (display-buffer log-buffer) 0) ;so can watch progress - (call-process-region start (point-max) "sh" nil log-buffer t)) - (error "Cannot find start of shar."))) - - -(defun mh-visit-folder (folder &optional range) - "Visit FOLDER and display RANGE of messages. -Assumes mh-e has already been initialized." - (interactive (list (mh-prompt-for-folder "Visit" "+inbox" t) - (mh-read-msg-range "Range [all]? "))) - (let ((config (current-window-configuration))) - (mh-scan-folder folder (or range "all")) - (setq mh-previous-window-config config)) - nil) - - -(defun mh-widen () - "Remove restrictions from the current folder, thereby showing all messages." - (interactive) - (if mh-narrowed-to-seq - (with-mh-folder-updating (t) - (delete-region (point-min) (point-max)) - (widen) - (mh-make-folder-mode-line))) - (setq mh-narrowed-to-seq nil)) - - - -;;; Support routines. - -(defun mh-delete-a-msg (msg) - ;; Delete the MESSAGE. - (save-excursion - (mh-goto-msg msg nil t) - (if (looking-at mh-refiled-msg-regexp) - (error "Message %d is refiled. Undo refile before deleting." msg)) - (if (looking-at mh-deleted-msg-regexp) - nil - (mh-set-folder-modified-p t) - (mh-push msg mh-delete-list) - (mh-add-msgs-to-seq msg 'deleted t) - (mh-notate msg ?D mh-cmd-note)))) - - -(defun mh-refile-a-msg (msg destination) - ;; Refile MESSAGE in FOLDER. FOLDER is a symbol, not a string. - (save-excursion - (mh-goto-msg msg nil t) - (cond ((looking-at mh-deleted-msg-regexp) - (error "Message %d is deleted. Undo delete before moving." msg)) - ((looking-at mh-refiled-msg-regexp) - (if (y-or-n-p - (format "Message %d already refiled. Copy to %s as well? " - msg destination)) - (mh-exec-cmd "refile" (mh-get-msg-num t) "-link" - "-src" mh-current-folder - (symbol-name destination)) - (message "Message not copied."))) - (t - (mh-set-folder-modified-p t) - (if (not (memq destination mh-refile-list)) - (mh-push destination mh-refile-list)) - (if (not (memq msg (mh-seq-to-msgs destination))) - (mh-add-msgs-to-seq msg destination t)) - (mh-notate msg ?^ mh-cmd-note))))) - - -(defun mh-display-msg (msg-num folder) - ;; Display message NUMBER of FOLDER. - ;; Sets the current buffer to the show buffer. - (set-buffer folder) - ;; Bind variables in folder buffer in case they are local - (let ((formfile mhl-formfile) - (clean-message-header mh-clean-message-header) - (invisible-headers mh-invisible-headers) - (visible-headers mh-visible-headers) - (msg-filename (mh-msg-filename msg-num)) - (show-buffer mh-show-buffer) - (folder mh-current-folder)) - (if (not (file-exists-p msg-filename)) - (error "Message %d does not exist" msg-num)) - (switch-to-buffer show-buffer) - (if mh-bury-show-buffer (bury-buffer (current-buffer))) - (mh-when (not (equal msg-filename buffer-file-name)) - ;; Buffer does not yet contain message. - (clear-visited-file-modtime) - (unlock-buffer) - (setq buffer-file-name nil) ; no locking during setup - (erase-buffer) - (if formfile - (if (stringp formfile) - (mh-exec-lib-cmd-output "mhl" "-nobell" "-noclear" - "-form" formfile msg-filename) - (mh-exec-lib-cmd-output "mhl" "-nobell" "-noclear" - msg-filename)) - (insert-file-contents msg-filename)) - (goto-char (point-min)) - (cond (clean-message-header - (mh-clean-msg-header (point-min) - invisible-headers - visible-headers) - (goto-char (point-min))) - (t - (let ((case-fold-search t)) - (re-search-forward - "^To:\\|^From:\\|^Subject:\\|^Date:" nil t) - (beginning-of-line) - (mh-recenter 0)))) - (set-buffer-modified-p nil) - (setq buffer-file-name msg-filename) - (set-mark nil) - (setq mode-line-buffer-identification - (list (format mh-show-buffer-mode-line-buffer-id - folder msg-num)))))) - - -(defun mh-invalidate-show-buffer () - ;; Invalidate the show buffer so we must update it to use it. - (if (get-buffer mh-show-buffer) - (save-excursion - (set-buffer mh-show-buffer) - (setq buffer-file-name nil)))) - - -(defun mh-show-message-in-other-window () - (switch-to-buffer-other-window mh-show-buffer) - (if mh-bury-show-buffer (bury-buffer (current-buffer)))) - - -(defun mh-clean-msg-header (start invisible-headers visible-headers) - ;; Flush extraneous lines in a message header, from the given POINT to the - ;; end of the message header. If VISIBLE-HEADERS is non-nil, it contains a - ;; regular expression specifying the lines to display, otherwise - ;; INVISIBLE-HEADERS contains a regular expression specifying lines to - ;; delete from the header. - (let ((case-fold-search t)) - (save-restriction - (goto-char start) - (if (search-forward "\n\n" nil t) - (backward-char 1)) - (narrow-to-region start (point)) - (goto-char (point-min)) - (if visible-headers - (while (< (point) (point-max)) - (beginning-of-line) - (cond ((looking-at visible-headers) - (forward-line 1) - (while (looking-at "^[ \t]+") (forward-line 1))) - (t - (mh-delete-line 1) - (while (looking-at "^[ \t]+") - (beginning-of-line) - (mh-delete-line 1))))) - (while (re-search-forward invisible-headers nil t) - (beginning-of-line) - (mh-delete-line 1) - (while (looking-at "^[ \t]+") - (beginning-of-line) - (mh-delete-line 1)))) - (unlock-buffer)))) - - -(defun mh-delete-line (lines) - ;; Delete version of kill-line. - (delete-region (point) (save-excursion (forward-line lines) (point)))) - - -(defun mh-read-draft (use initial-contents delete-contents-file) - ;; Read draft file into a draft buffer and make that buffer the current one. - ;; USE is a message used for prompting about the intended use of the message. - ;; INITIAL-CONTENTS is filename that is read into an empty buffer, or NIL - ;; if buffer should not be modified. Delete the initial-contents file if - ;; DELETE-CONTENTS-FILE flag is set. - ;; Returns the draft folder's name. - ;; If the draft folder facility is enabled in ~/.mh_profile, a new buffer is - ;; used each time and saved in the draft folder. The draft file can then be - ;; reused. - (cond (mh-draft-folder - (let ((orig-default-dir default-directory)) - (pop-to-buffer (find-file-noselect (mh-new-draft-name)) t) - (rename-buffer (format "draft-%s" (buffer-name))) - (setq default-directory orig-default-dir))) - (t - (let ((draft-name (expand-file-name "draft" mh-user-path))) - (pop-to-buffer "draft") ; Create if necessary - (if (buffer-modified-p) - (if (y-or-n-p "Draft has been modified; kill anyway? ") - (set-buffer-modified-p nil) - (error "Draft preserved"))) - (setq buffer-file-name draft-name) - (clear-visited-file-modtime) - (unlock-buffer) - (mh-when (and (file-exists-p draft-name) - (not (equal draft-name initial-contents))) - (insert-file-contents draft-name) - (delete-file draft-name))))) - (mh-when (and initial-contents - (or (zerop (buffer-size)) - (not (y-or-n-p - (format "A draft exists. Use for %s? " use))))) - (erase-buffer) - (insert-file-contents initial-contents) - (if delete-contents-file (delete-file initial-contents))) - (auto-save-mode 1) - (if mh-draft-folder - (save-buffer)) ; Do not reuse draft name - (buffer-name)) - - -(defun mh-new-draft-name () - ;; Returns the pathname of folder for draft messages. - (save-excursion - (set-buffer (get-buffer-create " *mh-temp*")) - (erase-buffer) - (mh-exec-cmd-output "mhpath" nil mh-draft-folder "new") - (buffer-substring (point) (1- (mark t))))) - - -(defun mh-next-msg () - ;; Move backward or forward to the next undeleted message in the buffer. - (if (eq mh-next-direction 'forward) - (mh-next-undeleted-msg 1) - (mh-previous-undeleted-msg 1))) - - -(defun mh-set-scan-mode () - ;; Display the scan listing buffer, but do not show a message. - (if (get-buffer mh-show-buffer) - (delete-windows-on mh-show-buffer)) - (mh-set-mode-name "mh-e scan") - (setq mh-showing nil) - (if mh-recenter-summary-p - (mh-recenter nil))) - - -(defun mh-maybe-show (&optional msg) - ;; If in showing mode, then display the message pointed to by the cursor. - (if mh-showing (mh-show msg))) - - -(defun mh-set-mode-name (mode-name-string) - ;; Set the mode-name and ensure that the mode line is updated. - (setq mode-name mode-name-string) - ;; Force redisplay of all buffers' mode lines to be considered. - (save-excursion (set-buffer (other-buffer))) - (set-buffer-modified-p (buffer-modified-p))) - - - -;;; The folder data abstraction. - -(defvar mh-current-folder nil "Name of current folder, a string.") -(defvar mh-show-buffer nil "Buffer that displays message for this folder.") -(defvar mh-folder-filename nil "Full path of directory for this folder.") -(defvar mh-showing nil "If non-nil, show the message in a separate window.") -(defvar mh-next-seq-num nil "Index of free sequence id.") -(defvar mh-delete-list nil "List of msg numbers to delete.") -(defvar mh-refile-list nil "List of folder names in mh-seq-list.") -(defvar mh-seq-list nil "Alist of (seq . msgs) numbers.") -(defvar mh-seen-list nil "List of displayed messages.") -(defvar mh-next-direction 'forward "Direction to move to next message.") -(defvar mh-narrowed-to-seq nil "Sequence display is narrowed to.") -(defvar mh-first-msg-num nil "Number of first msg in buffer.") -(defvar mh-last-msg-num nil "Number of last msg in buffer.") - - -(defun mh-make-folder (name) - ;; Create and initialize a new mail folder called NAME and make it the - ;; current folder. - (switch-to-buffer name) - (setq buffer-read-only nil) - (erase-buffer) - (setq buffer-read-only t) - (mh-folder-mode) - (mh-set-folder-modified-p nil) - (setq buffer-file-name mh-folder-filename) - (mh-set-mode-name "mh-e scan")) - - -;;; Don't use this mode when creating buffers if default-major-mode is nil. -(put 'mh-folder-mode 'mode-class 'special) - -(defun mh-folder-mode () - "Major mode for \"editing\" an MH folder scan listing. -Messages can be marked for refiling and deletion. However, both actions -are deferred until you request execution with \\[mh-execute-commands]. -\\{mh-folder-mode-map} - A prefix argument (\\[universal-argument]) to delete, refile, list, or undo -applies the action to a message sequence. - -Variables controlling mh-e operation are (defaults in parentheses): - - mh-bury-show-buffer (t) - Non-nil means that the buffer used to display message is buried. - It will never be offered as the default other buffer. - - mh-clean-message-header (nil) - Non-nil means remove header lines matching the regular expression - specified in mh-invisible-headers from messages. - - mh-visible-headers (nil) - If non-nil, it contains a regexp specifying the headers that are shown in - a message if mh-clean-message-header is non-nil. Setting this variable - overrides mh-invisible-headers. - - mh-do-not-confirm (nil) - Non-nil means do not prompt for confirmation before executing some - non-recoverable commands such as mh-kill-folder and mh-undo-folder. - - mhl-formfile (nil) - Name of format file to be used by mhl to show messages. - A value of T means use the default format file. - Nil means don't use mhl to format messages. - - mh-lpr-command-format (\"lpr -p -J '%s'\") - Format for command used to print a message on a system printer. - - mh-recenter-summary-p (nil) - If non-nil, then the scan listing is recentered when the window displaying - a messages is toggled off. - - mh-summary-height (4) - Number of lines in the summary window including the mode line. - - mh-ins-buf-prefix (\"> \") - String to insert before each non-blank line of a message as it is - inserted in a draft letter. - -The value of mh-folder-mode-hook is called when a new folder is set up." - - (kill-all-local-variables) - (use-local-map mh-folder-mode-map) - (setq major-mode 'mh-folder-mode) - (mh-set-mode-name "mh-e folder") - (make-local-vars - 'mh-current-folder (buffer-name) ; Name of folder, a string - 'mh-show-buffer (format "show-%s" (buffer-name)) ; Buffer that displays msgs - 'mh-folder-filename ; e.g. "/usr/foobar/Mail/inbox/" - (file-name-as-directory (mh-expand-file-name (buffer-name))) - 'mh-showing nil ; Show message also? - 'mh-next-seq-num 0 ; Index of free sequence id - 'mh-delete-list nil ; List of msgs nums to delete - 'mh-refile-list nil ; List of folder names in mh-seq-list - 'mh-seq-list nil ; Alist of (seq . msgs) nums - 'mh-seen-list nil ; List of displayed messages - 'mh-next-direction 'forward ; Direction to move to next message - 'mh-narrowed-to-seq nil ; Sequence display is narrowed to - 'mh-first-msg-num nil ; Number of first msg in buffer - 'mh-last-msg-num nil ; Number of last msg in buffer - 'mh-previous-window-config nil) ; Previous window configuration - (setq truncate-lines t) - (auto-save-mode -1) - (setq buffer-offer-save t) - (make-local-variable 'write-file-hooks) - (setq write-file-hooks '(mh-execute-commands)) - (make-local-variable 'revert-buffer-function) - (setq revert-buffer-function 'mh-undo-folder) - (run-hooks 'mh-folder-mode-hook)) - - -(defun make-local-vars (&rest pairs) - ;; Take VARIABLE-VALUE pairs and makes local variables initialized to the - ;; value. - (while pairs - (make-variable-buffer-local (car pairs)) - (set (car pairs) (car (cdr pairs))) - (setq pairs (cdr (cdr pairs))))) - - -(defun mh-scan-folder (folder range) - ;; Scan the FOLDER over the RANGE. Return in the folder's buffer. - (cond ((null (get-buffer folder)) - (mh-make-folder folder)) - (t - (mh-process-or-undo-commands folder) - (switch-to-buffer folder))) - (mh-regenerate-headers range) - (mh-when (zerop (buffer-size)) - (if (equal range "all") - (message "Folder %s is empty" folder) - (message "No messages in %s, range %s" folder range)) - (sit-for 5)) - (mh-goto-cur-msg)) - - -(defun mh-regenerate-headers (range) - ;; Replace buffer with scan of its contents over range RANGE. - (let ((folder mh-current-folder)) - (message "Scanning %s..." folder) - (with-mh-folder-updating (nil) - (erase-buffer) - (mh-exec-cmd-output "scan" nil - "-noclear" "-noheader" - "-width" (window-width) - folder range) - (goto-char (point-min)) - (cond ((looking-at "scan: no messages in") - (keep-lines mh-valid-scan-line)) ; Flush random scan lines - ((looking-at "scan: ")) ; Keep error messages - (t - (keep-lines mh-valid-scan-line))) ; Flush random scan lines - (mh-delete-seq-locally 'cur) ; To pick up new one - (setq mh-seq-list (mh-read-folder-sequences folder nil)) - (mh-notate-user-sequences) - (mh-make-folder-mode-line (if (equal range "all") - nil - mh-partial-folder-mode-line-annotation))) - (message "Scanning %s...done" folder))) - - -(defun mh-get-new-mail (maildrop-name) - ;; Read new mail from a maildrop into the current buffer. - ;; Return T if there was new mail, NIL otherwise. Return in the current - ;; buffer. - (let ((point-before-inc (point)) - (folder mh-current-folder) - (return-value t)) - (with-mh-folder-updating (t) - (message (if maildrop-name - (format "inc %s -file %s..." folder maildrop-name) - (format "inc %s..." folder))) - (mh-unmark-all-headers nil) - (setq mh-next-direction 'forward) - (goto-char (point-max)) - (let ((start-of-inc (point))) - (if maildrop-name - (mh-exec-cmd-output "inc" nil folder - "-file" (expand-file-name maildrop-name) - "-width" (window-width) - "-truncate") - (mh-exec-cmd-output "inc" nil - "-width" (window-width))) - (message - (if maildrop-name - (format "inc %s -file %s...done" folder maildrop-name) - (format "inc %s...done" folder))) - (goto-char start-of-inc) - (cond ((looking-at "inc: no mail") - (keep-lines mh-valid-scan-line) ; Flush random scan lines - (goto-char point-before-inc) - (message "No new mail%s%s" (if maildrop-name " in " "") - (if maildrop-name maildrop-name ""))) - ((re-search-forward "^inc:" nil t) ; Error messages - (error "inc error")) - (t - (mh-delete-seq-locally 'cur) ; To pick up new one - (setq mh-seq-list (mh-read-folder-sequences folder t)) - (mh-notate-user-sequences) - (keep-lines mh-valid-scan-line) - (mh-make-folder-mode-line) - (mh-goto-cur-msg) - (setq return-value t)))) - return-value))) - - -(defun mh-make-folder-mode-line (&optional annotation) - ;; Set the fields of the mode line for a folder buffer. - ;; The optional ANNOTATION string is displayed after the folder's name. - (save-excursion - (mh-first-msg) - (setq mh-first-msg-num (mh-get-msg-num nil)) - (mh-last-msg) - (setq mh-last-msg-num (mh-get-msg-num nil)) - (let ((lines (count-lines (point-min) (point-max)))) - (setq mode-line-buffer-identification - (list (format "{%%b%s} %d msg%s" - (if annotation (format "/%s" annotation) "") - lines - (if (zerop lines) - "s" - (if (> lines 1) - (format "s (%d-%d)" mh-first-msg-num - mh-last-msg-num) - (format " (%d)" mh-first-msg-num))))))))) - - -(defun mh-unmark-all-headers (remove-all-flags) - ;; Remove all '+' flags from the headers, and if called with a non-nil - ;; argument, remove all 'D', '^' and '%' flags too. - ;; Optimized for speed (i.e., no regular expressions). - (save-excursion - (let ((case-fold-search nil) - (last-line (- (point-max) mh-cmd-note)) - char) - (mh-first-msg) - (while (<= (point) last-line) - (forward-char mh-cmd-note) - (setq char (following-char)) - (if (or (and remove-all-flags - (or (eql char ?D) - (eql char ?^) - (eql char ?%))) - (eql char ?+)) - (progn - (delete-char 1) - (insert " "))) - (forward-line))))) - - -(defun mh-goto-cur-msg () - ;; Position the cursor at the current message. - (let ((cur-msg (car (mh-seq-to-msgs 'cur)))) - (cond ((and cur-msg - (mh-goto-msg cur-msg t nil)) - (mh-notate nil ?+ mh-cmd-note) - (mh-recenter 0) - (mh-maybe-show cur-msg)) - (t - (mh-last-msg) - (message "No current message"))))) - - -(defun mh-pack-folder-1 (range) - ;; Close and pack the current folder. - (mh-process-or-undo-commands mh-current-folder) - (message "Packing folder...") - (mh-set-folder-modified-p t) ; lock folder while packing - (save-excursion - (mh-exec-cmd-quiet " *mh-temp*" "folder" mh-current-folder "-pack")) - (mh-regenerate-headers range)) - - -(defun mh-process-or-undo-commands (folder) - ;; If FOLDER has outstanding commands, then either process or discard them. - (set-buffer folder) - (if (mh-outstanding-commands-p) - (if (or mh-do-not-confirm - (y-or-n-p - "Process outstanding deletes and refiles (or lose them)? ")) - (mh-process-commands folder) - (mh-undo-folder)) - (mh-invalidate-show-buffer))) - - -(defun mh-process-commands (folder) - ;; Process outstanding commands for the folder FOLDER. - (message "Processing deletes and refiles for %s..." folder) - (set-buffer folder) - (with-mh-folder-updating (nil) - ;; Update the unseen sequence if it exists - (if (and mh-seen-list (mh-seq-to-msgs mh-unseen-seq)) - (mh-undefine-sequence mh-unseen-seq mh-seen-list)) - - ;; Then refile messages - (mh-mapc - (function - (lambda (dest) - (let ((msgs (mh-seq-to-msgs dest))) - (mh-when msgs - (apply 'mh-exec-cmd "refile" - "-src" folder (symbol-name dest) msgs) - (mh-delete-scan-msgs msgs))))) - mh-refile-list) - - ;; Now delete messages - (mh-when mh-delete-list - (apply 'mh-exec-cmd "rmm" folder mh-delete-list) - (mh-delete-scan-msgs mh-delete-list)) - - ;; Don't need to remove sequences since delete and refile do so. - - ;; Mark cur message - (if (> (buffer-size) 0) - (mh-define-sequence 'cur (list (or (mh-get-msg-num nil) "last")))) - - (mh-invalidate-show-buffer) - - (setq mh-delete-list nil - mh-refile-list nil - mh-seq-list (mh-read-folder-sequences mh-current-folder nil) - mh-seen-list nil) - (mh-unmark-all-headers t) - (mh-notate-user-sequences) - (message "Processing deletes and refiles for %s...done" folder))) - - -(defun mh-delete-scan-msgs (msgs) - ;; Delete the scan listing lines for each of the msgs in the LIST. - ;; Optimized for speed (i.e., no regular expressions). - (setq msgs (sort msgs (function <))) ;okay to clobber msgs - (save-excursion - (mh-first-msg) - (while (and msgs (< (point) (point-max))) - (cond ((equal (mh-get-msg-num nil) (car msgs)) - (delete-region (point) (save-excursion (forward-line) (point))) - (setq msgs (cdr msgs))) - (t - (forward-line)))))) - - -(defun mh-set-folder-modified-p (flag) - "Mark current folder as modified or unmodified according to FLAG." - (set-buffer-modified-p flag)) - - -(defun mh-outstanding-commands-p () - ;; Returns non-nil if there are outstanding deletes or refiles. - (or mh-delete-list mh-refile-list)) - - - -;;; Mode for composing and sending a draft message. - -(defvar mh-sent-from-folder nil - "Folder of msg associated with this letter.") - -(defvar mh-sent-from-msg nil - "Number of msg associated with this letter.") - -(defvar mh-send-args nil - "Extra arguments to pass to \"send\" command.") - -(defvar mh-annotate-char nil - "Character to use to annotate mh-sent-from-msg.") - -(defvar mh-annotate-field nil - "Field name for message annotation.") - -(defun mh-letter-mode () - "Mode for composing letters in mh-e. -When you have finished composing, type \\[mh-send-letter] to send the letter. - -Variables controlling this mode (defaults in parentheses): - - mh-delete-yanked-msg-window (nil) - If non-nil, \\[mh-yank-cur-msg] will delete any windows displaying - the yanked message. - - mh-yank-from-start-of-msg (t) - If non-nil, \\[mh-yank-cur-msg] will include the entire message. - If `body', just yank the body (no header). - If nil, only the portion of the message following the point will be yanked. - If there is a region, this variable is ignored. - - mh-signature-file-name (\"~/.signature\") - File to be inserted into message by \\[mh-insert-signature]. - -Upon invoking mh-letter-mode, text-mode-hook and mh-letter-mode-hook are -invoked with no args, if those values are non-nil. - -\\{mh-letter-mode-map}" - (interactive) - (kill-all-local-variables) - (make-local-variable 'paragraph-start) - (setq paragraph-start (concat "^[ \t]*[-_][-_][-_]+$\\|" paragraph-start)) - (make-local-variable 'paragraph-separate) - (setq paragraph-separate - (concat "^[ \t]*[-_][-_][-_]+$\\|" paragraph-separate)) - (make-local-variable 'mh-send-args) - (make-local-variable 'mh-annotate-char) - (make-local-variable 'mh-annotate-field) - (make-local-variable 'mh-previous-window-config) - (make-local-variable 'mh-sent-from-folder) - (make-local-variable 'mh-sent-from-msg) - (use-local-map mh-letter-mode-map) - (setq major-mode 'mh-letter-mode) - (mh-set-mode-name "mh-e letter") - (set-syntax-table mh-letter-mode-syntax-table) - (run-hooks 'text-mode-hook 'mh-letter-mode-hook) - (mh-when (and (boundp 'auto-fill-hook) auto-fill-hook) ;emacs 18 - (make-local-variable 'auto-fill-hook) - (setq auto-fill-hook 'mh-auto-fill-for-letter)) - (mh-when (and (boundp 'auto-fill-function) auto-fill-function) ;emacs 19 - (make-local-variable 'auto-fill-function) - (setq auto-fill-function 'mh-auto-fill-for-letter))) - - -(defun mh-auto-fill-for-letter () - ;; Auto-fill in letters treats the header specially by inserting a tab - ;; before continuation line. - (do-auto-fill) - (if (mh-in-header-p) - (save-excursion - (beginning-of-line nil) - (insert-char ?\t 1)))) - - -(defun mh-in-header-p () - ;; Return non-nil if the point is in the header of a draft message. - (save-excursion - (let ((cur-point (point))) - (goto-char (point-min)) - (re-search-forward "^--------" nil t) - (< cur-point (point))))) - - -(defun mh-to-field () - "Move point to the end of a specified header field. -The field is indicated by the previous keystroke. Create the field if -it does not exist. Set the mark to point before moving." - (interactive) - (expand-abbrev) - (let ((target (cdr (assoc (logior last-input-char ?`) mh-to-field-choices))) - (case-fold-search t)) - (cond ((mh-position-on-field target t) - (let ((eol (point))) - (skip-chars-backward " \t") - (delete-region (point) eol)) - (if (and (not (eq (logior last-input-char ?`) ?s)) - (save-excursion - (backward-char 1) - (not (looking-at "[:,]")))) - (insert ", ") - (insert " "))) - (t - (goto-char (point-min)) - (re-search-forward "^To:") - (forward-line 1) - (while (looking-at "^[ \t]") (forward-line 1)) - (insert (format "%s \n" target)) - (backward-char 1))))) - - -(defun mh-to-fcc () - "Insert an Fcc: field in the current message. -Prompt for the field name with a completion list of the current folders." - (interactive) - (let ((last-input-char ?\C-f) - (folder (mh-prompt-for-folder "Fcc" "" t))) - (expand-abbrev) - (save-excursion - (mh-to-field) - (insert (substring folder 1 nil))))) - - -(defun mh-insert-signature () - "Insert the file named by mh-signature-file-name at the current point." - (interactive) - (insert-file-contents mh-signature-file-name) - (set-buffer-modified-p (buffer-modified-p))) ; force mode line update - - -(defun mh-check-whom () - "Verify recipients of the current letter." - (interactive) - (let ((file-name (buffer-file-name))) - (set-buffer-modified-p t) ; Force writing of contents - (save-buffer) - (message "Checking recipients...") - (switch-to-buffer-other-window "*Mail Recipients*") - (bury-buffer (current-buffer)) - (erase-buffer) - (mh-exec-cmd-output "whom" t file-name) - (other-window -1) - (message "Checking recipients...done"))) - - - -;;; Routines to make a search pattern and search for a message. - -(defvar mh-searching-folder nil "Folder this pick is searching.") - - -(defun mh-make-pick-template () - ;; Initialize the current buffer with a template for a pick pattern. - (erase-buffer) - (kill-all-local-variables) - (make-local-variable 'mh-searching-folder) - (insert "From: \n" - "To: \n" - "Cc: \n" - "Date: \n" - "Subject: \n" - "---------\n") - (mh-letter-mode) - (use-local-map mh-pick-mode-map) - (goto-char (point-min)) - (end-of-line)) - - -(defun mh-do-pick-search () - "Find messages that match the qualifications in the current pattern buffer. -Messages are searched for in the folder named in mh-searching-folder. -Put messages found in a sequence named `search'." - (interactive) - (let ((pattern-buffer (buffer-name)) - (searching-buffer mh-searching-folder) - range msgs - (pattern nil) - (new-buffer nil)) - (save-excursion - (cond ((get-buffer searching-buffer) - (set-buffer searching-buffer) - (setq range (format "%d-%d" mh-first-msg-num mh-last-msg-num))) - (t - (mh-make-folder searching-buffer) - (setq range "all") - (setq new-buffer t)))) - (message "Searching...") - (goto-char (point-min)) - (while (setq pattern (mh-next-pick-field pattern-buffer)) - (setq msgs (mh-seq-from-command searching-buffer - 'search - (nconc (cons "pick" pattern) - (list searching-buffer - range - "-sequence" "search" - "-list")))) - (setq range "search")) - (message "Searching...done") - (if new-buffer - (mh-scan-folder searching-buffer msgs) - (switch-to-buffer searching-buffer)) - (delete-other-windows) - (mh-notate-seq 'search ?% (1+ mh-cmd-note)))) - - -(defun mh-next-pick-field (buffer) - ;; Return the next piece of a pick argument that can be extracted from the - ;; BUFFER. Returns nil if no pieces remain. - (set-buffer buffer) - (let ((case-fold-search t)) - (cond ((eobp) - nil) - ((re-search-forward "^\\([a-z].*\\):[ \t]*\\([a-z0-9].*\\)$" nil t) - (let* ((component - (format "--%s" - (downcase (buffer-substring (match-beginning 1) - (match-end 1))))) - (pat (buffer-substring (match-beginning 2) (match-end 2)))) - (forward-line 1) - (list component pat))) - ((re-search-forward "^-*$" nil t) - (forward-char 1) - (let ((body (buffer-substring (point) (point-max)))) - (if (and (> (length body) 0) (not (equal body "\n"))) - (list "-search" body) - nil))) - (t - nil)))) - - - -;;; Routines to compose and send a letter. - -(defun mh-compose-and-send-mail (draft send-args - sent-from-folder sent-from-msg - to subject cc - annotate-char annotate-field - config) - ;; Edit and compose a draft message in buffer DRAFT and send or save it. - ;; SENT-FROM-FOLDER is buffer containing scan listing of current folder, or - ;; nil if none exists. - ;; SENT-FROM-MSG is the message number or sequence name or nil. - ;; SEND-ARGS is an optional argument passed to the send command. - ;; The TO, SUBJECT, and CC fields are passed to the - ;; mh-compose-letter-function. - ;; If ANNOTATE-CHAR is non-null, it is used to notate the scan listing of the - ;; message. In that case, the ANNOTATE-FIELD is used to build a string - ;; for mh-annotate-msg. - ;; CONFIG is the window configuration to restore after sending the letter. - (pop-to-buffer draft) - (mh-letter-mode) - (setq mh-sent-from-folder sent-from-folder) - (setq mh-sent-from-msg sent-from-msg) - (setq mh-send-args send-args) - (setq mh-annotate-char annotate-char) - (setq mh-annotate-field annotate-field) - (setq mh-previous-window-config config) - (setq mode-line-buffer-identification (list "{%b}")) - (if (and (boundp 'mh-compose-letter-function) - (symbol-value 'mh-compose-letter-function)) - ;; run-hooks will not pass arguments. - (let ((value (symbol-value 'mh-compose-letter-function))) - (if (and (listp value) (not (eq (car value) 'lambda))) - (while value - (funcall (car value) to subject cc) - (setq value (cdr value))) - (funcall mh-compose-letter-function to subject cc))))) - - -(defun mh-send-letter (&optional arg) - "Send the draft letter in the current buffer. -If optional prefix argument is provided, monitor delivery. -Run mh-before-send-letter-hook before doing anything." - (interactive "P") - (run-hooks 'mh-before-send-letter-hook) - (set-buffer-modified-p t) ; Make sure buffer is written - (save-buffer) - (message "Sending...") - (let ((draft-buffer (current-buffer)) - (file-name (buffer-file-name)) - (config mh-previous-window-config)) - (cond (arg - (pop-to-buffer "MH mail delivery") - (erase-buffer) - (if mh-send-args - (mh-exec-cmd-output "send" t "-watch" "-nopush" - "-nodraftfolder" mh-send-args file-name) - (mh-exec-cmd-output "send" t "-watch" "-nopush" - "-nodraftfolder" file-name)) - (goto-char (point-max)) ; show the interesting part - (recenter -1) - (set-buffer draft-buffer)) ; for annotation below - (mh-send-args - (mh-exec-cmd-daemon "send" "-nodraftfolder" "-noverbose" - mh-send-args file-name)) - (t - (mh-exec-cmd-daemon "send" "-nodraftfolder" "-noverbose" - file-name))) - - (if mh-annotate-char - (mh-annotate-msg mh-sent-from-msg - mh-sent-from-folder - mh-annotate-char - "-component" mh-annotate-field - "-text" (format "\"%s %s\"" - (mh-get-field "To:") - (mh-get-field "Cc:")))) - - (mh-when (or (not arg) - (y-or-n-p "Kill draft buffer? ")) - (kill-buffer draft-buffer) - (if config - (set-window-configuration config))) - (message "Sending...done"))) - - -(defun mh-insert-letter (prefix-provided folder msg) - "Insert a message from any folder into the current letter. -Removes the message's headers using mh-invisible-headers. -Prefixes each non-blank line with mh-ins-buf-prefix (default \">> \"). -If optional prefix argument provided, do not indent and do not delete -headers. Leaves the mark before the letter and point after it." - (interactive - (list current-prefix-arg - (mh-prompt-for-folder "Message from" mh-sent-from-folder nil) - (read-input (format "Message number%s: " - (if mh-sent-from-msg - (format " [%d]" mh-sent-from-msg) - ""))))) - (save-restriction - (narrow-to-region (point) (point)) - (let ((start (point-min))) - (if (equal msg "") (setq msg (int-to-string mh-sent-from-msg))) - (mh-exec-lib-cmd-output "mhl" "-nobell" "-noclear" - (expand-file-name msg - (mh-expand-file-name folder))) - (mh-when (not prefix-provided) - (mh-clean-msg-header start mh-invisible-headers mh-visible-headers) - (set-mark start) ; since mh-clean-msg-header moves it - (mh-insert-prefix-string mh-ins-buf-prefix))))) - - -(defun mh-yank-cur-msg () - "Insert the current message into the draft buffer. -Prefix each non-blank line in the message with the string in -`mh-ins-buf-prefix'. If a region is set in the message's buffer, then -only the region will be inserted. Otherwise, the entire message will -be inserted if `mh-yank-from-start-of-msg' is non-nil. If this variable -is nil, the portion of the message following the point will be yanked. -If `mh-delete-yanked-msg-window' is non-nil, any window displaying the -yanked message will be deleted." - (interactive) - (if (and mh-sent-from-folder mh-sent-from-msg) - (let ((to-point (point)) - (to-buffer (current-buffer))) - (set-buffer mh-sent-from-folder) - (if mh-delete-yanked-msg-window - (delete-windows-on mh-show-buffer)) - (set-buffer mh-show-buffer) ; Find displayed message - (let ((mh-ins-str (cond (mark-active - (buffer-substring (region-beginning) - (region-end))) - ((eq 'body mh-yank-from-start-of-msg) - (buffer-substring - (save-excursion - (goto-char (point-min)) - (mh-goto-header-end 1) - (point)) - (point-max))) - (mh-yank-from-start-of-msg - (buffer-substring (point-min) (point-max))) - (t - (buffer-substring (point) (point-max)))))) - (set-buffer to-buffer) - (narrow-to-region to-point to-point) - (push-mark) - (insert mh-ins-str) - (mh-insert-prefix-string mh-ins-buf-prefix) - (insert "\n") - (widen))) - (error "There is no current message"))) - - -(defun mh-insert-prefix-string (mh-ins-string) - ;; Run MH-YANK-HOOK to insert a prefix string before each line in the buffer. - ;; Generality for supercite users. - (save-excursion - (set-mark (point-max)) - (goto-char (point-min)) - (run-hooks 'mh-yank-hooks))) - - -(defun mh-fully-kill-draft () - "Kill the draft message file and the draft message buffer. -Use \\[kill-buffer] if you don't want to delete the draft message file." - (interactive) - (if (y-or-n-p "Kill draft message? ") - (let ((config mh-previous-window-config)) - (if (file-exists-p (buffer-file-name)) - (delete-file (buffer-file-name))) - (set-buffer-modified-p nil) - (kill-buffer (buffer-name)) - (message "") - (if config - (set-window-configuration config))) - (error "Message not killed"))) - - -(defun mh-recenter (arg) - ;; Like recenter but with two improvements: nil arg means recenter, - ;; and only does anything if the current buffer is in the selected - ;; window. (Commands like save-some-buffers can make this false.) - (if (eql (get-buffer-window (current-buffer)) - (selected-window)) - (recenter (if arg arg '(t))))) - - - -;;; Commands to manipulate sequences. Sequences are stored in an alist -;;; of the form: -;;; ((seq-name msgs ...) (seq-name msgs ...) ...) - -(defun mh-make-seq (name msgs) (cons name msgs)) - -(defmacro mh-seq-name (pair) (list 'car pair)) - -(defmacro mh-seq-msgs (pair) (list 'cdr pair)) - -(defun mh-find-seq (name) (assoc name mh-seq-list)) - - -(defun mh-seq-to-msgs (seq) - "Return a list of the messages in SEQUENCE." - (mh-seq-msgs (mh-find-seq seq))) - - -(defun mh-seq-containing-msg (msg) - ;; Return a list of the sequences containing MESSAGE. - (let ((l mh-seq-list) - (seqs ())) - (while l - (if (memq msg (mh-seq-msgs (car l))) - (mh-push (mh-seq-name (car l)) seqs)) - (setq l (cdr l))) - seqs)) - - -(defun mh-msg-to-seq (msg) - ;; Given a MESSAGE number, return the first sequence in which it occurs. - (car (mh-seq-containing-msg msg))) - - -(defun mh-read-seq-default (prompt not-empty) - ;; Read and return sequence name with default narrowed or previous sequence. - (mh-read-seq prompt not-empty (or mh-narrowed-to-seq mh-previous-seq))) - - -(defun mh-read-seq (prompt not-empty &optional default) - ;; Read and return a sequence name. Prompt with PROMPT, raise an error - ;; if the sequence is empty and the NOT-EMPTY flag is non-nil, and supply - ;; an optional DEFAULT sequence. - ;; A reply of '%' defaults to the first sequence containing the current - ;; message. - (let* ((input (completing-read (format "%s %s %s" prompt "sequence:" - (if default - (format "[%s] " default) - "")) - (mh-seq-names mh-seq-list))) - (seq (cond ((equal input "%") (mh-msg-to-seq (mh-get-msg-num t))) - ((equal input "") default) - (t (intern input)))) - (msgs (mh-seq-to-msgs seq))) - (if (and (null msgs) not-empty) - (error (format "No messages in sequence `%s'" seq))) - seq)) - - -(defun mh-read-folder-sequences (folder define-sequences) - ;; Read and return the predefined sequences for a FOLDER. If - ;; DEFINE-SEQUENCES is non-nil, then define mh-e's sequences before - ;; reading MH's sequences. - (let ((seqs ())) - (mh-when define-sequences - (mh-define-sequences mh-seq-list) - (mh-mapc (function (lambda (seq) ; Save the internal sequences - (if (mh-folder-name-p (mh-seq-name seq)) - (mh-push seq seqs)))) - mh-seq-list)) - (save-excursion - (mh-exec-cmd-quiet " *mh-temp*" "mark" folder "-list") - (goto-char (point-min)) - ;; look for name in line of form "cur: 4" or "myseq (private): 23" - (while (re-search-forward "^[^: ]+" nil t) - (mh-push (mh-make-seq (intern (buffer-substring (match-beginning 0) - (match-end 0))) - (mh-read-msg-list)) - seqs)) - (delete-region (point-min) (point))) ; avoid race with mh-process-daemon - seqs)) - - -(defun mh-seq-names (seq-list) - ;; Return an alist containing the names of the SEQUENCES. - (mapcar (function (lambda (entry) (list (symbol-name (mh-seq-name entry))))) - seq-list)) - - -(defun mh-seq-from-command (folder seq seq-command) - ;; In FOLDER, make a sequence named SEQ by executing COMMAND. - ;; COMMAND is a list. The first element is a program name - ;; and the subsequent elements are its arguments, all strings. - (let ((msg) - (msgs ()) - (case-fold-search t)) - (save-excursion - (save-window-excursion - (apply 'mh-exec-cmd-quiet " *mh-temp*" seq-command) - (goto-char (point-min)) - (while (setq msg (car (mh-read-msg-list))) - (mh-push msg msgs) - (forward-line 1))) - (set-buffer folder) - (setq msgs (nreverse msgs)) ; Put in ascending order - (mh-push (mh-make-seq seq msgs) mh-seq-list) - msgs))) - - -(defun mh-read-msg-list () - ;; Return a list of message numbers from the current point to the end of - ;; the line. - (let ((msgs ()) - (end-of-line (save-excursion (end-of-line) (point))) - num) - (while (re-search-forward "[0-9]+" end-of-line t) - (setq num (string-to-int (buffer-substring (match-beginning 0) - (match-end 0)))) - (cond ((looking-at "-") ; Message range - (forward-char 1) - (re-search-forward "[0-9]+" end-of-line t) - (let ((num2 (string-to-int (buffer-substring (match-beginning 0) - (match-end 0))))) - (if (< num2 num) - (error "Bad message range: %d-%d" num num2)) - (while (<= num num2) - (mh-push num msgs) - (setq num (1+ num))))) - ((not (zerop num)) (mh-push num msgs)))) - msgs)) - - -(defun mh-remove-seq (seq) - ;; Delete the SEQUENCE. - (mh-map-to-seq-msgs 'mh-notate-if-in-one-seq seq ? (1+ mh-cmd-note) seq) - (mh-undefine-sequence seq (list "all")) - (mh-delete-seq-locally seq)) - - -(defun mh-delete-seq-locally (seq) - ;; Remove mh-e's record of SEQUENCE. - (let ((entry (mh-find-seq seq))) - (setq mh-seq-list (delq entry mh-seq-list)))) - - -(defun mh-remove-msg-from-seq (msg seq &optional internal-flag) - ;; Remove MESSAGE from the SEQUENCE. If optional FLAG is non-nil, do not - ;; inform MH of the change. - (let ((entry (mh-find-seq seq))) - (mh-when entry - (mh-notate-if-in-one-seq msg ? (1+ mh-cmd-note) (mh-seq-name entry)) - (if (not internal-flag) - (mh-undefine-sequence seq (list msg))) - (setcdr entry (delq msg (mh-seq-msgs entry)))))) - - -(defun mh-add-msgs-to-seq (msgs seq &optional internal-flag) - ;; Add MESSAGE(s) to the SEQUENCE. If optional FLAG is non-nil, do not mark - ;; the message in the scan listing or inform MH of the addition. - (let ((entry (mh-find-seq seq))) - (if (and msgs (atom msgs)) (setq msgs (list msgs))) - (if (null entry) - (mh-push (mh-make-seq seq msgs) mh-seq-list) - (if msgs (setcdr entry (append msgs (cdr entry))))) - (mh-when (not internal-flag) - (mh-add-to-sequence seq msgs) - (mh-notate-seq seq ?% (1+ mh-cmd-note))))) - - -(defun mh-rename-seq (seq new-name) - "Rename a SEQUENCE to have a new NAME." - (interactive "SOld sequence name: \nSNew name: ") - (let ((old-seq (mh-find-seq seq))) - (if old-seq - (rplaca old-seq new-name) - (error "Sequence %s does not exists" seq)) - (mh-undefine-sequence seq (mh-seq-msgs old-seq)) - (mh-define-sequence new-name (mh-seq-msgs old-seq)))) - - -(defun mh-notate-user-sequences () - ;; Mark the scan listing of all messages in user-defined sequences. - (let ((seqs mh-seq-list) - name) - (while seqs - (setq name (mh-seq-name (car seqs))) - (if (not (mh-internal-seq name)) - (mh-notate-seq name ?% (1+ mh-cmd-note))) - (setq seqs (cdr seqs))))) - - -(defun mh-internal-seq (name) - ;; Return non-NIL if NAME is the name of an internal mh-e sequence. - (or (memq name '(answered cur deleted forwarded printed)) - (eq name mh-unseen-seq) - (mh-folder-name-p name))) - - -(defun mh-folder-name-p (name) - ;; Return non-NIL if NAME is possibly the name of a folder. - ;; A name (a string or symbol) can be a folder name if it begins with "+". - (if (symbolp name) - (eql (aref (symbol-name name) 0) ?+) - (eql (aref name 0) ?+))) - - -(defun mh-notate-seq (seq notation offset) - ;; Mark the scan listing of all messages in the SEQUENCE with the CHARACTER - ;; at the given OFFSET from the beginning of the listing line. - (mh-map-to-seq-msgs 'mh-notate seq notation offset)) - - -(defun mh-notate-if-in-one-seq (msg notation offset seq) - ;; If the MESSAGE is in only the SEQUENCE, then mark the scan listing of the - ;; message with the CHARACTER at the given OFFSET from the beginning of the - ;; listing line. - (let ((in-seqs (mh-seq-containing-msg msg))) - (if (and (eq seq (car in-seqs)) (null (cdr in-seqs))) - (mh-notate msg notation offset)))) - - -(defun mh-map-to-seq-msgs (func seq &rest args) - ;; Invoke the FUNCTION at each message in the SEQUENCE, passing the - ;; remaining ARGS as arguments. - (save-excursion - (let ((msgs (mh-seq-to-msgs seq))) - (while msgs - (if (mh-goto-msg (car msgs) t t) - (apply func (car msgs) args)) - (setq msgs (cdr msgs)))))) - - -(defun mh-map-over-seqs (func seq-list) - ;; Apply the FUNCTION to each element in the list of SEQUENCES, - ;; passing the sequence name and the list of messages as arguments. - (while seq-list - (funcall func (mh-seq-name (car seq-list)) (mh-seq-msgs (car seq-list))) - (setq seq-list (cdr seq-list)))) - - -(defun mh-define-sequences (seq-list) - ;; Define the sequences in SEQ-LIST. - (mh-map-over-seqs 'mh-define-sequence seq-list)) - - -(defun mh-add-to-sequence (seq msgs) - ;; Add to a SEQUENCE each message the list of MSGS. - (if (not (mh-folder-name-p seq)) - (if msgs - (apply 'mh-exec-cmd "mark" mh-current-folder - "-sequence" (symbol-name seq) - "-add" msgs)))) - - -(defun mh-define-sequence (seq msgs) - ;; Define the SEQUENCE to contain the list of MSGS. Do not mark - ;; pseudo-sequences or empty sequences. - (if (and msgs - (not (mh-folder-name-p seq))) - (save-excursion - (apply 'mh-exec-cmd "mark" mh-current-folder - "-sequence" (symbol-name seq) - "-add" "-zero" (mh-list-to-string msgs))))) - - -(defun mh-undefine-sequence (seq msgs) - ;; Remove from the SEQUENCE the list of MSGS. - (apply 'mh-exec-cmd "mark" mh-current-folder - "-sequence" (symbol-name seq) - "-delete" msgs)) - - -(defun mh-copy-seq-to-point (seq location) - ;; Copy the scan listing of the messages in SEQUENCE to after the point - ;; LOCATION in the current buffer. - (mh-map-to-seq-msgs 'mh-copy-line-to-point seq location)) - - -(defun mh-copy-line-to-point (msg location) - ;; Copy the current line to the LOCATION in the current buffer. - (beginning-of-line) - (let ((beginning-of-line (point))) - (forward-line 1) - (copy-region-as-kill beginning-of-line (point)) - (goto-char location) - (yank) - (goto-char beginning-of-line))) - - - -;;; Issue commands to MH. - -(defun mh-exec-cmd (command &rest args) - ;; Execute MH command COMMAND with ARGS. - ;; Any output is assumed to be an error and is shown to the user. - (save-excursion - (set-buffer " *mh-temp*") - (erase-buffer) - (apply 'call-process - (expand-file-name command mh-progs) nil t nil - (mh-list-to-string args)) - (if (> (buffer-size) 0) - (save-window-excursion - (switch-to-buffer-other-window " *mh-temp*") - (sit-for 5))))) - - -(defun mh-exec-cmd-quiet (buffer command &rest args) - ;; In BUFFER, execute MH command COMMAND with ARGS. - ;; ARGS is a list of strings. Return in BUFFER, if one exists. - (mh-when (stringp buffer) - (set-buffer buffer) - (erase-buffer)) - (apply 'call-process - (expand-file-name command mh-progs) nil buffer nil - args)) - - -(defun mh-exec-cmd-output (command display &rest args) - ;; Execute MH command COMMAND with DISPLAY flag and ARGS putting the output - ;; into buffer after point. Set mark after inserted text. - (push-mark (point) t) - (apply 'call-process - (expand-file-name command mh-progs) nil t display - (mh-list-to-string args)) - (exchange-point-and-mark)) - - -(defun mh-exec-cmd-daemon (command &rest args) - ;; Execute MH command COMMAND with ARGS. Any output from command is - ;; displayed in an asynchronous pop-up window. - (save-excursion - (set-buffer (get-buffer-create " *mh-temp*")) - (erase-buffer)) - (let* ((process-connection-type nil) - (process (apply 'start-process - command nil - (expand-file-name command mh-progs) - (mh-list-to-string args)))) - (set-process-filter process 'mh-process-daemon))) - - -(defun mh-process-daemon (process output) - ;; Process daemon that puts output into a temporary buffer. - (set-buffer (get-buffer-create " *mh-temp*")) - (insert-before-markers output) - (display-buffer " *mh-temp*")) - - -(defun mh-exec-lib-cmd-output (command &rest args) - ;; Execute MH library command COMMAND with ARGS. - ;; Put the output into buffer after point. Set mark after inserted text. - (push-mark (point) t) - (apply 'call-process - (expand-file-name command mh-lib) nil t nil - (mh-list-to-string args)) - (exchange-point-and-mark)) - - -(defun mh-list-to-string (l) - ;; Flattens the list L and makes every element of the new list into a string. - (let ((new-list nil)) - (while l - (cond ((null (car l))) - ((symbolp (car l)) (mh-push (symbol-name (car l)) new-list)) - ((numberp (car l)) (mh-push (int-to-string (car l)) new-list)) - ((equal (car l) "")) - ((stringp (car l)) (mh-push (car l) new-list)) - ((listp (car l)) - (setq new-list (nconc (nreverse (mh-list-to-string (car l))) - new-list))) - (t (error "Bad element in mh-list-to-string: %s" (car l)))) - (setq l (cdr l))) - (nreverse new-list))) - - - -;;; Commands to annotate a message. - -(defun mh-annotate-msg (msg buffer note &rest args) - ;; Mark the MESSAGE in BUFFER listing with the character NOTE and annotate - ;; the saved message with ARGS. - (apply 'mh-exec-cmd "anno" buffer msg args) - (save-excursion - (cond ((get-buffer buffer) ; Buffer may be deleted - (set-buffer buffer) - (if (symbolp msg) - (mh-notate-seq msg note (1+ mh-cmd-note)) - (mh-notate msg note (1+ mh-cmd-note))))))) - - -(defun mh-notate (msg notation offset) - ;; Marks MESSAGE with the character NOTATION at position OFFSET. - ;; Null MESSAGE means the message that the cursor points to. - (save-excursion - (if (or (null msg) - (mh-goto-msg msg t t)) - (with-mh-folder-updating (t) - (beginning-of-line) - (forward-char offset) - (delete-char 1) - (insert notation))))) - - - -;;; User prompting commands. - -(defun mh-prompt-for-folder (prompt default can-create) - ;; Prompt for a folder name with PROMPT. Returns the folder's name as a - ;; string. DEFAULT is used if the folder exists and the user types return. - ;; If the CAN-CREATE flag is t, then a non-existent folder is made. - (let* ((prompt (format "%s folder%s" prompt - (if (equal "" default) - "? " - (format " [%s]? " default)))) - name) - (if (null mh-folder-list) - (mh-set-folder-list)) - (while (and (setq name (completing-read prompt mh-folder-list - nil nil "+")) - (equal name "") - (equal default ""))) - (cond ((or (equal name "") (equal name "+")) - (setq name default)) - ((not (mh-folder-name-p name)) - (setq name (format "+%s" name)))) - (let ((new-file-p (not (file-exists-p (mh-expand-file-name name))))) - (cond ((and new-file-p - (y-or-n-p - (format "Folder %s does not exist. Create it? " name))) - (message "Creating %s" name) - (call-process "mkdir" nil nil nil (mh-expand-file-name name)) - (message "Creating %s...done" name) - (mh-push (list name) mh-folder-list)) - (new-file-p - (error "Folder %s is not created" name)) - (t - (mh-when (null (assoc name mh-folder-list)) - (mh-push (list name) mh-folder-list))))) - name)) - - -(defun mh-set-folder-list () - "Sets mh-folder-list correctly. -A useful function for the command line or for when you need to sync by hand." - (setq mh-folder-list (mh-make-folder-list))) - - -(defun mh-make-folder-list () - "Return a list of the user's folders. -Result is in a form suitable for completing read." - (interactive) - (message "Collecting folder names...") - (save-window-excursion - (mh-exec-cmd-quiet " *mh-temp*" "folders" "-fast" - (if mh-recursive-folders - "-recurse" - "-norecurse")) - (goto-char (point-min)) - (let ((list nil) - start) - (while (not (eobp)) - (setq start (point)) - (forward-line 1) - (mh-push (list (format "+%s" (buffer-substring start (1- (point))))) - list)) - (message "Collecting folder names...done") - list))) - - -(defun mh-remove-folder-from-folder-list (folder) - ;; Remove FOLDER from the list of folders. - (setq mh-folder-list - (delq (assoc folder mh-folder-list) mh-folder-list))) - - -(defun mh-read-msg-range (prompt) - ;; Read a list of blank-separated items. - (let* ((buf (read-string prompt)) - (buf-size (length buf)) - (start 0) - (input ())) - (while (< start buf-size) - (let ((next (read-from-string buf start buf-size))) - (mh-push (car next) input) - (setq start (cdr next)))) - (nreverse input))) - - - -;;; Misc. functions. - -(defun mh-get-msg-num (error-if-no-message) - ;; Return the message number of the displayed message. If the argument - ;; ERROR-IF-NO-MESSAGE is non-nil, then complain if the cursor is not - ;; pointing to a message. - (save-excursion - (beginning-of-line) - (cond ((looking-at mh-msg-number-regexp) - (string-to-int (buffer-substring (match-beginning 1) - (match-end 1)))) - (error-if-no-message - (error "Cursor not pointing to message")) - (t nil)))) - - -(defun mh-msg-search-pat (n) - ;; Return a search pattern for message N in the scan listing. - (format mh-msg-search-regexp n)) - - -(defun mh-msg-filename (msg &optional folder) - ;; Return the file name of MESSAGE in FOLDER (default current folder). - (expand-file-name (int-to-string msg) - (if folder - (mh-expand-file-name folder) - mh-folder-filename))) - - -(defun mh-msg-filenames (msgs &optional folder) - ;; Return a list of file names for MSGS in FOLDER (default current folder). - (mapconcat (function (lambda (msg) (mh-msg-filename msg folder))) msgs " ")) - - -(defun mh-expand-file-name (filename &optional default) - "Just like `expand-file-name', but also handles MH folder names. -Assumes that any filename that starts with '+' is a folder name." - (if (mh-folder-name-p filename) - (expand-file-name (substring filename 1) mh-user-path) - (expand-file-name filename default))) - - -(defun mh-find-path () - ;; Set mh-user-path, mh-draft-folder, and mh-unseen-seq from profile file. - (save-excursion - ;; Be sure profile is fully expanded before switching buffers - (let ((profile (expand-file-name (or (getenv "MH") "~/.mh_profile")))) - (if (not (file-exists-p profile)) - (error "Cannot find MH profile %s" profile)) - (set-buffer (get-buffer-create " *mh-temp*")) - (erase-buffer) - (insert-file-contents profile) - (setq mh-draft-folder (mh-get-field "Draft-Folder:")) - (cond ((equal mh-draft-folder "") - (setq mh-draft-folder nil)) - ((not (mh-folder-name-p mh-draft-folder)) - (setq mh-draft-folder (format "+%s" mh-draft-folder)))) - (setq mh-user-path (mh-get-field "Path:")) - (if (equal mh-user-path "") - (setq mh-user-path "Mail")) - (setq mh-user-path - (file-name-as-directory - (expand-file-name mh-user-path (expand-file-name "~")))) - (if (and mh-draft-folder - (not (file-exists-p (mh-expand-file-name mh-draft-folder)))) - (error "Draft folder %s does not exist. Create it and try again." - mh-draft-folder)) - (setq mh-unseen-seq (mh-get-field "Unseen-Sequence:")) - (if (equal mh-unseen-seq "") - (setq mh-unseen-seq 'unseen) - (setq mh-unseen-seq (intern mh-unseen-seq)))))) - - -(defun mh-get-field (field) - ;; Find and return the value of field FIELD in the current buffer. - ;; Returns the empty string if the field is not in the message. - (let ((case-fold-search t)) - (goto-char (point-min)) - (cond ((not (re-search-forward (format "^%s" field) nil t)) "") - ((looking-at "[\t ]*$") "") - (t - (re-search-forward "[\t ]*\\([^\t \n].*\\)$" nil t) - (let ((start (match-beginning 1))) - (forward-line 1) - (while (looking-at "[ \t]") - (forward-line 1)) - (buffer-substring start (1- (point)))))))) - - -(defun mh-insert-fields (&rest name-values) - ;; Insert the NAME-VALUE pairs in the current buffer. - ;; Do not insert any pairs whose value is the empty string. - (let ((case-fold-search t)) - (while name-values - (let ((field-name (car name-values)) - (value (car (cdr name-values)))) - (mh-when (not (equal value "")) - (goto-char (point-min)) - (cond ((not (re-search-forward (format "^%s" field-name) nil t)) - (mh-goto-header-end 0) - (insert field-name " " value "\n")) - (t - (end-of-line) - (insert " " value)))) - (setq name-values (cdr (cdr name-values))))))) - - -(defun mh-position-on-field (field set-mark) - ;; Set point to the end of the line beginning with FIELD. - ;; Set the mark to the old value of point, if SET-MARK is non-nil. - ;; Returns non-nil iff the field was found. - (let ((case-fold-search t)) - (if set-mark (push-mark)) - (goto-char (point-min)) - (mh-goto-header-end 0) - (if (re-search-backward (format "^%s" field) nil t) - (progn (end-of-line) t) - nil))) - - -(defun mh-goto-header-end (arg) - ;; Find the end of the message header in the current buffer and position - ;; the cursor at the ARG'th newline after the header. - (if (re-search-forward "^$\\|^-+$" nil nil) - (forward-line arg))) - - - -;;; Build the folder-mode keymap: - -(suppress-keymap mh-folder-mode-map) -(define-key mh-folder-mode-map "q" 'mh-quit) -(define-key mh-folder-mode-map "b" 'mh-quit) -(define-key mh-folder-mode-map "?" 'mh-msg-is-in-seq) -(define-key mh-folder-mode-map "%" 'mh-put-msg-in-seq) -(define-key mh-folder-mode-map "|" 'mh-pipe-msg) -(define-key mh-folder-mode-map "\ea" 'mh-edit-again) -(define-key mh-folder-mode-map "\e%" 'mh-delete-msg-from-seq) -(define-key mh-folder-mode-map "\C-xn" 'mh-narrow-to-seq) -(define-key mh-folder-mode-map "\C-xw" 'mh-widen) -(define-key mh-folder-mode-map "\eb" 'mh-burst-digest) -(define-key mh-folder-mode-map "\eu" 'mh-undo-folder) -(define-key mh-folder-mode-map "\e " 'mh-page-digest) -(define-key mh-folder-mode-map "\e\177" 'mh-page-digest-backwards) -(define-key mh-folder-mode-map "\ee" 'mh-extract-rejected-mail) -(define-key mh-folder-mode-map "\ef" 'mh-visit-folder) -(define-key mh-folder-mode-map "\ek" 'mh-kill-folder) -(define-key mh-folder-mode-map "\el" 'mh-list-folders) -(define-key mh-folder-mode-map "\en" 'mh-unshar-msg) -(define-key mh-folder-mode-map "\eo" 'mh-write-msg-to-file) -(define-key mh-folder-mode-map "\ep" 'mh-pack-folder) -(define-key mh-folder-mode-map "\es" 'mh-search-folder) -(define-key mh-folder-mode-map "\er" 'mh-rescan-folder) -(define-key mh-folder-mode-map "l" 'mh-print-msg) -(define-key mh-folder-mode-map "t" 'mh-toggle-showing) -(define-key mh-folder-mode-map "c" 'mh-copy-msg) -(define-key mh-folder-mode-map ">" 'mh-write-msg-to-file) -(define-key mh-folder-mode-map "i" 'mh-inc-folder) -(define-key mh-folder-mode-map "x" 'mh-execute-commands) -(define-key mh-folder-mode-map "e" 'mh-execute-commands) -(define-key mh-folder-mode-map "r" 'mh-redistribute) -(define-key mh-folder-mode-map "f" 'mh-forward) -(define-key mh-folder-mode-map "s" 'mh-send) -(define-key mh-folder-mode-map "m" 'mh-send) -(define-key mh-folder-mode-map "a" 'mh-reply) -(define-key mh-folder-mode-map "j" 'mh-goto-msg) -(define-key mh-folder-mode-map "<" 'mh-first-msg) -(define-key mh-folder-mode-map "g" 'mh-goto-msg) -(define-key mh-folder-mode-map "\177" 'mh-previous-page) -(define-key mh-folder-mode-map " " 'mh-page-msg) -(define-key mh-folder-mode-map "." 'mh-show) -(define-key mh-folder-mode-map "u" 'mh-undo) -(define-key mh-folder-mode-map "!" 'mh-refile-or-write-again) -(define-key mh-folder-mode-map "^" 'mh-refile-msg) -(define-key mh-folder-mode-map "d" 'mh-delete-msg) -(define-key mh-folder-mode-map "\C-d" 'mh-delete-msg-no-motion) -(define-key mh-folder-mode-map "p" 'mh-previous-undeleted-msg) -(define-key mh-folder-mode-map "n" 'mh-next-undeleted-msg) -(define-key mh-folder-mode-map "o" 'mh-refile-msg) - - -;;; Build the letter-mode keymap: - -(define-key mh-letter-mode-map "\C-c\C-f\C-b" 'mh-to-field) -(define-key mh-letter-mode-map "\C-c\C-f\C-c" 'mh-to-field) -(define-key mh-letter-mode-map "\C-c\C-f\C-f" 'mh-to-fcc) -(define-key mh-letter-mode-map "\C-c\C-f\C-s" 'mh-to-field) -(define-key mh-letter-mode-map "\C-c\C-f\C-t" 'mh-to-field) -(define-key mh-letter-mode-map "\C-c\C-fb" 'mh-to-field) -(define-key mh-letter-mode-map "\C-c\C-fc" 'mh-to-field) -(define-key mh-letter-mode-map "\C-c\C-ff" 'mh-to-fcc) -(define-key mh-letter-mode-map "\C-c\C-fs" 'mh-to-field) -(define-key mh-letter-mode-map "\C-c\C-ft" 'mh-to-field) -(define-key mh-letter-mode-map "\C-c\C-q" 'mh-fully-kill-draft) -(define-key mh-letter-mode-map "\C-c\C-w" 'mh-check-whom) -(define-key mh-letter-mode-map "\C-c\C-i" 'mh-insert-letter) -(define-key mh-letter-mode-map "\C-c\C-y" 'mh-yank-cur-msg) -(define-key mh-letter-mode-map "\C-c\C-s" 'mh-insert-signature) -(define-key mh-letter-mode-map "\C-c\C-c" 'mh-send-letter) - - -;;; Build the pick-mode keymap: - -(define-key mh-pick-mode-map "\C-c\C-c" 'mh-do-pick-search) -(define-key mh-pick-mode-map "\C-c\C-f\C-b" 'mh-to-field) -(define-key mh-pick-mode-map "\C-c\C-f\C-c" 'mh-to-field) -(define-key mh-pick-mode-map "\C-c\C-f\C-f" 'mh-to-field) -(define-key mh-pick-mode-map "\C-c\C-f\C-s" 'mh-to-field) -(define-key mh-pick-mode-map "\C-c\C-f\C-t" 'mh-to-field) -(define-key mh-pick-mode-map "\C-c\C-fb" 'mh-to-field) -(define-key mh-pick-mode-map "\C-c\C-fc" 'mh-to-field) -(define-key mh-pick-mode-map "\C-c\C-ff" 'mh-to-field) -(define-key mh-pick-mode-map "\C-c\C-fs" 'mh-to-field) -(define-key mh-pick-mode-map "\C-c\C-ft" 'mh-to-field) -(define-key mh-pick-mode-map "\C-c\C-w" 'mh-check-whom) - - - -;;; For Gnu Emacs. -;;; Local Variables: *** -;;; eval: (put 'mh-when 'lisp-indent-hook 1) *** -;;; eval: (put 'with-mh-folder-updating 'lisp-indent-hook 1) *** -;;; End: *** - -(provide 'mh-e) - -;;; mh-e.el ends here diff --git a/lisp/mhspool.el b/lisp/mhspool.el deleted file mode 100644 index b81823938f0..00000000000 --- a/lisp/mhspool.el +++ /dev/null @@ -1,490 +0,0 @@ -;;; mhspool.el --- MH folder access using NNTP for GNU Emacs - -;; Copyright (C) 1988, 1989, 1990, 1993 Free Software Foundation, Inc. - -;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> -;; 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, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; Commentary: - -;; This package enables you to read mail or articles in MH folders, or -;; articles saved by GNUS. In any case, the file names of mail or -;; articles must consist of only numeric letters. - -;; Before using this package, you have to create a server specific -;; startup file according to the directory which you want to read. For -;; example, if you want to read mail under the directory named -;; `~/Mail', the file must be a file named `.newsrc-:Mail'. (There is -;; no way to specify hierarchical directory now.) In this case, the -;; name of the NNTP server passed to GNUS must be `:Mail'. - -;;; Code: - -(require 'nntp) - -(defvar mhspool-list-folders-method - (function mhspool-list-folders-using-sh) - "*Function to list files in folders. -The function should accept a directory as its argument, and fill the -current buffer with file and directory names. The output format must -be the same as that of 'ls -R1'. Two functions -mhspool-list-folders-using-ls and mhspool-list-folders-using-sh are -provided now. I suppose the later is faster.") - -(defvar mhspool-list-directory-switches '("-R") - "*Switches for mhspool-list-folders-using-ls to pass to `ls' for getting file lists. -One entry should appear on one line. You may need to add `-1' option.") - - - -(defconst mhspool-version "MHSPOOL 1.8" - "Version numbers of this version of MHSPOOL.") - -(defvar mhspool-spool-directory "~/Mail" - "Private mail directory.") - -(defvar mhspool-current-directory nil - "Current news group directory.") - -;;; -;;; Replacement of Extended Command for retrieving many headers. -;;; - -(defun mhspool-retrieve-headers (sequence) - "Return list of article headers specified by SEQUENCE of article id. -The format of list is - `([NUMBER SUBJECT FROM XREF LINES DATE MESSAGE-ID REFERENCES] ...)'. -If there is no References: field, In-Reply-To: field is used instead. -Reader macros for the vector are defined as `nntp-header-FIELD'. -Writer macros for the vector are defined as `nntp-set-header-FIELD'. -Newsgroup must be selected before calling this." - (save-excursion - (set-buffer nntp-server-buffer) - ;;(erase-buffer) - (let ((file nil) - (number (length sequence)) - (count 0) - (headers nil) ;Result list. - (article 0) - (subject nil) - (message-id nil) - (from nil) - (xref nil) - (lines 0) - (date nil) - (references nil)) - (while sequence - ;;(nntp-send-strings-to-server "HEAD" (car sequence)) - (setq article (car sequence)) - (setq file - (concat mhspool-current-directory (prin1-to-string article))) - (if (and (file-exists-p file) - (not (file-directory-p file))) - (progn - (erase-buffer) - (insert-file-contents file) - ;; Make message body invisible. - (goto-char (point-min)) - (search-forward "\n\n" nil 'move) - (narrow-to-region (point-min) (point)) - ;; Fold continuation lines. - (goto-char (point-min)) - (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t) - (replace-match " " t t)) - ;; Make it possible to search for `\nFIELD'. - (goto-char (point-min)) - (insert "\n") - ;; Extract From: - (goto-char (point-min)) - (if (search-forward "\nFrom: " nil t) - (setq from (buffer-substring - (point) - (save-excursion (end-of-line) (point)))) - (setq from "(Unknown User)")) - ;; Extract Subject: - (goto-char (point-min)) - (if (search-forward "\nSubject: " nil t) - (setq subject (buffer-substring - (point) - (save-excursion (end-of-line) (point)))) - (setq subject "(None)")) - ;; Extract Message-ID: - (goto-char (point-min)) - (if (search-forward "\nMessage-ID: " nil t) - (setq message-id (buffer-substring - (point) - (save-excursion (end-of-line) (point)))) - (setq message-id nil)) - ;; Extract Date: - (goto-char (point-min)) - (if (search-forward "\nDate: " nil t) - (setq date (buffer-substring - (point) - (save-excursion (end-of-line) (point)))) - (setq date nil)) - ;; Extract Lines: - (goto-char (point-min)) - (if (search-forward "\nLines: " nil t) - (setq lines (string-to-int - (buffer-substring - (point) - (save-excursion (end-of-line) (point))))) - ;; Count lines since there is no lines field in most cases. - (setq lines - (save-restriction - (goto-char (point-max)) - (widen) - (count-lines (point) (point-max))))) - ;; Extract Xref: - (goto-char (point-min)) - (if (search-forward "\nXref: " nil t) - (setq xref (buffer-substring - (point) - (save-excursion (end-of-line) (point)))) - (setq xref nil)) - ;; Extract References: - ;; If no References: field, use In-Reply-To: field instead. - ;; Suggested by tanaka@flab.fujitsu.co.jp (Hiroshi TANAKA). - (goto-char (point-min)) - (if (or (search-forward "\nReferences: " nil t) - (search-forward "\nIn-Reply-To: " nil t)) - (setq references (buffer-substring - (point) - (save-excursion (end-of-line) (point)))) - (setq references nil)) - ;; Collect valid article only. - (and article - message-id - (setq headers - (cons (vector article subject from - xref lines date - message-id references) headers))) - )) - (setq sequence (cdr sequence)) - (setq count (1+ count)) - (and (numberp nntp-large-newsgroup) - (> number nntp-large-newsgroup) - (zerop (% count 20)) - (message "MHSPOOL: Receiving headers... %d%%" - (/ (* count 100) number))) - ) - (and (numberp nntp-large-newsgroup) - (> number nntp-large-newsgroup) - (message "MHSPOOL: Receiving headers... done")) - (nreverse headers) - ))) - - -;;; -;;; Replacement of NNTP Raw Interface. -;;; - -(defun mhspool-open-server (host &optional service) - "Open news server on HOST. -If HOST is nil, use value of environment variable `NNTPSERVER'. -If optional argument SERVICE is non-nil, open by the service name." - (let ((host (or host (getenv "NNTPSERVER"))) - (status nil)) - ;; Get directory name from HOST name. - (if (string-match ":\\(.+\\)$" host) - (progn - (setq mhspool-spool-directory - (file-name-as-directory - (expand-file-name - (substring host (match-beginning 1) (match-end 1)) - (expand-file-name "~/" nil)))) - (setq host (system-name))) - (setq mhspool-spool-directory nil)) - (setq nntp-status-string "") - (cond ((and (stringp host) - (stringp mhspool-spool-directory) - (file-directory-p mhspool-spool-directory) - (string-equal host (system-name))) - (setq status (mhspool-open-server-internal host service))) - ((string-equal host (system-name)) - (setq nntp-status-string - (format "No such directory: %s. Goodbye." - mhspool-spool-directory))) - ((null host) - (setq nntp-status-string "NNTP server is not specified.")) - (t - (setq nntp-status-string - (format "MHSPOOL: cannot talk to %s." host))) - ) - status - )) - -(defun mhspool-close-server () - "Close news server." - (mhspool-close-server-internal)) - -(fset 'mhspool-request-quit (symbol-function 'mhspool-close-server)) - -(defun mhspool-server-opened () - "Return server process status, T or NIL. -If the stream is opened, return T, otherwise return NIL." - (and nntp-server-buffer - (get-buffer nntp-server-buffer))) - -(defun mhspool-status-message () - "Return server status response as string." - nntp-status-string - ) - -(defun mhspool-request-article (id) - "Select article by message ID (or number)." - (let ((file (concat mhspool-current-directory (prin1-to-string id)))) - (if (and (stringp file) - (file-exists-p file) - (not (file-directory-p file))) - (save-excursion - (mhspool-find-file file))) - )) - -(defun mhspool-request-body (id) - "Select article body by message ID (or number)." - (if (mhspool-request-article id) - (save-excursion - (set-buffer nntp-server-buffer) - (goto-char (point-min)) - (if (search-forward "\n\n" nil t) - (delete-region (point-min) (point))) - t - ) - )) - -(defun mhspool-request-head (id) - "Select article head by message ID (or number)." - (if (mhspool-request-article id) - (save-excursion - (set-buffer nntp-server-buffer) - (goto-char (point-min)) - (if (search-forward "\n\n" nil t) - (delete-region (1- (point)) (point-max))) - t - ) - )) - -(defun mhspool-request-stat (id) - "Select article by message ID (or number)." - (setq nntp-status-string "MHSPOOL: STAT is not implemented.") - nil - ) - -(defun mhspool-request-group (group) - "Select news GROUP." - (cond ((file-directory-p - (mhspool-article-pathname group)) - ;; Mail/NEWS.GROUP/N - (setq mhspool-current-directory - (mhspool-article-pathname group))) - ((file-directory-p - (mhspool-article-pathname - (mhspool-replace-chars-in-string group ?. ?/))) - ;; Mail/NEWS/GROUP/N - (setq mhspool-current-directory - (mhspool-article-pathname - (mhspool-replace-chars-in-string group ?. ?/)))) - )) - -(defun mhspool-request-list () - "List active newsgoups." - (save-excursion - (let* ((newsgroup nil) - (articles nil) - (directory (file-name-as-directory - (expand-file-name mhspool-spool-directory nil))) - (folder-regexp (concat "^" (regexp-quote directory) "\\(.+\\):$")) - (buffer (get-buffer-create " *MHSPOOL File List*"))) - (set-buffer nntp-server-buffer) - (erase-buffer) - (set-buffer buffer) - (erase-buffer) -;; (apply 'call-process -;; "ls" nil t nil -;; (append mhspool-list-directory-switches (list directory))) - (funcall mhspool-list-folders-method directory) - (goto-char (point-min)) - (while (re-search-forward folder-regexp nil t) - (setq newsgroup - (mhspool-replace-chars-in-string - (buffer-substring (match-beginning 1) (match-end 1)) ?/ ?.)) - (setq articles nil) - (forward-line 1) ;(beginning-of-line) - ;; Thank nobu@flab.fujitsu.junet for his bug fixes. - (while (and (not (eobp)) - (not (looking-at "^$"))) - (if (looking-at "^[0-9]+$") - (setq articles - (cons (string-to-int - (buffer-substring - (match-beginning 0) (match-end 0))) - articles))) - (forward-line 1)) - (if articles - (princ (format "%s %d %d n\n" newsgroup - (apply (function max) articles) - (apply (function min) articles)) - nntp-server-buffer)) - ) - (kill-buffer buffer) - (set-buffer nntp-server-buffer) - (buffer-size) - ))) - -(defun mhspool-request-list-newsgroups () - "List newsgoups (defined in NNTP2)." - (setq nntp-status-string "MHSPOOL: LIST NEWSGROUPS is not implemented.") - nil - ) - -(defun mhspool-request-list-distributions () - "List distributions (defined in NNTP2)." - (setq nntp-status-string "MHSPOOL: LIST DISTRIBUTIONS is not implemented.") - nil - ) - -(defun mhspool-request-last () - "Set current article pointer to the previous article -in the current news group." - (setq nntp-status-string "MHSPOOL: LAST is not implemented.") - nil - ) - -(defun mhspool-request-next () - "Advance current article pointer." - (setq nntp-status-string "MHSPOOL: NEXT is not implemented.") - nil - ) - -(defun mhspool-request-post () - "Post a new news in current buffer." - (setq nntp-status-string "MHSPOOL: POST: what do you mean?") - nil - ) - - -;;; -;;; Replacement of Low-Level Interface to NNTP Server. -;;; - -(defun mhspool-open-server-internal (host &optional service) - "Open connection to news server on HOST by SERVICE (default is nntp)." - (save-excursion - (if (not (string-equal host (system-name))) - (error "MHSPOOL: cannot talk to %s." host)) - ;; Initialize communication buffer. - (setq nntp-server-buffer (get-buffer-create " *nntpd*")) - (set-buffer nntp-server-buffer) - (buffer-flush-undo (current-buffer)) - (erase-buffer) - (kill-all-local-variables) - (setq case-fold-search t) ;Should ignore case. - (setq nntp-server-process nil) - (setq nntp-server-name host) - ;; It is possible to change kanji-fileio-code in this hook. - (run-hooks 'nntp-server-hook) - t - )) - -(defun mhspool-close-server-internal () - "Close connection to news server." - (if nntp-server-buffer - (kill-buffer nntp-server-buffer)) - (setq nntp-server-buffer nil) - (setq nntp-server-process nil)) - -(defun mhspool-find-file (file) - "Insert FILE in server buffer safely." - (set-buffer nntp-server-buffer) - (erase-buffer) - (condition-case () - (progn - (insert-file-contents file) - (goto-char (point-min)) - ;; If there is no body, `^L' appears at end of file. Special - ;; hack for MH folder. - (and (search-forward "\n\n" nil t) - (string-equal (buffer-substring (point) (point-max)) "\^L") - (delete-char 1)) - t - ) - (file-error nil) - )) - -(defun mhspool-article-pathname (group) - "Make pathname for GROUP." - (concat (file-name-as-directory mhspool-spool-directory) group "/")) - -(defun mhspool-replace-chars-in-string (string from to) - "Replace characters in STRING from FROM to TO." - (let ((string (substring string 0)) ;Copy string. - (len (length string)) - (idx 0)) - ;; Replace all occurrences of FROM with TO. - (while (< idx len) - (if (= (aref string idx) from) - (aset string idx to)) - (setq idx (1+ idx))) - string - )) - - -;; Methods for listing files in folders. - -(defun mhspool-list-folders-using-ls (directory) - "List files in folders under DIRECTORY using 'ls'." - (apply 'call-process - "ls" nil t nil - (append mhspool-list-directory-switches (list directory)))) - -;; Basic ideas by tanaka@flab.fujitsu.co.jp (Hiroshi TANAKA) - -(defun mhspool-list-folders-using-sh (directory) - "List files in folders under DIRECTORY using '/bin/sh'." - (let ((buffer (current-buffer)) - (script (get-buffer-create " *MHSPOOL Shell Script Buffer*"))) - (save-excursion - (save-restriction - (set-buffer script) - (erase-buffer) - ;; /bin/sh script which does 'ls -R'. - (insert - "PS2= - ffind() { - cd $1; echo $1: - ls -1 - echo - for j in `echo *[a-zA-Z]*` - do - if [ -d $1/$j ]; then - ffind $1/$j - fi - done - } - cd " directory "; ffind `pwd`; exit 0\n") - (call-process-region (point-min) (point-max) "sh" nil buffer nil) - )) - (kill-buffer script) - )) - -(provide 'mhspool) - -;;; mhspool.el ends here diff --git a/lisp/mim-mode.el b/lisp/mim-mode.el deleted file mode 100644 index 94e63cb9f48..00000000000 --- a/lisp/mim-mode.el +++ /dev/null @@ -1,848 +0,0 @@ -;;; mim-mode.el --- Mim (MDL in MDL) mode. - -;; Copyright (C) 1985 Free Software Foundation, Inc. - -;; Author: K. Shane Hartman -;; Maintainer: FSF -;; Keywords: languages - -;; 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, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; Code: - -(autoload 'fast-syntax-check-mim "mim-syntax" - "Checks Mim syntax quickly. -Answers correct or incorrect, cannot point out the error context." - t) - -(autoload 'slow-syntax-check-mim "mim-syntax" - "Check Mim syntax slowly. -Points out the context of the error, if the syntax is incorrect." - t) - -(defvar mim-mode-hysterical-bindings t - "*Non-nil means bind list manipulation commands to Meta keys as well as -Control-Meta keys for historical reasons. Otherwise, only the latter keys -are bound.") - -(defvar mim-mode-map nil) - -(defvar mim-mode-syntax-table nil) - -(if mim-mode-syntax-table - () - (let ((i -1)) - (setq mim-mode-syntax-table (make-syntax-table)) - (while (< i ?\ ) - (modify-syntax-entry (setq i (1+ i)) " " mim-mode-syntax-table)) - (while (< i 127) - (modify-syntax-entry (setq i (1+ i)) "_ " mim-mode-syntax-table)) - (setq i (1- ?a)) - (while (< i ?z) - (modify-syntax-entry (setq i (1+ i)) "w " mim-mode-syntax-table)) - (setq i (1- ?A)) - (while (< i ?Z) - (modify-syntax-entry (setq i (1+ i)) "w " mim-mode-syntax-table)) - (setq i (1- ?0)) - (while (< i ?9) - (modify-syntax-entry (setq i (1+ i)) "w " mim-mode-syntax-table)) - (modify-syntax-entry ?: " " mim-mode-syntax-table) ; make : symbol delimiter - (modify-syntax-entry ?, "' " mim-mode-syntax-table) - (modify-syntax-entry ?. "' " mim-mode-syntax-table) - (modify-syntax-entry ?' "' " mim-mode-syntax-table) - (modify-syntax-entry ?` "' " mim-mode-syntax-table) - (modify-syntax-entry ?~ "' " mim-mode-syntax-table) - (modify-syntax-entry ?\; "' " mim-mode-syntax-table) ; comments are prefixed objects - (modify-syntax-entry ?# "' " mim-mode-syntax-table) - (modify-syntax-entry ?% "' " mim-mode-syntax-table) - (modify-syntax-entry ?! "' " mim-mode-syntax-table) - (modify-syntax-entry ?\" "\" " mim-mode-syntax-table) - (modify-syntax-entry ?\\ "\\ " mim-mode-syntax-table) - (modify-syntax-entry ?\( "\() " mim-mode-syntax-table) - (modify-syntax-entry ?\< "\(> " mim-mode-syntax-table) - (modify-syntax-entry ?\{ "\(} " mim-mode-syntax-table) - (modify-syntax-entry ?\[ "\(] " mim-mode-syntax-table) - (modify-syntax-entry ?\) "\)( " mim-mode-syntax-table) - (modify-syntax-entry ?\> "\)< " mim-mode-syntax-table) - (modify-syntax-entry ?\} "\){ " mim-mode-syntax-table) - (modify-syntax-entry ?\] "\)[ " mim-mode-syntax-table))) - -(defconst mim-whitespace "\000- ") - -(defvar mim-mode-hook nil - "*User function run after mim mode initialization. Usage: -\(setq mim-mode-hook '(lambda () ... your init forms ...)).") - -(define-abbrev-table 'mim-mode-abbrev-table nil) - -(defconst indent-mim-function 'indent-mim-function - "Controls (via properties) indenting of special forms. -\(put 'FOO 'indent-mim-function n\), integer n, means lines inside -<FOO ...> will be indented n spaces from start of form. -\(put 'FOO 'indent-mim-function 'DEFINE\) is like above but means use -value of mim-body-indent as offset from start of form. -\(put 'FOO 'indent-mim-function <cons>\) where <cons> is a list or pointed list -of integers, means indent each form in <FOO ...> by the amount specified -in <cons>. When <cons> is exhausted, indent remaining forms by -`mim-body-indent' unless <cons> is a pointed list, in which case the last -cdr is used. Confused? Here is an example: -\(put 'FROBIT 'indent-mim-function '\(4 2 . 1\)\) -<FROBIT - <CHOMP-IT> - <CHOMP-SOME-MORE> - <DIGEST> - <BELCH> - ...> -Finally, the property can be a function name (read the code).") - -(defvar indent-mim-comment t - "*Non-nil means indent string comments.") - -(defvar mim-body-indent 2 - "*Amount to indent in special forms which have DEFINE property on -`indent-mim-function'.") - -(defvar indent-mim-arglist t - "*nil means indent arglists like ordinary lists. -t means strings stack under start of arglist and variables stack to -right of them. Otherwise, strings stack under last string (or start -of arglist if none) and variables stack to right of them. -Examples (for values 'stack, t, nil): - -\(FOO \"OPT\" BAR \(FOO \"OPT\" BAR \(FOO \"OPT\" BAR - BAZ MUMBLE BAZ MUMBLE BAZ MUMBLE - \"AUX\" \"AUX\" \"AUX\" - BLETCH ... BLETCH ... BLETCH ...") - -(put 'DEFINE 'indent-mim-function 'DEFINE) -(put 'DEFMAC 'indent-mim-function 'DEFINE) -(put 'BIND 'indent-mim-function 'DEFINE) -(put 'PROG 'indent-mim-function 'DEFINE) -(put 'REPEAT 'indent-mim-function 'DEFINE) -(put 'CASE 'indent-mim-function 'DEFINE) -(put 'FUNCTION 'indent-mim-function 'DEFINE) -(put 'MAPF 'indent-mim-function 'DEFINE) -(put 'MAPR 'indent-mim-function 'DEFINE) -(put 'UNWIND 'indent-mim-function (cons (* 2 mim-body-indent) mim-body-indent)) - -(defvar mim-down-parens-only t - "*nil means treat ADECLs and ATOM trailers like structures when -moving down a level of structure.") - -(defvar mim-stop-for-slop t - "*Non-nil means {next previous}-mim-object consider any -non-whitespace character in column 0 to be a toplevel object, otherwise -only open paren syntax characters will be considered.") - -(defalias 'mdl-mode 'mim-mode) - -(defun mim-mode () - "Major mode for editing Mim (MDL in MDL) code. -Commands: - If value of `mim-mode-hysterical-bindings' is non-nil, then following -commands are assigned to escape keys as well (e.g. ESC f = ESC C-f). -The default action is bind the escape keys. -\\{mim-mode-map} -Other Commands: - Use \\[describe-function] to obtain documentation. - replace-in-mim-object find-mim-definition fast-syntax-check-mim - slow-syntax-check-mim backward-down-mim-object forward-up-mim-object -Variables: - Use \\[describe-variable] to obtain documentation. - mim-mode-hook indent-mim-comment indent-mim-arglist indent-mim-function - mim-body-indent mim-down-parens-only mim-stop-for-slop - mim-mode-hysterical-bindings -Entry to this mode calls the value of mim-mode-hook if non-nil." - (interactive) - (kill-all-local-variables) - (if (not mim-mode-map) - (progn - (setq mim-mode-map (make-sparse-keymap)) - (define-key mim-mode-map "\e\^o" 'open-mim-line) - (define-key mim-mode-map "\e\^q" 'indent-mim-object) - (define-key mim-mode-map "\e\^p" 'previous-mim-object) - (define-key mim-mode-map "\e\^n" 'next-mim-object) - (define-key mim-mode-map "\e\^a" 'beginning-of-DEFINE) - (define-key mim-mode-map "\e\^e" 'end-of-DEFINE) - (define-key mim-mode-map "\e\^t" 'transpose-mim-objects) - (define-key mim-mode-map "\e\^u" 'backward-up-mim-object) - (define-key mim-mode-map "\e\^d" 'forward-down-mim-object) - (define-key mim-mode-map "\e\^h" 'mark-mim-object) - (define-key mim-mode-map "\e\^k" 'forward-kill-mim-object) - (define-key mim-mode-map "\e\^f" 'forward-mim-object) - (define-key mim-mode-map "\e\^b" 'backward-mim-object) - (define-key mim-mode-map "\e^" 'raise-mim-line) - (define-key mim-mode-map "\e\\" 'fixup-whitespace) - (define-key mim-mode-map "\177" 'backward-delete-char-untabify) - (define-key mim-mode-map "\e\177" 'backward-kill-mim-object) - (define-key mim-mode-map "\^j" 'newline-and-mim-indent) - (define-key mim-mode-map "\e;" 'begin-mim-comment) - (define-key mim-mode-map "\t" 'indent-mim-line) - (define-key mim-mode-map "\e\t" 'indent-mim-object) - (if (not mim-mode-hysterical-bindings) - nil - ;; i really hate this but too many people are accustomed to these. - (define-key mim-mode-map "\e!" 'line-to-top-of-window) - (define-key mim-mode-map "\eo" 'open-mim-line) - (define-key mim-mode-map "\ep" 'previous-mim-object) - (define-key mim-mode-map "\en" 'next-mim-object) - (define-key mim-mode-map "\ea" 'beginning-of-DEFINE) - (define-key mim-mode-map "\ee" 'end-of-DEFINE) - (define-key mim-mode-map "\et" 'transpose-mim-objects) - (define-key mim-mode-map "\eu" 'backward-up-mim-object) - (define-key mim-mode-map "\ed" 'forward-down-mim-object) - (define-key mim-mode-map "\ek" 'forward-kill-mim-object) - (define-key mim-mode-map "\ef" 'forward-mim-object) - (define-key mim-mode-map "\eb" 'backward-mim-object)))) - (use-local-map mim-mode-map) - (set-syntax-table mim-mode-syntax-table) - (make-local-variable 'paragraph-start) - (setq paragraph-start (concat "$\\|" page-delimiter)) - (make-local-variable 'paragraph-separate) - (setq paragraph-separate paragraph-start) - (make-local-variable 'paragraph-ignore-fill-prefix) - (setq paragraph-ignore-fill-prefix t) - ;; Most people use string comments. - (make-local-variable 'comment-start) - (setq comment-start ";\"") - (make-local-variable 'comment-start-skip) - (setq comment-start-skip ";\"") - (make-local-variable 'comment-end) - (setq comment-end "\"") - (make-local-variable 'comment-column) - (setq comment-column 40) - (make-local-variable 'comment-indent-function) - (setq comment-indent-function 'indent-mim-comment) - ;; tell generic indenter how to indent. - (make-local-variable 'indent-line-function) - (setq indent-line-function 'indent-mim-line) - ;; look for that paren - (make-local-variable 'blink-matching-paren-distance) - (setq blink-matching-paren-distance nil) - ;; so people who dont like tabs can turn them off locally in indenter. - (make-local-variable 'indent-tabs-mode) - (setq indent-tabs-mode t) - (setq local-abbrev-table mim-mode-abbrev-table) - (setq major-mode 'mim-mode) - (setq mode-name "Mim") - (run-hooks 'mim-mode-hook)) - -(defun line-to-top-of-window () - "Move current line to top of window." - (interactive) ; for lazy people - (recenter 0)) - -(defun forward-mim-object (arg) - "Move forward across Mim object. -With ARG, move forward that many objects." - (interactive "p") - ;; this function is weird because it emulates the behavior of the old - ;; (gosling) mim-mode - if the arg is 1 and we are `inside' an ADECL, - ;; more than one character into the ATOM part and not sitting on the - ;; colon, then we move to the DECL part (just past colon) instead of - ;; the end of the object (the entire ADECL). otherwise, ADECL's are - ;; atomic objects. likewise for ATOM trailers. - (if (= (abs arg) 1) - (if (inside-atom-p) - ;; Move to end of ATOM or to trailer (!) or to ADECL (:). - (forward-sexp arg) - ;; Either scan an sexp or move over one bracket. - (forward-mim-objects arg t)) - ;; in the multi-object case, don't perform any magic. - ;; treats ATOM trailers and ADECLs atomically, stops at unmatched - ;; brackets with error. - (forward-mim-objects arg))) - -(defun inside-atom-p () - ;; Returns t iff inside an atom (takes account of trailers) - (let ((c1 (preceding-char)) - (c2 (following-char))) - (and (or (= (char-syntax c1) ?w) (= (char-syntax c1) ?_) (= c1 ?!)) - (or (= (char-syntax c2) ?w) (= (char-syntax c2) ?_) (= c2 ?!))))) - -(defun forward-mim-objects (arg &optional skip-bracket-p) - ;; Move over arg objects ignoring ADECLs and trailers. If - ;; skip-bracket-p is non-nil, then move over one bracket on error. - (let ((direction (sign arg))) - (condition-case conditions - (while (/= arg 0) - (forward-sexp direction) - (if (not (inside-adecl-or-trailer-p direction)) - (setq arg (- arg direction)))) - (error (if (not skip-bracket-p) - (signal 'error (cdr conditions)) - (skip-mim-whitespace direction) - (goto-char (+ (point) direction))))) - ;; If we moved too far move back to first interesting character. - (if (= (point) (buffer-end direction)) (skip-mim-whitespace (- direction))))) - -(defun backward-mim-object (&optional arg) - "Move backward across Mim object. -With ARG, move backward that many objects." - (interactive "p") - (forward-mim-object (if arg (- arg) -1))) - -(defun mark-mim-object (&optional arg) - "Mark following Mim object. -With ARG, mark that many following (preceding, ARG < 0) objects." - (interactive "p") - (push-mark (save-excursion (forward-mim-object (or arg 1)) (point)))) - -(defun forward-kill-mim-object (&optional arg) - "Kill following Mim object. -With ARG, kill that many objects." - (interactive "*p") - (kill-region (point) (progn (forward-mim-object (or arg 1)) (point)))) - -(defun backward-kill-mim-object (&optional arg) - "Kill preceding Mim object. -With ARG, kill that many objects." - (interactive "*p") - (forward-kill-mim-object (- (or arg 1)))) - -(defun raise-mim-line (&optional arg) - "Raise following line, fixing up whitespace at join. -With ARG raise that many following lines. -A negative ARG will raise current line and previous lines." - (interactive "*p") - (let* ((increment (sign (or arg (setq arg 1)))) - (direction (if (> arg 0) 1 0))) - (save-excursion - (while (/= arg 0) - ;; move over eol and kill it - (forward-line direction) - (delete-region (point) (1- (point))) - (fixup-whitespace) - (setq arg (- arg increment)))))) - -(defun forward-down-mim-object (&optional arg) - "Move down a level of Mim structure forwards. -With ARG, move down that many levels forwards (backwards, ARG < 0)." - (interactive "p") - ;; another weirdo - going down `inside' an ADECL or ATOM trailer - ;; depends on the value of mim-down-parens-only. if nil, treat - ;; ADECLs and trailers as structured objects. - (let ((direction (sign (or arg (setq arg 1))))) - (if (and (= (abs arg) 1) (not mim-down-parens-only)) - (goto-char - (save-excursion - (skip-mim-whitespace direction) - (if (> direction 0) (re-search-forward "\\s'*")) - (or (and (let ((c (next-char direction))) - (or (= (char-syntax c) ?_) - (= (char-syntax c) ?w))) - (progn (forward-sexp direction) - (if (inside-adecl-or-trailer-p direction) - (point)))) - (scan-lists (point) direction -1) - (buffer-end direction)))) - (while (/= arg 0) - (goto-char (or (scan-lists (point) direction -1) (buffer-end direction))) - (setq arg (- arg direction)))))) - -(defun backward-down-mim-object (&optional arg) - "Move down a level of Mim structure backwards. -With ARG, move down that many levels backwards (forwards, ARG < 0)." - (interactive "p") - (forward-down-mim-object (if arg (- arg) -1))) - -(defun forward-up-mim-object (&optional arg) - "Move up a level of Mim structure forwards -With ARG, move up that many levels forwards (backwards, ARG < 0)." - (interactive "p") - (let ((direction (sign (or arg (setq arg 1))))) - (while (/= arg 0) - (goto-char (or (scan-lists (point) direction 1) (buffer-end arg))) - (setq arg (- arg direction))) - (if (< direction 0) (backward-prefix-chars)))) - -(defun backward-up-mim-object (&optional arg) - "Move up a level of Mim structure backwards -With ARG, move up that many levels backwards (forwards, ARG > 0)." - (interactive "p") - (forward-up-mim-object (if arg (- arg) -1))) - -(defun replace-in-mim-object (old new) - "Replace string in following Mim object." - (interactive "*sReplace in object: \nsReplace %s with: ") - (save-restriction - (narrow-to-region (point) (save-excursion (forward-mim-object 1) (point))) - (replace-string old new))) - -(defun transpose-mim-objects (&optional arg) - "Transpose Mim objects around point. -With ARG, transpose preceding object that many times with following objects. -A negative ARG will transpose backwards." - (interactive "*p") - (transpose-subr 'forward-mim-object (or arg 1))) - -(defun beginning-of-DEFINE (&optional arg move) - "Move backward to beginning of surrounding or previous toplevel Mim form. -With ARG, do it that many times. Stops at last toplevel form seen if buffer -end is reached." - (interactive "p") - (let ((direction (sign (or arg (setq arg 1))))) - (if (not move) (setq move t)) - (if (< direction 0) (goto-char (1+ (point)))) - (while (and (/= arg 0) (re-search-backward "^<" nil move direction)) - (setq arg (- arg direction))) - (if (< direction 0) - (goto-char (1- (point)))))) - -(defun end-of-DEFINE (&optional arg) - "Move forward to end of surrounding or next toplevel mim form. -With ARG, do it that many times. Stops at end of last toplevel form seen -if buffer end is reached." - (interactive "p") - (if (not arg) (setq arg 1)) - (if (< arg 0) - (beginning-of-DEFINE (- (1- arg))) - (if (not (looking-at "^<")) (setq arg (1+ arg))) - (beginning-of-DEFINE (- arg) 'move) - (beginning-of-DEFINE 1)) - (forward-mim-object 1) - (forward-line 1)) - -(defun next-mim-object (&optional arg) - "Move to beginning of next toplevel Mim object. -With ARG, do it that many times. Stops at last object seen if buffer end -is reached." - (interactive "p") - (let ((search-string (if mim-stop-for-slop "^\\S " "^\\s(")) - (direction (sign (or arg (setq arg 1))))) - (if (> direction 0) - (goto-char (1+ (point)))) ; no error if end of buffer - (while (and (/= arg 0) - (re-search-forward search-string nil t direction)) - (setq arg (- arg direction))) - (if (> direction 0) - (goto-char (1- (point)))) ; no error if beginning of buffer - ;; scroll to top of window if moving forward and end not visible. - (if (not (or (< direction 0) - (save-excursion (forward-mim-object 1) - (pos-visible-in-window-p (point))))) - (recenter 0)))) - -(defun previous-mim-object (&optional arg) - "Move to beginning of previous toplevel Mim object. -With ARG do it that many times. Stops at last object seen if buffer end -is reached." - (interactive "p") - (next-mim-object (- (or arg 1)))) - -(defun calculate-mim-indent (&optional parse-start) - "Calculate indentation for Mim line. Returns column." - (save-excursion ; some excursion, huh, toto? - (beginning-of-line) - (let ((indent-point (point)) retry state containing-sexp last-sexp - desired-indent start peek where paren-depth) - (if parse-start - (goto-char parse-start) ; should be containing environment - (catch 'from-the-top - ;; find a place to start parsing. going backwards is fastest. - ;; forward-sexp signals error on encountering unmatched open. - (setq retry t) - (while retry - (condition-case nil (forward-sexp -1) (error (setq retry nil))) - (if (looking-at ".?[ \t]*\"") - ;; cant parse backward in presence of strings, go forward. - (progn - (goto-char indent-point) - (re-search-backward "^\\s(" nil 'move 1) ; to top of object - (throw 'from-the-top nil))) - (setq retry (and retry (/= (current-column) 0)))) - (skip-chars-backward mim-whitespace) - (if (not (bobp)) (forward-char -1)) ; onto unclosed open - (backward-prefix-chars))) - ;; find outermost containing sexp if we started inside an sexp. - (while (< (point) indent-point) - (setq state (parse-partial-sexp (point) indent-point 0))) - ;; find usual column to indent under (not in string or toplevel). - ;; on termination, state will correspond to containing environment - ;; (if retry is nil), where will be position of character to indent - ;; under normally, and desired-indent will be the column to indent to - ;; except if inside form, string, or at toplevel. point will be in - ;; in column to indent to unless inside string. - (setq retry t) - (while (and retry (setq paren-depth (car state)) (> paren-depth 0)) - ;; find innermost containing sexp. - (setq retry nil) - (setq last-sexp (car (nthcdr 2 state))) - (setq containing-sexp (car (cdr state))) - (goto-char (1+ containing-sexp)) ; to last unclosed open - (if (and last-sexp (> last-sexp (point))) - ;; is the last sexp a containing sexp? - (progn (setq peek (parse-partial-sexp last-sexp indent-point 0)) - (if (setq retry (car (cdr peek))) (setq state peek)))) - (if retry - nil - (setq where (1+ containing-sexp)) ; innermost containing sexp - (goto-char where) - (cond - ((not last-sexp) ; indent-point after bracket - (setq desired-indent (current-column))) - ((= (preceding-char) ?\<) ; it's a form - (cond ((> (progn (forward-sexp 1) (point)) last-sexp) - (goto-char where)) ; only one frob - ((> (save-excursion (forward-line 1) (point)) last-sexp) - (skip-chars-forward " \t") ; last-sexp is on same line - (setq where (point))) ; as containing-sexp - ((progn - (goto-char last-sexp) - (beginning-of-line) - (parse-partial-sexp (point) last-sexp 0 t) - (or (= (point) last-sexp) - (save-excursion - (= (car (parse-partial-sexp (point) last-sexp 0)) - 0)))) - (backward-prefix-chars) ; last-sexp 1st on line or 1st - (setq where (point))) ; frob on that line level 0 - (t (goto-char where)))) ; punt, should never occur - ((and indent-mim-arglist ; maybe hack arglist - (= (preceding-char) ?\() ; its a list - (save-excursion ; look for magic atoms - (setq peek 0) ; using peek as counter - (forward-char -1) ; back over containing paren - (while (and (< (setq peek (1+ peek)) 6) - (condition-case nil - (progn (forward-sexp -1) t) - (error nil)))) - (and (< peek 6) (looking-at "DEFINE\\|DEFMAC\\|FUNCTION")))) - ;; frobs stack under strings they belong to or under first - ;; frob to right of strings they belong to unless luser has - ;; frob (non-string) on preceding line with different - ;; indentation. strings stack under start of arglist unless - ;; mim-indent-arglist is not t, in which case they stack - ;; under the last string, if any, else the start of the arglist. - (let ((eol 0) last-string) - (while (< (point) last-sexp) ; find out where the strings are - (skip-chars-forward mim-whitespace last-sexp) - (if (> (setq start (point)) eol) - (progn ; simultaneously keeping track - (setq where (min where start)) - (end-of-line) ; of indentation of first frob - (setq eol (point)) ; on each line - (goto-char start))) - (if (= (following-char) ?\") - (progn (setq last-string (point)) - (forward-sexp 1) - (if (= last-string last-sexp) - (setq where last-sexp) - (skip-chars-forward mim-whitespace last-sexp) - (setq where (point)))) - (forward-sexp 1))) - (goto-char indent-point) ; if string is first on - (skip-chars-forward " \t" (point-max)) ; line we are indenting, it - (if (= (following-char) ?\") ; goes under arglist start - (if (and last-string (not (equal indent-mim-arglist t))) - (setq where last-string) ; or under last string. - (setq where (1+ containing-sexp))))) - (goto-char where) - (setq desired-indent (current-column))) - (t ; plain vanilla structure - (cond ((> (save-excursion (forward-line 1) (point)) last-sexp) - (skip-chars-forward " \t") ; last-sexp is on same line - (setq where (point))) ; as containing-sexp - ((progn - (goto-char last-sexp) - (beginning-of-line) - (parse-partial-sexp (point) last-sexp 0 t) - (or (= (point) last-sexp) - (save-excursion - (= (car (parse-partial-sexp (point) last-sexp 0)) - 0)))) - (backward-prefix-chars) ; last-sexp 1st on line or 1st - (setq where (point))) ; frob on that line level 0 - (t (goto-char where))) ; punt, should never occur - (setq desired-indent (current-column)))))) - ;; state is innermost containing environment unless toplevel or string. - (if (car (nthcdr 3 state)) ; inside string - (progn - (if last-sexp ; string must be next - (progn (goto-char last-sexp) - (forward-sexp 1) - (search-forward "\"") - (forward-char -1)) - (goto-char indent-point) ; toplevel string, look for it - (re-search-backward "[^\\]\"") - (forward-char 1)) - (setq start (point)) ; opening double quote - (skip-chars-backward " \t") - (backward-prefix-chars) - ;; see if the string is really a comment. - (if (and (looking-at ";[ \t]*\"") indent-mim-comment) - ;; it's a comment, line up under the start unless disabled. - (goto-char (1+ start)) - ;; it's a string, dont mung the indentation. - (goto-char indent-point) - (skip-chars-forward " \t")) - (setq desired-indent (current-column)))) - ;; point is sitting in usual column to indent to and if retry is nil - ;; then state corresponds to containing environment. if desired - ;; indentation not determined, we are inside a form, so call hook. - (or desired-indent - (and indent-mim-function - (not retry) - (setq desired-indent - (funcall indent-mim-function state indent-point))) - (setq desired-indent (current-column))) - (goto-char indent-point) ; back to where we started - desired-indent))) ; return column to indent to - -(defun indent-mim-function (state indent-point) - "Compute indentation for Mim special forms. Returns column or nil." - (let ((containing-sexp (car (cdr state))) (current-indent (point))) - (save-excursion - (goto-char (1+ containing-sexp)) - (backward-prefix-chars) - ;; make sure we are looking at a symbol. if so, see if it is a special - ;; symbol. if so, add the special indentation to the indentation of - ;; the start of the special symbol, unless the property is not - ;; an integer and not nil (in this case, call the property, it must - ;; be a function which returns the appropriate indentation or nil and - ;; does not change the buffer). - (if (looking-at "\\sw\\|\\s_") - (let* ((start (current-column)) - (function - (intern-soft (buffer-substring (point) - (progn (forward-sexp 1) - (point))))) - (method (get function 'indent-mim-function))) - (if (or (if (equal method 'DEFINE) (setq method mim-body-indent)) - (integerp method)) - ;; only use method if its first line after containing-sexp. - ;; we could have done this in calculate-mim-indent, but someday - ;; someone might want to format frobs in a special form based - ;; on position instead of indenting uniformly (like lisp if), - ;; so preserve right for posterity. if not first line, - ;; calculate-mim-indent already knows right indentation - - ;; give luser chance to change indentation manually by changing - ;; 1st line after containing-sexp. - (if (> (progn (forward-line 1) (point)) (car (nthcdr 2 state))) - (+ method start)) - (goto-char current-indent) - (if (consp method) - ;; list or pointed list of explicit indentations - (indent-mim-offset state indent-point) - (if (and (symbolp method) (fboundp method)) - ;; luser function - s/he better know what's going on. - ;; should take state and indent-point as arguments - for - ;; description of state, see parse-partial-sexp - ;; documentation the function is guaranteed the following: - ;; (1) state describes the closest surrounding form, - ;; (2) indent-point is the beginning of the line being - ;; indented, (3) point points to char in column that would - ;; normally be used for indentation, (4) function is bound - ;; to the special ATOM. See indent-mim-offset for example - ;; of a special function. - (funcall method state indent-point))))))))) - -(defun indent-mim-offset (state indent-point) - ;; offset forms explicitly according to list of indentations. - (let ((mim-body-indent mim-body-indent) - (indentations (get function 'indent-mim-function)) - (containing-sexp (car (cdr state))) - (last-sexp (car (nthcdr 2 state))) - indentation) - (goto-char (1+ containing-sexp)) - ;; determine which of the indentations to use. - (while (and (< (point) indent-point) - (condition-case nil - (progn (forward-sexp 1) - (parse-partial-sexp (point) indent-point 1 t)) - (error nil))) - (skip-chars-backward " \t") - (backward-prefix-chars) - (if (= (following-char) ?\;) - nil ; ignore comments - (setq indentation (car indentations)) - (if (integerp (setq indentations (cdr indentations))) - ;; if last cdr is integer, that is indentation to use for all - ;; all the rest of the forms. - (progn (setq mim-body-indent indentations) - (setq indentations nil))))) - (goto-char (1+ containing-sexp)) - (+ (current-column) (or indentation mim-body-indent)))) - -(defun indent-mim-comment (&optional start) - "Indent a one line (string) Mim comment following object, if any." - (let* ((old-point (point)) (eol (progn (end-of-line) (point))) state last-sexp) - ;; this function assumes that comment indenting is enabled. it is caller's - ;; responsibility to check the indent-mim-comment flag before calling. - (beginning-of-line) - (catch 'no-comment - (setq state (parse-partial-sexp (point) eol)) - ;; determine if there is an existing regular comment. a `regular' - ;; comment is defined as a commented string which is the last thing - ;; on the line and does not extend beyond the end of the line. - (if (or (not (setq last-sexp (car (nthcdr 2 state)))) - (car (nthcdr 3 state))) - ;; empty line or inside string (multiple line). - (throw 'no-comment nil)) - ;; could be a comment, but make sure its not the only object. - (beginning-of-line) - (parse-partial-sexp (point) eol 0 t) - (if (= (point) last-sexp) - ;; only one object on line - (throw 'no-comment t)) - (goto-char last-sexp) - (skip-chars-backward " \t") - (backward-prefix-chars) - (if (not (looking-at ";[ \t]*\"")) - ;; aint no comment - (throw 'no-comment nil)) - ;; there is an existing regular comment - (delete-horizontal-space) - ;; move it to comment-column if possible else to tab-stop - (if (< (current-column) comment-column) - (indent-to comment-column) - (tab-to-tab-stop))) - (goto-char old-point))) - -(defun indent-mim-line () - "Indent line of Mim code." - (interactive "*") - (let* ((position (- (point-max) (point))) - (bol (progn (beginning-of-line) (point))) - (indent (calculate-mim-indent))) - (skip-chars-forward " \t") - (if (/= (current-column) indent) - (progn (delete-region bol (point)) (indent-to indent))) - (if (> (- (point-max) position) (point)) (goto-char (- (point-max) position))))) - -(defun newline-and-mim-indent () - "Insert newline at point and indent." - (interactive "*") - ;; commented code would correct indentation of line in arglist which - ;; starts with string, but it would indent every line twice. luser can - ;; just say tab after typing string to get same effect. - ;(if indent-mim-arglist (indent-mim-line)) - (newline) - (indent-mim-line)) - -(defun open-mim-line (&optional lines) - "Insert newline before point and indent. -With ARG insert that many newlines." - (interactive "*p") - (beginning-of-line) - (let ((indent (calculate-mim-indent))) - (while (> lines 0) - (newline) - (forward-line -1) - (indent-to indent) - (setq lines (1- lines))))) - -(defun indent-mim-object (&optional dont-indent-first-line) - "Indent object following point and all lines contained inside it. -With ARG, idents only contained lines (skips first line)." - (interactive "*P") - (let (end bol indent start) - (save-excursion (parse-partial-sexp (point) (point-max) 0 t) - (setq start (point)) - (forward-sexp 1) - (setq end (- (point-max) (point)))) - (save-excursion - (if (not dont-indent-first-line) (indent-mim-line)) - (while (progn (forward-line 1) (> (- (point-max) (point)) end)) - (setq indent (calculate-mim-indent start)) - (setq bol (point)) - (skip-chars-forward " \t") - (if (/= indent (current-column)) - (progn (delete-region bol (point)) (indent-to indent))) - (if indent-mim-comment (indent-mim-comment)))))) - -(defun find-mim-definition (name) - "Search for definition of function, macro, or gfcn. -You need type only enough of the name to be unambiguous." - (interactive "sName: ") - (let (where) - (save-excursion - (goto-char (point-min)) - (condition-case nil - (progn - (re-search-forward - (concat "^<\\(DEFINE\\|\\DEFMAC\\|FCN\\|GFCN\\)\\([ \t]*\\)" - name)) - (setq where (point))) - (error (error "Can't find %s" name)))) - (if where - (progn (push-mark) - (goto-char where) - (beginning-of-line) - (recenter 0))))) - -(defun begin-mim-comment () - "Move to existing comment or insert empty comment." - (interactive "*") - (let* ((eol (progn (end-of-line) (point))) - (bol (progn (beginning-of-line) (point)))) - ;; check for existing comment first. - (if (re-search-forward ";[ \t]*\"" eol t) - ;; found it. indent if desired and go there. - (if indent-mim-comment - (let ((where (- (point-max) (point)))) - (indent-mim-comment) - (goto-char (- (point-max) where)))) - ;; nothing there, make a comment. - (let (state last-sexp) - ;; skip past all the sexps on the line - (goto-char bol) - (while (and (equal (car (setq state (parse-partial-sexp (point) eol 0))) - 0) - (car (nthcdr 2 state))) - (setq last-sexp (car (nthcdr 2 state)))) - (if (car (nthcdr 3 state)) - nil ; inside a string, punt - (delete-region (point) eol) ; flush trailing whitespace - (if (and (not last-sexp) (equal (car state) 0)) - (indent-to (calculate-mim-indent)) ; empty, indent like code - (if (> (current-column) comment-column) ; indent to comment column - (tab-to-tab-stop) ; unless past it, else to - (indent-to comment-column))) ; tab-stop - ;; if luser changes comment-{start end} to something besides semi - ;; followed by zero or more whitespace characters followed by string - ;; delimiters, the code above fails to find existing comments, but as - ;; taa says, `let the losers lose'. - (insert comment-start) - (save-excursion (insert comment-end))))))) - -(defun skip-mim-whitespace (direction) - (if (>= direction 0) - (skip-chars-forward mim-whitespace (point-max)) - (skip-chars-backward mim-whitespace (point-min)))) - -(defun inside-adecl-or-trailer-p (direction) - (if (>= direction 0) - (looking-at ":\\|!-") - (or (= (preceding-char) ?:) - (looking-at "!-")))) - -(defun sign (n) - "Returns -1 if N < 0, else 1." - (if (>= n 0) 1 -1)) - -(defun abs (n) - "Returns the absolute value of N." - (if (>= n 0) n (- n))) - -(defun next-char (direction) - "Returns preceding-char if DIRECTION < 0, otherwise following-char." - (if (>= direction 0) (following-char) (preceding-char))) - -(provide 'mim-mode) - -;;; mim-mode.el ends here diff --git a/lisp/mim-syntax.el b/lisp/mim-syntax.el deleted file mode 100644 index beb8d330a35..00000000000 --- a/lisp/mim-syntax.el +++ /dev/null @@ -1,95 +0,0 @@ -;;; mim-syntax.el --- syntax checker for Mim (MDL). - -;; Copyright (C) 1985 Free Software Foundation, Inc. - -;; Author: K. Shane Hartman -;; Maintainer: FSF -;; Keywords: languages - -;; 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, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; Code: - -(require 'mim-mode) - -(defun slow-syntax-check-mim () - "Check Mim syntax slowly. -Points out the context of the error, if the syntax is incorrect." - (interactive) - (message "checking syntax...") - (let ((stop (point-max)) point-stack current last-bracket whoops last-point) - (save-excursion - (goto-char (point-min)) - (while (and (not whoops) - (re-search-forward "\\s(\\|\\s)\\|\"\\|[\\]" stop t)) - (setq current (preceding-char)) - (cond ((= current ?\") - (condition-case nil - (progn (re-search-forward "[^\\]\"") - (setq current nil)) - (error (setq whoops (point))))) - ((= current ?\\) - (condition-case nil (forward-char 1) (error nil))) - ((= (char-syntax current) ?\)) - (if (or (not last-bracket) - (not (= (logand (lsh (aref (syntax-table) last-bracket) -8) - ?\177) - current))) - (setq whoops (point)) - (setq last-point (car point-stack)) - (setq last-bracket (if last-point (char-after (1- last-point)))) - (setq point-stack (cdr point-stack)))) - (t - (if last-point (setq point-stack (cons last-point point-stack))) - (setq last-point (point)) - (setq last-bracket current))))) - (cond ((not (or whoops last-point)) - (message "Syntax correct")) - (whoops - (goto-char whoops) - (cond ((equal current ?\") - (error "Unterminated string")) - ((not last-point) - (error "Extraneous %s" (char-to-string current))) - (t - (error "Mismatched %s with %s" - (save-excursion - (setq whoops (1- (point))) - (goto-char (1- last-point)) - (buffer-substring (point) - (min (progn (end-of-line) (point)) - whoops))) - (char-to-string current))))) - (t - (goto-char last-point) - (error "Unmatched %s" (char-to-string last-bracket)))))) - -(defun fast-syntax-check-mim () - "Checks Mim syntax quickly. -Answers correct or incorrect, cannot point out the error context." - (interactive) - (save-excursion - (goto-char (point-min)) - (let (state) - (while (and (not (eobp)) - (equal (car (setq state (parse-partial-sexp (point) (point-max) 0))) - 0))) - (if (equal (car state) 0) - (message "Syntax correct") - (error "Syntax incorrect"))))) - -;;; mim-syntax.el ends here diff --git a/lisp/netunam.el b/lisp/netunam.el deleted file mode 100644 index 492ac9b2c12..00000000000 --- a/lisp/netunam.el +++ /dev/null @@ -1,160 +0,0 @@ -;;; netunam.el --- HP-UX RFA Commands - -;; Copyright (C) 1988 Free Software Foundation, Inc. - -;; Author: Chris Hanson <cph@zurich.ai.mit.edu> -;; Keywords: comm - -;; 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, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; Commentary: - -;; Use the Remote File Access (RFA) facility of HP-UX from Emacs. - -;;; Code: - -(defconst rfa-node-directory "/net/" - "Directory in which RFA network special files are stored. -By HP convention, this is \"/net/\".") - -(defvar rfa-default-node nil - "If not nil, this is the name of the default RFA network special file.") - -(defvar rfa-password-memoize-p t - "If non-nil, remember login user's passwords after they have been entered.") - -(defvar rfa-password-alist '() - "An association from node-name strings to password strings. -Used if `rfa-password-memoize-p' is non-nil.") - -(defvar rfa-password-per-node-p t - "If nil, login user uses same password on all machines. -Has no effect if `rfa-password-memoize-p' is nil.") - -(defun rfa-set-password (password &optional node user) - "Add PASSWORD to the RFA password database. -Optional second arg NODE is a string specifying a particular nodename; - if supplied and not nil, PASSWORD applies to only that node. -Optional third arg USER is a string specifying the (remote) user whose - password this is; if not supplied this defaults to (user-login-name)." - (if (not user) (setq user (user-login-name))) - (let ((node-entry (assoc node rfa-password-alist))) - (if node-entry - (let ((user-entry (assoc user (cdr node-entry)))) - (if user-entry - (rplacd user-entry password) - (rplacd node-entry - (nconc (cdr node-entry) - (list (cons user password)))))) - (setq rfa-password-alist - (nconc rfa-password-alist - (list (list node (cons user password)))))))) - -(defun rfa-open (node &optional user password) - "Open a network connection to a server using remote file access. -First argument NODE is the network node for the remote machine. -Second optional argument USER is the user name to use on that machine. - If called interactively, the user name is prompted for. -Third optional argument PASSWORD is the password string for that user. - If not given, this is filled in from the value of -`rfa-password-alist', or prompted for. A prefix argument of - will -cause the password to be prompted for even if previously memoized." - (interactive - (list (read-file-name "rfa-open: " rfa-node-directory rfa-default-node t) - (read-string "user-name: " (user-login-name)))) - (let ((node - (and (or rfa-password-per-node-p - (not (equal user (user-login-name)))) - node))) - (if (not password) - (setq password - (let ((password - (cdr (assoc user (cdr (assoc node rfa-password-alist)))))) - (or (and (not current-prefix-arg) password) - (rfa-password-read - (format "password for user %s%s: " - user - (if node (format " on node \"%s\"" node) "")) - password)))))) - (let ((result - (sysnetunam (expand-file-name node rfa-node-directory) - (concat user ":" password)))) - (if (interactive-p) - (if result - (message "Opened network connection to %s as %s" node user) - (error "Unable to open network connection"))) - (if (and rfa-password-memoize-p result) - (rfa-set-password password node user)) - result)) - -(defun rfa-close (node) - "Close a network connection to a server using remote file access. -NODE is the network node for the remote machine." - (interactive - (list (read-file-name "rfa-close: " rfa-node-directory rfa-default-node t))) - (let ((result (sysnetunam (expand-file-name node rfa-node-directory) ""))) - (cond ((not (interactive-p)) result) - ((not result) (error "Unable to close network connection")) - (t (message "Closed network connection to %s" node))))) - -(defun rfa-password-read (prompt default) - (let ((rfa-password-accumulator (or default ""))) - (read-from-minibuffer prompt - (and default - (let ((copy (concat default)) - (index 0) - (length (length default))) - (while (< index length) - (aset copy index ?.) - (setq index (1+ index))) - copy)) - rfa-password-map) - rfa-password-accumulator)) - -(defvar rfa-password-map nil) -(if (not rfa-password-map) - (let ((char ? )) - (setq rfa-password-map (make-keymap)) - (while (< char 127) - (define-key rfa-password-map (char-to-string char) - 'rfa-password-self-insert) - (setq char (1+ char))) - (define-key rfa-password-map "\C-g" - 'abort-recursive-edit) - (define-key rfa-password-map "\177" - 'rfa-password-rubout) - (define-key rfa-password-map "\n" - 'exit-minibuffer) - (define-key rfa-password-map "\r" - 'exit-minibuffer))) - -(defvar rfa-password-accumulator nil) - -(defun rfa-password-self-insert () - (interactive) - (setq rfa-password-accumulator - (concat rfa-password-accumulator - (char-to-string last-command-char))) - (insert ?.)) - -(defun rfa-password-rubout () - (interactive) - (delete-char -1) - (setq rfa-password-accumulator - (substring rfa-password-accumulator 0 -1))) - -;;; netunam.el ends here diff --git a/lisp/old-shell.el b/lisp/old-shell.el deleted file mode 100644 index 4c3944a65f4..00000000000 --- a/lisp/old-shell.el +++ /dev/null @@ -1,399 +0,0 @@ -;;; old-shell.el --- run a shell in an Emacs window - -;; Copyright (C) 1985, 1986, 1987, 1990 Free Software Foundation, Inc. - -;; Keywords: processes - -;; 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, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; Hacked from tea.el and shell.el by Olin Shivers (shivers@cs.cmu.edu). 8/88 - -;;; Since this mode is built on top of the general command-interpreter-in- -;;; a-buffer mode (comint mode), it shares a common base functionality, -;;; and a common set of bindings, with all modes derived from comint mode. - -;;; For documentation on the functionality provided by comint mode, and -;;; the hooks available for customising it, see the file comint.el. - -;;; Needs fixin: -;;; When sending text from a source file to a subprocess, the process-mark can -;;; move off the window, so you can lose sight of the process interactions. -;;; Maybe I should ensure the process mark is in the window when I send -;;; text to the process? Switch selectable? - -;;; Code: - -(require 'comint) -(defvar shell-popd-regexp "popd" - "*Regexp to match subshell commands equivalent to popd.") - -(defvar shell-pushd-regexp "pushd" - "*Regexp to match subshell commands equivalent to pushd.") - -(defvar shell-cd-regexp "cd" - "*Regexp to match subshell commands equivalent to cd.") - -(defvar explicit-shell-file-name nil - "*If non-nil, is file name to use for explicitly requested inferior shell.") - -(defvar explicit-csh-args - (if (eq system-type 'hpux) - ;; -T persuades HP's csh not to think it is smarter - ;; than us about what terminal modes to use. - '("-i" "-T") - '("-i")) - "*Args passed to inferior shell by M-x shell, if the shell is csh. -Value is a list of strings, which may be nil.") - -(defvar shell-dirstack nil - "List of directories saved by pushd in this buffer's shell.") - -(defvar shell-dirstack-query "dirs" - "Command used by shell-resync-dirlist to query shell.") - -(defvar shell-mode-map ()) -(cond ((not shell-mode-map) - (setq shell-mode-map (copy-keymap comint-mode-map)) - (define-key shell-mode-map "\t" 'comint-dynamic-complete) - (define-key shell-mode-map "\M-?" 'comint-dynamic-list-completions))) - -(defvar shell-mode-hook '() - "*Hook for customising shell mode") - - -;;; Basic Procedures -;;; =========================================================================== -;;; - -(defun shell-mode () - "Major mode for interacting with an inferior shell. -Return after the end of the process' output sends the text from the - end of process to the end of the current line. -Return before end of process output copies rest of line to end (skipping - the prompt) and sends it. -M-x send-invisible reads a line of text without echoing it, and sends it to - the shell. - -If you accidentally suspend your process, use \\[comint-continue-subjob] -to continue it. - -cd, pushd and popd commands given to the shell are watched by Emacs to keep -this buffer's default directory the same as the shell's working directory. -M-x dirs queries the shell and resyncs Emacs' idea of what the current - directory stack is. -M-x dirtrack-toggle turns directory tracking on and off. - -\\{shell-mode-map} -Customisation: Entry to this mode runs the hooks on comint-mode-hook and -shell-mode-hook (in that order). - -Variables shell-cd-regexp, shell-pushd-regexp and shell-popd-regexp are used -to match their respective commands." - (interactive) - (comint-mode) - (setq major-mode 'shell-mode - mode-name "Shell" - comint-prompt-regexp shell-prompt-pattern - comint-input-sentinel 'shell-directory-tracker) - (use-local-map shell-mode-map) - (make-local-variable 'shell-dirstack) - (set (make-local-variable 'shell-dirtrackp) t) - (run-hooks 'shell-mode-hook)) - - -(defun shell () - "Run an inferior shell, with I/O through buffer *shell*. -If buffer exists but shell process is not running, make new shell. -If buffer exists and shell process is running, just switch to buffer *shell*. - -The shell to use comes from the first non-nil variable found from these: -explicit-shell-file-name in Emacs, ESHELL in the environment or SHELL in the -environment. If none is found, /bin/sh is used. - -If a file ~/.emacs_SHELLNAME exists, it is given as initial input, simulating -a start-up file for the shell like .profile or .cshrc. Note that this may -lose due to a timing error if the shell discards input when it starts up. - -The buffer is put in shell-mode, giving commands for sending input -and controlling the subjobs of the shell. - -The shell file name, sans directories, is used to make a symbol name -such as `explicit-csh-arguments'. If that symbol is a variable, -its value is used as a list of arguments when invoking the shell. -Otherwise, one argument `-i' is passed to the shell. - -\(Type \\[describe-mode] in the shell buffer for a list of commands.)" - (interactive) - (if (not (comint-check-proc "*shell*")) - (let* ((prog (or explicit-shell-file-name - (getenv "ESHELL") - (getenv "SHELL") - "/bin/sh")) - (name (file-name-nondirectory prog)) - (startfile (concat "~/.emacs_" name)) - (xargs-name (intern-soft (concat "explicit-" name "-args")))) - (set-buffer (apply 'make-comint "shell" prog - (if (file-exists-p startfile) startfile) - (if (and xargs-name (boundp xargs-name)) - (symbol-value xargs-name) - '("-i")))) - (shell-mode))) - (switch-to-buffer "*shell*")) - - -;;; Directory tracking -;;; =========================================================================== -;;; This code provides the shell mode input sentinel -;;; SHELL-DIRECTORY-TRACKER -;;; that tracks cd, pushd, and popd commands issued to the shell, and -;;; changes the current directory of the shell buffer accordingly. -;;; -;;; This is basically a fragile hack, although it's more accurate than -;;; the original version in shell.el. It has the following failings: -;;; 1. It doesn't know about the cdpath shell variable. -;;; 2. It only spots the first command in a command sequence. E.g., it will -;;; miss the cd in "ls; cd foo" -;;; 3. More generally, any complex command (like ";" sequencing) is going to -;;; throw it. Otherwise, you'd have to build an entire shell interpreter in -;;; emacs lisp. Failing that, there's no way to catch shell commands where -;;; cd's are buried inside conditional expressions, aliases, and so forth. -;;; -;;; The whole approach is a crock. Shell aliases mess it up. File sourcing -;;; messes it up. You run other processes under the shell; these each have -;;; separate working directories, and some have commands for manipulating -;;; their w.d.'s (e.g., the lcd command in ftp). Some of these programs have -;;; commands that do *not* effect the current w.d. at all, but look like they -;;; do (e.g., the cd command in ftp). In shells that allow you job -;;; control, you can switch between jobs, all having different w.d.'s. So -;;; simply saying %3 can shift your w.d.. -;;; -;;; The solution is to relax, not stress out about it, and settle for -;;; a hack that works pretty well in typical circumstances. Remember -;;; that a half-assed solution is more in keeping with the spirit of Unix, -;;; anyway. Blech. -;;; -;;; One good hack not implemented here for users of programmable shells -;;; is to program up the shell w.d. manipulation commands to output -;;; a coded command sequence to the tty. Something like -;;; ESC | <cwd> | -;;; where <cwd> is the new current working directory. Then trash the -;;; directory tracking machinery currently used in this package, and -;;; replace it with a process filter that watches for and strips out -;;; these messages. - -;;; REGEXP is a regular expression. STR is a string. START is a fixnum. -;;; Returns T if REGEXP matches STR where the match is anchored to start -;;; at position START in STR. Sort of like LOOKING-AT for strings. -(defun shell-front-match (regexp str start) - (eq start (string-match regexp str start))) - -(defun shell-directory-tracker (str) - "Tracks cd, pushd and popd commands issued to the shell. -This function is called on each input passed to the shell. -It watches for cd, pushd and popd commands and sets the buffer's -default directory to track these commands. - -You may toggle this tracking on and off with M-x dirtrack-toggle. -If emacs gets confused, you can resync with the shell with M-x dirs. - -See variables shell-cd-regexp, shell-pushd-regexp, and shell-popd-regexp. -Environment variables are expanded, see function substitute-in-file-name." - (condition-case err - (cond (shell-dirtrackp - (string-match "^\\s *" str) ; skip whitespace - (let ((bos (match-end 0)) - (x nil)) - (cond ((setq x (shell-match-cmd-w/optional-arg shell-popd-regexp - str bos)) - (shell-process-popd (substitute-in-file-name x))) - ((setq x (shell-match-cmd-w/optional-arg shell-pushd-regexp - str bos)) - (shell-process-pushd (substitute-in-file-name x))) - ((setq x (shell-match-cmd-w/optional-arg shell-cd-regexp - str bos)) - (shell-process-cd (substitute-in-file-name x))))))) - (error (message (car (cdr err)))))) - - -;;; Try to match regexp CMD to string, anchored at position START. -;;; CMD may be followed by a single argument. If a match, then return -;;; the argument, if there is one, or the empty string if not. If -;;; no match, return nil. - -(defun shell-match-cmd-w/optional-arg (cmd str start) - (and (shell-front-match cmd str start) - (let ((eoc (match-end 0))) ; end of command - (cond ((shell-front-match "\\s *\\(\;\\|$\\)" str eoc) - "") ; no arg - ((shell-front-match "\\s +\\([^ \t\;]+\\)\\s *\\(\;\\|$\\)" - str eoc) - (substring str (match-beginning 1) (match-end 1))) ; arg - (t nil))))) ; something else. -;;; The first regexp is [optional whitespace, (";" or the end of string)]. -;;; The second regexp is [whitespace, (an arg), optional whitespace, -;;; (";" or end of string)]. - - -;;; popd [+n] -(defun shell-process-popd (arg) - (let ((num (if (zerop (length arg)) 0 ; no arg means +0 - (shell-extract-num arg)))) - (if (and num (< num (length shell-dirstack))) - (if (= num 0) ; condition-case because the CD could lose. - (condition-case nil (progn (cd (car shell-dirstack)) - (setq shell-dirstack - (cdr shell-dirstack)) - (shell-dirstack-message)) - (error (message "Couldn't cd."))) - (let* ((ds (cons nil shell-dirstack)) - (cell (nthcdr (- num 1) ds))) - (rplacd cell (cdr (cdr cell))) - (setq shell-dirstack (cdr ds)) - (shell-dirstack-message))) - (message "Bad popd.")))) - - -;;; cd [dir] -(defun shell-process-cd (arg) - (condition-case nil (progn (cd (if (zerop (length arg)) (getenv "HOME") - arg)) - (shell-dirstack-message)) - (error (message "Couldn't cd.")))) - - -;;; pushd [+n | dir] -(defun shell-process-pushd (arg) - (if (zerop (length arg)) - ;; no arg -- swap pwd and car of shell stack - (condition-case nil (if shell-dirstack - (let ((old default-directory)) - (cd (car shell-dirstack)) - (setq shell-dirstack - (cons old (cdr shell-dirstack))) - (shell-dirstack-message)) - (message "Directory stack empty.")) - (message "Couldn't cd.")) - - (let ((num (shell-extract-num arg))) - (if num ; pushd +n - (if (> num (length shell-dirstack)) - (message "Directory stack not that deep.") - (let* ((ds (cons default-directory shell-dirstack)) - (dslen (length ds)) - (front (nthcdr num ds)) - (back (reverse (nthcdr (- dslen num) (reverse ds)))) - (new-ds (append front back))) - (condition-case nil - (progn (cd (car new-ds)) - (setq shell-dirstack (cdr new-ds)) - (shell-dirstack-message)) - (error (message "Couldn't cd."))))) - - ;; pushd <dir> - (let ((old-wd default-directory)) - (condition-case nil - (progn (cd arg) - (setq shell-dirstack - (cons old-wd shell-dirstack)) - (shell-dirstack-message)) - (error (message "Couldn't cd.")))))))) - -;; If STR is of the form +n, for n>0, return n. Otherwise, nil. -(defun shell-extract-num (str) - (and (string-match "^\\+[1-9][0-9]*$" str) - (string-to-int str))) - - -(defun shell-dirtrack-toggle () - "Turn directory tracking on and off in a shell buffer." - (interactive) - (setq shell-dirtrackp (not shell-dirtrackp)) - (message "directory tracking %s." - (if shell-dirtrackp "ON" "OFF"))) - -;;; For your typing convenience: -(fset 'dirtrack-toggle 'shell-dirtrack-toggle) - - -(defun shell-resync-dirs () - "Resync the buffer's idea of the current directory stack. -This command queries the shell with the command bound to -shell-dirstack-query (default \"dirs\"), reads the next -line output and parses it to form the new directory stack. -DON'T issue this command unless the buffer is at a shell prompt. -Also, note that if some other subprocess decides to do output -immediately after the query, its output will be taken as the -new directory stack -- you lose. If this happens, just do the -command again." - (interactive) - (let* ((proc (get-buffer-process (current-buffer))) - (pmark (process-mark proc))) - (goto-char pmark) - (insert shell-dirstack-query) (insert "\n") - (sit-for 0) ; force redisplay - (comint-send-string proc shell-dirstack-query) - (comint-send-string proc "\n") - (set-marker pmark (point)) - (let ((pt (point))) ; wait for 1 line - ;; This extra newline prevents the user's pending input from spoofing us. - (insert "\n") (backward-char 1) - (while (not (looking-at ".+\n")) - (accept-process-output proc) - (goto-char pt))) - (goto-char pmark) (delete-char 1) ; remove the extra newline - ;; That's the dirlist. grab it & parse it. - (let* ((dl (buffer-substring (match-beginning 0) (- (match-end 0) 1))) - (dl-len (length dl)) - (ds '()) ; new dir stack - (i 0)) - (while (< i dl-len) - ;; regexp = optional whitespace, (non-whitespace), optional whitespace - (string-match "\\s *\\(\\S +\\)\\s *" dl i) ; pick off next dir - (setq ds (cons (substring dl (match-beginning 1) (match-end 1)) - ds)) - (setq i (match-end 0))) - (let ((ds (reverse ds))) - (condition-case nil - (progn (cd (car ds)) - (setq shell-dirstack (cdr ds)) - (shell-dirstack-message)) - (error (message "Couldn't cd."))))))) - -;;; For your typing convenience: -(fset 'dirs 'shell-resync-dirs) - - -;;; Show the current dirstack on the message line. -;;; Pretty up dirs a bit by changing "/usr/jqr/foo" to "~/foo". -;;; (This isn't necessary if the dirlisting is generated with a simple "dirs".) -;;; All the commands that mung the buffer's dirstack finish by calling -;;; this guy. -(defun shell-dirstack-message () - (let ((msg "") - (ds (cons default-directory shell-dirstack))) - (while ds - (let ((dir (car ds))) - (if (string-match (format "^%s\\(/\\|$\\)" (getenv "HOME")) dir) - (setq dir (concat "~/" (substring dir (match-end 0))))) - (if (string-equal dir "~/") (setq dir "~")) - (setq msg (concat msg dir " ")) - (setq ds (cdr ds)))) - (message msg))) - -(provide 'shell) - -;;; old-shell.el ends here diff --git a/lisp/sc-alist.el b/lisp/sc-alist.el deleted file mode 100644 index 31cb0a180ba..00000000000 --- a/lisp/sc-alist.el +++ /dev/null @@ -1,134 +0,0 @@ -;; -*- Mode: Emacs-Lisp -*- -;; sc-alist.el -- Version 1.0 (used to be baw-alist.el) - -;; association list utilities providing insertion, deletion, sorting -;; fetching off key-value pairs in association lists. - -;; ========== Disclaimer ========== -;; This software is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY. No author or distributor accepts -;; responsibility to anyone for the consequences of using it or for -;; whether it serves any particular purpose or works at all, unless he -;; says so in writing. - -;; This software was written as part of the supercite author's -;; official duty as an employee of the United States Government and is -;; thus in the public domain. You are free to use that particular -;; software as you wish, but WITHOUT ANY WARRANTY WHATSOEVER. It -;; would be nice, though if when you use any of this code, you give -;; due credit to the author. - -;; ========== Author (unless otherwise stated) ======================== -;; NAME: Barry A. Warsaw USMAIL: Century Computing, Inc. -;; TELE: (301) 593-3330 1014 West Street -;; INET: bwarsaw@cen.com Laurel, Md 20707 -;; UUCP: uunet!cen.com!bwarsaw -;; -(provide 'sc-alist) - - -(defun asort (alist-symbol key) - "Move a specified key-value pair to the head of an alist. -The alist is referenced by ALIST-SYMBOL. Key-value pair to move to -head is one matching KEY. Returns the sorted list and doesn't affect -the order of any other key-value pair. Side effect sets alist to new -sorted list." - (set alist-symbol - (sort (copy-alist (eval alist-symbol)) - (function (lambda (a b) (equal (car a) key)))))) - - -(defun aelement (key value) - "Makes a list of a cons cell containing car of KEY and cdr of VALUE. -The returned list is suitable as an element of an alist." - (list (cons key value))) - - -(defun aheadsym (alist) - "Return the key symbol at the head of ALIST." - (car (car alist))) - - -(defun anot-head-p (alist key) - "Find out if a specified key-value pair is not at the head of an alist. -The alist to check is specified by ALIST and the key-value pair is the -one matching the supplied KEY. Returns nil if ALIST is nil, or if -key-value pair is at the head of the alist. Returns t if key-value -pair is not at the head of alist. ALIST is not altered." - (not (equal (aheadsym alist) key))) - - -(defun aput (alist-symbol key &optional value) - "Inserts a key-value pair into an alist. -The alist is referenced by ALIST-SYMBOL. The key-value pair is made -from KEY and optionally, VALUE. Returns the altered alist or nil if -ALIST is nil. - -If the key-value pair referenced by KEY can be found in the alist, and -VALUE is supplied non-nil, then the value of KEY will be set to VALUE. -If VALUE is not supplied, or is nil, the key-value pair will not be -modified, but will be moved to the head of the alist. If the key-value -pair cannot be found in the alist, it will be inserted into the head -of the alist (with value nil if VALUE is nil or not supplied)." - (let ((elem (aelement key value)) - alist) - (asort alist-symbol key) - (setq alist (eval alist-symbol)) - (cond ((null alist) (set alist-symbol elem)) - ((anot-head-p alist key) (set alist-symbol (nconc elem alist))) - (value (setcar alist (car elem))) - (t alist)))) - - -(defun adelete (alist-symbol key) - "Delete a key-value pair from the alist. -Alist is referenced by ALIST-SYMBOL and the key-value pair to remove -is pair matching KEY. Returns the altered alist." - (asort alist-symbol key) - (let ((alist (eval alist-symbol))) - (cond ((null alist) nil) - ((anot-head-p alist key) alist) - (t (set alist-symbol (cdr alist)))))) - - -(defun aget (alist key &optional keynil-p) - "Returns the value in ALIST that is associated with KEY. -Optional KEYNIL-P describes what to do if the value associated with -KEY is nil. If KEYNIL-P is not supplied or is nil, and the value is -nil, then KEY is returned. If KEYNIL-P is non-nil, then nil would be -returned. - -If no key-value pair matching KEY could be found in ALIST, or ALIST is -nil then nil is returned. ALIST is not altered." - (let ((copy (copy-alist alist))) - (cond ((null alist) nil) - ((progn (asort 'copy key) - (anot-head-p copy key)) nil) - ((cdr (car copy))) - (keynil-p nil) - ((car (car copy))) - (t nil)))) - - -(defun amake (alist-symbol keylist &optional valuelist) - "Make an association list. -The association list is attached to the alist referenced by -ALIST-SYMBOL. Each element in the KEYLIST becomes a key and is -associated with the value in VALUELIST with the same index. If -VALUELIST is not supplied or is nil, then each key in KEYLIST is -associated with nil. - -KEYLIST and VALUELIST should have the same number of elements, but -this isn't enforced. If VALUELIST is smaller than KEYLIST, remaining -keys are associated with nil. If VALUELIST is larger than KEYLIST, -extra values are ignored. Returns the created alist." - (let ((keycar (car keylist)) - (keycdr (cdr keylist)) - (valcar (car valuelist)) - (valcdr (cdr valuelist))) - (cond ((null keycdr) - (aput alist-symbol keycar valcar)) - (t - (amake alist-symbol keycdr valcdr) - (aput alist-symbol keycar valcar)))) - (eval alist-symbol)) diff --git a/lisp/sc.el b/lisp/sc.el deleted file mode 100644 index 03eade6cba2..00000000000 --- a/lisp/sc.el +++ /dev/null @@ -1,1547 +0,0 @@ -;; -*- Mode: Emacs-Lisp -*- -;; sc.el -- Version 2.3 (used to be supercite.el) - -;; ========== Introduction ========== -;; Citation and attribution package for various GNU emacs news and -;; electronic mail reading subsystems. This version of supercite should -;; work with Rmail and GNUS as found in Emacs 19. It may also work with -;; VM 4.40+ and MH-E 3.7. - -;; This package does not do any yanking of messages, but instead -;; massages raw reply buffers set up by the reply/forward functions in -;; the news/mail subsystems. Therefore, such useful operations as -;; yanking and citing portions of the original article (instead of the -;; whole article) are not within the ability or responsibility of -;; supercite. - -;; ========== Disclaimer ========== -;; This software is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY. No author or distributor, nor any -;; author's past, present, or future employers accepts responsibility -;; to anyone for the consequences of using it or for whether it serves -;; any particular purpose or works at all, unless he says so in -;; writing. - -;; Some of this software was written as part of the supercite author's -;; official duty as an employee of the United States Government and is -;; thus not subject to copyright. You are free to use that particular -;; software as you wish, but WITHOUT ANY WARRANTY WHATSOEVER. It -;; would be nice, though if when you use any of this or other freely -;; available code, you give due credit to the author. - -;; Other parts of this code were written by other people. Wherever -;; possible, credit to that author, and the copy* notice supplied by -;; the author are included with that code. The supercite author is no -;; longer an employee of the U.S. Government so the GNU Public Licence -;; should be considered in effect for all enhancements and bug fixes -;; performed by the author. - -;; ========== Author (unless otherwise stated) ======================== -;; NAME: Barry A. Warsaw USMAIL: Century Computing, Inc. -;; TELE: (301) 593-3330 1014 West Street -;; INET: bwarsaw@cen.com Laurel, Md 20707 -;; UUCP: uunet!cen.com!bwarsaw -;; -;; Want to be on the Supercite mailing list? -;; -;; Send articles to: -;; Internet: supercite@anthem.nlm.nih.gov -;; UUCP: uunet!anthem.nlm.nih.gov!supercite -;; -;; Send administrivia (additions/deletions to list, etc) to: -;; Internet: supercite-request@anthem.nlm.nih.gov -;; UUCP: uunet!anthem.nlm.nih.gov!supercite-request - -;; ========== Credits and Thanks ========== -;; This package was derived from the Superyank 1.11 package as posted -;; to the net. Superyank 1.11 was inspired by code and ideas from -;; Martin Neitzel and Ashwin Ram. Supercite version 2.3 has evolved -;; through the comments and suggestions of the supercite mailing list -;; which consists of many authors and users of the various mail and -;; news reading subsystems. - -;; Many folks on the supercite mailing list have contributed their -;; help in debugging, making suggestions and supplying support code or -;; bug fixes for the previous versions of supercite. I want to thank -;; everyone who helped, especially (in no particular order): -;; -;; Mark D. Baushke, Khalid Sattar, David Lawrence, Chris Davis, Kyle -;; Jones, Kayvan Sylvan, Masanobu Umeda, Dan Jacobson, Piet van -;; Oostrum, Hamish (H.I.) Macdonald, and Joe Wells. -;; -;; I don't mean to leave anyone out. All who have helped have been -;; appreciated. - -;; ========== Getting Started ========== -;; Here is a quick guide to getting started with supercite. The -;; information contained here is mostly excerpted from the more -;; detailed explanations given in the accompanying README file. -;; Naturally, there are many customizations you can do to give your -;; replies that personalized flair, but the instructions in this -;; section should be sufficient for getting started. - -;; First, to connect supercite to any mail/news reading subsystem, put -;; this in your .emacs file: -;; -;; (setq mail-yank-hooks 'sc-cite-original) ; for old mail agents -;; (setq mh-yank-hooks 'sc-cite-original) ; for MH-E only -;; (add-hook 'mail-citation-hook 'sc-cite-original) ; for newer mail agents -;; -;; If supercite is not pre-loaded into your emacs session, you should -;; add the following autoload: -;; -;; (autoload 'sc-cite-original "sc" "Supercite 2.3" t) -;; -;; Finally, if you want to customize supercite, you should do it in a -;; function called my-supercite-hook and: -;; -;; (setq sc-load-hook 'my-supercite-hook) - -(require 'assoc) - - -;; vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv -;; start of user defined variables -;; vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv - -(defvar sc-nested-citation-p nil - "*Controls whether to use nested or non-nested citation style. -Non-nil uses nested citations, nil uses non-nested citations. Type -\\[sc-describe] for more information.") - -(defvar sc-citation-leader " " - "*String comprising first part of a citation.") - -(defvar sc-citation-delimiter ">" - "*String comprising third part of a citation. -This string is used in both nested and non-nested citations.") - -(defvar sc-citation-separator " " - "*String comprising fourth and last part of a citation.") - -(defvar sc-default-author-name "Anonymous" - "*String used when author's name cannot be determined.") - -(defvar sc-default-attribution "Anon" - "*String used when author's attribution cannot be determined.") - -;; Noriya KOBAYASHI (nk@ics.osaka-u.ac.jp) writes to the supercite -;; mailing list: -;; I use supercite in Nemacs-3.3.2. In order to handle citation using -;; Kanji, [...set sc-cite-regexp to...] -;; "\\s *\\([a-zA-Z0-9]\\|\\cc\\|\\cC\\|\\ch\\|\\cH\\|\\ck\\|\\cK\\)*\\s *>+" -;; -(defvar sc-cite-regexp "\\s *[-a-zA-Z0-9_.]*>+\\s *" - "*Regular expression describing how a already cited line begins. -The regexp is only used at the beginning of a line, so it doesn't need -to start with a '^'.") - -(defvar sc-titlecue-regexp "\\s +-+\\s +" - "*Regular expression describing the separator between names and titles. -Set to nil to treat entire field as a name.") - -(defvar sc-spacify-name-chars '(?_ ?* ?+ ?=) - "*List of characters to convert to spaces if found in an author's name.") - -(defvar sc-nicknames-alist - '(("Michael" "Mike") - ("Daniel" "Dan") - ("David" "Dave") - ("Jonathan" "John") - ("William" "Bill") - ("Elizabeth" "Beth") - ("Elizabeth" "Betsy") - ("Kathleen" "Kathy") - ("Smith" "Smitty")) - "*Association list of names and their common nicknames. -Entries are of the form (NAME NICKNAME), and NAMEs can have more than -one nickname. Nicknames will not be automatically used as an -attribution string, since I'm not sure this is really polite, but if a -name is glommed from the author name and presented in the attribution -string completion list, the matching nicknames will also be presented. -Set this variable to nil to defeat nickname expansions. Also note that -nicknames are not put in the supercite information alist.") - -(defvar sc-confirm-always-p t - "*If non-nil, always confirm attribution string before citing text body.") - -(defvar sc-preferred-attribution 'firstname - "*Specifies which part of the author's name becomes the attribution. -The value of this variable must be one of the following quoted symbols: - - emailname -- email terminus name - initials -- initials of author - firstname -- first name of author - lastname -- last name of author - middlename1 -- first middle name of author - middlename2 -- second middle name of author - ... - -Middle name indexes can be any positive integer greater than 0, though -it is unlikely that many authors will supply more than one middle -name, if that many.") - -(defvar sc-use-only-preference-p nil - "*Controls what happens when the preferred attribution cannot be found. -If non-nil, then sc-default-attribution will be used. If nil, then -some secondary scheme will be employed to find a suitable attribution -string.") - -(defvar sc-downcase-p nil - "*Non-nil means downcase the attribution and citation strings.") - -(defvar sc-rewrite-header-list - '((sc-no-header) - (sc-header-on-said) - (sc-header-inarticle-writes) - (sc-header-regarding-adds) - (sc-header-attributed-writes) - (sc-header-verbose) - (sc-no-blank-line-or-header) - ) - "*List of reference header rewrite functions. -The variable sc-preferred-header-style controls which function in this -list is chosen for automatic reference header insertions. Electric -reference mode will cycle through this list of functions. For more -information, type \\[sc-describe].") - -(defvar sc-preferred-header-style 1 - "*Index into sc-rewrite-header-list specifying preferred header style. -Index zero accesses the first function in the list.") - -(defvar sc-electric-references-p t - "*Use electric references if non-nil.") - -(defvar sc-electric-circular-p t - "*Treat electric references as circular if non-nil.") - -(defvar sc-mail-fields-list - '("date" "message-id" "subject" "newsgroups" "references" - "from" "return-path" "path" "reply-to" "organization" - "reply" ) - "*List of mail header whose values will be saved by supercite. -These values can be used in header rewrite functions by accessing them -with the sc-field function. Mail headers in this list are case -insensitive and do not require a trailing colon.") - -(defvar sc-mumble-string "" - "*Value returned by sc-field if chosen field cannot be found.") - -(defvar sc-nuke-mail-headers-p t - "*Nuke or don't nuke mail headers. -If non-nil, nuke mail headers after gleaning useful information from -them.") - -(defvar sc-reference-tag-string ">>>>> " - "*String used at the beginning of built-in reference headers.") - -(defvar sc-fill-paragraph-hook 'sc-fill-paragraph - "*Hook for filling a paragraph. -This hook gets executed when you fill a paragraph either manually or -automagically. It expects point to be within the extent of the -paragraph that is going to be filled. This hook allows you to use a -different paragraph filling package than the one supplied with -supercite.") - -(defvar sc-auto-fill-region-p nil - "*If non-nil, automatically fill each paragraph after it has been cited.") - -(defvar sc-auto-fill-query-each-paragraph-p nil - "*If non-nil, query before filling each paragraph. -No querying and no filling will be performed if sc-auto-fill-region-p -is set to nil.") - -(defvar sc-fixup-whitespace-p nil - "*If non-nil, delete all leading white space before citing.") - -(defvar sc-all-but-cite-p nil - "*If non-nil, sc-cite-original does everything but cite the text. -This is useful for manually citing large messages, or portions of -large messages. When non-nil, sc-cite-original will still set up all -necessary variables and databases, but will skip the citing routine -which modify the reply buffer's text.") - -(defvar sc-load-hook nil - "*User definable hook. -Runs after supercite is loaded. Set your customizations here.") - -(defvar sc-pre-hook nil - "*User definable hook. -Runs before sc-cite-original executes.") - -(defvar sc-post-hook nil - "*User definable hook. -Runs after sc-cite-original executes.") - -(defvar sc-header-nuke-list - '("via" "origin" "status" "received" "remailed" "cc" "sender" "replied" - "organization" "keywords" "distribution" "xref" "references" "expires" - "approved" "summary" "precedence" "subject" "newsgroup[s]?" - "\\(followup\\|apparently\\|errors\\|\\(\\(in-\\)?reply\\)?-\\)?to" - "x-[a-z0-9-]+" "[a-z-]*message-id" "\\(summary-\\)?line[s]" - "\\(\\(return\\|reply\\)-\\)?path" "\\(posted-\\)?date" - "\\(mail-\\)?from") - "*List of mail headers to remove from body of reply.") - - - -;; ====================================================================== -;; keymaps - -(defvar sc-default-keymap - '(lambda () - (local-set-key "\C-c\C-r" 'sc-insert-reference) - (local-set-key "\C-c\C-t" 'sc-cite) - (local-set-key "\C-c\C-a" 'sc-recite) - (local-set-key "\C-c\C-u" 'sc-uncite) - (local-set-key "\C-c\C-i" 'sc-insert-citation) - (local-set-key "\C-c\C-o" 'sc-open-line) - (local-set-key "\C-c\C-q" 'sc-fill-paragraph-manually) - (local-set-key "\C-cq" 'sc-fill-paragraph-manually) - (local-set-key "\C-c\C-m" 'sc-modify-information) - (local-set-key "\C-cf" 'sc-view-field) - (local-set-key "\C-cg" 'sc-glom-headers) - (local-set-key "\C-c\C-v" 'sc-version) - (local-set-key "\C-c?" 'sc-describe) - ) - "*Default keymap if major-mode can't be found in `sc-local-keymaps'.") - -(defvar sc-local-keymaps - '((mail-mode - (lambda () - (local-set-key "\C-c\C-r" 'sc-insert-reference) - (local-set-key "\C-c\C-t" 'sc-cite) - (local-set-key "\C-c\C-a" 'sc-recite) - (local-set-key "\C-c\C-u" 'sc-uncite) - (local-set-key "\C-c\C-i" 'sc-insert-citation) - (local-set-key "\C-c\C-o" 'sc-open-line) - (local-set-key "\C-c\C-q" 'sc-fill-paragraph-manually) - (local-set-key "\C-cq" 'sc-fill-paragraph-manually) - (local-set-key "\C-c\C-m" 'sc-modify-information) - (local-set-key "\C-cf" 'sc-view-field) - (local-set-key "\C-cg" 'sc-glom-headers) - (local-set-key "\C-c\C-v" 'sc-version) - (local-set-key "\C-c?" 'sc-describe) - )) - (mh-letter-mode - (lambda () - (local-set-key "\C-c\C-r" 'sc-insert-reference) - (local-set-key "\C-c\C-t" 'sc-cite) - (local-set-key "\C-c\C-a" 'sc-recite) - (local-set-key "\C-c\C-u" 'sc-uncite) - (local-set-key "\C-ci" 'sc-insert-citation) - (local-set-key "\C-c\C-o" 'sc-open-line) - (local-set-key "\C-cq" 'sc-fill-paragraph-manually) - (local-set-key "\C-c\C-m" 'sc-modify-information) - (local-set-key "\C-cf" 'sc-view-field) - (local-set-key "\C-cg" 'sc-glom-headers) - (local-set-key "\C-c\C-v" 'sc-version) - (local-set-key "\C-c?" 'sc-describe) - )) - (news-reply-mode mail-mode) - (vm-mail-mode mail-mode) - (e-reply-mode mail-mode) - (n-reply-mode mail-mode) - ) - "*List of keymaps to use with the associated major-mode.") - -(defvar sc-electric-mode-map nil - "*Keymap for sc-electric-mode.") - -(if sc-electric-mode-map - nil - (setq sc-electric-mode-map (make-sparse-keymap)) - (define-key sc-electric-mode-map "p" 'sc-eref-prev) - (define-key sc-electric-mode-map "n" 'sc-eref-next) - (define-key sc-electric-mode-map "s" 'sc-eref-setn) - (define-key sc-electric-mode-map "j" 'sc-eref-jump) - (define-key sc-electric-mode-map "x" 'sc-eref-abort) - (define-key sc-electric-mode-map "\r" 'sc-eref-exit) - (define-key sc-electric-mode-map "\n" 'sc-eref-exit) - (define-key sc-electric-mode-map "q" 'sc-eref-exit) - (define-key sc-electric-mode-map "g" 'sc-eref-goto) - ) - -;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -;; end of user defined variables -;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - - -;; ====================================================================== -;; global variables, not user accessible - -(defconst sc-version-number "2.3" - "Supercite's version number.") - -;; when rnewspost.el patch is installed (or function is overloaded) -;; this should be nil since supercite now does this itself. -(setq news-reply-header-hook nil) - -;; autoload for sc-electric-mode -(autoload 'sc-electric-mode "sc-elec" - "Quasi-major mode for viewing supercite reference headers." nil) - -;; global alists (gals), misc variables. make new bytecompiler happy -(defvar sc-gal-information nil - "Internal global alist variable containing information.") -(defvar sc-gal-attributions nil - "Internal global alist variable containing attributions.") -(defvar sc-fill-arg nil - "Internal fill argument holder.") -(defvar sc-cite-context nil - "Internal citation context holder.") -(defvar sc-force-confirmation-p nil - "Internal variable.") - -(make-variable-buffer-local 'sc-gal-attributions) -(make-variable-buffer-local 'sc-gal-information) -(make-variable-buffer-local 'sc-leached-keymap) -(make-variable-buffer-local 'sc-fill-arg) -(make-variable-buffer-local 'sc-cite-context) - -(setq-default sc-gal-attributions nil) -(setq-default sc-gal-information nil) -(setq-default sc-leached-keymap (current-local-map)) -(setq-default sc-fill-arg nil) -(setq-default sc-cite-context nil) - - - -;; ====================================================================== -;; miscellaneous support functions - -(defun sc-mark () - "Mark compatibility between emacs v18 and v19." - (let ((zmacs-regions nil)) - (marker-position (mark-marker)))) - -(defun sc-update-gal (attribution) - "Update the information alist. -Add ATTRIBUTION and compose the nested and non-nested citation -strings." - (let ((attrib (if sc-downcase-p (downcase attribution) attribution))) - (aput 'sc-gal-information "sc-attribution" attrib) - (aput 'sc-gal-information "sc-nested-citation" - (concat attrib sc-citation-delimiter)) - (aput 'sc-gal-information "sc-citation" - (concat sc-citation-leader - attrib - sc-citation-delimiter - sc-citation-separator)))) - -(defun sc-valid-index-p (index) - "Returns t if INDEX is a valid index into sc-rewrite-header-list." - (let ((last (1- (length sc-rewrite-header-list)))) - (and (natnump index) ;; a number, and greater than or equal to zero - (<= index last) ;; less than or equal to the last index - ))) - -(defun sc-string-car (namestring) - "Return the string-equivalent \"car\" of NAMESTRING. - - example: (sc-string-car \"John Xavier Doe\") - => \"John\"" - (substring namestring - (progn (string-match "\\s *" namestring) (match-end 0)) - (progn (string-match "\\s *\\S +" namestring) (match-end 0)))) - -(defun sc-string-cdr (namestring) - "Return the string-equivalent \"cdr\" of NAMESTRING. - - example: (sc-string-cdr \"John Xavier Doe\") - => \"Xavier Doe\"" - (substring namestring - (progn (string-match "\\s *\\S +\\s *" namestring) - (match-end 0)))) - -(defun sc-linepos (&optional position col-p) - "Return the character position at various line positions. -Optional POSITION can be one of the following symbols: - bol == beginning of line - boi == beginning of indentation - eol == end of line [default] - -Optional COL-P non-nil returns current-column instead of character position." - (let ((tpnt (point)) - rval) - (cond - ((eq position 'bol) (beginning-of-line)) - ((eq position 'boi) (back-to-indentation)) - (t (end-of-line))) - (setq rval (if col-p (current-column) (point))) - (goto-char tpnt) - rval)) - - -;; ====================================================================== -;; this section snarfs mail fields and places them in the info alist - -(defun sc-build-header-zap-regexp () - "Return a regexp for sc-mail-yank-clear-headers." - (let ((headers sc-header-nuke-list) - (regexp nil)) - (while headers - (setq regexp (concat regexp - "^" (car headers) ":" - (if (cdr headers) "\\|" nil))) - (setq headers (cdr headers))) - regexp)) - -(defun sc-mail-yank-clear-headers (start end) - "Nuke mail headers between START and END." - (if (and sc-nuke-mail-headers-p sc-header-nuke-list) - (let ((regexp (sc-build-header-zap-regexp))) - (save-excursion - (goto-char start) - (if (search-forward "\n\n" end t) - (save-restriction - (narrow-to-region start (point)) - (goto-char start) - (while (let ((case-fold-search t)) - (re-search-forward regexp nil t)) - (beginning-of-line) - (delete-region (point) - (progn (re-search-forward "\n[^ \t]") - (forward-char -1) - (point))) - ))) - )))) - -(defun sc-mail-fetch-field (field) - "Return the value of the header field FIELD. -The buffer is expected to be narrowed to just the headers of the -message." - (save-excursion - (goto-char (point-min)) - (let ((case-fold-search t) - (name (concat "^" (regexp-quote field) "[ \t]*:[ \t]*"))) - (goto-char (point-min)) - (if (re-search-forward name nil t) - (let ((opoint (point))) - (while (progn (forward-line 1) - (looking-at "[ \t]"))) - (buffer-substring opoint (1- (point)))))))) - -(defun sc-fetch-fields (start end) - "Fetch the mail fields in the region from START to END. -These fields can be accessed in header rewrite functions with sc-field." - (save-excursion - (save-restriction - (narrow-to-region start end) - (goto-char start) - (let ((fields sc-mail-fields-list)) - (while fields - (let ((value (sc-mail-fetch-field (car fields))) - (next (cdr fields))) - (and value - (aput 'sc-gal-information (car fields) value)) - (setq fields next))) - (if (sc-mail-fetch-field "from") - (aput 'sc-gal-information "from" (sc-mail-fetch-field "from"))))))) - -(defun sc-field (field) - "Return the alist information associated with the FIELD. -If FIELD is not a valid key, return sc-mumble-string." - (or (aget sc-gal-information field) sc-mumble-string)) - - -;; ====================================================================== -;; built-in reference header rewrite functions - -(defun sc-no-header () - "Does nothing. Use this instead of nil to get a blank header." - ()) - -(defun sc-no-blank-line-or-header() - "Similar to sc-no-header except it removes the preceding blank line." - (if (not (bobp)) - (if (and (eolp) - (progn (forward-line -1) - (or (looking-at mail-header-separator) - (and (eq major-mode 'mh-letter-mode) - (mh-in-header-p))))) - (progn (forward-line) - (let ((kill-lines-magic t)) (kill-line)))))) - -(defun sc-header-on-said () - "\"On <date>, <from> said:\", unless 1. the \"from\" field cannot be -found, in which case nothing is inserted; or 2. the \"date\" field is -missing in which case only the from part is printed." - (let* ((sc-mumble-string "") - (whofrom (sc-field "from")) - (when (sc-field "date"))) - (if (not (string= whofrom "")) - (insert sc-reference-tag-string - (if (not (string= when "")) - (concat "On " when ", ") "") - whofrom " said:\n")))) - -(defun sc-header-inarticle-writes () - "\"In article <message-id>, <from> writes:\" -Treats \"message-id\" and \"from\" fields similar to sc-header-on-said." - (let* ((sc-mumble-string "") - (whofrom (sc-field "from")) - (msgid (sc-field "message-id"))) - (if (not (string= whofrom "")) - (insert sc-reference-tag-string - (if (not (string= msgid "")) - (concat "In article " msgid ", ") "") - whofrom " writes:\n")))) - -(defun sc-header-regarding-adds () - "\"Regarding <subject>; <from> adds:\" -Treats \"subject\" and \"from\" fields similar to sc-header-on-said." - (let* ((sc-mumble-string "") - (whofrom (sc-field "from")) - (subj (sc-field "subject"))) - (if (not (string= whofrom "")) - (insert sc-reference-tag-string - (if (not (string= subj "")) - (concat "Regarding " subj "; ") "") - whofrom " adds:\n")))) - -(defun sc-header-attributed-writes () - "\"<sc-attribution>\" == <sc-author> <address> writes: -Treats these fields in a similar manner to sc-header-on-said." - (let* ((sc-mumble-string "") - (whofrom (sc-field "from")) - (reply (sc-field "sc-reply-address")) - (from (sc-field "sc-from-address")) - (attr (sc-field "sc-attribution")) - (auth (sc-field "sc-author"))) - (if (not (string= whofrom "")) - (insert sc-reference-tag-string - (if (not (string= attr "")) - (concat "\"" attr "\" == " ) "") - (if (not (string= auth "")) - (concat auth " ") "") - (if (not (string= reply "")) - (concat "<" reply ">") - (if (not (string= from "")) - (concat "<" from ">") "")) - " writes:\n")))) - -(defun sc-header-verbose () - "Very verbose, some say gross." - (let* ((sc-mumble-string "") - (whofrom (sc-field "from")) - (reply (sc-field "sc-reply-address")) - (from (sc-field "sc-from-address")) - (author (sc-field "sc-author")) - (date (sc-field "date")) - (org (sc-field "organization")) - (msgid (sc-field "message-id")) - (ngrps (sc-field "newsgroups")) - (subj (sc-field "subject")) - (refs (sc-field "references")) - (cite (sc-field "sc-citation")) - (nl sc-reference-tag-string)) - (if (not (string= whofrom "")) - (insert (if (not (string= date "")) - (concat nl "On " date ",\n") "") - (concat nl (if (not (string= author "")) - author - whofrom) "\n") - (if (not (string= org "")) - (concat nl "from the organization of " org "\n") "") - (if (not (string= reply "")) - (concat nl "who can be reached at: " reply "\n") - (if (not (string= from "")) - (concat nl "who can be reached at: " from "\n") "")) - (if (not (string= cite "")) - (concat nl "(whose comments are cited below with \"" - cite "\"),\n") "") - (if (not (string= msgid "")) - (concat nl "had this to say in article " msgid "\n") "") - (if (not (string= ngrps "")) - (concat nl "in newsgroups " ngrps "\n") "") - (if (not (string= subj "")) - (concat nl "concerning the subject of " subj "\n") "") - (if (not (string= refs "")) - (concat nl "(see " refs " for more details)\n") "") - )))) - - -;; ====================================================================== -;; this section queries the user for necessary information - -(defun sc-query (&optional default) - "Query for an attribution string with the optional DEFAULT choice. -Returns the string entered by the user, if non-empty and non-nil, or -DEFAULT otherwise. If DEFAULT is not supplied, sc-default-attribution -is used." - (if (not default) (setq default sc-default-attribution)) - (let* ((prompt (concat "Enter attribution string: (default " default ") ")) - (query (read-string prompt))) - (if (or (null query) - (string= query "")) - default - query))) - -(defun sc-confirm () - "Confirm the preferred attribution with the user." - (if (or sc-confirm-always-p - sc-force-confirmation-p) - (aput 'sc-gal-attributions - (let* ((default (aheadsym sc-gal-attributions)) - chosen - (prompt (concat "Complete " - (cond - ((eq sc-cite-context 'citing) "cite") - ((eq sc-cite-context 'reciting) "recite") - (t "")) - " attribution string: (default " - default ") ")) - (minibuffer-local-completion-map - (copy-keymap minibuffer-local-completion-map))) - (define-key minibuffer-local-completion-map "\C-g" - '(lambda () (interactive) (beep) (throw 'select-abort nil))) - (setq chosen (completing-read prompt sc-gal-attributions)) - (if (or (not chosen) - (string= chosen "")) - default - chosen))))) - - -;; ====================================================================== -;; this section contains primitive functions used in the email address -;; parsing schemes. they extract name fields from various parts of -;; the "from:" field. - -(defun sc-style1-addresses (from-string &optional delim) - "Extract the author's email terminus from email address FROM-STRING. -Match addresses of the style \"name%[stuff].\" when called with DELIM -of \"%\" and addresses of the style \"[stuff]name@[stuff]\" when -called with DELIM \"@\". If DELIM is nil or not provided, matches -addresses of the style \"name\"." - (and (string-match (concat "[a-zA-Z0-9_-]+" delim) from-string 0) - (substring from-string - (match-beginning 0) - (- (match-end 0) (if (null delim) 0 1))))) - -(defun sc-style2-addresses (from-string) - "Extract the author's email terminus from email address FROM-STRING. -Match addresses of the style \"[stuff]![stuff]...!name[stuff].\"" - (let ((eos (length from-string)) - (mstart (string-match "![a-zA-Z0-9_-]+\\([^!a-zA-Z0-9_-]\\|$\\)" - from-string 0)) - (mend (match-end 0))) - (and mstart - (substring from-string (1+ mstart) (- mend (if (= mend eos) 0 1))) - ))) - -(defun sc-get-address (from-string author) - "Get the full email address path from FROM-STRING. -AUTHOR is the author's name (which is removed from the address)." - (let ((eos (length from-string))) - (if (string-match (concat "\\(^\\|^\"\\)" author - "\\(\\s +\\|\"\\s +\\)") from-string 0) - (let ((addr (substring from-string (match-end 0) eos))) - (if (and (= (aref addr 0) ?<) - (= (aref addr (1- (length addr))) ?>)) - (substring addr 1 (1- (length addr))) - addr)) - (if (string-match "[a-zA-Z0-9!@%._-]+" from-string 0) - (substring from-string (match-beginning 0) (match-end 0)) - "") - ))) - -(defun sc-get-emailname (from-string) - "Get the email terminus name from FROM-STRING." - (cond - ((sc-style1-addresses from-string "%")) - ((sc-style1-addresses from-string "@")) - ((sc-style2-addresses from-string)) - ((sc-style1-addresses from-string nil)) - (t (substring from-string 0 10)))) - - -;; ====================================================================== -;; this section contains functions that will extract a list of names -;; from the name field string. - -(defun sc-spacify-name-chars (name) - (let ((len (length name)) - (s 0)) - (while (< s len) - (if (memq (aref name s) sc-spacify-name-chars) - (aset name s 32)) - (setq s (1+ s))) - name)) - -(defun sc-name-substring (string start end extend) - "Extract the specified substring of STRING from START to END. -EXTEND is the number of characters on each side to extend the -substring." - (and start - (let ((sos (+ start extend)) - (eos (- end extend))) - (substring string sos - (or (string-match sc-titlecue-regexp string sos) eos) - )))) - -(defun sc-extract-namestring (from-string) - "Extract the name string from FROM-STRING. -This should be the author's full name minus an optional title." - (let ((pstart (string-match "(.*)" from-string 0)) - (pend (match-end 0)) - (qstart (string-match "\".*\"" from-string 0)) - (qend (match-end 0)) - (bstart (string-match "\\([.a-zA-Z0-9_-]+\\s *\\)+" from-string 0)) - (bend (match-end 0))) - (sc-spacify-name-chars - (cond - ((sc-name-substring from-string pstart pend 1)) - ((sc-name-substring from-string qstart qend 1)) - ((sc-name-substring from-string bstart bend 0)) - )))) - -(defun sc-chop-namestring (namestring) - "Convert NAMESTRING to a list of names. - - example: (sc-namestring-to-list \"John Xavier Doe\") - => (\"John\" \"Xavier\" \"Doe\")" - (if (not (string= namestring "")) - (append (list (sc-string-car namestring)) - (sc-chop-namestring (sc-string-cdr namestring))))) - -(defun sc-strip-initials (namelist) - "Extract the author's initials from the NAMELIST." - (if (not namelist) - nil - (concat (if (string= (car namelist) "") - "" - (substring (car namelist) 0 1)) - (sc-strip-initials (cdr namelist))))) - - -;; ====================================================================== -;; this section handles selection of the attribution and citation strings - -(defun sc-populate-alists (from-string) - "Put important and useful information in the alists using FROM-STRING. -Return the list of name symbols." - (let* ((namelist (sc-chop-namestring (sc-extract-namestring from-string))) - (revnames (reverse (cdr namelist))) - (midnames (reverse (cdr revnames))) - (firstname (car namelist)) - (midnames (reverse (cdr revnames))) - (lastname (car revnames)) - (initials (sc-strip-initials namelist)) - (emailname (sc-get-emailname from-string)) - (n 1) - (symlist (list 'emailname 'initials 'firstname 'lastname))) - - ;; put basic information - (aput 'sc-gal-attributions 'firstname firstname) - (aput 'sc-gal-attributions 'lastname lastname) - (aput 'sc-gal-attributions 'emailname emailname) - (aput 'sc-gal-attributions 'initials initials) - - (aput 'sc-gal-information "sc-firstname" firstname) - (aput 'sc-gal-information "sc-lastname" lastname) - (aput 'sc-gal-information "sc-emailname" emailname) - (aput 'sc-gal-information "sc-initials" initials) - - ;; put middle names and build sc-author entry - (let ((author (concat firstname " "))) - (while midnames - (let ((name (car midnames)) - (next (cdr midnames)) - (symbol (intern (format "middlename%d" n))) - (string (format "sc-middlename-%d" n))) - ;; first put new middlename - (aput 'sc-gal-attributions symbol name) - (aput 'sc-gal-information string name) - (setq n (1+ n)) - (nconc symlist (list symbol)) - - ;; now build author name - (setq author (concat author name " ")) - - ;; incr loop - (setq midnames next) - )) - (setq author (concat author lastname)) - - ;; put author name and email address - (aput 'sc-gal-information "sc-author" author) - (aput 'sc-gal-information "sc-from-address" - (sc-get-address from-string author)) - (aput 'sc-gal-information "sc-reply-address" - (sc-get-address (sc-field "reply-to") author)) - ) - ;; return value - symlist)) - -(defun sc-sort-attribution-alist () - "Put preferred attribution at head of attributions alist." - (asort 'sc-gal-attributions sc-preferred-attribution) - - ;; use backup scheme if preference is not legal - (if (or (null sc-preferred-attribution) - (anot-head-p sc-gal-attributions sc-preferred-attribution) - (let ((prefval (aget sc-gal-attributions - sc-preferred-attribution))) - (or (null prefval) - (string= prefval "")))) - ;; no legal attribution - (if sc-use-only-preference-p - (aput 'sc-gal-attributions 'sc-user-query - (sc-query sc-default-attribution)) - ;; else use secondary scheme - (asort 'sc-gal-attributions 'firstname)))) - -(defun sc-build-attribution-alist (from-string) - "Extract attributions from FROM-STRING, applying preferences." - (let ((symlist (sc-populate-alists from-string)) - (headval (progn (sc-sort-attribution-alist) - (aget sc-gal-attributions - (aheadsym sc-gal-attributions) t)))) - - ;; for each element in the symlist, remove the corresponding - ;; key-value pair in the alist, then insert just the value. - (while symlist - (let ((value (aget sc-gal-attributions (car symlist) t)) - (next (cdr symlist))) - (if (not (or (null value) - (string= value ""))) - (aput 'sc-gal-attributions value)) - (adelete 'sc-gal-attributions (car symlist)) - (setq symlist next))) - - ;; add nicknames to the completion list - (let ((gal sc-gal-attributions)) - (while gal - (let ((nns sc-nicknames-alist) - (galname (car (car gal)))) - (while nns - (if (string= galname (car (car nns))) - (aput 'sc-gal-attributions (car (cdr (car nns))))) - (setq nns (cdr nns))) - (setq gal (cdr gal))))) - - ;; now reinsert the head (preferred) attribution unless it is nil, - ;; this effectively just moves the head value to the front of the - ;; list. - (if headval - (aput 'sc-gal-attributions headval)) - - ;; check to be sure alist is not nil - (if (null sc-gal-attributions) - (aput 'sc-gal-attributions sc-default-attribution)))) - -(defun sc-select () - "Select an attribution and create a citation string." - (cond - (sc-nested-citation-p - (sc-update-gal "")) - ((null (aget sc-gal-information "from" t)) - (aput 'sc-gal-information "sc-author" sc-default-author-name) - (sc-update-gal (sc-query sc-default-attribution))) - ((null sc-gal-attributions) - (sc-build-attribution-alist (aget sc-gal-information "from" t)) - (sc-confirm) - (sc-update-gal (aheadsym sc-gal-attributions))) - (t - (sc-confirm) - (sc-update-gal (aheadsym sc-gal-attributions)))) - t) - - -;; ====================================================================== -;; region citing and unciting - -(defun sc-cite-region (start end) - "Cite a region delineated by START and END." - (save-excursion - ;; set real end-of-region - (goto-char end) - (forward-line 1) - (set-mark (point)) - ;; goto real beginning-of-region - (goto-char start) - (beginning-of-line) - (let ((fstart (point)) - (fend (point))) - (while (< (point) (sc-mark)) - ;; remove leading whitespace if desired - (and sc-fixup-whitespace-p - (fixup-whitespace)) - ;; if end of line then perhaps autofill - (cond ((eolp) - (or (= fstart fend) - (not sc-auto-fill-region-p) - (and sc-auto-fill-query-each-paragraph-p - (not (y-or-n-p "Fill this paragraph? "))) - (save-excursion (set-mark fend) - (goto-char (/ (+ fstart fend 1) 2)) - (run-hooks 'sc-fill-paragraph-hook))) - (setq fstart (point) - fend (point))) - ;; not end of line so perhaps cite it - ((not (looking-at sc-cite-regexp)) - (insert (aget sc-gal-information "sc-citation"))) - (sc-nested-citation-p - (insert (aget sc-gal-information "sc-nested-citation")))) - (setq fend (point)) - (forward-line 1)) - (and sc-auto-fill-query-each-paragraph-p - (message " ")) - ))) - -(defun sc-uncite-region (start end cite-regexp) - "Uncite a previously cited region delineated by START and END. -CITE-REGEXP describes how a cited line of texts starts. Unciting also -auto-fills paragraph if sc-auto-fill-region-p is non-nil." - (save-excursion - (set-mark end) - (goto-char start) - (beginning-of-line) - (let ((fstart (point)) - (fend (point))) - (while (< (point) (sc-mark)) - ;; if end of line, then perhaps autofill - (cond ((eolp) - (or (= fstart fend) - (not sc-auto-fill-region-p) - (and sc-auto-fill-query-each-paragraph-p - (not (y-or-n-p "Fill this paragraph? "))) - (save-excursion (set-mark fend) - (goto-char (/ (+ fstart fend 1) 2)) - (run-hooks 'sc-fill-paragraph-hook))) - (setq fstart (point) - fend (point))) - ;; not end of line so perhaps uncite it - ((looking-at cite-regexp) - (save-excursion - (save-restriction - (narrow-to-region (sc-linepos 'bol) (sc-linepos)) - (beginning-of-line) - (delete-region (point-min) - (progn (re-search-forward cite-regexp - (point-max) - t) - (match-end 0))))))) - (setq fend (point)) - (forward-line 1))))) - - -;; ====================================================================== -;; this section contains paragraph filling support - -(defun sc-guess-fill-prefix (&optional literalp) - "Guess the fill prefix used on the current line. -Use various heuristics to find the fill prefix. Search begins on first -non-blank line after point. - - 1) If fill-prefix is already bound to the empty string, return - nil. - - 2) If fill-prefix is already bound, but not to the empty - string, return the value of fill-prefix. - - 3) If the current line starts with the last chosen citation - string, then that string is returned. - - 4) If the current line starts with a string matching the regular - expression sc-cite-regexp, return the match. Note that if - optional LITERALP is provided and non-nil, then the *string* - that matches the regexp is return. Otherwise, if LITERALP is - not provided or is nil, the *regexp* sc-cite-regexp is - returned. - - 5) If the current line starts with any number of characters, - followed by the sc-citation-delimiter and then white space, - that match is returned. See comment #4 above for handling of - LITERALP. - - 6) Nil is returned." - (save-excursion - ;; scan for first non-blank line in the region - (beginning-of-line) - (skip-chars-forward "\n\t ") - (beginning-of-line) - (let ((citation (aget sc-gal-information "sc-citation")) - (generic-citation - (concat "\\s *[^ \t\n" sc-citation-delimiter "]+>\\s +"))) - (cond - ((string= fill-prefix "") nil) ;; heuristic #1 - (fill-prefix) ;; heuristic #2 - ((looking-at (regexp-quote citation)) citation) ;; heuristic #3 - ((looking-at sc-cite-regexp) ;; heuristic #4 - (if literalp - (buffer-substring - (point) - (progn (re-search-forward (concat sc-cite-regexp "\\s *") - (point-max) nil) - (point))) - sc-cite-regexp)) - ((looking-at generic-citation) ;; heuristic #5 - (if literalp - (buffer-substring - (point) - (progn (re-search-forward generic-citation) (point))) - generic-citation)) - (t nil))))) ;; heuristic #6 - -(defun sc-consistent-cite-p (prefix) - "Check current paragraph for consistent citation. -Scans to paragraph delineated by (forward|backward)-paragraph to see -if all lines start with PREFIX. Returns t if entire paragraph is -consistently cited, nil otherwise." - (save-excursion - (let ((end (progn (forward-paragraph) - (beginning-of-line) - (or (not (eolp)) - (forward-char -1)) - (point))) - (start (progn (backward-paragraph) - (beginning-of-line) - (or (not (eolp)) - (forward-char 1)) - (point))) - (badline t)) - (goto-char start) - (beginning-of-line) - (while (and (< (point) end) - badline) - (setq badline (looking-at prefix)) - (forward-line 1)) - badline))) - -(defun sc-fill-start (fill-prefix) - "Find buffer position of start of region which begins with FILL-PREFIX. -Restrict scan to current paragraph." - (save-excursion - (let ((badline nil) - (top (save-excursion - (backward-paragraph) - (beginning-of-line) - (or (not (eolp)) - (forward-char 1)) - (point)))) - (while (and (not badline) - (> (point) top)) - (forward-line -1) - (setq badline (not (looking-at fill-prefix))))) - (forward-line 1) - (point))) - -(defun sc-fill-end (fill-prefix) - "Find the buffer position of end of region which begins with FILL-PREFIX. -Restrict scan to current paragraph." - (save-excursion - (let ((badline nil) - (bot (save-excursion - (forward-paragraph) - (beginning-of-line) - (or (not (eolp)) - (forward-char -1)) - (point)))) - (while (and (not badline) - (< (point) bot)) - (beginning-of-line) - (setq badline (not (looking-at fill-prefix))) - (forward-line 1))) - (forward-line -1) - (point))) - -(defun sc-fill-paragraph () - "Supercite's paragraph fill function. -Fill the paragraph containing or following point. Use -sc-guess-fill-prefix to find the fill-prefix for the paragraph. - -If the paragraph is inconsistently cited (mixed fill-prefix), then the -user is queried to restrict the the fill to only those lines around -point which begin with the fill prefix. - -The variable sc-fill-arg is passed to fill-paragraph and -fill-region-as-paragraph which controls justification of the -paragraph. sc-fill-arg is set by sc-fill-paragraph-manually." - (save-excursion - (let ((pnt (point)) - (fill-prefix (sc-guess-fill-prefix t))) - (cond - ((not fill-prefix) - (fill-paragraph sc-fill-arg)) - ((sc-consistent-cite-p fill-prefix) - (fill-paragraph sc-fill-arg)) - ((y-or-n-p "Inconsistent citation found. Restrict? ") - (message "") - (fill-region-as-paragraph (progn (goto-char pnt) - (sc-fill-start fill-prefix)) - (progn (goto-char pnt) - (sc-fill-end fill-prefix)) - sc-fill-arg)) - (t - (message "") - (progn - (setq fill-prefix (aget sc-gal-information "sc-citation")) - (fill-paragraph sc-fill-arg))))))) - - -;; ====================================================================== -;; the following functions are the top level, interactive commands that -;; can be bound to key strokes - -(defun sc-insert-reference (arg) - "Insert, at point, a reference header in the body of the reply. -Numeric ARG indicates which header style from sc-rewrite-header-list -to use when rewriting the header. No supplied ARG indicates use of -sc-preferred-header-style. - -With just \\[universal-argument], electric reference insert mode is -entered, regardless of the value of sc-electric-references-p. See -sc-electric-mode for more information." - (interactive "P") - (if (consp arg) - (sc-electric-mode) - (let ((pref (cond ((sc-valid-index-p arg) arg) - ((sc-valid-index-p sc-preferred-header-style) - sc-preferred-header-style) - (t 0)))) - (if sc-electric-references-p (sc-electric-mode pref) - (condition-case err - (eval (nth pref sc-rewrite-header-list)) - (void-function - (progn (message - "Symbol's function definition is void: %s. (Header %d)." - (symbol-name (car (cdr err))) - pref) - (beep))) - (error - (progn (message "Error evaluating rewrite header function %d." - pref) - (beep))) - ))))) - -(defun sc-cite (arg) - "Cite the region of text between point and mark. -Numeric ARG, if supplied, is passed unaltered to sc-insert-reference." - (interactive "P") - (if (not (sc-mark)) - (error "Please designate a region to cite (i.e. set the mark).")) - (catch 'select-abort - (let ((sc-cite-context 'citing) - (sc-force-confirmation-p (interactive-p))) - (sc-select) - (undo-boundary) - (let ((xchange (if (> (sc-mark) (point)) nil - (exchange-point-and-mark) - t))) - (sc-insert-reference arg) - (sc-cite-region (point) (sc-mark)) - ;; leave point on first cited line - (while (and (< (point) (sc-mark)) - (not (looking-at (aget sc-gal-information - (if sc-nested-citation-p - "sc-nested-citation" - "sc-citation"))))) - (forward-line 1)) - (and xchange - (exchange-point-and-mark)) - )))) - -(defun sc-uncite () - "Uncite the region between point and mark." - (interactive) - (if (not (sc-mark)) - (error "Please designate a region to uncite (i.e. set the mark).")) - (undo-boundary) - (let ((xchange (if (> (sc-mark) (point)) nil - (exchange-point-and-mark) - t)) - (fp (or (sc-guess-fill-prefix) - ""))) - (sc-uncite-region (point) (sc-mark) fp) - (and xchange - (exchange-point-and-mark)))) - -(defun sc-recite () - "Recite the region by first unciting then citing the text." - (interactive) - (if (not (sc-mark)) - (error "Please designate a region to recite (i.e. set the mark).")) - (catch 'select-abort - (let ((sc-cite-context 'reciting) - (sc-force-confirmation-p t)) - (sc-select) - (undo-boundary) - (let ((xchange (if (> (sc-mark) (point)) nil - (exchange-point-and-mark) - t)) - (fp (or (sc-guess-fill-prefix) - ""))) - (sc-uncite-region (point) (sc-mark) fp) - (sc-cite-region (point) (sc-mark)) - (and xchange - (exchange-point-and-mark)) - )))) - -(defun sc-insert-citation () - "Insert citation string at beginning of current line." - (interactive) - (save-excursion - (beginning-of-line) - (insert (aget sc-gal-information "sc-citation")))) - -(defun sc-open-line (arg) - "Insert a newline and leave point before it. -Also inserts the guessed prefix at the beginning of the new line. With -numeric ARG, inserts that many new lines." - (interactive "p") - (save-excursion - (let ((start (point)) - (string (or (sc-guess-fill-prefix t) - ""))) - (open-line arg) - (goto-char start) - (forward-line 1) - (while (< 0 arg) - (insert string) - (forward-line 1) - (setq arg (- arg 1)))))) - -(defun sc-fill-paragraph-manually (arg) - "Fill current cited paragraph. -Really just runs the hook sc-fill-paragraph-hook, however it does set -the global variable sc-fill-arg to the value of ARG. This is -currently the only way to pass an argument to a hookified function." - (interactive "P") - (setq sc-fill-arg arg) - (run-hooks 'sc-fill-paragraph-hook)) - -(defun sc-modify-information (arg) - "Interactively modify information in the information alist. -\\[universal-argument] if supplied, deletes the entry from the alist. -You can add an entry by supplying a key instead of completing." - (interactive "P") - (let* ((delete-p (consp arg)) - (action (if delete-p "delete" "modify")) - (defaultkey (aheadsym sc-gal-information)) - (prompt (concat "Select information key to " - action ": (default " - defaultkey ") ")) - (key (completing-read prompt sc-gal-information)) - ) - (if (or (string= key "") - (null key)) - (setq key defaultkey)) - (if delete-p (adelete 'sc-gal-information key) - (let* ((oldval (aget sc-gal-information key t)) - (prompt (concat "Enter new value for key \"" - key "\" (default \"" oldval "\") ")) - (newval (read-input prompt))) - (if (or (string= newval "") - (null newval)) - nil - (aput 'sc-gal-information key newval) - ))))) - -(defun sc-view-field (arg) - "View field values in the information alist. -This is essentially an interactive version of sc-field, and is similar -to sc-modify-information, except that the field values can't be -modified. With \\[universal-argument], if supplied, inserts the value -into the current buffer as well." - (interactive "P") - (let* ((defaultkey (aheadsym sc-gal-information)) - (prompt (concat "View information key: (default " - defaultkey ") ")) - (key (completing-read prompt sc-gal-information))) - (if (or (string= key "") - (null key)) - (setq key defaultkey)) - (let* ((val (aget sc-gal-information key t)) - (pval (if val (concat "\"" val "\"") "nil"))) - (message "value of key %s: %s" key pval) - (if (and key (consp arg)) (insert val))))) - -(defun sc-glom-headers () - "Glom information from mail headers in region between point and mark. -Any old information is lost, unless an error occurs." - (interactive) - (let ((attr (copy-sequence sc-gal-attributions)) - (info (copy-sequence sc-gal-information))) - (setq sc-gal-attributions nil - sc-gal-information nil) - (let (start end - (sc-force-confirmation-p t) - (sc-cite-context nil)) - (let ((mark-active t)) - (setq start (region-beginning) - end (region-end))) - (sc-fetch-fields start end) - (if (null sc-gal-information) - (progn - (message "No mail headers found! Restoring old information.") - (setq sc-gal-attributions attr - sc-gal-information info)) - (sc-mail-yank-clear-headers start end) - (if (not (catch 'select-abort - (condition-case foo - (sc-select) - (quit (beep) (throw 'select-abort nil))) - )) - (setq sc-gal-attributions attr - sc-gal-information info)) - )))) - -(defun sc-version (arg) - "Show supercite version. -Universal argument (\\[universal-argument]) ARG inserts version -information in the current buffer instead of printing the message in -the echo area." - (interactive "P") - (if (consp arg) - (insert "Using Supercite version " sc-version-number) - (message "Using Supercite version %s" sc-version-number))) - - -;; ====================================================================== -;; leach onto current mode - -(defun sc-append-current-keymap () - "Append some useful key bindings to the current local key map. -This searches sc-local-keymap for the keymap to install based on the -major-mode of the current buffer." - (let ((hook (car (cdr (assq major-mode sc-local-keymaps))))) - (cond - ((not hook) - (run-hooks 'sc-default-keymap)) - ((not (listp hook)) - (setq hook (car (cdr (assq hook sc-local-keymaps)))) - (run-hooks 'hook)) - (t - (run-hooks 'hook)))) - (setq sc-leached-keymap (current-local-map))) - -(defun sc-snag-all-keybindings () - "Snag all keybindings in major-mode's current keymap." - (let* ((curkeymap (current-local-map)) - (symregexp ".*sc-.*\n") - (docstring (substitute-command-keys "\\{curkeymap}")) - (start 0) - (maxend (length docstring)) - (spooge "")) - (while (and (< start maxend) - (string-match symregexp docstring start)) - (setq spooge (concat spooge (substring docstring - (match-beginning 0) - (match-end 0)))) - (setq start (match-end 0))) - spooge)) - -(defun sc-spoogify-docstring () - "Modifies (makes into spooge) the docstring for the current major mode. -This will leach the keybinding descriptions for supercite onto the end -of the current major mode's docstring. If major mode is preloaded, -this function will first make a copy of the list associated with the -mode, then modify this copy." - (let* ((symfunc (symbol-function major-mode)) - (doc-cdr (and (listp symfunc) (nthcdr 2 symfunc))) - (doc-str (documentation major-mode))) - (cond - ;; is a docstring even provided? - ((not (stringp doc-str))) - ;; have we already leached on? - ((string-match "Supercite" doc-str)) - ;; lets build the new doc string - (t - (let* ((described (sc-snag-all-keybindings)) - (commonstr " - -The major mode for this buffer has been modified to include the -Supercite 2.3 package for handling attributions and citations of -original messages in email replies. For more information on this -package, type \"\\[sc-describe]\".") - (newdoc-str - (concat doc-str commonstr - (if (not (string= described "")) - (concat "\n\nThe following keys are bound " - "to Supercite commands:\n\n" - described))) - )) - (cond - (doc-cdr - (condition-case nil - (setcar doc-cdr newdoc-str) - (error - ;; the major mode must be preloaded, make a copy first - (setq symfunc (copy-sequence (symbol-function major-mode)) - doc-cdr (nthcdr 2 symfunc)) - (setcar doc-cdr newdoc-str) - (fset major-mode symfunc)))) - ;; lemacs 19 byte-code. - ;; Set function to a new byte-code vector with the - ;; new documentation in the documentation slot (element 4). - ;; We can't use aset because aset won't allow you to modify - ;; a byte-code vector. - ;; Include element 5 if the vector has one. - (t - (fset major-mode - (apply 'make-byte-code - (aref symfunc 0) (aref symfunc 1) - (aref symfunc 2) (aref symfunc 3) - newdoc-str - (if (> (length symfunc) 5) - (list (aref symfunc 5))))) - ))))))) - - -;; ====================================================================== -;; this section contains default hooks and hook support for execution - -;;;###autoload -(defun sc-cite-original () - "Hook version of sc-cite. -This is callable from the various mail and news readers' reply -function according to the agreed upon standard. See \\[sc-describe] -for more details. Sc-cite-original does not do any yanking of the -original message but it does require a few things: - - 1) The reply buffer is the current buffer. - - 2) The original message has been yanked and inserted into the - reply buffer. - - 3) Verbose mail headers from the original message have been - inserted into the reply buffer directly before the text of the - original message. - - 4) Point is at the beginning of the verbose headers. - - 5) Mark is at the end of the body of text to be cited." - (run-hooks 'sc-pre-hook) - (setq sc-gal-attributions nil) - (setq sc-gal-information nil) - (let (start end) - (let ((mark-active t)) - (setq start (region-beginning) - end (region-end))) - (sc-fetch-fields start end) - (sc-mail-yank-clear-headers start end) - (if (not sc-all-but-cite-p) - (sc-cite sc-preferred-header-style)) - (sc-append-current-keymap) - (sc-spoogify-docstring) - (run-hooks 'sc-post-hook))) - - -;; ====================================================================== -;; describe this package -;; -(defun sc-describe () - "Supercite version 2.3 is now described in a texinfo manual which -makes the documentation available both for online perusal via emacs' -info system, or for hard-copy printing using the TeX facility. - -To view the online document hit \\[info], then \"mSupercite <RET>\"." - (interactive) - (describe-function 'sc-describe)) - -;; ====================================================================== -;; load hook -(run-hooks 'sc-load-hook) -(provide 'sc) diff --git a/lisp/sc.elec.el b/lisp/sc.elec.el deleted file mode 100644 index 67f18c66a5e..00000000000 --- a/lisp/sc.elec.el +++ /dev/null @@ -1,198 +0,0 @@ -;; -*- Mode: Emacs-Lisp -*- -;; sc-elec.el -- Version 2.3 - -;; ========== Introduction ========== -;; This file contains sc-electric mode for viewing reference headers. -;; It is loaded automatically by supercite.el when needed. - -;; ========== Disclaimer ========== -;; This software is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY. No author or distributor accepts -;; responsibility to anyone for the consequences of using it or for -;; whether it serves any particular purpose or works at all, unless he -;; says so in writing. - -;; Some of this software was written as part of the supercite author's -;; official duty as an employee of the United States Government and is -;; thus in the public domain. You are free to use that particular -;; software as you wish, but WITHOUT ANY WARRANTY WHATSOEVER. It -;; would be nice, though if when you use any of this code, you give -;; due credit to the author. - -;; Other parts of this code were written by other people. Wherever -;; possible, credit to that author, and the copy* notice supplied by -;; the author are included with that code. In all cases, the spirit, -;; if not the letter of the GNU General Public Licence applies. - -;; ========== Author (unless otherwise stated) ========== -;; NAME: Barry A. Warsaw USMAIL: Century Computing, Inc. -;; TELE: (301) 593-3330 1014 West Street -;; UUCP: uunet!cen.com!bwarsaw Laurel, MD 20707 -;; INET: bwarsaw@cen.com - -;; Want to be on the Supercite mailing list? -;; -;; Send articles to: -;; INET: supercite@anthem.nlm.nih.gov -;; UUCP: uunet!anthem.nlm.nih.gov!supercite -;; -;; Send administrivia (additions/deletions to list, etc) to: -;; INET: supercite-request@anthem.nlm.nih.gov -;; UUCP: uunet!anthem.nlm.nih.gov!supercite-request -;; -(provide 'sc-elec) - - -;; ====================================================================== -;; set up vars for major mode - -(defconst sc-electric-bufname "*sc-erefs*" - "*Supercite's electric buffer name.") - - -(defvar sc-electric-mode-hook nil - "*Hook for sc-electric-mode.") - - - -;; ====================================================================== -;; sc-electric-mode - -(defun sc-electric-mode (&optional arg) - "Quasi major mode for viewing supercite reference headers. -Commands are: \\{sc-electric-mode-map} -Sc-electric-mode is not intended to be run interactively, but rather -accessed through supercite's electric reference feature. See -sc-insert-reference for more details. Optional ARG is the initial -header style to use, unless not supplied or invalid, in which case -sc-preferred-header-style is used." - (let ((gal sc-gal-information) - (sc-eref-style (if arg ;; assume passed arg is okay - arg - (if (and (natnump sc-preferred-header-style) - (sc-valid-index-p sc-preferred-header-style)) - sc-preferred-header-style - 0)))) - (get-buffer-create sc-electric-bufname) - ;; set up buffer and enter command loop - (save-excursion - (save-window-excursion - (pop-to-buffer sc-electric-bufname) - (kill-all-local-variables) - (setq sc-gal-information gal - buffer-read-only t - mode-name "Supercite-Electric-References" - major-mode 'sc-electric-mode) - (use-local-map sc-electric-mode-map) - (sc-eref-show sc-eref-style) - (run-hooks 'sc-electric-mode-hook) - (recursive-edit) - )) - (if sc-eref-style - (condition-case nil - (eval (nth sc-eref-style sc-rewrite-header-list)) - (error nil) - )) - ;; now restore state - (kill-buffer sc-electric-bufname) - )) - - - -;; ====================================================================== -;; functions for electric mode - -(defun sc-eref-index (index) - "Check INDEX to be sure it is a valid index into sc-rewrite-header-list. -If sc-electric-circular-p is non-nil, then list is considered circular -so that movement across the ends of the list wraparound." - (let ((last (1- (length sc-rewrite-header-list)))) - (cond ((sc-valid-index-p index) index) - ((< index 0) - (if sc-electric-circular-p last - (progn (error "No preceding reference headers in list.") 0))) - ((> index last) - (if sc-electric-circular-p 0 - (progn (error "No following reference headers in list.") last))) - ) - )) - - -(defun sc-eref-show (index) - "Show reference INDEX in sc-rewrite-header-list." - (setq sc-eref-style (sc-eref-index index)) - (save-excursion - (set-buffer sc-electric-bufname) - (let ((ref (nth sc-eref-style sc-rewrite-header-list)) - (buffer-read-only nil)) - (erase-buffer) - (goto-char (point-min)) - (condition-case err - (progn - (set-mark (point-min)) - (eval ref) - (message "Showing reference header %d." sc-eref-style) - (goto-char (point-max)) - ) - (void-function - (progn (message - "Symbol's function definition is void: %s (Header %d)" - (symbol-name (car (cdr err))) - sc-eref-style) - (beep) - )) - )))) - - - -;; ====================================================================== -;; interactive commands - -(defun sc-eref-next () - "Display next reference in other buffer." - (interactive) - (sc-eref-show (1+ sc-eref-style))) - - -(defun sc-eref-prev () - "Display previous reference in other buffer." - (interactive) - (sc-eref-show (1- sc-eref-style))) - - -(defun sc-eref-setn () - "Set reference header selected as preferred." - (interactive) - (setq sc-preferred-header-style sc-eref-style) - (message "Preferred reference style set to header %d." sc-eref-style)) - - -(defun sc-eref-goto (refnum) - "Show reference style indexed by REFNUM. -If REFNUM is an invalid index, don't go to that reference and return -nil." - (interactive "NGoto Reference: ") - (if (sc-valid-index-p refnum) - (sc-eref-show refnum) - (error "Invalid reference: %d. (Range: [%d .. %d])" - refnum 0 (1- (length sc-rewrite-header-list))) - )) - - -(defun sc-eref-jump () - "Set reference header to preferred header." - (interactive) - (sc-eref-show sc-preferred-header-style)) - - -(defun sc-eref-abort () - "Exit from electric reference mode without inserting reference." - (interactive) - (setq sc-eref-style nil) - (exit-recursive-edit)) - - -(defun sc-eref-exit () - "Exit from electric reference mode and insert selected reference." - (interactive) - (exit-recursive-edit)) diff --git a/lisp/setaddr.el b/lisp/setaddr.el deleted file mode 100644 index 1ae72ef6cb5..00000000000 --- a/lisp/setaddr.el +++ /dev/null @@ -1,71 +0,0 @@ -;;; setaddr.el --- determine whether sendmail is configured on this machine - -;; Copyright (C) 1997 Free Software Foundation, Inc. - -;; Maintainer: FSF -;; Keywords: mail - -;; 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: - -;; If neither sendmail nor Emacs knows what host address to use -;; for this machine, ask for it, and save it in site-start.el -;; so we won't have to ask again. - -;; This uses a heuristic about the output from sendmail -;; which may or may not really work. We will have to find -;; out by experiment. - -;;; Code: - -(or mail-host-address - (let (sendmail-configured) - (with-temp-buffer " mail-host-address" - (call-process sendmail-program nil t nil "-bv" "root") - (goto-char (point-min)) - (setq sendmail-configured (looking-at "root@"))) - (or sendmail-configured - (let (buffer) - (setq mail-host-address - (read-string "Specify your host's fully qualified domain name: "))) - ;; Create an init file, and if we just read mail-host-address, - ;; make the init file set it. - (unwind-protect - (save-excursion - (set-buffer (find-file-noselect "site-start.el")) - (setq buffer (current-buffer)) - ;; Get rid of the line that ran this file. - (if (search-forward "(load \"setaddr\")\n") - (progn - (beginning-of-line) - (delete-region (point) - (progn (end-of-line) - (point))))) - ;; Add the results - (goto-char (point-max)) - (insert "\n(setq mail-host-address " - (prin1-to-string mail-host-address) - ")\n") - (condition-case nil - (save-buffer) - (file-error nil))) - (if buffer - (kill-buffer buffer)))))) - -;;; setaddr.el ends here diff --git a/lisp/sun-keys.el b/lisp/sun-keys.el deleted file mode 100644 index f91abc2063f..00000000000 --- a/lisp/sun-keys.el +++ /dev/null @@ -1,77 +0,0 @@ -;;; sun-keys.el --- support for Sun function keys - -;;; Copyright (C) 1986 Free Software Foundation, Inc. - -;; Author: Ian G. Batten <batten@uk.ac.bham.multics> -;; Keywords: terminals - -;;; 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, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; Commentary: - -;;; Support (cleanly) for Sun function keys. Provides help facilities, -;;; better diagnostics, etc. -;;; -;;; To use: make sure your .ttyswrc binds 'F1' to <ESC> * F1 <CR> and so on. -;;; load this lot from your start_up - -;;; Code: - -(defun sun-function-keys-dispatch (arg) - "Dispatcher for function keys." - (interactive "p") - (let* ((key-stroke (read t)) - (command (assq key-stroke sun-function-keys-command-list))) - (cond (command (funcall (cdr command) arg)) - (t (error "Unbound function key %s" key-stroke))))) - -(defvar sun-function-keys-command-list - '((F1 . sun-function-keys-describe-bindings) - (R8 . previous-line) ; arrow keys - (R10 . backward-char) - (R12 . forward-char) - (R14 . next-line))) - -(defun sun-function-keys-bind-key (arg1 arg2) - "Bind a specified key." - (interactive "xFunction Key Cap Label: -CCommand To Use:") - (setq sun-function-keys-command-list - (cons (cons arg1 arg2) sun-function-keys-command-list))) - -(defun sun-function-keys-describe-bindings (arg) - "Describe the function key bindings we're running" - (interactive) - (with-output-to-temp-buffer "*Help*" - (sun-function-keys-write-bindings - (sort (copy-sequence sun-function-keys-command-list) - '(lambda (x y) (string-lessp (car x) (car y))))))) - -(defun sun-function-keys-write-bindings (list) - (cond ((null list) - t) - (t - (princ (format "%s: %s\n" - (car (car list)) - (cdr (car list)))) - (sun-function-keys-write-bindings (cdr list))))) - -(global-set-key "\e*" 'sun-function-keys-dispatch) - -(make-variable-buffer-local 'sun-function-keys-command-list) - -;;; sun-keys.el ends here diff --git a/lisp/superyank.el b/lisp/superyank.el deleted file mode 100644 index f76e6c7c3bf..00000000000 --- a/lisp/superyank.el +++ /dev/null @@ -1,1243 +0,0 @@ -;;; superyank.el --- smart message-yanking code for GNUS - -;; Copyright (C) 1992 Free Software Foundation, Inc. - -;; Author: Barry A. Warsaw <warsaw@cme.nist.gov> -;; Version: 1.1 -;; Adapted-By: ESR -;; 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, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; Commentary: - -;; Inserts the message being replied to with various user controlled -;; citation styles. -;; - -;; This file is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY. No author or distributor -;; accepts responsibility to anyone for the consequences of using it -;; or for whether it serves any particular purpose or works at all, -;; unless he says so in writing. Refer to the GNU Emacs General Public -;; License for full details. - -;; Everyone is granted permission to copy, modify and redistribute -;; this file, but only under the conditions described in the -;; GNU Emacs General Public License. A copy of this license is -;; supposed to have been given to you along with GNU Emacs so you -;; can know your rights and responsibilities. It should be in a -;; file named COPYING. Among other things, the copyright notice -;; and this notice must be preserved on all copies. - -;; NAME: Barry A. Warsaw USMAIL: National Institute of Standards -;; TELE: (301) 975-3460 and Technology (formerly NBS) -;; UUCP: {...}!uunet!cme-durer!warsaw Rm. B-124, Bldg. 220 -;; ARPA: warsaw@cme.nist.gov Gaithersburg, MD 20899 - -;; Modification history: -;; -;; modified: 14-Jun-1989 baw (better keymap set procedure, rewrite-headers) -;; modified: 12-Jun-1989 baw (added defvar for sy-use-only-preference-p) -;; modified: 6-Jun-1989 baw (better sy-rewrite-headers, no kill/yank) -;; modified: 5-Jun-1989 baw (requires rnewspost.el) -;; modified: 1-Jun-1989 baw (persistent attribution, sy-open-line) -;; modified: 31-May-1989 baw (fixed some gnus problems, id'd another) -;; modified: 22-May-1989 baw (documentation) -;; modified: 8-May-1989 baw (auto filling of regions) -;; modified: 1-May-1989 baw (documentation) -;; modified: 27-Apr-1989 baw (new preference scheme) -;; modified: 24-Apr-1989 baw (remove gnus headers, attrib scheme, cite lines) -;; modified: 19-Apr-1989 baw (cite key, fill p, yank region, naming scheme) -;; modified: 12-Apr-1989 baw (incorp other mail yank features seen on net) -;; created : 16-Feb-1989 baw (mod vanilla fn indent-rigidly mail-yank-original) - -;; Though I wrote this package basically from scratch, as an Emacs Lisp -;; learning exercise, it was inspired by postings of similar packages to -;; the gnu.emacs newsgroup over the past month or so. -;; -;; Here's a brief history of how this package developed: -;; -;; I as well as others on the net were pretty unhappy about the way emacs -;; cited replies with the tab or 4 spaces. It looked ugly and made it hard -;; to distinguish between original and cited lines. I hacked on the function -;; yank-original to at least give the user the ability to define the citation -;; character. I posted this simple hack, and others did as well. The main -;; difference between mine and others was that a space was put after the -;; citation string on on new citations, but not after previously cited lines: -;; -;; >> John wrote this originally -;; > Jane replied to that -;; -;; Then Martin Neitzel posted some code that he developed, derived in part -;; from code that Ashwin Ram posted previous to that. In Martin's -;; posting, he introduced a new, and (IMHO) superior, citation style, -;; eliminating nested citations. Yes, I wanted to join the Small-But- -;; Growing-Help-Stamp-Out-Nested-Citation-Movement! You should too. -;; -;; But Martin's code simply asks the user for the citation string (here -;; after called the `attribution' string), and I got to thinking, it wouldn't -;; be that difficult to automate that part. So I started hacking this out. -;; It proved to be not as simple as I first thought. But anyway here it -;; is. See the wish list below for future plans (if I have time). -;; -;; Type "C-h f mail-yank-original" after this package is loaded to get a -;; description of what it does and the variables that control it. -;; -;; ====================================================================== -;; -;; Changes wish list -;; -;; 1) C-x C-s yanks a region from the RMAIL buffer instead of the -;; whole buffer -;; -;; 2) reparse nested citations to try to recast as non-nested citations -;; perhaps by checking the References: line -;; - -;;; Code: - -;; ====================================================================== -;; -;; require and provide features -;; -(require 'sendmail) -;; -;; ====================================================================== -;; -;; don't need rnewspost.el to rewrite the header. This only works -;; with diffs to rnewspost.el that I posted with the original -;; superyank code. -;; -(setq news-reply-header-hook nil) - -;; ********************************************************************** -;; start of user defined variables -;; ********************************************************************** -;; -;; this section defines variables that control the operation of -;; super-mail-yank. Most of these are described in the comment section -;; as well as the DOCSTRING. -;; - -;; -;; ---------------------------------------------------------------------- -;; -;; this variable holds the default author's name for citations -;; -(defvar sy-default-attribution "Anon" - "String that describes attribution to unknown person. This string -should not contain the citation string.") - -;; -;; ---------------------------------------------------------------------- -;; -;; string used as an end delimiter for both nested and non-nested citations -;; -(defvar sy-citation-string ">" - "String to use as an end-delimiter for citations. This string is -used in both nested and non-nested citations. For best results, use a -single character with no trailing space. Most commonly used string -is: \">\.") - -;; -;; ---------------------------------------------------------------------- -;; -;; variable controlling citation type, nested or non-nested -;; -(defvar sy-nested-citation-p nil - "Non-nil uses nested citations, nil uses non-nested citations. -Nested citations are of the style: - -I wrote this -> He wrote this ->> She replied to something he wrote - -Non-nested citations are of the style: - -I wrote this -John> He wrote this -Jane> She originally wrote this") - - -;; -;; ---------------------------------------------------------------------- -;; -;; regular expression that matches existing citations -;; -(defvar sy-cite-regexp "[a-zA-Z0-9]*>" - "Regular expression that describes how an already cited line in an -article begins. The regexp is only used at the beginning of a line, -so it doesn't need to begin with a '^'.") - -;; -;; ---------------------------------------------------------------------- -;; -;; regular expression that delimits names from titles in the field that -;; looks like: (John X. Doe -- Computer Hacker Extraordinaire) -;; -(defvar sy-titlecue-regexp "\\s +-+\\s +" - - "Regular expression that delineates names from titles in the name -field. Often, people will set up their name field to look like this: - -(John Xavier Doe -- Computer Hacker Extraordinaire) - -Set to nil to treat entire field as a name.") - -;; -;; ---------------------------------------------------------------------- -;; -;; -(defvar sy-preferred-attribution 2 - - "This is an integer indicating what the user's preference is in -attribution style, based on the following key: - -0: email address name is preferred -1: initials are preferred -2: first name is preferred -3: last name is preferred - -The value of this variable may also be greater than 3, which would -allow you to prefer the 2nd through nth - 1 name. If the preferred -attribution is nil or the empty string, then the secondary preferrence -will be the first name. After that, the entire name alist is search -until a non-empty, non-nil name is found. If no such name is found, -then the user is either queried or the default attribution string is -used depending on the value of sy-confirm-always-p. - -Examples: - -assume the from: line looks like this: - -from: doe@computer.some.where.com (John Xavier Doe) - -The following preferences would return these strings: - -0: \"doe\" -1: \"JXD\" -2: \"John\" -3: \"Doe\" -4: \"Xavier\" - -anything else would return \"John\".") - -;; -;; ---------------------------------------------------------------------- -;; -(defvar sy-confirm-always-p t - "If t, always confirm attribution string before inserting into -buffer.") - - -;; -;; ---------------------------------------------------------------------- -;; -;; informative header hook -;; -(defvar sy-rewrite-header-hook 'sy-header-on-said - "Hook for inserting informative header at the top of the yanked -message. Set to nil for no header. Here is a list of predefined -header styles; you can use these as a model to write you own: - -sy-header-on-said [default]: On 14-Jun-1989 GMT, - John Xavier Doe said: - -sy-header-inarticle-writes: In article <123456789> John Xavier Doe writes: - -sy-header-regarding-writes: Regarding RE: superyank; John Xavier Doe adds: - -sy-header-verbose: On 14-Jun-1989 GMT, John Xavier Doe - from the organization Great Company - has this to say about article <123456789> - in newsgroups misc.misc - concerning RE: superyank - referring to previous articles <987654321> - -You can use the following variables as information strings in your header: - -sy-reply-yank-date: the date field [ex: 14-Jun-1989 GMT] -sy-reply-yank-from: the from field [ex: John Xavier Doe] -sy-reply-yank-message-id: the message id [ex: <123456789>] -sy-reply-yank-subject: the subject line [ex: RE: superyank] -sy-reply-yank-newsgroup: the newsgroup name for GNUS [ex: misc.misc] -sy-reply-yank-references: the article references [ex: <987654321>] -sy-reply-yank-organization: the author's organization [ex: Great Company] - -If a field can't be found, because it doesn't exist or is not being -shown, perhaps because of toggle-headers, the corresponding field -variable will contain the string \"mumble mumble\".") - -;; -;; ---------------------------------------------------------------------- -;; -;; non-nil means downcase the author's name string -;; -(defvar sy-downcase-p nil - "Non-nil means downcase the author's name string.") - -;; -;; ---------------------------------------------------------------------- -;; -;; controls removal of leading white spaces -;; -(defvar sy-left-justify-p nil - "If non-nil, delete all leading white space before citing.") - -;; -;; ---------------------------------------------------------------------- -;; -;; controls auto filling of region -;; -(defvar sy-auto-fill-region-p nil - "If non-nil, automatically fill each paragraph that is cited. If -nil, do not auto fill each paragraph.") - - -;; -;; ---------------------------------------------------------------------- -;; -;; controls use of preferred attribution only, or use of attribution search -;; scheme if the preferred attrib can't be found. -;; -(defvar sy-use-only-preference-p nil - - "If non-nil, then only the preferred attribution string will be -used. If the preferred attribution string can not be found, then the -sy-default-attribution will be used. If nil, and the preferred -attribution string is not found, then some secondary scheme will be -employed to find a suitable attribution string.") - -;; ********************************************************************** -;; end of user defined variables -;; ********************************************************************** - -;; -;; ---------------------------------------------------------------------- -;; -;; The new citation style means we can clean out other headers in addition -;; to those previously cleaned out. Anyway, we create our own headers. -;; Also, we want to clean out any headers that gnus puts in. Add to this -;; for other mail or news readers you may be using. -;; -(setq mail-yank-ignored-headers "^via:\\|^origin:\\|^status:\\|^re\\(mail\\|ceiv\\)ed\\|^[a-z-]*message-id:\\|^\\(summary-\\)?line[s]?:\\|^cc:\\|^subject:\\|^\\(\\(in-\\)?reply-\\)?to:\\|^\\(\\(return\\|reply\\)-\\)?path:\\|^\\(posted-\\)?date:\\|^\\(mail-\\)?from:\\|^newsgroup[s]?:\\|^organization:\\|^keywords:\\|^distribution:\\|^references:") - -;; -;; ---------------------------------------------------------------------- -;; -;; global variables, not user accessable -;; -(setq sy-persist-attribution (concat sy-default-attribution "> ")) -(setq sy-reply-yank-date "") -(setq sy-reply-yank-from "") -(setq sy-reply-yank-message-id "") -(setq sy-reply-yank-subject "") -(setq sy-reply-yank-newsgroups "") -(setq sy-reply-yank-references "") -(setq sy-reply-yank-organization "") - -;; -;; ====================================================================== -;; -;; This section contains primitive functions used in the schemes. They -;; extract name fields from various parts of the "from:" field based on -;; the control variables described above. -;; -;; Some will use recursion to pick out the correct namefield in the namestring -;; or the list of initials. These functions all scan a string that contains -;; the name, ie: "John Xavier Doe". There is no limit on the number of names -;; in the string. Also note that all white spaces are basically ignored and -;; are stripped from the returned strings, and titles are ignored if -;; sy-titlecue-regexp is set to non-nil. -;; -;; Others will use methods to try to extract the name from the email -;; address of the originator. The types of addresses readable are -;; described above. - -;; -;; ---------------------------------------------------------------------- -;; -;; try to extract the name from an email address of the form -;; name%[stuff] -;; -;; Unlike the get-name functions above, these functions operate on the -;; buffer instead of a supplied name-string. -;; -(defun sy-%-style-address () - (beginning-of-line) - (buffer-substring - (progn (re-search-forward "%" (point-max) t) - (if (not (bolp)) (forward-char -1)) - (point)) - (progn (re-search-backward "^\\|[^a-zA-Z0-9]") - (point)))) - -;; -;; ---------------------------------------------------------------------- -;; -;; try to extract names from addresses with the form: -;; [stuff]name@[stuff] -;; -(defun sy-@-style-address () - (beginning-of-line) - (buffer-substring - (progn (re-search-forward "@" (point-max) t) - (if (not (bolp)) (forward-char -1)) - (point)) - (progn (re-search-backward "^\\|[^a-zA-Z0-0]") - (if (not (bolp)) (forward-char 1)) - (point)))) - -;; -;; ---------------------------------------------------------------------- -;; -;; try to extract the name from addresses with the form: -;; [stuff]![stuff]...!name[stuff] -;; -(defun sy-!-style-address () - (beginning-of-line) - (buffer-substring - (progn (while (re-search-forward "!" (point-max) t)) - (point)) - (progn (re-search-forward "[^a-zA-Z0-9]\\|$") - (if (not (eolp)) (forward-char -1)) - (point)))) - -;; -;; ---------------------------------------------------------------------- -;; -;; using the different email name schemes, try each one until you get a -;; non-nil entry -;; -(defun sy-get-emailname () - (let ((en1 (sy-%-style-address)) - (en2 (sy-@-style-address)) - (en3 (sy-!-style-address))) - (cond - ((not (string-equal en1 "")) en1) - ((not (string-equal en2 "")) en2) - ((not (string-equal en3 "")) en3) - (t "")))) - -;; -;; ---------------------------------------------------------------------- -;; -;; returns the "car" of the namestring, really the first namefield -;; -;; (sy-string-car "John Xavier Doe") -;; => "John" -;; -(defun sy-string-car (namestring) - (substring namestring - (progn (string-match "\\s *" namestring) (match-end 0)) - (progn (string-match "\\s *\\S +" namestring) (match-end 0)))) - -;; -;; ---------------------------------------------------------------------- -;; -;; returns the "cdr" of the namestring, really the whole string from -;; after the first name field to the end of the string. -;; -;; (sy-string-cdr "John Xavier Doe") -;; => "Xavier Doe" -;; -(defun sy-string-cdr (namestring) - (substring namestring - (progn (string-match "\\s *\\S +\\s *" namestring) - (match-end 0)))) - -;; -;; ---------------------------------------------------------------------- -;; -;; convert a namestring to a list of namefields -;; -;; (sy-namestring-to-list "John Xavier Doe") -;; => ("John" "Xavier" "Doe") -;; -(defun sy-namestring-to-list (namestring) - (if (not (string-match namestring "")) - (append (list (sy-string-car namestring)) - (sy-namestring-to-list (sy-string-cdr namestring))))) - -;; -;; ---------------------------------------------------------------------- -;; -;; strip the initials from each item in the list and return a string -;; that is the concatenation of the initials -;; -(defun sy-strip-initials (raw-nlist) - (if (not raw-nlist) - nil - (concat (substring (car raw-nlist) 0 1) - (sy-strip-initials (cdr raw-nlist))))) - - -;; -;; ---------------------------------------------------------------------- -;; -;; using the namestring, build a list which is in the following order -;; -;; (email, initials, firstname, lastname, name1, name2, name3 ... nameN-1) -;; -(defun sy-build-ordered-namelist (namestring) - (let* ((raw-nlist (sy-namestring-to-list namestring)) - (initials (sy-strip-initials raw-nlist)) - (firstname (car raw-nlist)) - (revnames (reverse (cdr raw-nlist))) - (lastname (car revnames)) - (midnames (reverse (cdr revnames))) - (emailnames (sy-get-emailname))) - (append (list emailnames) - (list initials) - (list firstname) - (list lastname) - midnames))) - -;; -;; ---------------------------------------------------------------------- -;; -;; Query the user for the attribution string. Supply sy-default-attribution -;; as the default choice. -;; -(defun sy-query-for-attribution () - (concat - (let* ((prompt (concat "Enter attribution string: (default " - sy-default-attribution - ") ")) - (query (read-input prompt)) - (attribution (if (string-equal query "") - sy-default-attribution - query))) - (if sy-downcase-p - (downcase attribution) - attribution)) - sy-citation-string)) - - -;; -;; ---------------------------------------------------------------------- -;; -;; parse the current line for the namestring -;; -(defun sy-get-namestring () - (save-restriction - (beginning-of-line) - (if (re-search-forward "(.*)" (point-max) t) - (let ((start (progn - (beginning-of-line) - (re-search-forward "\\((\\s *\\)\\|$" (point-max) t) - (point))) - (end (progn - (re-search-forward - (concat "\\(\\s *\\()\\|" sy-titlecue-regexp "\\)\\)\\|$") - (point-max) t) - (point)))) - (narrow-to-region start end) - (let ((start (progn - (beginning-of-line) - (point))) - (end (progn - (end-of-line) - (re-search-backward - (concat "\\s *\\()\\|" sy-titlecue-regexp "\\)$") - (point-min) t) - (point)))) - (buffer-substring start end))) - (let ((start (progn - (beginning-of-line) - (re-search-forward "^\"*") - (point))) - (end (progn - (re-search-forward "\\(\\s *[a-zA-Z0-9\\.]+\\)*" - (point-max) t) - (point)))) - (buffer-substring start end))))) - - -;; -;; ---------------------------------------------------------------------- -;; -;; scan the nlist and return the integer pointing to the first legal -;; non-empty namestring. Returns the integer pointing to the index -;; in the nlist of the preferred namestring, or nil if no legal -;; non-empty namestring could be found. -;; -(defun sy-return-preference-n (nlist) - (let ((p sy-preferred-attribution) - (exception nil)) - ;; - ;; check to be sure the index is not out-of-bounds - ;; - (cond - ((< p 0) (setq p 2) (setq exception t)) - ((not (nth p nlist)) (setq p 2) (setq exception t))) - ;; - ;; check to be sure that the explicit preference is not empty - ;; - (if (string-equal (nth p nlist) "") - (progn (setq p 0) - (setq exception t))) - ;; - ;; find the first non-empty namestring - ;; - (while (and (nth p nlist) - (string-equal (nth p nlist) "")) - (setq exception t) - (setq p (+ p 1))) - ;; - ;; return the preference index if non-nil, otherwise nil - ;; - (if (or (and exception sy-use-only-preference-p) - (not (nth p nlist))) - nil - p))) - -;; -;; -;; ---------------------------------------------------------------------- -;; -;; rebuild the nlist into an alist for completing-read. Use as a guide -;; the index of the preferred name field. Get the actual preferred -;; name field base on other factors (see above). If no actual preferred -;; name field is found, then query the user for the attribution string. -;; -;; also note that the nlist is guaranteed to be non-empty. At the very -;; least it will consist of 4 empty strings ("" "" "" "") -;; -(defun sy-nlist-to-alist (nlist) - (let ((preference (sy-return-preference-n nlist)) - alist - (n 0)) - ;; - ;; check to be sure preference is not nil - ;; - (if (not preference) - (setq alist (list (cons (sy-query-for-attribution) nil))) - ;; - ;; preference is non-nil - ;; - (setq alist (list (cons (nth preference nlist) nil))) - (while (nth n nlist) - (if (= n preference) nil - (setq alist (append alist (list (cons (nth n nlist) nil))))) - (setq n (+ n 1)))) - alist)) - - - -;; -;; ---------------------------------------------------------------------- -;; -;; confirm if desired after the alist has been built -;; -(defun sy-get-attribution (alist) - (concat - ;; - ;; check to see if nested citations are to be used - ;; - (if sy-nested-citation-p - "" - ;; - ;; check to see if confirmation is needed - ;; if not, just return the preference (first element in alist) - ;; - (if (not sy-confirm-always-p) - (car (car alist)) - ;; - ;; confirmation is requested so build the prompt, confirm - ;; and return the chosen string - ;; - (let* (ignore - (prompt (concat "Complete attribution string: (default " - (car (car alist)) - ") ")) - ;; - ;; set up the local completion keymap - ;; - (minibuffer-local-must-match-map - (let ((map (make-sparse-keymap))) - (define-key map "?" 'minibuffer-completion-help) - (define-key map " " 'minibuffer-complete-word) - (define-key map "\t" 'minibuffer-complete) - (define-key map "\00A" 'exit-minibuffer) - (define-key map "\00D" 'exit-minibuffer) - (define-key map "\007" - '(lambda () - (interactive) - (beep) - (exit-minibuffer))) - map)) - ;; - ;; read the completion - ;; - (attribution (completing-read prompt alist)) - ;; - ;; check attribution string for emptyness - ;; - (choice (if (or (not attribution) - (string-equal attribution "")) - (car (car alist)) - attribution))) - - (if sy-downcase-p - (downcase choice) - choice)))) - sy-citation-string)) - - -;; -;; ---------------------------------------------------------------------- -;; -;; this function will scan the current rmail buffer, narrowing it to the -;; from: line, then using this, it will try to decipher some names from -;; that line. It will then build the name alist and try to confirm -;; its choice of attribution strings. It returns the chosen attribution -;; string. -;; -(defun sy-scan-rmail-for-names (rmailbuffer) - (save-excursion - (let ((case-fold-search t) - alist - attribution) - (switch-to-buffer rmailbuffer) - (goto-char (point-min)) - ;; - ;; be sure there is a from: line - ;; - (if (not (re-search-forward "^from:\\s *" (point-max) t)) - (setq attribution (sy-query-for-attribution)) - ;; - ;; if there is a from: line, then scan the narrow the buffer, - ;; grab the namestring, and build the alist, then using this - ;; get the attribution string. - ;; - (save-restriction - (narrow-to-region (point) - (progn (end-of-line) (point))) - (let* ((namestring (sy-get-namestring)) - (nlist (sy-build-ordered-namelist namestring))) - (setq alist (sy-nlist-to-alist nlist)))) - ;; - ;; we've built the alist, now confirm the attribution choice - ;; if appropriate - ;; - (setq attribution (sy-get-attribution alist))) - attribution))) - - -;; -;; ====================================================================== -;; -;; the following function insert of citations, writing of headers, filling -;; paragraphs and general higher level operations -;; - -;; -;; ---------------------------------------------------------------------- -;; -;; insert a nested citation -;; -(defun sy-insert-citation (start end cite-string) - (save-excursion - (goto-char end) - (setq end (point-marker)) - (goto-char start) - (or (bolp) - (forward-line 1)) - - (let ((fill-prefix (concat cite-string " ")) - (fstart (point)) - (fend (point))) - - (while (< (point) end) - ;; - ;; remove leading tabs if desired - ;; - (if sy-left-justify-p - (delete-region (point) - (progn (skip-chars-forward " \t") (point)))) - ;; - ;; check to see if the current line should be cited - ;; - (if (or (eolp) - (looking-at sy-cite-regexp)) - ;; - ;; do not cite this line unless nested-citations are to be - ;; used - ;; - (progn - (or (eolp) - (if sy-nested-citation-p - (insert cite-string))) - - ;; set fill start and end points - ;; - (or (= fstart fend) - (not sy-auto-fill-region-p) - (progn (goto-char fend) - (or (not (eolp)) - (setq fend (+ fend 1))) - (fill-region-as-paragraph fstart fend))) - (setq fstart (point)) - (setq fend (point))) - - ;; else - ;; - (insert fill-prefix) - (end-of-line) - (setq fend (point))) - - (forward-line 1))) - (move-marker end nil))) - -;; -;; ---------------------------------------------------------------------- -;; -;; yank a particular field into a holding variable -;; -(defun sy-yank-fields (start) - (save-excursion - (goto-char start) - (setq sy-reply-yank-date (mail-fetch-field "date") - sy-reply-yank-from (mail-fetch-field "from") - sy-reply-yank-subject (mail-fetch-field "subject") - sy-reply-yank-newsgroups (mail-fetch-field "newsgroups") - sy-reply-yank-references (mail-fetch-field "references") - sy-reply-yank-message-id (mail-fetch-field "message-id") - sy-reply-yank-organization (mail-fetch-field "organization")) - (or sy-reply-yank-date - (setq sy-reply-yank-date "mumble mumble")) - (or sy-reply-yank-from - (setq sy-reply-yank-from "mumble mumble")) - (or sy-reply-yank-subject - (setq sy-reply-yank-subject "mumble mumble")) - (or sy-reply-yank-newsgroups - (setq sy-reply-yank-newsgroups "mumble mumble")) - (or sy-reply-yank-references - (setq sy-reply-yank-references "mumble mumble")) - (or sy-reply-yank-message-id - (setq sy-reply-yank-message-id "mumble mumble")) - (or sy-reply-yank-organization - (setq sy-reply-yank-organization "mumble mumble")))) - -;; -;; ---------------------------------------------------------------------- -;; -;; rewrite the header to be more conversational -;; -(defun sy-rewrite-headers (start) - (goto-char start) - (run-hooks 'sy-rewrite-header-hook)) - -;; -;; ---------------------------------------------------------------------- -;; -;; some different styles of headers -;; -(defun sy-header-on-said () - (insert-string "\nOn " sy-reply-yank-date ",\n" - sy-reply-yank-from " said:\n")) - -(defun sy-header-inarticle-writes () - (insert-string "\nIn article " sy-reply-yank-message-id - " " sy-reply-yank-from " writes:\n")) - -(defun sy-header-regarding-writes () - (insert-string "\nRegarding " sy-reply-yank-subject - "; " sy-reply-yank-from " adds:\n")) - -(defun sy-header-verbose () - (insert-string "\nOn " sy-reply-yank-date ",\n" - sy-reply-yank-from "\nfrom the organization " - sy-reply-yank-organization "\nhad this to say about article " - sy-reply-yank-message-id "\nin newsgroups " - sy-reply-yank-newsgroups "\nconcerning " - sy-reply-yank-subject "\nreferring to previous articles " - sy-reply-yank-references "\n")) - -;; -;; ---------------------------------------------------------------------- -;; -;; yank the original article in and attribute -;; -(defun sy-yank-original (arg) - - "Insert the message being replied to, if any (in rmail/gnus). Puts -point before the text and mark after. Calls generalized citation -function sy-insert-citation to cite all allowable lines." - - (interactive "P") - (if mail-reply-buffer - (let* ((sy-confirm-always-p (if (consp arg) - t - sy-confirm-always-p)) - (attribution (sy-scan-rmail-for-names mail-reply-buffer)) - (top (point)) - (start (point)) - (end (progn (delete-windows-on mail-reply-buffer) - (insert-buffer mail-reply-buffer) - (mark)))) - - (sy-yank-fields start) - (sy-rewrite-headers start) - (setq start (point)) - (mail-yank-clear-headers top (mark)) - (setq sy-persist-attribution (concat attribution " ")) - (sy-insert-citation start end attribution)) - - (goto-char top) - (exchange-point-and-mark))) - - -;; -;; ---------------------------------------------------------------------- -;; -;; this is here for compatibility with existing mail/news yankers -;; overloads the default mail-yank-original -;; -(defun mail-yank-original (arg) - - "Yank original message buffer into the reply buffer, citing as per -user preferences. Numeric Argument forces confirmation. - -Here is a description of the superyank.el package, what it does and -what variables control its operation. This was written by Barry -Warsaw (warsaw@cme.nist.gov, {...}!uunet!cme-durer!warsaw). - -A 'Citation' is the acknowledgement of the original author of a mail -message. There are two general forms of citation. In 'nested -citations', indication is made that the cited line was written by -someone *other* that the current message author (or by that author at -an earlier time). No indication is made as to the identity of the -original author. Thus, a nested citation after multiple replies would -look like this (this is after my reply to a previous message): - ->>John originally wrote this ->>and this as well -> Jane said that John didn't know -> what he was talking about -And that's what I think as well. - -In non-nested citations, you won't see multiple \">\" characters at -the beginning of the line. Non-nested citations will insert an -informative string at the beginning of a cited line, attributing that -line to an author. The same message described above might look like -this if non-nested citations were used: - -John> John originally wrote this -John> and this as well -Jane> Jane said that John didn't know -Jane> what he was talking about -And that's what I think as well. - -Notice that my inclusion of Jane's inclusion of John's original -message did not result in a cited line of the form: Jane>John>. Thus -no nested citations. The style of citation is controlled by the -variable `sy-nested-citation-p'. Nil uses non-nested citations and -non-nil uses old style, nested citations. - -The variable `sy-citation-string' is the string to use as a marker for -a citation, either nested or non-nested. For best results, this -string should be a single character with no trailing space and is -typically the character \">\". In non-nested citations this string is -appended to the attribution string (author's name), along with a -trailing space. In nested citations, a trailing space is only added -to a first level citation. - -Another important variable is `sy-cite-regexp' which describes strings -that indicate a previously cited line. This regular expression is -always used at the beginning of a line so it doesn't need to begin -with a \"^\" character. Change this variable if you change -`sy-citation-string'. - -The following section only applies to non-nested citations. - -This package has a fair amount of intellegence related to deciphering -the author's name based on information provided by the original -message buffer. In normal operation, the program will pick out the -author's first and last names, initials, terminal email address and -any other names it can find. It will then pick an attribution string -from this list based on a user defined preference and it will ask for -confirmation if the user specifies. This package gathers its -information from the `From:' line of the original message buffer. It -recognizes From: lines with the following forms: - -From: John Xavier Doe <doe@speedy.computer.com> -From: \"John Xavier Doe\" <doe@speedy.computer.com> -From: doe@speedy.computer.com (John Xavier Doe) -From: computer!speedy!doe (John Xavier Doe) -From: computer!speedy!doe (John Xavier Doe) -From: doe%speedy@computer.com (John Xavier Doe) - -In this case, if confirmation is requested, the following strings will -be made available for completion and confirmation: - -\"John\" -\"Xavier\" -\"Doe\" -\"JXD\" -\"doe\" - -Note that completion is case sensitive. If there was a problem -picking out a From: line, or any other problem getting even a single -name, then the user will be queried for an attribution string. The -default attribution string is set in the variable -`sy-default-attribution'. - -Sometimes people set their name fields so that it also includes a -title of the form: - -From: doe@speedy.computer.com (John Doe -- Hacker Extraordinaire) - -To avoid the inclusion of the string \"-- Hacker Extraordinaire\" in -the name list, the variable `sy-titlecue-regexp' is provided. Its -default setting will still properly recognize names of the form: - -From: xdoe@speedy.computer.com (John Xavier-Doe -- Crazed Hacker) - -The variable `sy-preferred-attribution' contains an integer that -indicates which name field the user prefers to use as the attribution -string, based on the following key: - -0: email address name is preferred -1: initials are preferred -2: first name is preferred -3: last name is preferred - -The value can be greater than 3, in which case, you would be -preferring the 2nd throught nth -1 name. In any case, if the -preferred name can't be found, then one of two actions will be taken -depending on the value of the variable `sy-use-only-preference-p'. If -this is non-nil, then the `sy-default-attribution will be used. If it -is nil, then a secondary scheme will be employed to find a suitable -attribution scheme. First, the author's first name will be used. If -that can't be found than the name list is searched for the first -non-nil, non-empty name string. If still no name can be found, then -the user is either queried, or the `sy-default-attribution' is used, -depending on the value of `sy-confirm-always-p'. - -If the variable `sy-confirm-always-p' is non-nil, superyank will always -confirm the attribution string with the user before inserting it into -the reply buffer. Confirmation is with completion, but the completion -list is merely a suggestion; the user can override the list by typing -in a string of their choice. - -The variable `sy-rewrite-header-hook' is a hook that contains a lambda -expression which rewrites the informative header at the top of the -yanked message. Set to nil to avoid writing any header. - -You can make superyank autofill each paragraph it cites by setting the -variable `sy-auto-fill-region-p' to non-nil. Or set the variable to nil -and fill the paragraphs manually with sy-fill-paragraph-manually (see -below). - -Finally, `sy-downcase-p' if non-nil, indicates that you always want to -downcase the attribution string before insertion, and -`sy-left-justify-p', if non-nil, indicates that you want to delete all -leading white space before citing. - -Since the almost all yanking in other modes (RMAIL, GNUS) is done -through the function `mail-yank-original', and since superyank -overloads this function, cited yanking is automatically bound to the -C-c C-y key. There are three other smaller functions that are -provided with superyank and they are bound as below. Try C-h f on -each function to get more information on these functions. - -Key Bindings: - -C-c C-y mail-yank-original (superyank's version) -C-c q sy-fill-paragraph-manually -C-c C-q sy-fill-paragraph-manually -C-c i sy-insert-persist-attribution -C-c C-i sy-insert-persist-attribution -C-c C-o sy-open-line - - -Summary of variables, with their default values: - -sy-default-attribution (default: \"Anon\") - Attribution to use if no attribution string can be deciphered - from the original message buffer. - -sy-citation-string (default: \">\") - String to append to the attribution string for citation, for - best results, it should be one character with no trailing space. - -sy-nested-citation-p (default: nil) - Nil means use non-nested citations, non-nil means use old style - nested citations. - -sy-cite-regexp (default: \"[a-zA-Z0-9]*>\") - Regular expression that matches the beginning of a previously - cited line. Always used at the beginning of a line so it does - not need to start with a \"^\" character. - -sy-titlecue-regexp (default: \"\\s +-+\\s +\") - Regular expression that matches a title delimiter in the name - field. - -sy-preferred-attribution (default: 2) - Integer indicating user's preferred attribution field. - -sy-confirm-always-p (default: t) - Non-nil says always confirm with completion before inserting - attribution. - -sy-rewrite-header-hook (default: 'sy-header-on-said) - Hook for inserting informative header at the top of the yanked - message. - -sy-downcase-p (default: nil) - Non-nil says downcase the attribution string before insertion. - -sy-left-justify-p (default: nil) - Non-nil says delete leading white space before citing. - -sy-auto-fill-region-p (default: nil) - Non-nil says don't auto fill the region. T says auto fill the - paragraph. - -sy-use-only-preference-p (default: nil) - If nil, use backup scheme when preferred attribution string - can't be found. If non-nil and preferred attribution string - can't be found, then use sy-default-attribution." - - (interactive "P") - - (local-set-key "\C-cq" 'sy-fill-paragraph-manually) - (local-set-key "\C-c\C-q" 'sy-fill-paragraph-manually) - (local-set-key "\C-c\i" 'sy-insert-persist-attribution) - (local-set-key "\C-c\C-i" 'sy-insert-persist-attribution) - (local-set-key "\C-c\C-o" 'sy-open-line) - - (sy-yank-original arg)) - - -;; -;; ---------------------------------------------------------------------- -;; -;; based on Bruce Israel's "fill-paragraph-properly", and modified from -;; code posted by David C. Lawrence. Modified to use the persistant -;; attribution if none could be found from the paragraph. -;; -(defun sy-fill-paragraph-manually (arg) - "Fill paragraph containing or following point. -This automatically finds the sy-cite-regexp and uses it as the prefix. -If the sy-cite-regexp is not in the first line of the paragraph, it -makes a guess at what the fill-prefix for the paragraph should be by -looking at the first line and taking anything up to the first -alphanumeric character. - -Prefix arg means justify both sides of paragraph as well. - -This function just does fill-paragraph if the fill-prefix is set. If -what it deduces to be the paragraph prefix (based on the first line) -does not precede each line in the region, then the persistant -attribution is used. The persistant attribution is just the last -attribution string used to cite lines." - - (interactive "P") - (save-excursion - (forward-paragraph) - (or (bolp) - (newline 1)) - - (let ((end (point)) - st - (fill-prefix fill-prefix)) - (backward-paragraph) - (if (looking-at "\n") - (forward-char 1)) - (setq st (point)) - (if fill-prefix - nil - (untabify st end) ;; die, scurvy tabs! - ;; - ;; untabify might have made the paragraph longer character-wise, - ;; make sure end reflects the correct location of eop. - ;; - (forward-paragraph) - (setq end (point)) - (goto-char st) - (if (looking-at sy-cite-regexp) - (setq fill-prefix (concat - (buffer-substring - st (progn (re-search-forward sy-cite-regexp) - (point))) - " ")) - ;; - ;; this regexp is is convenient because paragraphs quoted by simple - ;; indentation must still yield to us <evil laugh> - ;; - (while (looking-at "[^a-zA-Z0-9]") - (forward-char 1)) - (setq fill-prefix (buffer-substring st (point)))) - (next-line 1) (beginning-of-line) - (while (and (< (point) end) - (not (string-equal fill-prefix ""))) - ;; - ;; if what we decided was the fill-prefix does not precede all - ;; of the lines in the paragraph, we probably goofed. In this - ;; case set it to the persistant attribution. - ;; - (if (looking-at (regexp-quote fill-prefix)) - () - (setq fill-prefix sy-persist-attribution)) - (next-line 1) - (beginning-of-line))) - (fill-region-as-paragraph st end arg)))) - -;; -;; ---------------------------------------------------------------------- -;; -;; insert the persistant attribution at point -;; -(defun sy-insert-persist-attribution () - "Insert the persistant attribution. -This inserts the peristant attribution at the beginning of the line that -point is on. This string is the last attribution confirmed and used -in the yanked reply buffer." - (interactive) - (save-excursion - (beginning-of-line) - (insert-string sy-persist-attribution))) - - -;; -;; ---------------------------------------------------------------------- -;; -;; open a line putting the attribution at the beginning - -(defun sy-open-line (arg) - "Insert a newline and leave point before it. -Also inserts the persistant attribution at the beginning of the line. -With argument, inserts ARG newlines." - (interactive "p") - (save-excursion - (let ((start (point))) - (open-line arg) - (goto-char start) - (forward-line) - (while (< 0 arg) - (sy-insert-persist-attribution) - (forward-line 1) - (setq arg (- arg 1)))))) - -(provide 'superyank) - -;;; superyank.el ends here diff --git a/lisp/timer.el b/lisp/timer.el deleted file mode 100644 index e860f843095..00000000000 --- a/lisp/timer.el +++ /dev/null @@ -1,473 +0,0 @@ -;;; timer.el --- run a function with args at some time in future. - -;; Copyright (C) 1996 Free Software Foundation, Inc. - -;; Maintainer: FSF - -;; 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: - -;; This package gives you the capability to run Emacs Lisp commands at -;; specified times in the future, either as one-shots or periodically. - -;;; Code: - -;; Layout of a timer vector: -;; [triggered-p high-seconds low-seconds usecs repeat-delay -;; function args idle-delay] - -(defun timer-create () - "Create a timer object." - (let ((timer (make-vector 8 nil))) - (aset timer 0 t) - timer)) - -(defun timerp (object) - "Return t if OBJECT is a timer." - (and (vectorp object) (= (length object) 8))) - -(defun timer-set-time (timer time &optional delta) - "Set the trigger time of TIMER to TIME. -TIME must be in the internal format returned by, e.g., `current-time'. -If optional third argument DELTA is a non-zero integer, make the timer -fire repeatedly that many seconds apart." - (or (timerp timer) - (error "Invalid timer")) - (aset timer 1 (car time)) - (aset timer 2 (if (consp (cdr time)) (car (cdr time)) (cdr time))) - (aset timer 3 (or (and (consp (cdr time)) (consp (cdr (cdr time))) - (nth 2 time)) - 0)) - (aset timer 4 (and (numberp delta) (> delta 0) delta)) - timer) - -(defun timer-set-idle-time (timer secs &optional repeat) - "Set the trigger idle time of TIMER to SECS. -If optional third argument REPEAT is non-nil, make the timer -fire each time Emacs is idle for that many seconds." - (or (timerp timer) - (error "Invalid timer")) - (aset timer 1 0) - (aset timer 2 0) - (aset timer 3 0) - (timer-inc-time timer secs) - (aset timer 4 repeat) - timer) - -(defun timer-next-integral-multiple-of-time (time secs) - "Yield the next value after TIME that is an integral multiple of SECS. -More precisely, the next value, after TIME, that is an integral multiple -of SECS seconds since the epoch. SECS may be a fraction." - (let ((time-base (ash 1 16))) - (if (fboundp 'atan) - ;; Use floating point, taking care to not lose precision. - (let* ((float-time-base (float time-base)) - (million 1000000.0) - (time-usec (+ (* million - (+ (* float-time-base (nth 0 time)) - (nth 1 time))) - (nth 2 time))) - (secs-usec (* million secs)) - (mod-usec (mod time-usec secs-usec)) - (next-usec (+ (- time-usec mod-usec) secs-usec)) - (time-base-million (* float-time-base million))) - (list (floor next-usec time-base-million) - (floor (mod next-usec time-base-million) million) - (floor (mod next-usec million)))) - ;; Floating point is not supported. - ;; Use integer arithmetic, avoiding overflow if possible. - (let* ((mod-sec (mod (+ (* (mod time-base secs) - (mod (nth 0 time) secs)) - (nth 1 time)) - secs)) - (next-1-sec (+ (- (nth 1 time) mod-sec) secs))) - (list (+ (nth 0 time) (floor next-1-sec time-base)) - (mod next-1-sec time-base) - 0))))) - -(defun timer-relative-time (time secs &optional usecs) - "Advance TIME by SECS seconds and optionally USECS microseconds. -SECS may be a fraction." - (let ((high (car time)) - (low (if (consp (cdr time)) (nth 1 time) (cdr time))) - (micro (if (numberp (car-safe (cdr-safe (cdr time)))) - (nth 2 time) - 0))) - ;; Add - (if usecs (setq micro (+ micro usecs))) - (if (floatp secs) - (setq micro (+ micro (floor (* 1000000 (- secs (floor secs))))))) - (setq low (+ low (floor secs))) - - ;; Normalize - (setq low (+ low (/ micro 1000000))) - (setq micro (mod micro 1000000)) - (setq high (+ high (/ low 65536))) - (setq low (logand low 65535)) - - (list high low (and (/= micro 0) micro)))) - -(defun timer-inc-time (timer secs &optional usecs) - "Increment the time set in TIMER by SECS seconds and USECS microseconds. -SECS may be a fraction." - (let ((time (timer-relative-time - (list (aref timer 1) (aref timer 2) (aref timer 3)) - secs - usecs))) - (aset timer 1 (nth 0 time)) - (aset timer 2 (nth 1 time)) - (aset timer 3 (or (nth 2 time) 0)))) - -(defun timer-set-time-with-usecs (timer time usecs &optional delta) - "Set the trigger time of TIMER to TIME. -TIME must be in the internal format returned by, e.g., `current-time'. -If optional third argument DELTA is a non-zero integer, make the timer -fire repeatedly that many seconds apart." - (or (timerp timer) - (error "Invalid timer")) - (aset timer 1 (car time)) - (aset timer 2 (if (consp (cdr time)) (car (cdr time)) (cdr time))) - (aset timer 3 usecs) - (aset timer 4 (and (numberp delta) (> delta 0) delta)) - timer) - -(defun timer-set-function (timer function &optional args) - "Make TIMER call FUNCTION with optional ARGS when triggering." - (or (timerp timer) - (error "Invalid timer")) - (aset timer 5 function) - (aset timer 6 args) - timer) - -(defun timer-activate (timer) - "Put TIMER on the list of active timers." - (if (and (timerp timer) - (integerp (aref timer 1)) - (integerp (aref timer 2)) - (integerp (aref timer 3)) - (aref timer 5)) - (let ((timers timer-list) - last) - ;; Skip all timers to trigger before the new one. - (while (and timers - (or (> (aref timer 1) (aref (car timers) 1)) - (and (= (aref timer 1) (aref (car timers) 1)) - (> (aref timer 2) (aref (car timers) 2))) - (and (= (aref timer 1) (aref (car timers) 1)) - (= (aref timer 2) (aref (car timers) 2)) - (> (aref timer 3) (aref (car timers) 3))))) - (setq last timers - timers (cdr timers))) - ;; Insert new timer after last which possibly means in front of queue. - (if last - (setcdr last (cons timer timers)) - (setq timer-list (cons timer timers))) - (aset timer 0 nil) - (aset timer 7 nil) - nil) - (error "Invalid or uninitialized timer"))) - -(defun timer-activate-when-idle (timer &optional dont-wait) - "Arrange to activate TIMER whenever Emacs is next idle. -If optional argument DONT-WAIT is non-nil, then enable the -timer to activate immediately, or at the right time, if Emacs -is already idle." - (if (and (timerp timer) - (integerp (aref timer 1)) - (integerp (aref timer 2)) - (integerp (aref timer 3)) - (aref timer 5)) - (let ((timers timer-idle-list) - last) - ;; Skip all timers to trigger before the new one. - (while (and timers - (or (> (aref timer 1) (aref (car timers) 1)) - (and (= (aref timer 1) (aref (car timers) 1)) - (> (aref timer 2) (aref (car timers) 2))) - (and (= (aref timer 1) (aref (car timers) 1)) - (= (aref timer 2) (aref (car timers) 2)) - (> (aref timer 3) (aref (car timers) 3))))) - (setq last timers - timers (cdr timers))) - ;; Insert new timer after last which possibly means in front of queue. - (if last - (setcdr last (cons timer timers)) - (setq timer-idle-list (cons timer timers))) - (aset timer 0 (not dont-wait)) - (aset timer 7 t) - nil) - (error "Invalid or uninitialized timer"))) - -;;;###autoload -(defalias 'disable-timeout 'cancel-timer) -;;;###autoload -(defun cancel-timer (timer) - "Remove TIMER from the list of active timers." - (or (timerp timer) - (error "Invalid timer")) - (setq timer-list (delq timer timer-list)) - (setq timer-idle-list (delq timer timer-idle-list)) - nil) - -;;;###autoload -(defun cancel-function-timers (function) - "Cancel all timers scheduled by `run-at-time' which would run FUNCTION." - (interactive "aCancel timers of function: ") - (let ((tail timer-list)) - (while tail - (if (eq (aref (car tail) 5) function) - (setq timer-list (delq (car tail) timer-list))) - (setq tail (cdr tail)))) - (let ((tail timer-idle-list)) - (while tail - (if (eq (aref (car tail) 5) function) - (setq timer-idle-list (delq (car tail) timer-idle-list))) - (setq tail (cdr tail))))) - -;; Record the last few events, for debugging. -(defvar timer-event-last-2 nil) -(defvar timer-event-last-1 nil) -(defvar timer-event-last nil) - -(defvar timer-max-repeats 10 - "*Maximum number of times to repeat a timer, if real time jumps.") - -(defun timer-until (timer time) - "Calculate number of seconds from when TIMER will run, until TIME. -TIMER is a timer, and stands for the time when its next repeat is scheduled. -TIME is a time-list." - (let ((high (- (car time) (aref timer 1))) - (low (- (nth 1 time) (aref timer 2)))) - (+ low (* high 65536)))) - -(defun timer-event-handler (timer) - "Call the handler for the timer TIMER. -This function is called, by name, directly by the C code." - (setq timer-event-last-2 timer-event-last-1) - (setq timer-event-last-1 timer-event-last) - (setq timer-event-last timer) - (let ((inhibit-quit t)) - (if (timerp timer) - (progn - ;; Delete from queue. - (cancel-timer timer) - ;; Re-schedule if requested. - (if (aref timer 4) - (if (aref timer 7) - (timer-activate-when-idle timer) - (timer-inc-time timer (aref timer 4) 0) - ;; If real time has jumped forward, - ;; perhaps because Emacs was suspended for a long time, - ;; limit how many times things get repeated. - (if (and (numberp timer-max-repeats) - (< 0 (timer-until timer (current-time)))) - (let ((repeats (/ (timer-until timer (current-time)) - (aref timer 4)))) - (if (> repeats timer-max-repeats) - (timer-inc-time timer (* (aref timer 4) repeats))))) - (timer-activate timer))) - ;; Run handler. - ;; We do this after rescheduling so that the handler function - ;; can cancel its own timer successfully with cancel-timer. - (condition-case nil - (apply (aref timer 5) (aref timer 6)) - (error nil))) - (error "Bogus timer event")))) - -;; This function is incompatible with the one in levents.el. -(defun timeout-event-p (event) - "Non-nil if EVENT is a timeout event." - (and (listp event) (eq (car event) 'timer-event))) - -;;;###autoload -(defun run-at-time (time repeat function &rest args) - "Perform an action at time TIME. -Repeat the action every REPEAT seconds, if REPEAT is non-nil. -TIME should be a string like \"11:23pm\", nil meaning now, a number of seconds -from now, a value from `current-time', or t (with non-nil REPEAT) -meaning the next integral multiple of REPEAT. -REPEAT may be an integer or floating point number. -The action is to call FUNCTION with arguments ARGS. - -This function returns a timer object which you can use in `cancel-timer'." - (interactive "sRun at time: \nNRepeat interval: \naFunction: ") - - (or (null repeat) - (and (numberp repeat) (< 0 repeat)) - (error "Invalid repetition interval")) - - ;; Special case: nil means "now" and is useful when repeating. - (if (null time) - (setq time (current-time))) - - ;; Special case: t means the next integral multiple of REPEAT. - (if (and (eq time t) repeat) - (setq time (timer-next-integral-multiple-of-time (current-time) repeat))) - - ;; Handle numbers as relative times in seconds. - (if (numberp time) - (setq time (timer-relative-time (current-time) time))) - - ;; Handle relative times like "2 hours and 35 minutes" - (if (stringp time) - (let ((secs (timer-duration time))) - (if secs - (setq time (timer-relative-time (current-time) secs))))) - - ;; Handle "11:23pm" and the like. Interpret it as meaning today - ;; which admittedly is rather stupid if we have passed that time - ;; already. (Though only Emacs hackers hack Emacs at that time.) - (if (stringp time) - (progn - (require 'diary-lib) - (let ((hhmm (diary-entry-time time)) - (now (decode-time))) - (if (>= hhmm 0) - (setq time - (encode-time 0 (% hhmm 100) (/ hhmm 100) (nth 3 now) - (nth 4 now) (nth 5 now) (nth 8 now))))))) - - (or (consp time) - (error "Invalid time format")) - - (let ((timer (timer-create))) - (timer-set-time timer time repeat) - (timer-set-function timer function args) - (timer-activate timer) - timer)) - -;;;###autoload -(defun run-with-timer (secs repeat function &rest args) - "Perform an action after a delay of SECS seconds. -Repeat the action every REPEAT seconds, if REPEAT is non-nil. -SECS and REPEAT may be integers or floating point numbers. -The action is to call FUNCTION with arguments ARGS. - -This function returns a timer object which you can use in `cancel-timer'." - (interactive "sRun after delay (seconds): \nNRepeat interval: \naFunction: ") - (apply 'run-at-time secs repeat function args)) - -;;;###autoload -(defun add-timeout (secs function object &optional repeat) - "Add a timer to run SECS seconds from now, to call FUNCTION on OBJECT. -If REPEAT is non-nil, repeat the timer every REPEAT seconds. -This function is for compatibility; see also `run-with-timer'." - (run-with-timer secs repeat function object)) - -;;;###autoload -(defun run-with-idle-timer (secs repeat function &rest args) - "Perform an action the next time Emacs is idle for SECS seconds. -The action is to call FUNCTION with arguments ARGS. -SECS may be an integer or a floating point number. - -If REPEAT is non-nil, do the action each time Emacs has been idle for -exactly SECS seconds (that is, only once for each time Emacs becomes idle). - -This function returns a timer object which you can use in `cancel-timer'." - (interactive - (list (read-from-minibuffer "Run after idle (seconds): " nil nil t) - (y-or-n-p "Repeat each time Emacs is idle? ") - (intern (completing-read "Function: " obarray 'fboundp t)))) - (let ((timer (timer-create))) - (timer-set-function timer function args) - (timer-set-idle-time timer secs repeat) - (timer-activate-when-idle timer) - timer)) - -(defun with-timeout-handler (tag) - (throw tag 'timeout)) - -;;;###autoload (put 'with-timeout 'lisp-indent-function 1) - -;;;###autoload -(defmacro with-timeout (list &rest body) - "Run BODY, but if it doesn't finish in SECONDS seconds, give up. -If we give up, we run the TIMEOUT-FORMS and return the value of the last one. -The call should look like: - (with-timeout (SECONDS TIMEOUT-FORMS...) BODY...) -The timeout is checked whenever Emacs waits for some kind of external -event \(such as keyboard input, input from subprocesses, or a certain time); -if the program loops without waiting in any way, the timeout will not -be detected." - (let ((seconds (car list)) - (timeout-forms (cdr list))) - `(let ((with-timeout-tag (cons nil nil)) - with-timeout-value with-timeout-timer) - (if (catch with-timeout-tag - (progn - (setq with-timeout-timer - (run-with-timer ,seconds nil - 'with-timeout-handler - with-timeout-tag)) - (setq with-timeout-value (progn . ,body)) - nil)) - (progn . ,timeout-forms) - (cancel-timer with-timeout-timer) - with-timeout-value)))) - -(defun y-or-n-p-with-timeout (prompt seconds default-value) - "Like (y-or-n-p PROMPT), with a timeout. -If the user does not answer after SECONDS seconds, return DEFAULT-VALUE." - (with-timeout (seconds default-value) - (y-or-n-p prompt))) - -(defvar timer-duration-words - (list (cons "microsec" 0.000001) - (cons "microsecond" 0.000001) - (cons "millisec" 0.001) - (cons "millisecond" 0.001) - (cons "sec" 1) - (cons "second" 1) - (cons "min" 60) - (cons "minute" 60) - (cons "hour" (* 60 60)) - (cons "day" (* 24 60 60)) - (cons "week" (* 7 24 60 60)) - (cons "fortnight" (* 14 24 60 60)) - (cons "month" (* 30 24 60 60)) ; Approximation - (cons "year" (* 365.25 24 60 60)) ; Approximation - ) - "Alist mapping temporal words to durations in seconds") - -(defun timer-duration (string) - "Return number of seconds specified by STRING, or nil if parsing fails." - (let ((secs 0) - (start 0) - (case-fold-search t)) - (while (string-match - "[ \t]*\\([0-9.]+\\)?[ \t]*\\([a-z]+[a-rt-z]\\)s?[ \t]*" - string start) - (let ((count (if (match-beginning 1) - (string-to-number (match-string 1 string)) - 1)) - (itemsize (cdr (assoc (match-string 2 string) - timer-duration-words)))) - (if itemsize - (setq start (match-end 0) - secs (+ secs (* count itemsize))) - (setq secs nil - start (length string))))) - (if (= start (length string)) - secs - (if (string-match "\\`[0-9.]+\\'" string) - (string-to-number string))))) - -(provide 'timer) - -;;; timer.el ends here diff --git a/lisp/tpu-doc.el b/lisp/tpu-doc.el deleted file mode 100644 index ef724ecb6d9..00000000000 --- a/lisp/tpu-doc.el +++ /dev/null @@ -1,469 +0,0 @@ -;;; tpu-doc.el --- Documentation for TPU-edt - -;; Copyright (C) 1993, 1994 Free Software Foundation, Inc. - -;; Author: Rob Riepel <riepel@networking.stanford.edu> -;; Maintainer: Rob Riepel <riepel@networking.stanford.edu> -;; Keywords: emulations - -;; 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, 675 Mass Ave, Cambridge, MA 02139, USA. - - -;; This is documentation for the TPU-edt editor for GNU emacs. Major -;; sections of this document are separated with lines that begin with -;; ";; %% <topic>", where <topic> is what is discussed in that section. - - -;; %% Contents - -;; % Introduction -;; % Terminal Support -;; % X-windows Support -;; % Differences Between TPU-edt and the Real Thing -;; % Starting TPU-edt -;; % TPU-edt Default Editing Keypad, Control and Gold Key Bindings -;; % Optional TPU-edt Extensions -;; % Customizing TPU-edt using the Emacs Initialization File -;; % Compiling TPU-edt -;; % Regular expressions in TPU-edt -;; % Etcetera - - -;; %% Introduction - -;; TPU-edt is based on tpu.el by Jeff Kowalski and Bob Covey. TPU-edt -;; endeavors to be even more like TPU's EDT emulation than the original -;; tpu.el. Considerable effort has been expended to that end. Still, -;; emacs is emacs and there are differences between TPU-edt and the -;; real thing. Please read the "Differences Between TPU-edt and the -;; Real Thing" and "Starting TPU-edt" sections before running TPU-edt. - - -;; %% Terminal Support - -;; TPU-edt, like it's VMS cousin, works on VT-series terminals with -;; DEC style keyboards. VT terminal emulators, including xterm with -;; the appropriate key translations, work just fine too. - - -;; %% X-windows Support - -;; Starting with version 19 of emacs, TPU-edt works with X-windows. -;; This is accomplished through a TPU-edt X keymap. The emacs lisp -;; program tpu-mapper.el creates this map and stores it in a file. -;; Tpu-mapper will be run automatically the first time you invoke -;; the X-windows version of emacs, or you can run it by hand. See -;; the commentary in tpu-mapper.el for details. - - -;; %% Differences Between TPU-edt and the Real Thing (not Coke (r)) - -;; Emacs (version 18.58) doesn't support text highlighting, so selected -;; regions are not shown in inverse video. Emacs uses the concept of -;; "the mark". The mark is set at one end of a selected region; the -;; cursor is at the other. The letter "M" appears in the mode line -;; when the mark is set. The native emacs command ^X^X (Control-X -;; twice) exchanges the cursor with the mark; this provides a handy -;; way to find the location of the mark. - -;; In TPU the cursor can be either bound or free. Bound means the -;; cursor cannot wander outside the text of the file being edited. -;; Free means the arrow keys can move the cursor past the ends of -;; lines. Free is the default mode in TPU; bound is the only mode -;; in EDT. Bound is the only mode in the base version of TPU-edt; -;; optional extensions add an approximation of free mode. - -;; Like TPU, emacs uses multiple buffers. Some buffers are used to -;; hold files you are editing; other "internal" buffers are used for -;; emacs' own purposes (like showing you help). Here are some commands -;; for dealing with buffers. - -;; Gold-B moves to next buffer, including internal buffers -;; Gold-N moves to next buffer containing a file -;; Gold-M brings up a buffer menu (like TPU "show buffers") - -;; Emacs is very fond of throwing up new windows. Dealing with all -;; these windows can be a little confusing at first, so here are a few -;; commands to that may help: - -;; Gold-Next_Scr moves to the next window on the screen -;; Gold-Prev_Scr moves to the previous window on the screen -;; Gold-TAB also moves to the next window on the screen - -;; Control-x 1 deletes all but the current window -;; Control-x 0 deletes the current window - -;; Note that the buffers associated with deleted windows still exist! - -;; Like TPU, TPU-edt has a "command" function, invoked with Gold-KP7 or -;; Do. Most of the commands available are emacs commands. Some TPU -;; commands are available, they are: replace, exit, quit, include, and -;; Get (unfortunately, "get" is an internal emacs function, so we are -;; stuck with "Get" - to make life easier, Get is available as Gold-g). - -;; Support for recall of commands, file names, and search strings was -;; added to emacs in version 19. For version 18 of emacs, optional -;; extensions are available to add this recall capability (see "Optional -;; TPU-edt Extensions" below). The history of strings recalled in both -;; versions of emacs differs slightly from TPU/edt, but it is still very -;; convenient. - -;; Help is available! The traditional help keys (Help and PF2) display -;; a three page help file showing the default keypad layout, control key -;; functions, and Gold key functions. Pressing any key inside of help -;; splits the screen and prints a description of the function of the -;; pressed key. Gold-PF2 invokes the native emacs help, with it's -;; zillions of options. Gold-Help shows all the current key bindings. - -;; Thanks to emacs, TPU-edt has some extensions that may make your life -;; easier, or at least more interesting. For example, Gold-r toggles -;; TPU-edt rectangular mode. In rectangular mode, Remove and Insert work -;; on rectangles. Likewise, Gold-* toggles TPU-edt regular expression -;; mode. In regular expression mode Find, Find Next, and the line-mode -;; replace command work with regular expressions. [A regular expression -;; is a pattern that denotes a set of strings; like VMS wildcards.] - -;; Emacs also gives TPU-edt the undo and occur functions. Undo does -;; what it says; it undoes the last change. Multiple undos in a row -;; undo multiple changes. For your convenience, undo is available on -;; Gold-u. Occur shows all the lines containing a specific string in -;; another window. Moving to that window, and typing ^C^C (Control-C -;; twice) on a particular line moves you back to the original window -;; at that line. Occur is on Gold-o. - -;; Finally, as you edit, remember that all the power of emacs is at -;; your disposal. It really is a fantastic tool. You may even want to -;; take some time and read the emacs tutorial; perhaps not to learn the -;; native emacs key bindings, but to get a feel for all the things -;; emacs can do for you. The emacs tutorial is available from the -;; emacs help function: "Gold-PF2 t" - - -;; %% Starting TPU-edt - -;; In order to use TPU-edt, the TPU-edt editor definitions, contained -;; in tpu-edt.el, need to be loaded when emacs is run. This can be -;; done in a couple of ways. The first is by explicitly requesting -;; loading of the TPU-edt emacs definition file on the command line: - -;; prompt> emacs -l /path/to/definitions/tpu-edt.el - -;; If TPU-edt is installed on your system, that is, if tpu-edt.el is in -;; a directory like /usr/local/emacs/lisp, along with dozens of other -;; .el files, you should be able to use the command: - -;; prompt> emacs -l tpu-edt - -;; If you like TPU-edt and want to use it all the time, you can load -;; the TPU-edt definitions using the emacs initialization file, .emacs. -;; Simply create a .emacs file in your home directory containing the -;; line: - -;; (load "/path/to/definitions/tpu-edt") - -;; or, if (as above) TPU-edt is installed on your system: - -;; (load "tpu-edt") - -;; Once TPU-edt has been loaded, you will be using an editor with the -;; interface shown in the next section (A section that is suitable for -;; cutting out of this document and pasting next to your terminal!). - - -;; %% TPU-edt Default Editing Keypad, Control and Gold Key Bindings -;; -;; _______________________ _______________________________ -;; | HELP | Do | | | | | | -;; |KeyDefs| | | | | | | -;; |_______|_______________| |_______|_______|_______|_______| -;; _______________________ _______________________________ -;; | Find |Insert |Remove | | Gold | HELP |FndNxt | Del L | -;; | | |Sto Tex| | key |E-Help | Find |Undel L| -;; |_______|_______|_______| |_______|_______|_______|_______| -;; |Select |Pre Scr|Nex Scr| | Page | Sect |Append | Del W | -;; | Reset |Pre Win|Nex Win| | Do | Fill |Replace|Undel W| -;; |_______|_______|_______| |_______|_______|_______|_______| -;; |Move up| |Forward|Reverse|Remove | Del C | -;; | Top | |Bottom | Top |Insert |Undel C| -;; _______|_______|_______ |_______|_______|_______|_______| -;; |Mov Lef|Mov Dow|Mov Rig| | Word | EOL | Char | | -;; |StaOfLi|Bottom |EndOfLi| |ChngCas|Del EOL|SpecIns| Enter | -;; |_______|_______|_______| |_______|_______|_______| | -;; | Line |Select | Subs | -;; | Open Line | Reset | | -;; |_______________|_______|_______| -;; Control Characters -;; -;; ^A toggle insert and overwrite ^L insert page break -;; ^B recall ^R remember, re-center -;; ^E end of line ^U delete to beginning of line -;; ^G cancel current operation ^V quote -;; ^H beginning of line ^W refresh -;; ^J delete previous word ^Z exit -;; ^K learn ^X^X exchange point and mark -;; -;; -;; Gold-<key> Functions -;; ----------------------------------------------------------------- -;; W Write - save current buffer -;; K Kill buffer - abandon edits and delete buffer -;; -;; E Exit - save current buffer and ask about others -;; X eXit - save all modified buffers and exit -;; Q Quit - exit without saving anything -;; -;; G Get - load a file into a new edit buffer -;; I Include - include a file in this buffer -;; -;; B next Buffer - display the next buffer (all buffers) -;; N Next file buffer - display next buffer containing a file -;; M buffer Menu - display a list of all buffers -;; -;; U Undo - undo the last edit -;; C Recall - edit and possibly repeat previous commands -;; -;; O Occur - show following lines containing REGEXP -;; S Search and substitute - line mode REPLACE command -;; -;; ? Spell check - check spelling in a region or entire buffer -;; -;; R Toggle Rectangular mode for remove and insert -;; * Toggle regular expression mode for search and substitute -;; -;; V Show TPU-edt version -;; ----------------------------------------------------------------- - - -;; %% Optional TPU-edt Extensions - -;; Several optional packages have been included in this distribution -;; of TPU-edt. The following is a brief description of each package. -;; See the {package}.el file for more detailed information and usage -;; instructions. - -;; tpu-extras - TPU/edt scroll margins and free cursor mode. -;; tpu-recall - String, file name, and command history. -;; vt-control - VTxxx terminal width and keypad controls. - -;; Packages are normally loaded from the emacs initialization file -;; (discussed below). If a package is not installed in the emacs -;; lisp directory, it can be loaded by specifying the complete path -;; to the package file. However, it is preferable to modify the -;; emacs load-path variable to include the directory where packages -;; are stored. This way, packages can be loaded by name, just as if -;; they were installed. The first part of the sample .emacs file -;; below shows how to make such a modification. - - -;; %% Customizing TPU-edt using the Emacs Initialization File - -;; .emacs - a sample emacs initialization file - -;; This is a sample emacs initialization file. It shows how to invoke -;; TPU-edt, and how to customize it. - -;; The load-path is where emacs looks for files to fulfill load requests. -;; If TPU-edt is not installed in a standard emacs directory, the load-path -;; should be updated to include the directory where the TPU-edt files are -;; stored. Modify and un-comment the following section if TPU-ed is not -;; installed on your system - be sure to leave the double quotes! - -;; (setq load-path -;; (append (list (expand-file-name "/path/to/tpu-edt/files")) -;; load-path)) - -;; Load TPU-edt -(load "tpu-edt") - -;; Load the optional goodies - scroll margins, free cursor mode, command -;; and string recall. But don't complain if the file aren't available. -(load "tpu-extras" t) -(load "tpu-recall" t) - -;; Uncomment this line to set scroll margins 10% (top) and 15% (bottom). -;(and (fboundp 'tpu-set-scroll-margins) (tpu-set-scroll-margins "10%" "15%")) - -;; Load the vtxxx terminal control functions, but don't complain if -;; if the file is not found. -(load "vt-control" t) - -;; TPU-edt treats words like EDT; here's how to add word separators. -;; Note that backslash (\) and double quote (") are quoted with '\'. -(tpu-add-word-separators "]\\[-_,.\"=+()'/*#:!&;$") - -;; Emacs is happy to save files without a final newline; other Unix programs -;; hate that! This line will make sure that files end with newlines. -(setq require-final-newline t) - -;; Emacs has the ability to automatically run code embedded in files -;; you edit. This line makes emacs ask if you want to run the code. -(if tpu-emacs19-p (setq enable-local-variables "ask") - (setq inhibit-local-variables t)) - -;; Emacs uses Control-s and Control-q. Problems can occur when using emacs -;; on terminals that use these codes for flow control (Xon/Xoff flow control). -;; These lines disable emacs' use of these characters. -(global-unset-key "\C-s") -(global-unset-key "\C-q") - -;; top, bottom, bol, eol seem like a waste of Gold-arrow functions. The -;; following section re-maps up and down arrow keys to top and bottom of -;; screen, and left and right arrow keys to pan left and right (pan-left, -;; right moves the screen 16 characters left or right - try it, you'll -;; like it!). - -;; Re-map the Gold-arrow functions -(define-key GOLD-CSI-map "A" 'tpu-beginning-of-window) ; up-arrow -(define-key GOLD-CSI-map "B" 'tpu-end-of-window) ; down-arrow -(define-key GOLD-CSI-map "C" 'tpu-pan-right) ; right-arrow -(define-key GOLD-CSI-map "D" 'tpu-pan-left) ; left-arrow -(define-key GOLD-SS3-map "A" 'tpu-beginning-of-window) ; up-arrow -(define-key GOLD-SS3-map "B" 'tpu-end-of-window) ; down-arrow -(define-key GOLD-SS3-map "C" 'tpu-pan-right) ; right-arrow -(define-key GOLD-SS3-map "D" 'tpu-pan-left) ; left-arrow - -;; Re-map the Gold-arrow functions for X-windows TPU-edt (emacs version 19) -(cond - ((and tpu-emacs19-p window-system) - (define-key GOLD-map [up] 'tpu-beginning-of-window) ; up-arrow - (define-key GOLD-map [down] 'tpu-end-of-window) ; down-arrow - (define-key GOLD-map [right] 'tpu-pan-right) ; right-arrow - (define-key GOLD-map [left] 'tpu-pan-left))) ; left-arrow - -;; The emacs universal-argument function is very useful for native emacs -;; commands. This line maps universal-argument to Gold-PF1 -(define-key GOLD-SS3-map "P" 'universal-argument) ; Gold-PF1 - -;; Make KP7 move by paragraphs, instead of pages. -(define-key SS3-map "w" 'tpu-paragraph) ; KP7 - -;; TPU-edt assumes you have the ispell spelling checker; -;; Un-comment this line if you don't. -;(setq tpu-have-spell nil) - -;; Display the TPU-edt version. -(tpu-version) - -;; End of .emacs - a sample emacs initialization file - -;; After initialization with the .emacs file shown above, the editing -;; keys have been re-mapped to look like this: - -;; _______________________ _______________________________ -;; | HELP | Do | | | | | | -;; |KeyDefs| | | | | | | -;; |_______|_______________| |_______|_______|_______|_______| -;; _______________________ _______________________________ -;; | Find |Insert |Remove | | Gold | HELP |FndNxt | Del L | -;; | | |Sto Tex| | U Arg |E-Help | Find |Undel L| -;; |_______|_______|_______| |_______|_______|_______|_______| -;; |Select |Pre Scr|Nex Scr| |Paragra| Sect |Append | Del W | -;; | Reset |Pre Win|Nex Win| | Do | Fill |Replace|Undel W| -;; |_______|_______|_______| |_______|_______|_______|_______| -;; |Move up| |Forward|Reverse|Remove | Del C | -;; |Tscreen| |Bottom | Top |Insert |Undel C| -;; _______|_______|_______ |_______|_______|_______|_______| -;; |Mov Lef|Mov Dow|Mov Rig| | Word | EOL | Char | | -;; |PanLeft|Bscreen|PanRigh| |ChngCas|Del EOL|SpecIns| Enter | -;; |_______|_______|_______| |_______|_______|_______| | -;; | Line |Select | Subs | -;; | Open Line | Reset | | -;; |_______________|_______|_______| - -;; Astute emacs hackers will realize that on systems where TPU-edt is -;; installed, this documentation file can be loaded to produce the above -;; editing keypad layout. In fact, to get all the changes in the sample -;; initialization file, you only need a one line initialization file: - -;; (load "tpu-doc") - -;; wow! - - -;; %% Compiling TPU-edt - -;; It is not necessary to compile (byte-compile in emacs parlance) -;; TPU-edt to use it. However, byte-compiled code loads and runs -;; faster, and takes up less memory when loaded. To byte compile -;; TPU-edt, use the following command. - -;; emacs -batch -f batch-byte-compile tpu-edt.el - -;; This will produce a file named tpu-edt.elc. This new file can be -;; used in place of the original tpu-edt.el file. In commands where -;; the file type is not specified, emacs always attempts to use the -;; byte-compiled version before resorting to the source. - - -;; %% Regular expressions in TPU-edt - -;; Gold-* toggles TPU-edt regular expression mode. In regular expression -;; mode, find, find next, replace, and substitute accept emacs regular -;; expressions. A complete list of emacs regular expressions can be -;; found using the emacs "info" command (it's somewhat like the VMS help -;; command). Try the following sequence of commands: - -;; DO info <enter info mode> -;; m regex <select the "regular expression" topic> -;; m directives <select the "directives" topic> - -;; Type "q" to quit out of info mode. - -;; There is a problem in regular expression mode when searching for -;; empty strings, like beginning-of-line (^) and end-of-line ($). -;; When searching for these strings, find-next may find the current -;; string, instead of the next one. This can cause global replace and -;; substitute commands to loop forever in the same location. For this -;; reason, commands like - -;; replace "^" "> " <add "> " to beginning of line> -;; replace "$" "00711" <add "00711" to end of line> - -;; may not work properly. - -;; Commands like those above are very useful for adding text to the -;; beginning or end of lines. They might work on a line-by-line basis, -;; but go into an infinite loop if the "all" response is specified. If -;; the goal is to add a string to the beginning or end of a particular -;; set of lines TPU-edt provides functions to do this. - -;; Gold-^ Add a string at BOL in region or buffer -;; Gold-$ Add a string at EOL in region or buffer - -;; There is also a TPU-edt interface to the native emacs string -;; replacement commands. Gold-/ invokes this command. It accepts -;; regular expressions if TPU-edt is in regular expression mode. Given -;; a repeat count, it will perform the replacement without prompting -;; for confirmation. - -;; This command replaces empty strings correctly, however, it has its -;; drawbacks. As a native emacs command, it has a different interface -;; than the emulated TPU commands. Also, it works only in the forward -;; direction, regardless of the current TPU-edt direction. - - -;; %% Etcetera - -;; That's TPU-edt in a nutshell... - -;; Please send any bug reports, feature requests, or cookies to the -;; author, Rob Riepel, at the address shown by the tpu-version command -;; (Gold-V). - -;; Share and enjoy... Rob Riepel 7/93 - -;;; tpu-doc.el ends here diff --git a/lisp/vmsx.el b/lisp/vmsx.el deleted file mode 100644 index b3ab41e51f7..00000000000 --- a/lisp/vmsx.el +++ /dev/null @@ -1,144 +0,0 @@ -;;; vmsx.el --- run asynchronous VMS subprocesses under Emacs - -;; Copyright (C) 1986 Free Software Foundation, Inc. - -;; Author: Mukesh Prasad -;; Maintainer: FSF -;; Keywords: vms - -;; 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, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; Code: - -(defvar display-subprocess-window nil - "If non-nil, the suprocess window is displayed whenever input is received.") - -(defvar command-prefix-string "$ " - "String to insert to distinguish commands entered by user.") - -(defvar subprocess-running nil) -(defvar command-mode-map nil) - -(if command-mode-map - nil - (setq command-mode-map (make-sparse-keymap)) - (define-key command-mode-map "\C-m" 'command-send-input) - (define-key command-mode-map "\C-u" 'command-kill-line)) - -(defun subprocess-input (name str) - "Handles input from a subprocess. Called by Emacs." - (if display-subprocess-window - (display-buffer subprocess-buf)) - (let ((old-buffer (current-buffer))) - (set-buffer subprocess-buf) - (goto-char (point-max)) - (insert str) - (insert ?\n) - (set-buffer old-buffer))) - -(defun subprocess-exit (name) - "Called by Emacs upon subprocess exit." - (setq subprocess-running nil)) - -(defun start-subprocess () - "Spawns an asynchronous subprocess with output redirected to -the buffer *COMMAND*. Within this buffer, use C-m to send -the last line to the subprocess or to bring another line to -the end." - (if subprocess-running - (return t)) - (setq subprocess-buf (get-buffer-create "*COMMAND*")) - (save-excursion - (set-buffer subprocess-buf) - (use-local-map command-mode-map)) - (setq subprocess-running (spawn-subprocess 1 'subprocess-input - 'subprocess-exit)) - ;; Initialize subprocess so it doesn't panic and die upon - ;; encountering the first error. - (and subprocess-running - (send-command-to-subprocess 1 "ON SEVERE_ERROR THEN CONTINUE"))) - -(defvar subprocess-command-to-buffer-tmpdir "SYS$SCRATCH:" - "*Put temporary files from subprocess-command-to-buffer here.") - -(defun subprocess-command-to-buffer (command buffer) - "Execute command and redirect output into buffer. - -BUGS: only the output up to the end of the first image activation is trapped." - (if (not subprocess-running) - (start-subprocess)) - (save-excursion - (set-buffer buffer) - (let ((output-filename - (concat subprocess-command-to-buffer-tmpdir - "OUTPUT-FOR-" (getenv "USER") ".LISTING"))) - (while (file-attributes output-filename) - (delete-file output-filename)) - (send-command-to-subprocess 1 (concat "DEFINE/USER SYS$OUTPUT " - output-filename "-NEW")) - (send-command-to-subprocess 1 command) - (send-command-to-subprocess 1 (concat "RENAME " output-filename - "-NEW " output-filename)) - (while (not (file-attributes output-filename)) - (sleep-for 2)) - (insert-file output-filename)))) - -(defun subprocess-command () - "Starts asynchronous subprocess if not running and switches to its window." - (interactive) - (if (not subprocess-running) - (start-subprocess)) - (and subprocess-running - (progn (pop-to-buffer subprocess-buf) (goto-char (point-max))))) - -(defun command-send-input () - "If at last line of buffer, sends the current line to -the spawned subprocess. Otherwise brings back current -line to the last line for resubmission." - (interactive) - (beginning-of-line) - (let ((current-line (buffer-substring (point) - (progn (end-of-line) (point))))) - (if (eobp) - (progn - (if (not subprocess-running) - (start-subprocess)) - (if subprocess-running - (progn - (beginning-of-line) - (send-command-to-subprocess 1 current-line) - (if command-prefix-string - (progn (beginning-of-line) (insert command-prefix-string))) - (next-line 1)))) - ;; else -- if not at last line in buffer - (end-of-buffer) - (backward-char) - (next-line 1) - (if (string-equal command-prefix-string - (substring current-line 0 (length command-prefix-string))) - (insert (substring current-line (length command-prefix-string))) - (insert current-line))))) - -(defun command-kill-line() - "Kills the current line. Used in command mode." - (interactive) - (beginning-of-line) - (kill-line)) - -(define-key esc-map "$" 'subprocess-command) - -;;; vmsx.el ends here diff --git a/lisp/word-help.el b/lisp/word-help.el deleted file mode 100644 index 3a7644d7be9..00000000000 --- a/lisp/word-help.el +++ /dev/null @@ -1,970 +0,0 @@ -;;; word-help.el --- keyword help for any language doc'd in TeXinfo. - -;; Copyright (c) 1996 Free Software Foundation, Inc. - -;; Author: Jens T. Berger Thielemann <jensthi@ifi.uio.no> -;; Keywords: help, keyword, languages, completion - -;; This file is part of GNU Emacs. - -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; This package provides a rather general interface for doing keyword -;; help in most languages. In short, it'll determine which TeXinfo -;; file which is relevant for the current mode; cache the index and -;; use regexps to give you help on the keyword you're looking at. - -;; Installation -;; ************ - -;; For the default setup to work for all supported modes, make sure -;; the Texinfo files from the following packages are installed: - -;; Texinfo file | Available in archive or URL | Notes -;; autoconf.info | autoconf-2.10.tar.gz | - -;; bison.info | bison-1.25.tar.gz | - -;; libc.info | glibc-1.09.1.tar.gz | - -;; elisp.info | elisp-manual-19-2.4.tar.gz | - -;; latex.info | ftp://ftp.dante.de/pub/tex/info/latex2e-help-texinfo/latex2e.texi -;; groff.info | groff-1.10.tar.gz | - -;; m4.info | m4-1.4.tar.gz | - -;; make.info | make-3.75.tar.gz | - -;; perl.info | http://www.perl.com/CPAN/doc/manual/info/ -;; simula.info | Mail bjort@ifi.uio.no | Written in Norwegian -;; texinfo.info | texinfo-3.9.tar.gz | - - -;; BTW: We refer to Texinfo files by just their last component, not -;; with an absolute file name. You must thus set up -;; `Info-directory-list' and `Info-default-directory-list' so that -;; these can automatically be located. - -;; Usage -;; ***** -;; -;; Place the cursor over the function/variable/type/whatever you want -;; help on. Type "C-h C-i". `word-help' will then make a suggestion -;; to an index topic; press return to accept this. If not, you may use -;; tab-completion to find the topic you're interested in. - -;; `word-help' is also able to do symbol completion via the -;; `word-help-complete' function. Bind this function to C-TAB by -;; adding the following line to your .emacs file: -;; -;; (global-set-key [?\M-\t] 'word-help-complete) -;; -;; Note that some modes automatically override this key; you may -;; therefore wish to either put the above statement in a hook or -;; associate the function with an other key. - -;; Usually, `word-help' is able to determine the relevant Texinfo -;; file from looking at the buffer's `mode-name'; if not, you can use -;; the interactive function `set-help-file' to set this. - -;; Customizing -;; *********** -;; -;; User interface -;; -------------- -;; -;; Two variables control the behaviour of the user-interface of -;; `word-help': `word-help-split-window' and -;; `word-help-magic-index'. Do C-h v to get more information on -;; these. - -;; Adding more Texinfo files -;; ------------------------- -;; -;; Associations between mode-names and Texinfo files can be done -;; through the `word-help-mode-alist' variable, which defines an -;; `alist' making `set-help-file' able to initialize the necessary -;; variable. - -;; NOTE: If you have to customize the regexps, it is *CRUCIAL* that -;; none of your regexps match the empty string! Not adhering to this -;; restriction will make `word-help' enter an infinite loop. - -;; Contacting the author -;; ********************* -;; -;; If you wish to contact me for any reason, please feel free to write -;; to: - -;; Jens Berger -;; Spektrumveien 4 -;; N-0666 Oslo -;; Norway -;; -;; E-mail: <jensthi@ifi.uio.no> - -;; Have fun. - -;; -;;; Code: -;; - -(require 'info) - -;;;-------------------- -;;; USER OPTIONS -;;;-------------------- - -(defvar word-help-split-window t - "*Non-nil means that the info buffer will pop up in a separate window. -If nil, we will just switch to it.") - -(defvar word-help-magic-index t - "*Non-nil means that the keyword will be searched for in the requested node. -This is done by determining whether the line the point is positioned -on after using `Info-goto-node', actually contains the keyword. If -not, we will search for the first occurence of the keyword. This may -help when the info file isn't correctly indexed.") - -;;; ---- end of user configurable variables - -;;;------------------------- -;;; ADVANCED USER OPTIONS -;;;------------------------- - -(defvar word-help-mode-alist - '( - ("autoconf" - (("autoconf" "Macro Index") ("m4" "Macro index")) - (("AC_\\([A-Za-z0-9_]+\\)" 1) - ("[a-z]+")) - nil - nil - (("AC_\\([A-Za-z0-9_]+\\)" 1 nil (("^[A-Z_]+$"))) - ("[a-z_][a-z_]*" 0 nil (("^[a-z_]+$"))))) - - ("Bison" - (("bison" "Index") - ("libc" "Type Index" "Function Index" "Variable Index")) - (("%[A-Za-z]*") - ("[A-Za-z_][A-Za-z0-9_]*")) - nil - nil - (("%[A-Za-z]*" nil nil (("^%"))) - ("[A-Za-z_][A-Za-z0-9_]*" nil nil (("[A-Za-z_][A-Za-z0-9_]*"))))) - - ("YACC" . "Bison") - - ("C" (("libc" "Type Index" "Function Index" "Variable Index"))) - ("C++" . "C") - - ("Emacs-Lisp" - (("elisp" "Index")) - (("[^][ ()\n\t.\"'#]+")) - nil - nil - lisp-complete-symbol) - - ("LaTeX" - (("latex" "Command Index")) - (("\\\\\\(begin\\|end\\){\\([^}\n]+\\)}" 2 0) - ("\\\\[A-Za-z]+") - ("\\\\[^A-Za-z]") - ("[A-Za-z]+")) - nil - nil - (("\\\\begin{\\([A-Za-z]*\\)" 1 "}" (("^[A-Za-z]+$"))) - ("\\\\end{\\([A-Za-z]*\\)" 1 "}" (("^[A-Za-z]+$"))) - ("\\\\renewcommand{\\(\\\\?[A-Za-z]*\\)" 1 "}" (("^\\\\[A-Za-z]+"))) - ("\\\\renewcommand\\(\\\\?[A-Za-z]*\\)" 1 "" (("^\\\\[A-Za-z]+"))) - ("\\\\renewenvironment{?\\([A-Za-z]*\\)" 1 "}"(("^[A-Za-z]+$"))) - ("\\\\[A-Za-z]*" 0 "" (("^\\\\[A-Za-z]+"))))) - - ("latex" . "LaTeX") - - ("Nroff" - (("groff" "Macro Index" "Register Index" "Request Index")) - (("\\.[^A-Za-z]") - ("\\.[A-Za-z]+") - ("\\.\\([A-Za-z]+\\)" 1)) - nil - nil - (("\\.[A-Za-z]*" nil nil (("^\\.[A-Za-z]+$"))) - ("\\.\\([A-Za-z]*\\)" 1 nil (("^[A-Za-z]+$"))))) - - ("Groff" . "Nroff") - - ("m4" - (("m4" "Macro index")) - (("\\([mM]4_\\)?\\([A-Za-z_][A-Za-z_0-9]*\\)" 2)) - nil - nil - (("[mM]4_\\([A-Za-z_]?[A-Za-z_0-9]*\\)" 1) - ("[A-Za-z_][A-Za-z_0-9]*"))) - - ("Makefile" - (("make" "Name Index")) - (("\\.[A-Za-z]+") ;; .SUFFIXES - ("\\$[^()]") ;; $@ - ("\\$([^A-Za-z].)") ;; $(<@) - ("\\$[\(\{]\\([a-zA-Z+]\\)" 1) ;; $(wildcard) - ("[A-Za-z]+")) ;; foreach - nil - nil - (("\\.[A-Za-z]*" nil ":" (("^\\.[A-Za-z]+$"))) - ("\\$(\\([A-Z]*\\)" 1 ")" (("^[A-Z]"))) - ("[a-z]+" nil nil (("^[a-z]+$"))))) - - ("Perl" - (("perl" "Variable Index" "Function Index")) - (("\\$[^A-Za-z^]") ;; $@ - ("\\$\\^[A-Za-z]?") ;; $^D - ("\\$[A-Za-z][A-Za-z_0-9]+") ;; $foobar - ("[A-Za-z_][A-Za-z_0-9]+")) ;; dbmopen - nil - nil - (("\\$[A-Za-z]*" nil nil (("^\\$[A-Za-z]+$"))) ;; $variable - ("[A-Za-z_][A-Za-z_0-9]*" nil nil - (("^[A-Za-z_][A-Za-z_0-9]*$"))))) ;; function - - ("Simula" (("simula" "Index")) nil t) - ("Ifi Simula" . "Simula") - ("SIMULA" . "Simula") - - ("Texinfo" - (("texinfo" "Command and Variable Index")) - (("@\\([A-Za-z]+\\)" 1)) - nil - nil - (("@\\([A-Za-z]*\\)" 1))) - - ) - "Assoc list between `mode-name' and Texinfo files. -The variable should be initialized with a list of elements with the -following form: - -\(mode-name (word-help-info-files) (word-help-keyword-regexps) - word-help-ignore-case word-help-index-mapper - word-help-complete-list) - -where `word-help-info-files', `word-help-keyword-regexps' and so -forth of course are the values which should be put in these variables -for this mode. Note that `mode-name' doesn't have to be a legal -mode-name; the user may use the call `set-help-file', where -`mode-name' will be used in the `completing-read'. - -Example entry (for C): - -\(\"C\" ((\"libc\" \"Type Index\" \"Function Index\" \"Variable Index\")) - ((\"[A-Za-z_][A-Za-z0-9]+\"))) - -The two first variables must be initialized; the two remaining will -get default values if you omit them or set them to nil. The default -values are: - -word-help-keyword-regexps: (\"[A-Za-z_][A-Za-z0-9]+\") -word-help-ignore-case: nil - -More settings may be defined in the future. - -You may also define aliases, if there are several relevant mode-names -to a single entry. These should be of the form: - -\(MODE-NAME-ALIAS . MODE-NAME-REAL) - -For C++, you would use the alias - -\(\"C++\" . \"C\") - -to make C++ mode use the same help files as C files do. Please note -that you can shoot yourself in the foot with this possibility, by -defining recursive aliases.") - -;;; --- end of advanced user options - -(defvar word-help-ignore-case nil - "Non-nil means that case is ignored when doing lookup.") -(make-variable-buffer-local 'word-help-ignore-case) - -(defvar word-help-info-files nil - "List of info files with respective nodes, for the current mode. - -This should be a list of the following form: - -\((INFO-FILE-1 NODE-NAME-1 NODE-NAME-2 ...) - (INFO-FILE-1 NODE-NAME-1 NODE-NAME-2 ...) - : : : - (INFO-FILE-1 NODE-NAME-1 NODE-NAME-2 ...)) - -An example entry for e.g. C would be: - -\((\"/local/share/gnu/info/libc\" \"Function Index\" \"Type Index\" - \"Variable Index\")) - -The files and nodes will be searched/cached in the order specified. -This variable is usually set by the `word-help-switch-help-file' -function, which utilizes the `word-help-mode-alist'.") -(make-variable-buffer-local 'word-help-info-files) - -(defvar word-help-keyword-regexps nil - "Regexps for finding keywords in the current mode. - -This is constructed as a list of the following form: - -\((REGEXP SUBMATCH-LOOKUP SUBMATCH-CURSOR) - (REGEXP SUBMATCH-LOOKUP SUBMATCH-CURSOR) - : : : - (REGEXP SUBMATCH-LOOKUP SUBMATCH-CURSOR)) - -The regexps will be searched in order for a match which the cursor is -within. - -submatch-lookup is the submatch number which will be looked for in the -index. May be omitted; defaults to 0 (e.g. the entire pattern). This is -useful in for instance configure lookup; each command is there prefixed -with 'AC_', which must be ignored when doing a lookup. Example regexp -entry for this: - -\(\"AC_\\\\([A-Za-z0-9]+\\\\)\" 1) - -submatch-cursor is the part of the match which the cursor must be within. -May be omitted; defaults to 0 (e.g. the entire pattern).") -(make-variable-buffer-local 'word-help-keyword-regexps) -(set-default 'word-help-keyword-regexps '(("[A-Za-z_][A-Za-z_0-9]*"))) - -(defvar word-help-index-mapper nil - "Regexps to use for massaging index-entries into keywords. -This variable should contain a list of regexps with sub-expressions, -where we will only look for the sub-expression in the user text. - -The regexp list should be formatted as: - - ((REGEXP SUBEXP) (REGEXP SUBEXP) ... ) - -If the index entry does not match any of the regexps, it will be ignored. - -Example: - -Perl has index entries of the following form: - -* abs VALUE: perlfunc. -* accept NEWSOCKET,GENERICSOCKET: perlfunc. -* alarm SECONDS: perlfunc. -* atan2 Y,X: perlfunc. -* bind SOCKET,NAME: perlfunc. - : : : - -We will thus try to extract the first word in the index entry - -\"abs\" from \"abs VALUE\", etc. This is done by the following entry: - -\((\"^\\\\([^ \\t\\n]+\\\\)\" 1)) - -This value is btw. the default one, and works with most Texinfo files") -(make-variable-buffer-local 'word-help-index-mapper) -(set-default 'word-help-index-mapper '(("^\\([^ \t\n]+\\)" 1))) - - -(defvar word-help-complete-list nil - "Regexps or function to use for completion of symbols. -The list should have the following format: - - ((REGEXP SUBMATCH TEXT-APPEND (RE-FILTER-1 REG-FILTER-2 ...) - : : : : : - (REGEXP SUBMATCH TEXT-APPEND (RE-FILTER-1 REG-FILTER-2 ...)) - -The two first entries are similar to `word-help-keyword-regexps', -REGEXP is a regular expression which should match any relevant -expression, and where SUBMATCH should be used for look up. By -specifying non-nil REGEXP-FILTERs, we'll only include entries in the -index which matches the regexp specified. - -If the contents of this variable is a symbol of a function, this -function will be called instead. This is useful for modes providing -a more intelligent function (like `lisp-complete-symbol' in Emacs Lisp mode). - -If you would like to use another function instead, you may. - -Non-nil TEXT-APPEND means that this text will be inserted after the -completion, if we manage to do make a completion.") -(make-variable-buffer-local 'word-help-complete-list) -(set-default 'word-help-complete-list '(("[A-Za-z_][A-Za-z_0-9]*"))) - -;;; Work variables - - -(defvar word-help-main-index nil - "List of all index entries. - -See `word-help-process-indexes' for structure formatting. - -Minor note: This variable is a list if it is initialized, t if -initializing failed and nil if uninitialized.") -(make-variable-buffer-local 'word-help-main-index) - -(defvar word-help-complete-index nil - "List of regexps for completion, with matching index entries. -Value is nil if uninitialized, t if initialized but not accessible, -a list if we're feeling ok.") -(make-variable-buffer-local 'word-help-complete-index) - -(defvar word-help-main-obarray nil - "Global work variable for `word-help' system. -Do Not mess with this!") - -(defvar word-help-history nil - "History for `word-help' minibuffer queries.") -(make-local-variable 'word-help-history) - -(defvar word-help-current-help-file nil - "Current help file active for this mode.") - -(defvar word-help-index-alist nil - "An assoc list mapping help files to info indexes. -This means that `word-help-mode-index' can be init'ed faster.") - -(defvar word-help-help-mode nil - "Which mode the help system is bound to for the current mode.") -(make-variable-buffer-local 'word-help-help-mode) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;; User Functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; Debugging - -;;;###autoload -(defun reset-word-help () - "Clear all cached indexes in the `word-help' system. -You should only need this when installing new info files, and/or -adding more Texinfo files to the `word-help' system." - (interactive) - (setq word-help-index-alist nil - word-help-main-index nil - word-help-info-files nil - word-help-complete-index nil)) - - -;;; Changing help file - -;;;###autoload -(defun set-word-help-file () - "Change which set of Texinfo files used for word-help. - -`word-help' maintains a list over which Texinfo files which are -relevant for each programming language (`word-help-mode-alist'). It -usually selects the correct one, based upon the value of `mode-name'. -If this guess is incorrect, you may also use this function manually to -instruct future `word-help' calls which Texinfo files to use." - (interactive) - (let (helpfile helpguess (completion-ignore-case t)) -;; Try to make a guess - (setq helpguess (cond - (word-help-current-help-file) - ((word-help-guess-help-file)))) -;; Ask the user - (setq helpfile (completing-read - (if helpguess - (format "Select help mode (default %s): " helpguess) - "Select help mode: ") - word-help-mode-alist - nil t nil nil)) - (if (equal "" helpfile) - (setq helpfile helpguess)) - (if helpfile - (word-help-switch-help-file helpfile)))) - -;;; Main user interface - -;;;###autoload -(defun word-help () - "Find documentation on the keyword under the cursor. -The determination of which language the keyword belongs to, is based upon -The relevant info file is selected by matching `mode-name' (the major -mode) against the assoc list `word-help-mode-alist'. - -If this is not possible, `set-help-file' will be invoked for selecting -the relevant info file. `set-help-file' may also be invoked -interactively by the user. - -If the keyword you are looking at is not available in any index, no -default suggestion will be presented. " - (interactive) - (let (myguess guess index-info - (completion-ignore-case word-help-ignore-case)) -;; Set necessary variables for later lookup - (word-help-find-help-file) -;; Have we previously cached datas? - (word-help-process-indexes) - (if - (atom word-help-main-index) - (message "No help file available for this mode.") -;; First make a guess at what the user is looking for - (setq myguess (word-help-guess - (point) - (cond - ((not (atom word-help-main-index)) - (car word-help-main-index))) - word-help-keyword-regexps)) -;; Ask the user himself - (setq guess (completing-read - ; Format string - (if myguess - (format "Look up keyword (default %s): " myguess) - "Look up keyword: ") - ; Collection - (car word-help-main-index) - nil t nil 'word-help-history)) - (if (equal guess "") - (setq guess myguess)) -;; If we've got anything meaningful to lookup, do so - (if (not guess) - (message "Help aborted.") - (setq index-info (word-help-find-index-node - guess - word-help-main-index)) - (if (not index-info) - (message "Oops, I could not find \"%s\" anyway! Bug?" guess) - (word-help-goto-index-node (nconc index-info (list guess)))))))) - -;;;###autoload -(defun word-help-complete () - "Perform completion on the symbol preceding the point. -The determination of which language the keyword belongs to, is based upon -The relevant info file is selected by matching `mode-name' (the major -mode) against the assoc list `word-help-mode-alist'. - -If this is not possible, `set-help-file' will be invoked for selecting -the relevant info file. `set-help-file' may also be invoked -interactively by the user. - -The keywords are extracted from the index of the info file defined for -this mode, by using the `word-help-complete-list' variable." - (interactive) - (word-help-make-complete) - (cond - ((not word-help-complete-index) - (message "No completion available for this mode.")) - ((symbolp word-help-complete-index) - (call-interactively word-help-complete-index)) - ((listp word-help-complete-index) - (let ((all-match (word-help-guess-all (point) - word-help-complete-index t)) - (completion-ignore-case word-help-ignore-case) - (c-list word-help-complete-index) - c-entry word-match completion completed) -;; Loop over and try to find a match - (while (and all-match (not completed)) - (setq word-match (car all-match) - c-entry (car c-list) - c-list (cdr c-list) - all-match (cdr all-match)) -;; Check whether the current pattern matched - (if word-match - (let ((close (nth 3 c-entry)) - (words (nth 4 c-entry))) -;; Find the maximum completion for this word -; (print word-match) -; (print c-entry) -; (print close) - (setq completion (try-completion word-match words)) -;; Was the match exact - (cond ((eq completion t) - (and close - (not (looking-at (regexp-quote close))) - (insert close)) - (setq completed t)) -;; Silently ignore non-matches - ((not completion)) -;; May we complete more unambiguously - ((not (string-equal completion word-match)) - (delete-region (- (point) (length word-match)) - (point)) - (insert completion) - (if (eq t (try-completion completion words)) - (progn - (and close - (not (looking-at (regexp-quote close))) - (insert close)))) - (setq completed t)) - (t - (message "Making completion list...") - (let ((list (all-completions word-match words nil))) - (setq completed list) - (with-output-to-temp-buffer "*Completions*" - (display-completion-list list))) - (message "Making completion list...done")))))) - (if (not completed) (message "No match.")))) - (t (message "No completion available for this mode.")))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;; Index mapping ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - -(defun word-help-map-index-entries (str re-list) - "Transform an Info index entry into a programming keyword. -Uses this by mapping the entries through `word-help-index-mapper'." - (let ((regexp (car (car re-list))) - (subexp (car (cdr (car re-list)))) - (next (cdr re-list))) - (cond - ((string-match regexp str) - (substring str (match-beginning subexp) (match-end subexp))) - (next - (word-help-map-index-entries str next))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;; Switch mode files ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; Mode lookup - -(defun word-help-guess-help-file () - "Guesses a relevant help file based on mode name. -Returns nil if no guess could be made. Uses `word-help-mode-alist'." - (let (guess) - (cond - ((setq guess (assoc mode-name word-help-mode-alist)) - (car guess))))) - - -(defun word-help-switch-help-file (helpfile) - "Changes the help-file to the mode name given. -Uses `word-help-mode-alist'." - (if helpfile - (let (helpdesc) - (if (not (setq helpdesc (assoc helpfile word-help-mode-alist))) - (message "No help defined for \"%s\"." helpfile) - (if (stringp (cdr helpdesc)) - (word-help-switch-help-file (cdr helpdesc)) - (word-help-make-default-map - helpdesc - (list 'word-help-help-mode - 'word-help-info-files - 'word-help-keyword-regexps - 'word-help-ignore-case - 'word-help-index-mapper - 'word-help-complete-list)))) - (setq word-help-main-index nil - word-help-complete-index nil)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;; Index collection ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - -(defun word-help-extract-index (file-name index-list index-map ignore-case) - "Extract index from filename and the first node name in index list. -`file-name' is the name of the info file, while `index-list' is a list -of node-names to search." - (let (cmd1 cmdlow nodename ob-array next (case-fold-search word-help-ignore-case)) - (setq nodename (car index-list)) - (setq ob-array (make-vector 211 0)) - (message "Processing \"%s\" in %s..." nodename file-name) - (save-window-excursion - (Info-goto-node (concat "(" file-name ")" nodename)) - (end-of-buffer) - (while (re-search-backward "\\* \\([^\n:]+\\):" nil t) - (setq cmd1 (buffer-substring (match-beginning 1) (match-end 1))) - (setq cmdlow (if ignore-case (downcase cmd1) cmd1)) - (if index-map - (setq cmdlow (word-help-map-index-entries cmdlow - index-map))) -;; We have to do this workaround to support case-insensitive matching - (cond - (cmdlow - (put (intern cmdlow ob-array) 'word-help-real-name cmd1) - (intern cmdlow word-help-main-obarray))))) - (setq next (cond - ((cdr index-list) - (word-help-extract-index file-name (cdr index-list) - index-map ignore-case)))) - (nconc (list (list nodename ob-array)) next))) - - -(defun word-help-collect-indexes (info-file) - "Process all the indexes in an info file. - -Uses `word-help-extract-index' on each node, and returns an entry -suitable for merging into `word-help-process-indexes'. `info-file' -is an entry of the form - -\(FILE-NAME INDEX-NAME-1 INDEX-NAME-2 ...)" - (let ((file (car info-file)) - (nodes (cdr info-file))) - (nconc (list file) (word-help-extract-index file nodes - word-help-index-mapper - word-help-ignore-case)))) - -(defun word-help-process-indexes () - "Process all the entries in the global variable `word-help-info-files'. -Returns a list formatted as follows: - -\(all-entries-ob - (file-name-1 (node-name-1 this-node-entries-ob) - (node-name-2 this-node-entries-ob) - : : : - (node-name-n this-node-entries-ob)) - (file-name-2 (node-name-1 this-node-entries-ob) - (node-name-2 this-node-entries-ob) - : : : - (node-name-n this-node-entries-ob)) - : : : : : : : : : - (file-name-n (node-name-1 this-node-entries-ob) - (node-name-2 this-node-entries-ob) - : : : - (node-name-n this-node-entries-ob))) - -The symbols in the obarrays may contain the additional property -`word-help-real-name', which tells the *real* node to go to. - -Note that we use `word-help-index-alist' to speed up the process. Note -that `word-help-switch-help-file' must have been called before this function. - -This structure is then later searched by `word-help-find-index-node'." - (let (index-words old-index) - (if (not word-help-main-index) - (cond - ((setq old-index - (assoc word-help-help-mode word-help-index-alist)) - (setq word-help-main-index (nth 1 old-index))) - (word-help-info-files - (setq word-help-main-obarray (make-vector 307 0) - index-words (mapcar 'word-help-collect-indexes - word-help-info-files) - word-help-main-index - (append (list word-help-main-obarray) index-words)) - (setq word-help-index-alist (cons (list word-help-help-mode - word-help-main-index) - word-help-index-alist))) - (t (setq word-help-main-index t)))))) - -(defun word-help-find-help-file () - "Tries to find and set a relevant help file for the current mode." - (let (helpguess) - (if (not word-help-info-files) - (if (setq helpguess (word-help-guess-help-file)) - (word-help-switch-help-file helpguess) - (set-help-file))))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;; Keyword guess ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun word-help-guess-all (cur-point re-list - &optional copy-to-point) - "Guesses *all* keywords the user possibly may be looking at. -Returns a list of all possible keywords. " - (let ((regexp (car (car re-list))) - (submatch (cond ((nth 1 (car re-list))) (0))) - (cursmatch (cond ((nth 2 (car re-list))) (0))) - (guess nil) - (next-guess nil) - (case-fold-search word-help-ignore-case) - (end-point nil)) - (save-excursion - (end-of-line) - (setq end-point (point)) - ;; Start at the beginning - (beginning-of-line) - (while (and (not guess) (re-search-forward regexp end-point t)) - ;; Look whether the cursor is within the match - (if (and (<= (match-beginning cursmatch) cur-point) - (>= (match-end cursmatch) cur-point)) - (if (or (not copy-to-point) (<= cur-point (match-end submatch))) - (setq guess (buffer-substring (match-beginning submatch) - (if copy-to-point - cur-point - (match-end submatch))))))) - ;; If we found anything, return it and call ourselves again - (if (cdr re-list) - (setq next-guess (word-help-guess-all cur-point (cdr re-list) - copy-to-point)))) - (cons guess next-guess))) - -(defun word-help-guess-match (all-match cmd-array) - (let ((sym (car all-match))) - (cond - ((and sym (intern-soft (if word-help-ignore-case - (downcase sym) - sym) cmd-array) - sym)) - ((cdr all-match) - (word-help-guess-match (cdr all-match) cmd-array))))) - - -(defun word-help-guess (cur-point cmd-array re-list) - "Guesses what keyword the user is looking at, and returns that. -CUR-POINT should be the current value of `point', CMD-ARRAY an obarray -of all the keywords which are defined for the current mode, and -RE-LIST a list of regexps use for the hunt. See also -`word-help-keyword-regexps'." - (let ((all-matches (word-help-guess-all cur-point re-list))) -; (print all-matches) - (word-help-guess-match all-matches cmd-array))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;; Show node for keyword ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; Find an index entry - -(defun word-help-find-index-node (node index-reg) - "Finds the node named `node' in the index-register `index-reg'. -`index-reg' has the format as returned (and documented) by the -`word-help-process-indexes' call. In most cases, this will be equal to -`word-help-main-index'. - -Returns a list with format - (file-name index-node-name index-entry) -which contains the file and index where the entry can be found. -Returns nil if the entry can't be found." - (let (file-info node-name) - (setq node-name (cond (word-help-ignore-case (downcase node)) (node))) - (if (intern-soft node-name (car index-reg)) - (setq file-info (word-help-index-search-file node-name - (cdr index-reg)))) - file-info)) - -(defun word-help-index-search-file (entry file-data) - "Searches a cached file for the index-entry `entry'." - (let (this-file next-files file-name node node-infos) - (setq this-file (car file-data) - next-files (cdr file-data) - file-name (car this-file) - node-infos (cdr this-file) - node (word-help-index-search-nodes entry node-infos)) - (cond - (node - (cons file-name node)) - (next-files (word-help-index-search-file entry next-files))))) - -(defun word-help-index-search-nodes (entry node-info) - "Searches a cached list of nodes for the entry `entry'." - (let (this-node next-nodes node-name node-ob node-sym) - (setq this-node (car node-info) - next-nodes (cdr node-info) - node-name (car this-node) - node-ob (car (cdr this-node)) - node-sym (intern-soft entry node-ob)) - (cond - (node-sym - (list node-name (get node-sym 'word-help-real-name))) - (next-nodes (word-help-index-search-nodes entry next-nodes))))) - -;;; Switch to a node in an index - -(defun word-help-goto-index-node (index-info) - "Jumps to an index node. -`index-info' should be a list with the following format: - -\(FILE-NAME INDEX-NODE-NAME INDEX-ENTRY KEYWORD)" - - (let* ((file-name (car index-info)) - (node-name (nth 1 index-info)) - (entry-name (nth 2 index-info)) - (kw-name (nth 3 index-info)) - (buffer (current-buffer))) - (if word-help-split-window - (pop-to-buffer nil)) - (Info-goto-node (concat "(" file-name ")" node-name)) - (Info-menu entry-name) -;; Do magic keyword search - (if word-help-magic-index - (let (end-point regs this-re found entry-re) - (setq entry-re (regexp-quote kw-name) - regs (list (concat - (if (string-match "^[A-Za-z]" entry-name) - "\\<" "") - entry-re - (if (string-match "[A-Za-z]$" entry-name) - "\\>" "")) - (concat "[`\"\(]" entry-re) - (concat "^" entry-re - (if (string-match "[A-Za-z]$" entry-name) - "\\>" "")))) - (end-of-line) - (setq end-point (point)) - (beginning-of-line) - (if (not (re-search-forward (car regs) end-point t)) - (while (and (not found) (car regs)) - (setq this-re (car regs) - regs (cdr regs) - found (re-search-forward this-re nil t)))) - (recenter 0))) - (if word-help-split-window - (pop-to-buffer buffer)))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Completion ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - - -(defun word-help-extract-matches (from-ob dest-ob re-list) - "Takes atoms from from-ob, and puts them in dest-ob if they match re-list." - (let ((regexp (car (car re-list)))) - (mapatoms (lambda (x) - (if (or (not regexp) (string-match regexp (symbol-name x))) - (intern (symbol-name x) dest-ob))) - from-ob) - (if (cdr re-list) - (word-help-extract-matches from-ob dest-ob (cdr re-list)))) - dest-ob) - -(defun word-help-make-complete () - "Generates the `word-help-complete-index'." - (if word-help-complete-index - nil - (word-help-find-help-file) - (cond - ((symbolp word-help-complete-list) - (setq word-help-complete-index word-help-complete-list)) - (t - (word-help-process-indexes) - (if (not (atom word-help-main-index)) - (let ((from-ob (car word-help-main-index))) - (message "Processing keywords...") - (setq word-help-complete-index - (mapcar - (lambda (cmpl) - (let - ((regexp (car cmpl)) - (subm (cond ((nth 1 cmpl)) (0))) - (app (cond ((nth 2 cmpl)) (""))) - (re-list (cond ((nth 3 cmpl)) ('(("."))))) - (obarr (make-vector 47 0))) - (list regexp subm subm app - (word-help-extract-matches from-ob obarr - re-list)))) - word-help-complete-list)))))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Misc. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - -;;; Default mapping - -(defun word-help-make-default-map (list vars) - "Makes a default mapping for `vars', which must be listed in order. -vars is a list of quoted symbols. If the nth entry in the list is -non-nil, the nth variable will be given this value. If nil, the var -will be given the global default value." - (set (car vars) (cond ((car list)) ((default-value (car vars))))) - (if (cdr vars) - (word-help-make-default-map (cdr list) (cdr vars)))) - -(provide 'word-help) - -;;; word-help.el ends here |