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   ;; If the gap intersects with the range we wanna grab, move it.
 135   (if (= start end)
 136       ""
 137     (progn
 138       (when (and (< start (buffer-gap-start buffer))
 139                  (< (buffer-gap-start buffer) end))
 140         (gap-move-to buffer start))
 141       (dformat +debug-v+ "substring: ~a ~a ~a~%" start end (length (buffer-data buffer)))
 142       (subseq (buffer-data buffer)
 143               (buffer-char-to-aref buffer start)
 144               (1+ (buffer-char-to-aref buffer (1- end)))))))
 145
 146 (defun buffer-substring (start end &optional (buffer (current-buffer)))
 147   "Return the contents of part of the current buffer as a string.
 148 The two arguments START and END are character positions;
 149 they can be in either order.
 150 The string returned is multibyte if the buffer is multibyte.
 151
 152 This function copies the text properties of that part of the buffer
 153 into the result string; if you don't want the text properties,
 154 use `buffer-substring-no-properties' instead."
 155   (multiple-value-setq (start end) (validate-region start end buffer))
 156   (make-buffer-string start end t buffer))
 157
 158 (defun buffer-substring-no-properties (start end &optional (buffer (current-buffer)))
 159   "Return the characters of part of the buffer, without the text properties.
 160 The two arguments START and END are character positions;
 161 they can be in either order."
 162   (multiple-value-setq (start end) (validate-region start end buffer))
 163   (make-buffer-string start end nil buffer))
 164
 165
 166 (defun field-string (pos)
 167   "Return the contents of the field surrounding POS as a string.
 168 A field is a region of text with the same `field' property.
 169 If POS is nil, the value of point is used for POS."
 170   (multiple-value-bind (beg end) (find-field pos nil :beg t :end t)
 171     (make-buffer-string beg end t)))
 172
 173 (defun field-beginning (&optional pos escape-from-edge limit)
 174   "Return the beginning of the field surrounding POS.
 175 A field is a region of text with the same `field' property.
 176 If POS is nil, the value of point is used for POS.
 177 If ESCAPE-FROM-EDGE is non-nil and POS is at the beginning of its
 178 field, then the beginning of the *previous* field is returned.
 179 If LIMIT is non-nil, it is a buffer position; if the beginning of the field
 180 is before LIMIT, then LIMIT will be returned instead."
 181   (multiple-value-bind (beg end) (find-field pos nil :beg-limit limit :beg t)
 182     beg))
 183
 184 (defun field-end (&optional pos escape-from-edge limit)
 185   "Return the end of the field surrounding POS.
 186 A field is a region of text with the same `field' property.
 187 If POS is nil, the value of point is used for POS.
 188 If ESCAPE-FROM-EDGE is non-nil and POS is at the end of its field,
 189 then the end of the *following* field is returned.
 190 If LIMIT is non-nil, it is a buffer position; if the end of the field
 191 is after LIMIT, then LIMIT will be returned instead."
 192   (multiple-value-bind (beg end) (find-field pos nil :end-limit limit :end t)
 193     end))
 194
 195 (defun npropertize (string &rest props)
 196   "Same as propertize but don't make a copy of STRING."
 197   (declare (type string string))
 198   (let ((ps (make-instance 'pstring
 199                            :data string)))
 200     (create-root-interval ps)
 201     (add-text-properties 0 (pstring-length ps) props ps)
 202     ps))
 203
 204 (defun propertize (string &rest props)
 205   "Return a copy of STRING with text properties added.
 206 First argument is the string to copy.
 207 Remaining arguments form a sequence of PROPERTY VALUE pairs for text
 208 properties to add to the result.
 209 usage: (propertize STRING &rest PROPERTIES)"
 210   (declare (type string string))
 211   (apply #'npropertize (copy-seq string) props))
 212
 213 (defun delete-region (start end &optional (buffer (current-buffer)))
 214   "Delete the text between point and mark.
 215
 216 expects two arguments, positions (integers or markers) specifying
 217 the stretch to be deleted."
 218   (multiple-value-setq (start end) (validate-region start end buffer))
 219   (buffer-delete buffer start (- end start)))
 220
 221 (defmacro save-current-buffer (&body body)
 222   "Save the current buffer; execute BODY; restore the current buffer.
 223 Executes BODY just like `progn'."
 224   (let ((cb (gensym "CB")))
 225     `(let ((,cb (current-buffer)))
 226        (unwind-protect (progn ,@body)
 227          (when (get-buffer ,cb)
 228            (set-buffer cb))))))
 229
 230 (defmacro save-excursion (&body body)
 231   "Save point, mark, and current buffer; execute BODY; restore those things.
 232 Executes BODY just like `progn'.
 233 The values of point, mark and the current buffer are restored
 234 even in case of abnormal exit (throw or error).
 235 *The state of activation of the mark is also restored.
 236
 237 *This construct does not save `deactivate-mark', and therefore
 238 *functions that change the buffer will still cause deactivation
 239 *of the mark at the end of the command.  To prevent that, bind
 240 *`deactivate-mark' with `let'."
 241   (let ((cb (gensym "CB"))
 242         (point (gensym "POINT"))
 243         (mark (gensym "MARK")))
 244     `(let ((,cb (current-buffer))
 245            (,point (copy-marker (point-marker)))
 246            (,mark (copy-marker (mark-marker))))
 247        (unwind-protect (progn ,@body)
 248          (when (get-buffer ,cb)
 249            (set-buffer ,cb)
 250            (setf (buffer-mark-marker ,cb) ,mark
 251                  (buffer-point ,cb) ,point))))))
 252
 253 (defun insert-buffer-substring (buffer start end)
 254   "Insert before point a substring of the contents of buffer.
 255 buffer may be a buffer or a buffer name.
 256 Arguments start and end are character positions specifying the substring.
 257 They default to the values of (point-min) and (point-max) in buffer."
 258   (let* ((buf (get-buffer buffer))
 259          (s (buffer-substring start end)))
 260     (with-current-buffer buf
 261       (insert s))))
 262
 263 (defun preceding-char ()
 264   "Return the character preceding point.
 265 At the beginning of the buffer or accessible region, return #\Nul."
 266   (or (char-before (point))
 267       #\Nul))
 268
 269 (defun bolp ()
 270   "Return t if point is at the beginning of a line."
 271   (or (= (point) (point-min))
 272       (char= (char-before (point)) #\Newline)))
 273
 274 (defun eolp ()
 275   "Return t if point is at the end of a line.
 276 `End of a line' includes point being at the end of the buffer."
 277   (or (= (point) (point-max))
 278       (char= (char-after (point)) #\Newline)))
 279
 280 (defun delete-and-extract-region (start end)
 281   "Delete the text between start and end and return it."
 282   (multiple-value-setq (start end) (validate-region start end))
 283   (if (= start end)
 284       ""
 285     (prog1
 286         (make-buffer-string start end t)
 287       (delete-region start end))))
 288
 289 (provide :lice-0.1/editfns)