;; .emacs

;; *$Id: emacs,v 1.222 2006/03/02 22:51:16 gmorris Exp $*


;;;; System-dependent conditionals ;;;;
;;;

(defun my-initialize ()
  "Set up the system-dependent variables."
  (interactive)

  ;; Identify host system.
  (let ((host (downcase (system-name))))

    (setq my-system
          (cond
           ((string-match "^\\(cass\\|capc\\)" host) "cass")
           ((string-match ".*\\.ast\\.cam\\.ac\\.uk" host) "xray")
           ((string-match "^\\(furness\\|rgm22\\)" host) "furn")
           ((string-match ".*\\.slac\\.stanford\\.edu" host) "slac")
           ((string-match "grasmoor" host) "gras")
           ((string-match "kipac-dell*" host) "kdell")
           ((string-match ".*\\.stanford\\.edu" host) "stanford")
           ((string-match "\\.gnu\\.org" host) "gnu")
           (t "unkn"))))

  ;; Defaults.
  ;; 'main, 'mail, 'secondary.
  ;; --eval seems to take effect after .emacs is processed, so this
  ;; does not work for the command-line, but can put a temp line at
  ;; top of .emacs.
  (setq my-emacs-type (if (boundp 'my-emacs-type) my-emacs-type
                        (if (or (member "gnus" command-line-args)
                                (member "vm" command-line-args))
                            'mail
                          'main))
        my-printer      (or (getenv "PRINTER") "lp2")
        my-user         "gmorris"
        my-emacsdir     (expand-file-name "~/.emacs.d/")
        my-backupdir    (expand-file-name "backups" my-emacsdir)
        ;; Trailing / here caused error in 20.7 for
        ;; (normal-top-level-add-subdirs-to-load-path function.
        my-sitelisp     (file-truename
                         (expand-file-name
                          "~/scratch/software/share/emacs/site-lisp")))

  (cond
   ((string-equal my-system "xray"))
   ((string-equal my-system "slac")
    (setq my-printer "ki-hp4200"))
   ((string-equal my-system "stanford")
    (setq my-user "rgm"
          my-sitelisp (expand-file-name "~/elisp")))
   ((string-equal my-system "kdell")
    (setq my-printer "hptheory"))
   ((string-equal my-system "gras")
    (setq my-user "gm"))
   ((string-equal my-system "gnu")
    (setq my-printer "InvalidPrinter"
          my-user "rgm"
          my-sitelisp (expand-file-name "~/elisp")))
   ((string-equal my-system "furn")
    (setq my-printer "lp0"
          my-user "gm"
          my-sitelisp "/usr/local/share/emacs/site-lisp")))

  (and (zerop (user-uid)) (setq my-user "root")))

(my-initialize)

;;;
;;;; System-dependent conditionals ;;;;


;; Protect the innocent...
(or (string-equal (user-real-login-name) my-user)
    (error "Init-file belongs to %s, load aborted" my-user))


;;;; Lockfile ;;;;
;;;

(defun my-lockfile-name ()
  "Return name of `my-lockfile' as a string.
Mail lockfiles go in home directory, others in temporary directory."
  (let (dot dir type)
    (if (equal my-emacs-type 'mail)
        (setq dot "."
              dir "~"
              type "-mail")
      (setq dot ""
            dir temporary-file-directory
            type ""))
  (expand-file-name
   (format "%semacs%s%s.lock" dot (user-uid) type)
   dir)))

(setq my-lockfile (my-lockfile-name))


(defun my-lockfile-host ()
  "Extract the hostname from `my-lockfile'."
  (with-temp-buffer
    (insert-file-contents my-lockfile)
    (buffer-substring (point-min) (point-max))))

(defun my-lockfile-create ()
  "Create `my-lockfile'."
  (with-temp-file my-lockfile
    (insert (substring (downcase system-name)
                       0 (string-match "\\." system-name)))))

(defun my-lockfile-delete ()
  "Delete `my-lockfile'."
  (when (file-exists-p my-lockfile)
    (delete-file my-lockfile)))

(if (file-exists-p my-lockfile)
    (if (equal my-emacs-type 'mail)
        (progn
          ;; TODO set bbdb, gnus, vm to readonly?
          ;; Note disabled-command-function barfs in this usage.
          ;; Do not run gnus, since vars from .emacs do not get set.
          (put 'gnus 'disabled t)
          ;; Error aborts processing of .emacs, but not
          ;; command-line-args (it probably should do).
          (error "Mail Emacs already running on %s" (my-lockfile-host)))
      (setq my-emacs-type 'secondary))
  (my-lockfile-create)
  (add-hook 'my-before-kill-emacs-hook 'my-lockfile-delete))

;;;
;;;; Lockfile ;;;;


;; TODO man netrc?
(when (equal my-emacs-type 'mail)
  (require 'private (expand-file-name "private.el" my-emacsdir) t))


;;;; Frame properties ;;;;
;;;

;;; Note menu (and popup) settings may only be specified in ~/.Xdefaults.
;;;
;;; Emacs.geometry: 80x40
;;; Emacs.font: -misc-fixed-medium-r-normal-*-14-*-100-100-*-*-iso8859-1
;;; Emacs.background: DarkSlateGrey
;;; Emacs.foreground: Wheat
;;; Emacs.cursorColor: Orchid
;;; Emacs.pointerColor: Orchid
;;; !!! LessTif resources.
;;; Emacs.pane.menubar.*.fontList:
;;;     -adobe-helvetica-medium-r-normal--12-120-75-75-p-67-iso8859-1
;;; Emacs.pane.menubar.*.Background: DarkSlateGray
;;; Emacs.pane.menubar.*.Foreground: Wheat
;;; !! Popups.
;;; Emacs.dialog*.background: DarkSlateGrey
;;; Emacs.dialog*.foreground: Wheat
;;; Emacs.dialog*.borderColor: lawngreen

(setq my-normal-cursor-colour "Orchid")

(when window-system

  (if (boundp 'tool-bar-button-margin)
      (setq tool-bar-button-margin 3
            tool-bar-button-relief 2))

  (setq ruler-mode-show-tab-stops t)

    ;; "1280x1024\n" or somesuch, if dpyinfo can be executed.
    (let ((resvar
           (shell-command-to-string
            "/usr/X11R6/bin/xdpyinfo |awk '$1 ~ /dimensions/ {print $2; exit}'"
            )))

      (setq default-frame-alist
            `(
              ;; "#181839", azure.
              (background-color . ,(if (string-equal my-user "root") "Black"
                                     "DarkSlateGrey"))
              (foreground-color . ,(if (string-equal my-user "root") "White"
                                     "Wheat"))
              ;; Preserve size imposed by Xdefaults.
              ,(cons 'width  (frame-width))
              ,(cons 'height (frame-height))
              (cursor-color     . ,my-normal-cursor-colour)
              (mouse-color      . ,my-normal-cursor-colour)
;;;           (font
;;;            .
;;;            ,(if (string-match "1600x1200" resvar)
;;;                 "-misc-fixed-medium-r-normal--15-120-100-100-c-*-iso8859-1"
;;;               ;; Also accounts for case where dpyinfo not found.
;;;               "-misc-fixed-medium-r-normal--14-110-100-100-c-70-iso8859-1"
;;;               ))
              ))))                ; window-system
;;;
;;;; Frame properties ;;;;


;;;; Startup ;;;;

;; TODO ?
;; This will not fix it for people who copy this file.
;;; (put 'inhibit-startup-echo-area-message 'saved-value t)
;;; (setq inhibit-startup-echo-area-message (user-login-name))
(setq inhibit-startup-buffer-menu t     ; 22.1
      inhibit-startup-echo-area-message my-user
      initial-scratch-message nil)      ; no scratch buffer message

;; Fancy splash.
(if (or (not window-system)
        (not (fboundp 'fancy-splash-screens))
        (equal my-emacs-type 'mail))

    (setq inhibit-startup-message t)

  (defun my-splash ()
    "Show the splash screen."
    (interactive)
    (fancy-splash-screens))

  (setq fancy-splash-delay 10
        fancy-splash-max-time 600)

  (let* ((quote "~/scripts/quote.bash")
         (image (expand-file-name "images/gnuspiritflare.xpm" my-emacsdir))
         (text
          (and (file-executable-p quote) (shell-command-to-string quote))))
    (and (file-exists-p image) (setq fancy-splash-image image))
    (when text
      (setq fancy-splash-text nil) ; comment out to retain default text
      (add-to-list
       'fancy-splash-text
       (list :face '(variable-pitch :foreground "lawngreen" :weight bold)
             "\n\nWelcome to the brave GNU world...\n\n"
             :face '(variable-pitch :foreground "lawngreen")
             "Startup: " (current-time-string) "\n\n"
             text)))))

;;;; Startup ;;;;


;;;; Backups & saves ;;;;
;;;

(setq make-backup-files t               ; make ~ files
      ;; With nil, numbered backups are made only if they already exist.
      ;; A new backup version is made every time the file is loaded.
      version-control nil ; set to t below if `backup-directory-alist' exists
      kept-old-versions 2
      kept-new-versions 2
      ;; Preserves permissions of file being edited. Also affects links.
      backup-by-copying nil
      backup-by-copying-when-linked t
      backup-by-copying-when-mismatch nil
      backup-by-copying-when-privileged-mismatch 200
      delete-old-versions t           ; auto-delete excess numbered backups
      delete-auto-save-files t          ; delete auto-save files on save
      auto-save-default t               ; auto-save on every visit
      auto-save-interval 200            ; input events between auto-saves
      auto-save-timeout 30)             ; seconds idleness before autosave

(unless (file-directory-p my-emacsdir)
  (make-directory my-emacsdir)
  (set-file-modes my-emacsdir 448))

;; Alist of (REGEXP . DIR). Files matching REGEXP backed up to DIR.
;; DIR will be created if necessary. If DIR is an absolute path,
;; full file names with "/" replaced by "!" will be used for the backup.
(if (boundp 'backup-directory-alist)
    (let ((dir my-backupdir))
      (or (file-directory-p dir) (make-directory dir))
      (setq backup-directory-alist `(("." . ,dir))
            version-control t)))  ; only if can have all files in one place

(if (boundp 'confirm-kill-emacs) (setq confirm-kill-emacs 'yes-or-no-p))


;; Move all .saves- files to a specific directory.
;; At least in 21, directories are created if needed.
(let ((dir (expand-file-name "saves" my-emacsdir)))
  (or (file-directory-p dir) (make-directory dir))
  ;; Set to nil for no session recovery.
  (setq auto-save-list-file-prefix (expand-file-name "saves-" dir)))


(defvar my-backup-disable-list nil
  "List of directories/files which should not be backed up.
If an element is a file, it is not backed up.
If an element is a directory, nothing under that directory is backed up.
File elements may be regexps.")


;; TODO full wildcard support for both file and directory elements of
;; my-backup-disable-list.
(defun my-backup-enable-predicate (name)
  "Function to use for `backup-enable-predicate'.
First runs `normal-backup-enable-predicate'. If that is non-nil,
checks against the elements of `my-backup-disable-list', if non-nil.
Returns t to enable backup, nil otherwise."
  (when (normal-backup-enable-predicate name)
    (not
     (when (listp my-backup-disable-list)
       (catch 'found
         (let (comp)
           (dolist (elem my-backup-disable-list)
             ;; t if elem matches name.
             ;; -N if elem < name (ie name > elem).
             ;; - (1 + N) is number of matching characters at start.
             ;; +N is elem > name (ie name < elem).
             ;; N - 1 is number of matching characters at start.
             (setq comp (compare-strings elem 0 nil name 0 nil))
             (and
              ;; TODO is this worse than file-directory-p?
              ;; After all, the directory must exist if it is
              ;; to be relevant.
              (if (string-equal elem (file-name-as-directory elem))
                  ;; elem is a directory.
                  ;; True if name is under elem in the tree.
                  ;; and prevents an error if name == elem and comp is t.
                  (and (not (eq comp t)) (< comp (- (length elem))))
                ;; elem is a file.
                (string-match elem name))
;;;                (eq comp t))
              ;; Break at first match.
              (throw 'found t)))))))))

(and (fboundp 'normal-backup-enable-predicate)
     (setq backup-enable-predicate 'my-backup-enable-predicate))

;;;
;;;; Backups & saves ;;;;


;;;; Display ;;;;

(setq my-enable-cursor-indications t
      my-read-only-cursor-colour "cyan"
      my-overwrite-cursor-colour "green")

(defun my-set-cursor-colour ()
  "Set the cursor colour.
Intended for use with `post-command-hook'.
Adapted from `cua--update-indications' and `cua--post-command-handler'."
  (condition-case nil
      (if my-enable-cursor-indications
          (let ((cursor
                 (cond (buffer-read-only my-read-only-cursor-colour)
                       (overwrite-mode my-overwrite-cursor-colour)
                       (t my-normal-cursor-colour))))
            (and cursor (stringp cursor)
                 (not (string-equal cursor
                                    (frame-parameter nil 'cursor-color)))
                 (set-cursor-color cursor))))
    (error nil)))

(add-hook 'post-command-hook 'my-set-cursor-colour)

(if (boundp 'yank-excluded-properties)
    (add-to-list 'yank-excluded-properties 'face))

(put 'truncate-lines 'permanent-local t)

;; If t, `debug-on-error' is set to t when interactively evaluating.
(setq eval-expression-debug-on-error nil
      enable-local-variables t
      enable-local-eval 'query)


;; Make all "yes or no" prompts show "y or n" instead.
(fset 'yes-or-no-p 'y-or-n-p)
;; Do not accept space for yes.
(define-key query-replace-map " " 'undefined)      ; 'act
(define-key query-replace-map [delete] 'undefined) ; 'skip
(define-key query-replace-map [backspace] 'undefined) ; 'skip


(setq mouse-yank-at-point t             ; yank to point rather than cursor
      column-number-mode t
      next-line-add-newlines nil        ; do not scroll past end of file
      require-final-newline t           ; always end a file with a newline
      buffers-menu-max-size 25          ; number of listed buffers
      message-log-max 1000
      line-number-display-limit 10000000 ; characters - 21 supports nil
      default-buffer-file-coding-system 'undecided-unix
      ;; Controls subdivision of mouse buffer menu into mode groups.
      mouse-buffer-menu-mode-mult 4
      track-eol nil
      display-buffer-reuse-frames t
      history-delete-duplicates t
      even-window-heights nil
      custom-buffer-style 'brackets
      cursor-in-non-selected-windows t
      highlight-nonselected-windows t   ; for `transient-mark-mode'
      compile-auto-highlight t
      imenu-max-items 50
      imenu-scanning-message nil ; tends to obscure more useful things
      x-select-enable-clipboard nil
      focus-follows-mouse nil
      ;; Preserve vertical screen position of point when scrolling.
      scroll-preserve-screen-position t
      scroll-step 1                     ;0 ?
      kill-ring-max 100)


;; Escape character before non-breaking space (C-q 240) and
;; non-breaking hyphen (C-q 255).
(if (boundp 'show-nonbreak-escape) (setq show-nonbreak-escape t))

(defadvice set-mark-command (after no-bloody-t-m-m activate)
  "Prevent consecutive marks activating bloody `transient-mark-mode'."
  (if (eq transient-mark-mode 'lambda)
      (setq transient-mark-mode nil)))

(defadvice mouse-set-region-1 (after no-bloody-t-m-m activate)
  "Prevent mouse commands activating bloody `transient-mark-mode'."
  (if (eq transient-mark-mode 'only)
      (setq transient-mark-mode nil)))

(if (boundp 'mouse-1-click-follows-link)
    (setq mouse-1-click-follows-link nil))


(setq large-file-warning-threshold (* 20 1024 1024))


;; TODO check system memory instead?
(when (string-match "^\\(xray\\|slac\\)$" my-system)
  (setq undo-limit 40000
        undo-strong-limit (floor (* 1.5 undo-limit)))
  (if (boundp 'undo-outer-limit) (setq undo-outer-limit 400000)))

(setq special-display-buffer-names '("*info*")
      special-display-regexps '(".*-diff\\*" "\\*Man .*\\*")
      special-display-frame-alist
      `((unsplittable . nil)
        ,(cons 'height (frame-height)))
      same-window-buffer-names (delete "*info*" same-window-buffer-names))

(mapcar (lambda (e) (if (string-match "\\\\*info\\\\*" e)
                        (setq same-window-regexps
                              (delete e same-window-regexps))))
        same-window-regexps)

(mapcar (lambda (pair) (if (boundp (car pair))
                           (set (car pair) (cdr pair))))
        '((mode-line-in-non-selected-windows  . t)
          (default-indicate-buffer-boundaries . 'left)
          (overflow-newline-into-fringe       . t)))

;; Annoying really. Only does lines after end of buffer.
;;;(if (boundp 'indicate-empty-lines) (setq-default indicate-empty-lines t))

;; Added to options menu.
(when (boundp 'show-trailing-whitespace)
  ;; Mode name must be same as mode variable.
  (define-minor-mode show-trailing-whitespace
    "Toggle display of trailing whitespace.
With optional numeric argument ARG, activate trailing whitespace display if
ARG is positive, otherwise deactivate it."
    :init-value nil
    :lighter " WS")

  (defun my-show-trailing-whitespace ()
    "Activate `show-trailing-whitespace' mode."
    (show-trailing-whitespace 1))

  (mapcar (lambda (hook) (add-hook hook 'my-show-trailing-whitespace))
          '(sh-mode-hook emacs-lisp-mode-hook f90-mode-hook
                         fortran-mode-hook awk-mode-hook
                         change-log-mode-hook c-mode-hook
                         tcl-mode-hook)))

(setq bookmark-default-file (expand-file-name "bookmarks" my-emacsdir))


;; Save places in files.
(setq save-place-file (expand-file-name "places" my-emacsdir))

(when (and (not (equal my-emacs-type 'mail))
                (require 'saveplace nil t))
           (setq-default save-place t)
           (setq save-place-limit 200
                 save-place-version-control 'never))


(let (func arg)
  (mapcar (lambda (elem)
            (setq func (car elem)
                  arg (cdr elem))
            (and (fboundp func) (funcall func arg)))
          '((tool-bar-mode                    . -1)
            (blink-cursor-mode                . -1)
            (reveal-mode                      .  1)
            (file-name-shadow-mode            .  1)
            (minibuffer-electric-default-mode .  1)
            (size-indication-mode             .  1)
            (auto-image-file-mode             .  1)
            (auto-compression-mode            .  1))))

;; TODO There should be an easier way than this.
(when (boundp 'jka-compr-compression-info-list)
  (add-to-list 'jka-compr-compression-info-list
               '["\\.ASZ\\'" "zipping" "gzip" ("-c" "-q")
                 "unzipping" "gzip"  ("-c" "-q" "-d") t t "\037\213"])
  (require 'jka-compr)
  (jka-compr-uninstall)
  (jka-compr-install))

;; TODO Mimic tail -f. Only works when cursor is in reverting buffer?
(add-hook 'after-revert-hook
          (lambda () (when (bound-and-true-p auto-revert-mode)
                       (goto-char (point-max)))))

(setq apropos-sort-by-scores t)

(setq tooltip-delay         0.5
      tooltip-short-delay   0.1
      tooltip-recent-second 1
      tooltip-hide-delay    5)

(when (featurep 'tooltip)
  ;; Replaced with gud-tooltip-mode in 22.1.
  (if (boundp 'tooltip-gud-tips-p) (setq tooltip-gud-tips-p t))
  ;; Replaced with gud-tooltip-mode?
  (if (fboundp 'tooltip-gud-tips-setup) (tooltip-gud-tips-setup)))


(defun my-face-set (face props)
  "If FACE is a face, set its properties to PROPS."
  (when (facep face)
    (face-spec-set face props)))

(my-face-set 'tooltip
             ;; Turn off variable-pitch.
             '((t (:foreground "black" :inherit default
                               :background "light goldenrod yellow"))))

(when (fboundp 'propertize)

  (defface display-time-mail-face '((t (:background "cornflower blue")))
    "If display-time-use-mail-icon is non-nil, its background colour is that
of this face. Should be distinct from mode-line. Note that this does not seem
to affect display-time-mail-string as claimed.")

  (setq
   ;; First two not needed if set display-time-string-forms directly.
   display-time-day-and-date t
   display-time-24hr-format  t
   display-time-interval     10
   display-time-mail-file (expand-file-name my-user "/var/spool/mail/")
   display-time-use-mail-icon t
   display-time-mail-face 'display-time-mail-face
   display-time-mail-icon
   (let ((file (expand-file-name "images/letter.xpm" my-emacsdir)))
     (if (file-exists-p file)
         `(image :type xpm
                 :file ,file
                 :ascent center
                 :color-symbols
                 (list
                  (cons "BG" (face-attribute
                              'display-time-mail-face :background))))))
   ;; XPM supports transparency, so that the background colour
   ;; always matches that of the mode-line, whether active or not.
   my-display-time-icon
   (let ((file (expand-file-name "images/clock.xpm" my-emacsdir)))
     (if (file-exists-p file)
         `(image :type xpm
                 :file ,file
;;;                 :color-symbols (("FG" . "blue"))
                 :ascent center)))
   ;; (mapconcat 'eval display-time-string-forms "") is used.
   display-time-string-forms
   `(
     ;; Mode-line a bit crowded, so put time and date in tool-tip.
     ;; Note that even if this is made buffer-local, there is
     ;; only ever one value active at a time, applying to all windows.
     (propertize "*"
                 'display
                 (if (and my-display-time-icon (display-graphic-p))
                     (append
                      my-display-time-icon
                      (list
                       :color-symbols
                       (list
                        (cons "FG" "slate grey")))))
;;;                              (face-attribute 'mode-line :foreground))))))
;;;
;;;                       (if (string-equal (buffer-name) "*scratch*")
;;;                           (list
;;;                            :background (face-attribute
;;;                                         'mode-line :foreground)
;;;                            :foreground (face-attribute
;;;                                         'mode-line :background))
;;;                         (list
;;;                          :background (face-attribute
;;;                                       'mode-line-inactive :foreground)
;;;                          :foreground (face-attribute
;;;                                       'mode-line-inactive :background))
;;;                         )))
                 'help-echo (format-time-string "%H:%M, %A %B %e %Y"))
     (if mail
         (concat " "
                 (propertize
                  "MAIL"
                  'display
                  (and display-time-use-mail-icon (display-graphic-p)
                       display-time-mail-icon)
                  'help-echo "mouse-2: read mail"
                  'local-map
                  (make-mode-line-mouse-map 'mouse-2 read-mail-command)))
       "")))

  ;; I despair of this.
;;;  (add-hook 'display-time-hook
;;;            (lambda () (make-local-variable 'display-time-string)))
;;;   (defadvice display-time-update (around set-face activate)
;;;     "Update all buffer-local values of display-time-string, and set
;;; face appropriately."
;;;     (make-local-variable 'display-time-string)
;;;     (let (winflag (win (selected-window)))
;;;       (walk-windows
;;;        (lambda (window)
;;;          (setq winflag (or (not (facep 'mode-line-inactive))
;;;                            (equal window win)))
;;;          ad-do-it
;;;          )
;;;        nil 'visible)))

  ;; Works, but not if current buffer is displayed in > 1 window.
  ;; Need window local variables, which don't exist.
;;;   (let ((nw 0)
;;;         (win (selected-window))
;;;         (count 1))
;;;     ;; count-windows should have an all frames option.
;;;     ;; Not minibuffer, all frames.
;;;     (walk-windows (lambda (w) (setq nw (1+ nw))) nil t)
;;;     ;; Seems to "unlocalize" itself a lot.
;;;     (make-local-variable 'display-time-string)
;;;     (setq display-time-string "here")
;;;     (save-window-excursion
;;;       (while (< count nw)
;;;         ;; other-window buggy - last arg must be t, non just non-nil?
;;;         (other-window 1 t)
;;;         (setq count (1+ count)
;;;               display-time-string "there")
;;;         )))

  ;; Needed in 22.1 if text properties (eg images) are to be interpreted.
  (put 'working-mode-line-message 'risky-local-variable t)

  (display-time-mode 1))                ; propertize

;;;; Display ;;;;


;;;; Display popup on new mail ;;;;
;;; TODO move to a separate file.
;;;
(defvar my-display-mail-file (getenv "MAIL")
  "File to be monitored by `my-display-mail' functions.")

(defvar my-display-mail-interval 10
  "Interval in seconds between checks of `my-display-mail-file' status.")

(setq my-display-mail-file (expand-file-name my-user "/var/spool/mail/")
      my-display-mail-interval 10)

(defun my-display-mail-file-nonempty-p (file)
  "Return non-nil if FILE has size > 0."
  (and (file-exists-p file)
       (< 0 (nth 7 (file-attributes (file-chase-links file))))))

(defun my-display-mail-popup ()
  "Display a popup the first time mail arrives."
  (if (my-display-mail-file-nonempty-p my-display-mail-file) ; mail?
      (when (not my-display-mail-new-p) ; already know about this mail?
        (setq my-display-mail-new-p t)
        (if (x-popup-dialog t
                            '("    New Mail!  "
                              ("OK" . nil) ("Off" . t)))
            (my-display-mail-deactivate)))
    (setq my-display-mail-new-p nil)))  ; no mail

(defun my-display-mail-activate ()
  "Activate the popup mail display."
  (interactive)
  (my-display-mail-deactivate)
  (setq my-display-mail-new-p nil
        my-display-mail-timer
        ;; Run 60 seconds from now.
        (run-at-time 60 my-display-mail-interval 'my-display-mail-popup)))

(defun my-display-mail-deactivate ()
  "Deactivate the popup mail display."
  (interactive)
  (and (boundp 'my-display-mail-timer) (timerp my-display-mail-timer)
       (cancel-timer my-display-mail-timer)))

;; On a remote host, DISPLAY includes a machine name so is long.
(and window-system
     (not (equal my-emacs-type 'secondary))
     (string-equal my-system "xray")
     (> (length (getenv "DISPLAY")) 4)
     (my-display-mail-activate))
;;;
;;;; Display popup on new mail ;;;;


;;;; Time-stamp ;;;;

(setq time-stamp-active t
      time-stamp-warn-inactive t
;;;      time-stamp-format "%:y-%02m-%02d %02H:%02M:%02S %u" ; default
      time-stamp-format "%3a %02d-%3b-%:y %02H:%02M:%02S %u on %s")

;; Auto update timestamp in stamped files.
(unless (equal my-emacs-type 'mail)
  (add-hook (if (boundp 'before-save-hook) 'before-save-hook
              'write-file-hooks) 'time-stamp))

;;;; Time-stamp ;;;;


;;;; Faces ;;;;
;;;

(when (and (not (equal my-emacs-type 'mail))
           (require 'help-fns nil t))

  (if (fboundp 'help-default-arg-highlight)
      (fset 'help-default-arg-highlight '(lambda (arg) arg)))

  (defface help-highlight-face
    '((t (:underline t)))
    "Face used by `help-make-xrefs' to highlight cross-references.
Default is underline. Don't make it too gaudy!")

  (setq help-highlight-face 'help-highlight-face)) ; 'help-fns


(defface occur-match-face
  '((t (:foreground "pink" :weight bold)))
  "Face used by `occur' to highlight matching regexps.
See variable `list-matching-lines-face' (default bold).")

(defface occur-buffer-name-face
  '((t (:foreground "yellow")))
  "Face used by `occur' to highlight buffer name.
See variable `list-matching-lines-buffer-name-face' (default underline).")

(setq list-matching-lines-face 'occur-match-face
      list-matching-lines-buffer-name-face 'occur-buffer-name-face)


(my-face-set 'completions-first-difference
             '((t (:foreground "cyan" :weight bold))))

(my-face-set 'completions-common-part
             '((t (:foreground "grey" :weight normal))))

(my-face-set 'minibuffer-prompt '((t (:foreground "cyan"))))


;; cf define-derived-mode.
(defmacro my-make-hook-fn (hook &rest body)
  "Add a function to HOOK, with body BODY."
  (if (fboundp 'declare) (declare (indent 1)))
  ;; hooks often not bound. Could change to using mode as argument,
  ;; and checking that is fbound.
;;;  (or (boundp hook) (error "No such hook `%s'" hook))
  (let ((fn (intern (format "my-%s-fn" hook))))
    `(progn
       (defun ,fn ()
         ,(format "Function added to `%s'." hook)
         ,@body)
       (add-hook ',hook ',fn))))


(my-make-hook-fn Info-mode-hook
  (my-face-set 'info-node '((t (:foreground "white" :weight bold))))
  (my-face-set 'info-xref-visited
               '((t (:foreground "violet" :weight normal :underline nil))))
  (my-face-set 'info-xref '((t (:foreground "cyan" :weight normal
                                            :underline nil)))))


(when window-system

  ;; Note no `set-face-attribute' pre-21.
  (if (facep 'mode-line)
      (set-face-attribute 'mode-line nil ; all frames
                          :foreground "DarkSlateGrey" :background "Wheat"))

  ;; TODO inherit foreground from mode-line (inactive or not).
  (my-face-set 'mode-line-highlight
               '((t :background "light sky blue" :foreground "black")))

  (when (facep 'fringe)
    (cond ((equal my-emacs-type 'mail)
           (set-face-attribute 'fringe nil
                               :foreground "lawngreen"
                               :background "SeaGreen4"))
          ((equal my-emacs-type 'secondary)
           (set-face-attribute 'fringe nil
                               :foreground "lawngreen"
                               :background "slategrey"))
          (t
           (set-face-attribute 'fringe nil
                               :foreground "lawngreen"
                               :background "SteelBlue4"))))

  (if (facep 'tool-bar) (set-face-background 'tool-bar "DarkSlateGrey"))

  ;; Does something odd to frame-height / make-frame in 21.3.50.
  ;; Applies to S-Mouse1 menu.
  ;; .Xdefaults at last not needed!
;;;  (my-face-set 'menu
;;;               '((t (:foreground "Wheat" :background "DarkSlateGrey")))))

  (if (facep 'trailing-whitespace)
      (set-face-background 'trailing-whitespace "SeaGreen1"))

  (my-face-set 'minibuffer-prompt '((t (:foreground "cyan"))))

  ;; eg ^L, \203, etc.
  (my-face-set 'escape-glyph '((t (:foreground "cyan" :weight bold))))

  (when (fboundp 'set-face-attribute)
    (face-spec-set 'italic
                   '((t (:slant italic :underline nil :family "helvetica"))))
    (face-spec-set 'bold-italic
                   '((t (:slant italic :underline nil
                               :weight bold :family "helvetica"))))))


(my-make-hook-fn custom-mode-hook
  (when window-system
    (my-face-set 'custom-button-face
                 '((t (:box (:line-width 2 :style released-button)
                            :foreground "wheat" :background "DarkSlateGrey"))))
    (my-face-set 'custom-button-pressed-face
                 '((t (:box (:line-width 2 :style pressed-button)
                            :foreground "wheat" :background "DarkSlateGrey"
                            ))))))

(eval-after-load "font-lock"
  '(progn
     (face-spec-set 'font-lock-builtin-face
                    '((t (:foreground "LightSteelBlue"))))
     (face-spec-set 'font-lock-comment-face
                    '((t (:foreground "OrangeRed"))))
     (face-spec-set 'font-lock-constant-face
                    '((t (:foreground "Aquamarine"))))
     (face-spec-set 'font-lock-function-name-face
                    '((t (:foreground "LightSkyBlue" :weight bold))))
     (face-spec-set 'font-lock-keyword-face
                    '((t (:foreground "Cyan"))))
     (face-spec-set 'font-lock-string-face
                    '((t (:foreground "LightSalmon")))) ; aquamarine3
     (face-spec-set 'font-lock-type-face
                    '((t (:foreground "PaleGreen" ))))
     (face-spec-set 'font-lock-variable-name-face
                    '((t (:foreground "LightGoldenrod" :weight bold))))
     (face-spec-set 'font-lock-warning-face
                    '((t (:foreground "pink" :weight bold))))
     (my-face-set 'font-lock-regexp-backslash
                  '((t :foreground "sienna")))
     (my-face-set 'font-lock-regexp-backslash-construct
                  '((t :inherit 'bold)))))

;; Change default highlight colour from DarkOliveGreen.
(set-face-background 'highlight "Blue")

;;;
;;;; Faces ;;;;


;;;; Auto-mode alist ;;;;
(let (ext mode)
  (mapcar (lambda (elem)
            (when elem
              (setq ext (regexp-quote (car elem))
                    mode (cdr elem))
              (add-to-list 'auto-mode-alist `(,(concat ext "\\'") . ,mode))))
          `((".awk"     . awk-mode)
            (".bash"    . shell-script-mode)
            (".tcsh"    . shell-script-mode)
            ("README"   . text-mode)
            (".notes"   . text-mode)
            (".texinfo" . texinfo-mode)
            (".cps"     . ps-mode)
            ,(if (string-equal my-system "cass") '(".html" . html-mode)))))
;;;; Auto-mode alist ;;;;


;;;; Load-path ;;;;
;;;

;; Most important directories last.
(let (dir flag default-directory)
  (mapcar (lambda (elem)
            (setq dir (car elem)
                  flag (cdr elem)
                  default-directory dir)
            (when (and dir (file-directory-p dir))
              (add-to-list 'load-path dir)
              (and flag
                   (fboundp 'normal-top-level-add-subdirs-to-load-path)
                   ;; Can use .nosearch to exclude.
                   (normal-top-level-add-subdirs-to-load-path))))
          `(
            ;; These just annoy me.
            ,(if (string-match "^\\(cass\\|kdell\\)$" my-system)
                 '("/usr/local/share/emacs/site-lisp" . t))
            ("/usr/share/emacs/site-lisp"   . t)
            ("/usr/share/emacs21/site-lisp" . t)
            (,my-sitelisp . t)
            ;; Only want ~/lisp/pre-21 with old Emacs.
            (,(expand-file-name "~/elisp") . ,(< emacs-major-version 21)))))

;;;
;;;; Load-path ;;;;


(when (locate-library "debian-startup")
  (load-library "debian-startup")
  (debian-startup 'emacs21))


;;;; TAGS ;;;;
(if (boundp 'tags-table-list)
    (mapcar (lambda (dir)
              (and (file-directory-p dir)
                   (file-exists-p (expand-file-name "TAGS" dir))
                   (add-to-list 'tags-table-list dir)))
            ;; Order of increasing importance.
            (list (expand-file-name "lisp"  source-directory)
                  (expand-file-name "lwlib" source-directory) ; make tags
                  (expand-file-name "src"   source-directory) ; make tags
                  my-sitelisp
                  ;; Note doc-directory rather than data-directory -
                  ;; different in non-installed Emacs.
                  (expand-file-name "../"   doc-directory))))
;;;; TAGS ;;;;


;;;; Disable/enable ;;;;

;; Undo these with C-x n w
(put 'narrow-to-region 'disabled nil)   ; C-x n n
(put 'narrow-to-page   'disabled nil)   ; C-x n p
(put 'narrow-to-defun  'disabled nil)   ; C-x n d

(put 'downcase-region  'disabled nil)
(put 'upcase-region    'disabled nil)

(put 'rmail 'disabled t)

;; VM not a problem since does not get loaded.
(unless (equal my-emacs-type 'mail)
  (put 'gnus 'disabled t))

;;;; Disable/enable ;;;;


;;;; Advice ;;;;
(defadvice find-file (around confirm-new-file activate)
  "If file does not exist, prompt."
  (let ((file (ad-get-arg 0)))
    (if (or (not (interactive-p))
             (find-buffer-visiting file)
             ;; old/new style Tramp.
             (string-match "\\`/\\(\\[\\|[[:alnum:]]+@?:\\)" file)
             (file-directory-p file)
             (file-expand-wildcards file)
             (yes-or-no-p
              (format "`%s' does not exist, create buffer? " file)))
        ad-do-it)))


(defadvice switch-to-buffer (around confirm-new-buffer activate)
  "If buffer does not exist, prompt."
  (let ((buff (ad-get-arg 0)))
    (if (or (not (interactive-p))
            (get-buffer buff)
            (yes-or-no-p
             (format "Buffer `%s' does not exist, create? " buff)))
        ad-do-it)))


;; kill-emacs-hook does not seem to do what I would want.
(defvar my-before-kill-emacs-hook nil
  "Hook to run before `save-buffers-kill-emacs'.")

(defadvice save-buffers-kill-emacs (around before-kill-hook activate)
  "Run `my-before-kill-emacs-hook' before save-buffers-kill-emacs."
  ;; This is so that an abortive exit does not mess up our session.
  ;; Also quite nice since it means we do not get prompted to save
  ;; files etc unless we have really decided to exit emacs.
  ;; But maybe we will change our mind if we know files have to be saved?
  (when (yes-or-no-p "Really exit Emacs? ")
    (run-hooks 'my-before-kill-emacs-hook)
    (setq confirm-kill-emacs nil)       ; no need to ask twice
    ad-do-it))

;;;; Advice ;;;;


;;;; Functions ;;;;
;;;

(defun my-process-running (name)
  "Return non-nil if a process called NAME is running under current user."
  (string-match (format "[ \t]%s$" (regexp-quote name))
                (shell-command-to-string
                 (format "ps -u %s" (user-uid)))))


(defun my-get-track (&optional stat)
  "Call the appropriate my-player-get-track function."
  (interactive "P")
  (cond ((my-process-running "orpheus")
         (my-orpheus-get-track))
        ((my-process-running "gqmpeg")
         (my-gqmpeg-get-track stat))
        ((my-process-running "xmms")
         (my-xmms-get-track stat))
        ((string-equal my-system "slac")
         (let ((h (my-get-remote-host)))
           (and h
                (string-equal h "171.64.56.172")
                (my-get-remote-track))))))


(defun my-get-remote-host ()
  "Try to get the IP address of the remote ssh host."
  (let ((str (getenv "SSH_CLIENT")))
    (when str
      (string-match "^\\([0-9.]+\\)" str)
      (match-string 1 str))))


(defun my-get-remote-track (&optional host)
  "Use music-playing.bash script on HOST to get current track.
With no HOST, use `my-get-remote-host'."
  (interactive (list (read-from-minibuffer "Enter host name: ")))
  (when
      (if host
          (zerop (shell-command (format "/bin/ping -c1 %s" host))) ; ugh
        (setq host (my-get-remote-host)))
    ;; TODO need some way to check a passwordless ssh connection
    ;; will work. Also a timeout.
    (with-temp-buffer
      (insert
       (shell-command-to-string
        (format "ssh %s 'PATH=~/bin:$PATH; bin/music-playing -p'" host)))
      (goto-char (point-min))
      (let ((artist "?")
            (track "?")
            (player "?")
            result)
        (if (re-search-forward "^Track :[ \t]*\\(.*\\)" (point-max) t)
            (setq track (match-string 1)))
        (if (re-search-forward "^Artist:[ \t]*\\(.*\\)" (point-max) t)
            (setq artist (match-string 1)))
        (if (re-search-forward "^Player:[ \t]*\\(.*\\)" (point-max) t)
            (setq player (match-string 1)))
        (unless (string-equal track "silence")
          (setq result (format "%s - %s" artist track)))
        (if (interactive-p) (message "%s" result)
          result)))))


(defun my-xmms-get-track (&optional stat)
  "Return as a string the current xmms track, or nil if no track.
With optional STAT, append the track status."
  (interactive "P")
  (let ((file "/tmp/xmms-info")
        track status result)
    (when (and (file-exists-p file)
               ;; Avoid hang if xmms leaves stale FIFO.
               (my-process-running "xmms"))
      (with-temp-buffer
        ;; insert-file-contents does not like FIFOs (bug).
        (insert (shell-command-to-string (format "cat %s " file)))
        (goto-char (point-min))
        (when stat
          (re-search-forward "^Status:[ \t]*\\(.*\\)" (point-max) t)
          (setq status (downcase (or (match-string 1) "?"))))
        (re-search-forward "^Title:[ \t]*\\(.*\\)" (point-max) t)
        (setq track (or (match-string 1) "?")
              result (if stat
                         (format "%s (%s)" track status)
                       (format "%s" track)))))
    (if (interactive-p) (message "%s" result)
      result)))


(defun my-gqmpeg-get-track (&optional stat)
  "Return as a string the current gqmpeg track, or nil if no track.
With optional argument STAT, append the track status."
  (interactive "P")
  (let ((artist "?")
        (track "?")
        status result)
    (when (and (executable-find "gqmpeg")
               (my-process-running "gqmpeg"))
      (with-temp-buffer
        (shell-command "gqmpeg --status" t)
        (goto-char (point-min))
        (setq result (re-search-forward
                      "\\(process not active\\|retrieval failed\\)"
                      (point-max) t))
        (if (re-search-forward "^name:\"\\(.*\\)\"" (point-max) t)
            (setq track (match-string 1)))
        (if (re-search-forward "^artist:\"\\(.*\\)\"" (point-max) t)
            (setq artist (match-string 1)))
        (when (and stat
                   (re-search-forward "^time: \\([a-z]+\\)" (point-max) t))
          (setq status (match-string 1)
                status (cond
                        ((string-equal "play"  status) "playing")
                        ((string-equal "stop"  status) "stopped")
                        ((string-equal "pause" status) "paused")
                        (t "?"))))
        (setq result (if result nil
                       (if stat
                           (format "%s - %s (%s)" artist track status)
                         (format "%s - %s" artist track))))))
    (if (interactive-p) (message "%s" result)
      result)))


;; No status info available for orpheus.
(defun my-orpheus-get-track ()
  "Return as a string the current orpheus track, or nil if no track."
  (interactive)
  (let ((file "~/.orpheus/currently_playing")
        (artist "?")
        (track "?")
        (result "?"))
    (when (and (file-exists-p file)
               (my-process-running "orpheus"))
      (with-temp-buffer
        (insert-file-contents file)
        (goto-char (point-min))
        (if (or (looking-at "\\([^:]+\\): \\(.*\\)")
                (looking-at "\\(.*\\) - \\(.*\\)"))
            (setq artist (match-string 1)
                  track (match-string 2)
                  result (format "%s - %s" artist track))
          (setq result (buffer-substring (point-min) (point-max)))))
    (if (interactive-p) (message "%s" result)
      result))))


(defun my-mail-obfuscate-address (user fake)
  "Supply with USER and address FAKE in the form \"falsename@truedomain\".
Returns the true address \"user@truedomain\".
A little paranoia to protect email addresses from harvesting,
if they are needed in Lisp code that may be distributed on-line."
  (string-match "^\\(\\w+\\)@" fake)
  (replace-match user t nil fake 1))


(find-function-setup-keys)

(defvar my-defun-re
  (regexp-opt '("defun" "defsubst" "defmacro" "defadvice") 'paren)
  "Regular expression used to identify a defun.")

;;; (defvar my-defvar-re
;;;   (regexp-opt '("defvar" "defconst" "defcustom") 'paren)
;;;   "Regular expression use to identify a defvar.")

;; `find-function' does this kind of thing.
(defun my-jump-to-defun (func)
  "Jump to the definition of function FUNC in the current buffer, if found.
Return the position of the defun, or nil if not found."
  (interactive
   ;; From `describe-function'. *NB ?*
   (let ((fn (function-called-at-point)))
     (list (completing-read (if fn
                                (format "Find defun for (default %s): " fn)
                              "Find defun for: ")
                            obarray 'fboundp t nil nil (symbol-name fn)))))
  (let (place)
    (save-excursion
      (goto-char (point-min))
      (if (re-search-forward
           (concat "^[ \t]*(" my-defun-re "[ \t]+"
                   (regexp-quote func) "[ \t]+") (point-max) t)
          (setq place (point))))
    (if (not place)
        (if (interactive-p) (message "No defun found for `%s'" func))
      (when (interactive-p)
        (push-mark)
        (goto-char place)
        (message "Found defun for `%s'" func))
      place)))


;; Use ps-print instead.
(defun my-ps-toggle-landscape ()
  "Toggle the value of ps-landscape-mode, or set to nil if not bound."
  (interactive)
  (if (not (boundp 'ps-landscape-mode))
      (setq ps-landscape-mode nil)
    (setq ps-landscape-mode (not ps-landscape-mode))))


(defun my-copy-line-as-kill ()
  "Copy-as-kill from point to end-of-line."
  (interactive)
  (copy-region-as-kill (point) (line-end-position))
  (message "Copied from point to end of line"))


(defun my-stamp (&optional arg)
  "Insert current date, user, and system information.
With optional argument ARG, use \"*Creation: -- *\" format."
  (interactive "*P")
  ;; Get this from time-stamp-format somehow?
  (let ((string (format "<%s %s on %s>"
                        (format-time-string "%a %d-%b-%Y %T")
                        user-login-name
                        system-name)))
    (if arg (setq string (format "*Creation: %s*" string)))
    (if (interactive-p)
        (insert string)
      string)))


;;; TODO replace existing "Creation: header".
(defun my-filestamp (&optional time)
  "Insert the <filename> ... <filename ends here> boilerplate.
With optional prefix arg TIME, insert timestamp info as well."
  (interactive "*P")
;;;  (or comment-start (error "No comment syntax defined"))
  (save-excursion
    (let* ((comment-start (or comment-start "#"))
           (name (file-name-nondirectory buffer-file-name))
           (c (string-to-char comment-start))
           (cc (if (eq major-mode 'c-mode)
                   (replace-regexp-in-string " +$" "" comment-start)
                 (make-string 3 c)))
           (string (format "%s %s" cc name))
           oldname)
      (goto-char (point-max))
      (if (re-search-backward (format "^%s \\(.*\\) ends here"
                                      (regexp-quote cc))
                              (line-beginning-position -5) t)
          ;; Avoid unecessary buffer modification.
          (unless (string-equal (setq oldname (match-string 1)) name)
            (replace-match name nil nil nil 1))
        (insert "\n\n" string " ends here" comment-end "\n"))
      (goto-char (point-min))
      (if (looking-at (format "^\\(#!\\|\\(%s\\)*[ \t]*-\\*- \\)"
                              (replace-regexp-in-string "[ \t]*$" ""
                              comment-start)))
          (forward-line 1))
      (save-excursion
        (and oldname
             (re-search-forward (format "%s \\(%s\\)" cc oldname) nil t)
             (replace-match name nil nil nil 1)))
      ;; Do not add multiple identical copies.
      (unless (looking-at (regexp-quote string))
        ;; TODO make this more robust.
        (if (eq major-mode 'c-mode) (setq cc " *"))
        (insert string "\n"
                (if time
                    (concat cc "\n"
                            cc " "
                            (if (or vc-mode
                                    (file-directory-p "CVS"))
                                (concat "*$I" "d$*")
                              (my-timestamp)) "\n"
                            cc " " (my-stamp t) "\n")
                  "") cc "\n")))))


(defun my-timestamp ()
  "Insert the \"Time-stamp: <>\" string at point."
  (interactive)
  (if (interactive-p) (insert "*Time-stamp: <>*")
    "*Time-stamp: <>*"))


;; TODO remove spaces? Do not downcase?
;; Have ARG specify the string to use instead of always "Status:"?
(defun my-random-colour (&optional arg)
  "Return a random colour as a (lower-case) string.
Excludes colours that end in numbers. With optional prefix arg, insert
colour into buffer at point as a Status: header."
  (interactive "P")
  (if arg (barf-if-buffer-read-only))
  (let* ((cols (defined-colors))
         ;; 0 (inclusive) - length (exclusive), as required by nth.
         (ncols (length cols))
         col)
    (if cols
        (while (or (not col) (string-match "[0-9]$" col))
          (setq col (nth (random ncols) cols)))
      ;; No colours defined. Else infloop!
      (setq col "black"))
    (setq col (downcase col))
    (if arg
        (save-excursion
          (if (progn (goto-char (line-beginning-position))
                     (looking-at ".*Status: \\(.*\\)$"))
              ;; Recurse till get a different colour.
              (if (string-equal col (match-string 1))
                  (my-random-colour arg)
                (replace-match col nil nil nil 1))
            (insert "Status: " col "\n")))
      (if (interactive-p) (message "%s" col)
        col))))


(defun my-random-string (&optional n)
  "Return a string of random characters of length N (default 10)."
  (let ((x ""))
    (dotimes (i (or n 10) x)
      ;; Range chosen from `my-print-chars' output.
      (setq x (format "%s%c" x (+ 33 (random 94)))))))

(defun my-print-chars ()
  "Print the character codes and their characters in a buffer."
  (interactive)
  (let ((buff (generate-new-buffer "*chars*")))
    (with-current-buffer buff
      (dotimes (i 128)
        (insert (format "%d %c\n" i i)))
      (set-buffer-modified-p nil))
    (display-buffer buff)))


;; TODO emacs should do the equivalent.
(defadvice kill-buffer (around buffer-offer-save activate)
  "Confirm kill if `buffer-offer-save' is non-nil."
  (let ((buff (or (ad-get-arg 0) (current-buffer))))
    (when (or (not (interactive-p))
              (not (buffer-modified-p))
              (not (with-current-buffer buff
                     buffer-offer-save))
              (yes-or-no-p (format "Really kill buffer `%s'? " buff)))
      ad-do-it)))


(defun my-scratch-setup (&optional sbuff)
  "Set some properties of the \"*scratch*\" buffer.
With optional buffer name SBUFF, use that instead of \"*scratch*\"."
  (or sbuff (setq sbuff "*scratch*"))
  (when (get-buffer sbuff)
    (with-current-buffer sbuff
      (funcall initial-major-mode)
      (let ((default-directory my-backupdir))
        (auto-save-mode 1))
      (setq buffer-offer-save t
            show-trailing-whitespace nil))))

(defun my-scratch (&optional arg)
  "(Make and) goto scratch buffer.
With optional prefix argument ARG, run `my-scratch-setup' (normally only
run if buffer is created)."
  (interactive "P")
  (let* ((buff "*scratch*")
         (exists (get-buffer buff)))
    (switch-to-buffer (get-buffer-create buff))
    ;; Only set properties if creating buffer, or if ARG.
    (if (or arg (not exists))
        (my-scratch-setup buff))))

(defun my-scratch-offer-save ()
  "Offer to save the scratch buffer.
Also, delete the scratch auto-save file if it exists, so not left with
a scratch auto-save file after every Emacs instance.
Intended for use with `my-before-kill-emacs-hook'."
  (let ((buff "*scratch*")
        file)
    (when (get-buffer buff)
      (with-current-buffer buff
        (when buffer-offer-save
          (save-some-buffers nil
                             (lambda () (string-equal (buffer-name) buff)))
          (setq buffer-offer-save nil))
        (and (setq file buffer-auto-save-file-name)
             (file-exists-p file)
             (delete-file file))
        (setq buffer-auto-save-file-name nil)))))


(unless (equal my-emacs-type 'mail)
  (add-hook 'after-init-hook 'my-scratch-setup)
  (add-hook 'my-before-kill-emacs-hook 'my-scratch-offer-save))


;; cf my-desktop-auto-save.
;; TODO Extract common code.
(defvar my-scratch-auto-save-directory
  (if (file-directory-p my-backupdir)
      my-backupdir
    "~")
  "Directory used by `my-scratch-auto-save'.")

(defvar my-scratch-auto-save-interval 120
  "Interval in seconds before scratch buffer is auto-saved.")

(defvar my-scratch-auto-save-timer nil
    "Timer for `my-scratch-auto-save-mode'.")

(defun my-scratch-auto-save ()
  "Auto-save the scratch buffer to `my-scratch-auto-save-directory'."
  (let ((buff "*scratch*")
        (dir my-scratch-auto-save-directory)
        (file (format "scratch-%s-%s" (format-time-string "%Y_%m_%d")
                      (emacs-pid)))
        (str "Saving scratch..."))
    (when (get-buffer buff)
;;;      (message "%s" str)
      (or (file-directory-p dir)
          (error "Directory `%s' does not exist" dir))
      ;; Delete any existing desktops for this PID (eg from previous day).
      (mapc (lambda (file) (delete-file file))
            (file-expand-wildcards (expand-file-name
                                    (format "scratch-*-%s" (emacs-pid))
                                    dir)))
      (with-current-buffer buff
        (save-restriction
          (widen)
          (unless (zerop (buffer-size))
            (write-region (point-min) (point-max)
                          (expand-file-name file dir) nil 'shutup))))
;;;      (message "%s%s" "done")
      )))

(define-minor-mode my-scratch-auto-save-mode
  "Toggle periodic saving of the scratch buffer.
With optional numeric argument ARG, activate saving only if ARG
is positive."
  :global t
  (if my-scratch-auto-save-mode
      (or my-scratch-auto-save-timer    ; already running?
          (setq my-scratch-auto-save-timer
                (run-with-timer my-scratch-auto-save-interval
                                my-scratch-auto-save-interval
                                'my-scratch-auto-save)))
    (if (timerp my-scratch-auto-save-timer)
        (cancel-timer my-scratch-auto-save-timer))))

(or (equal my-emacs-type 'mail)
    (my-scratch-auto-save-mode 1))


(defun my-messages ()
  "Switch to the `*Messages*' buffer."
  (interactive)
  (switch-to-buffer "*Messages*"))

 ;; Better functions than this exist in Emacs.
(defun my-delete-trailing-whitespace ()
  "Delete all trailing whitespace in buffer.
Return values are suitable for use with `write-file-functions'."
  (condition-case nil
      (progn
        ;; Don't want to do this to mail messages, etc.
        ;; Would an exclude list be better?
        ;; Error was occurring in VM-mode for some reason.
        (when (memq major-mode '(text-mode sh-mode emacs-lisp-mode
                                           f90-mode awk-mode c-mode))
          (message "Cleaning up whitespace...")
          (delete-trailing-whitespace)
          (message "Cleaning up whitespace...done")
          nil))
    (error (message "Cleaning up whitespace...ERROR")
           t)))

;; Too invasive?
;;;(add-hook (if (boundp 'write-file-functions) 'write-file-functions
;;;            'write-file-hooks) 'my-delete-trailing-whitespace)

(defun my-comment-region (start end)
  "Just like `comment-region', but uses 3 comment characters."
  (interactive "*r")
  (comment-region start end (or (eq major-mode 'c-mode) 3)))


;; Don't see any clean way to combine this with `comment-dwim'.
(defun my-comment-indent-region (start end)
  "Indent all the trailing comments in the region.
No new comments will be inserted."
  (interactive "*r")
  (or comment-start (error "No comment syntax defined"))
  ;; Sometimes I define comment-start with trailing whitespace.
  ;; I probably shouldn't do that, but this strips any of that out.
  (let ((cstart (regexp-quote (substring
                               comment-start 0
                               (string-match "[ \t]+$" comment-start)))))
    (save-excursion
      (save-restriction
        (narrow-to-region start end)
        (goto-char (point-min))
        (while (not (eobp))
          (skip-chars-forward " \t")
          (or (looking-at cstart)         ; full-line comment
              (and (re-search-forward cstart (line-end-position) t)
                   (comment-indent)))     ; autoload
          (forward-line 1))))))


(defun my-get-image-size (file &optional pixels)
  "Get the size of the specified image file. Values rounded UP to integers.
With optional argument `pixels', return values in pixels.
Output is (width height)."
  (interactive (list (read-file-name "Enter file name: " nil nil t)))
  (if (file-exists-p file)              ; need for non-interactive
      (let* ((fullname (expand-file-name file))
             (img-type (image-type-from-file-header fullname))
             (img (create-image fullname))
             (img-size (and img (image-size img pixels)))
             (img-width (car img-size))
             (img-height (cdr img-size)))
        (or (memq img-type image-types)
            (error "File %s is not of a recognized image type" file))
        ;; Round up to an integer.
        (or pixels
            (setq img-width  (round (+ img-width  0.5))
                  img-height (round (+ img-height 0.5))))
        (if (interactive-p)
            (message "Width: %s, Height: %s" img-width img-height)
          (list img-width img-height)))
    (error "File %s not found" file)))


(defun my-longest-line (&optional goto)
  "Find visual length (ie in columns) of longest line in buffer.
If optional argument GOTO is non-nil, go to that line."
  (interactive "p")                    ; NB not p
  (let ((maxlen 0)
        (line 1)
        len maxline)
    (save-excursion
      (goto-char (point-min))
      (goto-char (line-end-position))
      ;; Not necessarily same as line-end - line-beginning (eg tabs)
      ;; and this function is for visual purposes.
      (setq len (current-column))
      (if (eobp)                        ; 1 line in buffer
          (setq maxlen len
                maxline line)
        (while (zerop (forward-line))
          (goto-char (line-end-position))
          (setq line (1+ line)
                len (current-column))
          (if (> len maxlen)
              (setq maxlen len
                    maxline line)))))
    (if (not (interactive-p))
        maxlen
      (message "Longest line is line %s (%s)" maxline maxlen)
      (if goto (goto-line maxline)))))

(defvar my-frame-parameters nil
  "Internal variable used by `my-frame-height'.")

;; Should really be frame-local.
(make-variable-buffer-local 'my-frame-parameters)

(defun my-resize-frame (&optional prefix)
  "Increase width of current frame to length of the longest line,
if necessary and possible within the size of the display.
If called again, restore the original width.
If called with a prefix, restore frame size to default.
If called in a frame displaying an image, adjust width AND height as
per that of the image."
  (interactive "P")
  (let ((frame (selected-frame)))
    (if prefix                          ; restore defaults
        (progn
          (set-frame-width frame (cdr (assoc 'width default-frame-alist)))
          ;; 1- allows for minibuffer.
          (set-frame-height frame
                            (1- (cdr (assoc 'height default-frame-alist))))
          (setq my-frame-parameters nil)) ; exit
      (if my-frame-parameters           ; reset to previous values
          (progn
            (set-frame-width frame (cdr (assoc 'width my-frame-parameters)))
            (set-frame-height frame (cdr (assoc 'height my-frame-parameters)))
            (set-frame-position frame (cdr (assoc 'left my-frame-parameters))
                                (frame-parameter nil 'top))
            (setq my-frame-parameters nil)) ; exit
        ;; Store original values.
        (setq my-frame-parameters `((height . ,(frame-height))
                                    (width . ,(frame-width))
                                    (left . ,(frame-parameter frame 'left))))
        ;; Pixels per column. 1.0 forces real.
        (let* ((pix-col (/ (frame-pixel-width) 1.0 (frame-width)))
               (maxpix (display-pixel-width))
               (maxcols (truncate (/ maxpix pix-col)))
               (maxrows (truncate
                         (/ (display-pixel-height)
                            (/ (frame-pixel-height) 1.0 (frame-height)))))
               (new-width (my-longest-line))
               (old-height (cdr (assoc 'height my-frame-parameters)))
               (new-height old-height)
               (old-width (cdr (assoc 'width my-frame-parameters)))
               new-left templist)
          (and auto-image-file-mode
               (string-match (image-file-name-regexp)
                             ;; Buffer may not be visiting a file.
                             (or (buffer-file-name) "dummy"))
               (setq templist (my-get-image-size (buffer-file-name))
                     new-width  (car templist)
                     new-height (min maxrows (cadr templist))))
          ;; Add one to avoid continuation arrows.
          (setq new-width (1+ (min maxcols new-width))
                ;; 60 is a fiddle to avoid the WM dock at the right margin.
                new-left (max 0 (truncate (- maxpix (* new-width pix-col) 60))))
          (when (> new-width old-width)
            (set-frame-width frame new-width)
            ;; Shift frame left if would go offscreen.
            (if (< new-left (cdr (assoc 'left (frame-parameters))))
                ;; Leave the y-position alone.
                (set-frame-position frame new-left
                                    (frame-parameter frame 'top))))
          (if (> new-height old-height)
              (set-frame-height frame new-height)))))))

;; TODO improve for varying size of initial frame.
(defun my-maximize-frame ()
  "Maximize the current frame."
  (interactive)
  (let ((maxcols (truncate
                  (/ (display-pixel-width)
;;;                     (frame-char-width))))
                     (/ (frame-pixel-width) 1.0 (frame-width)))))
        (maxrows (truncate
                  (/ (display-pixel-height)
;;;                     (frame-char-height))))
                     (/ (frame-pixel-height) 1.0 (frame-height)))))
        (frame (selected-frame)))
    (set-frame-size frame maxcols maxrows)
    (set-frame-position frame 0 0)))

;; MARGIN seems buggy - infloop?
(defun my-justify-region (margin start end)
  "Justify a region of text.
With optional prefix argument MARGIN, first re-fill to that column."
  (interactive "*p\nr")
  (let ((fill-column (or margin fill-column)))
    (save-excursion
      (save-restriction
        (narrow-to-region
         (progn (goto-char start) (line-beginning-position))
         (progn (goto-char end) (line-end-position)))
        (goto-char (point-min))
        (while (not (eobp))
          (if margin (my-refill-paragraph ()))
          (forward-paragraph 1)
          (previous-line 1)        ; now at start of last line in paragraph
          (let ((parend (point)))
            (backward-paragraph 1)      ; now at start of paragraph
            (while (< (point) parend)   ; for all lines save the last
              (justify-current-line nil)
              (forward-line 1)))
          (justify-current-line nil t)  ; special treatment for last line
          (forward-line 1))))))         ; else infloop


(defun my-count-words-region (start end)
  "Count the number of words in the region."
  (interactive "r")
  (save-excursion
    (save-restriction
      (narrow-to-region start end)
      (goto-char (point-min))
      (let ((count 0))
        (while (forward-word 1)
          (setq count (1+ count)))
        (if (interactive-p) (message "Region contains %d words." count)
          count)))))


;; C-u 0 C-M-\ does this, as does C-a M-\.
(defun my-unindent-line ()
  "Delete indentation of current line."
  (interactive)
  (save-excursion
    (forward-line 0)
    (delete-horizontal-space)))


(defun my-unindent-region (start end)
  "Delete indentation of current region."
  (interactive "*r")
  (save-excursion
    (save-restriction
      (narrow-to-region
       (progn (goto-char start) (line-beginning-position))
       (progn (goto-char end) (line-end-position)))
      (goto-char (point-min))
      (while (not (eobp))
        (my-unindent-line)
        (forward-line 1)))))


(defun my-listtostring (list)
  "Converts a list of strings into single string."
  (mapconcat 'identity list ""))


;; Why does this exist, given fill-paragraph?
(defun my-refill-paragraph (arg)
  "Fill current paragraph"
  (interactive "*P")
  (let (beg end)
    (forward-paragraph 1)
    (setq end (copy-marker (- (point) 2)))
    (backward-paragraph 1)
    (setq beg (point-marker))
    (forward-char)
    (while (< (point) end)
      (delete-indentation 1)
      (end-of-line))
    (funcall   ; return first arg as function, passing remaining args to it
     (if (memq major-mode '(c-mode c++-mode))
         'c-fill-paragraph
       'fill-paragraph)
     (and arg (prefix-numeric-value arg)))
    (if (memq major-mode '(c-mode c++-mode))
        (c-recomment-region beg (+ end 2)))
    (set-marker beg nil)
    (set-marker end nil)))


(defun my-unfill-paragraph (arg)
  "Unfill current paragraph"
  (interactive "*P")
  (forward-paragraph 1)
  (let ((end (copy-marker (- (point) 2))))
    (backward-paragraph 1)
    (forward-char)
    (while (< (point) end)
      (delete-indentation 1)
      (end-of-line))
    (set-marker end nil)))


;; string-insert-rectangle.
(defun my-prepend (start end s &optional append)
  "Add a string in front of all lines in the region.
If APPEND is non-nil, add the string to the end of lines."
  (interactive "*r\nMEnter a string: ")
  (save-excursion
    (save-restriction
      (narrow-to-region
       (progn (goto-char start) (line-beginning-position))
       (progn (goto-char end) (line-end-position)))
      (goto-char (point-min))
      (beginning-of-line)
      (while (not (eobp))
        (if append (end-of-line))
        (insert s)
        (forward-line 1)))))


(defun my-unprepend (start end s)
  "Remove a regexp from the front of all lines in the region."
  (interactive "*r\nMEnter a regexp: ")
  (save-excursion
    (save-restriction
      (narrow-to-region
       (progn (goto-char start) (line-beginning-position))
       (progn (goto-char end) (line-end-position)))
      (goto-char (point-min))
      (while (not (eobp))
        (if (looking-at s)
            (delete-region (match-beginning 0) (match-end 0)))
        (forward-line 1)))))


(defun my-append (start end s)
  "Append a string to the end of all lines in region"
  (interactive "*r\nMEnter a string: ")
  (my-prepend start end s t))


;; This is probably rather ugly...
(defun my-unappend (start end s)
  "Remove string from end of each line in region"
  (interactive "*r\nMEnter a string: ")
  (save-excursion
    (save-restriction
      (narrow-to-region
       (progn (goto-char start) (line-beginning-position))
       (progn (goto-char end) (line-end-position)))
      (goto-char (point-min))
      (while (not (eobp))
        (end-of-line)
        (when (> (point) (line-beginning-position)) ; do nothing for blank line
          (backward-char 1)             ; so looking-at will work
          ;; Does last char on line match last char of string?
          (when (looking-at (substring s -1))
            (forward-char 1)            ; so search will work
            ;; Search backwards for regexp as far as linestart.
            ;; t means return nil, rather than error, if no match.
            (if (search-backward-regexp s (line-beginning-position) t)
                (delete-region (match-beginning 0) (match-end 0)))))
        (forward-line 1)))))


(defun my-deltw (start end)
  "Remove trailing whitespace from all lines in the region."
  (interactive "*r")
  (save-excursion
    (save-restriction
      (narrow-to-region start end)
      (goto-char (point-min))
      (while (re-search-forward "[ \t]+$" nil t)
        (delete-horizontal-space) ; delete all spaces and tabs around point
;;;      (replace-match "" t nil)               ; removes blank lines
        ))))


;; Must be a simpler way to do this.
(defun my-shell-backspace ()
  "Backspace in shell-mode that will not delete the command prompt."
  (interactive)
  (and (> (point) (line-beginning-position)) (delete-backward-char 1)))

(defun my-indent-region (start end)
  "Indent all text in region as per tab-key."
  (interactive "*r")
  (save-excursion
    (save-restriction
      (narrow-to-region
       (progn (goto-char start) (line-beginning-position))
       (progn (goto-char end) (line-end-position)))
      (goto-char (point-min))
      (while (not (eobp))
        (indent-for-tab-command)
        (forward-line 1)))))


(defun my-indent-relative (start end)
  "Indent all lines in region to level of first, using tabs and spaces"
  (interactive "*r")
  (save-excursion
    (save-restriction
      (narrow-to-region
       (progn (goto-char start) (line-beginning-position))
       (progn (goto-char end) (line-end-position)))
      (goto-char (point-min))
      (let ((col (skip-chars-forward " \t"))) ; column of first non-blank
        (while (zerop (forward-line 1))
          (indent-to col))))))


(my-make-hook-fn minibuffer-exit-hook
  (let ((buff "*Completions*"))
    (if (get-buffer buff) (kill-buffer buff))))


(setq custom-buffer-done-function 'kill-buffer)


(defun my-member-match (re list)
 "Return non-nil if regexp RE matches an element of LIST.
The value is actually the tail of LIST whose car matches RE.
The value of `case-fold-search' is obeyed."
  (catch 'found
    (mapcar (lambda (elem)
              (if (string-match re elem)
                  (throw 'found (member elem list))))
            list)
    nil))


;; Kill some temporary buffers, etc.
(defvar my-clean-buffers-names
  '("\\*Completions" "\\*Compile-Log" "\\*.*[Oo]utput\\*$"
    "\\*Apropos" "\\*compilation" "\\*Customize" "\\*Calc"
    "\\*BBDB\\*" "\\*Occur\\*" "\\*trace of SMTP" "\\*vc" "\\*cvs"
    "\\*WoMan-Log" "\\*tramp" "\\*desktop\\*")
  "List of regexps matching names of buffers to kill.")

(defvar my-clean-buffers-modes
  '(help-mode)                          ; Info-mode
  "List of modes whose buffers will be killed.")

(defun my-clean-buffers ()
  "Kills buffers as per `my-clean-buffer-list' and `my-clean-buffer-modes'."
  (interactive)
  (let (string buffname)
    (mapcar (lambda (buffer)
              (and (setq buffname (buffer-name buffer))
                   (or (catch 'found
                         (mapcar '(lambda (name)
                                    (if (string-match name buffname)
                                        (throw 'found t)))
                                 my-clean-buffers-names)
                         nil)
                       (save-excursion
                         (set-buffer buffname)
                         (catch 'found
                           (mapcar '(lambda (mode)
                                      (if (eq major-mode mode)
                                          (throw 'found t)))
                                   my-clean-buffers-modes)
                           nil)))
                   (kill-buffer buffname)
                   (setq string (concat string
                                        (and string ", ") buffname))))
            (buffer-list))
    (if string (message "Deleted: %s" string)
      (message "No buffers deleted"))))


(defvar my-file-name-history-exclude-re
  '("~/VM/.+" "/bbdb$" )
  "List of regexps matching files to exclude from `file-name-history'.")

(defun my-file-name-history-prune ()
  "Trim the contents of the variable `file-name-history'."
  (let (file)
    (mapcar (lambda (re)
              (while (setq file (my-member-match re file-name-history))
                (setq file-name-history
                      (delete (car file) file-name-history))))
            my-file-name-history-exclude-re)))

(defadvice find-file (after prune-history activate)
  "Run `my-file-name-history-prune'."
  (my-file-name-history-prune))


(defun my-faceset (face fg &optional bg bold)
  "Give FACE foreground FG, and optional background BG. Make bold if BOLD,
else make unbold. For example: (my-faceset 'dircolors-face-package \"Red\" t)"
  (set-face-foreground face fg)
  ;; 3rd argument taken to be bg colour if string, else make bold.
  (if bg
      (if (stringp bg) (set-face-background bg) (make-face-bold face)))
  (if bold (make-face-bold face) (make-face-unbold face)))


(defun my-file-perm-check (mode atype utype)
  "Return non-nil if integer file MODE allows access ATYPE for user UTYPE.
ATYPE is a single character, either r(ead), w(rite), x(ecute);
UTYPE is a single character, either u(ser), g(roup), o(other)."
  (let ((case-fold-search t)
        (mask))
    ;; Set comparison mask.
    (cond ((char-equal atype ?r)
           (setq mask #o4))
          ((char-equal atype ?w)
           (setq mask #o2))
          ((char-equal atype ?x)
           (setq mask #o1))
          (t (error "Bad ATYPE `%c'" atype)))
    ;; Bit-shift comparison mask to appropriate point.
    (cond ((char-equal utype ?u)
           (setq mask (* mask (expt 2 6))))
          ((char-equal utype ?g)
           (setq mask (* mask (expt 2 3))))
          ((char-equal utype ?o))
          (t (error "Bad UTYPE `%c'" utype)))
    ;; Make the comparison.
    (not (zerop (logand mode mask)))))

;;; (my-file-perm-check (default-file-modes) ?r ?o)

;;;
;;;; Functions ;;;;


;;;; Keybindings ;;;;
;;;
;;; Note C-c letter, F5-F9 reserved for user commands.

;; termcap entry "xterm" has no colour, but good key settings.
;; "xterm-color" has colour but bad settings for backspace, etc.
;; This is because it is based on "xterm-old" rather than "xterm-new".
;; "xterm-redhat" also has bad key settings, IMO.
;; If possible, customize the generic "xterm" entry in termcap
;; to be the same as "xterm-color", but based on "xterm-new".
(unless window-system
  (if (string-equal my-system "slac")
      (progn
        ;; TODO FIXME Works in scratch, not here?!
        (define-key function-key-map "\e[4~" [end])
        ;; Have to set TERM to xterm-color on darwin for colour ls.
        (if (string-equal system-type "darwin")
            (define-key function-key-map "\e[1~" [home])))

    (when (string-equal (getenv "TERM") "xterm-color")
      (keyboard-translate ?\C-h ?\C-?)
      ;; Give us an alternative to the lost C-h help prefix.
      (global-set-key "\C-xh" 'help-command) ; overrides mark-whole-buffer
      (global-set-key "\eOH"  'beginning-of-buffer) ; HOME key
      (global-set-key "\eOF"  'end-of-buffer))))    ; END key

;; Unset rarely used/often mistaken keys.
(global-unset-key "\C-xf")

;; Rebind keys.
;; Default is list-buffers. Replaced with ibuffer below if available.
;;;(global-set-key "\C-x\C-b" 'buffer-menu)

;; Analogous to C-h i for info. Shadows `where-is'.
(global-set-key "\C-hw" 'woman)

;; This is a better approach since it affects the "Buffers" menu item as
;; well. Note both functions have the same syntax.
(fset 'list-buffers 'buffer-menu)


;; Set new keys. f5-f9 reserved for users.
(global-set-key [(f5)]   'make-frame)
(global-set-key [(control f5)] 'delete-frame)
(global-set-key [(f7)]   'repeat-complex-command)
(global-set-key [(f8)]   'my-resize-frame)
(global-set-key [(f9)]   'my-comment-region)
(global-set-key [(control f9)] 'uncomment-region)
(global-set-key [(f12)]  'revert-buffer) ; move to f6?

(global-set-key "\C-ca" 'align)
(global-set-key "\C-cA" 'auto-fill-mode)
(global-set-key "\C-cc" 'my-comment-indent-region)
(global-set-key "\C-cf" 'flyspell-mode)
(global-set-key "\C-cg" 'goto-line)
(global-set-key "\C-ch" 'hscroll-mode)
(global-set-key "\C-ci" 'iso-accents-mode)
;; This is on M-q.
;;;(global-set-key "\C-cj" 'fill-paragraph)
(global-set-key "\C-cJ" 'fill-region)
(global-set-key "\C-ck" 'my-copy-line-as-kill)
;;;(global-set-key "\C-cl" 'my-ps-toggle-landscape)
(global-set-key "\C-cm" 'my-messages)
;;;(global-set-key "\C-co" 'ps-print-buffer-with-faces)
;;;(global-set-key "\C-cp" 'ps-print-buffer)

(if (fboundp 'my-splash) (global-set-key "\C-cq" 'my-splash))

(global-set-key "\C-cr" 'my-indent-relative)

(global-set-key "\C-cs" 'my-scratch)

(if (fboundp 'toggle-truncate-lines)
    (global-set-key "\C-ct" 'toggle-truncate-lines))

(global-set-key "\C-cF" 'my-filestamp)
(global-set-key "\C-cT" 'my-timestamp)
(global-set-key "\C-cu" 'my-url-selection)
(global-set-key "\C-cU" 'my-unindent-line)
(global-set-key "\C-cV" 'my-unindent-region)
;; M-w does this.
;;;(global-set-key "\C-cw" 'copy-region-as-kill)
(global-set-key "\C-cW" 'my-websearch-selection)

;; These are the defaults pre-21.
(global-set-key [end]   'end-of-buffer) ; end-of-line in 21
(global-set-key [home]  'beginning-of-buffer) ; beginning-of-line in 21
(global-set-key [?\C-^] 'join-line)     ; undefined in 21


;; Without advice, almost same as indent-for-comment. Slightly better,
;; because inserts ";;" and indents on empty line.
;; With advice, end up commenting regions when wanted to indent.
(defadvice comment-dwim (around activate-trans-mark disable)
  "If point is at the beginning of a line, assume we wanted to call
`comment-region', and activate `transient-mark-mode' so that `comment-dwim'
will do the Right Thing."
  (let ((transient-mark-mode (= (line-beginning-position) (point))))
    ad-do-it))

;;;
;;;; Keybindings ;;;;


;;;; Menu ;;;;

;; Add the VC menu to the menu-bar for files under version control,
;; at the top-level as "VC" (normally in the Tools menu).
(when (boundp 'vc-menu-map)
  (add-to-list 'minor-mode-map-alist
               `(vc-mode keymap
                         (menu-bar keymap
                                   (VC menu-item "VC" ,vc-menu-map))))
  (when (boundp 'cvs-global-menu)
    (define-key-after vc-menu-map [pcl-cvs-sep] '("--"))
    ;; Add PCL-CVS as separate menu.
;;;    (define-key-after vc-menu-map [pcl-cvs-menu]
;;;     '(menu-item "PCL-CVS" cvs-global-menu
;;;                  :help "Module-level interface to CVS"))
    ;; Add PCL-CVS entries in the same level.
    (mapc (lambda (e) (if (listp e)
                          (define-key-after vc-menu-map `[,(car e)]
                            (cdr e))))
          (cdr cvs-global-menu))))


(defun my-menu-bar-find-file (file doc help)
  "Make a menu-item to visit a file read-only.
FILE is the file to visit, relative to `data-directory'.
DOC is the text to use the menu entry.
HELP is the text to use for the tooltip."
  `(menu-item ,doc
              (lambda () (interactive)
                (find-file-read-only
                 (expand-file-name ,file data-directory)))
              :help ,help))

(let ((last 'emacs-problems)           ; start point in menu
      file doc this)
  (mapcar (lambda (elem)
            (setq file (car elem)
                  doc (cdr elem)
                  ;; NB how make symbol on the fly. Not `make-symbol'.
                  this (intern (concat "emacs-" (downcase file))))
            (define-key-after menu-bar-help-menu `[,this]
              (my-menu-bar-find-file file doc doc)
              last)
            (setq last this))
          '(("TODO"       . "Emacs TODO List")
            ("DEBUG"      . "Emacs Debugging Information")
            ("JOKES"      . "Emacs Jokes")
            ("future-bug" . "Emacs Future Bug"))))


;; cf menu-bar-make-mm-toggle.
(defmacro my-menu-bar-make-local-mm-toggle (fname doc help &optional props)
  "Make a menu-item for a local minor mode toggle.
FNAME is the minor mode's name (variable and function).
DOC is the text to use the menu entry.
HELP is the text to use for the tooltip.
PROPS are additional properties."
  `'(menu-item ,doc ,fname
     ,@(if props props)
     :help ,help
     :button (:toggle . (and (boundp ',fname)
                             ,fname))))

(or (fboundp 'menu-bar-make-mm-toggle)  ; for 21.3
    (defmacro menu-bar-make-mm-toggle (fname doc help &optional props) ""
      `'(menu-item ,doc ,fname
     ,@(if props props)
     :help ,help
     :button (:toggle . (and (default-boundp ',fname)
                             (default-value ',fname))))))


(when (boundp 'menu-bar-options-menu)

  ;; Note that an error in a definition of this kind caused Emacs to exit
  ;; after "loading tooltip" portion of startup.
  (define-key-after menu-bar-options-menu [show-trailing-whitespace]
    (my-menu-bar-make-local-mm-toggle
     show-trailing-whitespace
     "Trailing Whitespace Highlighting"
     "Highlight whitespace at line ends (Show Trailing Whitespace)")
    'highlight-paren-mode)

  (define-key-after menu-bar-options-menu [toggle-auto-image]
    (menu-bar-make-mm-toggle auto-image-file-mode
                             "Automatic Display of Image Files"
                             "Visit image files as images")
    'toggle-auto-compression)

  (define-key-after menu-bar-options-menu [debug-on-signal]
    (menu-bar-make-toggle
     toggle-debug-on-signal debug-on-signal
     "Enter Debugger on Signal" "Debug on Signal %s"
     "Enter Lisp debugger regardless of condition handlers")
    'debug-on-error)

  (if (boundp 'menu-bar-showhide-menu)
      (define-key menu-bar-showhide-menu [ruler]
        (my-menu-bar-make-local-mm-toggle ruler-mode
                              "Ruler" "Turn ruler on/off"))

    (define-key-after menu-bar-options-menu [tool-bar-separator]
      '("--") 'debug-on-quit)

    (define-key-after menu-bar-options-menu [tool-bar]
      (menu-bar-make-mm-toggle tool-bar-mode "Toggle Tool Bar"
                               "Toggle display of the tool-bar")
      'tool-bar-separator)

    (define-key-after menu-bar-options-menu [display-time]
      (menu-bar-make-mm-toggle
       display-time-mode "Toggle Display Time/Mail"
       "Toggle display of the time and mail indicator"))))

;;;; Menu ;;;;


;;;; Font-lock ;;;;
;;;

(global-font-lock-mode 1)
(setq font-lock-maximum-decoration t
      ;; Removed text-mode from this exclusion list for 21.
      ;; Otherwise yanking preserves font-lock attributes of kill buffer,
      ;; which is annoying. Still need hook to actually enable
      ;; font-lock mode for text-mode - see below.
      ;; Then put back in as it messes up latex mode as well.
      font-lock-global-modes '(not shell-mode text-mode)
      font-lock-verbose t
      font-lock-maximum-size '((t . 1048576) (vm-mode . 5250000)))

;; Extra highlighting.
(let (mode comment)
  (mapcar (lambda (elem)
            (setq mode (car elem)
                  comment (cdr elem))
            (font-lock-add-keywords
             mode
             `((,comment ("\\<\\(GM\\|NB\\|TODO\\|FIXME\\)\\>" nil nil
                          (0 'font-lock-warning-face t)))
               (,comment ("[* ]\\*\\([$a-zA-Z].*\\)\\*" nil nil
                          (1 'font-lock-warning-face t)))
               (,comment ("`\\([^`']+\\)'" nil nil
                          (1 'font-lock-constant-face t))))))
          '((awk-mode      . "#")
            (sh-mode       . "#")
            (fortran-mode  . "^C")
            (f90-mode      . "!")
            (tcl-mode      . "#")
            (makefile-mode . "#")
            (python-mode   . "#"))))

;; Support mode.
;; jit-lock doesn't seem to work for MIME messages in VM.
(setq font-lock-support-mode
      (if (require 'jit-lock nil t)
          '((vm-mode . fast-lock-mode) (t . jit-lock-mode))
        'fast-lock-mode))

;; Jit-lock.
(setq jit-lock-stealth-verbose nil
      jit-lock-stealth-time 2
      ;; If system load rises above this value, pause stealth fontification.
      jit-lock-stealth-load 90
      ;; Seconds to pause between chunks of stealth fontification.
      jit-lock-stealth-nice 0.5
      ;; If nil, deferred fontification only on lines directly modified.
      ;; If t, on those line plus any following.
      ;; Any other value, only if syntactic fontification for that buffer.
      jit-lock-defer-contextually 'syntax-driven)

;; Fast-lock. Caches font-lock information to speed up loads.
(setq fast-lock-minimum-size 50000      ; but not for small files
      fast-lock-verbose      50000      ; so keep quiet
      ;; Or kill-buffer, kill-emacs. If did not save, do not care.
      fast-lock-save-events '(save-buffer)
      fast-lock-save-others nil         ; no font-caching for others' files
      ;; Prefer all information to be in one place rather than ./
      fast-lock-cache-directories `(,(expand-file-name "flc" my-emacsdir)))

(let (dir)
  (mapcar (lambda (elem)
            (setq dir (if (listp elem) (cdr elem) elem))
            (or (file-directory-p dir) (make-directory elem)))
          fast-lock-cache-directories))
;;;
;;;; Font-lock ;;;;


;;;; Sound ;;;;
;;;

;;; (defvar my-use-sound-effects nil
;;;   "If non-nil, play sound effects on start and exit.")
;;;
;;; (setq
;;;  my-startup-sound (expand-file-name
;;;                    "Library/WindowMaker/Sounds/Windows/logoff.wav"
;;;                    (or (getenv "GNUSTEP_USER_ROOT")
;;;                        "~/GNUstep"))
;;;  ;; Can be masked by WindowMaker.
;;;  my-exit-sound (expand-file-name
;;;                 "Library/WindowMaker/Sounds/Windows/notify.wav"
;;;                 (or (getenv "GNUSTEP_USER_ROOT")
;;;                     "~/GNUstep")))
;;;
;;; (when my-use-sound-effects
;;;   ;; Use `emacs-startup-hook' if want to wait till click past splash.
;;;   (add-hook 'after-init-hook
;;;             (lambda () (my-play-sound my-startup-sound)))
;;;   (add-hook 'kill-emacs-hook (lambda () (my-play-sound my-exit-sound))))
;;;
;;;
;;; (defun my-play-sound (file)
;;;   "Play a sound file asynchronously."
;;;   (interactive (list (read-file-name "Sound file name: " nil nil t)))
;;;   (or (file-exists-p file) (error "File `%s' not found" file))
;;;   (let* ((ext (file-name-extension (setq file (expand-file-name file))))
;;;          (player
;;;           (cond
;;;            ((string-equal "wav" ext) "/usr/bin/play")
;;;            ((string-equal "au"  ext) "/usr/bin/showaudio")
;;;            ((string-equal "mp3" ext) "/usr/bin/plaympeg")
;;;            (t (error "Unrecognized extension: .%s" ext)))))
;;;     (if (not (file-executable-p player))
;;;         (message "Cannot execute %s" player)
;;;       ;; Call-process will continue after emacs exits.
;;;       (call-process player nil 0 nil file) ; not really async
;;;       ;; Prompted to kill if running when emacs exits.
;;; ;;;     (start-process "Sound-player" nil player file)
;;;       )))

;;;
;;;; Sound ;;;;


;;;; Tabs ;;;;
;; Bad idea to change this from 8.
;;;(setq-default default-tab-width 4)
;; If this is not a multiple of tab-width, tabbing will insert spaces.
(setq tab-stop-list '(4 8 12 16 20 24 28 32 36)
      ;; Default 'untabify converts a tab to equivalent number of
      ;; spaces before deleting a single character.
      backward-delete-char-untabify-method nil)
(setq-default indent-tabs-mode nil)

;;;; Tabs ;;;;


;;;; Abbreviations ;;;;
(setq-default abbrev-mode t)
(setq save-abbrevs t
      abbrev-file-name (expand-file-name "abbrevs" my-emacsdir)
      ;; Free up space in the mode line by removing the "Abbrev" string.
      minor-mode-alist
      (delq (assq 'abbrev-mode minor-mode-alist) minor-mode-alist))

(if (file-exists-p abbrev-file-name) (quietly-read-abbrev-file))

;; Avoid the annoying "Save abbrevs in... ?" prompt.
(defun my-abbrevs-save ()
  "Save the abbreviations file if it has changed.
Intended for use with `my-before-kill-emacs-hook'."
  (when (and abbrevs-changed save-abbrevs)
    (write-abbrev-file abbrev-file-name)
    (setq abbrevs-changed nil)))

(add-hook 'my-before-kill-emacs-hook 'my-abbrevs-save)

;;;; Abbreviations ;;;;


;;;; Bookmarks ;;;;
;; Save bookmarks file each time a bookmark is added, not just on exit.
(setq bookmark-save-flag 1)
;;;; Bookmarks ;;;;


;;;; which-function-mode ;;;;
;;; Note that all this does is display the name of the last defined function,
;;; not really the function under point.
;;; Pretty useless. Comments above a program confuse it.
;;;(setq which-func-modes t)            ; activate for all supported modes
;;;(which-func-mode 1)
;;;; which-function-mode ;;;;


;;;; Printing ;;;;
(setq printer-name my-printer
      ps-printer-name-option "-P"
      ps-printer-name nil               ; nil -> use printer-name
;;;      lpr-switches (list (format "-P%s" my-printer))
;;;      ps-lpr-switches (list (format "-P%s" my-printer))
      ps-print-color-p nil         ; else default fg too light to read
      ps-paper-type (cond
                     ((string-equal my-system "slac") 'letter)
                     (t 'a4))
      ps-header-lines 2
      ps-right-header '("/pagenumberstring load" my-ps-header-fn)
      ps-spool-duplex t
      ps-multibyte-buffer 'bdf-font-except-latin)

(defun my-ps-header-fn ()
  "Format the date and time as I prefer for PS header."
  (format-time-string "%T %x"))

(if (file-directory-p "/usr/local/share/fonts/intlfonts/bdf")
    (add-to-list 'bdf-directory-list "/usr/local/share/fonts/intlfonts/bdf"))

(when (and (require 'printing nil t)
           (executable-find "lpstat"))

  (with-temp-buffer
    (call-process "lpstat" nil t nil "-p")
    (goto-char (point-min))
    (let (pr-string pr-name)
      (while (re-search-forward "^printer \\([[:alnum:]]+\\) .*enabled"
                                nil t)
        (setq pr-string (match-string 1)
              pr-symbol (intern pr-string))
        (add-to-list 'pr-txt-printer-alist
                     (list pr-symbol "lpr" nil "-P" pr-string) t))))

  ;; TODO specify no name for the default printer, so that the current
  ;; system default gets used? Problem seemed to be -P switch always
  ;; added, even with no printer name.
  (setq pr-txt-printer-alist
        (append `((default "lpr" nil "-P" ,my-printer))
                (delete (assoc 'default pr-txt-printer-alist)
                        pr-txt-printer-alist))
        pr-ps-printer-alist pr-txt-printer-alist
        pr-menu-lock nil)

;;;   (defcustom pr-color-p nil             ; cf ps-print-color-p
;;;     "*Non-nil means print in color."
;;;     :type '(choice :menu-tag "Print Color"
;;;                    :tag "Print Color"
;;;                    (const :tag "Do not use color" nil)
;;;                    (const :tag "Use color" t)
;;;                    (const :tag "Colors on b/w printer" black-white))
;;;     :group 'printing
;;;     :version "22.1")
;;;
;;;   ;; Need a 3-value version.
;;;   (defun pr-toggle-color ()
;;;     "Toggle printing in color."
;;;     (interactive)
;;;     (pr-toggle

;;;   (define-key-after ??? [pr-toggle-color]
;;;     (menu-bar-make-toggle
;;;     ??? 'pr-toggle-faces)

  (pr-update-menus t)) ; require 'printing

;;;; Printing ;;;;


;;;; Spook ;;;;

(setq spook-phrase-default-count 8)

(let ((file (expand-file-name "spook.lines" my-emacsdir)))
  (if (file-exists-p file) (setq spook-phrases-file file)))

(defun my-spook-string (&optional number length)
  "Return as a string the output of `spook'.
Optional argument NUMBER is the number of spook phrases to
return.  If unspecified, `spook-default-phrase-count' will be
used.  If LENGTH is present, output will not be longer than this
many characters."
  (with-temp-buffer
    (let ((spook-phrase-default-count (or number spook-phrase-default-count))
          start end)
      (spook)
      ;; 1+, 1- avoid leading and final newlines.
      (setq start (1+ (point-min))
            end   (1- (point-max)))
      ;; Try to select complete words if length is specified,
      ;; but these are often not complete phrases.
      (buffer-substring start
                        (if (and length (< length end))
                            (progn
                              (goto-char length)
                              (or (re-search-backward " " start t)
                                  length))
                          end)))))


(when (and (equal my-emacs-type 'mail)
           (require 'spookmime nil t))

  (autoload 'mail-header-extract "mailheader")

  (defun my-spookmime-mml-make-boundary (&optional this-msg-count)
    "Like `spookmime-mml-make-boundary', but only with an X-Spook header."
    (if (save-excursion
          (goto-char (point-min))
          (assoc 'x-spook (mail-header-extract)))
        (spookmime-mml-make-boundary this-msg-count)
      (mml-make-boundary this-msg-count)))

  (setq mml-boundary-function 'my-spookmime-mml-make-boundary)


  (ad-deactivate 'vm-mime-make-multipart-boundary)

  (defadvice vm-mime-make-multipart-boundary (around spookmime activate)
  "Use Spookmime, but only if there is an X-Spook header."
  (if (save-excursion
        (goto-char (point-min))
        (assoc 'x-spook (mail-header-extract)))
      (setq ad-return-value (spookmime-make-mime-boundary))
    ad-do-it)))                         ; 'spookmime and 'mail

;;;; Spook ;;;;


;;;; News/mail ;;;;
;;;

(when (equal my-emacs-type 'mail)

  (setq feedmail-buffer-eating-function 'feedmail-buffer-to-smtpmail
        feedmail-deduce-envelope-from nil
        ;; Default sendmail-send-it, also feedmail-send-it.
        send-mail-function 'smtpmail-send-it
        message-send-mail-function 'smtpmail-send-it ; Gnus
        smtpmail-default-smtp-server "localhost"
        ;; Trace buffer deleted if this is nil (22.1).
        smtpmail-debug-info nil
        mail-interactive nil
        ;; If t, queue mail and send with smtpmail-send-queued-mail.
        smtpmail-queue-mail nil
        smtpmail-queue-dir "~/VM/queue/"
        mail-use-rfc822 t
        ;; Now for sendmail and smtpmail.
        mail-specify-envelope-from nil
        mail-envelope-from 'header)


  (cond ((string-equal my-system "xray")
         (setq smtpmail-local-domain nil  ; "ast.cam.ac.uk"
               ;; Used to initialize `smtpmail-smtp-server'. Or ppsw.cam.ac.uk.
               smtpmail-default-smtp-server "xalph3.ast.cam.ac.uk"
               ;; NB if set: "Received: from xpc21.ast.cam.ac.uk.ast.cam.ac.uk".
               ;; It's just concated with (system-name) to get a fqdn.
               smtpmail-sendto-domain "ast.cam.ac.uk"))
        ((string-equal my-system "slac")
         (setq smtpmail-default-smtp-server "smtpserv.slac.stanford.edu"
;;;               smtpmail-sendto-domain "slac.stanford.edu"
               ))
        ((string-equal my-system "stanford")
         (setq smtpmail-default-smtp-server "smtp.stanford.edu")))

  (setq smtpmail-smtp-server smtpmail-default-smtp-server)


  (when (require 'smtpmod nil t)
    (setq smtpmod-enable-flag t
          smtpmod-fqdn (if (boundp 'smtpmail-default-smtp-server)
                           smtpmail-default-smtp-server
                         'real)
          smtpmod-user-mail-address 'copy))


  (setq
   ;; If not set, constructed from `mail-host-address' or `system-name'.
   user-mail-address (cond ((string-equal my-system "furn")
                            "gm@localhost")
                           ((string-match "^\\(xray\\|cass\\)$" my-system)
                            (my-mail-obfuscate-address
                             "gmorris" "generic@ast.cam.ac.uk"))
                           ((string-equal my-system "slac")
                            (my-mail-obfuscate-address
                             "gmorris" "generic@slac.stanford.edu"))
                           ((string-equal my-system "stanford")
                            (my-mail-obfuscate-address
                             "rgm" "generic@stanford.edu"))
                           ((string-equal my-system "gnu")
                            (my-mail-obfuscate-address
                             "rgm" "generic@gnu.org")))
   gnus-nntp-server nil                   ; obsolete
   gnus-select-method (cond ((string-equal my-system "slac")
                             '(nntp "news.slac.stanford.edu"))
                            ((string-equal my-system "stanford")
                             '(nntp "news.stanford.edu"))
                            ((string-match "^\\(cass\\|xray\\)" my-system)
                             '(nntp "nntp-serv.cam.ac.uk"))
                            ;; or (nnfolder "")?
                            (t '(nntp "news.gmane.org")))
   gnus-home-directory "~/Gnus/"
   gnus-read-newsrc-file nil
   gnus-save-newsrc-file nil
   gnus-startup-file    (expand-file-name ".newsrc" gnus-home-directory)
   ;; Hopeless.
   nnfolder-directory   (expand-file-name "Mail" gnus-home-directory)
   nnfolder-active-file (expand-file-name "active" nnfolder-directory)
   ;; Requires extra smiles from site-lisp/etc.
   ;; \\W = not word.
   smiley-regexp-alist
   '(("\\(:-*[<?]+\\)\\W"            1 "FaceAngry")
     ("\\(:-+\\]+\\)\\W"             1 "FaceGoofy")
     ("\\(:-*D\\)\\W"                1 "FaceGrinning")
     ("\\(:-*[)>}?]+\\)\\W"          1 "FaceHappy")
     ("\\(=[)?]+\\)\\W"              1 "FaceHappy")
     ("\\(:-*[/\\\"]\\)[^/]\\W"      1 "FaceIronic")
     ("[^.0-9]\\([8|]-*[|Oo%]\\)\\W" 1 "FaceKOed")
     ("\\([:|]-*#+\\)\\W"            1 "FaceNyah")
     ("\\(:-*[({]+\\)\\W"            1 "FaceSad")
     ("\\(=[({]+\\)\\W"              1 "FaceSad")
     ("\\(:-*[Oo\*]\\)\\W"           1 "FaceStartled")
     ("\\(:-*|\\)\\W"                1 "FaceStraight")
     ("\\(:-*p\\)\\W"                1 "FaceTalking")
     ("\\(:-*d\\)\\W"                1 "FaceTasty")
     ("\\(;-*[>)}?]+\\)\\W"          1 "FaceWinking")
     ("\\(:-*[Vv?]\\)\\W"            1 "FaceWry")
     ("\\([:|]-*P\\)\\W"             1 "FaceYukky")))
  )                                     ; 'mail
;;;
;;;; News/mail ;;;;


;;;; Browse-url ;;;;
(let ((galeon (executable-find "galeon")))
  (when (and galeon (file-executable-p galeon))
    (setq browse-url-netscape-program galeon)
    (when (fboundp 'browse-url-galeon)
      (setq browse-url-browser-function 'browse-url-galeon
            browse-url-galeon-program galeon
            browse-url-new-window-flag t
            browse-url-galeon-new-window-is-tab t))))
;;;; Browse-url ;;;;


;;;; VC ;;;;
(setq vc-initial-comment       t ; add comment at start of new source file
      vc-default-init-version "1.1"
      ;; Prevent auto-mounting of /home/MCVS etc.
      vc-handled-backends '(RCS CVS)
      vc-make-backup-files     t
      ;; Default t tries to make local copies of old versions.
      ;; Useful for slow connections.
      ;; TODO want this to be t for any repository not on the current
      ;; machine - is that what t means?
      vc-cvs-stay-local        (not (string-equal my-system "kdell"))
      vc-keep-workfiles        t
      vc-command-messages      t
      vc-follow-symlinks       t
      vc-dired-terse-display   t
      diff-switches           '("-c" "-w")
      ;; ~/.cvsrc also has an effect on cvs switches?
      vc-cvs-diff-switches    nil       ; appended to previous
      vc-cvs-global-switches  '("-z3"))

(setq change-log-version-info-enabled nil
      add-log-full-name "Glenn Morris"
      add-log-mailing-address (my-mail-obfuscate-address
                               "rgm" "generic@gnu.org")
      add-log-keep-changes-together t
      log-edit-confirm 'changed
      log-edit-changelog-full-paragraphs nil)

;; PCL-CVS

(setq cvs-auto-remove-handled t)

(my-make-hook-fn cvs-mode-hook
  (face-spec-set 'cvs-msg-face '((t (:foreground "pink"))))
  (face-spec-set 'cvs-header-face
                 '((t (:foreground "aquamarine" :weight bold))))
  (face-spec-set 'cvs-need-action-face '((t (:foreground "yellow2"))))
  (face-spec-set 'cvs-unknown-face '((t (:foreground "red" :weight bold))))
  (face-spec-set 'cvs-handled-face '((t (:foreground "lawngreen")))))


(my-make-hook-fn log-view-mode-hook
  (face-spec-set 'log-view-file-face
                 '((t (:foreground "aquamarine" :weight bold))))
  (face-spec-set 'log-view-message-face
                 '((t (:foreground "yellow2")))))


;;; TODO make this work as per C-x 4 a, but for the log buffer.
;;; (defun my-log-edit-add-entry ()
;;;   "Insert the start of a log-entry using the function name at point.
;;; Stolen from `add-change-log-entry-other-window'."
;;;   (interactive "*")
;;;   (let ((defun (add-log-current-defun))
;;;         (dbuff "*vc-log*"))
;;;     (if (not defun)
;;;     ;; No function name, so put in a colon unless we have just a star.
;;;     (unless (save-excursion
;;;               (beginning-of-line 1)
;;;               (looking-at "\\s *\\(\\*\\s *\\)?$"))
;;;       (insert ": "))
;;;       ;; Make it easy to get rid of the function name.
;;;       (undo-boundary)
;;;       (unless (save-excursion
;;;             (beginning-of-line 1)
;;;             (looking-at "\\s *$"))
;;;     (insert ?\ ))
;;;       ;; See if the prev function name has a message yet or not.
;;;       ;; If not, merge the two items.
;;;       (let ((pos (point-marker)))
;;;     (skip-syntax-backward " ")
;;;     (skip-chars-backward "):")
;;;     (if (and (looking-at "):")
;;;              (let ((pos (save-excursion (backward-sexp 1) (point))))
;;;                (when (equal (buffer-substring pos (point)) defun)
;;;                  (delete-region pos (point)))
;;;                (> fill-column (+ (current-column) (length defun) 4))))
;;;         (progn (skip-chars-backward ", ")
;;;                (delete-region (point) pos)
;;;                (unless (memq (char-before) '(?\()) (insert ", ")))
;;;       (if (looking-at "):")
;;;           (delete-region (+ 1 (point)) (line-end-position)))
;;;       (goto-char pos)
;;;       (insert "("))
;;;     (set-marker pos nil))
;;;       (insert defun "): "))))

(my-make-hook-fn log-edit-mode-hook
  (local-set-key "\C-ca" 'my-log-edit-add-entry))


(defun my-empty-buffer (&optional buffer)
  "Return non-nil if buffer is empty (ie nothing but whitespace).
Operate on the current buffer, or that specified by optional BUFFER argument."
  (if buffer
      (or (get-buffer buffer)
          (error "Buffer `%s' not found" buffer))
    (setq buffer (buffer-name))
  (save-excursion
    (set-buffer buffer)
    (goto-char (point-min))
    (not (re-search-forward "[^ \t\n]" (point-max) t)))))


(my-make-hook-fn log-edit-done-hook
  (if (my-empty-buffer)
      ;; If any file being committed is not a ChangeLog, query.
      (or
       (catch 'found
         (dolist (file (log-edit-files) t)
           (or (string-equal "ChangeLog" (file-name-nondirectory file))
               (throw 'found nil))))
        ;; See also `log-edit-confirm'.
       (yes-or-no-p "Really commit with empty log? ")
       (error "Commit aborted"))
    ;; Remove trailing blank lines.
    (save-excursion
      (goto-char (point-max))
      (re-search-backward "[^ \t]" nil t) ; last non-blank line
      (delete-blank-lines)))
  ;; Really only want to do this after a successful commit, but no
  ;; hook for that.
  (let ((dbuff "*vc-diff*")
        (file (car (log-edit-files)))
        diff-buff)
    ;; Only kill diff if associated with file being commited.
    (when (and file (get-buffer dbuff))
        ;; file is not absolute, so use buffer instead.
      (setq file (find-buffer-visiting file))
      (with-current-buffer dbuff
        (save-excursion
          ;; Avoid "Can't find the beginning of the hunk" error.
          (goto-char (point-max))
          (setq diff-buff (car (diff-find-source-location)))))
      (if (equal diff-buff file)
          (kill-buffer dbuff)))))

;;;; VC ;;;;


;;;; Diff ;;;;
(setq diff-default-read-only t)

(my-make-hook-fn diff-mode-hook
;;;  (or buffer-file-name (toggle-read-only 1))
  (if window-system
      (progn
        (face-spec-set
         'diff-file-header-face '((t (:weight bold :foreground "aquamarine"))))
        (face-spec-set
         'diff-header-face
         '((t (:weight bold :foreground "cyan" :background "grey45"))))
        (face-spec-set
         'diff-hunk-header-face
         '((t (:weight bold :foreground "azure" :background "grey45"))))
        (face-spec-set 'diff-context-face '((t (:foreground "grey70"))))
        (face-spec-set 'diff-nonexistent-face '((t (:foreground "red"))))
        (face-spec-set 'diff-changed-face '((t (:foreground "DarkSlateGray1"))))
        (face-spec-set 'diff-added-face '((t (:foreground "DarkOliveGreen1"))))
        (face-spec-set 'diff-removed-face '((t (:foreground "khaki1"))))
        (face-spec-set 'diff-function-face '((t (:foreground "IndianRed1")))))
    (face-spec-set 'diff-context-face '((t (:inherit default))))))

;;;; Diff ;;;;


;;;; Ediff ;;;;
(setq ediff-use-long-help-message t)
;;;; Ediff ;;;;


;;;; Completion ;;;;
;; Annoying.
;;;(partial-completion-mode 1)

(setq completion-ignored-extensions
      (delete ".bbl" completion-ignored-extensions)
      completion-ignored-extensions
      (delete ".log" completion-ignored-extensions))

;;;; Completion ;;;;


;;;; Compilation ;;;;
(setq compilation-scroll-output t
      ;; Saves all buffers. Saving none is not an option.
      compilation-ask-about-save nil)
;;;; Compilation ;;;;



;;;; Calendar ;;;;
;;;

(unless (equal my-emacs-type 'mail)
  (setq calendar-latitude +52.1
        calendar-longitude +0.1
        calendar-location-name "Cambridge"
        calendar-remove-frame-by-deleting t
        calendar-week-start-day 1
        european-calendar-style t
        mark-diary-entries-in-calendar t
        mark-holidays-in-calendar t
        view-calendar-holidays-initially nil)

  (require 'cal-x)                        ; bug
  (setq calendar-setup 'calendar-only)

  (add-hook 'today-visible-calendar-hook 'calendar-mark-today)

  (add-hook 'list-diary-entries-hook 'sort-diary-entries t)


  (my-make-hook-fn initial-calendar-window-hook
    ;; Doesn't work fully in `calendar-load-hook'.
    (face-spec-set 'calendar-today-face '((t (:background "steelblue"))))
    (face-spec-set 'diary-face
                   '((t (:foreground "aquamarine" :weight bold))))
    ;; Something complementary to diary-face.
    (face-spec-set 'holiday-face '((t (:underline t)))))


  (defadvice exit-calendar (after kill-calendar-buffer activate)
    "Kill the calendar buffer on exit."
    (mapcar (lambda (buff) (and (get-buffer buff) (kill-buffer buff)))
            '("*Calendar*" "*Fancy Diary Entries*"))) ; "diary"

  )                                     ; unless 'mail

;;;
;;;; Calendar ;;;;


;;;; Diary ;;;;
;;;

(unless (equal my-emacs-type 'mail)
  (setq diary-file (file-chase-links (expand-file-name "diary" my-emacsdir))
        diary-list-include-blanks nil
        diary-header-line-flag nil
        mark-diary-entries-in-calendar t
        diary-mail-addr (my-mail-obfuscate-address "gmorris+diary"
                                                   "generic@ast.cam.ac.uk")
        diary-mail-days 7)

  (add-hook 'diary-display-hook 'fancy-diary-display)

  (defadvice fancy-diary-display (after view-mode activate)
    "Switch the fancy-diary-buffer to read-only."
    (if (get-buffer fancy-diary-buffer)
        (save-excursion
          (set-buffer fancy-diary-buffer)
          (local-set-key "q" 'View-kill-and-leave) ; does not work?
          (view-mode 1)))))                        ; unless 'mail
;;;
;;;; Diary ;;;;


;;;; Appointments ;;;;
;;;

(unless (equal my-emacs-type 'mail)

  (setq appt-display-diary nil
        appt-display-mode-line t
        appt-display-duration 10          ; secs
        appt-display-interval 3           ; mins
        appt-message-warning-time 12      ; mins
        appt-audible t)

  (if (fboundp 'appt-activate)
      (progn
        (setq appt-display-format 'window)
        ;; Set vc-follow-symlinks first.
        (appt-activate 1)
        (my-face-set 'appt-mode-line
                     '((t :foreground "deepskyblue2" :weight bold))))
    (setq appt-issue-message t
          appt-msg-window t
          appt-visible nil)
    (add-hook 'diary-hook 'appt-make-list))) ; unless 'mail

;;;
;;;; Appointments ;;;;


;;;; Text-mode ;;;;
(add-hook 'text-mode-hook 'turn-on-auto-fill)
;; Seems necessary to enable font-lock in text-mode, even with
;; (global-font-lock-mode 1), perhaps because text mode defines no font-lock
;; syntax. Only want this to stop text yanked from buffers in other modes
;; bringing face attributes with it. HOWEVER, adding this line messes up
;; fontification of VM mail composition buffers, as these run this hook
;; when initializing. This can be easily overcome in .vm.el.
;; But this messes up latex font-locking as well. Lose it.
;;;(add-hook 'text-mode-hook 'turn-on-font-lock)
;; Leave a bit of space in case comment out lines or something.
(setq-default fill-column 70)
;;;(setq-default auto-fill-function 'do-auto-fill) ; global auto-fill

(setq ispell-program-name "/usr/bin/ispell")
;;;      (let ((aspell "/scratch/gmorris/software/bin/aspell"))
;;;        (if (file-executable-p aspell) aspell "ispell")))

(setq-default ispell-local-dictionary "british")
(setq flyspell-issue-welcome-flag nil)
;;;(add-hook 'text-mode-hook 'flyspell-mode)


(my-make-hook-fn text-mode-hook
  ;; Bug, IMO, that hs-minor-mode is perm local.
  ;; Alternatively, could undo that.
  (when (and (boundp 'hs-minor-mode)
             hs-minor-mode)
    (hs-minor-mode -1)))


(my-make-hook-fn enriched-mode-hook
  ;; Rather than reindent-then-newline-and-indent.
  (define-key enriched-mode-map [return] 'newline)
  (face-spec-set 'excerpt '((t (:slant italic :family "helvetica")))))


;; Single spaces after full-stops at end of sentences.
(setq sentence-end-double-space nil
      sentence-end (if sentence-end-double-space
                       "[.?!][]\"')]*\\($\\| $\\|\t\\|  \\)[ \t\n]*"
                     "[.?!][]\"')]*\\($\\|\t\\| \\)[ \t\n]*"))

(defun my-sentence-end-double-space ()
  "Set `sentence-end-double-space' to t, and set `sentence-end' to match.
Make these variables buffer-local."
  (set (make-local-variable 'sentence-end-double-space) t)
  (set (make-local-variable 'sentence-end)
       "[.?!][]\"')]*\\($\\| $\\|\t\\|  \\)[ \t\n]*"))

(mapcar (lambda (mode) (add-hook (intern (format "%s-mode-hook" mode))
                                 'my-sentence-end-double-space))
        ;; Texinfo is the AUCTeX mode name.
        '(emacs-lisp log-edit change-log texinfo Texinfo))

(defun my-duplicate-words-find ()       ; cf dupwords.el?
  "Find consecutive groups of one or more repeated words."
  (interactive)
  (if (search-forward-regexp
       ;; For duplicate words, eg words words.
;;;       "\\(\\<\\w+\\>\\)[ \t\n]*\\1\\>" nil t)
       ;; Attempt at duplicate groups, eg word group word group.
       "\\(\\<\\w+\\>\\(?:[ \t]+\\<\\w+\\>\\)*\\)[ \t\n]*\\1\\>" nil t)
      ;; Temporary highlighting needs overlays, post-command hooks (?).
      ;; I'll go to hell for this though.
      (dotimes (i 2)
        (save-excursion
          (sit-for 0.1)
          (goto-char (match-beginning 0))
          (sit-for 0.1)))
    (if (interactive-p) (message "No more duplicates"))))
;;;; Text-mode ;;;;


;;;; Man ;;;;
(defface my-Man-overstrike-face '((t (:foreground "white" :weight normal)))
  "Face used for overstrike in man pages.")

(defface my-Man-underline-face '((t (:foreground "yellow")))
  "Face used for overstrike in man pages.")

(setq Man-overstrike-face 'my-Man-overstrike-face
      Man-underline-face 'my-Man-underline-face)
;;;; Man ;;;;


;;;; WoMan ;;;;
(setq woman-cache-filename (expand-file-name "woman.cache" my-emacsdir)
      woman-bold-headings nil
      woman-imenu-title "WoMan-imenu"
      woman-imenu t
      woman-use-own-frame t             ; does not work?
      woman-topic-at-point nil
      woman-fill-frame t)

(defun my-woman-pre-format-fn ()
  "Function added to `woman-pre-format-hook'."
  (copy-face 'my-Man-overstrike-face 'woman-bold-face)
  (copy-face 'my-Man-underline-face 'woman-italic-face)
  (face-spec-set 'woman-addition-face '((t (:foreground "orange"))))
  (face-spec-set 'woman-unknown-face  '((t (:foreground "cyan")))))

(add-hook 'woman-pre-format-hook 'my-woman-pre-format-fn)

;; So that each instance will pop up a new frame.
;; Maybe `special-display-regexps' would be better?
(add-hook 'woman-post-format-hook (lambda () (setq woman-frame nil)))
;;;; WoMan ;;;;


;;;; TCL mode ;;;;
(my-make-hook-fn tcl-mode-hook
  (imenu-add-menubar-index)
  ;; For some reason, does not work. See also my-sh-mode-hook-fn.
;;;  (if (facep 'tcl-escaped-newline)
;;;      (copy-face 'font-lock-warning-face 'tcl-escaped-newline))
  (my-face-set 'tcl-escaped-newline
               '((t (:foreground "pink" :weight bold)))))
;;;; TCL mode ;;;;


;;;; Python ;;;;
(font-lock-add-keywords
 'python-mode (list (cons
                     (concat "\\<"
                             ;; "Built-in Constants" in python-lib.info.
                             (regexp-opt '("False" "True" "None"
                                           "NotImplemented" "Ellipsis") t)
                             "\\>")
                     'font-lock-constant-face)
                    '("\\(^\\|[^\\]\\)\\(\\\\\\\\\\)*\\(\\\\\\)$"
                      3 font-lock-warning-face)
                    ;; TODO match a, b = 1, 2?
                    '("\\<\\([[:alpha:]_][.[:alnum:]_]*\\)\\>[ \t]*=[ \t]"
                      1 font-lock-variable-name-face)
                    (list
                     (concat "[ \t]"
                             (regexp-opt '("<" ">" "==" ">=" "<=" "<>" "!="
                                           "&" "|" "%" "+=") t)
                             "[ \t]")
                     1 font-lock-constant-face)
                    ;; Override some existing locking as keywords.
                    (list
                     (concat "\\<"
                             (regexp-opt '("global" "import"
                                           "len" "pass" "print") t)
                             "\\>")
                     1 font-lock-builtin-face)))

(defun my-python-set-magic ()
  "Insert the #! line in a python script."
  (interactive "*")
  (executable-set-magic "/usr/bin/python" nil t))

(my-make-hook-fn python-mode-hook
  (imenu-add-menubar-index)
  (require 'executable)
  (font-lock-add-keywords nil executable-font-lock-keywords)
  (local-set-key "\C-c:" 'my-python-set-magic))

;;;; Python ;;;;


;;;; c mode ;;;;
(setq-default c-default-style "k&r")
(font-lock-add-keywords
 'c-mode
 `(("/\\*" ("\\<\\(GM\\|NB\\|TODO\\)\\>"
            nil nil (0 'font-lock-warning-face t)))
   ;; More complex than usual to avoid comments commented by coment-region.
   ("/\\*" ("\\*\\([^ ][^*]*[^ ]*\\)\\*[^//]"
            nil nil (1 'font-lock-warning-face t)))
   ("/\\*" ("`\\([^`']+\\)'" nil nil (1 'font-lock-constant-face t)))
   (,(regexp-opt '("&&" "||" "<=" ">=" "==" "!=" ; overkill?
                   "++" "--" "+=" "-=" "*=" "/=") t) .
                   font-lock-constant-face)))

(add-hook 'c-mode-hook 'imenu-add-menubar-index)


(my-make-hook-fn c-mode-hook
  (hs-minor-mode 1)
  ;; Personally I think there should be an easier way to disable these.
  (mapc (lambda (key) (local-set-key key 'self-insert-command))
        '("{" "}" "(" ")" "," ";"))
  (or (file-expand-wildcards "[Mm]akefile")
      (if buffer-file-name
          (setq compile-command (format "gcc -Wall %s" buffer-file-name)))))

;;;; c mode ;;;;


;;;; FORTRAN mode ;;;;
(setq fortran-comment-indent-style nil  ; do not indent comments
      fortran-continuation-string "&"
      fortran-comment-region "C"
;;;      fortran-check-all-num-for-matching-do t
      fortran-blink-matching-if t
      fortran-break-before-delimiters nil)

(add-hook 'fortran-mode-hook 'imenu-add-menubar-index)

(my-make-hook-fn fortran-mode-hook
  (hs-minor-mode 1)
;;; As fortran.el notes, fortran comment don't play nice with Emacs.
;;; Or rather vice versa. One notes Emacs has special alternate comment
;;; syntax just for C! Perhaps Fortran could use this for free- and fixed-
;;; form comments? Yuck, I give up.
;;; Note comment-dwim fails to uncomment-region in fortran mode when it
;;; should. It seems this is because forward-comment does not operate for
;;; "^C" style comments. It must use the syntax table, in which "!" is
;;; defined with comment start syntax "<". Perhaps one could define a
;;; two-character comment, can one use "^" in syntax-tables? Don't see how...

  ;; Set to "![ \t]*" in fortran.el. Breaks uncomment-region,
  ;; since does not match "^C" inserted by comment-region.
  ;; This might break other things if use trailing "!" comments.
  ;; BAD idea - breaks filling.
;;;  (setq comment-start-skip "^[*!c]")
  ;; "\(..\)" constructs have special meaning to newcomment.el.
;;;  (concat "\\(^[*!c]\\|" comment-start-skip "\\)"))

  ;; Makes sure uncomment-region does not mess up columns.
  (set (make-local-variable 'comment-padding) nil)

  ;; This fixes comment-dwim, but I don't care.

  ;; Set to nil to use comment-forward in comment-dwim.
  ;; If left at the default, 'undecided, a test will be applied
  ;; that should set this automatically.
;;;  (set (make-local-variable 'comment-use-syntax) nil)

  ;; comment-forward fails if this is nil.
;;;  (set (make-local-variable 'comment-end-skip) "\n")

;;;   (when (fboundp 'comment-dwim)
;;;
;;;     (define-key fortran-mode-map [?\M-\;] 'comment-dwim)
;;;
;;;     ;; Normal version fails when `comment-use-syntax' is nil,
;;;     ;; because it does not skip empty lines.
;;;     ;; (skip-syntax-forward " ") skips all characters with
;;;     ;; whitespace syntax, but "\n" has end of comment syntax.
;;;     ;; Surely there are better ways to skip empty lines, if that
;;;     ;; is the object?
;;;     (defun comment-forward (&optional n)
;;;       "Skip forward over N comments.
;;; Just like `forward-comment' but only for positive N
;;; and can use regexps instead of syntax."
;;;       (setq n (or n 1))
;;;       (if (< n 0) (error "No comment-backward")
;;;         (if comment-use-syntax (forward-comment n)
;;;           (while (> n 0)
;;;             (skip-syntax-forward " ")
;;;             (skip-syntax-forward ">")   ; GM addition
;;;             (setq n
;;;                   (if (and (looking-at comment-start-skip)
;;;                            (goto-char (match-end 0))
;;;                            (re-search-forward comment-end-skip nil
;;;                                               'move))
;;;                       (1- n) -1)))
;;;           (= n 0)))))
  )

;;;; FORTRAN mode ;;;;


;;;; F90 mode ;;;;
;;;

(unless (equal 'my-emacs-type 'mail)

  (add-to-list 'auto-mode-alist '("\\.f95\\'" . f90-mode))

  (setq f90-beginning-ampersand nil ; no "&" at *start* of continuations
        f90-indented-comment-re "!!"    ; "!!" indented to code
        f90-comment-region "!!! "       ; string to comment regions
        f90-program-indent 2            ; PROG, MOD, SUB, FUNC
        f90-type-indent 3               ; TYPE, INTERFACE, BLOCK DATA
        f90-do-indent 3                 ; DO
        f90-if-indent 3               ; IF, SELECT CASE, WHERE, FORALL
        f90-continuation-indent 5
        f90-break-before-delimiters nil
        ;; OMPs can be indented.
        f90-directive-comment-re "!\\(hpf\\|\\$OMP\\)")

  (add-hook 'f90-mode-hook 'turn-on-auto-fill)
  (add-hook 'f90-mode-hook 'f90-add-imenu-menu)


  (defun my-f90-mode-init-fn ()
    "Run the first time f90-mode is loaded."
    (unless (and (boundp 'my-f90-mode-init-flag)
                 my-f90-mode-init-flag)
      (setq my-f90-mode-init-flag t)

      ;; For NAG f95.
      (when (require 'compile nil t)
        (add-to-list 'compilation-error-regexp-alist
                     '("^\\w+: \\(.+\\), line \\([0-9]+\\):" 1 2)))


      (defface f95-keyword-face
        '((t (:foreground "plum1")))
        "F95 keywords face.")

      (defface f95-function-face
        '((t (:foreground "azure1")))
        "F95 function name face.")

      (defvar f95-font-lock-keywords
        (list
         '("\\<\\(pure\\|elemental\\)\\>" . 'f95-keyword-face)

         ;; Override existing highlighting of 'elsewhere', etc,
         ;; but not in comments.
         '("^[^!]*\\<\\(null\\|cpu_time\\|elsewhere\\)\\>[ \t]*("
           1 'f95-function-face t)
;;;         (1 (if (f90-in-comment) 'font-lock-comment-face
;;;              'f95-function-face) t))

         ;; Plain forall should not really be highlighted without
         ;; trailing '(', but is in existing f90-mode.
         '("^[^!]*\\<\\(end[ \t]*forall\\)\\>"
           1 'f95-function-face t)

         '("^[^!]*\\<\\(forall\\)\\>"
           1 'f95-function-face t)

         ;; Highlight the extra 'dim' keyword for these functions.
         '("\\<\\(\\(max\\|min\\)loc\\|ceiling\\|floor\\)\\>[ \t]*("
           ("\\<dim\\>" nil nil (0 'f95-keyword-face))))
        "Highlights extra F95 keywords.")

;;;      (font-lock-add-keywords 'f90-mode f95-font-lock-keywords)


      (defun my-f90-in-declaration ()
        "Return non-nil if current line contains `::' construct."
        (save-excursion
          (beginning-of-line)
          (re-search-forward "::" (line-end-position) t)))

      (when (require 'align nil t)
        ;; Do not try to do everything with this, just most useful things.
        (setq align-to-tab-stop nil     ; global
              my-f90-align-rules-list
              `((f90-bracket-in-declaration
                 (regexp . "\\(\\s-+\\)([^ :]+).*::"))
                (f90-comma-in-declaration ; better than all that follows?
                 (regexp    . "\\(\\s-*\\),\\s-+.*::") ; avoid (1:,2:)
                 (spacing   . 0))
                (f90-dimension-in-declaration
                 (regexp    . "\\(\\s-*\\),\\s-*dimension.*::")
                 (spacing   . 0)
                 (case-fold . t))
                (f90-alloc-in-declaration
                 (regexp    . "\\(\\s-*\\),\\s-*allocatable.*::")
                 (spacing   . 0)
                 (case-fold . t))
                (f90-intent-in-declaration
                 (regexp    . "\\(\\s-*\\),\\s-*intent.*::")
                 (spacing   . 0)
                 (case-fold . t))
                (f90-parameter-in-declaration
                 (regexp    . "\\(\\s-*\\),\\s-*parameter.*::")
                 (spacing   . 0)
                 (case-fold . t))
                (f90-save-in-declaration
                 (regexp    . "\\(\\s-*\\),\\s-*save.*::")
                 (spacing   . 0)
                 (case-fold . t))
                (f90-colon-in-declaration ; must come last
                 (regexp . "\\(\\s-+\\):: "))
                (f90-left-bracket
                 (regexp  . "\\(\\s-*\\)(\\S+")
                 (spacing . 0)
                 (repeat  . t)
                 (valid   . ,(function (lambda ()
                                         (not (my-f90-in-declaration))))))
                (f90-assignment
                 (regexp  . "\\(\\s-+\\)[=<>]\\(\\s-+\\)\\S-") ; avoid (kind=dp)
                 (group   . (1 2))
                 (spacing . (1 1))
                 (repeat  . t))
                (f90-comma-colon
                 (regexp  . "\\(\\s-*\\)[,;]\\s-+") ; avoid dim(0:,1:)
                 (spacing . 0)    ; no space before "," if none needed
                 (repeat  . t)
                 (valid   . ,(function (lambda ()
                                         (not (my-f90-in-declaration))))))
                ;; No way to prevent acting on isolated comments,
                                        ; or line overrun.
                (f90-trailing-comment
                 (regexp  . "\\(\\s-+\\)!\\s-+")
                 (spacing . 10))))

        (add-to-list 'align-open-comment-modes 'f90-mode)
        (add-to-list 'align-dq-string-modes    'f90-mode)
        (add-to-list 'align-sq-string-modes    'f90-mode)) ; 'align


      ;; Extra font-lock keywords. Note not case-sensitive in Fortran-mode.
      (font-lock-add-keywords
       'f90-mode
       `(("^#\\(\\w+\\)\\([ \t]+\\w+\\)?" ; preprocessor
          (1 font-lock-builtin-face)
          (2 font-lock-variable-name-face nil t))
         (,(regexp-opt '("<=" ">=" "==" "/=") t) . font-lock-constant-face)))

      (define-abbrev [f90-mode-abbrev-table] "`ife" "" 'f90-skeleton-elif)
      (setq abbrevs-changed nil)


      (define-skeleton f90-skeleton-elif
        "Insert an F90 elif block."
        nil
        > "if (" _ ") then"\n
        \n
        -3"else" \n
        \n
        -3"end if"\n)

      ;; Now added to f90.el.
      (defconst f90-end-block-re
        (concat "^[ \t0-9]*\\<end\\>[ \t]*"
                (regexp-opt '("do" "if" "forall" "function" "interface"
                              "module" "program" "select"  "subroutine"
                              "type" "where" ) t)
                "[ \t]*\\sw*")
        "Regexp matching the end of a \"block\" of F90 code.")


      ;; Ignore the fact that FUNCTION, SUBROUTINE, WHERE, FORALL have a
      ;; following "(".  DO, CASE, IF can have labels; IF must be
      ;; accompanied by THEN.
      ;; A big problem is that many of these statements can be broken over
      ;; lines, even with embedded comments. We only try to handle this for
      ;; IF ... THEN statements, assuming and hoping it will be less common
      ;; for other constructs. We match up to one new-line, provided ")
      ;; THEN" appears on one line. Matching on just ") THEN" is no good,
      ;; since that includes ELSE branches.
      (defconst f90-start-block-re
        (concat
         "^[ \t0-9]*"                   ; statement number
         "\\(\\("
         "\\(\\sw+[ \t]*:[ \t]*\\)?"    ; structure label
         "\\(do\\|select[ \t]*case\\|if[ \t]*(.*\n?.*)[ \t]*then\\|"
         ;; Distinguish WHERE block from isolated WHERE.
         "\\(where\\|forall\\)[ \t]*(.*)[ \t]*\\(!\\|$\\)\\)\\)"
         "\\|"
         "program\\|interface\\|module\\|type\\|function\\|subroutine"
         ;; ") THEN" at line end. Problem - also does ELSE.
;;;   "\\|.*)[ \t]*then[ \t]*\\($\\|!\\)"
         "\\)"
         "[ \t]*")
        "Regexp matching the start of a \"block\" of F90 code.
A simple regexp cannot do this in fully correct fashion, so this
tries to strike a compromise between complexity and flexibility.")

      (add-to-list 'hs-special-modes-alist
                   `(f90-mode ,f90-start-block-re ,f90-end-block-re
                              "!" f90-end-of-block nil))

      ))                                ; my-f90-mode-init-fn


  (my-make-hook-fn f90-mode-hook
    (my-f90-mode-init-fn)
    (make-variable-buffer-local 'compile-command)
    (setq comment-column 35
          comment-start "! "
          ;; Normally level 4 consists of level 3 plus HPF syntax.
          f90-font-lock-keywords-4
          (append f90-font-lock-keywords-3 f95-font-lock-keywords)
          compile-command
          (if buffer-file-name
              (if (file-exists-p "Makefile")
                  (format "make %s"
                          (file-name-sans-extension
                           (file-name-nondirectory
                            buffer-file-name)))
                (format "ifort -warn all -std90 %s" buffer-file-name)))
          align-mode-rules-list my-f90-align-rules-list)
    ;; Annoying.
;;;  (define-key f90-mode-map [return] 'f90-indent-new-line)
    (define-key f90-mode-map [?\C-^] 'f90-join-lines)
    (hs-minor-mode 1)
    (when (boundp 'comment-auto-fill-only-comments)
      (setq comment-auto-fill-only-comments t)
      ;; Fixup for buggy 21.1.
      ;; NB this 'fix' breaks auto-fill of strings for some
      ;; reason if one resets c-a-f-o-c to nil.
      ;; Still does not deal with f90-electric-insert.
;;;    (kill-local-variable 'normal-auto-fill-function)
      ))

  )                                     ; unless 'mail

;;;
;;;; F90 mode ;;;;


;;;; Inferior lisp, etc ;;;;
;;;

(if (executable-find "clisp") (setq inferior-lisp-program "clisp"))

(when (and (not (equal my-emacs-type 'mail))
           (file-directory-p "~/elisp/slime")
           (add-to-list 'load-path "~/elisp/slime" t))
  (autoload 'slime "slime" "" t)
  ;; Necessary?
  (defadvice slime (before slime-setup activate)
    "Call `slime-setup' first."
    (slime-setup))
  (let ((dir (file-name-as-directory
              (expand-file-name "../../../doc/HyperSpec" my-sitelisp))))
    (if (file-directory-p dir)
        (setq common-lisp-hyperspec-root dir))))

;;;
;;;; Inferior lisp, etc ;;;;


;;;; Lisp-mode ;;;;
;;;


;; This version allows multiple matches in any one line.
(font-lock-add-keywords
 'emacs-lisp-mode
 '((";" ("\\<\\(GM\\|NB\\|TODO\\|FIXME\\)\\>" nil nil
         (0 'font-lock-warning-face t)))
   (";" ("[* ]\\*[ \t]*\\(\\w.*\\)\\*" nil nil
         (1 'font-lock-warning-face t)))))


(unless (equal my-emacs-type 'mail)

  (mapcar (lambda (elem)
            (add-hook 'emacs-lisp-mode-hook elem))
          '(imenu-add-menubar-index turn-on-eldoc-mode checkdoc-minor-mode))

  (defun my-eldoc-argument-case-fn (string)
    "Function to use for variable `eldoc-argument-case'."
    (propertize (upcase string) 'face 'font-lock-keyword-face))

  ;; TODO modify eldoc so that this applies to all doc-strings.
  (setq eldoc-argument-case 'my-eldoc-argument-case-fn)


  (my-make-hook-fn emacs-lisp-mode-hook
    (local-set-key "\C-cd" 'my-jump-to-defun)
    (hs-minor-mode 1)
    ;; A little shorter than "Emacs-Lisp".
    ;; Avoid lisp-interaction and other derived modes.
    (if (eq major-mode 'emacs-lisp-mode)
        (setq mode-name "Elisp"))
    (when (boundp 'comment-auto-fill-only-comments)
      (setq comment-auto-fill-only-comments t)
      (kill-local-variable 'normal-auto-fill-function)))


  (my-make-hook-fn lisp-interaction-mode-hook
    (setq mode-name "Lisp Int"))

  )                                     ; unless 'mail


(setq eval-expression-print-level  10
      eval-expression-print-length 100)

;;;
;;;; Lisp-mode ;;;;


;;;; makefile-mode ;;;;
(my-make-hook-fn makefile-mode-hook
  (imenu-add-menubar-index)
  (font-lock-add-keywords nil
                          '(("ifeq[ \t]*(" (" +" nil nil
                                            (0 'makefile-space-face)))))
  (when (fboundp 'makefile-gmake-mode)
    ;; f-l-t-f is only used for highlighting I don't like.
    (set (make-local-variable 'font-lock-type-face) 'default)
    ;; Restore old font-lock behaviour, which is illogical (should be
    ;; variable-name-face rather than constant), but I like it.
    ;; TODO $() bold in targets (prepend does that, but everywhere).
    (font-lock-add-keywords nil
                            '(
                              ("\\(\\$\\)\\([@%<?^+*]\\)"
                               (1 'default t)
                               (2 font-lock-constant-face t))
                              ("$[({]\\([[:alnum:]_.]+\\)[})]"
                               (1 font-lock-constant-face t t))
                              ) t)))

(eval-after-load "make-mode"
  '(progn
     (my-face-set 'makefile-shell-face
                  '((t :background "unspecified" :inherit 'default )))
     (my-face-set 'makefile-targets-face
                  '((t :underline nil
                       :inherit 'font-lock-function-name-face)))))

;; Would prefer makefile-mode to default to makefile-gmake-mode.
(when (fboundp 'makefile-gmake-mode)
  (add-to-list 'auto-mode-alist '("[Mm]akefile\\'" . makefile-gmake-mode)))

;;;; makefile-mode ;;;;


;;;; AWK mode ;;;;

(my-make-hook-fn awk-mode-hook
  ;; Indentation in old AWK mode is bad, as it is derived from C-mode,
  ;; and so does not function properly without ";" terminating every line.
  ;; New-AWK mode is much improved.
  ;; Get correct comment character on auto-fill.
  (set (make-local-variable 'c-block-comment-prefix) "#")
  ;; Turn off c-style indentation, so that tabs are literal.
  (set (make-local-variable 'c-syntactic-indentation)
       (if (locate-library "cc-awk") t))
  (set (make-local-variable 'c-basic-offset) 4)
  ;; c-electric-brace should behave when c-syntactic-indentation
  ;; is nil, (according to the doc string), but does not.
  (local-set-key "}" 'self-insert-command)
  (local-set-key "{" 'self-insert-command)
  (font-lock-add-keywords
   nil `(("^#!.*\\(gawk.*\\)$" . ; fontify magic
          (1 font-lock-keyword-face t)) ; allow override
         ("\\$\\([0-9]+\\|nf\\)" . ; fontify $field
          (1 font-lock-variable-name-face))
         ("\\(^\\|[^\\]\\)\\(\\\\\\\\\\)*\\(\\\\\\)$"
          3 font-lock-warning-face)     ; escaped EOL
         (,(regexp-opt '("&&" "||" "<=" ">=" "==" "!="
                         "++" "--" "+=" "-=" "*=" "/="
                         "~" "!~") t) .
                         font-lock-constant-face))))

;;;; AWK mode ;;;;


;;;; SGML mode ;;;;
;; TODO ??
(setq sgml-font-lock-keywords
      '(("<\\([!?][a-z][-.a-z0-9]*\\)" 1 font-lock-keyword-face)
        ("<\\(/?[a-z][-.a-z0-9]*\\)"   1 font-lock-function-name-face)
        ("[&%][a-z][-.a-z0-9]*;?"      . font-lock-variable-name-face)
        ("<!-- * -->"                  . font-lock-comment-face)))

(font-lock-add-keywords 'html-mode
                        '(("\\<TODO\\>" 0 font-lock-warning-face t)))

;;;; SGML mode ;;;;


;;;; sh-mode ;;;;
(setq executable-prefix "#!"            ; no space
      sh-here-document-word "EOF"
      sh-shell-file     "/bin/bash"
      sh-indent-comment t)              ; indent comments

;; Copied from make-mode.el for use with sh-mode font-lock-keywords.
(defface makefile-space-face
  '((((class color)) (:background  "hotpink"))
    (t (:reverse-video t)))
  "Face to use for highlighting leading spaces in Font-Lock mode.")

(defun my-sh-mode-font-lock-heredoc-space (lim)
  "Match leading space in a heredoc."
  (if (eq (get-text-property (point) 'face) 'sh-heredoc-face)
      (re-search-forward "^ +" (min lim (line-end-position)) t)))

(font-lock-add-keywords
 'sh-mode
 ;; \\< does not work with && etc.
 `((,(format "[ \t]%s\\([ \t]\\|$\\)"
             (regexp-opt '("||" "&&" "!=" "==" "<=" ">="
                           "-eq" "-ne" "-lt" "-gt" "-le" "-ge") t))
    . font-lock-constant-face)
   ;; Leading tabs anywhere.
   ("^\t+" (0 'makefile-space-face t))
   ;; Leading space in heredocs.
   ;; NB disabled.
;;;   (my-sh-mode-font-lock-heredoc-space (0 'trailing-whitespace t))
   ;; [ is harder than [[, because of the use in array syntax.
   ;; Actually, can be followed by anything (regexp).
   ;; This is also annoying because $foo] (an error)
   ;; cannot easily be distinguished from ${foo]}.
   ;; ]] does not have this problem.
;;;   ("\\(\\]\\)[^}=;\\\\ \t\n]" (1 font-lock-warning-face))))
   ))

(my-make-hook-fn sh-mode-hook
  ;; This means saving a sh-scipt changes its inode.
  ;; Enables one to safely (?) edit running scripts.
  ;; The backup must then be made by copying (the original cannot be
  ;; moved before being overwritten, else the file will be briefly
  ;; missing, or after, since then the contents have changed.
  ;; TODO check (file-nlinks (buffer-file-name))?
  (set (make-local-variable 'file-precious-flag) t)
  (imenu-add-menubar-index)
;;;  (define-key sh-mode-map [tab] 'sh-indent-line)
  ;; Default is symbol, which makes selection annoying.
  (modify-syntax-entry ?= ".")          ; punctuation
  ;; So adaptive fill does not get confused by #! line,
  ;; if a comment block follows on from there.
  (set (make-variable-buffer-local 'adaptive-fill-regexp)
       "[ \t]*\\(#+[ \t]+\\)*")
  (setq mode-name "Sh-script"          ; save a few chars
        ;; This means scripts may look different in other editors.
        tab-width 4)
  (my-face-set 'sh-heredoc-face
               '((t (:weight normal :foreground "green yellow"))))
  ;; For some reason, does not work. See also my-tcl-mode-hook-fn.
;;;  (if (facep 'sh-escaped-newline)
;;;      (copy-face 'font-lock-warning-face 'sh-escaped-newline))
  (my-face-set 'sh-escaped-newline
               '((t (:foreground "pink" :weight bold))))
  (when (boundp 'comment-auto-fill-only-comments)
    (setq comment-auto-fill-only-comments t))
  ;; Causes huge cpu usage in 21 for some reason.
  (when (> emacs-major-version 21)
    (add-to-list (if (boundp 'sh-font-lock-keywords-var)
                     'sh-font-lock-keywords-var
                   'sh-font-lock-keywords)
                 ;; Only works (?) because there is no bash entry by default.
                 '(bash sh-append sh
                        ("\\<\\(declare\\|export\\|typeset\\)\\>.*\\<-[fF]\\>"
                         ("\\<\\(\\sw+\\)\\>" nil nil
                          (1 font-lock-function-name-face)))
                        ("\\<\\(declare\\|local\\|typeset\\)\\>"
                         ;; \\< matches options, eg -f.
                         ("[ \t]+\\([A-Za-z_][A-Za-z0-9_]*\\)\\>" nil nil
                          (1 font-lock-variable-name-face)))
                        ("\\<let\\>"
                         ("[ \t]*\\(+\\+\\|--\\)\\([A-Za-z_][A-Za-z0-9_]*\\)\\>"
                          nil nil
                          (1 font-lock-constant-face)
                          (2 font-lock-variable-name-face)))
                        ("\\<let\\>"
                         ("\\<\\([A-Za-z_][A-Za-z0-9_]*\\)\
\\([|^&%*/+-]=\\|--\\|+\\+\\)"
                          nil nil
                          (1 font-lock-variable-name-face)
                          (2 font-lock-constant-face)))
                        ("for[ \t]*(("
                         ("\\<\\([A-Za-z_][A-Za-z0-9_]*\\)\
\\([ \t]*[<>]=?\\|--\\|+\\+\\)"
                          nil nil
                          (1 font-lock-variable-name-face)
                          (2 font-lock-constant-face)))
                        ;; This one should really be in the sh section.
                        ("\\<\\(export\\|read\\)\\>"
                         ;; Using \\< matches <<EOF.
                         ("[ \t]+\\([A-Za-z_][A-Za-z0-9_]*\\)\\>" nil nil
                          (1 font-lock-variable-name-face)))
                        ;; Process substitution.
                        ("[ \t]*\\([<>](\\)[^)]+\\()\\)"
                         (1 font-lock-builtin-face)
                         (2 font-lock-builtin-face))
                        ("\\(^\\|[; \t]\\)\\(\\[\\[?\\)[ \t]"
                         (2 font-lock-builtin-face)) ; [[
                        ("[ \t]\\(\\]\\]?\\)[; \t\n]"
                         (1 font-lock-builtin-face)) ; ]]
                        ;; [[, ]] without spaces, etc.
                        ("\\(\\[\\[\\|\\]\\]\\)" . font-lock-warning-face)))))


(and (fboundp 'executable-make-buffer-file-executable-if-script-p)
     (add-hook 'after-save-hook
               'executable-make-buffer-file-executable-if-script-p))

;; Ideal solution - add support for indentation in sh-script so that
;; here docs are indented with tabs. After toying with various
;; things, this is the simplest. Simply allow M-i to insert literal
;; tabs (but only in heredocs), and do it by hand.
(defadvice tab-to-tab-stop (around sh-indent-tabs disable) ; NB disabled
  "In sh-mode, allow indentation to insert tabs in heredocs."
  (if (and (eq major-mode 'sh-mode)
           (eq (get-text-property (point) 'face) sh-heredoc-face))
      (let ((indent-tabs-mode t))
        ad-do-it)
    ad-do-it))


(defun my-function-closing-comment (&optional always)
  "Insert a closing comment giving the name of the current shell/awk function.
Requires the function `paren-backward-sexp' from mic-paren.
Unless the optional argument ALWAYS is non-nil, a closing comment
is only inserted if the function body is 4 or more lines long."
  (interactive "*P")
  ;; TODO find a standard replacement for this.
  (when (fboundp 'paren-backward-sexp)
  ;; Want to save point rather than point-marker.
    (let ((pos (point))
          (n 0))
      (beginning-of-line)
      (when (save-excursion
              (and (re-search-forward "[ \t]*}" (line-end-position) t)
                   (paren-backward-sexp)
                   (or always
                       ;; Faster than using line-number-at-pos.
                       (save-excursion
                         (while (and (<= (point) pos)
                                     (zerop (forward-line 1)))
                           (setq n (1+ n)))
                         (> n 5)))
                   (progn
                     (beginning-of-line)
                     ;; "{" on separate line from function name.
                     (and (looking-at "^[ \t]*{") (forward-line -1))
                     (cond
                      ((eq major-mode 'sh-mode)
                       (looking-at "^[ \t]*\\(?:function\\)?[ \t]+\
\\([[:alnum:]_]+\\)[ \t]*()[ \t]*{?[ \t]*\\($\\|#.*\\)"))
                      ((eq major-mode 'awk-mode)
                       (or
                        (looking-at "^[ \t]*function[ \t]+\
\\([[:alnum:]_]+\\)[ \t]*(")
                        (looking-at "^\\(BEGIN\\|END\\)[ \t]+\\\\")))
                      (t
                       (message "Don't know what to do for `%s'" major-mode)
                       nil))
                     )))
        (setq fname (format "%c %s %s"
                            (string-to-char (or comment-start "#"))
                            (if (and (equal major-mode 'awk-mode)
                                     (member (match-string-no-properties 1)
                                             '("BEGIN" "END")))
                                "end"
                              "function")
                            (match-string-no-properties 1)))
        (re-search-forward "^[ \t]*}[ \t]*\\(.*\\)" (line-end-position) t)
        ;; Avoid unnecessary buffer modification.
        (unless (string-equal (match-string 1) fname)
          (replace-match fname nil nil nil 1)
          (comment-indent)))
      (goto-char pos))))

(defadvice sh-indent-line (before my-function-closing-comment activate)
  "Run `my-function-closing-comment' before indenting."
  (my-function-closing-comment))

;; TODO how pass prefix arg to my-function-closing-comment?
(defadvice c-indent-command (before my-function-closing-comment activate)
  "Run `my-function-closing-comment' before indenting in AWK mode."
  (if (equal major-mode 'awk-mode)
      (my-function-closing-comment)))


;;;; sh-mode ;;;;


;;;; eshell ;;;;

(defface my-eshell-code-face
  '((t (:foreground "Green")))
  "Eshell face for code (.c, .f90 etc) files.")

(defface my-eshell-img-face
  '((t (:foreground "magenta" :weight bold)))
  "Eshell face for image (.jpg etc) files.")

(defface my-eshell-movie-face
  '((t (:foreground "white" :weight bold)))
  "Eshell face for movie (.mpg etc) files.")

(defface my-eshell-music-face
  '((t (:foreground "magenta")))
  "Eshell face for music (.mp3 etc) files.")

(defface my-eshell-ps-face
  '((t (:foreground "cyan")))
  "Eshell face for PostScript (.ps, .pdf etc) files.")

(setq my-eshell-code-list '("f90" "f" "c" "bash" "sh" "csh" "awk" "el")
      my-eshell-img-list
      '("jpg" "jpeg" "png" "gif" "bmp" "ppm" "tga" "xbm" "xpm" "tif" "fli")
      my-eshell-movie-list '("mpg" "avi" "gl" "dl")
      my-eshell-music-list '("mp3" "ogg")
      my-eshell-ps-list    '("ps" "eps" "cps" "pdf")
      eshell-ls-highlight-alist nil)

(let (list face)
  (mapcar (lambda (elem)
            (setq list (car elem)
                  face (cdr elem))
            (add-to-list 'eshell-ls-highlight-alist
                         (cons `(lambda (file attr)
                                  (string-match
                                   (concat "\\." (regexp-opt ,list t) "$")
                                   file))
                               face)))
          '((my-eshell-code-list  . my-eshell-code-face)
            (my-eshell-img-list   . my-eshell-img-face)
            (my-eshell-movie-list . my-eshell-movie-face)
            (my-eshell-music-list . my-eshell-music-face)
            (my-eshell-ps-list    . my-eshell-ps-face))))

(defun my-tidy-pwd (string)
  "Replace leading ~ by $HOME in output of pwd."
  (replace-regexp-in-string "^~" (getenv "HOME") string))

(defun my-eshell-prompt-function ()
  "Return the prompt for eshell."
  (format "[%s@%s %s]%s "
          (eshell-user-name)
          (replace-regexp-in-string "\\..*" "" (system-name))
          (eshell/basename (eshell/pwd))
          (if (zerop (user-uid)) "#" "$")))

(defun my-eshell-line-discard ()
  "Eshell implementation of C-u."
  (interactive)
  (eshell-bol)
  (kill-line))


(defun my-eshell-clear-buffer ()
  (interactive)
  (let ((eshell-buffer-maximum-lines 0))
    (eshell-truncate-buffer)))

(defalias 'eshell/clear 'my-eshell-clear-buffer)


(setq eshell-directory-name (expand-file-name "eshell" my-emacsdir)
      eshell-pwd-convert-function 'my-tidy-pwd
      eshell-prompt-function 'my-eshell-prompt-function
      eshell-prompt-regexp "^\\[.*\\][#$] "
      eshell-ask-to-save-history 'always
      eshell-banner-message `(format-time-string
                              "Eshell startup: %T, %A %d %B %Y\n\n"))


(my-make-hook-fn eshell-first-time-mode-hook