Support XDG-based init directory

[sxemacs] / lisp / simple.el

;;; simple.el --- basic editing commands for SXEmacs

;; Copyright (C) 1985-7, 1993-5, 1997 Free Software Foundation, Inc.
;; Copyright (C) 1995 Tinker Systems and INS Engineering Corp.
;; Copyright (C) 2000, 2001, 2002, 2003 Ben Wing.
;; Copyright (C) 2006, Steve Youngs.

;; Maintainer: SXEmacs Development Team
;; Keywords: lisp, extensions, internal, dumped

;; This file is part of SXEmacs.

;; SXEmacs 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 3 of the License, or
;; (at your option) any later version.

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

;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.

;;; Synched up with: FSF 19.34 [But not very closely].

;;; Commentary:

;; This file is dumped with SXEmacs.

;; A grab-bag of basic SXEmacs commands not specifically related to some
;; major mode or to file-handling.

;; Changes for zmacs-style active-regions:
;;
;; beginning-of-buffer, end-of-buffer, count-lines-region,
;; count-lines-buffer, what-line, what-cursor-position, set-goal-column,
;; set-fill-column, prefix-arg-internal, and line-move (which is used by
;; next-line and previous-line) set zmacs-region-stays to t, so that they
;; don't affect the current region-hilighting state.
;;
;; mark-whole-buffer, mark-word, exchange-point-and-mark, and
;; set-mark-command (without an argument) call zmacs-activate-region.
;;
;; mark takes an optional arg like the new Fmark_marker() does.  When
;; the region is not active, mark returns nil unless the optional arg is true.
;;
;; push-mark, pop-mark, exchange-point-and-mark, and set-marker, and
;; set-mark-command use (mark t) so that they can access the mark whether
;; the region is active or not.
;;
;; shell-command, shell-command-on-region, yank, and yank-pop (which all
;; push a mark) have been altered to call exchange-point-and-mark with an
;; argument, meaning "don't activate the region".  These commands  only use
;; exchange-point-and-mark to position the newly-pushed mark correctly, so
;; this isn't a user-visible change.  These functions have also been altered
;; to use (mark t) for the same reason.

;; 97/3/14 Jareth Hein (jhod@po.iijnet.or.jp) added kinsoku processing (support
;; for filling of Asian text) into the fill code. This was ripped bleeding from
;; Mule-2.3, and could probably use some feature additions (like additional wrap
;; styles, etc)

;; 97/06/11 Steve Baur (steve@xemacs.org) Convert use of
;;  (preceding|following)-char to char-(after|before).

;;; Code:

(defgroup editing-basics nil
  "Most basic editing variables."
  :group 'editing)

(defgroup killing nil
  "Killing and yanking commands."
  :group 'editing)

(defgroup fill-comments nil
  "Indenting and filling of comments."
  :prefix "comment-"
  :group 'fill)

(defgroup paren-matching nil
  "Highlight (un)matching of parens and expressions."
  :prefix "paren-"
  :group 'matching)

(defgroup log-message nil
  "Messages logging and display customizations."
  :group 'minibuffer)

(defgroup warnings nil
  "Warnings customizations."
  :group 'minibuffer)


(defcustom search-caps-disable-folding t
  "*If non-nil, upper case chars disable case fold searching.
This does not apply to \"yanked\" strings."
  :type 'boolean
  :group 'editing-basics)

;; This is stolen (and slightly modified) from FSF emacs's
;; `isearch-no-upper-case-p'.
(defun no-upper-case-p (string &optional regexp-flag)
  "Return t if there are no upper case chars in STRING.
If REGEXP-FLAG is non-nil, disregard letters preceded by `\\' (but not `\\\\')
since they have special meaning in a regexp."
  (let ((case-fold-search nil))
    (not (string-match (if regexp-flag
                           #r"\(^\|\\\\\|[^\]\)[A-Z]"
                         "[A-Z]")
                       string))
    ))

(defmacro with-search-caps-disable-folding (string regexp-flag &rest body)
  "Eval BODY with `case-fold-search' let to nil if `search-caps-disable-folding'
is non-nil, and if STRING (either a string or a regular expression according
to REGEXP-FLAG) contains uppercase letters."
  `(let ((case-fold-search
          (if (and case-fold-search search-caps-disable-folding)
              (no-upper-case-p ,string ,regexp-flag)
            case-fold-search)))
     ,@body))
(put 'with-search-caps-disable-folding 'lisp-indent-function 2)
(put 'with-search-caps-disable-folding 'edebug-form-spec
     '(sexp sexp &rest form))

(defmacro with-interactive-search-caps-disable-folding (string regexp-flag
                                                               &rest body)
  "Same as `with-search-caps-disable-folding', but only in the case of a
function called interactively."
  `(let ((case-fold-search
          (if (and (interactive-p)
                   case-fold-search search-caps-disable-folding)
              (no-upper-case-p ,string ,regexp-flag)
            case-fold-search)))
     ,@body))
(put 'with-interactive-search-caps-disable-folding 'lisp-indent-function 2)
(put 'with-interactive-search-caps-disable-folding 'edebug-form-spec
     '(sexp sexp &rest form))

(defun newline (&optional n)
  "Insert a newline, and move to left margin of the new line if it's blank.
The newline is marked with the text-property `hard'.
With optional arg N, insert that many newlines.
In Auto Fill mode, if no numeric arg, break the preceding line if it's long."
  (interactive "*P")
  (barf-if-buffer-read-only nil (point))
  ;; Inserting a newline at the end of a line produces better redisplay in
  ;; try_window_id than inserting at the beginning of a line, and the textual
  ;; result is the same.  So, if we're at beginning of line, pretend to be at
  ;; the end of the previous line.
  ;; #### Does this have any relevance in XEmacs?
  (let ((flag (and (not (bobp))
                   (bolp)
                   ;; Make sure the newline before point isn't intangible.
                   (not (get-char-property (1- (point)) 'intangible))
                   ;; Make sure the newline before point isn't read-only.
                   (not (get-char-property (1- (point)) 'read-only))
                   ;; Make sure the newline before point isn't invisible.
                   (not (get-char-property (1- (point)) 'invisible))
                   ;; This should probably also test for the previous char
                   ;;  being the *last* character too.
                   (not (get-char-property (1- (point)) 'end-open))
                   ;; Make sure the newline before point has the same
                   ;; properties as the char before it (if any).
                   (< (or (previous-extent-change (point)) -2)
                      (- (point) 2))))
        (was-page-start (and (bolp)
                             (looking-at page-delimiter)))
        (beforepos (point)))
    (if flag (backward-char 1))
    ;; Call self-insert so that auto-fill, abbrev expansion etc. happens.
    ;; Set last-command-char to tell self-insert what to insert.
    (let ((last-command-char ?\n)
          ;; Don't auto-fill if we have a numeric argument.
          ;; Also not if flag is true (it would fill wrong line);
          ;; there is no need to since we're at BOL.
          (auto-fill-function (if (or n flag) nil auto-fill-function)))
      (unwind-protect
          (self-insert-command (prefix-numeric-value n))
        ;; If we get an error in self-insert-command, put point at right place.
        (if flag (forward-char 1))))
    ;; If we did *not* get an error, cancel that forward-char.
    (if flag (backward-char 1))
    ;; Mark the newline(s) `hard'.
    (if use-hard-newlines
        (let* ((from (- (point) (if n (prefix-numeric-value n) 1)))
               (sticky (get-text-property from 'end-open))) ; XEmacs
          (put-text-property from (point) 'hard 't)
          ;; If end-open is not "t", add 'hard to end-open list
          (if (and (listp sticky) (not (memq 'hard sticky)))
              (put-text-property from (point) 'end-open ; XEmacs
                                 (cons 'hard sticky)))))
    ;; If the newline leaves the previous line blank,
    ;; and we have a left margin, delete that from the blank line.
    (or flag
        (save-excursion
          (goto-char beforepos)
          (beginning-of-line)
          (and (looking-at "[ \t]$")
               (> (current-left-margin) 0)
               (delete-region (point) (progn (end-of-line) (point))))))
    (if flag (forward-char 1))
    ;; Indent the line after the newline, except in one case:
    ;; when we added the newline at the beginning of a line
    ;; which starts a page.
    (or was-page-start
        (move-to-left-margin nil t)))
  nil)

(defun set-hard-newline-properties (from to)
  (let ((sticky (get-text-property from 'rear-nonsticky)))
    (put-text-property from to 'hard 't)
    ;; If rear-nonsticky is not "t", add 'hard to rear-nonsticky list
    (if (and (listp sticky) (not (memq 'hard sticky)))
        (put-text-property from (point) 'rear-nonsticky
                           (cons 'hard sticky)))))

(defun open-line (n)
  "Insert a newline and leave point before it.
If there is a fill prefix and/or a left-margin, insert them on the new line
if the line would have been blank.
With arg N, insert N newlines."
  (interactive "*p")
  (let* ((do-fill-prefix (and fill-prefix (bolp)))
         (do-left-margin (and (bolp) (> (current-left-margin) 0)))
         (loc (point)))
    (newline n)
    (goto-char loc)
    (while (> n 0)
      (cond ((bolp)
             (if do-left-margin (indent-to (current-left-margin)))
             (if do-fill-prefix (insert fill-prefix))))
      (forward-line 1)
      (setq n (1- n)))
    (goto-char loc)
    (end-of-line)))

(defun split-line ()
  "Split current line, moving portion beyond point vertically down."
  (interactive "*")
  (skip-chars-forward " \t")
  (let ((col (current-column))
        (pos (point)))
    (newline 1)
    (indent-to col 0)
    (goto-char pos)))

(defun quoted-insert (arg)
  "Read next input character and insert it.
This is useful for inserting control characters.
You may also type up to 3 octal digits, to insert a character with that code.

In overwrite mode, this function inserts the character anyway, and
does not handle octal digits specially.  This means that if you use
overwrite as your normal editing mode, you can use this function to
insert characters when necessary.

In binary overwrite mode, this function does overwrite, and octal
digits are interpreted as a character code.  This is supposed to make
this function useful in editing binary files."
  (interactive "*p")
  (let ((char (if (or (not overwrite-mode)
                      (eq overwrite-mode 'overwrite-mode-binary))
                  (read-quoted-char)
                ;; read-char obeys C-g, so we should protect.  FSF
                ;; doesn't have the protection here, but it's a bug in
                ;; FSF.
                (let ((inhibit-quit t))
                  (read-char)))))
    (if (> arg 0)
        (if (eq overwrite-mode 'overwrite-mode-binary)
            (delete-char arg)))
    (while (> arg 0)
      (insert char)
      (setq arg (1- arg)))))

(defun delete-indentation (&optional arg)
  "Join this line to previous and fix up whitespace at join.
If there is a fill prefix, delete it from the beginning of this line.
With argument, join this line to following line."
  (interactive "*P")
  (beginning-of-line)
  (if arg (forward-line 1))
  (if (eq (char-before (point)) ?\n)
      (progn
        (delete-region (point) (1- (point)))
        ;; If the second line started with the fill prefix,
        ;; delete the prefix.
        (if (and fill-prefix
                 (<= (+ (point) (length fill-prefix)) (point-max))
                 (string= fill-prefix
                          (buffer-substring (point)
                                            (+ (point) (length fill-prefix)))))
            (delete-region (point) (+ (point) (length fill-prefix))))
        (fixup-whitespace))))

(defalias 'join-line 'delete-indentation)

(defun fixup-whitespace ()
  "Fixup white space between objects around point.
Leave one space or none, according to the context."
  (interactive "*")
  (save-excursion
    (delete-horizontal-space)
    (if (or (looking-at #r"^\|\s)")
            (save-excursion (backward-char 1)
                            (looking-at #r"$\|\s(\|\s'")))
        nil
      (insert ?\ ))))

(defun delete-horizontal-space ()
  "Delete all spaces and tabs around point."
  (interactive "*")
  (skip-chars-backward " \t")
  (delete-region (point) (progn (skip-chars-forward " \t") (point))))

(defun just-one-space ()
  "Delete all spaces and tabs around point, leaving one space."
  (interactive "*")
  (if abbrev-mode ; XEmacs
      (expand-abbrev))
  (skip-chars-backward " \t")
  (if (eq (char-after (point)) ? ) ; XEmacs
      (forward-char 1)
    (insert ? ))
  (delete-region (point) (progn (skip-chars-forward " \t") (point))))

(defun delete-blank-lines ()
  "On blank line, delete all surrounding blank lines, leaving just one.
On isolated blank line, delete that one.
On nonblank line, delete any immediately following blank lines."
  (interactive "*")
  (let (thisblank singleblank)
    (save-excursion
      (beginning-of-line)
      (setq thisblank (looking-at "[ \t]*$"))
      ;; Set singleblank if there is just one blank line here.
      (setq singleblank
            (and thisblank
                 (not (looking-at "[ \t]*\n[ \t]*$"))
                 (or (bobp)
                     (progn (forward-line -1)
                            (not (looking-at "[ \t]*$")))))))
    ;; Delete preceding blank lines, and this one too if it's the only one.
    (if thisblank
        (progn
          (beginning-of-line)
          (if singleblank (forward-line 1))
          (delete-region (point)
                         (if (re-search-backward "[^ \t\n]" nil t)
                             (progn (forward-line 1) (point))
                           (point-min)))))
    ;; Delete following blank lines, unless the current line is blank
    ;; and there are no following blank lines.
    (if (not (and thisblank singleblank))
        (save-excursion
          (end-of-line)
          (forward-line 1)
          (delete-region (point)
                         (if (re-search-forward "[^ \t\n]" nil t)
                             (progn (beginning-of-line) (point))
                           (point-max)))))
    ;; Handle the special case where point is followed by newline and eob.
    ;; Delete the line, leaving point at eob.
    (if (looking-at "^[ \t]*\n\\'")
        (delete-region (point) (point-max)))))

(defun back-to-indentation ()
  "Move point to the first non-whitespace character on this line."
  ;; XEmacs change
  (interactive "_")
  (beginning-of-line 1)
  (skip-chars-forward " \t"))

(defun newline-and-indent ()
  "Insert a newline, then indent according to major mode.
Indentation is done using the value of `indent-line-function'.
In programming language modes, this is the same as TAB.
In some text modes, where TAB inserts a tab, this command indents to the
column specified by the function `current-left-margin'."
  (interactive "*")
  (delete-region (point) (progn (skip-chars-backward " \t") (point)))
  (newline)
  (indent-according-to-mode))

(defun reindent-then-newline-and-indent ()
  "Reindent current line, insert newline, then indent the new line.
Indentation of both lines is done according to the current major mode,
which means calling the current value of `indent-line-function'.
In programming language modes, this is the same as TAB.
In some text modes, where TAB inserts a tab, this indents to the
column specified by the function `current-left-margin'."
  (interactive "*")
  (save-excursion
    (delete-region (point) (progn (skip-chars-backward " \t") (point)))
    (indent-according-to-mode))
  (newline)
  (indent-according-to-mode))

;; Internal subroutine of delete-char
(defun kill-forward-chars (arg)
  (if (listp arg) (setq arg (car arg)))
  (if (eq arg '-) (setq arg -1))
  (kill-region (point) (+ (point) arg)))

;; Internal subroutine of backward-delete-char
(defun kill-backward-chars (arg)
  (if (listp arg) (setq arg (car arg)))
  (if (eq arg '-) (setq arg -1))
  (kill-region (point) (- (point) arg)))

(defun backward-delete-char-untabify (arg &optional killp)
  "Delete characters backward, changing tabs into spaces.
Delete ARG chars, and kill (save in kill ring) if KILLP is non-nil.
Interactively, ARG is the prefix arg (default 1)
and KILLP is t if a prefix arg was specified."
  (interactive "*p\nP")
  (let ((count arg))
    (save-excursion
      (while (and (> count 0) (not (bobp)))
        (if (eq (char-before (point)) ?\t) ; XEmacs
            (let ((col (current-column)))
              (backward-char 1)
              (setq col (- col (current-column)))
              (insert-char ?\ col)
              (delete-char 1)))
        (backward-char 1)
        (setq count (1- count)))))