editfns.lisp

   1 (in-package :lice)
   2
   3 (defun get-pos-property (position prop &optional (object (current-buffer)))
   4   "Return the value of property PROP, in OBJECT at POSITION.
   5 It's the value of PROP that a char inserted at POSITION would get.
   6 OBJECT is optional and defaults to the current buffer.
   7 If OBJECT is a buffer, then overlay properties are considered as well as
   8 text properties.
   9 If OBJECT is a window, then that window's buffer is used, but
  10 window-specific overlays are considered only if they are associated
  11 with OBJECT."
  12   (when (typep object 'window)
  13     (setf object (window-buffer object)))
  14   (if (not (typep object 'buffer))
  15       (get-text-property position prop object)
  16     ;;; XXX: handle overlays.
  17     (let ((stickiness (text-property-stickiness prop position object)))
  18       (cond
  19        ((eq stickiness 'after)
  20         (get-text-property position prop object))
  21        ((eq stickiness 'before)
  22         (get-text-property (1- position) prop object))
  23        (t nil)))))
  24
  25 (defun find-field (pos merge-at-boundary &key beg-limit beg end-limit end (buf (current-buffer)))
  26   "Find the field surrounding POS and return the beginning and end of
  27 the field in a values list.  If POS is nil, the value of point is used
  28 instead. If BEG or END is nil then that boundary isn't calculated.
  29
  30 BEG_LIMIT and END_LIMIT serve to limit the ranged of the returned
  31 results; they do not effect boundary behavior.
  32
  33 If MERGE_AT_BOUNDARY is nonzero, then if POS is at the very first
  34 position of a field, then the beginning of the previous field is
  35 returned instead of the beginning of POS's field (since the end of a
  36 field is actually also the beginning of the next input field, this
  37 behavior is sometimes useful).  Additionally in the MERGE_AT_BOUNDARY
  38 true case, if two fields are separated by a field with the special
  39 value `boundary', and POS lies within it, then the two separated
  40 fields are considered to be adjacent, and POS between them, when
  41 finding the beginning and ending of the \"merged\" field.
  42
  43 Either BEG or END may be 0, in which case the corresponding value
  44 is not stored."
  45   (let ((at-field-start nil)
  46         (at-field-end nil)
  47         before-field after-field)
  48     (unless pos
  49       (setf pos (point)))
  50     (setf after-field (get-char-property-and-overlay pos 'field buf nil)
  51           before-field (if (> pos (begv buf))
  52                            (get-char-property-and-overlay (1- pos) 'field buf nil)
  53                          nil))
  54     ;; See if we need to handle the case where MERGE_AT_BOUNDARY is nil
  55     ;; and POS is at beginning of a field, which can also be interpreted
  56     ;; as the end of the previous field.  Note that the case where if
  57     ;; MERGE_AT_BOUNDARY is non-nil (see function comment) is actually the
  58     ;; more natural one; then we avoid treating the beginning of a field
  59     ;; specially.
  60     (unless merge-at-boundary
  61       (let ((field (get-pos-property pos 'field buf)))
  62         (when (not (eq field after-field))
  63           (setf at-field-end t))
  64         (when (not (eq field before-field))
  65           (setf at-field-start t))
  66         (when (and (null field)
  67                    at-field-start
  68                    at-field-end)
  69           ;; If an inserted char would have a nil field while the surrounding
  70           ;; text is non-nil, we're probably not looking at a
  71           ;; zero-length field, but instead at a non-nil field that's
  72           ;; not intended for editing (such as comint's prompts).
  73           (setf at-field-end nil
  74                 at-field-start nil))))
  75     ;; Note about special `boundary' fields:
  76
  77     ;; Consider the case where the point (`.') is between the fields `x' and `y':
  78
  79     ;;  xxxx.yyyy
  80
  81     ;; In this situation, if merge_at_boundary is true, we consider the
  82     ;; `x' and `y' fields as forming one big merged field, and so the end
  83     ;; of the field is the end of `y'.
  84
  85     ;; However, if `x' and `y' are separated by a special `boundary' field
  86     ;; (a field with a `field' char-property of 'boundary), then we ignore
  87     ;; this special field when merging adjacent fields.  Here's the same
  88     ;; situation, but with a `boundary' field between the `x' and `y' fields:
  89
  90     ;;  xxx.BBBByyyy
  91
  92     ;; Here, if point is at the end of `x', the beginning of `y', or
  93     ;; anywhere in-between (within the `boundary' field), we merge all
  94     ;; three fields and consider the beginning as being the beginning of
  95     ;; the `x' field, and the end as being the end of the `y' field.  */
  96
  97     ;; Return field boundary
  98     (values (and beg
  99                  (if at-field-start
 100                      pos
 101                    (let ((p pos))
 102                      (if (and (null merge-at-boundary)
 103                               (eq before-field 'boundary))
 104                          (setf p (previous-single-char-property-change p 'field buf beg-limit))
 105                        (setf p (previous-single-char-property-change p 'field buf beg-limit)))
 106                      (or p
 107                          (begv buf)))))
 108             (and end
 109                  (if at-field-end
 110                      pos
 111                    (progn
 112                      (when (and (null merge-at-boundary)
 113                                 (eq after-field 'boundary))
 114                        (setf pos (next-single-char-property-change pos 'field buf end-limit)))
 115                      (setf pos (next-single-char-property-change pos 'field buf end-limit))
 116                      (or pos
 117                          (zv buf))))))))
 118
 119 (defun make-buffer-string (start end props &optional (buffer (current-buffer)))
 120   "Making strings from buffer contents.
 121
 122 Return a Lisp_String containing the text of the current buffer from
 123 START to END. If text properties are in use and the current buffer has
 124 properties in the range specified, the resulting string will also have
 125 them, if PROPS is nonzero.
 126
 127 We don't want to use plain old make_string here, because it calls
 128 make_uninit_string, which can cause the buffer arena to be
 129 compacted.  make_string has no way of knowing that the data has
 130 been moved, and thus copies the wrong data into the string.  This
 131 doesn't effect most of the other users of make_string, so it should
 132 be left as is.  But we should use this function when conjuring
 133 buffer substrings."
 134   (declare (ignore props))
 135   ;; If the gap intersects with the range we wanna grab, move it.
 136   (if (= start end)
 137       ""
 138     (progn
 139       (when (and (< start (buffer-gap-start buffer))
 140                  (< (buffer-gap-start buffer) end))
 141         (gap-move-to buffer start))
 142       (dformat +debug-v+ "substring: ~a ~a ~a~%" start end (length (buffer-data buffer)))
 143       (subseq (buffer-data buffer)
 144               (buffer-char-to-aref buffer start)
 145               (1+ (buffer-char-to-aref buffer (1- end)))))))
 146
 147 (defun buffer-substring (start end &optional (buffer (current-buffer)))
 148   "Return the contents of part of the current buffer as a string.
 149 The two arguments START and END are character positions;
 150 they can be in either order.
 151 The string returned is multibyte if the buffer is multibyte.
 152
 153 This function copies the text properties of that part of the buffer
 154 into the result string; if you don't want the text properties,
 155 use `buffer-substring-no-properties' instead."
 156   (multiple-value-setq (start end) (validate-region start end buffer))
 157   (make-buffer-string start end t buffer))
 158
 159 (defun buffer-substring-no-properties (start end &optional (buffer (current-buffer)))
 160   "Return the characters of part of the buffer, without the text properties.
 161 The two arguments START and END are character positions;
 162 they can be in either order."
 163   (multiple-value-setq (start end) (validate-region start end buffer))
 164   (make-buffer-string start end nil buffer))
 165
 166
 167 (defun field-string (pos)
 168   "Return the contents of the field surrounding POS as a string.
 169 A field is a region of text with the same `field' property.
 170 If POS is nil, the value of point is used for POS."
 171   (multiple-value-bind (beg end) (find-field pos nil :beg t :end t)
 172     (make-buffer-string beg end t)))
 173
 174 (defun field-beginning (&optional pos escape-from-edge limit)
 175   "Return the beginning of the field surrounding POS.
 176 A field is a region of text with the same `field' property.
 177 If POS is nil, the value of point is used for POS.
 178 If ESCAPE-FROM-EDGE is non-nil and POS is at the beginning of its
 179 field, then the beginning of the *previous* field is returned.
 180 If LIMIT is non-nil, it is a buffer position; if the beginning of the field
 181 is before LIMIT, then LIMIT will be returned instead."
 182     (declare (ignore escape-from-edge))
 183   (multiple-value-bind (beg end) (find-field pos nil :beg-limit limit :beg t)
 184     (declare (ignore end))
 185     beg))
 186
 187 (defun field-end (&optional pos escape-from-edge limit)
 188   "Return the end of the field surrounding POS.
 189 A field is a region of text with the same `field' property.
 190 If POS is nil, the value of point is used for POS.
 191 If ESCAPE-FROM-EDGE is non-nil and POS is at the end of its field,
 192 then the end of the *following* field is returned.
 193 If LIMIT is non-nil, it is a buffer position; if the end of the field
 194 is after LIMIT, then LIMIT will be returned instead."
 195   (declare (ignore escape-from-edge))
 196   (multiple-value-bind (beg end) (find-field pos nil :end-limit limit :end t)
 197     (declare (ignore beg))
 198     end))
 199
 200 (defun npropertize (string &rest props)
 201   "Same as propertize but don't make a copy of STRING."
 202   (declare (type string string))
 203   (let ((ps (make-instance 'pstring
 204                            :data string)))
 205     (create-root-interval ps)
 206     (add-text-properties 0 (pstring-length ps) props ps)
 207     ps))
 208
 209 (defun propertize (string &rest props)
 210   "Return a copy of STRING with text properties added.
 211 First argument is the string to copy.
 212 Remaining arguments form a sequence of PROPERTY VALUE pairs for text
 213 properties to add to the result.
 214 usage: (propertize STRING &rest PROPERTIES)"
 215   (declare (type string string))
 216   (apply #'npropertize (copy-seq string) props))
 217
 218 (defun delete-region (start end &optional (buffer (current-buffer)))
 219   "Delete the text between point and mark.
 220
 221 expects two arguments, positions (integers or markers) specifying
 222 the stretch to be deleted."
 223   (multiple-value-setq (start end) (validate-region start end buffer))
 224   (buffer-delete buffer start (- end start)))
 225
 226 (defmacro save-current-buffer (&body body)
 227   "Save the current buffer; execute BODY; restore the current buffer.
 228 Executes BODY just like `progn'."
 229   (let ((cb (gensym "CB")))
 230     `(let ((,cb (current-buffer)))
 231        (unwind-protect (progn ,@body)
 232          (when (get-buffer ,cb)
 233            (set-buffer cb))))))
 234
 235 (defmacro save-excursion (&body body)
 236   "Save point, mark, and current buffer; execute BODY; restore those things.
 237 Executes BODY just like `progn'.
 238 The values of point, mark and the current buffer are restored
 239 even in case of abnormal exit (throw or error).
 240 *The state of activation of the mark is also restored.
 241
 242 *This construct does not save `deactivate-mark', and therefore
 243 *functions that change the buffer will still cause deactivation
 244 *of the mark at the end of the command.  To prevent that, bind
 245 *`deactivate-mark' with `let'."
 246   (let ((cb (gensym "CB"))
 247         (point (gensym "POINT"))
 248         (mark (gensym "MARK")))
 249     `(let ((,cb (current-buffer))
 250            (,point (copy-marker (point-marker)))
 251            (,mark (copy-marker (mark-marker))))
 252        (unwind-protect (progn ,@body)
 253          (when (get-buffer ,cb)
 254            (set-buffer ,cb)
 255            (setf (buffer-mark-marker ,cb) ,mark
 256                  (buffer-point ,cb) ,point))))))
 257
 258 (defun insert-buffer-substring (buffer start end)
 259   "Insert before point a substring of the contents of buffer.
 260 buffer may be a buffer or a buffer name.
 261 Arguments start and end are character positions specifying the substring.
 262 They default to the values of (point-min) and (point-max) in buffer."
 263   (let* ((buf (get-buffer buffer))
 264          (s (buffer-substring start end)))
 265     (with-current-buffer buf
 266       (insert s))))
 267
 268 (defun preceding-char ()
 269   "Return the character preceding point.
 270 At the beginning of the buffer or accessible region, return #\Nul."
 271   (or (char-before (point))
 272       #\Nul))
 273
 274 (defun bolp ()
 275   "Return t if point is at the beginning of a line."
 276   (or (= (point) (point-min))
 277       (char= (char-before (point)) #\Newline)))
 278
 279 (defun eolp ()
 280   "Return t if point is at the end of a line.
 281 `End of a line' includes point being at the end of the buffer."
 282   (or (= (point) (point-max))
 283       (char= (char-after (point)) #\Newline)))
 284
 285 (defun delete-and-extract-region (start end)
 286   "Delete the text between start and end and return it."
 287   (multiple-value-setq (start end) (validate-region start end))
 288   (if (= start end)
 289       ""
 290     (prog1
 291         (make-buffer-string start end t)
 292       (delete-region start end))))
 293
 294 (provide :lice-0.1/editfns)