xemacs-beta: lisp/simple.el comparison

comparison lisp/simple.el @ 442:abe6d1db359e r21-2-36

Import from CVS: tag r21-2-36

author	cvs
date	Mon, 13 Aug 2007 11:35:02 +0200
parents	8de8e3f6228a
children	576fb035e263

comparison

equal deleted inserted replaced

-:72a7cfa4a488
+:abe6d1db359e
 ;;; simple.el --- basic editing commands for XEmacs
 ;; Copyright (C) 1985-7, 1993-5, 1997 Free Software Foundation, Inc.
 ;; Copyright (C) 1995 Tinker Systems and INS Engineering Corp.
+;; Copyright (C) 2000 Ben Wing.
 ;; Maintainer: XEmacs Development Team
 ;; Keywords: lisp, extensions, internal, dumped
 ;; This file is part of XEmacs.
 		(t
 		 ;; give a basic line count
 		 (message "Line %d" buffer-line)))))))
 (setq zmacs-region-stays t))
-;;; Bob Weiner, Altrasoft, 02/12/1998
+;; new in XEmacs 21.2 (not in FSF).
-;;; Added the 3rd arg in `count-lines' to conditionalize the counting of
+(defun line-number (&optional pos respect-narrowing)
-;;; collapsed lines.
+"Return the line number of POS (defaults to point).
+If RESPECT-NARROWING is non-nil, then the narrowed line number is returned;
+otherwise, the absolute line number is returned.  The returned line can always
+be given to `goto-line' to get back to the current line."
+(if (and pos (/= pos (point)))
+(save-excursion
+	(goto-char pos)
+	(line-number nil respect-narrowing))
+(1+ (count-lines (if respect-narrowing (point-min) 1) (point-at-bol)))))
 (defun count-lines (start end &optional ignore-invisible-lines-flag)
 "Return number of lines between START and END.
 This is usually the number of newlines between them,
 but can be one more if START is not equal to END
 and the greater of them is not at the start of a line.
 With optional IGNORE-INVISIBLE-LINES-FLAG non-nil, lines collapsed with
-selective-display are excluded from the line count."
+selective-display are excluded from the line count.
+NOTE: The expression to return the current line number is not obvious:
+(1+ (count-lines 1 (point-at-bol)))
+See also `line-number'."
 (save-excursion
 (save-restriction
 (narrow-to-region start end)
 (goto-char (point-min))
 (if (and (not ignore-invisible-lines-flag) (eq selective-display t))
 (interactive "_p")
 (forward-line (- arg))
 (skip-chars-forward " \t"))
 (defcustom kill-whole-line nil
-"*If non-nil, `kill-line' with no arg at beg of line kills the whole line."
+"*Control when and whether `kill-line' removes entire lines.
-:type 'boolean
+Note: This only applies when `kill-line' is called interactively;
+otherwise, it behaves \"historically\".
+If `always', `kill-line' with no arg always kills the whole line,
+wherever point is in the line. (If you want to just kill to the end
+of the line, use \\[historical-kill-line].)
+If not `always' but non-nil, `kill-line' with no arg kills the whole
+line if point is at the beginning, and otherwise behaves historically.
+If nil, `kill-line' behaves historically."
+:type '(radio (const :tag "Kill to end of line" nil)
+		(const :tag "Kill whole line" always)
+		(const
+		 :tag "Kill whole line at beginning, otherwise end of line" t))
 :group 'killing)
+(defun historical-kill-line (&optional arg)
+"Same as `kill-line' but ignores value of `kill-whole-line'."
+(interactive "*P")
+(let ((kill-whole-line nil))
+(if (interactive-p)
+	(call-interactively 'kill-line)
+(kill-line arg))))
 (defun kill-line (&optional arg)
-"Kill the rest of the current line; if no nonblanks there, kill thru newline.
+"Kill the rest of the current line, or the entire line.
+If no nonblanks there, kill thru newline.
+If called interactively, may kill the entire line; see `kill-whole-line'.
+when given no argument at the beginning of a line.
 With prefix argument, kill that many lines from point.
 Negative arguments kill lines backward.
 When calling from a program, nil means \"no arg\",
-a number counts as a prefix arg.
+a number counts as a prefix arg."
-If `kill-whole-line' is non-nil, then kill the whole line
-when given no argument at the beginning of a line."
 (interactive "*P")
-(kill-region (point)
+(kill-region (if (and (interactive-p)
+			(not arg)
+			(eq kill-whole-line 'always))
+		   (save-excursion
+		     (beginning-of-line)
+		     (point))
+		 (point))
 	       ;; Don't shift point before doing the delete; that way,
 	       ;; undo will record the right position of point.
 ;; FSF
 ;	       ;; It is better to move point to the other end of the kill
 ;	       ;; before killing.  That way, in a read-only buffer, point
 	       (save-excursion
 		 (if arg
 		     (forward-line (prefix-numeric-value arg))
 		   (if (eobp)
 		       (signal 'end-of-buffer nil))
-		   (if (or (looking-at "[ \t]*$") (and kill-whole-line (bolp)))
+		   (if (or (looking-at "[ \t]*$")
+			   (and (interactive-p)
+				(or (eq kill-whole-line 'always)
+				    (and kill-whole-line (bolp)))))
 		       (forward-line 1)
 		     (end-of-line)))
 		 (point))))
 ;; XEmacs
 ;;; `kill-hooks' seems not sufficient because
 ;;; `interprogram-cut-function' requires more variable about to rotate
 ;;; the cut buffers.  I'm afraid to change interface of `kill-hooks',
 ;;; so I add it. (1997-11-03 by MORIOKA Tomohiko)
-(defvar interprogram-cut-function nil
+(defcustom interprogram-cut-function 'own-clipboard
 "Function to call to make a killed region available to other programs.
 Most window systems provide some sort of facility for cutting and
 pasting text between the windows of different programs.
 This variable holds a function that Emacs calls whenever text
 The function takes one or two arguments.
 The first argument, TEXT, is a string containing
 the text which should be made available.
 The second, PUSH, if non-nil means this is a \"new\" kill;
-nil means appending to an \"old\" kill.")
+nil means appending to an \"old\" kill."
+:type '(radio (function-item :tag "Send to Clipboard"
-(defvar interprogram-paste-function nil
+			       :format "%t\n"
+			       own-clipboard)
+		(const :tag "None" nil)
+		(function :tag "Other"))
+:group 'killing)
+(defcustom interprogram-paste-function 'get-clipboard
 "Function to call to get text cut from other programs.
 Most window systems provide some sort of facility for cutting and
 pasting text between the windows of different programs.
 This variable holds a function that Emacs calls to obtain
 Note that the function should return a string only if a program other
 than Emacs has provided a string for pasting; if Emacs provided the
 most recent string, the function should return nil.  If it is
 difficult to tell whether Emacs or some other program provided the
 current string, it is probably good enough to return nil if the string
-is equal (according to `string=') to the last text Emacs provided.")
+is equal (according to `string=') to the last text Emacs provided."
+:type '(radio (function-item :tag "Get from Clipboard"
+			       :format "%t\n"
+			       get-clipboard)
+		(const :tag "None" nil)
+		(function :tag "Other"))
+:group 'killing)
 ;;;; The kill ring data structure.
 (defvar kill-ring nil
 ;    (setq mark-active nil)
 ;    (run-hooks 'deactivate-mark-hook)
 ;    (set-marker (mark-marker) nil)))
 (defvar mark-ring nil
-"The list of former marks of the current buffer, most recent first.")
+"The list of former marks of the current buffer, most recent first.
+This variable is automatically buffer-local.")
 (make-variable-buffer-local 'mark-ring)
 (put 'mark-ring 'permanent-local t)
+(defvar dont-record-current-mark nil
+"If set to t, the current mark value should not be recorded on the mark ring.
+This is set by commands that manipulate the mark incidentally, to avoid
+cluttering the mark ring unnecessarily.  Under most circumstances, you do
+not need to set this directly; it is automatically reset each time
+`push-mark' is called, according to `mark-ring-unrecorded-commands'.  This
+variable is automatically buffer-local.")
+(make-variable-buffer-local 'dont-record-current-mark)
+(put 'dont-record-current-mark 'permanent-local t)
+;; a conspiracy between push-mark and handle-pre-motion-command
+(defvar in-shifted-motion-command nil)
+(defcustom mark-ring-unrecorded-commands '(shifted-motion-commands
+					   yank
+					   mark-beginning-of-buffer
+					   mark-bob
+					   mark-defun
+					   mark-end-of-buffer
+					   mark-end-of-line
+					   mark-end-of-sentence
+					   mark-eob
+					   mark-marker
+					   mark-page
+					   mark-paragraph
+					   mark-sexp
+					   mark-whole-buffer
+					   mark-word)
+"*List of commands whose marks should not be recorded on the mark stack.
+Many commands set the mark as part of their action.  Normally, all such
+marks get recorded onto the mark stack.  However, this tends to clutter up
+the mark stack unnecessarily.  You can control this by putting a command
+onto this list.  Then, any marks set by the function will not be recorded.
+The special value `shifted-motion-commands' causes marks set as a result
+of selection using any shifted motion commands to not be recorded.
+The value `yank' affects all yank-like commands, as well as just `yank'."
+:type '(repeat (choice (const :tag "shifted motion commands"
+				'shifted-motion-commands)
+			 (const :tag "functions that select text"
+				:inline t
+				'(mark-beginning-of-buffer
+				  mark-bob
+				  mark-defun
+				  mark-end-of-buffer
+				  mark-end-of-line
+				  mark-end-of-sentence
+				  mark-eob
+				  mark-marker
+				  mark-page
+				  mark-paragraph
+				  mark-sexp
+				  mark-whole-buffer
+				  mark-word))
+			 (const :tag "functions that paste text"
+				'yank)
+			 function))
+:group 'killing)
 (defcustom mark-ring-max 16
 "*Maximum size of mark ring.  Start discarding off end if gets this big."
 :type 'integer
 :group 'killing)
 "Set mark at where point is, or jump to mark.
 With no prefix argument, set mark, push old mark position on local mark
 ring, and push mark on global mark ring.
 With argument, jump to mark, and pop a new position for mark off the ring
 \(does not affect global mark ring\).
+The mark ring is a per-buffer stack of marks, most recent first.  Its
+maximum length is controlled by `mark-ring-max'.  Generally, when new
+marks are set, the current mark is pushed onto the stack.  You can pop
+marks off the stack using \\[universal-argument] \\[set-mark-command].  The term \"ring\" is used because when
+you pop a mark off the stack, the current mark value is pushed onto the
+far end of the stack.  If this is confusing, just think of the mark ring
+as a stack.
 Novice Emacs Lisp programmers often try to use the mark for the wrong
 purposes.  See the documentation of `set-mark' for more information."
 (interactive "P")
 (if (null arg)
 (push-mark nil nil t)
 (if (null (mark t))
 	(error "No mark set in this buffer")
+(if dont-record-current-mark (pop-mark))
 (goto-char (mark t))
 (pop-mark))))
 ;; XEmacs: Extra parameter
 (defun push-mark (&optional location nomsg activate-region buffer)
 Activate mark if optional third arg ACTIVATE-REGION non-nil.
 Novice Emacs Lisp programmers often try to use the mark for the wrong
 purposes.  See the documentation of `set-mark' for more information."
 (setq buffer (decode-buffer buffer)) ; XEmacs
-(if (null (mark t buffer)) ; XEmacs
+(if (or dont-record-current-mark (null (mark t buffer))) ; XEmacs
 nil
 ;; The save-excursion / set-buffer is necessary because mark-ring
 ;; is a buffer local variable
 (save-excursion
 (set-buffer buffer)
 	    (move-marker (car (nthcdr mark-ring-max mark-ring)) nil buffer)
 	    (setcdr (nthcdr (1- mark-ring-max) mark-ring) nil)))))
 (set-mark (or location (point buffer)) buffer)
 ; (set-marker (mark-marker) (or location (point)) (current-buffer)) ; FSF
 ;; Now push the mark on the global mark ring.
-(if (or (null global-mark-ring)
+(if (and (not dont-record-current-mark)
-(not (eq (marker-buffer (car global-mark-ring)) buffer)))
+	   (or (null global-mark-ring)
+	       (not (eq (marker-buffer (car global-mark-ring)) buffer))))
 ;; The last global mark pushed wasn't in this same buffer.
 (progn
 (setq global-mark-ring (cons (copy-marker (mark-marker t buffer))
 global-mark-ring))
 (if (> (length global-mark-ring) global-mark-ring-max)
 (progn
 (move-marker (car (nthcdr global-mark-ring-max global-mark-ring))
 nil buffer)
 (setcdr (nthcdr (1- global-mark-ring-max) global-mark-ring) nil)))))
-(or nomsg executing-kbd-macro (> (minibuffer-depth) 0)
+(setq dont-record-current-mark
+	(not (not (or (and in-shifted-motion-command
+			   (memq 'shifted-motion-commands
+				 mark-ring-unrecorded-commands))
+		      (memq this-command mark-ring-unrecorded-commands)))))
+(or dont-record-current-mark nomsg executing-kbd-macro
+(> (minibuffer-depth) 0)
 (display-message 'command "Mark set"))
 (if activate-region
 (progn
 	(setq zmacs-region-stays t)
 	(zmacs-activate-region)))
 This behavior used to be the default, and is still default in FSF Emacs.
 We think it is an unnecessary and unwanted side-effect."
 :type 'boolean
 :group 'editing-basics)
+(defcustom shifted-motion-keys-select-region t
+"*If non-nil, shifted motion keys select text, like in MS Windows.
+See also `unshifted-motion-keys-deselect-region'."
+:type 'boolean
+:group 'editing-basics)
+(defcustom unshifted-motion-keys-deselect-region t
+"*If non-nil, unshifted motion keys deselect a shifted-motion region.
+This only occurs after a region has been selected using shifted motion keys
+(not when using the traditional set-mark-then-move method), and has no effect
+if `shifted-motion-keys-select-region' is nil."
+:type 'boolean
+:group 'editing-basics)
+(defun handle-pre-motion-command-current-command-is-motion ()
+(and (key-press-event-p last-input-event)
+(memq (event-key last-input-event)
+	'(left right up down home end prior next
+	       kp-left kp-right kp-up kp-down
+	       kp-home kp-end kp-prior kp-next))))
+(defun handle-pre-motion-command ()
+(if
+(and
+(handle-pre-motion-command-current-command-is-motion)
+zmacs-regions
+shifted-motion-keys-select-region
+(not (region-active-p))
+(memq 'shift (event-modifiers last-input-event)))
+(let ((in-shifted-motion-command t))
+	(push-mark nil nil t))))
+(defun handle-post-motion-command ()
+(if
+(and
+(handle-pre-motion-command-current-command-is-motion)
+zmacs-regions
+(region-active-p))
+(cond ((memq 'shift (event-modifiers last-input-event))
+	     (if shifted-motion-keys-select-region
+		 (putf this-command-properties 'shifted-motion-command t))
+	     (setq zmacs-region-stays t))
+	    ((and (getf last-command-properties 'shifted-motion-command)
+		  unshifted-motion-keys-deselect-region)
+	     (setq zmacs-region-stays nil))
+	    (t
+	     (setq zmacs-region-stays t)))))
 (defun forward-char-command (&optional arg buffer)
 "Move point right ARG characters (left if ARG negative) in BUFFER.
 On attempt to pass end of buffer, stop and signal `end-of-buffer'.
 On attempt to pass beginning of buffer, stop and signal `beginning-of-buffer'.
 Error signaling is suppressed if `signal-error-on-buffer-boundary'
 (condition-case nil
 	(backward-char arg buffer)
 (beginning-of-buffer nil)
 (end-of-buffer nil))))
+(defun scroll-up-one ()
+"Scroll text of current window upward one line.
+On attempt to scroll past end of buffer, `end-of-buffer' is signaled.
+On attempt to scroll past beginning of buffer, `beginning-of-buffer' is
+signaled.
+If `signal-error-on-buffer-boundary' is nil, attempts to scroll past buffer
+boundaries do not cause an error to be signaled."
+(interactive "_")
+(scroll-up-command 1))
 (defun scroll-up-command (&optional n)
 "Scroll text of current window upward ARG lines; or near full screen if no ARG.
 A near full screen is `next-screen-context-lines' less than a full screen.
 Negative ARG means scroll downward.
 When calling from a program, supply a number as argument or nil.
 (condition-case nil
 	(scroll-up n)
 (beginning-of-buffer nil)
 (end-of-buffer nil))))
+(defun scroll-down-one ()
+"Scroll text of current window downward one line.
+On attempt to scroll past end of buffer, `end-of-buffer' is signaled.
+On attempt to scroll past beginning of buffer, `beginning-of-buffer' is
+signaled.
+If `signal-error-on-buffer-boundary' is nil, attempts to scroll past buffer
+boundaries do not cause an error to be signaled."
+(interactive "_")
+(scroll-down-command 1))
 (defun scroll-down-command (&optional n)
 "Scroll text of current window downward ARG lines; or near full screen if no ARG.
 A near full screen is `next-screen-context-lines' less than a full screen.
 Negative ARG means scroll upward.
 When calling from a program, supply a number as argument or nil.
 in `goal-column', which is nil when there is none.
 If you are thinking of using this in a Lisp program, consider
 using `forward-line' instead.  It is usually easier to use
 and more reliable (no dependence on goal column, etc.)."
-(interactive "_p") ; XEmacs
+(interactive "_p")
 (if (and next-line-add-newlines (= arg 1))
 (let ((opoint (point)))
 	(end-of-line)
 	(if (eobp)
 	    (newline 1)
 Then it does not try to move vertically.
 If you are thinking of using this in a Lisp program, consider using
 `forward-line' with a negative argument instead.  It is usually easier
 to use and more reliable (no dependence on goal column, etc.)."
-(interactive "_p") ; XEmacs
+(interactive "_p")
 (if (interactive-p)
 (condition-case nil
 	  (line-move (- arg))
 	((beginning-of-buffer end-of-buffer)
 	 (when signal-error-on-buffer-boundary ; XEmacs
 	   (ding nil 'buffer-bound))))
 (line-move (- arg)))
 nil)
+(defcustom block-movement-size 6
+"*Number of lines that \"block movement\" commands (\\[forward-block-of-lines], \\[backward-block-of-lines]) move by."
+:type 'integer
+:group 'editing-basics)
+(defun backward-block-of-lines ()
+"Move backward by one \"block\" of lines.
+The number of lines that make up a block is controlled by
+`block-movement-size', which defaults to 6."
+(interactive "_")
+(forward-line (- block-movement-size)))
+(defun forward-block-of-lines ()
+"Move forward by one \"block\" of lines.
+The number of lines that make up a block is controlled by
+`block-movement-size', which defaults to 6."
+(interactive "_")
+(forward-line block-movement-size))
 (defcustom track-eol nil
 "*Non-nil means vertical motion starting at end of line keeps to ends of lines.
 This means moving to the end of each line moved onto.
 The beginning of a blank line does not count as the end of a line."
 			       (newline)
 			     (forward-char 1)))
 		       (forward-line arg)))
 		  arg))
-(eval-when-compile
+(defun transpose-line-up (arg)
-;; avoid byte-compiler warnings...
+"Move current line one line up, leaving point at beginning of that line.
-(defvar start1)
+This can be run repeatedly to move to current line up a number of lines."
-(defvar start2)
+(interactive "*p")
-(defvar end1)
+;; Move forward over a line,
-(defvar end2))
+;; but create a newline if none exists yet.
+(end-of-line)
-; start[12] and end[12] used in transpose-subr-1 below
+(if (eobp)
+(newline)
+(forward-char 1))
+(transpose-lines (- arg))
+(forward-line -1))
+(defun transpose-line-down (arg)
+"Move current line one line down, leaving point at beginning of that line.
+This can be run repeatedly to move to current line down a number of lines."
+(interactive "*p")
+;; Move forward over a line,
+;; but create a newline if none exists yet.
+(end-of-line)
+(if (eobp)
+(newline)
+(forward-char 1))
+(transpose-lines arg)
+(forward-line -1))
 (defun transpose-subr (mover arg)
 (let (start1 end1 start2 end2)
-(if (= arg 0)
+;; XEmacs -- use flet instead of defining a separate function and
-	(progn
+;; relying on dynamic scope!!!
-	  (save-excursion
+(flet ((transpose-subr-1 ()
-	    (funcall mover 1)
+	     (if (> (min end1 end2) (max start1 start2))
-	    (setq end2 (point))
+		 (error "Don't have two things to transpose"))
-	    (funcall mover -1)
+	     (let ((word1 (buffer-substring start1 end1))
-	    (setq start2 (point))
+		   (word2 (buffer-substring start2 end2)))
-	    (goto-char (mark t)) ; XEmacs
+	       (delete-region start2 end2)
-	    (funcall mover 1)
+	       (goto-char start2)
-	    (setq end1 (point))
+	       (insert word1)
-	    (funcall mover -1)
+	       (goto-char (if (< start1 start2) start1
-	    (setq start1 (point))
+			    (+ start1 (- (length word1) (length word2)))))
-	    (transpose-subr-1))
+	       (delete-char (length word1))
-	  (exchange-point-and-mark t))) ; XEmacs
+	       (insert word2))))
-(while (> arg 0)
+(if (= arg 0)
-(funcall mover -1)
+	  (progn
-(setq start1 (point))
+	    (save-excursion
-(funcall mover 1)
+	      (funcall mover 1)
-(setq end1 (point))
+	      (setq end2 (point))
-(funcall mover 1)
+	      (funcall mover -1)
-(setq end2 (point))
+	      (setq start2 (point))
-(funcall mover -1)
+	      (goto-char (mark t)) ; XEmacs
-(setq start2 (point))
+	      (funcall mover 1)
-(transpose-subr-1)
+	      (setq end1 (point))
-(goto-char end2)
+	      (funcall mover -1)
-(setq arg (1- arg)))
+	      (setq start1 (point))
-(while (< arg 0)
+	      (transpose-subr-1))
-(funcall mover -1)
+	    (exchange-point-and-mark t))) ; XEmacs
-(setq start2 (point))
+(while (> arg 0)
-(funcall mover -1)
+	(funcall mover -1)
-(setq start1 (point))
+	(setq start1 (point))
-(funcall mover 1)
+	(funcall mover 1)
-(setq end1 (point))
+	(setq end1 (point))
-(funcall mover 1)
+	(funcall mover 1)
-(setq end2 (point))
+	(setq end2 (point))
-(transpose-subr-1)
+	(funcall mover -1)
-(setq arg (1+ arg)))))
+	(setq start2 (point))
+	(transpose-subr-1)
-; start[12] and end[12] used free
+	(goto-char end2)
-(defun transpose-subr-1 ()
+	(setq arg (1- arg)))
-(if (> (min end1 end2) (max start1 start2))
+(while (< arg 0)
-(error "Don't have two things to transpose"))
+	(funcall mover -1)
-(let ((word1 (buffer-substring start1 end1))
+	(setq start2 (point))
-	(word2 (buffer-substring start2 end2)))
+	(funcall mover -1)
-(delete-region start2 end2)
+	(setq start1 (point))
-(goto-char start2)
+	(funcall mover 1)
-(insert word1)
+	(setq end1 (point))
-(goto-char (if (< start1 start2) start1
+	(funcall mover 1)
-		 (+ start1 (- (length word1) (length word2)))))
+	(setq end2 (point))
-(delete-char (length word1))
+	(transpose-subr-1)
-(insert word2)))
+	(setq arg (1+ arg))))))
 (defcustom comment-column 32
 "*Column to indent right-margin comments to.
 Setting this variable automatically makes it local to the current buffer.
 Each mode establishes a different default value for this variable; you
 		    (display-message 'no-log "Unmatched parenthesis"))))))))
 ;Turned off because it makes dbx bomb out.
 (setq blink-paren-function 'blink-matching-open)
-(eval-when-compile (defvar myhelp))	; suppress compiler warning
 ;; XEmacs: Some functions moved to cmdloop.el:
 ;; keyboard-quit
 ;; buffer-quit-function
 ;; keyboard-escape-quit
 	  (setq element (car alist)))
 (setq alist (cdr alist)))
 element))
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;                          mail composition code                        ;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (defcustom mail-user-agent 'sendmail-user-agent
 "*Your preference for a mail composition package.
 Various Emacs Lisp packages (e.g. reporter) require you to compose an
 outgoing email message.  This variable lets you specify which
 mail-sending package you prefer.
 (list nil nil nil current-prefix-arg))
 (compose-mail to subject other-headers continue
 		'switch-to-buffer-other-frame yank-action send-actions))
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;                             set variable                              ;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (defun set-variable (var val)
 "Set VARIABLE to VALUE.  VALUE is a Lisp object.
 When using this interactively, supply a Lisp expression for VALUE.
 If you want VALUE to be a string, you must surround it with doublequotes.
 If VARIABLE is a specifier, VALUE is added to it as an instantiator in
 it were the arg to `interactive' (which see) to interactively read the value."
 (interactive
 (let* ((var (read-variable "Set variable: "))
 	  ;; #### - yucky code replication here.  This should use something
 	  ;; from help.el or hyper-apropos.el
-	  (minibuffer-help-form
-	   '(funcall myhelp))
 	  (myhelp
 	   #'(lambda ()
 	      (with-output-to-temp-buffer "*Help*"
 		(prin1 var)
 		(princ "\nDocumentation:\n")
 		      (princ "\n\nCurrent value: ")
 		      (prin1 (symbol-value var))))
 		(save-excursion
 		  (set-buffer standard-output)
 		  (help-mode))
-		nil))))
+		nil)))
+	  (minibuffer-help-form
+	   '(funcall myhelp)))
 (list var
 	   (let ((prop (get var 'variable-interactive)))
 	     (if prop
 		 ;; Use VAR's `variable-interactive' property
 		 ;; as an interactive spec for prompting.
 					   'arg))
 	       (eval-minibuffer (format "Set %s to value: " var)))))))
 (if (and (boundp var) (specifierp (symbol-value var)))
 (set-specifier (symbol-value var) val)
 (set var val)))
-;; XEmacs
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defun activate-region ()
+;;                           case changing code                          ;;
-"Activate the region, if `zmacs-regions' is true.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-Setting `zmacs-regions' to true causes LISPM-style active regions to be used.
-This function has no effect if `zmacs-regions' is false."
-(interactive)
-(and zmacs-regions (zmacs-activate-region)))
-;; XEmacs
-(defsubst region-exists-p ()
-"Return t if the region exists.
-If active regions are in use (i.e. `zmacs-regions' is true), this means that
-the region is active.  Otherwise, this means that the user has pushed
-a mark in this buffer at some point in the past.
-The functions `region-beginning' and `region-end' can be used to find the
-limits of the region."
-(not (null (mark))))
-;; XEmacs
-(defun region-active-p ()
-"Return non-nil if the region is active.
-If `zmacs-regions' is true, this is equivalent to `region-exists-p'.
-Otherwise, this function always returns false."
-(and zmacs-regions zmacs-region-extent))
 ;; A bunch of stuff was moved elsewhere:
 ;; completion-list-mode-map
 ;; completion-reference-buffer
 ;; completion-base-size
 (interactive "p")
 (if (region-active-p)
 (downcase-region (region-beginning) (region-end))
 (downcase-word arg)))
+;; #### not localized
+(defvar uncapitalized-title-words
+'("the" "a" "an" "in" "of" "for" "to" "and" "but" "at" "on" "as" "by"))
+(defvar uncapitalized-title-word-regexp
+(concat "[ \t]*\\(" (mapconcat #'identity uncapitalized-title-words "\\|")
+	  "\\)\\>"))
+(defun capitalize-string-as-title (string)
+"Capitalize the words in the string, except for small words (as in titles).
+The words not capitalized are specified in `uncapitalized-title-words'."
+(let ((buffer (get-buffer-create " *capitalize-string-as-title*")))
+(unwind-protect
+	(progn
+	  (insert-string string buffer)
+	  (capitalize-region-as-title 1 (point-max buffer) buffer)
+	  (buffer-string buffer))
+(kill-buffer buffer))))
+(defun capitalize-region-as-title (b e &optional buffer)
+"Capitalize the words in the region, except for small words (as in titles).
+The words not capitalized are specified in `uncapitalized-title-words'."
+(interactive "r")
+(save-excursion
+(and buffer
+	 (set-buffer buffer))
+(save-restriction
+(narrow-to-region b e)
+(goto-char (point-min))
+(let ((first t))
+	(while (< (point) (point-max))
+	  (if (or first
+		  (not (looking-at uncapitalized-title-word-regexp)))
+	      (capitalize-word 1)
+	    (forward-word 1))
+	  (setq first nil))))))
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;                          zmacs active region code                     ;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Most of the zmacs code is now in elisp.  The only thing left in C
 ;; are the variables zmacs-regions, zmacs-region-active-p and
 ;; zmacs-region-stays plus the function zmacs_update_region which
 ;; simply calls the lisp level zmacs-update-region.  It must remain
 ;; for convenience, since it is called by core C code.
+;; XEmacs
+(defun activate-region ()
+"Activate the region, if `zmacs-regions' is true.
+Setting `zmacs-regions' to true causes LISPM-style active regions to be used.
+This function has no effect if `zmacs-regions' is false."
+(interactive)
+(and zmacs-regions (zmacs-activate-region)))
+;; XEmacs
+(defsubst region-exists-p ()
+"Return t if the region exists.
+If active regions are in use (i.e. `zmacs-regions' is true), this means that
+the region is active.  Otherwise, this means that the user has pushed
+a mark in this buffer at some point in the past.
+The functions `region-beginning' and `region-end' can be used to find the
+limits of the region."
+(not (null (mark))))
+;; XEmacs
+(defun region-active-p ()
+"Return non-nil if the region is active.
+If `zmacs-regions' is true, this is equivalent to `region-exists-p'.
+Otherwise, this function always returns false."
+(and zmacs-regions zmacs-region-extent))
 (defvar zmacs-activate-region-hook nil
 "Function or functions called when the region becomes active;
 see the variable `zmacs-regions'.")
 (when (marker-buffer (mark-marker t))
 (zmacs-make-extent-for-region (cons (point-marker t)
 					  (mark-marker t))))
 (run-hooks 'zmacs-update-region-hook)))
-;;;;;;
-;;;;;; echo area stuff
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;;;
+;;                           message logging code                        ;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; #### Should this be moved to a separate file, for clarity?
 ;;; -hniksic
 ;;; The `message-stack' is an alist of labels with messages; the first
 	(clear-message label nil))
 (let ((str (apply 'format fmt args)))
 (display-message label str)
 str)))
-;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;;; warning stuff
+;;                              warning code                             ;;
-;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (defcustom log-warning-minimum-level 'info
 "Minimum level of warnings that should be logged.
 The warnings in levels below this are completely ignored, as if they never
 happened.
 (when (or (not warning-marker)
 	      (not (eq (marker-buffer warning-marker) buffer)))
 (setq warning-marker (make-marker))
 (set-marker warning-marker 1 buffer))
 (if temp-buffer-show-function
-(let ((show-buffer (get-buffer-create "*Warnings-Show*")))
+(progn
-(save-excursion
+(funcall temp-buffer-show-function buffer)
-(set-buffer show-buffer)
+	  (mapc #'(lambda (win) (set-window-start win warning-marker))
-(setq buffer-read-only nil)
+		(windows-of-buffer buffer nil t)))
-(erase-buffer))
-(save-excursion
-(set-buffer buffer)
-(copy-to-buffer show-buffer
-(marker-position warning-marker)
-(point-max)))
-(funcall temp-buffer-show-function show-buffer))
 (set-window-start (display-buffer buffer) warning-marker))
 (set-marker warning-marker (point-max buffer) buffer)))
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;                                misc junk                              ;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (defun emacs-name ()
 "Return the printable name of this instance of Emacs."
 (cond ((featurep 'infodock) "InfoDock")
 	((featurep 'xemacs) "XEmacs")
 	(t "Emacs")))
+(defun debug-print (format &rest args)
+"Send a string to the debugging output.
+The string is formatted using (apply #'format FORMAT ARGS)."
+(princ (apply #'format format args) 'external-debugging-output))
 ;;; simple.el ends here

Mercurial > hg > xemacs-beta

comparison lisp/simple.el @ 442:abe6d1db359e r21-2-36