Mercurial > hg > xemacs
changeset 31:129123962e51
trying to merge lib/emacs and xemacs
| author | Henry S Thompson <ht@inf.ed.ac.uk> |
|---|---|
| date | Sat, 07 Oct 2023 12:43:14 +0100 |
| parents | 8e0e16f4763c (current diff) 0e5b39d2f8bb (diff) |
| children | cb9b76219c55 |
| files | |
| diffstat | 14 files changed, 3465 insertions(+), 0 deletions(-) [+] |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/generic-extras.el Sat Oct 07 12:43:14 2023 +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 Sat Oct 07 12:43:14 2023 +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 Sat Oct 07 12:43:14 2023 +0100 @@ -0,0 +1,215 @@ +;; Last edited: Fri Aug 20 14:49:23 1999 +;; gnus customisation + +(setq gnus-novice-user nil) + +(setq gnus-message-archive-group + '((concat "general." (format-time-string + "%Y-%m" (current-time))))) + + +(site-caseq (maritain (require 'mail-from-m))) + +(setq +; gnus-article-sort-functions '(gnus-article-sort-by-subject +; see secondary-select-methods in my-news gnus-article-sort-by-number) + gnus-auto-select-next 'quietly + gnus-buttonized-mime-types '("multipart/signed") + gnus-inhibit-mime-unbuttonizing nil + gnus-ignored-headers "^Errors-To:\\|^Precedence:\\|^UNIX-From:" + gnus-mime-display-multipart-related-as-mixed t + gnus-posting-styles `((".*" + (signature-file ,mail-signature-file)) + ("quaker-2023" + (signature-file "/home/ht/.quaker-sig") + (address "ht@rsof.hst.name")) + ("mhmcc-2023" + (signature-file "/home/ht/.mhmcc-sig") + ("Reply-to" "sesam.emh.management@gmail.com") + (name "HST as Convenor SESAM MHMC") + (address "mhmcc@rsof.hst.name") + ("Bcc" "sesam.emh.management@gmail.com"))) + gnus-simplify-subject-regexp "^\\(re[:;.]\\| \\|fwd:\\)*" + gnus-summary-display-arrow nil + gnus-summary-gather-subject-limit nil + gnus-summary-line-format "%U%R%5N%I%(%[%4L: %-12,12A%]%) %s\n" + gnus-summary-make-false-root 'none + gnus-thread-sort-functions '(gnus-thread-sort-by-number + gnus-thread-sort-by-simpl-subject) + mm-discouraged-alternatives '("text/html") + gnus-summary-ignore-duplicates t + gnus-use-scoring nil ; not used yet + ) + +(setq bbdb/news-auto-create-p t) + +(setq nnmail-crosspost nil) +(setq nnmail-split-methods 'nnmail-split-fancy) +(defun set-nnmail-split-fancy () + (setq nnmail-split-fancy + (let ((month (format-time-string "%Y-%m" (current-time)))) + (cons '| + (append '(("Subject" "testing" "jjunk") + (to "quaker-\\(l\\|spectrum\\)" "quaker-2022") + (to "quaker-b" "quaker-b") + (to "[cC]ygwin" "cygwin") + (from "noreply@mrooms.net" "nayler") + (to "ht@rsof.hst.name" "quaker-2023") + (to "Wardenship@lists.quaker.eu.org" "wardens") + (to "mhmcc@rsof.hst.name" "mhmcc-2023") + ("Envelope-to" "mhmcc@rsof.hst.name" + (| (from "mhmcc@rsof.hst.name" junk) + "mhmcc-2023")) + (to "mfw@rsof.hst.name" "7vt") + (to "zphdaily" (concat "pers-" month)) + (to "inf\\(pg\\|msc\\|teach\\|res\\|staff\\)" "inf-\\1" ) + ) + (list (list 'to + "ht\\|h\\.?thompson?" + (concat "pers-" month)) + (concat "group-" + (format-time-string + "%Y-%m" (current-time)) + ""))))))) + +(set-nnmail-split-fancy) + +(defun set-ht-compiled-split () + (interactive) + (set-nnmail-split-fancy)) + +(setq gnus-show-mime t) + +(defun ht-gnus-summary-delete-forward () + "REAL delete for nnmail gnus" + (interactive) + (gnus-summary-delete-article) + (gnus-summary-next-unread-article)) + +(require 'my-news) +(open-quaker) + +(add-hook 'kill-emacs-hook + (lambda () +; (if (database-live-p whitelist-db) +; (close-database whitelist-db)) + (if (database-live-p 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) + +(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) + +;; run the first time we make a summary window +(defun gnus-summary-mode-fun1 () + "install ht's mods" + (define-key gnus-summary-mode-map "D" 'ht-gnus-summary-delete-forward) + (define-key gnus-summary-mode-map "\M-h" 'showMPAhtml) + (remove-hook 'gnus-summary-mode-hook 'gnus-summary-mode-fun1)) + +(defun message-mode-fun1 () + (define-key message-mode-map [(control meta q)] 'add-quaker) + (remove-hook 'message-mode-hook 'message-mode-fun1)) + +(defun ht-gnus-pers-refresh (n) + (interactive "p") + (let ((gn (concat "nnml+ht:pers-" + (format-time-string "%Y-%m" (current-time))))) + (gnus-group-goto-group gn) + (gnus-group-get-new-news-this-group n) + (gnus-group-goto-group gn) + (gnus-group-read-group)) + ) + +(add-hook 'gnus-group-mode-hook 'gnus-group-mode-fun1) + +;; run the first time we make a group window +(defun gnus-group-mode-fun1 () + "install ht's mods" + (define-key gnus-group-mode-map "\M-\C-g" 'ht-gnus-pers-refresh) + (remove-hook 'gnus-group-mode-hook 'gnus-group-mode-fun1)) + +(defun gnus-regen-group () + (nnml-generate-nov-databases-1 (concat + (expand-file-name nnml-directory) + "/" + (substring (gnus-group-group-name) 8)) + nil t) + ) + + +(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))) + +(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))) + +(defvar ht-gnus-just-read nil) + +(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)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/jde-hax.el Sat Oct 07 12:43:14 2023 +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-from-delphix.el Sat Oct 07 12:43:14 2023 +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-m.el Sat Oct 07 12:43:14 2023 +0100 @@ -0,0 +1,22 @@ +;;; Edit and load to send mail as from ... +(setq mail-append-host "home.hst.name") +(setq user-full-name "Henry S. Thompson") +(setq user-mail-address "ht@home.hst.name") +(setq mail-host-address "home.hst.name") +(setq mail-signature-file "/home/ht/.sig.pers") +(setq mail-signature t) +(setq message-signature-file "/home/ht/.sig.pers") +(setq message-signature t) +(defun system-name () "home.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 "home.hst.name") +(setq smtpmail-debug-info t) +(load "smtpmail" nil t) +(setq smtpmail-code-conv-from nil) + +(provide 'mail-from-m)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/mail-from-markup.el Sat Oct 07 12:43:14 2023 +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 Sat Oct 07 12:43:14 2023 +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 Sat Oct 07 12:43:14 2023 +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 Sat Oct 07 12:43:14 2023 +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)) + +(setq text-mode-hook `(lambda nil (progn ,@ (mapcar (function list) + text-mode-hook)) + (turn-on-auto-fill) + (abbrev-mode 1) + (local-set-key "\C-cl" 'set-left-margin) + (local-set-key "\C-cs" 'submerge-region))) + +(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 Sat Oct 07 12:43:14 2023 +0100 @@ -0,0 +1,336 @@ +;; Last edited: Wed Aug 25 14:10:36 1999 + +;(site-caseq (edin (require 'ccs-gnus))) + +; mix-spool stuff + +(load "gnus" nil t) +; (debug-on-entry 'gnus-start-news-server) +(setq gnus-nntp-server nil) +; + + +(setq gnus-article-save-directory "/home/ht/mail/Mail") +(setq nnml-directory (expand-file-name "/home/ht/mail/Mail")) +(setq gnus-message-archive-method + '(nnfolder "archive" + ;; the following two are not taking effect, not sure why, answer + ;; _may_ lie in gnus-setup-news... + (nnfolder-directory "/home/ht/mail/cpy") + (nnfolder-active-file "/home/ht/mail/cpy/active") + (nnfolder-get-new-mail nil) + (nnfolder-inhibit-expiry t))) +(setq gnus-secondary-select-methods + '((nnml "ht" + (gnus-show-threads nil) + (gnus-article-sort-functions (gnus-article-sort-by-subject gnus-article-sort-by-date)) + ))) +(setq mail-sources '((file :path "/var/spool/mail/ht"))) +;;; fixup clarinews +;(autoload 'gnus-clarinews-fun "clari-clean" "Clean ClariNews articles" t) +;(add-hook 'gnus-article-prepare-hook 'gnus-clarinews-fun) + + +(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-trim-simplify-subject (text) + "call gnus-simplify-subject and remove leading blanks" + (if text + (gnus-simplify-subject + (string-replace-regexp-2 + (gnus-simplify-subject text t) + "^\\s-+" + "") + t) + "")) + +(defun gnus-string-equal (a b) + "Return T if first arg string is equal than second in lexicographic order. +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 "/disk/scratch/mail/white" 'berkeley-db))) +(defun save-white () + (close-database whitelist-db) + (open-white)) + +(defun open-ad () + (setq adlist-db (open-database "/disk/scratch/mail/ad" 'berkeley-db))) + +(defun save-ad () + (close-database adlist-db) + (open-ad)) + +(defun open-quaker () + (setq quaker-db (open-database "~/mail/quaker" 'berkeley-db))) +(defun save-quaker () + (close-database quaker-db) + (open-quaker)) + + +(defun add-white (&optional addToBBDB) + (interactive "P") + (gnus-summary-goto-article (gnus-summary-article-number)) + (let* ((components (get-current-from-components)) + (addr (get-canonical-from-addr components))) + (if (new-white addr) + (save-white)) + (if addToBBDB + (let ((bbdb-no-duplicates-p t)) + (bbdb-create-internal (car components) nil (cadr components) + nil nil nil))))) + +(defun add-ad () + (interactive) + (gnus-summary-goto-article (gnus-summary-article-number)) + (let ((addr (get-current-from-addr))) + (if (or (not (get-database addr whitelist-db)) + (yes-or-no-p "Already white, really convert to ad?")) + (if (new-ad addr) + (save-ad))))) + +(defun add-quaker() + (interactive) + (let ((addr (get-addr-before-point))) + (when (new-quaker addr) + (save-quaker)) + (quaker-sig-maybe))) + +; not needed anymore because of gnus-posting-styles (q.v. in gnus-init) +(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 quaker-sig-maybe () + (save-excursion + (goto-char (point-min)) + (cond ((to-quaker-p) + (goto-char (point-min)) + (cond ((search-forward "\nFrom: ht@home.hst.name" nil t) + (backward-char 13) + (delete-char 4) + (insert "rsof"))))) + + (goto-char (point-max)) + (search-backward "\n-- \n") + (when (looking-at "\n-- \nHenry") + (forward-char 5) + (kill-entire-line 5) + (insert-file "~/.quaker-sig")))) + +(defun kill-white () + (interactive) + (gnus-summary-goto-article (gnus-summary-article-number)) + (let ((addr (get-current-from-addr))) + (rem-white addr))) + +(defun get-from-gnus-addr () + (get-from-addr (gnus-fetch-field "From"))) + +(defun get-from-addr (addr) + (get-canonical-from-addr (gnus-extract-address-components addr))) + +(defun get-canonical-from-addr (components) + (downcase (cadr components))) + +(defun get-current-from-addr () + (with-current-buffer gnus-article-buffer + (get-from-gnus-addr))) + +(defun get-current-from-components () + (with-current-buffer gnus-article-buffer + (gnus-extract-address-components (gnus-fetch-field "From")))) + +(defun get-addr-before-point () + (let ((cur (point))) + (save-excursion + (get-from-addr (buffer-substring (+ (search-backward " ") 1) cur))) + )) + +(defun blacken-and-delete (group) + ;; mis-named now + ;; this is part of the expiry processing for xxxSPAM groups, and + ;; actually whitens the from addresses of #-marked articles + ;; The return value is crucial (and crucially outside of the scope of the if) + (if (memq number + (with-current-buffer gnus-summary-buffer + gnus-newsgroup-processable)) + (let ((addr (get-from-gnus-addr))) + (new-white addr))) + 'delete) + +(defun unwhiten-and-delete (group) + ;; unused except in stale groups -- usable as an expiry + (if (memq number + (with-current-buffer gnus-summary-buffer + gnus-newsgroup-processable)) + (let ((addr (get-from-gnus-addr))) + (remove-database addr whitelist-db))) + 'delete) + +(defun known-black (list) + (if (get-database (get-from-gnus-addr) blacklist-db) + list)) + +(defun white-spam (list) + (if (or (equal (get-database (get-from-gnus-addr) whitelist-db) "t") + (let ((case-fold-search t) + (subj (gnus-fetch-field "Subject")) + (from (get-from-gnus-addr))) + (or + (and subj (string-match white-subjects subj)) + (and from + (let ((fromDom (substring from (+ 1 (search "@" from))))) + (and fromDom (member fromDom white-domains))))))) + list)) + +(defun ad-spam (list) + (if (let ((from (get-from-gnus-addr))) + (or + (equal (get-database from adlist-db) "t") + (and from + (let ((fromDom (substring from (+ 1 (search "@" from))))) + (and fromDom (member fromDom ad-domains)))) + )) + list)) + +(defun bogoNote (group) + (if (memq number + (with-current-buffer gnus-summary-buffer + gnus-newsgroup-processable)) + (let ((addr (get-from-gnus-addr))) + (new-white addr))) + (shell-command-on-region (point-min) (point-max) + "/afs/inf.ed.ac.uk/user/h/ht/share/bin/local/makeBogo") + 'delete) + +(defun whiten-recip () + ;;; a hook for outgoing mail + (let* ((recips (message-options-get 'message-recipients)) + (res (mapcar (function new-white) + (split-string (downcase recips) + ",[ \f\t\n\r\v]*" t)))) + (while (and res (not (car res))) + (setq res (cdr res))) + (if res (save-white)))) + + +(defun new-white (addr) + (if (get-database addr whitelist-db) + nil + (put-database addr "t" whitelist-db) + t)) + +(defun new-ad (addr) + (if (get-database addr adlist-db) + nil + (put-database addr "t" adlist-db) + t)) + +(defun rem-ad () + (interactive) + (remove-database (downcase (get-current-from-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)) + +(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 showMPAhtml () + "Show the text/html parts of an multipart/alternative message using lynx" + (interactive) + (gnus-summary-select-article) + (with-current-buffer gnus-original-article-buffer + (shell-command-on-region (point-min) (point-max) "/home/ht/bin/showMPA.sh") + ) + ) + +(provide 'my-news)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/pers-init.el Sat Oct 07 12:43:14 2023 +0100 @@ -0,0 +1,438 @@ +;;; 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 + +;;; mail stuff +(setq mail-archive-file-name "~/mail/cpy/general") +(setq rmail-dont-reply-to-names "hthompso*\\|h\\.thompso*\\|ht@*" ) +(set-default 'ht-last-file (expand-file-name "~/mail/")) +(setq ht-diary-file-name "~/mail/diary.babyl") +(setq mail-append-host "inf.ed.ac.uk") +(setq user-full-name "Henry S. Thompson") +(setq user-mail-address "ht@inf.ed.ac.uk") +(setq mail-host-address "inf.ed.ac.uk") + +;; new mail hackery +(site-caseq ((edin ircs ldc) + (setq rmail-spool-directory (file-name-as-directory + (concat rmail-spool-directory + "ht-mail"))))) + +;; sending mail on the road +;; [moved to mail-from-m.el, which is required by gnus-init.el + +;; don't know why this is necessary +(site-caseq ((edin) + (setq rmail-primary-inbox-list + (list (concat rmail-spool-directory "ht"))))) + +;; Perforce + +;;(setq p4-global-server-port "zorg.milowski.com:1666") +;;(setenv "P4PORT" "zorg.milowski.com:1666") +;;(setenv "P4CLIENT" "MarkupMan") +;;(setenv "P4CONFIG" ".p4env") +;;(load-library "p4") +;;(setq p4-use-p4config-exclusively t) +;;(p4-set-p4-executable "/c/Program Files/Perforce/p4.exe") +(setq vc-command-messages t) + +(setq minibuffer-max-depth nil) +(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)) + 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"))) + (edin (setq load-path (cons + "/home/ht/emacs/shared/gnus-5.0.15/lisp" + load-path)))) + +(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)) + +(site-caseq ((laptop maritain)) + (t(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) + (site-caseq ((laptop maritain)) + (t(require 'lemacs-compat)))) + +(if (boundp 'epoch::version) + ;; epoch only goes here + (progn + (if (string-match "4\\."emacs-version) + (load "motion4" nil t) + (load "motion" nil t)) + (redisplay-frame) + + (require 'alarm) + (idle-save 15) + + (defun ht-rooms-setup (&optional arg) + (interactive) + (redisplay-frame) + (require 'mail-extras) + (require 'diary) + (require 'my-news) + (let ((scr (current-frame))) + (load "ht-rooms-epoch.config" nil t) + (unwind-protect (make-frame-for-room "diary" "-0" "+130")) + (unwind-protect (make-frame-for-room "elisp" "-25" "+148")) + (unwind-protect (make-frame-for-room "news" "-50" "+166")) + (unwind-protect (make-frame-for-room "mail" "-75" "+184")) + (epoch::delete-frame scr)) + ;; presumably this is now frame local, so not quite the right thing. + (setq ht-default-config (current-window-configuration))) + )) +(if (string-match "^\\(19\\|2\\)" emacs-version) + (progn + ;; common v19 + (if window-system + (progn + (add-hook 'sh-mode-hook '(lambda () + (font-lock-mode 1))) + (add-hook 'lsl-mode-hook '(lambda () + (font-lock-mode 1))) + (add-hook 'perl-mode-hook '(lambda () + (font-lock-mode 1))) + (add-hook 'emacs-lisp-mode-hook '(lambda () + (font-lock-mode 1))) + (add-hook 'lisp-mode-hook '(lambda () + (font-lock-mode 1))) + (add-hook 'sgml-mode-hook '(lambda () + (if (not + (boundp 'sgml-font-lock-keywords)) + (load "sgml-font-lock-keywords" t t)) + (setq adaptive-fill-mode nil) + (font-lock-mode 1) + )) + (add-hook 'c-mode-hook '(lambda () + (font-lock-mode 1))) + (add-hook 'c++-mode-hook '(lambda () + (font-lock-mode 1))) + (add-hook 'scheme-mode-hook + '(lambda () + (setq + scheme-font-lock-keywords + (if (or + (boundp 'lisp-font-lock-keywords) + (load "lisp-font-lock-keywords" t t)) + lisp-font-lock-keywords)) + (font-lock-mode 1))) + (add-hook 'python-mode-hook '(lambda () + (font-lock-mode 1))) + (setq py-python-command "//c/Program Files/Python22/python") + (setq sgml-insert-missing-element-comment nil) + (load "psgml" nil t) + (load "psgml-edit" nil t) + ;; (load "xml-hack" nil t) +; (setq sgml-catalog-files '("CATALOG" "f:/lib/sgml/catalog")) + (if (string-match "i386" (emacs-version)) + (progn (defun win32-get-clipboard-data-cmd () + (interactive)(insert (win32-get-clipboard-data))) + (global-set-key + "\C-x\C-y" 'win32-get-clipboard-data-cmd))) + ;; gnus +; (setq mail-signature t) + + ;; loading gnus postponed to e.g. mail-from-delphix, q.v. + + ; (require 'gnus-min) + )) + (load "gnus-init" nil t) + +;; (require 'idle) +;; (idle-save 15) + + (if (string-match "Lucid" emacs-version) + ;; lemacs only goes here + (progn + (message "lem") + (setq bbdb-north-american-phone-numbers-p nil) + (setq bbdb-use-pop-up nil) + (require 'mail-abbrevs) + (require 'bbdb) + ;(require 'bbdb-rmail) + (require 'bbdb-com) ; to fix auto-fill + (setq mail-use-rfc822 nil) + (add-hook 'gnus-summary-mode-hook + (function (lambda () + (make-local-variable 'mail-use-rfc822) + (setq mail-use-rfc822 t)))) + (if (>= emacs-major-version 21) + (progn + (add-hook 'gnus-startup-hook 'bbdb-insinuate-gnus) + (add-hook 'gnus-startup-hook 'bbdb-insinuate-message))) + (fset 'bbdb-auto-fill-function (lambda () t)) ; ditto + (fmakunbound 'bbdb-orig-rmail-expunge) + ;(add-hook 'rmail-mode-hook 'bbdb-insinuate-rmail) + (add-hook 'gnus-startup-hook 'bbdb-insinuate-gnus) + (add-hook 'mail-setup-hook 'bbdb-insinuate-sendmail) + (setq bbdb-dwim-net-address-allow-redundancy t) + (add-hook 'mail-setup-hook 'bbdb-define-all-aliases) + (add-hook 'gnus-message-setup-hook 'bbdb-define-all-aliases) + (if (not (fboundp 'define-mail-abbrev)) + ;; fix a bug which crashes occasionally -- see also + ;; bbdb-com + (progn + (require 'sendmail) + ;(defadvice sendmail-pre-abbrev-expand-hook + ; (before bbdb-rebuilt-all-aliases activate) + ; (bbdb-rebuilt-all-aliases)) + )) + (defun gnuserv-start-maybe () + (if (not (frame-live-p gnuserv-frame)) + (gnuserv-start))) +;;; (require 'itimer) +;;; (start-itimer "gsr" 'gnuserv-start-maybe +;;; 1200 1200 nil nil) + + (if window-system + (progn + (require 'highlight-headers) + (defun rmail-fontify-headers () + (highlight-headers (point-min) (point-max) t)) + (add-hook 'rmail-show-message-hook 'rmail-fontify-headers) + (setq dired-mode-hook + '(lambda () + (font-lock-mode 1) + (define-key dired-mode-map + [button2] '(lambda (click) + (interactive "e") + (mouse-set-point click) + (dired-advertised-find-file))))) +;; (setq highlight-headers-follow-url-function + ;; 'highlight-headers-ht-follow-url-netscape + ;; browse-url-browser-function + ;;'highlight-headers-ht-follow-url-netscape) + )) +;; (load "~rjc/public_html/device-type-hacking.el") + (load "perl-mode" nil t) + (defun ht-rooms-setup (&optional arg) + (interactive) + (require 'mail-extras) + (require 'diary) + (require 'my-news) + ;; override changed default, except in gnus + (setq mail-use-rfc822 nil) + (add-hook 'gnus-summary-mode-hook + (function (lambda () + (make-local-variable 'mail-use-rfc822) + (setq mail-use-rfc822 t)))) + (if (>= emacs-major-version 21) + (progn + (add-hook 'gnus-startup-hook 'bbdb-insinuate-gnus) + (add-hook 'gnus-startup-hook 'bbdb-insinuate-message))) + (defun ht-rooms-setup (&optional arg) + (interactive) + (require 'mail-extras) + (require 'diary) + (let ((scr (selected-frame))) + ; (sit-for 5) + (load "ht-rooms.config" nil t) + (unwind-protect (make-screen-for-room "diary" "0" "+62")) + ; (sit-for 5) + (unwind-protect (make-screen-for-room "elisp" "-25" "+79")) + ; (sit-for 5) + (unwind-protect (make-screen-for-room "news" "-50" "+96")) + ; (sit-for 5) + (unwind-protect (make-screen-for-room "mail" "-75" "+113")) + (sit-for 1) + (delete-screen scr)) + (setq ht-default-config (current-window-configuration))))) + ;; vanilla v19 goes here + (if window-system + (progn + (defvar ht-frame-parameter-mods + '((auto-raise . t) + (auto-lower . nil) + (cursor-type . bar))) + (nconc + (site-caseq ((laptop maritain) (list '(height . 35))) + (t + (list + '(font . + "-adobe-courier-medium-r-normal--14-*")))) + ht-frame-parameter-mods + ) + ;; 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))))) + + (defun ht-rooms-setup (&optional arg) + (interactive) + (require 'mail-extras) + (require 'diary) + (require 'my-news) + ;; override changed default, except in gnus + (setq mail-use-rfc822 nil) + (add-hook 'gnus-summary-mode-hook + (function (lambda () + (make-local-variable 'mail-use-rfc822) + (setq mail-use-rfc822 t)))) + (let ((scr (selected-frame))) + (load "ht-rooms.config" nil t) + (unwind-protect (make-frame-for-room "elisp" "-25" "-58")) + (unwind-protect (progn + (make-frame-for-room "news" "-50" "-40") + )) + (unwind-protect (progn + (make-frame-for-room "mail" "-75" "-22") + )) + (unwind-protect (progn + (make-frame-for-room + "diary" + "-0" + (concat + "+" + (format + "%d" + (- + (cdr + (assoc + 'top + (frame-parameters + (cdr + (assoc + "elisp" + frames-table))))) + 18)))) + )) + (make-frame-invisible scr)) + (setq ht-default-config (current-window-configuration)))))) + (setq sgml-insert-missing-element-comment nil) + (add-hook 'sgml-mode-hook 'sgml-fix-para) +) + ;; v18 emacs only goes here + (progn + (require 'compress) + (defun ht-rooms-setup (&optional arg) + (interactive) + (require 'mail-extras) + (require 'diary) + (require 'my-news) + (load "ht-rooms.config" nil t) + (setq ht-default-config (current-window-configuration))))) + +(defun ht-rooms-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")) + +(site-caseq (laptop (defun system-name () "francis.markup.co.uk"))) + +(cd (user-home-directory)) + +(require 'misc) ; used to be in common-init... + +(ht-custom-size)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/xquery-mode.el Sat Oct 07 12:43:14 2023 +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