Mercurial > hg > xemacs
changeset 32:cb9b76219c55
attempt to merge mail read and send from all over
| author | Henry S Thompson <ht@inf.ed.ac.uk> |
|---|---|
| date | Sun, 08 Oct 2023 16:36:27 +0100 |
| parents | 129123962e51 |
| children | ce71d12b00ad |
| files | common-init.el gnus-init.el mail-from-m.el my-news.el pers-init.el |
| diffstat | 5 files changed, 1013 insertions(+), 457 deletions(-) [+] |
line wrap: on
line diff
--- a/gnus-init.el Sat Oct 07 12:43:14 2023 +0100 +++ b/gnus-init.el Sun Oct 08 16:36:27 2023 +0100 @@ -1,6 +1,23 @@ -;; Last edited: Fri Aug 20 14:49:23 1999 ;; gnus customisation +(site-caseq (edin + (require 'mail-from-inf)) + (maritain + (require 'mail-from-m) +)) + +;; things based on my-mail-dir, which is set in one of the above + +(setq gnus-article-save-directory (concat my-mail-dir "/Mail") + nnml-directory (expand-file-name (concat my-mail-dir "/Mail")) + gnus-message-archive-method + '(nnfolder "archive" + ;; the following two are not taking effect, not sure why, answer + ;; _may_ lie in gnus-setup-news... + (nnfolder-directory (concat my-mail-dir "/cpy")) + (nnfolder-active-file (concat my-mail-dir "/cpy/active"))) + mail-sources '((file :path "/var/spool/mail/ht"))) + (setq gnus-novice-user nil) (setq gnus-message-archive-group @@ -8,77 +25,77 @@ "%Y-%m" (current-time))))) -(site-caseq (maritain (require 'mail-from-m))) -(setq -; gnus-article-sort-functions '(gnus-article-sort-by-subject -; see secondary-select-methods in my-news gnus-article-sort-by-number) - gnus-auto-select-next 'quietly - gnus-buttonized-mime-types '("multipart/signed") - gnus-inhibit-mime-unbuttonizing nil - gnus-ignored-headers "^Errors-To:\\|^Precedence:\\|^UNIX-From:" - gnus-mime-display-multipart-related-as-mixed t - gnus-posting-styles `((".*" - (signature-file ,mail-signature-file)) - ("quaker-2023" - (signature-file "/home/ht/.quaker-sig") - (address "ht@rsof.hst.name")) - ("mhmcc-2023" - (signature-file "/home/ht/.mhmcc-sig") - ("Reply-to" "sesam.emh.management@gmail.com") - (name "HST as Convenor SESAM MHMC") - (address "mhmcc@rsof.hst.name") - ("Bcc" "sesam.emh.management@gmail.com"))) - gnus-simplify-subject-regexp "^\\(re[:;.]\\| \\|fwd:\\)*" - gnus-summary-display-arrow nil - gnus-summary-gather-subject-limit nil - gnus-summary-line-format "%U%R%5N%I%(%[%4L: %-12,12A%]%) %s\n" - gnus-summary-make-false-root 'none - gnus-thread-sort-functions '(gnus-thread-sort-by-number - gnus-thread-sort-by-simpl-subject) - mm-discouraged-alternatives '("text/html") - gnus-summary-ignore-duplicates t - gnus-use-scoring nil ; not used yet - ) +(setq gnus-auto-select-next 'quietly + gnus-buttonized-mime-types '("multipart/signed") + gnus-group-line-format "%M%S%p%P%5y:%uH%(%g%)%l %O +" + gnus-ignored-headers "^Errors-To:\\|^Precedence:\\|^UNIX-From:" + gnus-inhibit-mime-unbuttonizing nil + gnus-mime-display-multipart-related-as-mixed t + gnus-show-mime t + gnus-simplify-subject-regexp "^\\(re[:;.]\\| \\|fwd:\\)*" + gnus-summary-display-arrow nil + gnus-summary-gather-subject-limit nil + gnus-summary-ignore-duplicates t + gnus-summary-line-format "%U%R%5N%I%(%[%4L: %-12,12A%]%) %s\n" + gnus-summary-make-false-root 'none + gnus-thread-sort-functions '(gnus-thread-sort-by-number + gnus-thread-sort-by-simpl-subject) + gnus-use-scoring nil ; not used yet + message-from-style 'angles + mm-discouraged-alternatives '("text/html") + nnmail-expiry-wait 28 + no-select-groups '("nnml+ht:cygwin") + ) (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) -(defun set-nnmail-split-fancy () - (setq nnmail-split-fancy - (let ((month (format-time-string "%Y-%m" (current-time)))) - (cons '| - (append '(("Subject" "testing" "jjunk") - (to "quaker-\\(l\\|spectrum\\)" "quaker-2022") - (to "quaker-b" "quaker-b") - (to "[cC]ygwin" "cygwin") - (from "noreply@mrooms.net" "nayler") - (to "ht@rsof.hst.name" "quaker-2023") - (to "Wardenship@lists.quaker.eu.org" "wardens") - (to "mhmcc@rsof.hst.name" "mhmcc-2023") - ("Envelope-to" "mhmcc@rsof.hst.name" - (| (from "mhmcc@rsof.hst.name" junk) - "mhmcc-2023")) - (to "mfw@rsof.hst.name" "7vt") - (to "zphdaily" (concat "pers-" month)) - (to "inf\\(pg\\|msc\\|teach\\|res\\|staff\\)" "inf-\\1" ) - ) - (list (list 'to - "ht\\|h\\.?thompson?" - (concat "pers-" month)) - (concat "group-" - (format-time-string - "%Y-%m" (current-time)) - ""))))))) + +(setq white-domains (list)) -(set-nnmail-split-fancy) +(setq ad-domains (list "planetx.co.uk" "substack.com")) + +(defvar ht-compiled-split nil) (defun set-ht-compiled-split () + "update the mail splitting rules" (interactive) (set-nnmail-split-fancy)) -(setq gnus-show-mime t) +(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 ht-gnus-summary-delete-forward () "REAL delete for nnmail gnus" @@ -86,21 +103,17 @@ (gnus-summary-delete-article) (gnus-summary-next-unread-article)) -(require 'my-news) -(open-quaker) - (add-hook 'kill-emacs-hook (lambda () -; (if (database-live-p whitelist-db) -; (close-database whitelist-db)) + (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)) + (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) (custom-set-variables '(gnus-treat-display-picons nil)) @@ -112,16 +125,7 @@ (add-hook 'message-mode-hook 'message-mode-fun1) -;; 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 "\M-h" 'showMPAhtml) - (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)) +(add-hook 'message-sent-hook (function whiten-recip)) (defun ht-gnus-pers-refresh (n) (interactive "p") @@ -135,11 +139,6 @@ (add-hook 'gnus-group-mode-hook 'gnus-group-mode-fun1) -;; run the first time we make a group window -(defun gnus-group-mode-fun1 () - "install ht's mods" - (define-key gnus-group-mode-map "\M-\C-g" 'ht-gnus-pers-refresh) - (remove-hook 'gnus-group-mode-hook 'gnus-group-mode-fun1)) (defun gnus-regen-group () (nnml-generate-nov-databases-1 (concat @@ -148,7 +147,10 @@ (substring (gnus-group-group-name) 8)) nil t) ) - +(require 'mailcrypt) +(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) (defun gnus-user-format-function-t (header) "display the to field (for archive messages)" @@ -213,3 +215,5 @@ ))) (setq gnus-treat-strip-uoe-warning t) + +(provide 'gnus-init)
--- a/mail-from-m.el Sat Oct 07 12:43:14 2023 +0100 +++ b/mail-from-m.el Sun Oct 08 16:36:27 2023 +0100 @@ -1,4 +1,5 @@ -;;; Edit and load to send mail as from ... +;;; Load to read and send mail from maritain + (setq mail-append-host "home.hst.name") (setq user-full-name "Henry S. Thompson") (setq user-mail-address "ht@home.hst.name") @@ -9,6 +10,50 @@ (setq message-signature t) (defun system-name () "home.hst.name") +(setq gnus-default-directory "/home/ht" + my-mail-dir "/home/ht/mail" +) + +(defun set-nnmail-split-fancy () + (setq nnmail-split-fancy + (let ((month (format-time-string "%Y-%m" (current-time)))) + (cons '| + (append '(("Subject" "testing" "jjunk") + (to "quaker-\\(l\\|spectrum\\)" "quaker-2022") + (to "quaker-b" "quaker-b") + (to "[cC]ygwin" "cygwin") + (from "noreply@mrooms.net" "nayler") + (to "ht@rsof.hst.name" "quaker-2023") + (to "Wardenship@lists.quaker.eu.org" "wardens") + (to "mhmcc@rsof.hst.name" "mhmcc-2023") + ("Envelope-to" "mhmcc@rsof.hst.name" + (| (from "mhmcc@rsof.hst.name" junk) + "mhmcc-2023")) + (to "mfw@rsof.hst.name" "7vt") + (to "zphdaily" (concat "pers-" month)) + (to "inf\\(pg\\|msc\\|teach\\|res\\|staff\\)" "inf-\\1" ) + ) + (list (list 'to + "ht\\|h\\.?thompson?" + (concat "pers-" month)) + (concat "group-" + (format-time-string + "%Y-%m" (current-time)) + ""))))))) + +(setq gnus-posting-styles + `((".*" + (signature-file ,mail-signature-file)) + ("quaker-2023" + (signature-file "/home/ht/.quaker-sig") + (address "ht@rsof.hst.name")) + ("mhmcc-2023" + (signature-file "/home/ht/.mhmcc-sig") + ("Reply-to" "sesam.emh.management@gmail.com") + (name "HST as Convenor SESAM MHMC") + (address "mhmcc@rsof.hst.name") + ("Bcc" "sesam.emh.management@gmail.com")))) + ;; sending mail on the road ;(setq send-mail-function 'smtpmail-send-it) ;(setq message-send-mail-function 'smtpmail-send-it) @@ -19,4 +64,22 @@ (load "smtpmail" nil t) (setq smtpmail-code-conv-from nil) + +(defun quaker-sig-maybe () + (save-excursion + (goto-char (point-min)) + (cond ((to-quaker-p) + (goto-char (point-min)) + (cond ((search-forward "\nFrom: ht@home.hst.name" nil t) + (backward-char 13) + (delete-char 4) + (insert "rsof"))))) + + (goto-char (point-max)) + (search-backward "\n-- \n") + (when (looking-at "\n-- \nHenry") + (forward-char 5) + (kill-entire-line 5) + (insert-file "~/.quaker-sig")))) + (provide 'mail-from-m)
--- a/my-news.el Sat Oct 07 12:43:14 2023 +0100 +++ b/my-news.el Sun Oct 08 16:36:27 2023 +0100 @@ -1,31 +1,47 @@ -;; Last edited: Wed Aug 25 14:10:36 1999 +(message "my-news") +; (debug-on-entry 'gnus-start-news-server) +(setq + gnus-select-method '(nntp "hebe.uk.clara.net") + gnus-post-method '(nntp "usenet.inf.ed.ac.uk") + gnus-nntp-server nil ; override local default + ) -;(site-caseq (edin (require 'ccs-gnus))) +(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:\\)*") -; mix-spool stuff +(defsubst gnus-trim-simplify-subject (text) + (if (string-match gnus-simplify-subject-regexp text) + (substring text (match-end 0)) + text)) -(load "gnus" nil t) -; (debug-on-entry 'gnus-start-news-server) -(setq gnus-nntp-server nil) -; +(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))) -(setq gnus-article-save-directory "/home/ht/mail/Mail") -(setq nnml-directory (expand-file-name "/home/ht/mail/Mail")) -(setq gnus-message-archive-method - '(nnfolder "archive" - ;; the following two are not taking effect, not sure why, answer - ;; _may_ lie in gnus-setup-news... - (nnfolder-directory "/home/ht/mail/cpy") - (nnfolder-active-file "/home/ht/mail/cpy/active") - (nnfolder-get-new-mail nil) - (nnfolder-inhibit-expiry t))) -(setq gnus-secondary-select-methods +(setq nnfolder-get-new-mail nil + nnfolder-inhibit-expiry t + 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-article-sort-functions + (gnus-article-sort-by-subject gnus-article-sort-by-date)) ))) -(setq mail-sources '((file :path "/var/spool/mail/ht"))) ;;; fixup clarinews ;(autoload 'gnus-clarinews-fun "clari-clean" "Clean ClariNews articles" t) ;(add-hook 'gnus-article-prepare-hook 'gnus-clarinews-fun) @@ -51,16 +67,7 @@ )) ;(require 'util-mde) ; for string-replace-regexp-2 -(defun gnus-trim-simplify-subject (text) - "call gnus-simplify-subject and remove leading blanks" - (if text - (gnus-simplify-subject - (string-replace-regexp-2 - (gnus-simplify-subject text t) - "^\\s-+" - "") - t) - "")) + (defun gnus-string-equal (a b) "Return T if first arg string is equal than second in lexicographic order. @@ -79,24 +86,41 @@ ;; Database stuff (defun open-white () - (setq whitelist-db (open-database "/disk/scratch/mail/white" 'berkeley-db))) + (setq whitelist-db (open-database (concat my-mail-dir "/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))) + (setq adlist-db (open-database (concat my-mail-dir "/ad") 'berkeley-db))) (defun save-ad () (close-database adlist-db) (open-ad)) (defun open-quaker () - (setq quaker-db (open-database "~/mail/quaker" 'berkeley-db))) + (setq quaker-db (open-database (concat my-mail-dir "/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") @@ -156,29 +180,18 @@ (progn (quaker-sig-maybe) t))) -(defun quaker-sig-maybe () - (save-excursion - (goto-char (point-min)) - (cond ((to-quaker-p) - (goto-char (point-min)) - (cond ((search-forward "\nFrom: ht@home.hst.name" nil t) - (backward-char 13) - (delete-char 4) - (insert "rsof"))))) - - (goto-char (point-max)) - (search-backward "\n-- \n") - (when (looking-at "\n-- \nHenry") - (forward-char 5) - (kill-entire-line 5) - (insert-file "~/.quaker-sig")))) - (defun kill-white () (interactive) (gnus-summary-goto-article (gnus-summary-article-number)) - (let ((addr (get-current-from-addr))) + (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"))) @@ -282,9 +295,8 @@ (put-database addr "t" adlist-db) t)) -(defun rem-ad () - (interactive) - (remove-database (downcase (get-current-from-addr)) adlist-db) +(defun rem-ad (addr) + (remove-database addr adlist-db) (save-ad)) (defun new-quaker (addr) @@ -294,7 +306,8 @@ t)) (defun rem-white (addr) - (remove-database (downcase addr) whitelist-db)) + (remove-database (downcase addr) whitelist-db) + (save-white)) (defun bogoOK (group) (shell-command-on-region (point-min) (point-max) @@ -323,14 +336,457 @@ (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) "/home/ht/bin/showMPA.sh") + (shell-command-on-region (point-min) (point-max) + (expand-file-name "~/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 (concat my-mail-dir "/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 (concat "cd %s && mhstore -f " + my-mail-dir "/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)
--- a/pers-init.el Sat Oct 07 12:43:14 2023 +0100 +++ b/pers-init.el Sun Oct 08 16:36:27 2023 +0100 @@ -7,39 +7,47 @@ ;;; 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 +;;; Not sure this is still needed 2023-10-07 +(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 "~/mail/cpy/general") +(site-caseq (edin + (setq mail-archive-file-name (concat "/disk/scratch/mail/cpy/general/" + (format-time-string + "%Y-%m" (current-time)) + ".mbox")) + (t (setq mail-archive-file-name "~/mail/cpy/general")))) + + (setq rmail-dont-reply-to-names "hthompso*\\|h\\.thompso*\\|ht@*" ) -(set-default 'ht-last-file (expand-file-name "~/mail/")) -(setq ht-diary-file-name "~/mail/diary.babyl") -(setq mail-append-host "inf.ed.ac.uk") + +(site-caseq (edin + (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 user-mail-address "ht@inf.ed.ac.uk") + (setq mail-append-host "inf.ed.ac.uk") + (setq mail-host-address "inf.ed.ac.uk"))) + (setq user-full-name "Henry S. Thompson") -(setq user-mail-address "ht@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"))))) - -;; sending mail on the road -;; [moved to mail-from-m.el, which is required by gnus-init.el - ;; don't know why this is necessary (site-caseq ((edin) (setq rmail-primary-inbox-list (list (concat rmail-spool-directory "ht"))))) -;; Perforce - -;;(setq p4-global-server-port "zorg.milowski.com:1666") -;;(setenv "P4PORT" "zorg.milowski.com:1666") -;;(setenv "P4CLIENT" "MarkupMan") -;;(setenv "P4CONFIG" ".p4env") -;;(load-library "p4") -;;(setq p4-use-p4config-exclusively t) -;;(p4-set-p4-executable "/c/Program Files/Perforce/p4.exe") (setq vc-command-messages t) (setq minibuffer-max-depth nil) @@ -52,7 +60,8 @@ (require 'mdn-extras) (setq auto-mode-alist (append '(("/perl/" . perl-mode) - ("\\.scm$" . scheme-mode)) + ("\\.scm$" . scheme-mode) + ("\\.dsl$" . lisp-mode)) auto-mode-alist)) (setq inferior-lisp-program "scheme") ;;; for scheme @@ -61,10 +70,7 @@ (site-caseq (parc (nconc load-path '("/import/local/emacs/gnus-3.13/")) (setq rmail-primary-inbox-list - '("~/mbox" "/net/piglet/usr/spool/mail/$USER"))) - (edin (setq load-path (cons - "/home/ht/emacs/shared/gnus-5.0.15/lisp" - load-path)))) + '("~/mbox" "/net/piglet/usr/spool/mail/$USER")))) (defun run-sicstus () "Run an inferior Prolog process, input and output via buffer *prolog*." @@ -80,10 +86,9 @@ (parc "prolog")))) (inferior-prolog-mode)) -(site-caseq ((laptop maritain)) - (t(require 'hist) - (rplacd (assoc "*shell*" hk-pat-table) - "[a-z]+<[0-9]+>: "))) +(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") @@ -91,317 +96,288 @@ (global-set-key "\C-xl" (function goto-line)) -;(require 'repl-comment) +(require 'repl-comment) -;(require 'compress) +(require 'compress) (if (string-match "Lucid" emacs-version) - (site-caseq ((laptop maritain)) - (t(require 'lemacs-compat)))) - -(if (boundp 'epoch::version) - ;; epoch only goes here (progn - (if (string-match "4\\."emacs-version) - (load "motion4" nil t) - (load "motion" nil t)) - (redisplay-frame) - - (require 'alarm) - (idle-save 15) + (require 'lemacs-compat))) - (defun ht-rooms-setup (&optional arg) - (interactive) - (redisplay-frame) - (require 'mail-extras) - (require 'diary) - (require 'my-news) - (let ((scr (current-frame))) - (load "ht-rooms-epoch.config" nil t) - (unwind-protect (make-frame-for-room "diary" "-0" "+130")) - (unwind-protect (make-frame-for-room "elisp" "-25" "+148")) - (unwind-protect (make-frame-for-room "news" "-50" "+166")) - (unwind-protect (make-frame-for-room "mail" "-75" "+184")) - (epoch::delete-frame scr)) - ;; presumably this is now frame local, so not quite the right thing. - (setq ht-default-config (current-window-configuration))) - )) -(if (string-match "^\\(19\\|2\\)" emacs-version) +(if window-system (progn - ;; common v19 - (if window-system - (progn - (add-hook 'sh-mode-hook '(lambda () - (font-lock-mode 1))) - (add-hook 'lsl-mode-hook '(lambda () - (font-lock-mode 1))) - (add-hook 'perl-mode-hook '(lambda () - (font-lock-mode 1))) - (add-hook 'emacs-lisp-mode-hook '(lambda () - (font-lock-mode 1))) - (add-hook 'lisp-mode-hook '(lambda () - (font-lock-mode 1))) - (add-hook 'sgml-mode-hook '(lambda () - (if (not - (boundp 'sgml-font-lock-keywords)) - (load "sgml-font-lock-keywords" t t)) - (setq adaptive-fill-mode nil) - (font-lock-mode 1) - )) - (add-hook 'c-mode-hook '(lambda () - (font-lock-mode 1))) - (add-hook 'c++-mode-hook '(lambda () - (font-lock-mode 1))) - (add-hook '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))) - (add-hook 'python-mode-hook '(lambda () - (font-lock-mode 1))) - (setq py-python-command "//c/Program Files/Python22/python") - (setq sgml-insert-missing-element-comment nil) - (load "psgml" nil t) - (load "psgml-edit" nil t) - ;; (load "xml-hack" nil t) + (add-hook 'sh-mode-hook '(lambda () + (font-lock-mode 1))) + (add-hook 'perl-mode-hook '(lambda () + (font-lock-mode 1))) + (add-hook 'emacs-lisp-mode-hook '(lambda () + (font-lock-mode 1))) + (add-hook 'lisp-mode-hook '(lambda () + (font-lock-mode 1))) + (add-hook 'sgml-mode-hook '(lambda () + (if (not + (boundp 'sgml-font-lock-keywords)) + (load "sgml-font-lock-keywords" t t)) + (setq adaptive-fill-mode nil) + (font-lock-mode 1) + )) + (add-hook 'c-mode-hook '(lambda () + (font-lock-mode 1))) + (add-hook 'c++-mode-hook '(lambda () + (font-lock-mode 1))) + (add-hook '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))) + (add-hook 'python-mode-hook '(lambda () + (font-lock-mode 1))) + (setq sgml-insert-missing-element-comment nil) + (load "psgml" nil t) + (load "psgml-edit" nil t) + ;; (load "xml-hack" nil t) ; (setq sgml-catalog-files '("CATALOG" "f:/lib/sgml/catalog")) - (if (string-match "i386" (emacs-version)) - (progn (defun win32-get-clipboard-data-cmd () - (interactive)(insert (win32-get-clipboard-data))) - (global-set-key - "\C-x\C-y" 'win32-get-clipboard-data-cmd))) - ;; gnus -; (setq mail-signature t) + (if (string-match "i386" (emacs-version)) + (progn (defun win32-get-clipboard-data-cmd () + (interactive)(insert (win32-get-clipboard-data))) + (global-set-key + "\C-x\C-y" 'win32-get-clipboard-data-cmd))) + )) + + +(site-caseq (edin + (setq sgml-catalog-files '("catalog" "/afs/inf.ed.ac.uk/user/h/ht/lib/sgml/catalog")))) - ;; loading gnus postponed to e.g. mail-from-delphix, q.v. - - ; (require 'gnus-min) - )) - (load "gnus-init" nil t) - -;; (require 'idle) -;; (idle-save 15) - - (if (string-match "Lucid" emacs-version) - ;; lemacs only goes here - (progn - (message "lem") - (setq bbdb-north-american-phone-numbers-p nil) - (setq bbdb-use-pop-up nil) - (require 'mail-abbrevs) - (require 'bbdb) - ;(require 'bbdb-rmail) - (require 'bbdb-com) ; to fix auto-fill - (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))) - (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) - (setq bbdb-dwim-net-address-allow-redundancy t) - (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))) +(if (string-match "Lucid" emacs-version) + ;; lemacs only goes here + (progn + (message "lem") + ;; DICE comes here 2012-01-13 + (setq package-get-remove-copy nil) + (require 'mail-abbrevs) + (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) + (site-caseq (edin + (setq bbdb-file "/disk/scratch/mail/.bbdb"))) + (setq bbdb-hashtable-size 24203) + (require 'bbdb) + ;(require 'bbdb-rmail) + (require 'bbdb-com) ; to fix auto-fill + (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))) + (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) + (setq bbdb-dwim-net-address-allow-redundancy t) + (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 - (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 - ;; 'highlight-headers-ht-follow-url-netscape - ;; browse-url-browser-function - ;;'highlight-headers-ht-follow-url-netscape) - )) -;; (load "~rjc/public_html/device-type-hacking.el") - (load "perl-mode" nil t) - (defun ht-rooms-setup (&optional arg) - (interactive) - (require 'mail-extras) - (require 'diary) - (require 'my-news) - ;; 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))) - (defun ht-rooms-setup (&optional arg) - (interactive) - (require 'mail-extras) - (require 'diary) - (let ((scr (selected-frame))) + (if window-system + (progn + (message "window-system-1") + ;; 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))))) + (set-face-background 'modeline '((x) . "lightgrey")) + )) + ;; DICE comes here 2012-01-13 + (load "device-type-hacking" t t) + (message "dth") + (site-caseq (edin + (defun ht-rooms-setup (&optional arg) + (interactive) + (require 'mail-extras) + (require 'diary) + ;; 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))) + (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) - (unwind-protect (make-screen-for-room "diary" "0" "+62")) + (load "ht-rooms.config" nil t) + (unwind-protect (make-screen-for-room "diary" "0" "+62")) ; (sit-for 5) - (unwind-protect (make-screen-for-room "elisp" "-25" "+79")) + (unwind-protect (make-screen-for-room "elisp" "-25" "+79")) ; (sit-for 5) - (unwind-protect (make-screen-for-room "news" "-50" "+96")) + (unwind-protect (make-screen-for-room "news" "-50" "+96")) ; (sit-for 5) - (unwind-protect (make-screen-for-room "mail" "-75" "+113")) - (sit-for 1) - (delete-screen scr)) - (setq ht-default-config (current-window-configuration))))) - ;; vanilla v19 goes here - (if window-system - (progn - (defvar ht-frame-parameter-mods - '((auto-raise . t) - (auto-lower . nil) - (cursor-type . bar))) - (nconc - (site-caseq ((laptop maritain) (list '(height . 35))) - (t - (list - '(font . - "-adobe-courier-medium-r-normal--14-*")))) - ht-frame-parameter-mods + (unwind-protect (make-screen-for-room "mail" "-75" "+113")) + (sit-for 1) + (delete-screen scr)) + (setq ht-default-config (current-window-configuration))))) ) - ;; if we have X, we have ISO-Latin-1, so - ;; set char codes 128--255 to display as themselves. - (require 'disp-table) - (standard-display-8bit 161 255) + (message "gnus-init") + (require 'gnus-init) + ) + ;; vanilla v19 goes here + ;; probably stale/broken + (message "vanilla") + (if window-system + (progn + (message "window-system-2") + (defvar ht-frame-parameter-mods + '((auto-raise . t) + (auto-lower . nil) + (cursor-type . bar))) + (nconc + (site-caseq ((laptop maritain) (list '(height . 35))) + (t + (list + '(font . + "-adobe-courier-medium-r-normal--14-*")))) + ht-frame-parameter-mods + ) + ;; if we have X, we have ISO-Latin-1, so + ;; set char codes 128--255 to display as themselves. + (require 'disp-table) + (standard-display-8bit 161 255) ; (transient-mark-mode t) - ;; hightlight searching in bold - (setq search-highlight t) - (make-face 'isearch) - (copy-face 'bold 'isearch) + ;; hightlight searching in bold + (setq search-highlight t) + (make-face 'isearch) + (copy-face 'bold 'isearch) ; (set-face-underline-p 'region t) ; (set-face-background 'region "white") ; (set-face-foreground 'region "black") ; (setq c++-font-lock-keywords 'undef) ; (setq c-font-lock-keywords 'undef) - (modify-frame-parameters - nil - ht-frame-parameter-mods) - (setq default-frame-alist - (append - ht-frame-parameter-mods default-frame-alist)) - ;; fix cut and paste - (setq interprogram-paste-function nil - interprogram-cut-function nil) - (defun ht-mouse-set-region (click) "set region and primary selection" - (interactive "e") - (mouse-set-region click) - (x-set-selection "PRIMARY" (buffer-substring (point)(mark)))) - (defun ht-mouse-drag-region (click) - "drag region and set primary selection" - (interactive "e") - (mouse-drag-region click) - (if mark-active - (x-set-selection "PRIMARY" (buffer-substring (point)(mark))))) - (global-set-key [drag-mouse-1] (function ht-mouse-set-region)) - (global-set-key [down-mouse-1] (function ht-mouse-drag-region)) - (defun ht-mouse-insert-primary (click) - "set point and insert primary selection" - (interactive "e") - (mouse-set-point click) - (push-mark nil nil t) - (insert (x-selection))) - (global-set-key [mouse-2] (function ht-mouse-insert-primary)) - (setq dired-mode-hook - '(lambda () - (font-lock-mode 1) - (define-key dired-mode-map - [mouse-2] '(lambda (click) - (interactive "e") - (mouse-set-point click) - (dired-advertised-find-file))))) + (modify-frame-parameters + nil + ht-frame-parameter-mods) + (setq default-frame-alist + (append + ht-frame-parameter-mods default-frame-alist)) + ;; fix cut and paste + (setq interprogram-paste-function nil + interprogram-cut-function nil) + (defun ht-mouse-set-region (click) "set region and primary selection" + (interactive "e") + (mouse-set-region click) + (x-set-selection "PRIMARY" (buffer-substring (point)(mark)))) + (defun ht-mouse-drag-region (click) + "drag region and set primary selection" + (interactive "e") + (mouse-drag-region click) + (if mark-active + (x-set-selection "PRIMARY" (buffer-substring (point)(mark))))) + (global-set-key [drag-mouse-1] (function ht-mouse-set-region)) + (global-set-key [down-mouse-1] (function ht-mouse-drag-region)) + (defun ht-mouse-insert-primary (click) + "set point and insert primary selection" + (interactive "e") + (mouse-set-point click) + (push-mark nil nil t) + (insert (x-selection))) + (global-set-key [mouse-2] (function ht-mouse-insert-primary)) + (setq dired-mode-hook + '(lambda () + (font-lock-mode 1) + (define-key dired-mode-map + [mouse-2] '(lambda (click) + (interactive "e") + (mouse-set-point click) + (dired-advertised-find-file))))) - (defun ht-rooms-setup (&optional arg) - (interactive) - (require 'mail-extras) - (require 'diary) - (require 'my-news) - ;; 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)))) - (let ((scr (selected-frame))) - (load "ht-rooms.config" nil t) - (unwind-protect (make-frame-for-room "elisp" "-25" "-58")) - (unwind-protect (progn - (make-frame-for-room "news" "-50" "-40") - )) - (unwind-protect (progn - (make-frame-for-room "mail" "-75" "-22") - )) - (unwind-protect (progn - (make-frame-for-room - "diary" - "-0" - (concat - "+" - (format - "%d" - (- - (cdr - (assoc - 'top - (frame-parameters - (cdr - (assoc - "elisp" - frames-table))))) - 18)))) - )) - (make-frame-invisible scr)) - (setq ht-default-config (current-window-configuration)))))) - (setq sgml-insert-missing-element-comment nil) - (add-hook 'sgml-mode-hook 'sgml-fix-para) -) - ;; v18 emacs only goes here - (progn - (require 'compress) - (defun ht-rooms-setup (&optional arg) - (interactive) - (require 'mail-extras) - (require 'diary) - (require 'my-news) - (load "ht-rooms.config" nil t) - (setq ht-default-config (current-window-configuration))))) + (defun ht-rooms-setup (&optional arg) + (interactive) + (require 'mail-extras) + (require 'diary) + (require 'my-news) + ;; 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)))) + (let ((scr (selected-frame))) + (load "ht-rooms.config" nil t) + (unwind-protect (make-frame-for-room "elisp" "-25" "-58")) + (unwind-protect (progn + (make-frame-for-room "news" "-50" "-40") + )) + (unwind-protect (progn + (make-frame-for-room "mail" "-75" "-22") + )) + (unwind-protect (progn + (make-frame-for-room + "diary" + "-0" + (concat + "+" + (format + "%d" + (- + (cdr + (assoc + 'top + (frame-parameters + (cdr + (assoc + "elisp" + frames-table))))) + 18)))) + )) + (make-frame-invisible scr)) + (setq ht-default-config (current-window-configuration)))))) +(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) @@ -429,7 +405,64 @@ (call-process "netscape" nil 0 nil url))) (message "Sending URL to Netscape... done")) -(site-caseq (laptop (defun system-name () "francis.markup.co.uk"))) +;;; 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_ ! +) + +(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")))) +) (cd (user-home-directory))