home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / misc / overwrite-mode-fix.el < prev    next >
Encoding:
Text File  |  1993-03-03  |  4.9 KB  |  131 lines
  1. ;; Make backward deletion work properly in overwrite mode.
  2. ;; Copyright (C) 1991, 1992 Free Software Foundation, Inc.
  3. ;; Copyright (C) 1992 Joe Wells
  4. ;;
  5. ;; Parts of this are directly derived from part of GNU Emacs.  Thus, the
  6. ;; GNU Emacs copying conditions are included.  My portion is distributed
  7. ;; under the same copying conditions as GNU Emacs.
  8.  
  9. ;; GNU Emacs is free software; you can redistribute it and/or modify
  10. ;; it under the terms of the GNU General Public License as published by
  11. ;; the Free Software Foundation; either version 1, or (at your option)
  12. ;; any later version.
  13.  
  14. ;; GNU Emacs is distributed in the hope that it will be useful,
  15. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17. ;; GNU General Public License for more details.
  18.  
  19. ;; You should have received a copy of the GNU General Public License
  20. ;; along with GNU Emacs; see the file COPYING.  If not, write to
  21. ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  22.  
  23. ;; Created by: Joe Wells, jbw@maverick.uswest.com
  24. ;; Created on: Sun Jul 28 19:04:29 1991
  25. ;; Last modified by: Joe Wells, jbw@csd.bu.edu
  26. ;; Last modified on: Wed Oct  7 13:03:16 1992
  27. ;; Filename: overwrite-mode-fix.el
  28. ;; Purpose: make backward deletion work properly in overwrite mode
  29.  
  30. ;; LCD Archive Entry:
  31. ;; overwrite-mode-fix|Joe Wells|jbw@cs.bu.edu|
  32. ;; Make backward deletion work properly in overwrite mode.|
  33. ;; 1992-10-07||~/misc/overwrite-mode-fix.el.Z|
  34.  
  35. ;;(global-set-key "\M-o" 'overwrite-mode) ; interferes with terminal fn keys
  36.  
  37. (or (fboundp 'original-backward-delete-char-untabify)
  38.     (fset 'original-backward-delete-char-untabify
  39.       (symbol-function 'backward-delete-char-untabify)))
  40.  
  41. (defun backward-delete-char-untabify (arg &optional killp)
  42.   "Delete (or erase) characters backward, changing tabs into spaces.
  43. Delete ARG chars, and kill (save in kill ring) if KILLP is non-nil.
  44. Interactively, ARG is the prefix arg (default 1) and KILLP is t if prefix
  45. arg is was specified.  If overwrite-mode is non-nil, erases characters
  46. instead of deleting."
  47.   (interactive "*p\nP")
  48.   (if overwrite-mode
  49.       (backward-erase-char-untabify arg killp)
  50.     (original-backward-delete-char-untabify arg killp)))
  51.  
  52. (or (fboundp 'original-backward-delete-char)
  53.     (fset 'original-backward-delete-char
  54.       (symbol-function 'backward-delete-char)))
  55. ;; Equivalent to:
  56. ;; (fset 'original-backward-delete-char 'delete-backward-char)
  57.  
  58. (or (fboundp 'original-delete-backward-char)
  59.     (fset 'original-delete-backward-char
  60.       (symbol-function 'delete-backward-char)))
  61.  
  62. (defun delete-backward-char (arg &optional killp)
  63.   "Delete (or erase) the previous ARG characters (following, with neg. ARG).
  64. Optional second arg KILLFLAG non-nil means kill instead (save in kill
  65. ring).  Interactively, ARG is the prefix arg, and KILLFLAG is set if ARG
  66. was explicitly specified.  If overwrite-mode is non-nil, erases characters
  67. instead of deleting."
  68.   (interactive "p\nP")
  69.   (if overwrite-mode
  70.       (backward-erase-char arg killp)
  71.     (original-delete-backward-char arg killp)))
  72.  
  73. (defun backward-erase-char (arg &optional killp)
  74.   "Erase the previous ARG characters (following, with neg. ARG).
  75. Optional second arg KILLFLAG non-nil means kill instead (save in kill
  76. ring).  Interactively, ARG is the prefix arg, and KILLFLAG is set if ARG
  77. was explicitly specified."
  78.   (interactive "*p\nP")
  79.   (let* ((del-fun (if killp 'kill-region 'delete-region))
  80.      (last-command last-command)
  81.      opoint diff)
  82.     (while (> arg 0)
  83.       (cond ((memq (preceding-char) '(?\n ?\t ? ))
  84.          (backward-char 1)
  85.          (if killp
  86.          (copy-region-as-kill (1+ (point)) (point)))
  87.          (setq arg (1- arg)))
  88.         (t
  89.          (setq opoint (point))
  90.          (skip-chars-backward "^ \t\n")
  91.          (if (> (- opoint (point)) arg)
  92.          (goto-char (- opoint arg)))
  93.          (setq diff (- opoint (point))
  94.            arg (- arg diff))
  95.          (funcall del-fun opoint (point))
  96.          (or (eolp)
  97.          (save-excursion
  98.            (insert-char ?  diff)))))
  99.       (setq last-command 'kill-region))))
  100.  
  101. (defun backward-erase-char-untabify (arg &optional killp)
  102.   "Erase characters backward, changing tabs into spaces.
  103. Erase ARG chars, and kill (save in kill ring) if KILLP is non-nil.
  104. Interactively, ARG is the prefix arg (default 1) and KILLP is t if prefix
  105. arg is was specified."
  106.   (interactive "*p\nP")
  107.   (let* ((del-fun (if killp 'kill-region 'delete-region))
  108.      (last-command last-command)
  109.      opoint original-col target-col)
  110.     (while (> arg 0)
  111.       (cond ((bolp)
  112.          (backward-char 1)
  113.          (if killp
  114.          (copy-region-as-kill (1+ (point)) (point)))
  115.          (setq arg (1- arg)))
  116.         (t
  117.          (setq opoint (point)
  118.            original-col (current-column)
  119.            target-col (max 0 (- original-col arg))
  120.            arg (- arg (- original-col target-col)))
  121.          (move-to-column-force target-col)
  122.          (funcall del-fun opoint (point))
  123.          (or (eolp)
  124.          (save-excursion
  125.            (indent-to (max target-col original-col))))))
  126.       (setq last-command 'kill-region))))
  127.  
  128. (autoload 'move-to-column-force "picture")
  129.  
  130. (provide 'overwrite-mode-fix)
  131.