;;; caps-lock.el --- Caps Lock mode

;; Copyright (C) 2002 John Paul Wallington

;; Author:  John Paul Wallington <jpw@shootybangbang.com>
;; Created: 24 April 2002
;; Version:
;; Keywords: convenience keyboard

;; This file isn't part of Emacs.

;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 2, or (at
;; your option) any later version.

;; This program is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.

;;; Commentary:

;; Simulates Caps Lock.  Inspired by Hemlock on CMU Common Lisp; by
;; capslock.el - a quick and dirty Emacs 19 caps-lock minor mode
;; written by Eberhard Mattes; and by the deficiencies of an earlier
;; effort called lockcaps, which was a little too simple-minded and
;; had a crappy name.

;;; Code:

(defgroup caps-lock nil
  "Simulate Caps Lock."
  :group 'keyboard)

(defcustom caps-lock-invert nil
  "*If non-nil, `caps-lock-mode' inverts case when confronted with Capital Letters."
  :type '(choice (const :tag "Invert case" t)
		 (const :tag "Force upper case" nil))		
  :group 'caps-lock)

(defcustom caps-lock-disable-in-minibuffer t
  "*If non-nil, `caps-lock-mode' is disabled in minibuffers."
  :type 'boolean
  :group 'caps-lock)

(defcustom caps-lock-mode-line-string " Caps"
  "*String to display in the mode-line when `caps-lock-mode' is active.
  Set this to nil if you don't want a mode-line indicator."
  :type '(choice string
		 (const :tag "none" nil))
  :group 'caps-lock)

(defvar caps-lock-mode nil
  "Mode variable for Caps Lock mode.  Set this using the command `caps-lock-mode'.")

(defvar caps-lock-map-enabled nil)

(defvar caps-lock-map nil 
  "Keymap for Caps Lock minor mode.")

(unless caps-lock-map
  (let ((map (make-keymap)))
    (substitute-key-definition
     'self-insert-command 'caps-lock-character
     map global-map)
    (if (char-table-p (standard-case-table))
	(map-char-table (lambda (key value)
			  (if (< 127 key)
			      (define-key map
				(vector key) 'caps-lock-character)))
			(standard-case-table)))
    (setq caps-lock-map map)))

(or (assq 'caps-lock-map-enabled minor-mode-map-alist)
    (setq minor-mode-map-alist
	  (cons (cons 'caps-lock-map-enabled caps-lock-map) 
		minor-mode-map-alist)))

(or (assq 'caps-lock-mode minor-mode-alist)
    (setq minor-mode-alist
	  (cons '(caps-lock-mode caps-lock-mode-line-string)
		minor-mode-alist)))
(or (assq 'caps-lock-map-enabled minor-mode-alist)
    (setq minor-mode-alist
	  (cons '(caps-lock-map-enabled nil) minor-mode-alist)))

;;;###autoload 
(defun caps-lock-mode (&optional arg)
  "Toggle Caps Lock mode.
With arg, turn `caps-lock-mode' on if and only if arg is positive."
  (interactive "P")
  (setq caps-lock-map-enabled
	(setq caps-lock-mode 
	      (if (null arg)
		  (not caps-lock-mode)
		(> (prefix-numeric-value arg) 0))))
  (force-mode-line-update))

(if (or (featurep 'xemacs)
	(string-match "XEmacs\\|Lucid" (emacs-version)))
    (defun caps-lock-character (arg)
      "Simulate Caps Lock."
      (interactive "i")
      (let* ((lie (copy-event last-input-event))
	     (lic (event-to-character lie)))
	(when lic
	  (setq unread-command-events
		(list (character-to-event
		       (if (and caps-lock-disable-in-minibuffer
				(eq (minibuffer-window) (selected-window)))
			   lic
			 (if caps-lock-invert
			     (if (equal (downcase lic) lic)
				 (upcase lic)
			       (downcase lic))
			   (upcase lic))))))
	  (setq caps-lock-map-enabled nil)
	  (add-hook 'post-command-hook 'caps-lock-map-enable))))
  (defun caps-lock-character (arg)
    "Simulate Caps Lock."
    (interactive "i")
    (let ((lie last-input-event))
      (when (char-valid-p lie)
	(setq unread-command-events
	      (list
	       (if (and caps-lock-disable-in-minibuffer
			(eq (minibuffer-window) (selected-window)))
		   lie
		 (if caps-lock-invert
		     (if (equal (downcase lie) lie)
			 (upcase lie)
		       (downcase lie))
		   (upcase lie))))))
      (setq caps-lock-map-enabled nil)
      (add-hook 'post-command-hook 'caps-lock-map-enable))))

(defun caps-lock-map-enable (&optional twice)
  (remove-hook 'post-command-hook (if twice 
				      (lambda ()
					(caps-lock-map-enable 'twice))
				    'caps-lock-map-enable))
  (if twice
      (setq caps-lock-map-enabled caps-lock-mode)
    (add-hook 'post-command-hook (lambda ()
				   (caps-lock-map-enable 'twice)))))

(provide 'caps-lock)
;;; caps-lock.el ends here