Mercurial > hg > xemacs
changeset 31:129123962e51
trying to merge lib/emacs and xemacs
| author | Henry S Thompson <ht@inf.ed.ac.uk> |
|---|---|
| date | Sat, 07 Oct 2023 12:43:14 +0100 |
| parents | 8e0e16f4763c (diff) 0e5b39d2f8bb (current diff) |
| children | cb9b76219c55 |
| files | |
| diffstat | 23 files changed, 4558 insertions(+), 0 deletions(-) [+] |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/local/ht-rooms-epoch.config Sat Oct 07 12:43:14 2023 +0100 @@ -0,0 +1,34 @@ +(defvar no-news nil "inhibit news startup") + +(define-rooms '(("elisp" ("*scratch*" nil 0 0 80 23) + ((" a") (emacs-lisp-mode) 0 23 80 47)) + ("text" ((" b") nil 0 0 80 47)) + ("diary" ("diary.babyl" + (progn (rmail-input "~/mail/diary.babyl") + (setq ht-last-file + (expand-file-name + "~/mail/history/diary.msg"))) + 0 0 80 12) + ("diary.babyl-summary" (update-default-diary t) 0 11 80 23)) + ("news" ("*Newsgroup*" (if (not no-news)(gnus)) 0 0 80 47)) + ("mail" ("RMAIL" (rmail) 0 0 80 47)))) + +(sit-for 1) + +(defun make-lisp-room () + "create and go to a room for lisp work" + (interactive) + (establish-room '("lisp" + ("*lisp*" (run-lisp) 0 0 80 23) + ((" ") (lisp-mode) 0 23 80 47)) + t)) + +(defun make-prolog-room () + "create and go to a room for prolog work" + (interactive) + (establish-room '("prolog" + ("*prolog*" (site-caseq (edin (run-prolog)) + (parc (run-sicstus))) + 0 0 80 23) + ((" ") (prolog-mode) 0 23 80 47)) + t))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lucid/lemacs-compat.el Sat Oct 07 12:43:14 2023 +0100 @@ -0,0 +1,42 @@ +;; Last edited: Thu Sep 24 14:57:39 1992 +;; backwards compatibility + +(setq mail-aliases t) + +;; hack not really quite right +(defun current-msec-time () (* 1000 (car (cdr (current-time))))) +(defun last-event-time () (event-timestamp last-input-event)) + +;; inhibit-local-variables-regexps --> inhibit-first-line-modes-regexps +;; needs to be fixed for edb + + +(defun ht-rmail-cease-edit () + "check if diary edit, move if so" + (interactive) + (rmail-cease-edit) + (if editing-diary-entry + (progn (setq editing-diary-entry nil) + (ht-output-to-Calendar) + (rmail-output-to-rmail-file ht-diary-file-name 1) + (rmail-delete-forward)))) + +(defun fake-face-width (face) + ;; Hack since can't seem to do this directly + (cdr (assoc 'QUAD_WIDTH (x-font-properties (face-font face))))) + +(defun fake-face-height (face) + ;; Hack since can't seem to do this directly + (let ((prop (x-font-properties (face-font face)))) + ;; highly speculative . . . + (+ (cdr (assoc 'CAP_HEIGHT prop)) + (cdr (assoc 'X_HEIGHT prop))))) + +(if (not (fboundp 'face-width)) + (fset 'face-width (symbol-function 'fake-face-width))) + +(if (not (fboundp 'face-height)) + (fset 'face-height (symbol-function 'fake-face-height))) + +(provide 'lemacs-compat) +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lucid/my-news.el Sat Oct 07 12:43:14 2023 +0100 @@ -0,0 +1,742 @@ +(load "gnus" nil t) +;(require 'spam) +(require 'cl) +;(spam-initialize) +(setq + gnus-select-method '(nntp "usenet.inf.ed.ac.uk") + gnus-post-method '(nntp "usenet.inf.ed.ac.uk") + gnus-nntp-server nil ; override local default + ) + +(setq gnus-use-scoring nil ; not used yet + gnus-summary-gather-subject-limit nil + gnus-thread-sort-functions + '(gnus-thread-sort-by-number gnus-thread-sort-by-simpl-subject) + gnus-summary-line-format "%U%R%5N%I%(%[%4L: %-12,12A%]%) %s\n" + gnus-summary-make-false-root 'none + gnus-mime-display-multipart-related-as-mixed t + gnus-simplify-subject-regexp "^\\(re[:;.]\\| \\|fwd:\\)*") + +(defsubst gnus-trim-simplify-subject (text) + (if (string-match gnus-simplify-subject-regexp text) + (substring text (match-end 0)) + text)) + +(defun gnus-thread-sort-by-simpl-subject (h1 h2) + "sort by slightly simplified subject" +; (message (format "%s:%s %s:%s" (mail-header-number (gnus-thread-header h1))(mail-header-subject (gnus-thread-header h1))(mail-header-number (gnus-thread-header h2))(mail-header-subject (gnus-thread-header h2)))) + (let ((case-fold-search t)) + (let ((result + (string-lessp + (downcase (gnus-trim-simplify-subject (mail-header-subject + (gnus-thread-header h1)))) + (downcase (gnus-trim-simplify-subject (mail-header-subject + (gnus-thread-header h2))))))) +; (message (format " %s\n" result)) + result))) + + +;; Database stuff + + +(defun open-white () + (setq whitelist-db (open-database "/disk/scratch/mail/white" 'berkeley-db))) + +(defun save-white () + (close-database whitelist-db) + (open-white)) + +(defun open-ad () + (setq adlist-db (open-database "/disk/scratch/mail/ad" 'berkeley-db))) + +(defun save-ad () + (close-database adlist-db) + (open-ad)) + +(defun open-quaker () + (setq quaker-db (open-database "/disk/scratch/mail/quaker" 'berkeley-db))) +(defun save-quaker () + (close-database quaker-db) + (open-quaker)) + +(defvar database-names '(whitelist-db adlist-db quaker-db) "sic") + +(defun db-status (&optional name) + "Check on the whereabouts of a name" + (interactive) + (let ((addr + (or name + (progn + (gnus-summary-goto-article (gnus-summary-article-number)) + (get-canonical-from-addr (get-current-from-components))))) + res) + (dolist (dbn database-names) + (if (get-database addr (eval dbn)) + (setq res (cons dbn res)))) + (if name + res + (message "%s" res)))) + +(defun add-white (&optional addToBBDB) + (interactive "P") + (gnus-summary-goto-article (gnus-summary-article-number)) + (let* ((components (get-current-from-components)) + (addr (get-canonical-from-addr components))) + (if (new-white addr) + (save-white)) + (if addToBBDB + (let ((bbdb-no-duplicates-p t)) + (bbdb-create-internal (car components) nil (cadr components) + nil nil nil))))) + +(defun add-ad () + (interactive) + (gnus-summary-goto-article (gnus-summary-article-number)) + (let ((addr (get-current-from-addr))) + (if (or (not (get-database addr whitelist-db)) + (yes-or-no-p "Already white, really convert to ad?")) + (if (new-ad addr) + (save-ad))))) + +(defun add-quaker() + (interactive) + (let ((addr (get-addr-before-point))) + (when (new-quaker addr) + (save-quaker)) + (quaker-sig-maybe))) + +(defun quaker-sig-if-to-quaker () + (let ((message-options)) + (save-excursion (message-options-set-recipient)) + (let* ((recipStr (message-options-get 'message-recipients)) + (recips (split-string (downcase recipStr) + ",[ \f\t\n\r\v]+" t))) + (while (and recips + (not (quaker-sig-if-quaker-1 (car recips)))) + (setq recips (cdr recips)))))) + +(defun quaker-sig-if-quaker () + (quaker-sig-if-quaker-1 (get-addr-before-point))) + +(defun quaker-sig-if-quaker-1 (addr) + (if (get-database addr quaker-db) + (progn (quaker-sig-maybe) + t))) + +(defun quaker-sig-maybe () + (save-excursion + (goto-char (point-max)) + (search-backward "\n-- \n") + (when (looking-at "\n-- \n Henry") + (forward-char 5) + (kill-entire-line 6) + (insert-file "/afs/inf.ed.ac.uk/user/h/ht/.quaker-sig")))) + +(defun kill-white () + (interactive) + (gnus-summary-goto-article (gnus-summary-article-number)) + (let ((addr (downcase (get-current-from-addr)))) + (rem-white addr))) + +(defun kill-ad () + (interactive) + (gnus-summary-goto-article (gnus-summary-article-number)) + (let ((addr (downcase (get-current-from-addr)))) + (rem-ad addr))) + +(defun get-from-gnus-addr () + (get-from-addr (gnus-fetch-field "From"))) + +(defun get-from-addr (addr) + (get-canonical-from-addr (gnus-extract-address-components addr))) + +(defun get-canonical-from-addr (components) + (downcase (cadr components))) + +(defun get-current-from-addr () + (with-current-buffer gnus-article-buffer + (get-from-gnus-addr))) + +(defun get-current-from-components () + (with-current-buffer gnus-article-buffer + (gnus-extract-address-components (gnus-fetch-field "From")))) + +(defun get-addr-before-point () + (let ((cur (point))) + (save-excursion + (get-from-addr (buffer-substring (+ (search-backward " ") 1) cur))) + )) + +(defun blacken-and-delete (group) + ;; mis-named now + ;; this is part of the expiry processing for xxxSPAM groups, and + ;; actually whitens the from addresses of #-marked articles + ;; The return value is crucial (and crucially outside of the scope of the if) + (if (memq number + (with-current-buffer gnus-summary-buffer + gnus-newsgroup-processable)) + (let ((addr (get-from-gnus-addr))) + (new-white addr))) + 'delete) + +(defun unwhiten-and-delete (group) + ;; unused except in stale groups -- usable as an expiry + (if (memq number + (with-current-buffer gnus-summary-buffer + gnus-newsgroup-processable)) + (let ((addr (get-from-gnus-addr))) + (remove-database addr whitelist-db))) + 'delete) + +(defun known-black (list) + (if (get-database (get-from-gnus-addr) blacklist-db) + list)) + +(defun white-spam (list) + (if (or (equal (get-database (get-from-gnus-addr) whitelist-db) "t") + (let ((case-fold-search t) + (subj (gnus-fetch-field "Subject")) + (from (get-from-gnus-addr))) + (or + (and subj (string-match white-subjects subj)) + (and from + (let ((fromDom (substring from (+ 1 (search "@" from))))) + (and fromDom (member fromDom white-domains))))))) + list)) + +(defun ad-spam (list) + (if (let ((from (get-from-gnus-addr))) + (or + (equal (get-database from adlist-db) "t") + (and from + (let ((fromDom (substring from (+ 1 (search "@" from))))) + (and fromDom (member fromDom ad-domains)))) + )) + list)) + +(defun bogoNote (group) + (if (memq number + (with-current-buffer gnus-summary-buffer + gnus-newsgroup-processable)) + (let ((addr (get-from-gnus-addr))) + (new-white addr))) + (shell-command-on-region (point-min) (point-max) + "/afs/inf.ed.ac.uk/user/h/ht/share/bin/local/makeBogo") + 'delete) + +(defun whiten-recip () + ;;; a hook for outgoing mail + (let* ((recips (message-options-get 'message-recipients)) + (res (mapcar (function new-white) + (split-string (downcase recips) + ",[ \f\t\n\r\v]*" t)))) + (while (and res (not (car res))) + (setq res (cdr res))) + (if res (save-white)))) + + +(defun new-white (addr) + (if (get-database addr whitelist-db) + nil + (put-database addr "t" whitelist-db) + t)) + +(defun new-ad (addr) + (if (get-database addr adlist-db) + nil + (put-database addr "t" adlist-db) + t)) + +(defun rem-ad (addr) + (remove-database addr adlist-db) + (save-ad)) + +(defun new-quaker (addr) + (if (get-database addr quaker-db) + nil + (put-database addr "t" quaker-db) + t)) + +(defun rem-white (addr) + (remove-database (downcase addr) whitelist-db) + (save-white)) + +(defun bogoOK (group) + (shell-command-on-region (point-min) (point-max) + "/afs/inf.ed.ac.uk/user/h/ht/share/bin/local/makeNonBogo") + 'delete) + +(defun del-dups () + (interactive) + (gnus-summary-sort-by-subject) + (gnus-summary-clear-mark-forward 1) + (goto-char (point-min)) + (let ((pos)) + (while (setq pos (search-forward "] " nil t)) + (end-of-line) + (let ((subj (buffer-substring pos (point)))) + (unless (equal subj "") + (let ((target (if (< (length subj) 26) + (concat "] " subj "\n") + (concat "] " (substring subj 0 25)))) + (done 0) + (case-fold-search nil)) + (while (and (= done 0) + (search-forward target nil t)) + (forward-char -3) + (setq done (gnus-summary-mark-as-read-forward 1)))))))) + (gnus-summary-limit-to-unread) + (gnus-summary-sort-by-original)) + +(defun mark-and-mark (n) + (interactive "p") + (while (>= n 1) + (gnus-summary-mark-as-read) + (gnus-summary-mark-as-processable 1) + (setq n (- n 1)))) + +(defun split-on-whole-field (field pat list) + (goto-char (point-max)) + (let ((hit (assq pat wsp-cache)) + rpat) + (if hit + (setq rpat (cdr hit)) + (setq rpat + (concat "^" + field + ":\\s-*" + (if (stringp pat) + pat + (cdr (assq pat + nnmail-split-abbrev-alist))) + "$")) + (setq wsp-cache (cons (cons pat rpat) wsp-cache))) + (if (re-search-backward rpat nil t) + list))) + +(defun ht-gnus-summary-delete-forward () + "REAL delete for nnmail gnus" + (interactive) + (gnus-summary-delete-article) + (gnus-summary-next-unread-article)) + +;; run the first time we make a summary window +(defun gnus-summary-mode-fun1 () + "install ht's mods" + (define-key gnus-summary-mode-map "D" 'ht-gnus-summary-delete-forward) + (define-key gnus-summary-mode-map "~" 'mark-and-mark) + (define-key gnus-summary-mode-map "\M-d" 'gnus-edit-and-move-to-diary) + (define-key gnus-summary-mode-map "\M-e" 'gnus-extract-attachment) + (define-key gnus-summary-mode-map "\M-w" 'add-white) + (define-key gnus-summary-mode-map [(control meta w)] 'copy-region-to-kill) + (define-key gnus-summary-mode-map "\M-h" 'showMPAhtml) + ;(define-key gnus-summary-mode-map [(control meta w)] 'kill-white) + (define-key gnus-summary-mode-map "\M-a" 'add-ad) + (define-key gnus-summary-mode-map "\M-n" 'ht-next-unseen-maybe) + (define-key gnus-summary-mode-map "\M-c" 'ht-catchup-and-next-unseen) + (define-key gnus-summary-mime-map "O" 'ht-article-save-parts) + (define-key gnus-summary-backend-map "M" 'ht-move-to-pers) + (remove-hook 'gnus-summary-mode-hook 'gnus-summary-mode-fun1)) + +(defun message-mode-fun1 () + (define-key message-mode-map [(control meta q)] 'add-quaker) + (remove-hook 'message-mode-hook 'message-mode-fun1)) + +(defvar ht-gnus-just-read nil) + +(defun ht-catchup-and-next-unseen () + (interactive) + (when (gnus-summary-catchup nil t nil 'fast) + (gnus-summary-exit) + (previous-line 1) + (ht-next-with-unseen 1))) + +(defun ht-next-unseen-maybe (n) + (interactive "p") + (cond + ((eq (gnus-summary-next-unread-subject n) n) + (gnus-summary-exit) + (previous-line 1) + (if (ht-next-with-unseen n) + (ht-read-group-unseen-only))))) + +(defun ht-gnus-pers-refresh (n) + (interactive "p") + (let ((gn (concat "nnml+ht:pers-" + (format-time-string "%Y-%m" (current-time))))) + (gnus-group-get-new-news) + (let ((nn (gnus-number-of-unseen-articles-in-group gn))) + (gnus-group-goto-group gn) + (cond + ((> nn 0) + (gnus-group-read-group nn)) + ((> n 1) + (let ((gnus-auto-select-subject + (lambda () + (goto-char (point-max)) + (previous-line 1)))) + (gnus-group-read-group nil t))) + (t (goto-char (point-min)) + (ht-next-with-unseen 1)))) + (message "%s" ht-gnus-just-read)) + ) + +(defun no-select () + (if (member gnus-newsgroup-name no-select-groups) + (progn (make-variable-buffer-local 'gnus-auto-select-first) + (setq gnus-auto-select-first nil)))) + +(defun showMPAhtml () + "Show the text/html parts of an multipart/alternative message using lynx" + (interactive) + (gnus-summary-select-article) + (with-current-buffer gnus-original-article-buffer + (shell-command-on-region (point-min) (point-max) "/afs/inf.ed.ac.uk/user/h/ht/share/bin/showMPA.sh") + ) + ) + + +;; run the first time we make a group window +(defun gnus-group-mode-fun1 () + "install ht's mods" + (require 'gnus-msg) + (define-key gnus-group-mode-map "\M-\C-g" 'ht-gnus-pers-refresh) + (define-key gnus-group-mode-map "\M-n" 'ht-next-with-unseen) + (define-key gnus-group-mode-map "\M-p" 'ht-previous-with-unseen) + (define-key gnus-group-mode-map "\M- " 'ht-read-group-unseen-only) + (define-key gnus-send-bounce-map "R" 'resend-to-schemadev) + (define-key gnus-send-bounce-map "x" 'flush-all-nogoods) + (remove-hook 'gnus-group-mode-hook 'gnus-group-mode-fun1)) + +(defun flush-all-nogoods () + (interactive) + (while (re-search-forward + "] \\(\\(Returned\\|\\([Uu]n\\|[Nn]on-?\\)deliver\\(able\\|ed\\)\\)\\( [Mm]ail\\|:?\\)\\|DELIVERY FAILURE\\|Delivery \\(Notification: Delivery has failed\\|Status Notification .\\(Failure\\|Delay\\).\\)\\|failure \\(notice\\|delivery\\)\\)" + nil t) + (gnus-summary-mark-as-read) + (end-of-line))) + +(defun gnus-user-format-function-t (header) + "display the to field (for archive messages)" + (let ((n (mail-header-number header))) + (with-current-buffer nntp-server-buffer + (save-excursion + (save-restriction + (let ((inhibit-point-motion-hooks t)) + (goto-char (point-min)) + (let ((beg (search-forward (format " %d Article retrieved." n))) + (end (search-forward "\n.\n"))) + (narrow-to-region beg end) + (goto-char beg) + (message-fetch-field "To")))))))) + +(defun gnus-extract-attachment () + "extract attachments from a multi-part mime message" + (interactive) + (let ((sm gnus-show-mime)) + (if sm + (progn (setq gnus-show-mime nil) + (gnus-summary-select-article t 'force)) + ) + (gnus-summary-show-all-headers) + (with-current-buffer gnus-article-buffer + (save-excursion + (save-restriction + (mime/viewer-mode) + (delete-other-windows) + (let ((pt 0)) + (while (progn + (mime-viewer/next-content) + (and + (equal "*Preview-*Article**" (buffer-name (current-buffer))) + (not (= pt (point))))) + (setq pt (point)) + (if (looking-at "^\\[[0-9]* \\([^ ]+ \\)+<") + (mime-viewer/extract-content))))))) + (kill-buffer "*Preview-*Article**") + (setq gnus-show-mime sm) + )) + +;;; Why??? +(make-variable-buffer-local 'gnus-extra-headers) +(make-variable-buffer-local 'nnmail-extra-headers) + + +(defun resend-to-schemadev () + (interactive) + (message "forwarding to xmlschema-dev") + (gnus-summary-resend-message "xmlschema-dev@w3.org" 1) + (gnus-summary-next-unread-article)) + +(defun brutal-resend () + (interactive) + (message "editing for resend. . .") + (unless (eq (gnus-summary-article-number) + gnus-current-article) + (gnus-summary-select-article t)) + (gnus-summary-toggle-header 1) + (with-current-buffer gnus-article-buffer + (toggle-read-only) + (gnus-article-date-original) + (goto-char (point-min)) + (replace-regexp "^\\(X-Diagnostic\\|X-Envelope-To\\|X-Original-To\\|Delivered-To\\):.*\n" "") + (goto-char (point-min)) + (gnus-summary-edit-article-done + (or (mail-header-references gnus-current-headers) "") + (gnus-group-read-only-p) gnus-summary-buffer nil)) + (call-interactively (function gnus-summary-resend-message)) + (gnus-summary-next-unread-article)) + +; (unless (fboundp 'builtin-coding-system-p) +; (fset 'builtin-coding-system-p (symbol-function 'coding-system-p)) +; (defun coding-system-p (obj) +; (cond +; ((builtin-coding-system-p obj) t) +; ((memq obj '(utf-8 gb2312 koi8-r iso-8859-1)) +; (message (format "Coding system: %s" obj)) +; t)))) + +;;; dangerous hack to improve display of names and subjects in mail/news +(if nil (progn +(require 'mm-util) +(defun mm-decode-coding-string (str cs) + (if (and str (eq cs 'utf-8)) + (if (or (string-match "Â" str) + (string-match "Ã" str)) + (let* ((r 0) ; read pointer + (w 0) ; write pointer + (l (length str))) + (while (< r l) + (let* ((c (aref str r)) + (i (char-int c))) + (cond ((= i 194) + (aset str w (aref str (+ r 1))) + (setq r (+ r 2))) + ((= i 195) + (aset str w + (int-char + (+ 64 + (char-int (aref str (+ r 1)))))) + (setq r (+ r 2))) + (t + (aset str w c) + (setq r (+ r 1))))) + (setq w (+ w 1))) + (substring str 0 w)) + str) + str)) + +(defun mm-sort-coding-systems-predicate (a b) + ;; from mm-util, abort if no priorities + (or (not mm-coding-system-priorities) + (let ((priorities + (mapcar (lambda (cs) + ;; Note: invalid entries are dropped silently + (and (setq cs (mm-coding-system-p cs)) + (coding-system-base cs))) + mm-coding-system-priorities))) + (and (setq a (mm-coding-system-p a)) + (if (setq b (mm-coding-system-p b)) + (> (length (memq (coding-system-base a) priorities)) + (length (memq (coding-system-base b) priorities))) + t))))))) + +(require 'browse-url) + +;;; This version collects extra lines if you use right-button +;;; to click on a URL +(defun browse-url (url &rest args) + "Ask a WWW browser to load URL. +Prompts for a URL, defaulting to the URL at or before point. Variable +`browse-url-browser-function' says which browser to use." + (interactive (browse-url-interactive-arg "URL: ")) + (unless (interactive-p) + (setq args (or args (list browse-url-new-window-flag)))) + (if (and (boundp 'event)(= 3 (event-button event))) + (let ((thisLine url)) + (while (and (progn (forward-char (length thisLine)) + (eolp)) + (progn (forward-line 1) + (beginning-of-line) + (not (looking-at "\\s-")))) + (looking-at "\\S-*") + (setq thisLine (buffer-substring (match-beginning 0) + (match-end 0))) + (setq url (concat url thisLine))))) + (if (functionp browse-url-browser-function) + (apply browse-url-browser-function url args) + ;; The `function' can be an alist; look down it for first match + ;; and apply the function (which might be a lambda). + (catch 'done + (dolist (bf browse-url-browser-function) + (when (string-match (car bf) url) + (apply (cdr bf) url args) + (throw 'done t))) + (error "No browse-url-browser-function matching URL %s" + url)))) + +(defun gnus-user-format-function-H (dummy) + (format "%c" + (cond ((eq gnus-tmp-summary-live ?*) + ?*) + ((> (gnus-number-of-unseen-articles-in-group gnus-tmp-group) 0) + ?.) + (t ? )))) + +(defun ht-next-with-unseen (n) + (interactive "p") + (let* ((gvl (mapcar (function string-to-number) + (split-string gnus-version-number "\\."))) + (pattern (if (or (> (car gvl) 5) + (and (eq (car gvl) 5) + (or (> (cadr gvl) 10) + (and (eq (cadr gvl) 10) + (> (caddr gvl) 7))))) + "\\." + ":\\."))) + (if (looking-at pattern) + (if (< n 0) + (backward-char 1) + (forward-char 1))) + (let ((missing 0) + (winning (looking-at pattern))) + (while (and (zerop missing) + (not winning)) + (setq missing (gnus-group-next-unread-group n)) + (setq winning (looking-at pattern))) + winning))) + +(defun ht-read-group-unseen-only () + (interactive) + (gnus-group-read-group + (gnus-number-of-unseen-articles-in-group (gnus-group-group-name)))) + +(defun ht-previous-with-unseen (n) + (interactive "p") + (ht-next-with-unseen (- n))) + +(defun ht-gnus-note-save-to-group () + (let ((g (caar group-art))) + (if (not (member g ht-gnus-just-read)) + (setq ht-gnus-just-read (cons g ht-gnus-just-read))))) + +(defvar ht-stash-directory "/disk/scratch/mail/stash/") + +(defun ht-save-part (handle n) + (let ((sup-type (mm-handle-media-supertype handle)) + (sub-type (mm-handle-media-subtype handle))) + (message (format "%s %s/%s" n sup-type sub-type)) + (cond ((and (equal sup-type "multipart") + (or (equal sub-type "alternative") + (equal sub-type "related"))) + (let ((alts (cddr handle)) + (j 0)) + (while alts + (let* ((alt (pop alts)) + (handle-type (mm-handle-type alt))) + (let* ((sub (mm-handle-media-subtype alt)) + (ext (cdr + (assoc sub '(("calendar" . "vcs") + ("v-calendar" . "vcs")))))) + (setq j (+ j 1)) + (if (not (or (mail-content-type-get + (mm-handle-disposition alt) 'filename) + (mail-content-type-get + handle-type 'name))) + (nconc + handle-type + (list (cons 'name (format "%s.%s.%s" + n j (or ext sub)))))) + (ht-save-part alt (format "%s.%s" n j))))))) + ((and (equal sup-type "text")(not + (member sub-type '("html" + "v-calendar" + "calendar")))) + (message "Skipping text part: %s" (mm-handle-disposition handle))) + (t + (mm-save-part handle))))) + +(defun ht-move-to-pers (n) + (interactive "p") + (gnus-summary-move-article n + (concat + "nnml+ht:pers-" + (format-time-string "%Y-%m" (current-time))))) + +(defun ht-article-save-parts (n) + "Save non t/p MIME parts starting at N, which is the numerical prefix." + (interactive "p2") + (let ((window (get-buffer-window gnus-article-buffer 'visible)) + frame) + (when window + ;; It is necessary to select the article window so that + ;; `gnus-article-goto-part' may really move the point. + (setq frame (selected-frame)) + (gnus-select-frame-set-input-focus (window-frame window)) + (unwind-protect + (save-window-excursion + (select-window window) + (let ((len (length gnus-article-mime-handle-alist))) + (setq mm-default-directory ht-stash-directory) + (while (<= n len) + (gnus-article-goto-part n) + (let ((handle (cdr (assq n gnus-article-mime-handle-alist)))) + (ht-save-part handle n)) + (setq n (+ n 1)) + ))) + (gnus-select-frame-set-input-focus frame)))) + ) + + +(defun gnus-article-part-wrapper (n function) + (let ((window (get-buffer-window gnus-article-buffer 'visible)) + frame) + (when window + ;; It is necessary to select the article window so that + ;; `gnus-article-goto-part' may really move the point. + (setq frame (selected-frame)) + (gnus-select-frame-set-input-focus (window-frame window)) + (unwind-protect + (save-window-excursion + (select-window window) + (when (> n (length gnus-article-mime-handle-alist)) + (error "No such part")) + (gnus-article-goto-part n) + (let ((handle (cdr (assq n gnus-article-mime-handle-alist)))) + (funcall function handle))) + (gnus-select-frame-set-input-focus frame))))) + +(defun mhstore-me (dir) + (interactive (list (read-directory-name "Save parts to " "/tmp" "/tmp" t))) + (let ((art (gnus-summary-article-number))) + (let* ((grp-parts (split-string gnus-newsgroup-name ":")) + (meth (car grp-parts)) + (grp (cadr grp-parts))) + (if (string= meth "nnml+ht") + (let ((doit + (format "cd %s && mhstore -f /disk/scratch/mail/Mail/%s/%s -auto" + dir grp art))) + (message doit) + (shell-command doit)) + )))) + +(defun my-message-send-and-exit (&optional arg) + (interactive "P") + (let ((message-required-mail-headers + (if arg + (mapcar + (lambda(x) + (if(and(consp x)(eq(cdr x)'In-Reply-To)) + (cons 'optional 'xyzzy) + x)) + message-required-mail-headers) + message-required-mail-headers))) + (orig-message-send-and-exit))) + +(require 'message) +(if (not (fboundp 'orig-message-send-and-exit)) + (progn + (fset 'orig-message-send-and-exit (symbol-function 'message-send-and-exit)) + (fset 'message-send-and-exit (symbol-function 'my-message-send-and-exit)))) + +(provide 'my-news)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lucid/rooms.el Sat Oct 07 12:43:14 2023 +0100 @@ -0,0 +1,293 @@ +;;; rooms facility for gnuemacs + +;;; Copyright Henry S. Thompson 1990 + +;;; Last edited: Wed Sep 14 08:48:27 1994 + +;;; v19.19 version + +(provide 'rooms) +(require 'prompt-for-word) + +(defvar rooms-table nil "a-list of rooms in the form (name . window-specs)") + +(defvar frames-table nil "a-list of room to frame mappings") + +(defvar rooms-map (let ((new (copy-keymap pfw-map))) + (define-key new "\C-r" 'minibuffer-complete-and-exit) + new) + "allow ^R as synonym for CR in prompt-for-word") + +(defmacro room-name (room) (list 'car room)) +(defmacro room-window-specs (room) (list 'cdr room)) +(defmacro make-room (name window-specs) (list 'cons name window-specs)) + +(defvar current-room nil "the current room") + +(defvar previous-room nil "the previous room") + +;; a window spec is of the form (buffer-name constitution . edges) +(defmacro ws-buffer-name (ws) (list 'car ws)) +(defmacro ws-constitution (ws) (list 'car (list 'cdr ws))) +(defmacro ws-edges (ws) (list 'cdr (list 'cdr ws))) +(defmacro make-ws (buffer-name constitution edges) + (list 'cons buffer-name + (list 'cons constitution edges))) + +(defun rooms-top (redraw) + "top level for rooms - prompts for room name and goes there. +Prefix arg forces room's frame to its defined contents. +Typing overrides initial suggestion, exiting completes. To name a new room +exit with ^N +To redefine an existing room, exit with ^R" + (interactive "PIf prefixed, forces room's frame, if any, to its defined contents") + (let ((name (prompt-for-word "Room: " (or (room-name previous-room) "") + rooms-table (if rooms-table + rooms-map))) + (e-o-c last-input-char) + room) + (cond ((eq e-o-c 18) ; ^R + (rooms-redefine-query name)) + (t + (if (setq room (assoc name rooms-table)) + (rooms-goto room redraw) + (rooms-new-query name)))))) + +(defun rooms-goto (room &optional redraw) "switch frame to ROOM's config" + (let ((room (if (stringp room) + (or (assoc room rooms-table) + (error "No room named %s" room)) + room)) + st-entry) + (if (not (eq room current-room)) + (setq previous-room current-room)) + (setq current-room room) + ;; lazy if mapped to frame and not redraw + (if (setq st-entry (assoc (room-name room) frames-table)) + ;; very tricky -- appears to be the only order that works! + (progn +; (focus-frame (cdr st-entry)) + (select-frame (cdr st-entry)) + (raise-frame (cdr st-entry)) ; gwm/empty.gwm/emacs-19.28 pblm??? + (if redraw (establish-room room))) + (establish-room room)))) + +(defun rooms-new-query (name) + "check to see if new room or definition wanted" + (if (y-or-n-p (concat "Define a new room named " + name + "? ")) + (rooms-new name) + (message ""))) + +(defun rooms-redefine-query (name) "check to see if new room wanted" + (if (y-or-n-p (concat "Redefine the room named " + name + "? ")) + (progn (setq rooms-table (delq (or (assoc name rooms-table) + (error "shouldnt")) + rooms-table)) + (rooms-new name)) + (message ""))) + +(defun rooms-new (name) "define a new room named NAME as per the current frame" + (interactive "sroom name for current frame: ") + (let ((here (selected-window)) + (looping t) + spec top-p next all-specs) + ;; collect specs for all windows on frame, noting top one + (setq next here) + (while looping + (setq spec (window-edges next)) + (setq all-specs (cons (make-ws (buffer-name (window-buffer next)) + nil + spec) + all-specs)) + (if (= (car (cdr spec)) 0) ; check for top + (progn (setq top-p all-specs) + (setq all-specs nil))) + (setq next (previous-window next)) + (if (eq next here) + (setq looping nil))) + (setq rooms-table + (cons + (make-room name + (nconc top-p + all-specs)) + rooms-table)) + (message (concat name " defined as current frame configuration")))) + +(global-set-key "\eo" 'rooms-top) + +(defun define-rooms (spec-list) "define rooms from specs" + (let ((spp spec-list)) + (while spp + (establish-room (car spp) t) + (setq spp (cdr spp))))) + +(defun establish-room (r-spec &optional create) "define room from spec" + ;; a room-spec is of the form (name . window-specs) + ;; a window spec is of the form (buffer-name constitution . edges) + ;; a buffer-name is either a string, in which case the constitution will be + ;; left to create it, or (<string>), in which case a new buffer of that name + ;; will be generated first. + ;; a constitution is either nil, a file name to be visited, or a form + ;; to be evaluated + ;; if create is nil, buffer is not touched (constitution is ignored) + (let ((r-name (room-name r-spec)) + (w-specs (room-window-specs r-spec)) + (used -1) + w-spec st-entry) + (if create + (while w-specs + (setq w-spec (car w-specs)) + (let ((buf-name (ws-buffer-name w-spec)) + (const (ws-constitution w-spec))) + ;; initialise the buffer + (if (consp buf-name) + (set-buffer (generate-new-buffer (car buf-name)))) + (if const + (condition-case foo + (if (stringp const) + (find-file const) + (eval const)) + (error (message "%s" foo))))) + (setq w-specs (cdr w-specs)))) + (setq w-specs (room-window-specs r-spec)) + (switch-to-buffer (let ((b-n (ws-buffer-name (car w-specs)))) + (if (consp b-n) + (car b-n) + b-n))) + (delete-other-windows) + (setq w-specs (cdr w-specs)) + (while w-specs + (setq w-spec (car w-specs)) + (let ((buf-name (ws-buffer-name w-spec)) + (edges (ws-edges w-spec))) + ;; make a window of the right size + ;; we assume full-width windows for now, with specs in top-to-bottom + (let ((top (1- (car (cdr edges))))) + (split-window-vertically (- top used)) + (setq used top)) + (other-window 1) + (switch-to-buffer (if (consp buf-name) + (car buf-name) + buf-name))) + (setq w-specs (cdr w-specs))) + (if create + (setq rooms-table (nconc rooms-table (list r-spec)))))) + +(defun make-frame-for-room (&optional name xpos ypos ixpos iypos) + "prompts for room name and makes a frame for it. +Typing overrides initial suggestion, exiting completes." + (interactive) + (let ((name (or name + (prompt-for-word "Room: " (or (room-name previous-room) "") + rooms-table (if rooms-table + rooms-map)))) + room) + (if (not (setq room (assoc name rooms-table))) + (error "no room named %s" name) + (let ((last-w-edges (ws-edges (last-element (room-window-specs room)))) + (st-entry (assoc name frames-table)) + ;; assume (falsely) that new frame will be like old one + (parms (frame-parameters nil)) + (sys-name (substring (system-name) 0 + (string-match "\\." (system-name)))) + frame) + (let ((width (car (cdr (cdr last-w-edges)))) + (height (+ + (or (cdr (assoc 'menu-bar-lines parms)) 0) + 1 ; allowing 1 for mode line + (if (let ((mb (cdr (assoc 'minibuffer parms)))) + (or + (eq mb t) + (and (windowp mb) + (eq (window-frame mb) + (selected-frame))))) + 1 + 0) + (car (cdr (cdr (cdr last-w-edges)))))) + (x-slop (+ (* 2 (+ (cdr (assoc 'border-width parms)) + (cdr (assoc 'internal-border-width parms)))) + (if (cdr (assoc 'vertical-scroll-bars parms)) + 19 + 0))) + (y-slop (+ (* 2 (+ (cdr (assoc 'border-width parms)) + (cdr (assoc 'internal-border-width parms)))) + (if (cdr (assoc 'horizontal-scroll-bars parms)) + 19 + 0) + 16 ; window title bar + )) + (title + (concat name + ":" (user-login-name) + (concat "@" sys-name) + ))) + (let ((args (list + (cons 'width width) + (cons 'height height) + ;; Note that x-parse-geometry doesn't handle all position cases + (cons 'left + (if xpos + (+ (if (string-match + "^[+]" xpos) + 0 + (- + (x-display-pixel-width) + (+ (* (face-width (get-face 'default)) + width) + x-slop))) + (car (read-from-string xpos) + )) + 0)) + (cons 'top + (if ypos + (+ (if (string-match + "^[+]" ypos) + 0 + (- + (x-display-pixel-height) + (+ (* (face-height (get-face 'default)) + height) + y-slop))) + (car + (read-from-string ypos))) + 0)) + (cons 'name title)))) + (setq frame + (make-frame args)))) + (if st-entry + (rplacd st-entry frame) + (setq frames-table (cons (cons name frame) + frames-table))) + (if (or ixpos iypos) + (position-frame-icon (or ixpos + (car + (cdr + (assoc 'left + (frame-parameters frame))))) + (or iypos (car + (cdr + (assoc 'top + (frame-parameters frame))))) + frame))) + (rooms-goto room t)))) + +(defun make-screen-for-room (&optional name xpos ypos ixpos iypos) + (make-frame-for-room name xpos ypos ixpos iypos)) + +(defun position-frame-icon (x y frame) + "fiddle to get the icon for a frame in a specified place" +) + +(defun last-element (list) + "Return last element of LIST." + (let ((last nil)) + (while list + (if (null (cdr list)) + (setq last (car list))) + (setq list (cdr list))) + last + ))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/shared/alarm.el Sat Oct 07 12:43:14 2023 +0100 @@ -0,0 +1,123 @@ +;;; Last edited: Thu Jun 11 10:49:18 1992 +;;; alarm facility for emacs + +(provide 'alarm) + +(defvar alarm-process nil) + +(defvar alarm-callback nil) + +(defun alarm (seconds function) + "After SECONDS, funcall FUNCTION" + (if (and alarm-process + (not (eq (process-status alarm-process) 'exit))) + (error "already waiting") + (setq alarm-callback function) + (setq alarm-process + (start-process "alarm-clock" nil + "/bin/sleep" (format "%d" seconds))) + (set-process-sentinel alarm-process (function alarm-sentinel))) + ) + +(defun alarm-sentinel (process reason) + (setq asm reason) + (if (equal reason "finished\n") + (funcall alarm-callback) + (error "Bogus alarm message: %s" reason))) + +(defun alarm-stop () "turn off alarm" + (interactive) + (set-process-sentinel alarm-process nil) + (kill-process alarm-process) + (setq alarm-process nil)) + +(defvar idle-last-command nil) +(defvar idle-last-input-char nil) +(defvar idle-time nil) +(defvar idle-interval nil) +(defvar idle-function nil) +(defvar idle-count nil) + +(defun idle-timeout (seconds function &optional check-interval) + "If idle for SECONDS, call FUNCTION. Check every CHECK-INTERVAL, or 60 secs" + (setq idle-last-command last-command) + (setq idle-last-input-char last-input-char) + (setq idle-time seconds) + (setq idle-start-time (current-msec-time)) + (setq idle-interval (or check-interval 60)) + (setq idle-count (/ (+ seconds (1- idle-interval)) idle-interval)) + (setq idle-function function) + (alarm idle-interval (function idle-check))) + +(defun idle-check () + (setq idle-count (max (1- idle-count) 0)) +; (message "trying") + (if (and + (eq idle-last-command last-command) +; (message "tic") + (= idle-last-input-char last-input-char) +; (message "toc") + ) + (if (and (= idle-count 0) +; (message "torum") + (or + (let ((last-field-3 (last-event-time))) + ;; allow for wrap + (or (not last-field-3) +; (progn (message "tarum") nil) + (let ((last (logand 8388607 + last-field-3)) + (time (current-msec-time))) +; (message "%d %d %d" last time idle-time) + (> (/ (if (< time last) + (+ (- time last) 8388607) + (- time last)) + 1000) + idle-time)))))) + (save-excursion + (set-buffer (get-buffer-create "*Idle*")) + (insert-string "Idle at " (current-time-string) + (format " :\n %s -> " + idle-function)) + (insert-string (format "%s\n" + (save-excursion (funcall idle-function))))) + (alarm idle-interval (function idle-check))) + (setq idle-last-command last-command) + (setq idle-last-input-char last-input-char) + (setq idle-count (/ (+ idle-time (1- idle-interval)) idle-interval)) + (alarm idle-interval (function idle-check)))) + +(defvar idle-save-timeout nil) + +(defun idle-save (&optional minutes) + "If idle for more MINUTES (defaults to 5), save all changed buffers" + (interactive "nIdle after minutes: ") + (idle-timeout (setq idle-save-timeout (* 60 (or minutes 5))) + (quote idle-save-doit))) + +(defun idle-save-doit () + (let ((bufs (buffer-list)) + result) + (while bufs + (let ((buf (car bufs)) file-name) + (if (and (buffer-modified-p buf) + (setq file-name (buffer-file-name buf)) + (string-match "\\.babyl$" file-name)) + (progn (set-buffer buf) + (let ((require-final-newline nil)) + (save-buffer) + (setq result (cons file-name result)))))) + (setq bufs (cdr bufs))) + (idle-timeout idle-save-timeout (quote idle-save-doit)) + (if result + (mapconcat (function identity) + result + " ") + "nil"))) + +;; defaults +(defun current-msec-time () (the-time)) +(defun last-event-time () + (and (boundp '*last-event*) + (> (length *last-event*) 3) + (elt *last-event* 3)))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/shared/compress.el Sat Oct 07 12:43:14 2023 +0100 @@ -0,0 +1,69 @@ +;;; Last edited: Thu Oct 3 12:28:00 1991 +;;; Handle compressed files +;;; adapted by Henry S. Thompson from Miles Bader from ??? +(provide 'compress) + +(defun uncompress-while-visiting () + "Temporary \"major mode\" used for .[gzZ] files, to uncompress the contents. +It then selects a major mode from the uncompressed file name and contents." + (if (and (not (null buffer-file-name)) + (string-match "\\.g?[zZ]$" buffer-file-name)) + (set-visited-file-name + (substring buffer-file-name 0 (match-beginning 0)))) + (message "Uncompressing...") + (let ((buffer-read-only nil)) + (shell-command-on-region (point-min) (point-max) "zcat" t)) + (message "Uncompressing...done") + (set-buffer-modified-p nil) + (normal-mode)) + +(setq auto-mode-alist + (cons '("\\.g?[zZ]$" . uncompress-while-visiting) auto-mode-alist)) + +(defun find-compressed-version () + "Hook to read and uncompress the compressed version of a file." + ;; Just pretend we had visited the compressed file, + ;; and uncompress-while-visiting will do the rest. + (let ((exts '("gz" "z" "Z")) ext found) + (while (and exts (setq ext (car exts)) (not found)) + (if (file-exists-p (concat buffer-file-name "." ext)) + (progn + (setq buffer-file-name (concat buffer-file-name "." ext)) + (insert-file-contents buffer-file-name t) + (goto-char (point-min)) + (setq error nil) + t) + (setq exts (cdr exts)))))) + +(setq find-file-not-found-hooks + (cons 'find-compressed-version find-file-not-found-hooks)) + +(defun compress-again () + "Hook to compress the uncompressed version of a file." + (let ((exts '("gz" "z" "Z")) ext found) + (while (and exts (setq ext (car exts)) (not found)) + (if (file-exists-p (concat buffer-file-name "." ext)) + (let ((here (current-buffer)) + (fake-buffer-file-name (concat buffer-file-name "." ext)) + (require-final-newline nil)) + (set-buffer (get-buffer-create " *compress*")) + (erase-buffer) + (insert-buffer here) + (message "Compressing...") + (shell-command-on-region (point-min) (point-max) + (if (equal "Z" ext) + "compress" + "gzip") t) + (message "Compressing...done") + (write-region (point-min)(point-max) fake-buffer-file-name) + (bury-buffer (current-buffer)) + (set-buffer here) + (set-buffer-modified-p nil) + (setq found t) + t) + (setq exts (cdr exts)))) + found)) + + +(setq write-file-hooks (cons 'compress-again write-file-hooks)) +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/shared/device-type-hacking.el Sat Oct 07 12:43:14 2023 +0100 @@ -0,0 +1,63 @@ + + +(defconst device-type-hacking-id "$Id: device-type-hacking.el,v 1.1 1996/07/25 22:17:36 rjc Exp $") + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; ;; + ;; Changes some values depending on device type ttys. have ;; + ;; control-h being delete and zmacs-regions turned off. ;; + ;; ;; + ;; Since select-frame-hook doesn't seem to be called for tty ;; + ;; devices, we have to cheat and set the tty defaults whenever a ;; + ;; frame is deselected. ;; + ;; ;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defvar zmacs-regions-specifier + (make-specifier-and-init 'boolean + '( (global ((tty). nil) ((x) . t)) ) + )) + + +(defun device-type-tty-selected () + + (define-key global-map '(control h) 'backward-delete-char-untabify) + ) + +(defun device-type-x-selected () + + (define-key global-map '(control h) 'help) + ) + +(defun device-type-select-frame-hook () + + (setq zmacs-regions + (specifier-instance zmacs-regions-specifier) + ) + + (if (equal (device-type (selected-device)) "tty") + (device-type-tty-selected) + (device-type-x-selected) + ) + + ) + +(defun device-type-deselect-frame-hook () + + (setq zmacs-regions + (not (specifier-instance zmacs-regions-specifier)) + ) + + (device-type-tty-selected) + + ) + +(setq deselect-frame-hook '(default-deselect-frame-hook)) +(setq select-frame-hook '(default-select-frame-hook)) + + +(add-hook 'select-frame-hook (function device-type-select-frame-hook)) +(add-hook 'deselect-frame-hook (function device-type-deselect-frame-hook) t) + + +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/shared/diary.el Sat Oct 07 12:43:14 2023 +0100 @@ -0,0 +1,660 @@ +;; Last edited: Wed Oct 24 17:08:20 1990 +;; provide a simple diary facility on top of rmailsum +;; Copyright (C) 1990 Henry S. Thompson + +;; 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. + +(provide 'diary) +(require 'mail-extras) + +(autoload 'sort-subr "sort") + +(defvar ht-diary-file-name "~/DIARY.babyl" + "default name of diary file") + +(defvar ht-Calendar-directory "~/Calendar") + +(defun xxx-date-lessp (date1 date2) + "Return T if DATE1 is earlyer than DATE2." + (string-lessp (gnus-comparable-date date1) + (gnus-comparable-date date2))) + +(defun xxx-comparable-date (date) + "Make comparable string by string-lessp from DATE." + (let ((month '(("JAN" . " 1")("FEB" . " 2")("MAR" . " 3") + ("APR" . " 4")("MAY" . " 5")("JUN" . " 6") + ("JUL" . " 7")("AUG" . " 8")("SEP" . " 9") + ("OCT" . "10")("NOV" . "11")("DEC" . "12"))) + (date (or date ""))) + ;; Can understand the following styles: + ;; (1) 14 Apr 89 03:20:12 GMT + ;; (2) Fri, 17 March 89 4:01:33 GMT + (if (string-match + "\\([0-9]+\\) \\([^ ,]+\\) \\([0-9]+\\) *\\([0-9:]*\\)" date) + (let ((year (substring date (match-beginning 3) (match-end 3))) + (mn (substring date + (match-beginning 2) + (+ 3 (match-beginning 2)))) + (day (substring date + (match-beginning 1) (match-end 1))) + (time (substring date (match-beginning 4) (match-end 4)))) + (concat + ;; Year + (if (= (length year) 2) + (if (string-match "^9" year) + (concat "19" year) + (concat "20" year)) + year) + ;; Month + (cdr + (assoc + (upcase mn) + month)) + ;; Day + (format "%2d" (string-to-int day)) + ;; Time + time)) + ;; Cannot understand DATE string. + date + ) + )) + +(defun update-default-diary (arg) "update a diary - with arg, the one for +this file. Without arg, the default (named in ht-diary-file-name)" + (interactive "P") + (if arg + (update-diary (current-buffer)) + (require-diary) + (update-diary (get-file-buffer ht-diary-file-name)))) + +(defun update-diary (buffer) +;; (setq rmail-summary-buffer (get-buffer-create "*Diary*")) + (let ((obuf (current-buffer))) + (set-buffer buffer) + (if (not has-diary-summary) + (progn (make-local-variable 'has-diary-summary) + (setq has-diary-summary t))) + (rmail-summary) + (set-buffer obuf))) + +(defun do-diary-update () "rmail-summary-mode-hook calls this" + (if (save-excursion (set-buffer rbuf) + has-diary-summary) + (progn + (make-local-variable 'diary-summary-buffer) + (setq diary-summary-buffer t) + (setq description (concat "Diary " description)) + (setq buffer-read-only nil) + (sort-diary-hdrs) + (format-diary-hdrs) + (setq buffer-read-only t) + (not-modified) + (beginning-of-buffer) + (setq mesg nil) ; to go to earliest, not first in file + ))) + +(defun require-diary () + (if (not (get-file-buffer ht-diary-file-name)) + (progn (rmail-input ht-diary-file-name) + (rmail-show-message 1)) + )) + +(defvar diary-summary-buffer nil "flag to identify diary summaries") +(defvar has-diary-summary nil "flag to identify buffers with diary summaries") + +(defun sort-diary-hdrs () + (interactive) + (goto-char (point-min)) + (sort-subr nil 'forward-line 'end-of-line 'get-diary-hdr-date nil)) + +(defun format-diary-hdrs () + (goto-char (point-min)) + (while (< (point)(point-max)) + (forward-char 5) + (delete-char 35) + (looking-at " *\\([0-9]*\\) *\\([a-zA-Z]*\\) *\\([0-9]*\\) *\\([0-9]*\\)") + (if (match-beginning 0) + (let ((day (buffer-substring (match-beginning 1)(match-end 1))) + (month (capitalize (buffer-substring (match-beginning 2) + (min (+ (match-beginning 2) + 3) + (match-end 2))))) + (year (buffer-substring (max + (- (match-end 3) 2) + (match-beginning 3)) + (match-end 3))) + (time (buffer-substring (match-beginning 4)(match-end 4)))) + (delete-char (+ 1 + (if (= (match-end 4) + (match-beginning 4)) + 0 ; fix for no time case + 1) + (- (match-end 4)(match-beginning 1)))) + (insert (format " %2s %3s %2s %4s " day month year time)))) + (forward-line 1)) + (goto-char (point-min))) + +(defun get-diary-hdr-date () + (looking-at " *[^ ]* *[^ ]* *[^ ]* *\\(.*\\)$") + (xxx-comparable-date (buffer-substring (match-beginning 1)(match-end 1)))) + + +(if (not (boundp 'rmail-edit-map)) + (load-library "rmailedit")) +(if (not (boundp 'rmail-summary-mode-map)) + (progn (load-library "rmailsum") + (rmail-summary-mode-fun1))) +(define-key rmail-edit-map "\C-c\C-c" 'ht-rmail-cease-edit) +(define-key rmail-edit-map "\C-c\C-]" 'ht-rmail-abort-edit) +;(defvar diary-mode-map (copy-keymap rmail-summary-mode-map)) +;(define-key diary-mode-map "s" 'diary-save) +(define-key rmail-mode-map "h" 'ht-rmail-summarise) +(setq rmail-summary-mode-hook 'do-diary-update) + +(defvar editing-diary-entry nil) + +(defun diary-save () + "save parent file and update" + (interactive) + (set-buffer rmail-buffer) + (rmail-expunge-and-save) + (if has-diary-summary (update-diary (current-buffer)))) + +(defun ht-rmail-summarise () + "Display a summary of all messages, one line per message. +If file is named as ht-diary-file-name, or the summary buffer is already +a diary summary, make it a Diary summary (see +\\[describe-mode] rmail-summary-mode for info)." + (interactive) + (if (eq (current-buffer) + (get-file-buffer ht-diary-file-name)) + (update-default-diary t) + (rmail-summary))) + +(defun edit-and-move-to-diary () + "try to add a date to subject field, move to diary on exit" + (interactive) + (make-local-variable 'editing-diary-entry) + (setq editing-diary-entry t) + (rmail-edit-current-message) + (goto-char (point-min)) + (search-forward "\n\n") + (let ((try-date (and + (re-search-forward + "[0-9][-0-9 ]*[- ][a-zA-Z][a-zA-Z]*[- 0-9]*" nil t) + (buffer-substring (match-beginning 0)(match-end 0)))) + sublp) + (goto-char (point-min)) + (setq sublp (search-forward "Subject: " nil t)) + (if try-date + (progn (set-mark (point)) + (insert try-date))))) + +(defun gnus-edit-and-move-to-diary (&optional no-delete) + "try to add a date to subject field, move to diary on exit" + (interactive "P") + (let ((flush-shell nil)) + (when (and (not (and no-delete (cdr no-delete))) + (gnus-group-read-only-p)) + (error "The current newsgroup does not support article editing")) + ;; Select article if needed. + (unless (eq (gnus-summary-article-number) + gnus-current-article) + (gnus-summary-select-article t)) + (gnus-article-date-original) + (message "About to forward. . .") + (gnus-summary-mail-forward 1) + (message "Begin forward. . .") + (goto-char (point-min)) + (re-search-forward "^To: " nil t) + ;(forward-char 4) + (insert "htcalendar@markup.co.uk") + (search-forward "------ Start of forwarded") + (save-excursion + (when (and (bufferp (get-buffer "*Shell Command Output*")) + (not (re-search-forward + "^--0000.*[[:space:]]*Content-Type: text/plain" nil t nil + (get-buffer " *Original Article*"))) + (search-forward "<html" nil t)) + (backward-char 5) + (push-mark nil t) + (re-search-forward "</html>[[:space:]]*") + (exchange-point-and-mark) + (use-text-not-html t) + (let ((pos (point))) + (when (search-backward "type=text/html" nil t) + (replace-match "type=text/plain") + (goto-char (+ pos 1)))) + (setq flush-shell t) + )) + (let (sublp) + (save-excursion + (goto-char (point-min)) + (setq sublp (search-forward "Subject: " nil t)) + (delete-region (point)(progn (search-forward "] " nil t))) + (if (not + (looking-at "[123]?[0-9] [JFMASOND][a-z][a-z] (20)?[2-9][0-9] ")) + (save-excursion + (let ((try-date + (and + (or (re-search-forward "^\r?$" nil 1) t) + (re-search-forward + "[0-9][-0-9 ]*[- ][jfmasondJFMASOND][a-zA-Z]*[- 0-9]*" + (save-excursion (search-forward "\n--\n" nil t)) + t) + (buffer-substring (match-beginning 0)(match-end 0))))) + (message (format "date: |%s| %s" try-date sublp)) + (if (and sublp + try-date) + (progn (set-mark (point)) + (insert try-date))))))) + (make-local-hook 'message-send-hook) + (if (and no-delete (equal (car no-delete) 16)) + (let ((hook '(lambda () + (ht-gnus-cease-edit nil) + nil t))) + (add-hook 'message-send-hook hook nil t) + + (message-send-and-exit) + (if (cdr no-delete) + ;; called directly from splitting an ht+d message... + "_doom" + (if (not (gnus-summary-next-unread-article)) + (gnus-summary-exit)))) + (add-hook 'message-send-hook + `(lambda () + (ht-gnus-cease-edit ',no-delete ',flush-shell) + ; (gnus-summary-edit-article-done + ; ,(or (mail-header-references gnus-current-headers) "") + ; ,(gnus-group-read-only-p) ,gnus-summary-buffer nil) + ; (switch-to-buffer gnus-summary-buffer))) + ; (goto-char (point-min)) + ; (search-forward "\nSubject: " nil t)) + ) + nil t) + (split-window-vertically 6) + (other-window 1) + (search-forward "\n\n" nil t) + (other-window 1) + (goto-char sublp) + (message "Exiting to buffer, we hope"))) + ) + ) + +(defun ht-gnus-cease-edit (&optional no-delete flush-shell) + "check if diary edit, move if so" + (interactive "P") + (message "ceasing. . .") + (ht-forward-to-Calendar) + (let ((rmail-summary-redo '(rmail-summary))) + (gnus-output-to-rmail ht-diary-file-name) + ) + (unless no-delete + (with-current-buffer gnus-summary-buffer + (gnus-summary-move-article 1 "nnml+ht:_doom"))) + (if (get-buffer "diary.babyl-summary") + (kill-buffer "diary.babyl-summary")) + (with-current-buffer "diary.babyl" + (rmail-mode) + (save-buffer) + (ht-rmail-summarise)) + (if flush-shell + (let ((sb (get-buffer "*Shell Command Output*"))) + (if (bufferp sb) + (kill-buffer sb)))) + (message "ceased")) + +(defun ht-gnus-summary-save-in-diary (&optional filename) + (gnus-eval-in-buffer-window gnus-save-article-buffer + (save-excursion + (save-restriction + (widen) + (gnus-output-to-rmail ht-diary-file-name))))) + +;; private copy to simulate hook +(defun ht-rmail-cease-edit () + "check if diary edit, move if so" + (interactive) + (rmail-cease-edit) + (if editing-diary-entry + (progn (setq editing-diary-entry nil) + (ht-forward-to-Calendar) + (rmail-output-to-rmail-file ht-diary-file-name 1) + (ht-rmail-delete-forward)))) + +;; try to add a diary subject field line to the appropriate calendar file +(defun ht-forward-to-Calendar () + (goto-char (point-min)) + (search-forward "Subject: ") + (or (looking-at + "\\([0-9]+\\) \\([A-Za-z]+\\) \\([0-9]+\\) \\([0-9:]*\\) ?\\(.*\\)\n") + (error "not a recognisable diary line")) + (let ((day (buffer-substring (match-beginning 1) (match-end 1))) + (month (buffer-substring (match-beginning 2) (match-end 2))) + (year (buffer-substring (match-beginning 3) (match-end 3))) + (time (buffer-substring (match-beginning 4) (match-end 4))) + (message (buffer-substring (match-beginning 5) (match-end 5))) + (mb (match-beginning 4)) + (me (match-end 5)) + ends e-day e-month fn) + (let ((year (if (string-match "^\\(19\\|20\\).." year) + year + (if (eq (length year) 2) + (concat "20" year) + (progn (if (and (equal time "")(eq (length year) 4)) + (setq time year)) + (format-time-string "%Y"))))) + (t-month (capitalize + (substring month 0 3)))) + (let* ((n-day (read day)) + (mon-table '((Jan . 1) + (Feb . 2) + (Mar . 3) + (Apr . 4) + (May . 5) + (Jun . 6) + (Jul . 7) + (Aug . 8) + (Sep . 9) + (Oct . 10) + (Nov . 11) + (Dec . 12))) + (a-month (assq (read t-month) + mon-table)) + (n-month (if a-month (cdr a-month) 0)) + (u-time (if (equal time "") "0" time)) + (hour (/ (read u-time) 100)) + (minute (mod (read u-time) 100)) + (nhour (if (> minute 29) + (+ 1 hour) + hour)) + (nminute (if (> minute 29) + (- minute 30) + (+ minute 30))) + (n-year (read year)) + (r-subj (mail-fetch-field "Subject")) + (body (save-excursion + (buffer-substring + (progn + (goto-char (point-min)) + (if (re-search-forward "^\r?$" nil 1) + (match-beginning 0) + (point-max))) + (point-max)))) + (subj-matches (string-match "^\\([^(]*\\)\\((\\(.*\\))\\)?" + message)) + (np-subj (match-string 1 message)) + (p-subj (or (match-string 3 message) "")) + (uid (or (mail-fetch-field "Message-id") + (let ((ct (current-time))) + (format "%d-%d-%d" + (car ct) + (cadr ct) + (caddr ct))))) + ) + (if (string-match " -- \\(.*\\)$" message) + (progn + (setq ends (substring message (match-beginning 1) + (match-end 1))) + (setq message (substring message 0 (match-beginning 0))) + (if (string-match "\\([0-9]+\\) \\([A-Za-z]+\\)" ends) + (progn + (setq e-day (substring ends (match-beginning 1) + (match-end 1))) + (setq e-month (assq + (read (capitalize + (substring + (substring ends (match-beginning 2) + (match-end 2)) + 0 3))) + mon-table)))))) + (setq fn (build-vcal-message (my-time-iso8601 + (encode-time + 0 minute + hour + n-day + n-month + n-year)) + (my-time-iso8601 + (if e-day + (encode-time + 0 (if (eq hour 0) 30 minute) ;nminute + (if (eq hour 0) 23 hour) ; nhour + (read e-day) + (if e-month (cdr e-month) 0) + n-year) + (encode-time + 0 minute ; nminute + (+ hour 1) ; nhour + n-day + n-month + n-year))) + "ORGANIZER;CN=\"Henry S. Thompson\":mailto:htcalendar@markup.co.uk" + ;(concat "ORGANIZER:" (mail-fetch-field "From")) + p-subj + body + np-subj + (concat "ht-vcal-" uid))) + (if fn + (progn + (goto-char (point-min)) + (if (search-forward "<#multipart " nil t) + (progn + (if (search-forward "<#multipart type=alternative" nil t) + (beginning-of-line) + (forward-line 2) + ;; now at beginning of forwarded text + (if (search-forward "<#part " nil t) + (progn + ;; now at beginning of _attachments_ + (beginning-of-line)) + ;; no attachments, probably never happens + (search-forward "<#/multipart>")))) + ;; plain text, make it multipart + (search-forward "-------- Start of forwarded") + (re-search-forward "^\r?$") + (forward-line 1) + (insert "<#multipart type=mixed>\n<#part type=text/plain charset=\"ISO-8859-1\" format=\"flowed\" disposition=inline nofile=yes>\n") + (search-forward "--------- End of forwarded") + (forward-line -1) + (insert "<#/multipart>\n") + (forward-line -1)) + (mml-attach-file fn "application/octet-stream" "diary event") +; (let ((res (shell-command-to-string +; (concat "updateCal.pl < " fn)))) +; (if (not (equal res "")) +; (message (format "update losing: %s" res)))) + ))) + (if (file-exists-p ht-Calendar-directory) + (let* ((dfn (concat ht-Calendar-directory + "/xy" + year + "/xc" + day + t-month + year)) + (buf (find-file-noselect dfn)) + ) + (save-excursion + (set-buffer buf) + (goto-char (point-max)) + (if (not (bolp)) + (insert "\n")) + (if time + (insert time " ")) + (insert message) + (let ((require-final-newline nil)) + (save-buffer))) + (if ends + ;; an end date also given + (if e-day + (let (t-e-month msg) + (setq msg (concat + (substring message 0 + (string-match " " message)) + " continues")) + (if (string-equal (setq t-e-month + (if e-month (car e-month) + t-month)) + t-month) + (fill-dates year t-month (1+ (car + (read-from-string day))) + (car + (read-from-string e-day)) + msg) + (fill-dates year t-month (1+ (car + (read-from-string day))) + (cdr (assoc t-month + '(("Jan" . 31) + ("Feb" . 28) + ("Mar" . 31) + ("Apr" . 30) + ("May" . 31) + ("Jun" . 30) + ("Jul" . 31) + ("Aug" . 31) + ("Sep" . 30) + ("Oct" . 31) + ("Nov" . 30) + ("Dec" . 31)))) + msg) + (fill-dates year t-e-month 1 + (car (read-from-string e-day)) + msg))) + (message "\C-g\C-gCouldn't parse end date: %s" ends))) + ))))) + +(defun fill-dates (year month start end mesg) + "fill the dates between start and end with message in the calendar" + (let ((day start)) + (while (<= day end) + (let* ((dfn (concat ht-Calendar-directory + "/xy" + year + "/xc" + (format "%d" day) + (format "%s" month) + year)) + (buf (find-file-noselect dfn))) + (save-excursion + (set-buffer buf) + (goto-char (point-max)) + (if (not (bolp)) + (insert "\n")) + (insert mesg) + (let ((require-final-newline nil)) + (save-buffer)))) + (setq day (1+ day))))) + +;; private copy +(defun ht-rmail-abort-edit () + "add a hook" + (interactive) + (setq editing-diary-entry nil) + (rmail-abort-edit)) + +(defun rmail-edit-current-message () + "Edit the contents of this message." + (interactive) + (rmail-edit-mode) + (make-local-variable 'rmail-old-text) + (setq rmail-old-text (buffer-substring (point-min) (point-max))) + (setq buffer-read-only nil) + (set-buffer-modified-p (buffer-modified-p)) + ;; Make mode line update. + (if (and (eq (key-binding "\C-c\C-c") 'ht-rmail-cease-edit) + (eq (key-binding "\C-c\C-]") 'ht-rmail-abort-edit)) + (if editing-diary-entry + (message "Editing: Type C-c C-c to move to diary and return to Rmail, C-c C-] to abort") + (message "Editing: Type C-c C-c to return to Rmail, C-c C-] to abort")) + (message (substitute-command-keys + "Editing: Type \\[rmail-cease-edit] to return to Rmail, \\[rmail-abort-edit] to abort")))) + + +(defun build-vcal-message (start end org location description summary uid) + (save-excursion + (let ((fn (concat "/tmp/" (make-temp-name "vcal") ".vcs"))) + (find-file fn) + (insert "BEGIN:VCALENDAR\nMETHOD:PUBLISH\nPRODID:-//Henry S. Thompson//gnus diary hack//EN\nVERSION:0.1\nBEGIN:VEVENT\n") + (insert "UID\n :")(insert uid)(insert "\n") + (insert "SUMMARY")(insert-encoded-maybe summary)(insert "\n") + (insert "DESCRIPTION")(insert-folded description)(insert "\r\n") + (insert "LOCATION")(insert-encoded-maybe location)(insert "\n") + (insert "DTSTART\n :")(insert start)(insert "Z\n") + (insert "DTEND\n :")(insert end)(insert "Z\n") + (insert "DTSTAMP\n :")(insert + (my-time-iso8601 (current-time))) + (insert "Z\n") + ;(insert "ORGANIZER")(insert-encoded-maybe org) + (insert org) + (insert "\n") + (insert "BEGIN:VALARM\nTRIGGER:-PT15M\nACTION:DISPLAY\nDESCRIPTION:Reminder\nEND:VALARM\n") + (insert "BEGIN:VALARM\nTRIGGER:-PT15M\nACTION:AUDIO\nDESCRIPTION:Reminder\nEND:VALARM\n") + (insert "END:VEVENT\nEND:VCALENDAR\n") + (save-buffer) + fn))) + +(defun insert-encoded-maybe (string) + (if (string-match "[\000-\007\n\013\015-\037\200-\377=]" string) + (progn + (insert ";ENCODING=QUOTED-PRINTABLE:") + (let ((beg (point))) + (insert string) + (message (format "%d;%d" beg (point))) + (quoted-printable-encode-region + beg + (point) + t + "^\000-\007\n\013\015-\037\200-\377=")) + (goto-char (point-max))) + (insert "\n :") + (insert string))) + +(defun insert-folded (string) + (insert "\n :") + (let ((beg (point))) + (insert string) + (narrow-to-region beg (point)) + (goto-char (point-min)) + (replace-string "\n" "\\n") + (goto-char (point-min)) + (replace-string "\r" "") + (goto-char (point-min)) + (replace-string "," "\\,") + (goto-char (point-min)) + (while (> (- (point-max) (point)) 72) + (forward-char 70) + (insert "\n ")) + (goto-char (point-max)) + (insert "\r\n") + (widen))) + +(defun my-time-iso8601 (time) + (let ((tzo (car (current-time-zone time))) + (hi (car time)) + (lo (cadr time)) + (ignore (cddr time))) + (gnus-time-iso8601 + (if (>= lo tzo) + (cons hi + (cons (- lo tzo) + ignore)) + (cons (- hi 1) + (cons (- (+ lo 65536) tzo) + ignore))) + )))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/shared/gnus-init.el Sat Oct 07 12:43:14 2023 +0100 @@ -0,0 +1,459 @@ +;; Last edited: Fri Sep 7 12:19:43 2018 +;; gnus customisation + +(setq gnus-novice-user nil) +(setq gnus-message-archive-group + '((concat "general." (format-time-string + "%Y-%m" (current-time))))) + +(setq gnus-summary-ignore-duplicates t + gnus-auto-select-next 'quietly + gnus-save-newsrc-file nil + gnus-read-newsrc-file nil + gnus-save-killed-list nil + gnus-summary-display-arrow nil + gnus-check-new-newsgroups nil + gnus-auto-select-subject 'unseen-or-unread + gnus-your-organization "HCRC, University of Edinburgh" + gnus-buttonized-mime-types '("multipart/signed") + gnus-ignored-headers + "^Errors-To:\\|^Precedence:\\|^UNIX-From:" + gnus-default-directory "/afs/inf.ed.ac.uk/user/h/ht" + nnmail-message-id-cache-file "/disk/scratch/gnus/.nnmail-cache" + mm-discouraged-alternatives '("text/html") + nnmail-expiry-wait 28 + mail-sources + '((file :path "/disk/scratch/mail/ht_mbox")) + mail-source-crash-box "/tmp/crashbox" ; local disk + nndraft-directory "/disk/scratch/drafts/" + message-auto-save-directory "/disk/scratch/drafts/" + message-from-style 'angles + no-select-groups '("nnml+ht:cygwin") + gnus-group-line-format "%M%S%p%P%5y:%uH%(%g%)%l %O +") + +(setq bbdb/news-auto-create-p t) + +(setq wsp-cache nil) + +;;;(setq blacklist-db (open-database "~/.blacklist")) + +(require 'my-news) ; defines db functions + +(open-white) +(open-ad) +(open-quaker) + +(add-hook 'kill-emacs-hook + (lambda () + (if (database-live-p whitelist-db) + (close-database whitelist-db)) + (if (database-live-p quaker-db) + (close-database quaker-db)) + (if (database-live-p adlist-db) + (close-database adlist-db)))) + +(add-hook 'bbdb-complete-name-hooks 'quaker-sig-if-quaker) +(add-hook 'gnus-message-setup-hook 'quaker-sig-if-to-quaker) + +(setq nnmail-crosspost nil) +(setq nnmail-split-methods 'nnmail-split-fancy) + +(setq white-subjects "\\b\\(phd\\|ilcc\\)\\b") + +(setq white-domains (list)) + +(setq ad-domains (list "planetx.co.uk")) + +(setq w3c-lists1 + '((list "w3c-xml-schema-\\([a-zA-Z]+\\)\\(\\.w3\\.org\\)?" "xml-schema-\\1") + (list "chairs\\(\\.w3\\.org\\)?" "w3c-chairs" ) + (to "\\(w3c\\|public\\|member\\)-xml-\\([-a-zA-Z]+\\)\\(\\.w3\\.org\\)?" + "xml-\\2" ) + ;(list "w3t-\\([-a-zA-Z]+\\)\\(\\.w3\\.org\\)?" "w3t-\\1") + ;(list "team-\\([-a-zA-Z]+\\)\\(\\.w3\\.org\\)?" "w3-team-\\1") + ;(list "w3c-\\(xsl-wg\\|format\\|i18n-ig\\)\\(\\.w3\\.org\\)?" "w3c-xsl") + (list "w3c-\\([-a-zA-Z]+\\)\\(\\.w3\\.org\\)?" "w3c-\\1") + (list "member-\\(ac-uk\\|access\\)" "w3-member-\\1");[-a-zA-Z]+\\) + (to "public-xpointer-registry\\(-request\\)?" + "xpointer-registry");[-a-zA-Z]+ + (to "public-\\([-a-zA-Z]+\\)" "w3-public-\\1") + (to "w3c-xml-schema-\\([a-zA-Z]+\\)" "xml-schema-\\1") + (to "chairs" "w3c-chairs") + (to "w3c-xml-\\([-a-zA-Z]+\\)" "xml-\\1" ) + (to "www-xml-\\([-a-zA-Z]+\\)" "xml-\\1") + ;(list "www-\\([-a-zA-Z]+\\)" "www-\\1") + ;(to "w3c-\\(xsl-wg\\|format\\|i18n-ig\\)" "w3c-xsl") + ;(to "w3t-\\([-a-zA-Z]+\\)" "w3t-\\1") + ;(to "team-\\([-a-zA-Z]+\\)" "w3-team-\\1") + ;(to "w3c-\\([-a-zA-Z]+\\)" "w3c-\\1") + ;(to "xml-\\([-a-zA-Z]+\\)" "w3c-\\1") + ;(to "member-\\([-a-zA-Z]+\\)" "w3-member-\\1") + ;(to "ercim-\\([-a-zA-Z]+\\)" "ercim-\\1") + ;(to "w3t" "w3t") + )) + +(setq w3c-lists2 + '((to "w3t-archive" "w3t-archive") + (to "w3c-archive" "w3c-archive"))) + +(setq xml-lists1 + '(;(to "xml-uri" "nsuri") + (to ".*editor.*" "xml-rec-comments") + (to "xml-dev" "xml") + (to "xsl-list" "xsl") + ;(to "[Xx]emacs[- ]beta" "xemacs") + (to "xmlschema-dev" "schema-dev") + (to "xproc-dev" "xproc-dev") + ;(to "xml-sig" "xml-python") + ;(to "xml-plenary" "xml-plenary") + )) + +(setq xml-lists2 + '((list "ietf-xml-mime\\.imc\\.org" "xml-mime") + (list "xml-mime\\.ietf\\.org" "xml-mime"))) + +(setq misc-list1 + '(;(from "w3t-\\([a-zA-Z]+\\)-request" "w3t-\\1") + ;(from "w3c-\\([a-zA-Z]+\\)-request" "w3c-\\1") + ;(from "xml-\\([a-zA-Z]+\\)-request" "xml-\\1") + ;(from "p.woolman" "nhs-xml") + (from "Cron Daemon" "cron") + (from ".*@mail.gumtree.com" "personal") + (from ".*@postman.storyworth.com" "storyworth") + ;(from "\\(Richard\\.Kirkham\\|rachel\\.johnson\\|maria\\.papadaki\\|marisol\\.leonen\\|sangeeta\\.tewar\\|abdullah\\.alshamsi\\|.*@buid\\.ac\\.ae\\)" "buid") + (to "www-tag" "tag") + ;(to "webarch@noreply.github.com" "tag") + ;(to "dashboard-hackers" "beagle") + ;(to "pellet-users" "pellet") + (to "tkinter-discuss" "tkinter") + ;(to "sdp-students" "sdp") + (to "fnlp-students" "fnlp") + ;(from "fox@tardis\\.ed\\.ac\\.uk\\|s1505551" "fnlp") + ;(to "anlp-students" "anlp") + ;(from "nbnotifications" "anlp") + ;(: split-on-whole-field "Subject" "Re: MSc Project 18.*" "msc18") + ;(: split-on-whole-field "Subject" ".*\\(FNLP\\|100782021\\).*" "fnlp") + ;(: split-on-whole-field "Subject" ".*SDP \\(MS .\\|final\\) evaluation" "sdpEval") + ;(: split-on-whole-field "Subject" ".*[[]SDP[]] \\(Your evaluation\\|Evaluation deadline\\).*" "sdpEval") + ;(: split-on-whole-field "Subject" ".*SDP.*" "sdp") + ;(: split-on-whole-field "Subject" ".*Welcome to ANLP, action needed.*" "anlp_github") + (: split-on-whole-field "Subject" ".*\\(ANLP\\|Accelerated Natural Language Processing\\).*" "anlp") + (from "ANLP on Piazza" "anlp") + ;(from "FNLP on Piazza" "fnlp") + (from "alopez\\|learn\\|scohen\\|eponti" "anlp") + (from "080202022-3SV1SEM2" "inf1-cg") + (from "INFR111252023-4SV1SEM1" "anlp") + (from "no-reply@piazza.com" "anlp") + (: split-on-whole-field "Subject" ".*Personal Tutor.*" "tutees22") + (: split-on-whole-field "Subject" ".*Course Selection.*" "tutees22") + ;(: split-on-whole-field "Subject" ".*Sutton Trust.*" "inf-recruit") + (: split-on-whole-field "Subject" "mycron .*" "cron") + ;(: split-on-whole-field "Subject" "INF1-Cg experiment.*" "cgx_2013") + (: split-on-whole-field "Subject" ".*[[]urn[]].*" "urn") + (from "\\(106300.457@compuserve.com\\|elizdrummondyoung@gmail.com\\|jcdavey12@btinternet.com\\|andrewdolan@btinternet.com\\|wandbamoyes@btinternet.com\\)" "albertus") + (to "corpus-admin" "corpora") + (: split-on-whole-field "Subject" ".*Albertus.*" "albertus") + (: split-on-whole-field "Subject" ".*\\[corpus-admin\\].*" "corpora") + ;(to ".*@\\(hst\\|hthompson\\|henry\\.thompson\\)\\.name" "personal") + (from "mikereape@.*" "mikereape") + (from "\\(.*@mumble\\.net\\|jar@\\.csail\\.mit\\.edu\\)" "jar") + (from ".*@coulters.io" "belford") + (from ".*@umega.co.uk" "belford") + (to ".*@umega.co.uk" "belford") + (: split-on-whole-field "Subject" ".*belford.*" "belford") + )) + +(setq quaker-list + '((to "quaker-\\(l\\|spectrum\\)" "quaker") + ;(to "quaker-b" "quaker-b") + ;(to "QuakerBYM" "quaker-b") + ;(from "quaker-spectrum-approval" "quaker") + )) + +(setq sms-list + '(;(from "s1513009@.*" "ug4_18");\\|s1536017\\(s1443062\\|s1679328 + ;(from "Y.Chen-258@.*" "msc_19") + ;(from "\\(s1795066\\|s1825415\\|A.M.Magalhaes\\|T.Makino\\|S.Li-93\\|M.Maggiolo\\|ashe\\|Y.Li-242\\|E.J.Martin\\|K.Lohse\\|D.Li-28\\|S.D.Martin-1\\|K.Chen-35\\|J.Norris-3\\|S.Li-80\\|Y.Liu-236\\|J.Chen-114\\|Q.Zeng-3\\|Y.Liu-244\\|P.Guo-1\\|s1582739\\|B.Lun\\|X.Li-143\\|F.Li-17\\|K.R.Lu\\|Z.Li-86\\)@.*" "tutees18") + (from "\\(s1895309\\|s1765180\\|s1764494\\|s1645474\\|s1953043\\|s1651774\\|s1732316\\|s1742667\\)@.*" "tutees20") + )) + +(defalias 'tut20 (read-kbd-macro +"C-x o C-s < RET C-s @ C-b C-x C-x M-w C-x b gnus SPC RET C-s \"tutees20 RET C-r \\\\) RET \\\\| C-y C-a ESC ESC : nil RET ESC C-x M-x ht- 3*<backspace> set- ht SPC RET C-x C-s C-x b RET C-x o")) + +;;; groups only, comes _after_ split to pers-... for to: ht... +(setq misc-list2 + '(;(to "cogsci.general" "junk") + (from "anrdaemon@yandex.ru\\|gsenopu@gmail.com\\|pradeepan88@hotmail.com" "anr-doom") + ;(to "bp-people" "bp-people") + ;(to "ppelders" "ppelders") + ;(to "7vtw" "7vtw") + (to "\\(apps-review\\|uri-review\\|apps-discuss\\|discuss\\|architecture-discuss\\|appsdir\\|art\\)@[a-z.]*\\(ietf\\|iab\\).org" "ietf") + (to "urn@ietf.org" "urn") + (to "if-people" "if-people") + (to "maptask" "maptask") + ;(to "i18n-sig" "xml-python") + ;(to "spec-prod" "spec-prod") + ;(to "markup" "markup") + ;(to "system-notices" "w3c-sys-notes") + (to "[cC]ygwin" "cygwin") + ;(to "jde@sunsite.dk" "jde") + ;(to "jdee-users@lists.sourceforge.net" "jde") + (to "tagsoup-friends@yahoogroups.com" "tagsoup") + (to "screen-users@gnu.org" "screen") + (from "mailinglist@edinburghrc.co.uk" "erc") + (to "selenium-users" "selenium") + (to "python-list@python.org" "python") + ;(to "ding" "gnus") + ;(to "dssslist" "dsssl") + ;(to "TEI-L" "tei") + (to "\\(announcements\\|unicode\\)@.*[.]unicode[.]org" "unicode") + ;(to "squid-users@lists.squid-cache.org\\|squid-users@squid-cache.org" + ; "squid") + (to "exist-open" "exist") + (list "ilcc-\\([a-zA-Z]+\\)" "ilcc-\\1") + (to "ilcc" "ilcc") + (to ".*lecturers@inf.ed.ac.uk" "inf-teach") + (to "\\(aisyllabus\\|acstaff\\)" "inf-teach") + (to "\\(inf\\)?\\(pg\\|msc\\|teach\\|res\\|staff\\)\@inf\\(ormatics\\)?" + "inf-\\2" ) + ;(to "directors-of-studies" "inf-dos") + (to "common-crawl@googlegroups.com" "ccrawl") + ;(list "inkscape-user\\|openbox\\|ffmpeg-user" "misc-list") + )) + +(defvar ht-compiled-split nil) + +(defun set-ht-compiled-split () + "update the mail splitting rules" + (interactive) + (setq ht-compiled-split + (let* ((month + (format-time-string "%Y-%m" (current-time))) + (now-group (concat "group-" month)) + (now-pers (concat "pers-" month))) + `(| + (: split-on-whole-field "Subject" "testing" "junk") + (: ad-spam "adverts") +;;; ("Content-Type" content-spam "gnSPAM") +;;; ("Content-Transfer-Encoding" encoding-spam "gnSPAM") +;;; (: split-on-whole-subj 'subject-spam "gnSPAM") + ;; Special to people who use Yahoo +;;; ("X-YahooFilteredBulk" ".*" "gnSPAM") +;;; (from author-spam "gnSPAM") + ;; A subject with no letters is SPAM +;;; (: split-on-whole-subj "^[^a-zA-Z]+$" "gnSPAM") + ;; It would be cool to check the + ;; date and toss it if it is "old" + (to "\\(w3[ct]\\|www\\|team\\|member\\|public\\|ercim\\)[^ ]*@.*" + (| ,@w3c-lists1 + (to "ht\\|henry\\|\\(h\\.?\\)?thompson?" ,now-pers) + ,@w3c-lists2 + (to "x.*@.*" (| ,@xml-lists1 + (to "ht\\|henry\\|\\(h\\.?\\)?thompson?" ,now-pers) + ,@xml-lists2 + ,now-group)))) + (to "x.*@.*" (| ,@xml-lists1 + (to "ht\\|henry\\|\\(h\\.?\\)?thompson?" ,now-pers) + ,@xml-lists2)) + ,@misc-list1 + (to "ht\\|henry\\|\\(h\\.?\\)?thompson?" + (| (from ".*@sms.ed.ac.uk" (| + ,@sms-list + ,now-pers)) + + ,now-pers)) + (to "quaker.*" (| + ,@quaker-list + ,now-group)) + ,@misc-list2 + ,now-group + )))) + +(set-ht-compiled-split) + +(defconst ht-spam-res '("bfSPAM" "boSPAM" "edSPAM" "saSPAM" "slSPAM")) + +(setq nnmail-split-fancy + '(| + (to "ht\\+d@inf\\.ed\\.ac\\.uk" "_diary") + (! + (lambda (sres) + (cond + ((or (equal (car sres) "notSPAM") + (white-spam t)) + ;; documentation is wrong, no recursion, + ;; so we do it ourselves :-( + (message "was %s, trying further" sres) + (setq sres (nnmail-split-it ht-compiled-split)) + (log-good-sender sres) + sres) + ((member (car sres) ht-spam-res) + sres) + (t ; shouldn't happen! + (message "Shouldn't happen in nnmail-split-fancy %s" sres) + sres)) + ) + (| (: split-on-whole-field "Subject" ".*=\\?UTF-8\\(\\?B\\\?\\|.*=[A-F][0-9]=\\).*\\?=.*" "slSPAM") + ("X-Bogosity" "Yes.*" + (| + (From ".*@.*ed\.ac\.uk" "edSPAM") ; NB From not from + ("X-Spam-Score" "0" "boSPAM") + "bfSPAM")) + (: split-on-whole-field "X-Spam-Level" "\\*\\*\\*\\*.*" + "saSPAM") + ("X-Spam-Status" "Yes.*" "saSPAM") + "notSPAM")))) + +(defun log-good-sender (sres) + (message "good sender %s with result %s" (get-from-gnus-addr) sres)) + +(setq gnus-show-mime t) ; stale +(setq mml1991-use 'pgg + mml2015-use 'pgg + mm-verify-option 'always) + +(require 'mm-decode) +(setq mm-automatic-display (remove "text/html" mm-automatic-display)) + +(custom-set-faces) + +(defun straight-to-diary () + (save-excursion + (gnus-group-jump-to-group "nnml+ht:_diary") + (message "s1 %s" (get-text-property (point) 'gnus-group)) + (gnus-group-select-group) + (while (gnus-summary-first-unread-article) + (let ((sco (get-buffer "*Shell Command Output*"))) + (if sco + (kill-buffer sco))) + (gnus-edit-and-move-to-diary '(16 . t))) + (gnus-summary-exit) + ) + ) + +(add-hook 'gnus-group-mode-hook 'gnus-topic-mode) + +(add-hook 'gnus-summary-mode-hook 'gnus-summary-mode-fun1) + +;;; After hiding pgp, verify the message; +;;; only happens if pgp signature is found. + +;(add-hook 'gnus-article-hide-pgp-hook +; (lambda () +; (save-excursion +; (set-buffer gnus-original-article-buffer) +; (mc-verify)))) + + +(add-hook 'message-mode-hook 'message-mode-fun1) + +(add-hook 'gnus-group-mode-hook 'gnus-group-mode-fun1) +(add-hook 'gnus-select-group-hook 'no-select) + +(add-hook 'gnus-parse-headers-hook + '(lambda () + (gnus-summary-set-local-parameters gnus-newsgroup-name))) + + +;(add-hook 'gnus-summary-mode-hook 'mc-install-read-mode) +;(add-hook 'message-mode-hook 'mc-install-write-mode) +;(add-hook 'news-reply-mode-hook 'mc-install-write-mode) + +;;; Jack Vinson's (partial Fancy mail rules for killing SPAM) +;; Content with any of the following is probably SPAM + +(require 'nnmail) +(if (not (assq 'list nnmail-split-abbrev-alist)) + (setq nnmail-split-abbrev-alist + (cons '(list . "List-Id") nnmail-split-abbrev-alist))) + +(add-hook 'nnmail-split-abbrev-alist + (cons 'content-spam "text/html\\|big5\\|gb2312\\|ks_c_.*\\|euc-kr")) + +;; Encoding with any of the following is probably SPAM +(add-hook 'nnmail-split-abbrev-alist + (cons 'encoding-spam "binary\\|base64")) + +;; These special subjects are SPAM: +;; funny characters, whitespace followed by a string, no letters +;; and any words that are always SPAM +(add-hook 'nnmail-split-abbrev-alist + (cons 'subject-spam ".*\\([\177-\277\367]\\|=\\?big5\\?\\).*")) + +;; Bad authors who still get through all of this +(add-hook 'nnmail-split-abbrev-alist + (cons 'author-spam "explicit\\|amazing")) + +;; from w/o Resent-From +(add-hook 'nnmail-split-abbrev-alist + (cons 'From "from\\|sender")) + +;; And the actual splitting rule +;(setq nnmail-split-fancy +; '(| +; ;; Various mailing lists, match on Subject or Sender headers + ; (from mail "Boing") + ; (any "my_mailing_list@foo.com" "list_group") +; + ; ;; SPAM, SPAM, SPAM + ; ("Content-Type" content-spam "gnSPAM") + ; ("Content-Transfer-Encoding" encoding-spam "gnSPAM") + ; ("Subject" subject-spam "gnSPAM") + ; ;; Special to people who use Yahoo + ; ("X-YahooFilteredBulk" ".*" "gnSPAM") + ; (from author-spam "gnSPAM") + ;; A subject with no letters is SPAM +; ("Subject" "^[^a-zA-Z]+$" "gnSPAM") + ;; It would be cool to check the date and toss it if it is "old" + ;; Several spammers send mail that has ancient dates... + + ;; Additional splitting rules on Subject for convenience. + + ;; Everything else should be coming to me + ; (to "jackvinson" "misc") + + ;; Else it is SPAM + ; "gnSPAM") +; ) + +(add-hook 'message-sent-hook (function whiten-recip)) + +(add-hook 'gnus-get-new-news-hook (lambda () (setq ht-gnus-just-read nil))) +(add-hook 'gnus-after-getting-new-news-hook + (lambda () (progn + (message "%s" ht-gnus-just-read) + (if (member "_diary" ht-gnus-just-read) + (straight-to-diary))))) + +(add-hook 'nnml-prepare-save-mail-hook (function ht-gnus-note-save-to-group)) + +(require 'gnus-art) + +(nconc gnus-treatment-function-alist + '((gnus-treat-strip-uoe-warning gnus-article-strip-uoe-warning))) + +(defun gnus-article-strip-uoe-warning (&optional interactive &rest args) + "redirect for stripping" + (interactive (list t)) + (save-excursion + (set-buffer gnus-article-buffer) + (if interactive + (call-interactively 'article-strip-uoe-warning) + (apply 'article-strip-uoe-warning args)))) + +(defun article-strip-uoe-warning () + "strip the stupid uoe warning" + (interactive) + (save-excursion + (article-goto-body) + (let ((case-fold-search t)) + (when + (looking-at "This email was sent to you by someone outside the University.") + (gnus-delete-line)) + (when + (looking-at "You should only click on links or attachments if you are certain that the email is genuine and the content is safe.") + (gnus-delete-line)) + ))) + +(setq gnus-treat-strip-uoe-warning t)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/shared/hackbs.el Sat Oct 07 12:43:14 2023 +0100 @@ -0,0 +1,12 @@ +;;; Last edited: Tue Sep 9 10:22:22 2003 +;;; Hack bs vs ctrl-h + +(provide 'hackbs) +(defun hack-ctlh (prompt) + (if (eq (device-or-frame-type (frame-device)) 'tty) + [(backspace)] + [(control h)])) + +(define-key key-translation-map [(control h)] 'hack-ctlh) + +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/shared/hist.el Sat Oct 07 12:43:14 2023 +0100 @@ -0,0 +1,161 @@ +;;; a tcsh-type history key facility for sub-shells +;; Last edited: Wed Nov 14 09:52:12 1990 + +(provide 'hist) +(require 'prompt-for-word) + +(defvar hk-last-mb nil "*begin of last hk match") + +(defvar hk-last-mark nil "*beginning of last hk insertion") + +(defvar hk-search-pat nil "*regexp for hk search") + +(defvar hk-last-point 0 "*end of last hk insertion") + +(defvar hkr-last-point 0 "*end of last hk pattern search insertion") + +(defvar hkr-search-pat nil "*regexp for hk user pattern search") + +(defvar hk-last-user-pat nil "*user part of last pattern search") + +(make-local-variable 'hk-last-mb) +(make-local-variable 'hk-last-mark) +(make-local-variable 'hk-last-point) +(make-local-variable 'hk-search-pat) +(make-local-variable 'hkr-search-pat) +(make-local-variable 'hkr-last-point) +(make-local-variable 'hk-last-user-pat) + +(defvar hk-pat-table '(("*shell*" . ".*: ") + ("*prolog*" . "| \\?- ") + ("*lisp*" . ">") + ("*inferior-lisp*" . ">")) + "default crux of prompt pattern, by buffer name") + +(defun hist-key (&optional rpt) + "offer a previous input, a la tcsh ^P" + (interactive "p") + (if (not rpt) (setq rpt 1)) + (let ((here (point)) + (pat (or hk-search-pat + (setq hk-search-pat + (concat "^" (or (cdr (assoc (buffer-name + (current-buffer)) + hk-pat-table)) + "") + "\\(.+\\)$"))))) + (hk-find-b rpt here pat))) + +(defun hk-find-b (rpt here pat) + "search backwards for pat, no dups, rpt times" + (while (> rpt 0) + (goto-char (if (= (point) hk-last-point) + hk-last-mb + (if (eobp) + (progn (beginning-of-line) + (setq hk-last-mark nil) + (point)) + (error "nowhere??")))) + (let ((keep-trying t)) + (while keep-trying + (if (re-search-backward pat nil t) + (let ((entry (buffer-substring (match-beginning 1) + (match-end 1)))) + (setq hk-last-mb (match-beginning 0)) + (goto-char (or hk-last-mark here)) + (if (looking-at (regexp-quote entry)) + (goto-char hk-last-mb) + (setq keep-trying nil) + (if hk-last-mark (delete-region hk-last-mark hk-last-point)) + (setq hk-last-mark (point)) + (push-mark (point) t) + (insert entry) + (setq hk-last-point (point)))) + (unwind-protect (error "no more??") + (goto-char (if hk-last-mark + hk-last-point + here)))))) + (setq rpt (1- rpt)))) + +(defun hist-key-back (&optional rpt) + "offer a previous input, a la tcsh ^N" + (interactive "p") + (if (not rpt) (setq rpt 1)) + (let ((here (point)) + (pat (or hk-search-pat + (error "no pattern")))) + (while (> rpt 0) + (goto-char (if (= (point) hk-last-point) + hk-last-mb + (error "lost context"))) + (let ((keep-trying t)) + (while keep-trying + (end-of-line) + (if (re-search-forward pat nil t) + (let ((entry (buffer-substring (match-beginning 1) + (match-end 1)))) + (setq hk-last-mb (match-beginning 0)) + (goto-char (or hk-last-mark here)) + (if (looking-at (regexp-quote entry)) + ;; allow for back to square one + (if (progn (end-of-line) + (eobp)) + (progn (setq keep-trying nil) + (if hk-last-mark + (delete-region hk-last-mark hk-last-point) + (error "shouldnt")) + (goto-char hk-last-mark)) + (goto-char hk-last-mb)) + (setq keep-trying nil) + (if hk-last-mark (delete-region hk-last-mark hk-last-point)) + (setq hk-last-mark (point)) + (push-mark (point) t) + (insert entry) + (setq hk-last-point (point)))) + (unwind-protect (error "no more??") + (goto-char (if hk-last-mark + hk-last-point + here)))))) + (setq rpt (1- rpt))))) + +(defun hist-key-search (&optional rpt pat) + "offer a previous input, searching backwards for a pattern" + (interactive "p") + (if (not rpt) (setq rpt 1)) + (let ((here (point)) + (full-pat + (if (= (point) hkr-last-point) + hkr-search-pat + (setq hkr-search-pat + (if (eobp) + (concat "^" + (or (cdr (assoc (buffer-name + (current-buffer)) + hk-pat-table)) + "") + "\\(.*" + (setq hk-last-user-pat + (or pat + (regexp-quote + (prompt-for-word + "Pattern: " + (or hk-last-user-pat "") + nil nil)))) + ".*\\)$") + (error "nowhere??")))))) + (hk-find-b rpt here full-pat) + (setq hkr-last-point hk-last-point))) + +(require 'shell) + +(define-key shell-mode-map "\ep" 'hist-key) +(define-key shell-mode-map "\en" 'hist-key-back) +(define-key shell-mode-map "\es" 'hist-key-search) +(define-key shell-mode-map "\e\C-i" 'shell-expand-file-name) + +;;; hack in case we've been given com-int +(if (not (boundp 'inferior-lisp-mode-map)) + (require 'inf-lisp)) +(define-key inferior-lisp-mode-map "\ep" 'hist-key) +(define-key inferior-lisp-mode-map "\en" 'hist-key-back) +;; note that prolog copies shell-mode-map, so no need to fix that
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/shared/ht-rooms.config Sat Oct 07 12:43:14 2023 +0100 @@ -0,0 +1,36 @@ +(define-rooms '(("elisp" ("*scratch*" nil 0 0 80 47)) + ("text" ((" ") nil 0 0 80 47)) + ("diary" + ("diary.babyl" + (progn (rmail-input ht-diary-file-name) + (setq ht-last-file + (expand-file-name + "~/mail/history/diary.msg"))) + 0 0 80 11) + ("diary.babyl-summary" + (update-default-diary t) 0 11 80 23)) + ("news" ("*Group*" + (progn + (require 'my-news) + (gnus)) 0 0 80 47)) + )) + +;;; next two should be parameterised for screen height + +(defun make-lisp-room () + "create and go to a room for lisp work" + (interactive) + (establish-room '("lisp" + ("*lisp*" (run-lisp) 0 0 80 23) + ((" ") (lisp-mode) 0 23 80 47)) + t)) + +(defun make-prolog-room () + "create and go to a room for prolog work" + (interactive) + (establish-room '("prolog" + ("*prolog*" (run-prolog) 0 0 80 23) + ((" ") (prolog-mode) 0 23 80 47)) + t)) + +(rooms-goto (assoc "news" rooms-table) nil)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/shared/mail-extras.el Sat Oct 07 12:43:14 2023 +0100 @@ -0,0 +1,517 @@ +;; Last edited: Fri Nov 2 10:26:24 1990 +;; extra widgets for rmail and rmailsum +;; Copyright (C) 1990 Henry S. Thompson + +;; 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. + +(provide 'mail-extras) +(require 'rmail) +(require 'sendmail) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; mods and fixes for reading mail ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defvar ht-last-file (expand-file-name "~/XMAIL") + "default for moving mail to") +(make-variable-buffer-local 'ht-last-file) + +(defvar rmht-always-recompress t + "If non-nil, when saving into compressed babyl file, +always recompress and save immediately") + +(defvar rmht-allow-autosave t + "if non-nil, leaves autosave alone for compressed babyl files, +otherwise turns it off") + +(add-hook 'rmail-mode-hook 'rmail-mode-fun1) +(add-hook 'rmail-mode-hook 'rmail-mode-fun2) + +;; run the first time in to RMAIL +(defun rmail-mode-fun1 () + "add ht's mods to RMAIL" + (define-key rmail-mode-map "R" 'reply-w/o-cc) + (define-key rmail-mode-map "M" 'rmht-output) + (define-key rmail-mode-map "H" 'print-buffer) + (define-key rmail-mode-map "W" 'edit-and-move-to-diary) + (define-key rmail-mode-map "D" 'update-default-diary) + (define-key rmail-mode-map "F" 're-post-failed-mail) + (define-key rmail-mode-map "B" 'ht-write-body-to-file) + (define-key rmail-mode-map "E" 'extract-attachment) + ;; fix the doc string + (repl-comment 'rmail-mode + "Rmail Mode is used by \\[rmail] for editing Rmail files. +All normal editing commands are turned off. +Instead, these commands are available (additions from ht's mail-extras.el +indicated by *: + +. Move point to front of this message (same as \\[beginning-of-buffer]). +SPC Scroll to next screen of this message. +DEL Scroll to previous screen of this message. +n Move to Next non-deleted message. +p Move to Previous non-deleted message. +M-n Move to Next message whether deleted or not. +M-p Move to Previous message whether deleted or not. +> Move to the last message in Rmail file. +j Jump to message specified by numeric position in file. +M-s Search for string and show message it is found in. +d Delete this message, move to next nondeleted. +C-d Delete this message, move to previous nondeleted. +u Undelete message. Tries current message, then earlier messages + till a deleted message is found. +e Expunge deleted messages. +s Expunge and save the file. +q Quit Rmail: expunge, save, then switch to another buffer. +C-x C-s Save without expunging. +g Move new mail from system spool directory or mbox into this file. +m Mail a message (same as \\[mail-other-window]). +c Continue composing outgoing message started before. +r Reply to this message. Like m but initializes some fields. +R * Like r, but reply to originator only. +f Forward this message to another user. +F * like f, but assumes message is \"failed mail\" for re-sending +o Output this message to an Rmail file (append it). +C-o Output this message to a Unix-format mail file (append it). +M * Output this message to a file, + in format determined by extension (babyl for RMAIL/msg for Unix). +B * Write the body of the message to a file, leaving a pointer +H * Print the message (same as \\<global-map>\\[print-buffer]).\\<rmail-mode-map> +i Input Rmail file. Run Rmail on that file. +a Add label to message. It will be displayed in the mode line. +k Kill label. Remove a label from current message. +C-M-n Move to Next message with specified label + (label defaults to last one specified). + Standard labels: filed, unseen, answered, forwarded, deleted. + Any other label is present only if you add it with `a'. +C-M-p Move to Previous message with specified label +h, C-M-h Show headers buffer, with a one line summary of each message. +l, C-M-l Like h only just messages with particular label(s) are summarized. +C-M-r Like h only just messages with particular recipient(s) are summarized. +t Toggle header, show Rmail header if unformatted or vice versa. +w Edit the current message. C-c C-c to return to Rmail. +W * Edit the subject field. C-c C-c to move the message to the Diary. +D * Update the Diary. + +Messages for the diary (see also \\[describe-mode] in rmail-summary mode +or \\[describe-function] rmail-summary-mode) should have a subject field +which begins with the date and optional time of the event described therein. +These must be in the form + d m y t +where d is one or two digits for the day, +m is either the full month name or the first three letters thereof, +y is two digits for the year, +and t, if present, is 4 digits for the time, +thus for example + 31 Jun 91 1530 +") + (remove-hook 'rmail-mode-hook 'rmail-mode-fun1)) + +(defun rmail-mode-fun2 () + "always run in RMAIL mode" + (setq case-fold-search t)) + +(defun reply-w/o-cc () + "Reply as r, but without sending to other recipients" + (interactive) + (rmail-reply t)) + +(defun rmht-output (&optional file-name gnus) + "Move to a file, determining format by extension (babyl/msg)" + (interactive) + (if (not file-name) + (setq file-name (car (get-move-file-name)))) + (if (string-match "\\.g?[zZ]$" file-name) + (let ((clean-file-name (substring file-name 0 (match-beginning 0))) + there) + (if (setq there (get-file-buffer clean-file-name)) + nil + (save-window-excursion (rmail clean-file-name) + (setq there + (get-file-buffer clean-file-name)))) + (rmht-output clean-file-name gnus) + (if rmht-always-recompress + (save-excursion + (set-buffer there) + (save-buffer)) + (if (not rmht-allow-autosave) + (save-excursion + (set-buffer there) + (auto-save-mode -1))))) + (setq file-name (expand-file-name file-name)) + (save-excursion + (if (string-match "\\.babyl$" file-name) + (if gnus + (gnus-output-to-rmail file-name) + (rmail-output-to-rmail-file file-name 1)) + (if (string-match "\\.msg$" file-name) + (if (or (get-file-buffer file-name) + (file-exists-p file-name) + (yes-or-no-p + (concat "\"" file-name "\" does not exist, create it? "))) + (rmail-output file-name 1) + (error "Output file does not exist")) + (error "not a valid mail file: %s" file-name)))) + (setq ht-last-file file-name) + (if (not gnus) (ht-rmail-delete-forward)))) + +(defun get-move-file-name () + "get a file name for moving a message to" + (list (read-file-name + (concat "Output message to file: (default " + (file-name-nondirectory ht-last-file) + ") ") + (file-name-directory ht-last-file) + ht-last-file))) + +(defun re-post-failed-mail () + "try to salvage the original from failed mail and prepare to resend it" + (interactive) + (rmail-forward nil) + (let ((top (point)) + subjp textp) + (re-search-forward "^Subject: ") + (kill-line nil) + (setq subjp (point)) + (re-search-forward "^From: ") ; the bouncer + (re-search-forward "^From: ") ; should be us + (re-search-forward "^Subject: ") + (kill-line nil) + (save-excursion (goto-char subjp) + (yank)) + (beginning-of-line 3) + (setq textp (point)) + (goto-char top) + (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$")) + (beginning-of-line 2) + (delete-region (point) textp) + (goto-char top))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; mods and fixes for mail summaries ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(add-hook 'rmail-summary-mode-hook 'rmail-summary-mode-fun1) + +;; run the first time we make a summary window +(defun rmail-summary-mode-fun1 () + "install ht's mods" + (define-key rmail-summary-mode-map "r" 'rms-reply-w-cc) + (define-key rmail-summary-mode-map "R" 'rms-reply-w/o-cc) + (define-key rmail-summary-mode-map "s" 'diary-save) + (define-key rmail-summary-mode-map "m" 'rms-move) + (define-key rmail-summary-mode-map "d" 'rms-delete) + (define-key rmail-summary-mode-map "h" 'rms-hardcopy) + (define-key rmail-summary-mode-map " " 'ht-rmailsum-scroll-msg-up) + (define-key rmail-summary-mode-map "\177" 'ht-rmailsum-scroll-msg-down) + ;; fix the doc string + (repl-comment 'rmail-summary-mode + "Major mode in effect in Rmail summary buffer. +A subset of the Rmail mode commands are supported in this mode. +As commands are issued in the summary buffer the corresponding +mail message is displayed in the rmail buffer. +Modifications from ht's mail-extras.el indicated with *: + +n Move to next undeleted message, or arg messages. +p Move to previous undeleted message, or arg messages. +C-n Move to next, or forward arg messages. +C-p Move to previous, or previous arg messages. +j Jump to the message at the cursor location. +d Delete the message at the cursor location and move to next message. +u Undelete this or previous deleted message. +q Quit Rmail. +x Exit and kill the summary window. +space * If cursor is on line of current message, + scroll message window forward. Otherwise, jump to indicated message. +delete * same as space, but scrolls backward. +r * Same as r in rmail window. Reply to current message. +R * Same as R in rmail window. Reply to current message, originator only. +s * Update and save the rmail file, and re-summarise. Re-sorts if Diary. +m * Same as M in rmail window. Moves message to file. +h * Same as H in rmail window. Prints message on line printer. + +Entering this mode calls value of hook variable rmail-summary-mode-hook. + +If the file summarised is called by the name given in ht-diary-file-name, +which defaults to diary.babyl, +then the summary will be called *Diary*, sorted in date order and +formated in a special way. + +Messages in the diary should have a subject field +which begins with the date and optional time of the event described therein. +These must be in the form + d m y t +where d is one or two digits for the day, +m is either the full month name or the first three letters thereof, +y is two digits for the year, +and t, if present, is 4 digits for the time, +thus for example +Subject: 31 Jun 91 1530 Hades freezing ceremony followed by champagne reception +") + (remove-hook 'rmail-summary-mode-hook 'rmail-summary-mode-fun1)) + +(defun rmht-sum-reply (sender-only) + "reply to current message" + (rmail-summary-goto-msg) + (pop-to-buffer rmail-buffer) + (rmail-reply sender-only) + (switch-to-buffer rmail-summary-buffer) + (switch-to-buffer "*mail*") +) + +(defun rms-reply-w-cc () + "Do r in RMAIL - reply to everybody" + (interactive) + (rmht-sum-reply nil)) + +(defun rms-reply-w/o-cc () + "Do R in RMAIL - reply to sender only" + (interactive) + (rmht-sum-reply t)) + +(defun rms-save () + "expunge deleted messages, save RMAIL file and re-display headers" + (interactive) + (pop-to-buffer rmail-buffer) + (rmail-expunge-and-save) + (rmail-summary)) + +(defun rms-delete () + "delete current and move down to next in summary buffer" + (interactive) + (rmail-summary-goto-msg) + (save-excursion + (rmail-summary-delete-forward nil)) + (rms-del)) + +(defun rms-move () + "Move to a file, mode determined by file extension (babyl/msg)" + (interactive) + (rmail-summary-goto-msg) + (save-excursion + (set-buffer rmail-buffer) + (rmht-output)) + (rms-del)) + +(defun rms-del () + "mark current summary line as deleted and move down" + (let ((buffer-read-only nil)) + (skip-chars-forward " ") + (skip-chars-forward "[0-9]") + (delete-char 1) + (insert "D")) + (forward-line 1)) + +(defun rms-hardcopy () + "hardcopy the current message" + (interactive) + (pop-to-buffer rmail-buffer) + (print-buffer) + (pop-to-buffer rmail-summary-buffer)) + + +;; fix interpretation of SPACE and DEL in summary windows to +;; 1) scroll the right window regardless of how many panes are up; +;; 2) go to the message associated with the current line if not already there, +;; a la gnus, for instance + +(defun ht-rmailsum-normalise () + "if not already showing message named on current line, go to it & return t" + (beginning-of-line) + (let ((current-msg-num (cdr (assoc 'rmail-current-message + (buffer-local-variables + (or rmail-buffer + (error + "not in a summary buffer")))))) + (line-message-num (string-to-int + (buffer-substring + (point) + (min (point-max)(+ 5 (point))))))) + (if (= current-msg-num line-message-num) + nil + (rmail-summary-goto-msg line-message-num) + t))) + +(defun ht-rmailsum-scroll-msg-up (&optional dist) + "goto other message or scroll current message forward" + (interactive "P") + (if (ht-rmailsum-normalise) + nil + (pop-to-buffer rmail-buffer) + (scroll-up dist) + (pop-to-buffer rmail-summary-buffer))) + +(defun ht-rmailsum-scroll-msg-down (&optional dist) + "goto other message or scroll current message backward" + (interactive "P") + (if (ht-rmailsum-normalise) + nil + (pop-to-buffer rmail-buffer) + (scroll-down dist) + (pop-to-buffer rmail-summary-buffer))) + +(autoload 'edit-and-move-to-diary "diary") +(autoload 'update-diary "diary") +(autoload 'diary-save "diary") + +;; unfortunately, gnus mucks about with the buffers before calling +;; mail, so we have to intervene to make the about-to-mail-hook work right + +(defun ht-Subject-mode-fun () + "fix the map to save window state" +; (define-key gnus-summary-mode-map "r" 'ht-Subject-mail-reply) +; (define-key gnus-summary-mode-map "R" 'ht-Subject-mail-reply-with-original) +; (define-key gnus-summary-mode-map "m" 'ht-Subject-mail-other-window) + (define-key gnus-summary-save-map "M" 'ht-Subject-move) + (remove-hook 'gnus-summary-mode-hook 'ht-Subject-mode-fun)) + +(add-hook 'gnus-summary-mode-hook 'ht-Subject-mode-fun) + +(defun ht-Subject-mail-reply (yank) + "Runs about-to-mail-hook, then calls gnus-summary-mail-reply" + (interactive "P") + (require 'sendmail) + (run-hooks 'about-to-mail-hook) + (let (about-to-mail-hook) + (gnus-summary-reply yank))) + +(defun ht-Subject-mail-reply-with-original () + "Runs about-to-mail-hook, then calls gnus-summary-mail-reply-with-original" + (interactive) + (require 'sendmail) + (run-hooks 'about-to-mail-hook) + (let (about-to-mail-hook) + (gnus-summary-reply-with-original))) + +(defun ht-Subject-mail-other-window () + "Runs about-to-mail-hook, then calls gnus-summary-mail-other-window" + (interactive) + (require 'sendmail) + (run-hooks 'about-to-mail-hook) + (let (about-to-mail-hook) + (gnus-summary-mail-other-window))) + +(defun ht-Subject-move () + "Move article to a file, mode determined by file extension (babyl/msg)" + (interactive) + (gnus-summary-select-article) + (save-excursion + (set-buffer gnus-article-buffer) + (rmht-output nil t))) + + +(defun ht-write-body-to-file (file) + "Write the body of the message to a file and replace it with a pointer" + (interactive "FFile to save in: ") + (goto-char (point-min)) + (or (search-forward "\n\n" nil t) + (error "Can't find text")) + (write-region (point)(point-max) file) + (rmail-edit-current-message) + (delete-region (point)(point-max)) + (insert "\n>> " file "\n") + (rmail-cease-edit) + (rmht-output)) + +(defun extract-attachment () + "extract attachments from a multi-part mime message" + (interactive) + (rmail-toggle-header) + (mime/viewer-mode) + (let ((pt 0)) + (while (progn + (mime-viewer/next-content) + (and + (equal "*Preview-RMAIL*" (buffer-name (current-buffer))) + (not (= pt (point))))) + (setq pt (point)) + (if (looking-at "^\\[[0-9]* [^ ]+ <") + (mime-viewer/extract-content)))) + (if (not (equal "*Preview-RMAIL*" (buffer-name (current-buffer)))) + ;; we fell off the end + (rmail-previous-undeleted-message 1)) + (kill-buffer "*Preview-RMAIL*") + ) + +;; see message-citation-line-function in message.el +(defun safe-citation () + (use-text-not-html) + (when message-reply-headers + (let ((from (mail-header-from message-reply-headers))) + (cond ((string-match "^\"?\\([^\"]*\\)\"? <.*>$" from) + (insert (match-string 1 from) " writes:\n\n")) + ((string-match "^\\([^<@]*\\)@" from) + (insert (match-string 1 from) " writes:\n\n")) + (t + (insert "[anon] writes:\n\n")))))) + +(defun use-text-not-html (&optional clear) + (when (and (if clear (looking-at "<html") + (looking-at "> <html")) + (bufferp (get-buffer "*Shell Command Output*"))) + ;; replace HTML only with result of my HTML filter + (delete-region (point)(mark t)) + (insert-buffer "*Shell Command Output*") + (when (looking-at "piping") + (kill-entire-line) + (indent-rigidly (point) (mark t) -3) + (if (not clear) + (submerge-region (point) (mark t))))) + ) + +(setq message-citation-line-function (function safe-citation)) + +;(load-library "mailcrypt") ; provides "mc-setversion" +;(mc-setversion "gpg") ; for PGP 2.6 (default); also "5.0" and "gpg" +;(autoload 'mc-install-write-mode "mailcrypt" nil t) +;(autoload 'mc-install-read-mode "mailcrypt" nil t) +;(add-hook 'mail-mode-hook 'mc-install-write-mode) +;(add-hook 'gnus-summary-mode-hook 'mc-install-read-mode) +;(add-hook 'message-mode-hook 'mc-install-write-mode) +;(add-hook 'news-reply-mode-hook 'mc-install-write-mode) +;(setq mc-passwd-timeout 6000) +;;; Key server at Cambridge University (Cambridge, England) +;(setq mc-pgp-fetch-methods '(mc-pgp-fetch-from-keyrings +; mc-pgp-fetch-from-http)) +;(require 'pgg) +;(add-hook 'message-send-hook 'my-sign-message) +(setq hack-yn-map (copy-keymap query-replace-map)) +(define-key hack-yn-map 'return 'act) + +(defun my-sign-message () + (goto-char (point-min)) + (unless + (or + (re-search-forward "<#\\(part\\|mml\\) " nil t) + ; signing attachments doesn't seem + ; to work well + (search-forward "\n-- \nHenry S. Thompson, Central Edinburgh LM" nil t) + ; Don't sign Quaker mail + ) + (let* ((headers (mail-header-extract-no-properties)) + (cc (mail-header 'cc)) + (to (mail-header 'to))) + (if (and to + (not (string-match "htcalendar[@]markup\.co\.uk" to)) + (not (string-match "^ht$" to)) + (or + (string-match "w3.org" to) + (and cc (string-match "w3.org" cc)) + (let ((query-replace-map hack-yn-map)) + (y-or-n-p "Sign message? ")))) + (mml-secure-message-sign-pgp)))))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/shared/mdn-extras.el Sat Oct 07 12:43:14 2023 +0100 @@ -0,0 +1,167 @@ +;; Last edited: Thu Jun 11 14:04:02 1992 +;; stub for henry's mail reading and diary maintenance tools +;; Copyright (C) 1990 Henry S. Thompson +;; Edit history: made diary-setup do (update-default-diary nil) instead of t + +;; 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. + +(provide 'mdn-extras) + +;; get my sendmail, on way or another + +(if (featurep 'sendmail) + ;; already loaded - overwrite + (site-caseq + (parc (load "~hthompso/emacs/shared/sendmail")))) + +(setq command-switch-alist + (nconc command-switch-alist '(("-m" . ht-mail-setup) + ("-mail" . ht-mail-setup) + ("-d" . ht-diary-setup) + ("-diary" . ht-diary-setup)))) + +(setq command-switch-alist + (nconc command-switch-alist '(("-n" . ht-news-setup) + ("-news" . ht-news-setup)))) + +(autoload 'gnus "gnus" "read news" t) + +(defvar ht-default-config nil "saved window configuration after startup") +(defvar ht-back-config (current-window-configuration) + "saved window configuration from before ^Cw/^C^w") + +(defun ht-mail-setup (&optional arg) + "set up my mail reading and do it" + (interactive) + (require 'mail-extras) ; mail stuff + (if (featurep 'gnus) ; in case gnus is around + (split-window-vertically)) + (rmail) + (setq ht-default-config (current-window-configuration))) + +(defun ht-diary-setup (&optional arg) + "diary setup" + (interactive) + (require 'diary) + (update-default-diary nil) ; set up standard config. + (if (featurep 'rmail) + (if (featurep 'gnus) ; in case gnus is around + (progn (other-window 1) + (split-window) + (other-window 1) + (switch-to-buffer (get-file-buffer rmail-file-name))) + (switch-to-buffer (get-file-buffer rmail-file-name)) + (other-window 1) + (split-window) + (other-window 1) + (switch-to-buffer (save-excursion (set-buffer (get-file-buffer + ht-diary-file-name)) + rmail-summary-buffer)) + (other-window 1))) + (setq ht-default-config (current-window-configuration))) + +(defun ht-news-setup (&optional arg) + "set up my GNUS and do it" + (interactive) + (require 'my-news) ; GNUS stuff + (if (featurep 'rmail) + (split-window-vertically)) + (gnus) + (setq ht-default-config (current-window-configuration)) + (unless (gnuserv-running-p) + (gnuserv-start)) + ) + +(defun default-config () + "restore screen to default config" + (interactive) + (setq ht-back-config (current-window-configuration)) + (set-window-configuration ht-default-config)) + +(defun back-config () + (interactive) + (set-window-configuration (prog1 ht-back-config + (setq ht-back-config + (current-window-configuration))))) + +(global-set-key "\C-cw" 'default-config) + +(global-set-key "\C-c\C-w" 'back-config) + +(setq mail-custom-fields + '(("To" (fill-addr-field (local-field-var to "")) "\C-t") + ("Subject" (ht-subj-with-reply) "\C-s"))) + +(defun ht-subj-with-reply () + (let ((subj (local-field-var subject "")) + (irt (local-field-var in-reply-to))) + (if (and in-reply-to + (not (string-match "^Re:" subj))) + (concat "Re: " subj) + subj))) + + +;;; Henry's special double update hack + +(add-hook 'rmail-mode-hook 'rmail-mode-fun3) + +(defun get-mail-news-and () + "update both if both present" + (interactive) + (rmail-get-new-mail) + (let (nw) + (setq nw (get-buffer "*Newsgroup*")) + (if nw + (save-window-excursion + (pop-to-buffer nw) + (gnus-group-get-new-news))))) + +;;; rescued from old rmail +;;; hacked to cope with differences between e19 and lucid +(defun ht-rmail-delete-forward (&optional backward) + "Delete this message and move to next nondeleted one. +Deleted messages stay in the file until the \\[rmail-expunge] command is given. +With prefix argument, delete and move backward. +If there is no nondeleted message to move to +in the preferred or specified direction, move in the other direction." + (interactive "P") + (rmail-set-attribute "deleted" t) + (if (or + (string-match "Lucid" emacs-version) + (and (boundp 'emacs-minor-version) + (> emacs-minor-version 19) ; not sure where pblm was fixed + ; certainly by 28 + )) + (if (not (rmail-next-undeleted-message (if backward -1 1))) + (if (rmail-previous-undeleted-message (if backward -1 1)) + (message "") ; override the stupid one + )) + (if (rmail-next-undeleted-message (if backward -1 1)) + (if (not (rmail-previous-undeleted-message (if backward -1 1))) + (message ""))))) + +(defun rmail-mode-fun4 () + (setq buffer-auto-save-file-name nil) + (make-variable-buffer-local 'backup-inhibited) + (setq backup-inhibited t)) + +(defun rmail-mode-fun3 () + (define-key rmail-mode-map "G" 'get-mail-news-and) + (define-key rmail-mode-map "d" 'ht-rmail-delete-forward) + (remove-hook 'rmail-mode-hook 'rmail-mode-fun3) + (add-hook 'rmail-mode-hook 'rmail-mode-fun4 t))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/shared/motion.el Sat Oct 07 12:43:14 2023 +0100 @@ -0,0 +1,319 @@ +;;; Copyright (C) 1990 Alan M. Carroll +;;; +;;; This file is for use with Epoch, a modified version of GNU Emacs. +;;; Requires Epoch 3.2 or later. +;;; +;;; This code is distributed in the hope that it will be useful, +;;; bute WITHOUT ANY WARRANTY. No author or distributor accepts +;;; responsibility to anyone for the consequences of using this code +;;; or for whether it serves any particular purpose or works at all, +;;; unless explicitly stated in a written agreement. +;;; +;;; Everyone is granted permission to copy, modify and redistribute +;;; this code, but only under the conditions described in the +;;; GNU Emacs General Public License, except the original author nor his +;;; agents are bound by the License in their use of this code. +;;; (These special rights for the author in no way restrict the rights of +;;; others given in the License or this prologue) +;;; A copy of this license is supposed to have been given to you along +;;; with Epoch 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. +;;; +(provide 'motion) +(require 'button) +(require 'mouse) +;;; +;;; version tohandle mouse stuff +;;; +;;; [cjl] now use primitive epoch::move-button when possible. +;;; +(defvar horizontal-drag-inc 5 "Number of columns to scroll when the pointer is to the left or right of the window") +(defvar vertical-drag-inc 2 "Number of lines to scroll when the pointer is above or below the edge of the window") + +(defvar mouse::downp nil "State variable for mouse dragging internals") +(defvar mouse::last-point -1 "Last location of a motion event") + +(make-variable-buffer-local 'drag-button) +(make-variable-buffer-local 'mouse-down-marker) + +(defvar motion::attribute (reserve-attribute) "Attribute for drag buttons") +(setq epoch::buttons-modify-buffer nil) + +(defvar motion::style nil "style used by drag buttons") + +;; +;; Set window-setup-hook to call motion::init(), which sets default +;; style for button dragging +;; +(epoch-add-setup-hook 'motion::init) +(defun motion::init () + (and (not motion::style) (setq motion::style (make-style))) + (set-style-foreground motion::style (foreground)) + (set-style-background motion::style (background)) + (set-style-underline motion::style (foreground)) + (set-attribute-style motion::attribute motion::style) + ;; enable the handler + (push-event 'motion 'motion::handler) + ;; set up hints on all the current screens + (dolist (s (screen-list t)) (epoch::set-motion-hints t s)) + ;; enable hints on future screens + (push '(motion-hints t) epoch::screen-properties) + ) + +(setq-default drag-button nil) +(setq-default mouse-down-marker nil) + +;;; ------------------------------------------------------------------------ +(defun set-mouse-marker (&optional location) + (if (null mouse-down-marker) + (setq mouse-down-marker (make-marker)) + ) + (set-marker mouse-down-marker (or location (point))) +) +;;; -------------------------------------------------------------------------- +;;; generic arg is a list of ( POINT BUFFER WINDOW SCREEN ) +;;; +(defun end-mouse-drag (arg) + (setq mouse::last-point -1) ;always do this cleanup + (when mouse::downp + (setq mouse::downp nil) + (mouse::copy-button drag-button) + (if (buttonp drag-button) + (if (<= (point) (button-start drag-button)) + (progn + (push-mark (button-end drag-button) t) + (goto-char (button-start drag-button)) + ) + ;; ELSE point is past drag button start + (progn + (push-mark (button-start drag-button) t) + (goto-char (button-end drag-button)) + ) + ) + ) + ) +) + +(defun start-mouse-drag (arg) + (when arg + (setq mouse::downp 'start) + (mouse::set-point arg) + (set-mouse-marker) + (setq mouse::last-point (point)) + (if drag-button + (progn (delete-button drag-button) (setq drag-button nil) ) + ) + ) +) + +(defun extend-mouse-drag (arg) + (setq mouse::downp 'extend) + (let + ( + (m1 (and drag-button (button-start drag-button))) + (m2 (and drag-button (button-end drag-button))) + (spot (car arg)) ;point of the mouse click. + ) + (if (null m1) (setq m1 0)) + (if (null m2) (setq m2 0)) + (cond + ((or (null drag-button) (null mouse-down-marker)) + (setq drag-button (add-button (point) spot motion::attribute) ) + (set-mouse-marker) + ) + ((<= spot m1) + (setq drag-button (move-button drag-button spot m2) ) + (set-mouse-marker m2) + ) + ((>= spot m2) + (setq drag-button (move-button drag-button m1 spot) ) + (set-mouse-marker m1) + ) + ((<= mouse-down-marker spot) + (setq drag-button (move-button drag-button m1 spot) ) + (set-mouse-marker m1) + ) + (t + (setq drag-button (move-button drag-button spot m2) ) + (set-mouse-marker m2) + ) + ) + (epoch::redisplay-screen) + (setq mouse::last-point (point)) + ) +) + +;;; ------------------------------------------------------------------------ +;;; Define the handler +;;; +(defun motion::handler (type value scr) + (if (null mouse-down-marker) (set-mouse-marker)) + (if (and (boundp 'mouse::downp) mouse::downp) + (mouse-sweep-update) + ) +) +;;; +(defun mouse-sweep-update() + (let* + (x y pos drag-m1 drag-m2 pnt orig-m1 orig-m2 + (out-of-bounds t) + (epoch::event-handler-abort nil) + (w (selected-window)) + (w-edges (window-edges w)) + (left (car w-edges)) + (top (elt w-edges 1)) + (right (- (elt w-edges 2) (+ 2 left))) + (bottom (- (elt w-edges 3) (+ 2 top))) + ever + ) + (if drag-button + (progn (setq orig-m1 (or (button-start drag-button) -1)) + (setq orig-m2 (or (button-end drag-button) -1))) + (progn (setq orig-m1 mouse-down-marker) + (setq orig-m2 (point)))) + (while + (and + out-of-bounds + (setq pos (query-mouse)) + (/= 0 (logand mouse-any-mask (elt pos 2))) + ) + ;;convert to window relative co-ordinates + (setq x (- (car pos) left)) + (setq y (- (elt pos 1) top)) + (setq out-of-bounds + (not (and (<= 0 y) (<= y bottom) (<= 0 x) (<= x right))) + ) + + ;; scrolling conditions + (condition-case errno + (progn + (if (< y 0) (scroll-down vertical-drag-inc)) + (if (> y bottom) (scroll-up vertical-drag-inc)) + ) + (error ) ;nothing, just catch it + ) + (if (< x 0) (scroll-right horizontal-drag-inc)) + (if (> x right) (scroll-left horizontal-drag-inc)) + (setq y (max 0 (min bottom y))) + (setq x (max 0 (min right x))) + + (setq pnt (car (epoch::coords-to-point (+ x left) (+ y top)))) + (when (/= mouse::last-point pnt) + (if (> mouse-down-marker pnt) + (progn + (setq drag-m1 pnt) + (setq drag-m2 (marker-position mouse-down-marker)) + ) + (progn + (setq drag-m1 (marker-position mouse-down-marker)) + (setq drag-m2 pnt) + ) + ) + ;; don't move for trivial reasons + (when (or ever (/= drag-m1 orig-m1) (/= drag-m2 orig-m2)) + (setq ever t) + (if (not drag-button) + (setq drag-button + (add-button mouse-down-marker + (point) motion::attribute ) + ) + ) + (move-button drag-button drag-m1 drag-m2) + (epoch::redisplay-screen) + ) + ) + (setq mouse::last-point pnt) + ) + ) +) +;;; ------------------------------------------------------------------------ +;;; Code for selecting lines using motion events. Assumes that the line is +;;; left unmarked on button up +;;; +(defvar mouse::line-button nil "Button for selected line") +;;; +(defun mouse-select-line-start (arg) + (mouse::set-point arg) ;go there + (setq mouse::last-point (point)) + (let ( bol ) + (save-excursion + (beginning-of-line) + (setq bol (point)) + (end-of-line) + (setq mouse::line-button (add-button bol (point) motion::attribute)) + ) + ) + (push-event 'motion 'mouse-select-line-update) +) +;;; +(defun mouse-select-line-end (arg) + (setq mouse::last-point -1) + (when mouse::line-button (delete-button mouse::line-button)) + (pop-event 'motion) +) +;;; +(defun mouse-select-line-update (type value scr) + (let* + ( + y + pos + bol + (out-of-bounds t) + (epoch::event-handler-abort nil) + (w-edges (window-edges (selected-window))) + (top (elt w-edges 1)) + (bottom (- (elt w-edges 3) (+ 2 top))) + max-vscroll + ) + (while + (and + out-of-bounds + (setq pos (query-mouse)) + (/= 0 (logand mouse-any-mask (elt pos 2))) + ) + ;;convert to window relative co-ordinates + (setq y (- (elt pos 1) top)) + (setq out-of-bounds (not (and (<= 0 y) (<= y bottom)))) + + ;; Scrolling hard, because of possibly shrink-wrapped windows. + ;; set max-vscroll to be the most we could scroll down and not have + ;; empty lines at the bottom + (save-excursion + (move-to-window-line bottom) ;go to the last line in the window + (setq max-vscroll + (- vertical-drag-inc (forward-line vertical-drag-inc)) + ) + (if (and (> max-vscroll 0) (eobp) (= 0 (current-column))) + (decf max-vscroll) + ) + ) + (condition-case errno + (progn + (if (< y 0) (scroll-down vertical-drag-inc)) + (if (> y bottom) (scroll-up (min max-vscroll vertical-drag-inc))) + ) + ;; CONDITIONS + (error) ;nothing, just want to catch it + ) + (setq y (max 0 (min bottom y))) + + ;;move to the new point + (move-to-window-line y) + (beginning-of-line) (setq bol (point)) + (end-of-line) + (when (/= mouse::last-point (point)) + (move-button mouse::line-button bol (point)) + (epoch::redisplay-screen) + ) + (setq mouse::last-point (point)) + ) + ) +) +;;; -------------------------------------------------------------------------- +;;; install all our variouse handlers +(global-set-mouse mouse-left mouse-down 'start-mouse-drag) +(global-set-mouse mouse-left mouse-up 'end-mouse-drag) +(global-set-mouse mouse-right mouse-down 'extend-mouse-drag) +(global-set-mouse mouse-right mouse-up 'end-mouse-drag) +(global-set-mouse mouse-middle mouse-down 'mouse::paste-cut-buffer)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/shared/motion4.el Sat Oct 07 12:43:14 2023 +0100 @@ -0,0 +1,385 @@ +;;; Copyright (C) 1991 Christopher J. Love +;;; +;;; This file is for use with Epoch, a modified version of GNU Emacs. +;;; Requires Epoch 4.0 or later. +;;; +;;; This code is distributed in the hope that it will be useful, +;;; bute WITHOUT ANY WARRANTY. No author or distributor accepts +;;; responsibility to anyone for the consequences of using this code +;;; or for whether it serves any particular purpose or works at all, +;;; unless explicitly stated in a written agreement. +;;; +;;; Everyone is granted permission to copy, modify and redistribute +;;; this code, but only under the conditions described in the +;;; GNU Emacs General Public License, except the original author nor his +;;; agents are bound by the License in their use of this code. +;;; (These special rights for the author in no way restrict the rights of +;;; others given in the License or this prologue) +;;; A copy of this license is supposed to have been given to you along +;;; with Epoch 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. +;;; +;;; $Revision: 1.2 $ +;;; $Source: /home/user5/ht/emacs/shared/RCS/motion4.el,v $ +;;; $Date: 1992/03/18 21:44:10 $ +;;; $Author: ht $ +;;; +;;; motion.el - provide draggin/hi-lighting of primary selection +;;; +;;; Original version by Alan Carroll +;;; Epoch 4.0 modifications by Chris Love +;;; Abort-isearch and other ideas from Ken Laprade and others. +;;; +(provide 'motion) +(redisplay-screen) ; fix epoch4.0a race bug? +(require 'zone) +(require 'mouse) + +;;; ------------------------------------------------------------------------ +;;; Interface values +(defvar horizontal-drag-inc 5 + "Number of columns to scroll when the pointer is to the left or right of the window") +(defvar vertical-drag-inc 2 + "Number of lines to scroll when the pointer is above or below the edge of the window") + +(defvar mouse::downp nil "State variable for mouse dragging internals") +(defvar mouse::last-point -1 "Last location of a motion event") + +(setq epoch::zones-modify-buffer nil) +(defvar motion::style nil "style used by drag zones") + +(defvar drag-zone nil + "Epoch zone to be used for hilighting selected text region." +) +(setq-default drag-zone nil) +(setq-default mouse-down-marker nil) + +;;; ------------------------------------------------------------------------ +;;; Set window-setup-hook to call motion::init(), which sets default +;;; style for zone dragging. Default style is underlining; can be changed +;;; in .emacs file. +(epoch-add-setup-hook 'motion::init) + +(defun motion::init () + (and (not motion::style) (setq motion::style (make-style))) + (set-style-foreground motion::style (foreground)) + (set-style-background motion::style (background)) + (set-style-underline motion::style (foreground)) + ;; enable the handler + (push-event 'motion 'motion::handler) + ;; set up hints on all the current screens + (dolist (s (screen-list t)) (epoch::set-motion-hints t s)) + ;; enable hints on future screens + (push '(motion-hints t) epoch::screen-properties) + ) + +;;; ------------------------------------------------------------------------ +(defun set-mouse-marker (&optional location) + (if (null mouse-down-marker) + (setq mouse-down-marker (make-marker)) + ) + (set-marker mouse-down-marker (or location (point))) +) + +;;; -------------------------------------------------------------------------- +;;; Functions to provide dragging & hilighting. +;;; arg is a list of ( POINT BUFFER WINDOW SCREEN ) +(defun end-mouse-drag (arg) + (setq mouse::last-point -1) ;always do this cleanup + (when mouse::downp + (setq mouse::downp nil) + (mouse::copy-zone drag-zone) + (let ( + (s (and drag-zone (zone-start drag-zone))) + (e (and drag-zone (zone-end drag-zone))) + ) + (if (null s) (setq s 1)) + (if (null e) (setq e 1)) + (if (zonep drag-zone) + (if (<= (point) s) + (progn + (push-mark e t) + (goto-char s) + ) + ;; ELSE point is past drag zone start + (progn + (push-mark s t) + (goto-char e) + ) + ) + ) + ) + ) +) + +(defun start-mouse-drag (arg) + (when arg + (setq mouse::downp 'start) +; (message "%s" arg) + (mouse::set-point arg) + (abort-isearch) + (set-mouse-marker) + (setq mouse::last-point (point)) + (if drag-zone + (progn + (message "ddz") + (delete-zone drag-zone) + (setq drag-zone nil) + (redisplay-screen) + ) + ) + ) +) + +(defun extend-mouse-drag (arg) + (setq mouse::downp 'extend) + (let + ( + (m1 (and drag-zone (zone-start drag-zone))) + (m2 (and drag-zone (zone-end drag-zone))) + (spot (car arg)) ;point of the mouse click. + ) + (if (null m1) (setq m1 0)) + (if (null m2) (setq m2 0)) + (cond + ((or (null drag-zone) (null mouse-down-marker)) + (setq drag-zone (add-zone (point) spot motion::style) ) + (set-zone-transient drag-zone t) + (set-mouse-marker) + ) + ((<= spot m1) + (setq drag-zone (move-zone drag-zone spot m2) ) + (set-mouse-marker m2) + ) + ((>= spot m2) + (setq drag-zone (move-zone drag-zone m1 spot) ) + (set-mouse-marker m1) + ) + ((<= mouse-down-marker spot) + (setq drag-zone (move-zone drag-zone m1 spot) ) + (set-mouse-marker m1) + ) + (t + (setq drag-zone (move-zone drag-zone spot m2) ) + (set-mouse-marker m2) + ) + ) + (epoch::redisplay-screen) + (setq mouse::last-point (point)) + ) +) + +;;; ------------------------------------------------------------------------ +;;; Define the handler for dragging, etc. +(defun motion::handler (type value scr) + (if (null mouse-down-marker) (set-mouse-marker)) + (if (and (boundp 'mouse::downp) mouse::downp) + (mouse-sweep-update) + ) +) + +;;; +(defun mouse-sweep-update() + (let* + ( + drag-m1 + drag-m2 + pnt + pos + x + y + (w (selected-window)) + (out-of-bounds t) + (epoch::event-handler-abort nil) + (w-edges (window-pixedges w)) + (left (car w-edges)) + (top (elt w-edges 1)) + (right (- (elt w-edges 2) left 1)) + (bottom (- (elt w-edges 4) top 1)) + ) + (while + (and + out-of-bounds + (setq pos (query-pointer)) + (/= 0 (logand mouse-any-mask (elt pos 2))) + ) + ;;convert to window relative co-ordinates + (setq x (- (car pos) left)) + (setq y (- (elt pos 1) top)) + (setq out-of-bounds + (not (and (<= 0 y) (<= y bottom) (<= 0 x) (<= x right))) + ) + ;; scrolling conditions + (condition-case errno + (progn + (if (< y 0) (scroll-down vertical-drag-inc)) + (if (> y bottom) (scroll-up vertical-drag-inc)) + ) + (error ) ;nothing, just catch it + ) +;; Disable horizontal scrolling. +; (if (< x left) (scroll-right horizontal-drag-inc)) +; (if (> x right) (scroll-left horizontal-drag-inc)) + (setq y (max 1 (min bottom y))) + (setq x (max 0 (min right x))) + (setq pnt (car (epoch::coords-to-point (+ x left) (+ y top)))) + (when (/= mouse::last-point pnt) + (if (> mouse-down-marker pnt) + (progn + (setq drag-m1 pnt) + (setq drag-m2 (marker-position mouse-down-marker)) + ) + (progn + (setq drag-m1 (marker-position mouse-down-marker)) + (setq drag-m2 (1+ pnt)) + ) + ) + ;; moved this in here so that zone won't get made if + ;; only motion is jitter within a single character + ;; this fixes a bunch of bogus (often empty) + ;; entries in the kill ring + (if drag-zone + (move-zone drag-zone drag-m1 drag-m2) + (progn (setq drag-zone + (add-zone drag-m1 drag-m2 motion::style ) + ) + (set-zone-transient drag-zone t) + ) + ) + (redisplay-screen) + ) + (setq mouse::last-point pnt) + ) + ) +) + +;;; ------------------------------------------------------------------------ +;;; Code for selecting lines using motion events. Assumes that the line is +;;; left unmarked on zone up +(defvar mouse::line-zone nil "Zone for selected line") +;;; +(defun mouse-select-line-start (arg) + (mouse::set-point arg) ;go there + (setq mouse::last-point (point)) + (let ( bol ) + (save-excursion + (beginning-of-line) + (setq bol (point)) + (end-of-line) + (setq mouse::line-zone (add-zone bol (point) motion::style)) + ) + ) + (push-event 'motion 'mouse-select-line-update) +) +;;; +(defun mouse-select-line-end (arg) + (setq mouse::last-point -1) + (when mouse::line-zone (delete-zone mouse::line-zone)) + (pop-event 'motion) +) +;;; +(defun mouse-select-line-update (type value scr) + (let* + ( + y + pos + bol + (out-of-bounds t) + (epoch::event-handler-abort nil) + (w-edges (window-pixedges (selected-window))) + (top (elt w-edges 1)) + (bottom (- (elt w-edges 4) top 1)) + max-vscroll + ) + (while + (and + out-of-bounds + (setq pos (query-pointer)) + (/= 0 (logand mouse-any-mask (elt pos 2))) + ) + ;;convert to window relative co-ordinates + (setq y (- (elt pos 1) top)) + (setq out-of-bounds (not (and (<= 0 y) (<= y bottom)))) + + ;; Scrolling hard, because of possibly shrink-wrapped windows. + ;; set max-vscroll to be the most we could scroll down and not have + ;; empty lines at the bottom + (save-excursion + (move-to-window-line bottom) ;go to the last line in the window + (setq max-vscroll + (- vertical-drag-inc (forward-line vertical-drag-inc)) + ) + (if (and (> max-vscroll 0) (eobp) (= 0 (current-column))) + (decf max-vscroll) + ) + ) + (condition-case errno + (progn + (if (< y 0) (scroll-down vertical-drag-inc)) + (if (> y bottom) (scroll-up (min max-vscroll vertical-drag-inc))) + ) + ;; CONDITIONS + (error) ;nothing, just want to catch it + ) + (setq y (max 0 (min bottom y))) + + ;;move to the new point + (move-to-window-line y) + (beginning-of-line) (setq bol (point)) + (end-of-line) + (when (/= mouse::last-point (point)) + (move-zone mouse::line-zone bol (point)) + (epoch::redisplay-screen) + ) + (setq mouse::last-point (point)) + ) + ) +) +;;; -------------------------------------------------------------------------- +;; Stolen from AMC +(defun mouse::buffer-line (marg) + "Show the line number and buffer of the mouse EVENT" + ;; marg is (point buffer window screen) + ;; Pop over to the clicked buffer + (save-excursion (set-buffer (cadr marg)) + ;; Figure out how far down the mouse point is + (let ((n (count-lines (point-min) (car marg)))) + ;; display it. Include the buffer name for good measure. + (message (format "Line %d in %s" n (buffer-name (cadr marg)))) +))) + +;; Blow out of any current isearch +(defun abort-isearch () "Abort any isearch in progress." + (condition-case err + (throw 'search-done t) + (no-catch nil))) +;;; -------------------------------------------------------------------------- +;;; install all our various handlers +(global-set-mouse mouse-left mouse-down 'start-mouse-drag) +(global-set-mouse mouse-left mouse-shift 'mouse::buffer-line) +(global-set-mouse mouse-left mouse-up 'end-mouse-drag) +(global-set-mouse mouse-right mouse-down 'extend-mouse-drag) +(global-set-mouse mouse-right mouse-up 'end-mouse-drag) +(global-set-mouse mouse-middle mouse-down 'mouse::paste-cut-buffer) + + +(defun mouse-set-spot (arg) + "Set point at mouse. With double-click, set mark there as well. +Blinks matching paren if sitting after one. Intended to be bound +to a window down button." + (start-mouse-drag arg) + (let ((buf (current-buffer)) + (p (point))) + (mouse::set-point arg) + (if (and (equal p (point)) + (equal buf (current-buffer))) + (if (and (= mouse::clicks 1) + (not (eq (mark) (point)))) + (push-mark)) + (setq mouse::clicks 0)) + (if (eq (char-syntax (preceding-char)) ?\)) + (blink-matching-open))) + (abort-isearch)) + +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/shared/pers-init.el Sat Oct 07 12:43:14 2023 +0100 @@ -0,0 +1,353 @@ +;; GNU Emacs init file for Henry Thompson +;;; This part shared between all hosts +;; This part is my personal stuff, not for other incarnations +;;; initialisation file for Emacs, that is, (l)emacs and epoch common +;;; Last edited: Fri Sep 25 09:22:22 1992 +;;; Edit history since port: made load-path not site-dependant +;;; split into common-init for all my incarnations and pers-init for private +;;; added lemacs compatibility + +;;; HACK to deal with current x-crash workaround that I use a tty-launched +;;; xemacs via gnuclient from an X environment +(if (and (eq + (device-type (frame-device (get-frame-for-buffer (current-buffer)))) + 'x) + (not (getenv "DISPLAY"))) + (progn (message "setting DISPLAY in env") + (setenv "DISPLAY" ":0"))) + +;;; mail stuff +(setq mail-archive-file-name (concat "/disk/scratch/mail/cpy/general/" + (format-time-string + "%Y-%m" (current-time)) + ".mbox")) + +(defun hand () + (interactive) + (insert-file "~/pers/hand.txt")) + +(setq rmail-dont-reply-to-names "hthompso*\\|h\\.thompso*\\|ht@*" ) +(setq rmail-show-mime nil) +(set-default 'ht-last-file (expand-file-name "/disk/scratch/mail/")) +(setq ht-diary-file-name "/disk/scratch/mail/diary.babyl") +(setq mail-append-host "inf.ed.ac.uk") +(setq mail-host-address "inf.ed.ac.uk") + +;; new mail hackery +(site-caseq ((edin ircs ldc) + (setq rmail-spool-directory (file-name-as-directory + (concat rmail-spool-directory + "ht-mail"))))) +;; don't know why this is necessary +(site-caseq ((edin) + (setq rmail-primary-inbox-list + (list (concat rmail-spool-directory "ht"))))) + +(setq minibuffer-max-depth nil) +(defun run-kcl () + "Run an inferior kcl process" + (interactive) + (switch-to-buffer (make-shell "kcl" "kcl")) + (inferior-lisp-mode)) + +(require 'mdn-extras) +(require 'passwd) ; for shell login for kerberos +(setq auto-mode-alist + (append '(("/perl/" . perl-mode) + ("\\.scm$" . lisp-mode) + ("\\.dsl$" . lisp-mode)) + auto-mode-alist)) +(setq inferior-lisp-program "scheme") +;;; for scheme +(put 'letrec 'lisp-indent-function 1) +(put 'case 'lisp-indent-function 1) + +(site-caseq (parc (nconc load-path '("/import/local/emacs/gnus-3.13/")) + (setq rmail-primary-inbox-list + '("~/mbox" "/net/piglet/usr/spool/mail/$USER")))) + +(defun run-sicstus () + "Run an inferior Prolog process, input and output via buffer *prolog*." + (interactive) + (if (not (boundp 'prolog-mode-map)) + (let ((load-path (cons + (site-caseq (parc "/import/prolog-1.8/emacs") + (edin "??")) + load-path))) + (load "prolog" nil t))) + (require 'shell) + (switch-to-buffer (make-shell "prolog" (site-caseq (edin "sicstus") + (parc "prolog")))) + (inferior-prolog-mode)) + +(require 'hist) +(rplacd (assoc "*shell*" hk-pat-table) + "[a-z]+<[0-9]+>: ") + +;; turn off suspend-emacs -- use pause-emacs (^X.) instead +(global-unset-key "\C-Z") +(global-unset-key "\C-x\C-z") + +(global-set-key "\C-xl" (function goto-line)) + +(require 'repl-comment) + +(require 'compress) + +(if (string-match "Lucid" emacs-version) + (progn + (require 'lemacs-compat))) + + (if window-system + (progn + (add-hook 'sh-mode-hook '(lambda () + (font-lock-mode 1))) + (setq perl-mode-hook '(lambda () + (font-lock-mode 1))) + (setq emacs-lisp-mode-hook '(lambda () + (font-lock-mode 1))) + (setq lisp-mode-hook '(lambda () + (font-lock-mode 1))) + (setq sgml-mode-hook '(lambda () + (if (not + (boundp 'sgml-font-lock-keywords)) + (load "sgml-font-lock-keywords" t t)) + (font-lock-mode 1) + )) + (setq c-mode-hook '(lambda () + (font-lock-mode 1))) + (setq c++-mode-hook '(lambda () + (font-lock-mode 1))) + (setq scheme-mode-hook + '(lambda () + (setq + scheme-font-lock-keywords + (if (or + (boundp 'lisp-font-lock-keywords) + (load "lisp-font-lock-keywords" t t)) + lisp-font-lock-keywords)) + (font-lock-mode 1))) + (setq python-mode-hook '(lambda () + (font-lock-mode 1))) + )) + + + (setq sgml-catalog-files '("catalog" "/afs/inf.ed.ac.uk/user/h/ht/lib/sgml/catalog")) + + (if (string-match "Lucid" emacs-version) + ;; lemacs only goes here + (progn + ;; DICE comes here 2012-01-13 + (setq package-get-remove-copy nil) + (setq bbdb-north-american-phone-numbers-p nil) + (setq bbdb-use-pop-up nil) + (setq bbdb-complete-name-allow-cycling t + bbdb-completion-type 'primary-or-name) + (setq bbdb-quiet-about-name-mismatches t) + (setq bbdb-always-add-addresses t) + (setq bbdb-new-nets-always-primary t) + (setq bbdb-file "/disk/scratch/mail/.bbdb") + (setq bbdb-hashtable-size 24203) + ;(require 'bbdb) @ + ;(require 'bbdb-rmail) + ;(require 'bbdb-com) @ ; to fix auto-fill + (fset 'bbdb-auto-fill-function (lambda () t)) ; ditto + (fmakunbound 'bbdb-orig-rmail-expunge) + ;(add-hook 'rmail-mode-hook 'bbdb-insinuate-rmail) + (add-hook 'gnus-startup-hook 'bbdb-insinuate-gnus) + (add-hook 'mail-setup-hook 'bbdb-insinuate-sendmail) + (add-hook 'mail-setup-hook 'bbdb-define-all-aliases) + (add-hook 'gnus-message-setup-hook 'bbdb-define-all-aliases) + (if (not (fboundp 'define-mail-abbrev)) + ;; fix a bug which crashes occasionally -- see also + ;; bbdb-com + (progn + (require 'sendmail) + ;(defadvice sendmail-pre-abbrev-expand-hook @ + ; (before bbdb-rebuilt-all-aliases activate) + ; (bbdb-rebuilt-all-aliases)) + )) + (defun gnuserv-start-maybe () + (if (not (frame-live-p gnuserv-frame)) + (gnuserv-start))) +;;; (require 'itimer) +;;; (start-itimer "gsr" 'gnuserv-start-maybe +;;; 1200 1200 nil nil) + + (if window-system + (progn + ;; DICE comes here 2012-01-13 + (require 'highlight-headers) + (defun rmail-fontify-headers () + (highlight-headers (point-min) (point-max) t)) + (add-hook 'rmail-show-message-hook 'rmail-fontify-headers) + (setq dired-mode-hook + '(lambda () + (font-lock-mode 1) + (define-key dired-mode-map + [button2] '(lambda (click) + (interactive "e") + (mouse-set-point click) + (dired-advertised-find-file))))) + (setq highlight-headers-follow-url-function + 'browse-url-firefox + ;;browse-url-browser-function + ;;'browse-url-mozilla + ) + (setq browse-url-browser-function 'browse-url-firefox) + (set-face-background 'modeline '((x) . "lightgrey")))) + ;; DICE comes here 2012-01-13 + (load "device-type-hacking" t t) +;; (setq browse-url-mozilla-program "/usr/bin/X11/mozilla") + + ;; gnus + (setq nnml-directory (expand-file-name "/disk/scratch/mail/Mail") + gnus-secondary-select-methods + '((nnml "ht" + (gnus-show-threads nil) + (gnus-article-sort-functions + (gnus-article-sort-by-subject + gnus-article-sort-by-date)))) + gnus-home-directory "/disk/scratch/gnus" ; local disk + gnus-article-save-directory (expand-file-name "/disk/scratch/mail/Mail") + gnus-message-archive-method + `(nnfolder "archive" + (nnfolder-directory ,(expand-file-name + "/disk/scratch/mail/cpy")) + (nnfolder-active-file ,(expand-file-name + "/disk/scratch/cpy/active")) + (nnfolder-get-new-mail nil) + (nnfolder-inhibit-expiry t))) + + (load "gnus-init" nil t) + + ;; override changed default, except in gnus + (setq mail-use-rfc822 nil) + (add-hook 'gnus-summary-mode-hook + (function (lambda () + (make-local-variable 'mail-use-rfc822) + (setq mail-use-rfc822 t)))) + (if (>= emacs-major-version 21) + (progn + (add-hook 'gnus-startup-hook 'bbdb-insinuate-gnus) + (add-hook 'gnus-startup-hook 'bbdb-insinuate-message))) + ;; DICE comes here 2012-01-13 + (defun ht-rooms-setup (&optional arg) + (interactive) + (require 'mail-extras) + (require 'diary) + (let ((scr (selected-frame))) + ; (sit-for 5) + (load "ht-rooms.config" nil t) + ;; for ecclerig viewed from paul + (if (eq (device-pixel-width (selected-device)) 1920) + (progn + (unwind-protect + (make-screen-for-room "diary" "+1219" "+68")) + (unwind-protect + (make-screen-for-room "elisp" "+1185" "+102")) + (unwind-protect + (make-screen-for-room "news" "+1253" "+34"))) + ;; for ecclerig in office + (unwind-protect (make-screen-for-room "diary" "+1888" "+0")) + (unwind-protect (make-screen-for-room "elisp" "+1888" "+0")) + (unwind-protect (make-screen-for-room "news" "+1223" "+0"))) + (sit-for 1) + (delete-frame scr)) + (setq ht-default-config (current-window-configuration))))) + ;; vanilla v19 was here + (setq sgml-insert-missing-element-comment nil) + (load "psgml" nil t) + (load "psgml-edit" nil t) + (load "xml-hack" nil t) + (add-hook 'sgml-mode-hook 'sgml-fix-para) + ;; v18 emacs only was here + +(defun ht-rooms-resetup () + (interactive) + (setq rooms-table nil) + (setq frames-table nil) + (ht-rooms-setup)) + +(defun sgml-fix-para () + (setq paragraph-separate + "</[^>]*>\n\\([ \t]+\\| \\)") + (setq paragraph-start + "^[ \t]*</?[A-Za-z._-]+[ >]")) + +(defun highlight-headers-ht-follow-url-netscape (url &optional arg) + (message "Sending URL to Netscape...") + (save-excursion + (set-buffer (get-buffer-create "*Shell Command Output*")) + (erase-buffer) + (if (equal 0 (call-process "netscape" nil t nil "-display" ":0.0" + "-remote" + (concat "openURL(" url ")"))) + ;; it worked + nil + ;; it didn't work, so start a new Netscape process. + (call-process "netscape" nil 0 nil url))) + (message "Sending URL to Netscape... done")) + +;;; Moved from custom.el -- not customisable, I think. . . +(setq + ecb-options-version "2.27" + gnus-treat-display-smileys nil + gnus-treat-from-picon nil + gnus-treat-mail-picon nil + gnus-treat-newsgroups-picon nil + jde-enable-abbrev-mode t + package-get-require-signed-base-updates nil + pgg-passphrase-cache-expiry 36000 + pui-package-install-dest-dir "/afs/inf.ed.ac.uk/user/h/ht/.xemacs/xemacs-packages" + efs-ftp-program-args '("-i" "-n" "-g" "-v") + efs-use-passive-mode t ; actually turns it _off_ ! +) + +;;; The following duplicate settings in custom.el???? +(custom-set-faces + '(font-lock-builtin-face ((((type x mswindows)(class color)(background light))(:foreground "Purple"))(((type tty)(class color))(:foreground "magenta")))) + '(font-lock-comment-face ((((type x mswindows)(class color)(background light))(:foreground "blue4"))(((type tty)(class color))(:foreground "blue")))) + '(font-lock-constant-face ((((type x mswindows)(class color)(background light))(:foreground "CadetBlue"))(((type tty)(class color))(:foreground "cyan")))) + '(font-lock-doc-string-face ((((type x mswindows)(class color)(background light))(:foreground "green4"))(((type tty)(class color))(:foreground "green")))) + '(font-lock-function-name-face ((((type x mswindows)(class color)(background light))(:foreground "brown4"))(((type tty)(class color))(:foreground "cyan" :bold)))) + '(font-lock-keyword-face ((((type x mswindows)(class color)(background light))(:foreground "red4"))(((type tty)(class color))(:foreground "red" :bold)))) + '(font-lock-preprocessor-face ((((type x mswindows)(class color)(background light))(:foreground "blue3"))(((type tty)(class color))(:foreground "cyan" :bold)))) + '(font-lock-reference-face ((((type x mswindows)(class color)(background light))(:foreground "red3"))(((type tty)(class color))(:foreground "red")))) + '(font-lock-string-face ((((type x mswindows)(class color)(background light))(:foreground "green4"))(((type tty)(class color))(:foreground "green" :bold)))) + '(font-lock-type-face ((((type x mswindows)(class color)(background light))(:foreground "steelblue"))(((type tty)(class color))(:foreground "cyan" :bold)))) + '(font-lock-variable-name-face ((((type x mswindows)(class color)(background light))(:foreground "magenta4"))(((type tty)(class color))(:foreground "magenta" :bold)))) + '(font-lock-warning-face ((((type x mswindows)(class color)(background light))(:foreground "Red" :bold))(((type tty)(class color))(:foreground "red" :bold)))) +) + +(custom-set-faces + '(modeline ( + (((type x mswindows)(class color)) + (:foreground "black" :background "gray80")) + (t + (:foreground "black" :background "white")))) + '(modeline-buffer-id ( + (((type x mswindows)(class color)) + (:foreground "blue4" :background "gray80")) + (((type tty)(class color)) + (:foreground "blue" :background "white")) + (t + (:foreground "black" :background "white" :bold t)))) + '(modeline-mousable ( + (((type x mswindows)(class color)) + (:foreground "firebrick" :background "gray80")) + (((type tty)(class color)) + (:foreground "red" :background "white")) + (t + (:foreground "black" :background "white")))) + '(modeline-mousable-minor-mode ( + (((type x mswindows)(class color)) + (:foreground "green4" :background "gray80")) + (((type tty)(class color)) + (:foreground "green" :background "white" :bold t)) + (t + (:foreground "black" :background "white")))) +) + +(defalias 'review (read-kbd-macro +"PhD SPC applicant SPC review, SPC please 4*<C-n> M-x insert- f SPC RET bus/ilc SPC new SPC RET 9*<C-n> C-e"))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/shared/refInsert.el Sat Oct 07 12:43:14 2023 +0100 @@ -0,0 +1,45 @@ +;;; refInsert.el --- replace url with ref, resolve at end + +(provide 'refInsert) +;;; Code: + +(defun reference () + "Insert a reference" + (interactive) + (let ((current-point (point)) + (beginning (search-backward " +" (point-min) t))) + (save-excursion + (if (not (equal beginning nil)) + (goto-char beginning)) + (let ((url-point (search-forward-regexp "[a-zA-Z]+:[^ +]+" (+ current-point 1) t)) + (ref "http://www.w3.org/DOM")) + (if (not (equal url-point nil)) + (progn + (setq ref (buffer-substring (match-beginning 0) (match-end 0))) + (replace-match "") + (setq current-point (point)))) + + (setq ref (read-string "Reference? " ref)) + (setq nbReferences + (string-to-number (read-string "Reference number? " + (number-to-string (+ nbReferences 1))))) + (let ((search-p (search-forward-regexp "^-- +" (point-max) t))) + (if (equal search-p nil) + (end-of-buffer) + (progn (goto-char search-p) (previous-line 1))) + (insert (concat "[" (number-to-string nbReferences) "] " + ref)) + (newline)))) + (goto-char current-point) + (insert (concat "[" (number-to-string nbReferences) "]")) + )) + +(setq nbReferences 0) + +(add-hook 'mail-setup-hook (lambda () (setq nbReferences 0))) +(add-hook 'gnus-message-setup-hook (lambda () (setq nbReferences 0))) + +;;; %F ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/shared/repl-comment.el Sat Oct 07 12:43:14 2023 +0100 @@ -0,0 +1,59 @@ +;; Universal (?) replace comment in function + +;; Last edited: Thu Oct 7 09:39:50 1993 +(defun repl-comment (fn comment) + "replace/install as FN's comment COMMENT, no matter what emacs/compiler" + (let ((defn (symbol-function fn))) + (if (consp defn) + (if (eq (car defn) 'autoload) + (progn (load-library (car (cdr defn))) + (if (equal defn (symbol-function fn)) + (error "autoloading didn't help define %s" fn) + (repl-comment fn comment))) + ;; either symbolic or old byte-compiler + (if (eq (car defn) 'lambda) + (if (stringp (car (cdr (cdr defn)))) + (rplaca (cdr (cdr defn)) + comment) + (rplacd (cdr defn) + (cons comment + (cdr (cdr defn))))) + (error "can't diagnose defn %s" defn))) + ;; array or not + (if (compiled-function-p defn) + (fset fn (if (fboundp 'compiled-function-arglist) + (progn (make-byte-code + (compiled-function-arglist defn) + (compiled-function-instructions defn) + (compiled-function-constants defn) + (compiled-function-stack-depth defn) + comment + (compiled-function-interactive defn)) defn) + (repl-byte fn (list (cons 4 comment))))) + (error "unrecognised defn %s" defn))))) + +(defun repl-byte (fn alist) + "compute a new byte-code defn for FN, replacing +elements using ALIST, which is interpreted as (index . newbit). +Elements are 0: arglist 1: byte-codes 2: symbols 3: stack-depth 4: comment" + (let + ((defn (symbol-function fn))) + (let ((ln (if (sequencep defn) + (length defn) + ;; hack otherwise + 6)) + (i 0) + new entry) + (apply (function make-byte-code) + (progn (while (< i ln) + (setq new + (cons + (if (setq entry (assoc i alist)) + (cdr entry) + (aref defn i)) + new)) + (setq i (1+ i))) + (nreverse new)))))) + + +(provide 'repl-comment)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/shared/sgml-font-lock-keywords.el Sat Oct 07 12:43:14 2023 +0100 @@ -0,0 +1,11 @@ +(defvar sgml-font-lock-keywords +'(;; highlight defining forms. + ("^<!\\([^- \t\n]+\\)[ \t\n]\\s-*\\(% \\)?\\(\\S-+\\)" + (1 font-lock-keyword-face) (3 font-lock-function-name-face)) + ("</?\\([-a-z0-9.A-Z]+\\)" 1 font-lock-function-name-face t) ; allow overlap to speed up + ("\\(/\\)>" 1 font-lock-function-name-face) + ("[%&][^ \t\n;]+" . font-lock-string-face) + ("--[^-]+\\(-[^-]+\\)*--" . font-lock-comment-face) + ("^<[?].*>" . font-lock-string-face) + ) +)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/shared/xml-hack.el Sat Oct 07 12:43:14 2023 +0100 @@ -0,0 +1,8 @@ +(defun sgml-tag-again () + "Insert another of the tag we're in as sibling" + (interactive ) + (let ((elt (sgml-element-name (sgml-find-element-of (point))))) + (sgml-up-element) + (sgml-insert-element elt))) + +(define-key sgml-mode-map "\C-cn" 'sgml-tag-again)