Mercurial > hg > xemacs
changeset 78:0abfe9bf83a0
merge
| author | Henry S. Thompson <ht@inf.ed.ac.uk> |
|---|---|
| date | Thu, 25 Sep 2025 17:57:05 +0100 |
| parents | 62fb1a21629a (current diff) 0508101db40f (diff) |
| children | 4f01e4a447c6 |
| files | |
| diffstat | 21 files changed, 5586 insertions(+), 63 deletions(-) [+] |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/.hgignore Thu Sep 25 17:57:05 2025 +0100 @@ -0,0 +1,1 @@ +\.elc
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/device-type-hacking.el Thu Sep 25 17:57:05 2025 +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/diary.el Thu Sep 25 17:57:05 2025 +0100 @@ -0,0 +1,677 @@ +;; 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 arg) + "try to add a date to subject field if not already there, + move to diary on exit, + delete if n is absent, + move immediately w/o editing if marked. + Repeat for subsequent marked, if any" + (interactive "P") + (set-buffer gnus-summary-buffer) + (let* ((n (if arg (prefix-numeric-value arg))) + (no-delete (and n (> n 0))) + (neg (and n (< n 0))) + (no-edit (or gnus-newsgroup-processable neg))) + (let ((articles (gnus-summary-work-articles + (cond + (neg (- n)) + (gnus-newsgroup-processable nil) + (t 1)))) + article) + (when (and (not no-edit) + (/= (length articles) 1)) + (error "Editting multiple articles for diary not implemented yet")) + (while (setq article (pop articles)) + (gnus-edit-and-move-to-diary_1 no-delete no-edit) + (when (memq article gnus-newsgroup-processable) + (gnus-summary-remove-process-mark article))) + (if (and no-edit (not (gnus-summary-next-unread-article))) + (gnus-summary-exit))) + )) + +(defun gnus-edit-and-move-to-diary_1 (no-delete no-edit) + "try to add a date to subject field if not already there, + move to diary on exit, + delete if not no-delete, move immediately w/o editing if no-edit" + (let ((flush-shell nil)) + (when (and (not (and no-delete no-edit)) + (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 no-edit + (let ((hook `(lambda () + (ht-gnus-cease-edit ,no-delete)))) + (add-hook 'message-send-hook hook nil t) + (message-send-and-exit)) + (add-hook 'message-send-hook + `(lambda () + (ht-gnus-cease-edit ',no-delete ',flush-shell)) + 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") ".ics"))) + (find-file fn) + ;\nMETHOD:PUBLISH + (insert "BEGIN:VCALENDAR\nVERSION:1.0\nPRODID:-//Henry S. Thompson//gnus diary hack//EN\nBEGIN:VEVENT\n") + (insert "UID:")(insert uid)(insert "\n") + (insert "DTSTAMP:")(insert + (my-time-iso8601 (current-time))) + (insert "Z\n") + (insert "DTSTART:")(insert start)(insert "Z\n") + (insert "DTEND:")(insert end)(insert "Z\n") + (insert "SUMMARY:")(insert-encoded-maybe summary)(insert "\n") + (insert "DESCRIPTION")(insert-folded description) +; (insert "LOCATION")(insert-encoded-maybe location)(insert "\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/generic-extras.el Thu Sep 25 17:57:05 2025 +0100 @@ -0,0 +1,991 @@ +;;; generic-extras.el --- Extra Modes for generic-mode +;; +;; Author: Peter Breton <pbreton@i-kinetics.com> +;; Created: Tue Oct 08 1996 +;; Version: $Id$ +;; Keywords: +;; Time-stamp: <98/02/10 22:48:22 pbreton> +;; +;; Copyright (C) Peter Breton 01Nov96 +;; +;; This is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; generic-extras.el is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; +;; LCD Archive Entry: +;; generic-extras|Peter Breton|pbreton@i-kinetics.com| +;; Sample modes for 'generic-mode'| +;; 01-Nov-1996|1.0|~/misc/generic-extras.el.gz| +;; +;;; Commentary: +;; +;; This file contains some pre-defined generic-modes. +;; +;; INSTALLATION: +;; +;; Add this line to your .emacs file: +;; +;; (require 'generic-extras) +;; +;; You can decide which modes to load by setting the variable +;; 'generic-extras-enable-list'. Some platform-specific modes are +;; affected by the variables 'generic-define-mswindows-modes' and +;; 'generic-define-unix-modes' (which see). +;; +;; ALTERING THESE MODES: +;; +;; To alter the definition of these modes, use the 'alter-generic-mode-' +;; convenience functions defined in generic-mode.el. Each of these functions +;; takes an optional how-to-alter argument, which can be one of the following +;; symbols: 'overwrite, 'append, 'prepend. +;; +;; You can also send me new modes (I'll accept ones for file types which are +;; reasonably common) or patches to these ones. +;; +;; PROBLEMS WHEN USED WITH FOLDING MODE: +;; +;; From Anders Lindgren <andersl@csd.uu.se> +;; +;; Problem summary: Wayne Adams has found a problem when using folding +;; mode in conjuction with font-lock for a mode defined in +;; `generic-extras.el'. +;; +;; The problem, as Wayne described it, was that error messages of the +;; following form appeared when both font-lock and folding are used: +;; +;; > - various msgs including "Fontifying region...(error Stack +;; > overflow in regexp matcher)" appear +;; +;; I have just tracked down the cause of the problem. The regexp:s in +;; `generic-extras.el' does not take into account the way that folding +;; hides sections of the buffer. The technique is known as +;; `selective-display' and has been available for a very long time (I +;; started using it back in the good old' Emacs 18 days). Basically, a +;; section is hidden by creating one very long line were the newline +;; character (C-j) is replaced by a linefeed (C-m) character. +;; +;; Many other hiding packages, besides folding, use the same technique, +;; the problem should occur when using them as well. +;; +;; The erroronous lines in `generic-extras' look like the following (this +;; example is from the `ini' section): +;; +;; '(("^\\(\\[.*\\]\\)" 1 'font-lock-reference-face) +;; ("^\\(.*\\)=" 1 'font-lock-variable-name-face) +;; +;; The intention of these lines is to highlight lines of the following +;; form: +;; +;; [foo] +;; bar = xxx +;; +;; However, since the `.' regexp symbol match the linefeed character the +;; entire folded section is searched, resulting in a regexp stack +;; overflow. +;; +;; Solution suggestion 2: Instead of using ".", use the sequence +;; "[^\n\r]". This will make the rules behave just as before, but they +;; will work together with selective-display. +;; +;; +;;; Change log: +;; $Log$ +;; Revision 1.1 2008/04/19 18:10:28 ht +;; *** empty log message *** +;; +;; Revision 1.5 1998/02/11 03:44:32 pbreton +;; About to pull out generic-indent code +;; +;; Revision 1.4 1996/11/01 16:51:20 peter +;; Added GPL and LCD information. +;; +;; Revision 1.3 1996/10/19 12:22:07 peter +;; Added new versions of rc and rul modes +;; Regexp patches for generic-bat-mode +;; +;; Revision 1.2 1996/10/17 01:02:41 peter +;; Improved samba and apache modes +;; Added fvwm and x-resource modes +;; + +;;; Code: + +(require 'generic-mode) +(require 'font-lock) + +(defvar generic-extras-enable-list nil + "*List of generic modes to enable by default. +Each entry in the list should be a symbol. +The variables `generic-define-mswindows-modes' and `generic-define-unix-modes' +also affect which generic modes are defined") + +(defvar generic-define-mswindows-modes + (memq system-type (list 'windows-nt 'ms-dos)) + "*If non-nil, some MS-Windows specific generic modes will be defined.") + +(defvar generic-define-unix-modes + (not generic-define-mswindows-modes) + "*If non-nil, some Unix specific generic modes will be defined.") + +(if generic-define-mswindows-modes + (setq generic-extras-enable-list + (append (list 'bat-generic-mode 'ini-generic-mode + 'inf-generic-mode 'rc-generic-mode + 'reg-generic-mode 'rul-generic-mode) + generic-extras-enable-list))) + +(if generic-define-unix-modes + (setq generic-extras-enable-list + (append (list 'apache-generic-mode 'samba-generic-mode + 'hosts-generic-mode 'fvwm-generic-mode + 'x-resource-generic-mode + 'crontab-generic-mode) + generic-extras-enable-list))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Generic-modes +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Apache +(and + (memq 'apache-generic-mode generic-extras-enable-list) + +(define-generic-mode 'apache-generic-mode + (list ?#) + nil + '(("^\\(<.*>\\)" 1 'font-lock-reference-face) + ("^\\(\\sw+\\)\\s-" 1 'font-lock-variable-name-face)) + (list "srm\\.conf$" "httpd\\.conf$" "access\\.conf$") + nil + "Generic mode for Apache or HTTPD configuration files.")) + +;;; Samba +(and + (memq 'samba-generic-mode generic-extras-enable-list) + +(define-generic-mode 'samba-generic-mode + (list ?\;) + nil + '(("^\\(\\[.*\\]\\)" 1 'font-lock-reference-face)) + (list "smb\\.conf$") + (list 'generic-bracket-support) + "Generic mode for Samba configuration files.")) + +;;; Fvwm +;; This is pretty basic. Also, modes for other window managers could +;; be defined as well. +(and + (memq 'fvwm-generic-mode generic-extras-enable-list) + +(define-generic-mode 'fvwm-generic-mode + (list ?#) + (list "Style" "Function" "EndFunction" "Popup" "EndPopup") + nil + (list "\\.fvwmrc") + nil + "Generic mode for FVWM configuration files.")) + +;;; X Resource +;; I'm pretty sure I've seen an actual mode to do this, but I don't +;; think it's standard with Emacs +(and + (memq 'x-resource-generic-mode generic-extras-enable-list) + +(define-generic-mode 'x-resource-generic-mode + (list ?!) + nil + '(("^\\([^:\n]+:\\)" 1 'font-lock-variable-name-face)) + (list "\\.Xdefaults" "\\.Xresources") + nil + "Generic mode for X Resource configuration files.")) + +;;; Hosts +(and + (memq 'hosts-generic-mode generic-extras-enable-list) + +(define-generic-mode 'hosts-generic-mode + (list ?#) + (list "localhost") + '(("\\([0-9]+\.[0-9]+\.[0-9]+\.[0-9]+\\)" 1 'font-lock-reference-face)) + (list "[hH][oO][sS][tT][sS]$") + nil + "Generic mode for HOSTS files.")) + +;;; Windows INF files +(and + (memq 'inf-generic-mode generic-extras-enable-list) + +(define-generic-mode 'inf-generic-mode + (list ?\;) + nil + '(("^\\(\\[.*\\]\\)" 1 'font-lock-reference-face)) + (list "\\.[iI][nN][fF]") + (list 'generic-bracket-support) + "Generic mode for MS-Windows INF files.")) + +;;; Windows INI files +;; Should define escape character as well! +(and + (memq 'ini-generic-mode generic-extras-enable-list) + +(define-generic-mode 'ini-generic-mode + (list ?\;) + nil + '(("^\\(\\[.*\\]\\)" 1 'font-lock-reference-face) + ("^\\([^\n\r]*\\)=\\([^\n\r]*\\)$" + (1 font-lock-function-name-face) + (2 font-lock-variable-name-face))) + (list "\\.[iI][nN][iI]$") + (list + (function + (lambda () + (setq imenu-generic-expression + '((nil "^\\[\\(.*\\)\\]" 1) + ("*Variables*" "^\\s-*\\(.*\\)\\s-*=" 1))) + ))) + "Generic mode for MS-Windows INI files.")) + +;;; Windows REG files +;;; Unfortunately, Windows 95 and Windows NT have different REG file syntax! +(and + (memq 'reg-generic-mode generic-extras-enable-list) + +(define-generic-mode 'reg-generic-mode + '(?\;) + '("key" "classes_root" "REGEDIT" "REGEDIT4") + '(("\\(\\[.*]\\)" 1 'font-lock-reference-face) + ("^\\([^\n\r]*\\)\\s-*=" 1 'font-lock-variable-name-face)) + '("\\.[rR][eE][gG]$") + (list + (function + (lambda () + (setq imenu-generic-expression + '((nil "^\\s-*\\(.*\\)\\s-*=" 1)))))) + "Generic mode for MS-Windows Registry files.")) + +;;; Windows BAT files +(if (not (memq 'bat-generic-mode generic-extras-enable-list)) + nil +(define-generic-mode 'bat-generic-mode + nil + nil + (list + ;; Make this one first in the list, otherwise comments will + ;; be over-written by other variables + (list "^[@ \t]*\\([rR][eE][mM][^\n\r]*\\)" 1 'font-lock-comment-face t) + (list "^[ \t]*\\(::-.*\\)" 1 'font-lock-comment-face t) + ;; These keywords appear as the first word on a line + (generic-make-keywords-list + (list + "[cC][aA][lL][lL]" + "[eE][cC][hH][oO]" + "[fF][oO][rR]" + "[iI][fF]" + "[pP][aA][tT][hH]" + "[pP][aA][uU][sS][eE]" + "[pP][rR][oO][mM][pP][tT]" + "[sS][eE][tT]" + "[sS][tT][aA][rR][tT]" + ) + 'font-lock-keyword-face "^[@ \t]*") + ;; These keywords can be anywhere on a line + (generic-make-keywords-list + (list + "[eE][xX][iI][sS][tT]" + "[eE][rR][rR][oO][rR][lL][eE][vV][eE][lL]" + "[gG][oO][tT][oO]" + "[nN][oO][tT]" + ) 'font-lock-keyword-face) + (list "^[ \t]*\\(:\\sw+\\)" 1 'font-lock-function-name-face t) + (list "\\(%\\sw+%\\)" 1 'font-lock-reference-face) + (list "\\(%[0-9]\\)" 1 'font-lock-reference-face) + (list "\\(/[^/ \"\t\n]+\\)" 1 'font-lock-type-face) + (list "[\t ]+\\([+-][^\t\n\" ]+\\)" 1 'font-lock-type-face) + (list "\\<\\([gG][oO][tT][oO]\\)\\>[ \t]*\\(\\sw+\\)?" + '(1 font-lock-keyword-face) + '(2 font-lock-function-name-face nil t)) + + ) + (list "\\.[bB][aA][tT]$" "CONFIG\\." "AUTOEXEC\\." ) + (list 'generic-bat-mode-setup-function) + "Generic mode for MS-Windows BAT files.") + + (defvar bat-generic-mode-syntax-table nil + "Syntax table in use in bat-generic-mode buffers.") + + ;; Make underscores count as words + (if bat-generic-mode-syntax-table + nil + (setq bat-generic-mode-syntax-table (make-syntax-table)) + (modify-syntax-entry ?_ "w" bat-generic-mode-syntax-table)) + + ;; bat-generic-mode doesn't use the comment functionality of generic-mode + ;; because it has a three-letter comment-string, so we do it + ;; here manually instead + (defun generic-bat-mode-setup-function () + (make-local-variable 'parse-sexp-ignore-comments) + (make-local-variable 'comment-start) + (make-local-variable 'comment-start-skip) + (make-local-variable 'comment-end) + (setq imenu-generic-expression '((nil "^:\\(\\sw+\\)" 1)) + parse-sexp-ignore-comments t + comment-end "" + comment-start "[Rr][Ee][Mm] " + comment-start-skip "[Rr][Ee][Mm] *" + ) + (set-syntax-table bat-generic-mode-syntax-table) + ) + ) + +;;; Windows RC files +;; Contributed by ACorreir@pervasive-sw.com (Alfred Correira) +(and + (memq 'rc-generic-mode generic-extras-enable-list) + +(define-generic-mode 'rc-generic-mode +;; (list ?\/) + (list "//") + '("ACCELERATORS" + "AUTO3STATE" + "AUTOCHECKBOX" + "AUTORADIOBUTTON" + "BITMAP" + "CAPTION" + "CHARACTERISTICS" + "CHECKBOX" + "CLASS" + "COMBOBOX" + "CONTROL" + "CTEXT" + "CURSOR" + "DEFPUSHBUTTON" + "DIALOG" + "EDITTEXT" + "EXSTYLE" + "FONT" + "GROUPBOX" + "ICON" + "LANGUAGE" + "LISTBOX" + "LTEXT" + "MENUITEM SEPARATOR" + "MENUITEM" + "MENU" + "POPUP" + "PUSHBOX" + "PUSHBUTTON" + "RADIOBUTTON" + "RCDATA" + "RTEXT" + "SCROLLBAR" + "SEPARATOR" + "STATE3" + "STRINGTABLE" + "STYLE" + "VERSIONINFO" + "VERSION" + ) + ;; the choice of what tokens go where is somewhat arbitrary, + ;; as is the choice of which value tokens are included, as + ;; the choice of face for each token group + (list + (generic-make-keywords-list + (list + "FILEFLAGSMASK" + "FILEFLAGS" + "FILEOS" + "FILESUBTYPE" + "FILETYPE" + "FILEVERSION" + "PRODUCTVERSION" + ) 'font-lock-type-face) + (generic-make-keywords-list + (list + "BEGIN" + "BLOCK" + "END" + "VALUE" + ) 'font-lock-function-name-face) + '("^#[ \t]*include[ \t]+\\(<[^>\"\n]+>\\)" 1 font-lock-string-face) + '("^#[ \t]*define[ \t]+\\(\\sw+\\)(" 1 font-lock-function-name-face) + '("^#[ \t]*\\(elif\\|if\\)\\>" + ("\\<\\(defined\\)\\>[ \t]*(?\\(\\sw+\\)?" nil nil + (1 font-lock-reference-face) (2 font-lock-variable-name-face nil t))) + '("^#[ \t]*\\(\\sw+\\)\\>[ \t]*\\(\\sw+\\)?" + (1 font-lock-reference-face) (2 font-lock-variable-name-face nil t))) + (list "\\.[rR][cC]$") + nil + "Generic mode for MS-Windows Resource files.")) + +;;; InstallShield RUL files +;; Contributed by ACorreir@pervasive-sw.com (Alfred Correira) +;; Additional contributions by alex@brainstorm.fr (Alex Lemaresquier) +(and + (memq 'rul-generic-mode generic-extras-enable-list) + +(define-generic-mode 'rul-generic-mode + ;; Using "/*" and "*/" doesn't seem to be working right + (list "//") + '("begin" + "call" + "case" + "declare" + "default" + "downto" + "elseif" + "else" + "endfor" + "endif" + "endswitch" + "endwhile" + "end" + "exit" + "external" + "for" + "function" + ;; "goto" -- handled elsewhere + "if" + "program" + "prototype" + "repeat" + "return" + "step" + "switch" + "then" + "to" + "typedef" + "until" + "void" + "while") + (list + ;; preprocessor constructs + '("#[ \t]*include[ \t]+\\(<[^>\"\n]+>\\)" + 1 font-lock-string-face) + '("#[ \t]*\\(\\sw+\\)\\>[ \t]*\\(\\sw+\\)?" + (1 font-lock-reference-face) + (2 font-lock-variable-name-face nil t)) + ;; gotos + '("[ \t]*\\(\\sw+:\\)" 1 font-lock-reference-face) + '("\\<\\(goto\\)\\>[ \t]*\\(\\sw+\\)?" + (1 font-lock-keyword-face) + (2 font-lock-reference-face nil t)) + ;; system variables + (generic-make-keywords-list + (list + "CMDLINE" + "ERRORFILENAME" + "INFOFILENAME" + "ISRES" + "ISUSER" + "ISVERSION" + "SRCDIR" + "SRCDISK" + "SUPPORTDIR" + "TARGETDIR" + "TARGETDISK" + "WINDIR" + "WINDISK" + "WINMAJOR" + "WINSYSDIR" + "WINSYSDISK" + ) + 'font-lock-variable-name-face) + ;; system functions + (generic-make-keywords-list + (list + "AddFolderIcon" + "AppCommand" + "AskDestPath" + "AskOptions" + "AskPath" + "AskText" + "AskYesNo" + "CloseFile" + "CmdGetHwndDlg" + "CompressEnum" + "CompressGet" + "CopyFile" + "CreateDir" + "CreateProgramFolder" + "DeinstallStart" + "Delay" + "DeleteDir" + "DeleteFile" + "Disable" + "DoInstall" + "Do" + "Enable" + "EnterDisk" + "ExistsDir" + "EzDefineDialog" + "FindFile" + "FindWindow" + "FileCompare" + "FileSetBeginDefine" + "FileSetEndDefine" + "FileSetPerformEz" + "FileSetPerform" + "GetDiskSpace" + "GetDisk" + "GetExtents" + "GetProfString" + "GetSystemInfo" + "GetVersion" + "GetWindowHandle" + "InstallationInfo" + "Is" + "LaunchApp" + "ListCreate" + "ListDestroy" + "ListGetFirstString" + "ListGetNextString" + "ListSetIndex" + "LongPathToQuote" + "LongPathToShortPath" + "MessageBox" + "NumToStr" + "OpenFile" + "ParsePath" + "PlaceBitmap" + "PlaceWindow" + "ProgDefGroupType" + "RegDBCreateKeyEx" + "RegDBGetItem" + "RegDBSetItem" + "RegDBGetKeyValueEx" + "RegDBSetKeyValueEx" + "RegDBSetDefaultRoot" + "RenameFile" + "SdSelectFolder" + "SdShowMsg" + "SdWelcome" + "SetColor" + "SetDialogTitle" + "SetFileInfo" + "SetForegroundWindow" + "SetStatusWindow" + "SetTitle" + "ShowProgramFolder" + "Sprintf" + "StatusUpdate" + "StrCompare" + "StrFind" + "StrGetTokens" + "StrLength" + "StrRemoveLastSlash" + "StrToLower" + "StrToUpper" + "StrSub" + "VarRestore" + "VarSave" + "WaitOnDialog" + "Welcome" + "XCopyFile" + ) + 'font-lock-function-name-face) + ;; type keywords + (generic-make-keywords-list + (list + "BOOL" + "BYREF" + "CHAR" + "HIWORD" + "HWND" + "INT" + "LIST" + "LONG" + "LOWORD" + "NUMBER" + "POINTER" + "QUAD" + "RGB" + "SHORT" + "STRINGLIST" + "STRING" + ) + 'font-lock-type-face) + ;;; system variables + (generic-make-keywords-list + (list + "CMDLINE" + "ERRORFILENAME" + "INFOFILENAME" + "ISRES" + "ISUSER" + "ISVERSION" + "SRCDIR" + "SRCDISK" + "SUPPORTDIR" + "TARGETDIR" + "TARGETDISK" + "WINDIR" + "WINDISK" + "WINSYSDIR" + "WINSYSDISK" + ) + 'font-lock-variable-name-face) + ;; pre-defined constants (not exhaustive -- just my favorites) + (generic-make-keywords-list + (list + "AFTER" + "APPEND" + "BACKGROUNDCAPTION" + "BACKGROUND" + "BACK" + "BEFORE" + "BK_BLUE" + "BK_GREEN" + "BK_RED" + "CANCEL" + "COMMANDEX" + "COMMAND" + "CONTINUE" + "DEFWINDOWMODE" + "DISABLE" + "DLG_ERR" + "ENABLE" + "END_OF_LIST" + "EXCLUSIVE" + "EXISTS" + "EXIT" + "FAILIFEXISTS" + "FALSE" + "FULL" + "INDVFILESTATUS" + "INFORMATION" + "LIST_NULL" + "LISTFIRST" + "LISTNEXT" + "LOGGING" + "NEXT" + "NONEXCLUSIVE" + "NOSET" + "NO" + "OFF" + "ON" + "PARTIAL" + "REPLACE_ITEM" + "REPLACE" + "RESET" + "RESTART" + "SET" + "SEVERE" + "SRCTARGETDIR" + "STATUS" + "TRUE" + "YES" + "WARNING" + ) + 'font-lock-variable-name-face) ; is this face the best choice? + ) + (list "\\.[rR][uU][lL]$") + (list + (function + (lambda () + (setq imenu-generic-expression + '((nil "^function\\s-+\\([A-Za-z0-9_]+\\)" 1))) + ))) + "Generic mode for InstallShield RUL files") + +(define-skeleton rul-if + "Insert an if statement." + "condition: " + "if(" str ") then" \n + > _ \n + ( "other condition, %s: " + > "elseif(" str ") then" \n + > \n) + > "else" \n + > \n + resume: + > "endif;" + ) + +(define-skeleton rul-function + "Insert a function statement." + "function: " + "function " str " ()" \n + ( "local variables, %s: " + > " " str ";" \n) + > "begin" \n + > _ \n + resume: + > "end;") + +) + +;;; Info-Mac abstracts +;; Contributed by Jacques Duthen Prestataire (duthen@cegelec-red.fr) +;; +;; For an example of such a file, you can download (the small): +;; http://hyperarchive.lcs.mit.edu/HyperArchive/Archive/_Font/00font-abstracts.txt +(and + (memq 'info-mac-abstract-generic-mode generic-extras-enable-list) + +(define-generic-mode 'info-mac-abstract-generic-mode + () + (list "Date" "From" "Subject") + '(("^#### [^\n\r]*" . font-lock-function-name-face)) + (list "00.*-abstracts\\.txt") + nil + "Generic mode for info-mac abstract files.")) + +;;; Mailagent +;; Mailagent is a Unix mail filtering program. Anyone wanna do a generic mode +;; for procmail? +(and + (memq 'mailagent-rules-generic-mode generic-extras-enable-list) + +(define-generic-mode 'mailagent-rules-generic-mode + (list ?#) + (list "SAVE" "DELETE" "PIPE" "ANNOTATE" "REJECT") + '(("^\\(\\sw+\\)\\s-*=" 1 'font-lock-variable-name-face) + ("\\s-/\\([^/]+\\)/[i, \t\n]" 1 'font-lock-reference-face)) + (list "\\.rules$") + (list 'mailagent-rules-setup-function) + "Mode for Mailagent rules files.") + +(defun mailagent-rules-setup-function () + (make-local-variable 'imenu-generic-expression) + (setq imenu-generic-expression + '((nil "\\s-/\\([^/]+\\)/[i, \t\n]" 1)))) + ) + +;;; Crontab +;; I didn't write this, I only adapted it for generic-mode +;; If anyone knows who wrote it originally, I'd be glad to credit them +(and + (memq 'crontab-generic-mode generic-extras-enable-list) + +(define-generic-mode 'crontab-generic-mode + (list ?#) + nil + (list + (list + (concat "^\\(" + ;; Repeated 5 times for minute, hour, day of month, + ;; month and day of week fields + (mapconcat 'identity (make-list 5 "[*0-9,]+[ \t]+") "") + "\\)\\([^\n\r]*\\)") + (list 1 'font-lock-reference-face) + (list 2 'font-lock-function-name-face))) + nil + (list 'crontab-setup-function) + "Mode for Crontab files.") + +(defun crontab-setup-function () + (local-set-key "\C-c\C-c" 'crontab-update) + (local-set-key "\C-x\C-s" 'crontab-update) + ) + +(defun crontab () + "Edit a crontab file. +Type \\[save-buffer] to feed the buffer to the crontab command." + (interactive) + (switch-to-buffer "*Crontab*") + (erase-buffer) + (message "Reading crontab file ... ")(sit-for 0) ; redisplay + (if (eq (call-process-region (point) (point) "crontab" nil t t "-l") 0) + (message "Reading crontab file ... done") + (message "No crontab file") + (erase-buffer) + (insert "#min hour dom mon dow (0=Sun) cmd\n")) + (set-buffer-modified-p nil) + (crontab-generic-mode)) + +(defun crontab-update () + "Use the current buffer to update the crontab file." + (interactive) + (message "Updating crontab file ... ")(sit-for 0) ; redisplay + (shell-command-on-region (point-min) (point-max) "crontab" nil) + (message "Updating crontab file ... done") + (set-buffer-modified-p nil)) + ) + +;; Contributed by Jacques Duthen Prestataire (duthen@cegelec-red.fr) +(and + (memq 'ps-generic-mode generic-extras-enable-list) + +(define-generic-mode 'ps-generic-mode + () ;; (list ?%) would not permit to differentiate DSC comments. + (list "def" "if" "ifelse" "forall") ; some keywords + '(("^%%[^ \n]*" . font-lock-reference-face) ; DSC comments + ("^/[^ \n]*" . font-lock-function-name-face) ; func or glob var def + ("%.*" . font-lock-comment-face) ; normal comments + ("(.*)" . font-lock-string-face) ; ps strings + ("/[^ \n]*" . font-lock-variable-name-face) ; symbols + ) + (list "\\.ps") ;; extension of Postscript files + nil ;; no hook + "Generic mode for PostScript files") + ) + +;; Solaris/Sys V prototype files +(and + (memq 'prototype-generic-mode generic-extras-enable-list) + +(define-generic-mode 'prototype-generic-mode + (list ?#) + nil + '( + ("^\\([0-9]\\)?\\s-*\\([a-z]\\)\\s-+\\([A-Za-z_]+\\)\\s-+\\([^\n\r]*\\)$" + (2 font-lock-reference-face) + (3 font-lock-keyword-face)) + ("^\\([a-z]\\) \\([A-Za-z_]+\\)=\\([^\n\r]*\\)$" + (1 font-lock-reference-face) + (2 font-lock-keyword-face) + (3 font-lock-variable-name-face)) + ("^\\(!\\s-*\\(search\\|include\\|default\\)\\)\\s-*\\([^\n\r]*\\)$" + (1 font-lock-keyword-face) + (3 font-lock-variable-name-face)) + ("^\\(!\\s-*\\sw+\\)=\\([^\n\r]*\\)$" + (1 font-lock-keyword-face) + (2 font-lock-variable-name-face)) + ) + (list "prototype$") + nil + "Mode for Sys V prototype files")) + +;; Solaris/Sys V pkginfo files +(and + (memq 'pkginfo-generic-mode generic-extras-enable-list) + +(define-generic-mode 'pkginfo-generic-mode + (list ?#) + nil + '( + ("^\\([A-Za-z_]+\\)=\\([^\n\r]*\\)$" + (1 font-lock-keyword-face) + (2 font-lock-variable-name-face)) + ) + (list "pkginfo$") + nil + "Mode for Sys V pkginfo files")) + +(define-generic-mode 'javascript-generic-mode + (list "//") + (list + "document" + "else" + "function" + "function" + "if" + "then" + "var" + ) + (list + (list "^\\s-*function\\s-+\\([A-Za-z0-9]+\\)" + '(1 font-lock-function-name-face)) + (list "^\\s-*var\\s-+\\([A-Za-z0-9]+\\)" + '(1 font-lock-variable-name-face)) + ) + (list "\\.js$") + (list + (function + (lambda () + (setq imenu-generic-expression + '((nil "^function\\s-+\\([A-Za-z0-9_]+\\)" 1))) + ))) + "Mode for JavaScript files.") + +(define-generic-mode 'vrml-generic-mode + (list ?#) + (list + "DEF" + "NULL" + "USE" + "Viewpoint" + "ambientIntensity" + "appearance" + "children" + "color" + "coord" + "coordIndex" + "creaseAngle" + "diffuseColor" + "emissiveColor" + "fieldOfView" + "geometry" + "info" + "material" + "normal" + "orientation" + "position" + "shininess" + "specularColor" + "texCoord" + "texture" + "textureTransform" + "title" + "transparency" + "type" + ) + (list + (list "USE\\s-+\\([-A-Za-z0-9_]+\\)" + '(1 font-lock-reference-face)) + (list "DEF\\s-+\\([-A-Za-z0-9_]+\\)\\s-+\\([A-Za-z0-9]+\\)\\s-*{" + '(1 font-lock-type-face) + '(2 font-lock-reference-face)) + (list "^\\s-*\\([-A-Za-z0-9_]+\\)\\s-*{" + '(1 font-lock-function-name-face)) + (list + "^\\s-*\\(geometry\\|appearance\\|material\\)\\s-+\\([-A-Za-z0-9_]+\\)" + '(2 font-lock-variable-name-face)) + ) + (list "\\.wrl$") + (list + (function + (lambda () + (setq imenu-generic-expression + '((nil "^\\([A-Za-z0-9_]+\\)\\s-*{" 1) + ("*Definitions*" + "DEF\\s-+\\([-A-Za-z0-9_]+\\)\\s-+\\([A-Za-z0-9]+\\)\\s-*{" + 1))) + ))) + "Generic Mode for VRML files.") + +(define-generic-mode 'mailrc-generic-mode + (list ?#) + (list "alias" "group" "set") + '(("^\\s-*\\(alias\\|group\\)\\s-+\\([-A-Za-z0-9_]+\\)\\s-+\\([^\n\r]*\\)$" + (2 font-lock-reference-face) (3 font-lock-variable-name-face)) + ("^\\s-*set\\s-+\\([-A-Za-z0-9_]+\\)=\\([^\n\r]*\\)$" + (1 font-lock-reference-face) (2 font-lock-variable-name-face))) + (list "\\.mailrc$") + nil + "Mode for mailrc files") + +(define-generic-mode 'java-manifest-generic-mode + (list ?#) + (list "Name" + "Digest-Algorithms" + "Manifest-Version" + "Required-Version" + "Signature-Version" + "Magic") + '(("^Name:\\s-+\\([^\n\r]*\\)$" + (1 font-lock-variable-name-face)) + ("^\\(Manifest\\|Required\\|Signature\\)-Version:\\s-+\\([^\n\r]*\\)$" + (2 font-lock-reference-face)) + ) + (list "manifest\\.mf$") + nil + "Mode for Java Manifest files") + +(provide 'generic-extras) + +;;; generic-extras.el ends here + +;; Local Variables: +;; autocompile: t +;; End:
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/generic-mode.el Thu Sep 25 17:57:05 2025 +0100 @@ -0,0 +1,726 @@ +;;; generic-mode.el --- A meta-mode which makes it easy to create small +;; modes with basic comment and font-lock support +;; +;; Author: Peter Breton +;; Created: Fri Sep 27 1996 +;; Version: $Header$ +;; Keywords: generic, comment, font-lock +;; Time-stamp: <97/03/25 10:10:19 pbreton> +;; +;; Copyright (C) Peter Breton 01Nov96 +;; +;; This is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; generic-mode.el is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; +;; LCD Archive Entry: +;; generic-mode|Peter Breton|pbreton@i-kinetics.com| +;; Meta-mode to create small modes with basic comment and font-lock support| +;; 01-Nov-1996|1.0|~/misc/generic-mode.el.gz| +;; +;; Purpose: +;; +;; Meta-mode to create small modes with basic comment and font-lock support +;; +;;; Commentary: +;; +;; INTRODUCTION: +;; +;; Generic-mode is a meta-mode which can be used to define small modes +;; which provide basic comment and font-lock support. These modes are +;; intended for the many configuration files and such which are too small +;; for a "real" mode, but still have a regular syntax, comment characters +;; and the like. +;; +;; Each generic mode can define the following: +;; +;; * List of comment-characters. The entries in this list should be +;; either a character, a one or two character string or a cons pair. +;; If the entry is a character or a one-character string +;; LIMITATIONS: Emacs does not support comment strings of more than +;; two characters in length. +;; +;; * List of keywords to font-lock. Each keyword should be a string. +;; If you have additional keywords which should be highlighted in a face +;; different from 'font-lock-keyword-face', you can use the convenience +;; function 'generic-make-keywords-list' (which see), and add the +;; result to the following list: +;; +;; * Additional expressions to font-lock. This should be a list of +;; expressions, each of which should be of the same form +;; as those in 'font-lock-defaults-alist'. +;; +;; * List of regular expressions to be placed in auto-mode-alist. +;; +;; * List of functions to call to do some additional setup +;; +;; This should pretty much cover basic functionality; if you need much +;; more than this, or you find yourself writing extensive customizations, +;; perhaps you should be writing a major mode instead! +;; +;; INSTALLATION: +;; +;; Place the following in your .emacs file: +;; +;; (require 'generic-mode) +;; +;; If you want to use some pre-defined generic modes, add: +;; +;; (require 'generic-extras) +;; +;; Loading these generic modes will cause some new entries to be placed in +;; your auto-mode-alist. See 'generic-extras.el' for details. +;; +;; LOCAL VARIABLES: +;; +;; To put a file into generic mode using local variables, use a line +;; like this in a Local Variables block: +;; +;; mode: default-generic +;; +;; Do NOT use "mode: generic"! +;; See also "AUTOMATICALLY ENTERING GENERIC MODE" below. +;; +;; DEFINING NEW GENERIC MODES: +;; +;; Use the 'define-generic-mode' function to define new modes. +;; For example: +;; +;; (require 'generic-mode) +;; (define-generic-mode 'foo-generic-mode +;; (list ?% ) +;; (list "keyword") +;; nil +;; (list "\.FOO") +;; (list 'foo-setup-function)) +;; +;; defines a new generic-mode 'foo-generic-mode', which has '%' as a +;; comment character, and "keyword" as a keyword. When files which end in +;; '.FOO' are loaded, Emacs will go into foo-generic-mode and call +;; foo-setup-function. You can also use the function 'foo-generic-mode' +;; (which is interactive) to put a buffer into foo-generic-mode. +;; +;; ALTERING EXISTING MODES: +;; +;; To alter an existing generic-mode, use the convenience functions: +;; +;; (alter-generic-mode-comments MODE COMMENT-LIST HOW-TO-ALTER) +;; (alter-generic-mode-keywords MODE KEYWORD-LIST HOW-TO-ALTER) +;; (alter-generic-mode-font-lock MODE FONT-LOCK-LIST HOW-TO-ALTER) +;; (alter-generic-mode-auto-mode MODE AUTO-MODE-LIST HOW-TO-ALTER) +;; (alter-generic-mode-functions MODE FUNCTION-LIST HOW-TO-ALTER) +;; +;; HOW-TO-ALTER should be one of the following symbols: 'append, 'prepend, +;; or 'overwrite. If it is omitted, 'append is assumed. +;; +;; AUTOMATICALLY ENTERING GENERIC MODE: +;; +;; Generic-mode provides a hook which automatically puts a +;; file into default-generic-mode if the first few lines of a file in +;; fundamental mode start with a hash comment character. To disable +;; this functionality, set the variable 'generic-use-find-file-hook' +;; to nil BEFORE loading generic-mode. See the variables +;; 'generic-lines-to-scan' and 'generic-find-file-regexp' for customization +;; options. +;; +;; GOTCHAS: +;; +;; Be careful that your font-lock definitions are correct. Getting them +;; wrong can cause emacs to continually attempt to fontify! This problem +;; is not specific to generic-mode. +;; + +;; Credit for suggestions, brainstorming, patches and bug-fixes: +;; ACorreir@pervasive-sw.com (Alfred Correira) + +;;; Change log: +;; $Log$ +;; Revision 1.1 2008/04/19 18:10:28 ht +;; *** empty log message *** +;; +; Revision 1.2 1997/04/02 07:02:38 voelker +; *** empty log message *** +; +;; Revision 1.6 1996/11/01 17:27:47 peter +;; Changed the function generic-function-name to return a string instead +;; of a symbol. Generic-mode now uses this for the mode's name +;; +;; Revision 1.5 1996/11/01 16:45:20 peter +;; Added GPL and LCD information. +;; Updated documentation +;; Added generic-find-file-regexp variable +;; Added generic-make-keywords-list function +;; +;; Revision 1.4 1996/10/19 12:16:59 peter +;; Small bug fixes: fontlock -> font-lock +;; New entries are added to the end of auto-mode-alist +;; Generic-font-lock-defaults are set to nil, not (list nil) +;; Comment-regexp in generic-mode-find-file-hook changed to allow optional +;; blank lines +;; +;; Revision 1.3 1996/10/17 08:24:25 peter +;; Added generic-mode-find-file-hook and associated variables +;; +;; Revision 1.2 1996/10/17 01:00:45 peter +;; Moved from a data-centered approach (generic-mode-alist) to +;; a function-based one (define-generic-mode) +;; +;; Revision 1.1 1996/10/10 11:37:36 peter +;; Initial revision +;; + +;;; Code: + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Variables +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(make-variable-buffer-local +(defvar generic-font-lock-defaults nil + "Global defaults for font-lock in a generic mode.")) + +(make-variable-buffer-local +(defvar generic-mode-name 'default-generic-mode + "The name of the generic mode. +This is the car of one of the items in `generic-mode-alist'. +This variable is buffer-local.")) + +(make-variable-buffer-local +(defvar generic-comment-list nil + "List of comment characters for a generic mode.")) + +(make-variable-buffer-local +(defvar generic-keywords-list nil + "List of keywords for a generic mode.")) + +(make-variable-buffer-local +(defvar generic-font-lock-expressions nil + "List of font-lock expressions for a generic mode.")) + +(make-variable-buffer-local +(defvar generic-mode-function-list nil + "List of customization functions to call for a generic mode.")) + +(make-variable-buffer-local +(defvar generic-mode-syntax-table nil + "Syntax table for use in a generic mode.")) + +(defvar generic-mode-alist nil + "An association list for generic-mode. +Each entry in the list looks like this: + + NAME COMMENT-LIST KEYWORD-LIST FONT-LOCK-LIST AUTO-MODE-LIST FUNCTION-LIST. + +Do not add entries to this list directly; use `define-generic-mode' +instead (which see). + +To alter an already existing generic-mode, use +one of the `alter-generic-mode-' convenience functions (which see)" +) + +(defvar generic-use-find-file-hook t + "*If non-nil, add a hook to enter default-generic-mode automatically +if the first few lines of a file in fundamental mode start with a hash +comment character.") + +(defvar generic-lines-to-scan 3 + "*Number of lines that `generic-mode-find-file-hook' looks at +when deciding whether to enter generic-mode automatically. +This variable should be set to a small positive number.") + +(defvar generic-find-file-regexp "#.*\n\\(.*\n\\)?" + "*Regular expression used by `generic-mode-find-file-hook' +to determine if files in fundamental mode should be put into +`default-generic-mode' instead.") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Inline functions +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defsubst generic-read-type () + (completing-read + "Generic Type: " + (mapcar + '(lambda (elt) (list (symbol-name (car elt)))) + generic-mode-alist) nil t)) + +;; Basic sanity checks. It does *not* check whether the elements of the lists +;; are of the correct type. +(defsubst generic-mode-sanity-check (name comment-list keyword-list + font-lock-list auto-mode-list + function-list &optional description) + (if (not (symbolp name)) + (error "%s is not a symbol" (princ name))) + + (mapcar '(lambda (elt) + (if (not (listp elt)) + (error "%s is not a list" (princ elt)))) + (list comment-list keyword-list font-lock-list + auto-mode-list function-list)) + + (if (not (or (null description) (stringp description))) + (error "Description must be a string or nil")) +) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Functions +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;;### autoload +(defun define-generic-mode (name comment-list keyword-list font-lock-list + auto-mode-list function-list + &optional description) + "Create a new generic mode with NAME. +NAME should be a symbol; its string representation is used as the function +name. If DESCRIPTION is provided, it is used as the docstring for the new +function. + +COMMENT-LIST is a list, whose entries are either a single character, +a one or two character string or a cons pair. If the entry is a character +or a one-character string, it is added to the mode's syntax table with +comment-start syntax. If the entry is a cons pair, the elements of the +pair are considered to be comment-start and comment-end respectively. +Note that Emacs has limitations regarding comment characters. + +KEYWORD-LIST is a list of keywords to highlight with `font-lock-keyword-face'. +Each keyword should be a string. + +FONT-LOCK-LIST is a list of additional expressions to highlight. Each entry +in the list should have the same form as an entry in `font-lock-defaults-alist' + +AUTO-MODE-LIST is a list of regular expressions to add to auto-mode-alist. +These regexps are added to auto-mode-alist as soon as `define-generic-mode' +is called; any old regexps with the same name are removed. To modify the +auto-mode-alist expressions, use `alter-generic-mode-auto-mode' (which see). + +FUNCTION-LIST is a list of functions to call to do some additional setup. + +See the file generic-extras.el for some examples of `define-generic-mode'." + + ;; Basic sanity check + (generic-mode-sanity-check name + comment-list keyword-list font-lock-list + auto-mode-list function-list description) + + ;; Remove any old entry + (setq generic-mode-alist + (delq (assq name generic-mode-alist) + generic-mode-alist)) + + ;; Add a new entry + (setq generic-mode-alist + (append + (list + (list + name comment-list keyword-list font-lock-list + auto-mode-list function-list + )) + generic-mode-alist)) + + ;; Add it to auto-mode-alist + (generic-add-to-auto-mode name auto-mode-list t) + + ;; Define a function for it + (generic-create-generic-function name description) + ) + +(defun generic-add-to-auto-mode (mode auto-mode-list + &optional remove-old prepend) + "Add the entries for mode to `auto-mode-alist'. +If remove-old is non-nil, removes old entries first. If prepend is +non-nil, prepends entries to auto-mode-alist; otherwise, appends them." + + (if (not (listp auto-mode-list)) + (error "%s is not a list" (princ auto-mode-list))) + + (let ((new-mode (intern (symbol-name mode)))) + (if remove-old + (let ((auto-mode-entry)) + (while (setq auto-mode-entry (rassq new-mode auto-mode-alist)) + (setq auto-mode-alist + (delq auto-mode-entry + auto-mode-alist))))) + + (mapcar '(lambda (entry) + (generic-add-auto-mode-entry new-mode entry prepend)) + auto-mode-list))) + +(defun generic-add-auto-mode-entry (name entry &optional prepend) + "Add a new entry to the end of auto-mode-alist. +If prepend is non-nil, add the entry to the front of the list." + (let ((new-entry (list (cons entry name)))) + (setq auto-mode-alist + (if prepend + (append new-entry auto-mode-alist) + (append auto-mode-alist new-entry))))) + +(defun generic-create-generic-function (name &optional description) + "Create a generic mode function with NAME. +If DESCRIPTION is provided, it is used as the docstring." + (let ((symname (symbol-name name))) + (fset (intern symname) + (list 'lambda nil + (or description + (concat "Generic mode for type " symname)) + (list 'interactive) + (list 'generic-mode-with-type (list 'quote name)))))) + +(defun generic-mode-with-type (&optional mode) + "Go into the generic-mode MODE." + (let* ((type (or mode generic-mode-name)) + (generic-mode-list (assoc type generic-mode-alist)) + ) + + (if (not generic-mode-list) + (error "Can't find generic-mode information for type %s" + (princ generic-mode-name))) + + ;; Put this after the point where we read generic-mode-name! + (kill-all-local-variables) + + (setq + generic-mode-name type + generic-comment-list (nth 1 generic-mode-list) + generic-keywords-list (nth 2 generic-mode-list) + generic-font-lock-expressions (nth 3 generic-mode-list) + generic-mode-function-list (nth 5 generic-mode-list) + major-mode 'generic-mode + mode-name (symbol-name type) + ) + + (generic-mode-set-comments generic-comment-list) + + ;; Font-lock functionality + ;; Font-lock-defaults are always set even if there are no keywords + ;; or font-lock expressions, so comments can be highlighted. + (setq generic-font-lock-defaults nil) + (generic-mode-set-font-lock generic-keywords-list + generic-font-lock-expressions) + (make-local-variable 'font-lock-defaults) + (setq font-lock-defaults (list 'generic-font-lock-defaults nil)) + + ;; Call a list of functions + (if generic-mode-function-list + (mapcar 'funcall generic-mode-function-list)) + ) + ) + +;;;###autoload +(defun generic-mode (type) + "A mode to do basic comment and font-lock functionality +for files which are too small to warrant their own mode, but have +comment characters, keywords, and the like. + +To define a generic-mode, use the function `define-generic-mode'. +To alter an existing generic-mode, use the `alter-generic-mode-' +convenience functions. +Some generic modes are defined in generic-extras.el" + (interactive + (list (generic-read-type))) + (generic-mode-with-type (intern type))) + +;;; Comment Functionality +(defun generic-mode-set-comments (comment-list) + "Set up comment functionality for generic mode." + (if (null comment-list) + nil + (let ((generic-mode-syntax-table (make-syntax-table))) + (make-local-variable 'comment-start) + (make-local-variable 'comment-start-skip) + (make-local-variable 'comment-end) + (mapcar 'generic-mode-set-a-comment comment-list) + (set-syntax-table generic-mode-syntax-table)))) + +(defun generic-mode-set-a-comment (comment) + (and (char-or-string-p comment) + (if (stringp comment) + (cond + ((eq (length comment) 1) + (generic-mode-set-comment-char + (string-to-char comment))) + ((eq (length comment) 2) + (generic-mode-set-comment-string comment)) + (t + (error "Character string %s must be one or two characters long" + comment)) + ) + (generic-mode-set-comment-char comment))) + (if (consp comment) + (generic-mode-set-comment-pair comment))) + +(defun generic-mode-set-comment-char (comment-char) + "Set the given character as a comment character for generic mode." + (if (not comment-char) + nil + (setq + comment-end "" + comment-start (char-to-string comment-char) + comment-start-skip (concat comment-start "+ *") + ) + + (modify-syntax-entry comment-char "<" + generic-mode-syntax-table) + (modify-syntax-entry ?\n ">" + generic-mode-syntax-table))) + +(defun generic-mode-set-comment-string (comment-string) + "Set the given string as a comment string for generic mode." + (if (not comment-string) + nil + (setq + comment-end "" + comment-start comment-string + comment-start-skip (concat comment-start " *") + ) + + (let ((first (elt comment-string 0)) + (second (elt comment-string 1))) + ;; C++ style comments + (if (char-equal first second) + (progn + (modify-syntax-entry first "<12b" + generic-mode-syntax-table) + (modify-syntax-entry ?\n ">b" + generic-mode-syntax-table))) + ;; Some other two character string + (modify-syntax-entry first "<1" + generic-mode-syntax-table) + (modify-syntax-entry second "<2" + generic-mode-syntax-table) + (modify-syntax-entry ?\n ">" + generic-mode-syntax-table)))) + +(defun generic-mode-set-comment-pair (comment-pair) + "Set the given comment pair as a comment start and end for generic mode." + (let ((generic-comment-start (car comment-pair)) + (generic-comment-end (cdr comment-pair)) + ) + (setq + comment-end generic-comment-end + comment-start generic-comment-start + comment-start-skip (concat generic-comment-start " *") + ) + + ;; Sanity checks + (if (not (and (stringp generic-comment-start) + (stringp generic-comment-end))) + (error "Elements of cons pair must be strings")) + (if (not (and (equal (length generic-comment-start) 2) + (equal (length generic-comment-end) 2))) + (error "Start and end must be exactly two characters long")) + + (let ((first (elt generic-comment-start 0)) + (second (elt generic-comment-start 1)) + (third (elt generic-comment-end 0)) + (fourth (elt generic-comment-end 1)) + ) + + (modify-syntax-entry first ". 1" generic-mode-syntax-table) + (modify-syntax-entry second ". 2" generic-mode-syntax-table) + + (modify-syntax-entry + third + (concat + "." + (cond + ((char-equal first third) " 13") + ((char-equal second third) " 23") + (t " 3")) + ) + generic-mode-syntax-table) + + (modify-syntax-entry + fourth + (concat + "." + (cond + ((char-equal first fourth) " 14") + ((char-equal second fourth) " 24") + (t " 4")) + ) + generic-mode-syntax-table) + ))) + +(defun generic-mode-set-font-lock (keywords font-lock-expressions) + "Set up font-lock functionality for generic mode." + (let ((generic-font-lock-expressions)) + ;; Keywords + (if keywords + (setq + generic-font-lock-expressions + (append + (list + (list + (concat + "\\(\\<" + (mapconcat 'identity keywords "\\>\\|\\<") + "\\>\\)") + 1 'font-lock-keyword-face)) + generic-font-lock-expressions))) + ;; Other font-lock expressions + (if font-lock-expressions + (setq generic-font-lock-expressions + (append + font-lock-expressions + generic-font-lock-expressions))) + (if (not (or font-lock-expressions keywords)) + nil + (setq generic-font-lock-defaults generic-font-lock-expressions)) + )) + +(defun alter-generic-mode (mode alter-list &optional how-to-alter) + "Alter the specified generic mode. +How-to-alter, if specified, should be one of the following symbols: +`append', `prepend', `overwrite'. The default is `append'." + (let ((generic-mode-list (assoc mode generic-mode-alist)) + (item-number 0) + (current-elt) + (current-list) + (alter-elt) + (alter-method (or how-to-alter 'append)) + ) + (if (not generic-mode-list) + (error "Can't find generic-mode information for type %s" + (princ mode))) + ;; Ignore the name + (setq generic-mode-list (cdr generic-mode-list)) + (while (< item-number (length alter-list)) + (setq current-list (nthcdr item-number generic-mode-list) + current-elt (nth item-number generic-mode-list) + alter-elt (nth item-number alter-list)) + (cond + ;; Ignore items with value t + ((eq alter-elt 't) + nil) + ((eq alter-method 'overwrite) + (setcar current-list alter-elt)) + ((eq alter-method 'prepend) + (setcar current-list (append alter-elt current-elt))) + ((eq alter-method 'append) + (setcar current-list (append current-elt alter-elt))) + (t + (error "Optional argument %s not understood" (princ alter-method)))) + (setq item-number (1+ item-number)) + ) + ) + ) + +;; Convenience functions +(defun alter-generic-mode-comments (mode comment-list &optional how-to-alter) + "Alter comments in the specified generic mode. +How-to-alter, if specified, should be one of the following symbols: +`append', `prepend', `overwrite'. The default is `append'." + (alter-generic-mode mode (list comment-list t t t t) how-to-alter)) + +(defun alter-generic-mode-keywords (mode keyword-list &optional how-to-alter) + "Alter keywords in the specified generic mode. +How-to-alter, if specified, should be one of the following symbols: +`append', `prepend', `overwrite'. The default is `append'." + (alter-generic-mode mode (list t keyword-list t t t) how-to-alter)) + +(defun alter-generic-mode-font-lock (mode font-lock-list &optional how-to-alter) + "Alter font-lock expressions in the specified generic mode. +How-to-alter, if specified, should be one of the following symbols: +`append', `prepend', `overwrite'. The default is `append'." + (alter-generic-mode mode (list t t font-lock-list t t) how-to-alter)) + +(defun alter-generic-mode-functions (mode function-list &optional how-to-alter) + "Alter functions in the specified generic mode. +How-to-alter, if specified, should be one of the following symbols: +`append', `prepend', `overwrite'. The default is `append'." + (alter-generic-mode mode (list t t t t function-list) how-to-alter)) + +;; This one is different because it takes effect immediately +;; Appending or Prepending to auto-mode-alist is ignored, +;; since the effect is the same either way +(defun alter-generic-mode-auto-mode + (mode auto-mode-list &optional how-to-alter) + "Alter auto-mode-alist regular expressions in the specified generic mode. +How-to-alter, if specified, should be one of the following symbols: +`append', `prepend', `overwrite'. The default is `append'." + (alter-generic-mode mode (list t t t auto-mode-list t) how-to-alter) + (let ((alter-method (or how-to-alter 'append))) + (cond ((eq alter-method 'overwrite) + (generic-add-to-auto-mode mode auto-mode-list t)) + ((eq alter-method 'append) + (generic-add-to-auto-mode mode auto-mode-list nil)) + ((eq alter-method 'prepend) + (generic-add-to-auto-mode mode auto-mode-list nil t)) + (t + (error "Optional argument %s not understood" (princ alter-method)))) + )) + +;; Support for [KEYWORD] constructs found in INF, INI and Samba files +(defun generic-bracket-support () + (setq imenu-generic-expression + '((nil "^\\[\\(.*\\)\\]" 1)))) + +;; This generic mode is always defined +(define-generic-mode 'default-generic-mode (list ?#) nil nil nil nil) + +;; A more general solution would allow us to enter generic-mode for +;; *any* comment character, but would require us to synthesize a new +;; generic-mode on the fly. I think this gives us most of what we +;; want. +(defun generic-mode-find-file-hook () + "Hook to enter default-generic-mode automatically +if the first few lines of a file in fundamental-mode start with a hash +comment character. This hook will be installed if the variable +`generic-use-find-file-hook' is non-nil. The variable `generic-lines-to-scan' +determines the number of lines to look at." + (if (not (eq major-mode 'fundamental-mode)) + nil + (if (or (> 1 generic-lines-to-scan) + (< 50 generic-lines-to-scan)) + (error "Variable `generic-lines-to-scan' should be set to a small" + " positive number")) + (let ((comment-regexp "") + (count 0) + ) + (while (< count generic-lines-to-scan) + (setq comment-regexp (concat comment-regexp + generic-find-file-regexp)) + (setq count (1+ count))) + (save-excursion + (goto-char (point-min)) + (if (looking-at comment-regexp) + (generic-mode-with-type 'default-generic-mode)))))) + +(if generic-use-find-file-hook + (add-hook 'find-file-hooks 'generic-mode-find-file-hook)) + +(defun generic-make-keywords-list (keywords-list face &optional prefix suffix) + "Return a regular expression matching the specified keywords. +The regexp is highlighted with FACE." + ;; Sanity checks + ;; Don't check here; face may not be defined yet + ;; (if (not (facep face)) + ;; (error "Face %s is not defined" (princ face))) + (if (not (listp keywords-list)) + (error "Keywords argument must be a list of strings")) + (list + (concat + (or prefix "") + "\\(\\<" + (mapconcat 'identity keywords-list "\\>\\|\\<") + "\\>\\)" + (or suffix "") + ) 1 face)) + +(provide 'generic-mode) + +;;; generic-mode.el ends here + +;; Local Variables: +;; autocompile: t +;; End:
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/gnus-init.el Thu Sep 25 17:57:05 2025 +0100 @@ -0,0 +1,234 @@ +;; gnus customisation + +(eval-when-compile + (setq my-mail-dir "/bogus") ; will be overwritten by the following +) + +(site-caseq (edin + (require 'mail-from-inf)) + (maritain + (message "1 %s %s" (and (boundp 'gnus-server-alist) + gnus-server-alist) + (and (boundp 'gnus-message-archive-method) + gnus-message-archive-method)) + (require 'mail-from-m) + (message "2 %s %s" (and (boundp 'gnus-server-alist) + gnus-server-alist) + (and (boundp 'gnus-message-archive-method) + gnus-message-archive-method)) + (load-file (expand-file-name "~/.xemacs/gnus.el")) + (message "3 %s %s" (and (boundp 'gnus-server-alist) + gnus-server-alist) + (and (boundp 'gnus-message-archive-method) + gnus-message-archive-method))) + (t + (defun set-ht-compiled-split ())) + ) + +;; things based on my-mail-dir, or set-ht-compiled-split +;; which are defined in one of the above + +(set-ht-compiled-split) + +(setq + gnus-article-save-directory (expand-file-name + (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")) + (nnfolder-get-new-mail nil) + (nnfolder-inhibit-expiry t) + ) +) + +(setq gnus-novice-user nil) + +(setq gnus-message-archive-group + '((concat "general." (format-time-string + "%Y-%m" (current-time))))) + + + +(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) + +(setq white-subjects "\\b\\(phd\\|ilcc\\)\\b") + +(setq white-domains (list)) + +(setq ad-domains (list "planetx.co.uk" "substack.com")) + +(defvar ht-compiled-split nil) + +(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" + (interactive) + (gnus-summary-delete-article) + (gnus-summary-next-unread-article)) + +(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) + +(custom-set-variables + '(gnus-treat-display-picons nil)) +(custom-set-faces) + +(add-hook 'gnus-group-mode-hook 'gnus-topic-mode) + +(add-hook 'gnus-summary-mode-hook 'gnus-summary-mode-fun1) + +(add-hook 'message-mode-hook 'message-mode-fun1) + +(add-hook 'message-sent-hook (function whiten-recip)) + +(add-hook 'gnus-group-mode-hook 'gnus-group-mode-fun1) + + +(defun gnus-regen-group () + (nnml-generate-nov-databases-1 (concat + (expand-file-name nnml-directory) + "/" + (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)" + (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")))))))) + +(make-variable-buffer-local 'gnus-extra-headers) +(make-variable-buffer-local 'nnmail-extra-headers) + +(add-hook 'gnus-parse-headers-hook + '(lambda () + (gnus-summary-set-local-parameters gnus-newsgroup-name))) + +(defvar ht-gnus-just-read nil) + +(add-hook 'gnus-get-new-news-hook (lambda () (setq ht-gnus-just-read nil))) + +(add-hook 'gnus-after-getting-new-news-hook + (lambda () (message "%s" ht-gnus-just-read))) + +(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))))) + +(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) + +(provide 'gnus-init)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/jde-hax.el Thu Sep 25 17:57:05 2025 +0100 @@ -0,0 +1,27 @@ +(defun jde-cursor-posn-as-event(&optional forceText) + "Returns the text cursor position as an EVENT on Emacs and the mouse +cursor position on XEmacs." + (if (and jde-xemacsp (not forceText)) + (let* ((mouse-pos (mouse-pixel-position)) + (x (car (cdr mouse-pos))) + (y (cdr (cdr mouse-pos)))) + (if x + (make-event 'button-press `(button 1 modifiers nil x ,x y ,y)) + (let ((fake (jde-cursor-posn-as-event t))) + (make-event 'button-press `(button 1 modifiers nil + x ,(caar fake) + y ,(cadar fake)))))) + (let ((x (* (if jde-xemacsp (/(window-pixel-width)(window-width)) + (frame-char-width)) + (if (and + (boundp 'hscroll-mode) + (fboundp 'hscroll-window-column)) + (hscroll-window-column) + (mod (current-column) (window-width))))) + (y (* (if jde-xemacsp (/ (window-pixel-height) + (window-height)) + (frame-char-height)) + (- (count-lines (point-min) (point)) + (count-lines (point-min) (window-start))))) + (window (get-buffer-window (current-buffer)))) + (list (list x y) window))))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/mail-extras.el Thu Sep 25 17:57:05 2025 +0100 @@ -0,0 +1,492 @@ +;; 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. + +(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") + +;;; I _think_ (almost?) everything above here is diary-related, so belongs +;;; in diary.el. + +;; 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*") + ) + +;(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))))) + +(provide 'mail-extras)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/mail-from-delphix.el Thu Sep 25 17:57:05 2025 +0100 @@ -0,0 +1,20 @@ +;;; Edit and load to send mail as from ... +(setq mail-append-host "delphix.co.uk") +(setq user-full-name "Henry S. Thompson") +(setq user-mail-address "ht@delphix.co.uk") +(setq mail-host-address "delphix.co.uk") +(setq mail-signature-file "/home/ht/.sig.delphix") +(defun system-name () "gregory") +(load "gnus-init" nil t) + +;; sending mail on the road +(setq send-mail-function 'smtpmail-send-it) +(setq message-send-mail-function 'smtpmail-send-it) +(setq smtpmail-default-smtp-server "localhost") +(setq smtpmail-smtp-service "smtp") +(setq smtpmail-local-domain "delphix.co.uk") +(setq smtpmail-debug-info t) +(load "smtpmail" nil t) +(setq smtpmail-code-conv-from nil) + +;; tunnel: ssh -L 25:p15135390.pureserver.info:25 markup.co.uk
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/mail-from-inf.el Thu Sep 25 17:57:05 2025 +0100 @@ -0,0 +1,305 @@ +(setq my-mail-dir "/disk/scratch/mail" + gnus-your-organization "HCRC, University of Edinburgh" + gnus-home-directory "/disk/scratch/gnus" + gnus-default-directory "/disk/scratch" + nnmail-message-id-cache-file "/disk/scratch/gnus/.nnmail-cache" + 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/" + mail-archive-file-name (concat "/disk/scratch/mail/cpy/general/" + (format-time-string + "%Y-%m" (current-time)) + ".mbox") +) + +(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 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 rmail-spool-directory (file-name-as-directory + (concat rmail-spool-directory + "ht-mail"))) +;; don't know why this is necessary +(setq rmail-primary-inbox-list + (list (concat rmail-spool-directory "ht"))) + +(setq white-subjects "\\b\\(phd\\|ilcc\\)\\b") + +(setq white-domains (list)) + +(setq ad-domains (list "planetx.co.uk")) + +(setq w3c-lists1 + '((any "w3c-xml-schema-\\([a-zA-Z]+\\)\\(@\\.w3\\.org\\)?" "xml-schema-\\1") + (any "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") + (any "w3c-\\([-a-zA-Z]+\\)\\(@\\.w3\\.org\\)?" "w3c-\\1") + (any "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 + '((any "ietf-xml-mime\\.imc\\.org" "xml-mime") + (any "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\\|cython-users@googlegroups.com" "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") + (any "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") + )) + +(defconst ht-spam-res '("bfSPAM" "boSPAM" "edSPAM" "saSPAM" "slSPAM")) + +(defun log-good-sender (sres) + (message "good sender %s with result %s" (get-from-gnus-addr) sres)) + +(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 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 + )))) + +(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 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_1 nil t)) + (gnus-summary-exit) + ) + ) + +(add-hook 'gnus-after-getting-new-news-hook + (lambda () + (if (member "_diary" ht-gnus-just-read) + (straight-to-diary)))) + +(provide 'mail-from-inf)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/mail-from-m.el Thu Sep 25 17:57:05 2025 +0100 @@ -0,0 +1,103 @@ +;;; Load to read and send mail from maritain + +(setq mail-append-host "home.hst.name") +(make-variable-buffer-local 'user-mail-address) +(setq-default user-mail-address (format "%s@home.hst.name" user-name)) +(setq mail-host-address "home.hst.name") +(defun system-name () "home.hst.name") + +(let ((hdn (format "/home/%s" user-name))) + (let ((sfn (format "%s/.sig.pers" hdn))) + (setq mail-signature-file sfn + message-signature-file sfn + mail-signature t + message-signature t) + ) + (setq gnus-default-directory hdn + gnus-home-directory hdn + my-mail-dir (format "%s/mail" hdn) + mail-sources `((file :path ,(format "/var/spool/mail/%s" user-name))) + mail-archive-file-name (concat my-mail-dir "/cpy/general/" + (format-time-string + "%Y-%m" (current-time)) + ".mbox")) +) + +(setq mail-archive-file-name (expand-file-name "~/mail/cpy/general")) + +;; sending mail on the road +;(setq send-mail-function 'smtpmail-send-it) +;(setq message-send-mail-function 'smtpmail-send-it) +;(setq smtpmail-default-smtp-server "localhost") +;(setq smtpmail-smtp-service "smtp") +;(setq smtpmail-local-domain "home.hst.name") +(setq smtpmail-debug-info t) +(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 ((re-search-forward "^From: .*ht@home.hst.name" nil t) + ;; will fail on mhmcc + (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 from-mhmcc () + (interactive) + ;; This is cribbed from the value of + ;; (gnus-configure-posting-styles "mhmcc-2024") + (let ((user-full-name "HST as Convenor SESAM MHMC") + (user-mail-address "mhmcc@rsof.hst.name")) + (set (make-local-variable (quote user-mail-address)) + "mhmcc@rsof.hst.name") + (save-excursion + (message-remove-header "From") + (message-goto-eoh) + (insert "From: " (message-make-from) " +") + )) + (save-excursion + (let ((message-signature + "Henry S. Thompson, Convenor, SESAM Meeting House Management Committee +")) + (message-insert-signature) + (re-search-backward "^--") + (let ((p (point))) + (kill-region (re-search-backward "^--") p)) + )) + (save-excursion + (message-remove-header "Reply-to") + (let ((value "sesam.emh.management@gmail.com")) + (when value + (message-goto-eoh) + (insert "Reply-to" ": " value) + (unless (bolp) (insert " +")) + )) + ) + (save-excursion (message-remove-header "Bcc") (let ((value "sesam.emh.management@gmail.com")) (when value (message-goto-eoh) (insert "Bcc" ": " value) (unless (bolp) (insert " +"))))) + ) +; (let ((use-this (gnus-configure-posting-styles "mhmcc-2024")) +; (gnus-posting-styles nil)) +; (mapc (lambda (expr) +; (let ((varbind (and (listp expr) +; (eq (car (caadr expr)) 'save-excursion) +; (caadr (cadr (caddr expr)))))) +; (unless (and (eq (car varbind) 'message-signature) +; (not (position "Convenor" (cadr varbind)))) +; (apply expr nil)))) +; )) + +(provide 'mail-from-m)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/mail-from-markup.el Thu Sep 25 17:57:05 2025 +0100 @@ -0,0 +1,19 @@ +;;; Edit and load to send mail as from ... +(setq mail-append-host "markup.co.uk") +(setq user-full-name "Henry S. Thompson") +(setq user-mail-address "ht@markup.co.uk") +(setq mail-host-address "markup.co.uk") +(setq mail-signature-file "~/.sig.markup") +(defun system-name () "gregory") + +;; sending mail on the road +(setq send-mail-function 'smtpmail-send-it) +(setq message-send-mail-function 'smtpmail-send-it) +(setq smtpmail-default-smtp-server "localhost") +(setq smtpmail-smtp-service "smtp") +(setq smtpmail-local-domain "markup.co.uk") +(setq smtpmail-debug-info t) +(load "smtpmail" nil t) +(setq smtpmail-code-conv-from nil) + +;; tunnel: ssh -L 25:p15135390.pureserver.info:25 markup.co.uk
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/mail-from.el Thu Sep 25 17:57:05 2025 +0100 @@ -0,0 +1,19 @@ +;;; Edit and load to send mail as from ... +(setq mail-append-host "hst.name") +(setq user-full-name "Henry S. Thompson") +(setq user-mail-address "hst@hst.name") +(setq mail-host-address "hst.name") +(setq mail-signature-file "~/.sig.pers") +(defun system-name () "francis.hst.name") + +;; sending mail on the road +(setq send-mail-function 'smtpmail-send-it) +(setq message-send-mail-function 'smtpmail-send-it) +(setq smtpmail-default-smtp-server "localhost") +(setq smtpmail-smtp-service "smtp") +(setq smtpmail-local-domain "hst.name") +(setq smtpmail-debug-info t) +(load "smtpmail" nil t) +(setq smtpmail-code-conv-from nil) + +;; tunnel: ssh -L 25:p15135390.pureserver.info:25 markup.co.uk
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/mdn-extras.el Thu Sep 25 17:57:05 2025 +0100 @@ -0,0 +1,164 @@ +;; 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))) + +(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/misc.el Thu Sep 25 17:57:05 2025 +0100 @@ -0,0 +1,224 @@ +;; various hacks +;; a compiled version exists! +;; Last edited: Thu Oct 2 16:47:40 1986 + +(provide 'misc) + +(defun + insert-time () + (interactive) + (insert-string (current-time-string))) + +(global-set-key "\et" 'insert-time) + +(defun + note-edit () + (interactive) + (beginning-of-buffer) + (if + (not (search-forward "Last edited: " nil t)) + (progn (insert-string ";; Last edited: ") + (newline) + (forward-char -1)) + (if (not (looking-at "\n")) + (kill-line))) + (insert-time)) + +(global-set-key "\em" 'note-edit) + +(defun save-and-pause() + (interactive) + (save-some-buffers t) + (suspend-emacs)) + +(global-set-key "\C-x." 'save-and-pause) + +(defun fix-comment-line () + "split comment onto enough lines to avoid overflow" + (interactive) + (indent-for-comment) + (end-of-line) + (if (> (current-column) 79) + (progn + (while (> (current-column) 79) + (re-search-backward "[ ]")) + (indent-new-comment-line) + (end-of-line)))) + +(defun fix-all-comments () + "iterate over file with fix-comment-line" + (interactive) + (while (search-forward ";" nil t) + (fix-comment-line))) + +(global-set-key "\e:" 'fix-comment-line) + +(defun grind-file () + "grind all forms in a lisp file" + (interactive) + (beginning-of-buffer) + (while (re-search-forward "^(" nil t) + (beginning-of-line) + (indent-sexp) + (end-of-line))) + +(defun suggest-breaks () + "suggest line breaks to improve indentation" + (interactive) + (set-mark (point)) + (message "Trying to add line breaks to over-long lines . . .") + (let (finished) + (while (not (or finished + (= (point)(point-max)))) + (end-of-line) + (if (> (current-column) 79) + (let* ((left (progn (beginning-of-line) + (re-search-forward "[ ]*") + (current-column))) + (min-pt (point)) + (target (min 69 (/ (+ 79 left) 2)))) + (end-of-line) + (while (and (> (current-column) target) + (> (point) min-pt) + (search-backward " " nil t))) + (if (<= (point) min-pt) + (progn (goto-char min-pt) + (if (search-forward " " nil t) + (backward-char 1) + (message "losing %d %d %d" min-pt left target)))) + (let ((help-form (quote + "y or <space> to break here,n or . or ! to stop, others interpreted")) + (re-probe t) + (char nil)) + (while re-probe + (setq re-probe nil) + (setq char (read-char)) + (cond ((or (= char ??) + (= char help-char)) + (message help-form)) + ((or (= char ?\ ) + (= char ?y)) + (while (looking-at " ") + (delete-char 1)) + (newline-and-indent) + (message + "Trying to add line breaks to over-long lines . . .")) + ((or (= char ?n) + (= char ?\.) + (= char ?\!)) + nil) + ((= char ?f) + (forward-char 1) + (search-forward " ") + (backward-char 1) + (setq re-probe t)) + ((= char ?b) + (search-backward " ") + (setq re-probe t)) + (t (setq unread-command-char char) + (setq finished t)))))) + (forward-line))) + (message "Trying to add line breaks to over-long lines . . . done."))) + +(defun set-left-margin () + (interactive) + (if (and margin-stack + (< (current-column)(car margin-stack))) + (setq margin-stack nil) + (if (> (current-column) left-margin) + (setq margin-stack (cons left-margin margin-stack)))) + (setq left-margin (current-column)) + (set-fill-prefix)) + +(defun pop-left-margin () + (interactive) + (if margin-stack + (progn (setq left-margin (car margin-stack)) + (setq margin-stack (cdr margin-stack))) + (setq left-margin 0)) + (move-to-column left-margin) + (set-fill-prefix)) + +(add-hook 'text-mode-hook + (lambda nil + (turn-on-auto-fill) + (abbrev-mode 1) + (local-set-key "\C-cl" 'set-left-margin) + (local-set-key "\C-cs" 'submerge-region)) t) + +(global-set-key "\C-cp" 'pop-left-margin) + +(make-variable-buffer-local 'margin-stack) +(set-default 'margin-stack nil) + +(global-set-key "\^Xn" 'other-window) ; as per emacs - used to be narrow +(global-set-key "\^Xp" 'other-window-up) ; " + +(defun other-window-up (n) + (interactive "p") + (other-window (- (or n 1)))) + +(defun minibuffer-electric-tilde () + ;; by Stig@hackvan.com + (interactive) + (and (eq ?/ (preceding-char)) + (delete-region (point-min) (point))) + (insert ?~)) + + + +;; Created by: Joe Wells, jbw@cs.bu.edu +;; Created on: Fri May 15 13:16:01 1992 +;; Last modified by: Joe Wells, jbw@csd +;; Last modified on: Fri May 15 17:03:28 1992 +;; Filename: backtrace-fix.el +;; Purpose: make backtrace useful when circular structures are on the stack + +(or (fboundp 'original-backtrace) + (fset 'original-backtrace + (symbol-function 'backtrace))) + +(defconst backtrace-junk "\ + original-backtrace() + (condition-case ...) + (let ...) + (save-excursion ...) + (let ...) +") + +(defun circ-backtrace () + "Print a trace of Lisp function calls currently active. +Output stream used is value of standard-output." + (let (err-flag) + (save-excursion + (set-buffer (get-buffer-create " backtrace-temp")) + (buffer-flush-undo (current-buffer)) + (erase-buffer) + (let ((standard-output (current-buffer))) + (condition-case err + (original-backtrace) + (error + (setq error-flag err)))) + (cond (err-flag + (goto-char (point-max)) + (beginning-of-line 1) + ;; don't leave any unbalanced parens lying around + (delete-region (point) (point-max)))) + (goto-char (point-min)) + (search-forward backtrace-junk nil t) + (delete-region (point-min) (point)) + (princ (buffer-substring (point-min) (point-max))))) + nil) + +(defun install-circ-bt () + (fset 'backtrace + (symbol-function 'circ-backtrace))) + +(defvar submerge-prefix "> " + "prefix to submerge quoted text with") + +(defun submerge-region (&optional start end) + "submerge the current region" + (interactive "r") + (let ((fill-prefix submerge-prefix)) + (indent-region start end nil)))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/my-news.el Thu Sep 25 17:57:05 2025 +0100 @@ -0,0 +1,852 @@ +(message "my-news") +; (debug-on-entry 'gnus-start-news-server) +(setq ; see ~/.xemacs/gnus.el for local settings + 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))) + + +(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)) + ))) +;;; fixup clarinews +;(autoload 'gnus-clarinews-fun "clari-clean" "Clean ClariNews articles" t) +;(add-hook 'gnus-article-prepare-hook 'gnus-clarinews-fun) + + +(defun gnus-Subject-sort-by-subject-and-date (reverse) + "Sort subject display buffer by subject alphabetically. `Re:'s are ignored. +If case-fold-search is non-nil, case of letters is ignored. Date is used +if subjects are equal +Argument REVERSE means reverse order." + (interactive "P") + (gnus-summary-sort-summary + (function + (lambda (a b) + (let ((s-a (gnus-trim-simplify-subject (nntp-header-subject a))) + (s-b (gnus-trim-simplify-subject (nntp-header-subject b))) + ) + (or (gnus-string-lessp s-a s-b) + (and (gnus-string-equal s-a s-b) + (gnus-date-lessp (nntp-header-date a) + (nntp-header-date b))))))) + reverse + )) + +;(require 'util-mde) ; for string-replace-regexp-2 + + +(defun gnus-string-equal (a b) + "Return T if first arg string is equal than second in lexicographic order. +If case-fold-search is non-nil, case of letters is ignored." + (if case-fold-search + (string-equal (downcase a) (downcase b)) (string-equal a b))) + +(defun gnus-Group-update-and-vanish () + "update newsrc and restore config pre-group selection" + (interactive) + (gnus-group-force-update) + (if gnus-pre-config + (set-window-configuration gnus-pre-config)) +; (setq gnus-pre-config nil) + ) + +;; Database stuff +(defun open-white () + (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 (concat my-mail-dir "/ad") 'berkeley-db))) + +(defun save-ad () + (close-database adlist-db) + (open-ad)) + +(defun open-quaker () + (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 dontAddToBBDB) + "While reading an article, add to whitelist" + (interactive "P") + (gnus-summary-goto-article (gnus-summary-article-number)) + (do-add-white (gnus-fetch-original-field "From") dontAddToBBDB)) + +(defun do-add-white (addr &optional dontAddToBBDB) + (let* ((components (gnus-extract-address-components addr)) + (addr (get-canonical-from-addr components))) + (if (not dontAddToBBDB) + (let ((bbdb-no-duplicates-p t)) + (condition-case nil + (bbdb-create-internal (car components) nil + (cadr components) nil nil nil) + (error + ;; OK, just means already present + )))) + (if (new-white addr) + (save-white)))) + +(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))) + +; not needed anymore because of gnus-posting-styles (q.v. in mail-from-*) +(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 to-quaker-p () + (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 (get-database (car recips) quaker-db))) + (setq recips (cdr recips))) + (not (null 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 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* ((to (message-fetch-field "To")) + (cc (message-fetch-field "cc")) + (msg-recipients (concat to (and to cc ", ") cc)) + (recips (message-tokenize-header msg-recipients)) + (res (mapcar (function do-add-white) recips))) + (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) + (comint-exec (get-buffer-create "*new-white*") + "new-white" shell-file-name + nil (list shell-command-switch + (format "echo '%s' >> %s/new-white.txt" addr my-mail-dir))) t)) + +(defun new-ad (addr) + (new-white 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)) + +(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)))) + (jr ht-gnus-just-read)) + (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 "read: %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) + ;(expand-file-name + "/home/ht/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))) + +(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)))) + +;; 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\\|div\\)")) + (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)) + + +(defvar safelink_pat "https://[a-z0-9.]*safelinks.protection.outlook.com/\\?url=\\(\\(ftp\\|https?\\)%3A%2F%2F[^&<>\"]*\\)[^\"<> \n]*") + +(require 'url) + +(defvar url-ok-chars (nconc + '(?/ ?& ?% ?+ ?? ?= ?: ?; + ?# + ) + url-unreserved-chars)) + +(defun unsafelink () + ;; Thanks to Iain Murray for + ;; /public/homepages/imurray2/web/code/hacks/unsafelink + (let ((url-unreserved-chars url-ok-chars)) + (while (re-search-forward safelink_pat nil t) + (let ((res (match-string 1))) + (replace-match "") + ;; unhexify uses regex, so trashes match-string :-( + (insert (url-hexify-string (url-unhex-string res))) + )) + )) + +(add-hook 'gnus-article-prepare-hook 'unsafelink) + +(provide 'my-news)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/pers-init.el Thu Sep 25 17:57:05 2025 +0100 @@ -0,0 +1,405 @@ +;;; 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 +;;; 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"))) + +(setq user-full-name "Henry S. Thompson") + +(setq vc-command-messages t) + +(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) +(setq auto-mode-alist + (append '(("/perl/" . perl-mode) + ("\\.scm$" . scheme-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))) + (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))) + )) + + +(site-caseq (edin + (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 + (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 + (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")) + (defun ht-rooms-setup (&optional arg) + (interactive) + (require 'rooms) + (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))))) + ;; DICE comes here 2012-01-13 + (setq interprogram-paste-function (lambda () + (or (get-clipboard-foreign) + (if (selection-exists-p) + (get-selection-foreign))))) + ;(load "device-type-hacking" t t) + (setq zmacs-regions t) + ;; override changed default, except in gnus + (message "dth") + (site-caseq (edin + (setq highlight-headers-follow-url-function + 'browse-url-firefox + ) + (setq browse-url-browser-function 'browse-url-firefox) + )) + (message "gnus-init") + (site-caseq ((edin markup maritain) + (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) +; (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))))) + (message "defined rooms 2") + ))) +(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_ ! +) + +(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)) + +(require 'misc) ; used to be in common-init... + +(ht-custom-size)
--- a/shared/device-type-hacking.el Thu Sep 25 17:56:42 2025 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,63 +0,0 @@ - - -(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/xquery-mode.el Thu Sep 25 17:57:05 2025 +0100 @@ -0,0 +1,264 @@ +;;; xquery-mode.el --- A simple mode for editing xquery programs +;; Time-stamp: <2005-03-26 18:05:39 sacharya> + +;;; Copyright (C) 2005 Suraj Acharya + +;; Author: Suraj Acharya <sacharya@cs.indiana.edu> + +;; This file is not part of GNU Emacs. + +;; xquery-mode.el is free software; you can redistribute it +;; and/or modify it under the terms of the GNU General Public License +;; as published by the Free Software Foundation; either version 2, or +;; (at your option) any later version.: + +;; This software is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: +;;; + +(require 'nxml-mode) +(require 'generic-mode) +;;; Code: +(define-generic-mode 'xquery-mode + '(("(:" . ":)") ("!-" . "->")) + '("xquery" "version" "encoding" "at" "module" "namespace" "child" "descendant" "parent" "attribute" "self" "descendant-or-self" "ancestor" "following-sibling" "preceding-sibling" "following" "preceding" "ancestor-or-self" "declare" "function" "option" "ordering" "ordered" "unordered" "default" "order" "external" "or" "and" "div" "idiv" "mod" "in" "construction" "satisfies" "return" "then" "else" "boundary-space" "base-uri" "preserve" "strip" "copy-namespaces" "no-preserve" "inherit" "no-inherit" "to" "where" "collation" "intersect" "union" "except" "as" "case" "instance" "of" "castable" "item" "element" "schema-element" "schema-attribute" "processing-instruction" "comment" "text" "empty" "import" "schema" "is" "eq" "ne" "gt" "ge" "lt" "le" "some" "every" "for" "let" "cast" "treat" "validate" "document-node" "document" "node" "if" "typeswitch" "by" "stable" "ascending" "descending" "greatest" "least" "variable") ;keywords + '(("\\(\\$\\w+\\)" 1 font-lock-variable-name-face) ;; \\(\\s_\\|\\w\\) + ("\\(\\w*:?\\w+\\)\\s *(" 1 font-lock-function-name-face) + ("\\(<\\)\\(/?\\)\\(\\w*\\)\\(:?\\)\\(\\w+\\).*?\\(/?\\)\\(>\\)" + (1 'nxml-tag-delimiter-face) + (2 'nxml-tag-slash-face) + (3 'nxml-element-prefix-face) + (4 'nxml-element-colon-face) + (5 'nxml-element-local-name-face) + (6 'nxml-tag-slash-face) + (7 'nxml-tag-delimiter-face) + ) + ("\\(\\w*\\)\\(:?\\)\\(\\w+\\)=\\([\"']\\)\\(.*?\\)\\([\"']\\)" + (1 'nxml-attribute-prefix-face) + (2 'nxml-attribute-colon-face) + (3 'nxml-attribute-local-name-face) + (4 'nxml-attribute-value-delimiter-face) + (5 'nxml-attribute-value-face) + (6 'nxml-attribute-value-delimiter-face)) + ("\\(/\\)\\(\\w*\\)\\(:?\\)\\(\\w+\\)" + (1 font-lock-constant-face) + (2 font-lock-constant-face) + (3 font-lock-constant-face) + (4 font-lock-constant-face) + ) + ("as\\s +\\(\\w*:?\\w+\\)" + (1 font-lock-type-face) + ) + ) ;font-lock-list + '(".xq[ml]?$") ;auto-mode-list + '(xquery-set-indent-function xquery-set-up-syntax-table) ;function list + "A Major mode for editing xquery." + ) + + + +(defun xquery-set-indent-function () + "Set the indent function for xquery mode." + (setq nxml-prolog-end (point-min)) + (setq nxml-scan-end (copy-marker (point-min) nil)) + (set (make-local-variable 'indent-line-function) 'xquery-indent-line) + (make-local-variable 'forward-sexp-function) + (setq forward-sexp-function 'xquery-forward-sexp) + ;;(local-set-key "/" 'nxml-electric-slash) + ) + +(defun xquery-forward-sexp (&optional arg) + "Xquery forward s-expresssion. +This function is not very smart, it tries to use +`nxml-forward-balanced-item' if it sees '>' or '<' characters in +the direction you are going, and uses the regular `forward-sexp' +otherwise. " + (if (> arg 0) + (progn + (if (looking-at "[ \t]*<") + (nxml-forward-balanced-item arg) + (let ((forward-sexp-function nil)) (forward-sexp arg)))) + (if (looking-back ">[ \t]*") + (nxml-forward-balanced-item arg) + (let ((forward-sexp-function nil)) (forward-sexp arg)))) + ) + + +(defun xquery-set-up-syntax-table () + "Allow the hypen character to be recognized as part of a xquery symbol." + (modify-syntax-entry ?- "w" (syntax-table)) + (modify-syntax-entry ?/ "." (syntax-table)) + ;; set-up the syntax table correctly for parentheis type characters + (modify-syntax-entry ?\{ "(}" (syntax-table)) + (modify-syntax-entry ?\} "){" (syntax-table)) + (modify-syntax-entry ?\[ "(]" (syntax-table)) + (modify-syntax-entry ?\] ")]" (syntax-table)) + (modify-syntax-entry ?\( "()1" (syntax-table)) + (modify-syntax-entry ?\) ")(4" (syntax-table)) + ;;(modify-syntax-entry ?\< "(>" (syntax-table)) + ;;(modify-syntax-entry ?\> ")<" (syntax-table)) + ;; xquery comments are like (: :) -- handled above at mode decl + ;;(modify-syntax-entry ?\: ".23" (syntax-table)) + ) + + + +(defun xquery-indent-line () + "Indent current line as xquery code." + (interactive) + (let ((savep (> (current-column) (current-indentation))) + (indent (condition-case err (max (xquery-calculate-indentation) 0) + (error (message "%S" err))))) + (if savep + (save-excursion (indent-line-to indent)) + (indent-line-to indent)))) + +(defvar xquery-start-block-regexp "[ \t]*\\((\|{\\|for\\|let\\|where\\|return\\|if\\|else\\|typeswitch\\|declare[ \t]+function\\|.*[({]$\\)" + "A regular expression which indicates that a xquery block is starting.") + +(defvar xquery-flwr-block-regexp "[ \t]*\\(for\\|let\\|where\\|return\\|order\\|stable\\s *order\\)") + +(defvar xquery-indent-size 2 + "The size of each indent level.") + +(defvar xquery-indent-debug nil) + +(defun xquery-toggle-debug-indent () + "Toggle the debug flag used in `xquery-calculate-indentation'. " + (interactive) + (setq xquery-indent-debug (not xquery-indent-debug)) + (message (concat "xquery-indent-debug is " (if xquery-indent-debug "en" "dis") "abled")) + ) + +(defun xquery-calculate-indentation () + "Return the column to which the current line should be indented." + (beginning-of-line) + (if (bobp) + 0 ; First line is always non-indented + (skip-chars-forward " \t") + (cond + ;; do nothing if this is a comment + ((eq (get-text-property (point) 'face) 'font-lock-comment-face) (current-indentation)) + + ((looking-at "\\(</?\\w\\|{\\)") ;; xml constructor or enclosed expressions + (if xquery-indent-debug + (message "xquery-indent-debug: xml constructor")) + (let ((nxml-prolog-end (point-min)) + (nxml-scan-end (copy-marker (point-min) nil))) + (nxml-compute-indent) + )) + + ;; for close braces or else statements indent to the same level as the opening { + ((looking-at "}") + (if xquery-indent-debug + (message "xquery-indent-debug: }")) + (save-excursion + (backward-up-list) + (let ((cc (current-column))) + (beginning-of-line) + (if (looking-at xquery-start-block-regexp) + (current-indentation) + cc)))) + + ((looking-at "else") + (if xquery-indent-debug + (message "xquery-indent-debug: else")) + (save-excursion + (xquery-previous-non-empty-line) + (- (current-indentation) xquery-indent-size) + )) + + ;; for close parens, indent to the start of the func call + ((looking-at ")") + (if xquery-indent-debug + (message "xquery-indent-debug: )")) + (save-excursion + (backward-up-list) + (if (looking-back "\\w+\\s *") + (backward-word)) + (current-column) + )) + + ;; order flwr expressions on the same column + ((save-excursion + (when + (and + (looking-at xquery-flwr-block-regexp) + (progn + (xquery-previous-non-empty-line) + (beginning-of-line) + (looking-at xquery-flwr-block-regexp))) + (if xquery-indent-debug + (message "xquery-indent-debug: nested flwr")) + (current-indentation) + ) + )) + + ;; if this is the first non-empty line after a block, indent xquery-indent-size chars relative to the block + ((save-excursion + (xquery-previous-non-empty-line) + (beginning-of-line) + (when (looking-at xquery-start-block-regexp) + (if xquery-indent-debug + (message "xquery-indent-debug: first line in block")) + (+ xquery-indent-size (current-indentation)))) + ) + + ;; for everything else indent relative to the outer list + (t + (if xquery-indent-debug + (message "xquery-indent-debug: everyting else")) + (save-excursion (xquery-previous-non-empty-line) (current-indentation))) + ))) + +(when (featurep 'xemacs) + (unless (functionp 'looking-back) + ;; from GNU Emacs subr.el + (defun looking-back (regexp &optional limit greedy) + "Return non-nil if text before point matches regular expression +REGEXP. + Like `looking-at' except matches before point, and is slower. + LIMIT if non-nil speeds up the search by specifying a minimum + starting position, to avoid checking matches that would start + before LIMIT. + If GREEDY is non-nil, extend the match backwards as far as possible, + stopping when a single additional previous character cannot be part + of a match for REGEXP." + (let ((start (point)) + (pos + (save-excursion + (and (re-search-backward (concat "\\(?:" regexp +"\\)\\=") limit t) + (point))))) + (if (and greedy pos) + (save-restriction + (narrow-to-region (point-min) start) + (while (and (> pos (point-min)) + (save-excursion + (goto-char pos) + (backward-char 1) + (looking-at (concat "\\(?:" regexp +"\\)\\'")))) + (setq pos (1- pos))) + (save-excursion + (goto-char pos) + (looking-at (concat "\\(?:" regexp "\\)\\'"))))) + (not (null pos)))))) + +(defun xquery-previous-non-empty-line () + "Move to the last non-empty line." + (re-search-backward "\\S " (point-min) t) + ) + +(provide 'xquery-mode) + +;;; xquery-mode.el ends here