editfns.lisp

   1 (in-package :lice)
   2
   3 (defvar *inhibit-field-text-motion* nil
   4   "Non-nil means text motion commands don't notice fields.")
   5
   6 (defvar *buffer-access-fontify-functions* nil
   7 "List of functions called by `buffer-substring' to fontify if necessary.
   8 Each function is called with two arguments which specify the range
   9 of the buffer being accessed.")
  10
  11 (defvar *buffer-access-fontified-property* nil
  12 "Property which (if non-nil) indicates text has been fontified.
  13 `buffer-substring' need not call the `buffer-access-fontify-functions'
  14 functions if all the text being accessed has this property.")
  15
  16 (defvar *system-name* nil
  17   "The host name of the machine Emacs is running on.")
  18
  19 (defvar *user-full-name* nil
  20   "The full name of the user logged in.")
  21
  22 (defvar *user-login-name* nil
  23   "The user's name, taken from environment variables if possible.")
  24
  25 (defvar *user-real-login-name* nil
  26   "The user's name, based upon the real uid only.")
  27
  28 (defvar *operating-system-release* nil
  29   "The release of the operating system Emacs is running on.")
  30
  31 (defun get-pos-property (position prop &optional (object (current-buffer)))
  32   "Return the value of property PROP, in OBJECT at POSITION.
  33 It's the value of PROP that a char inserted at POSITION would get.
  34 OBJECT is optional and defaults to the current buffer.
  35 If OBJECT is a buffer, then overlay properties are considered as well as
  36 text properties.
  37 If OBJECT is a window, then that window's buffer is used, but
  38 window-specific overlays are considered only if they are associated
  39 with OBJECT."
  40   (when (typep object 'window)
  41     (setf object (window-buffer object)))
  42   (if (not (typep object 'buffer))
  43       (get-text-property position prop object)
  44     ;;; XXX: handle overlays.
  45     (let ((stickiness (text-property-stickiness prop position object)))
  46       (cond
  47        ((eq stickiness 'after)
  48         (get-text-property position prop object))
  49        ((eq stickiness 'before)
  50         (get-text-property (1- position) prop object))
  51        (t nil)))))
  52
  53 (defun find-field (pos merge-at-boundary &key beg-limit beg end-limit end (buf (current-buffer)))
  54   "Find the field surrounding POS and return the beginning and end of
  55 the field in a values list.  If POS is nil, the value of point is used
  56 instead. If BEG or END is nil then that boundary isn't calculated.
  57
  58 BEG_LIMIT and END_LIMIT serve to limit the ranged of the returned
  59 results; they do not effect boundary behavior.
  60
  61 If MERGE_AT_BOUNDARY is nonzero, then if POS is at the very first
  62 position of a field, then the beginning of the previous field is
  63 returned instead of the beginning of POS's field (since the end of a
  64 field is actually also the beginning of the next input field, this
  65 behavior is sometimes useful).  Additionally in the MERGE_AT_BOUNDARY
  66 true case, if two fields are separated by a field with the special
  67 value `boundary', and POS lies within it, then the two separated
  68 fields are considered to be adjacent, and POS between them, when
  69 finding the beginning and ending of the \"merged\" field.
  70
  71 Either BEG or END may be 0, in which case the corresponding value
  72 is not stored."
  73   (let ((at-field-start nil)
  74         (at-field-end nil)
  75         before-field after-field)
  76     (unless pos
  77       (setf pos (point)))
  78     (setf after-field (get-char-property-and-overlay pos 'field buf nil)
  79           before-field (if (> pos (begv buf))
  80                            (get-char-property-and-overlay (1- pos) 'field buf nil)
  81                          nil))
  82     ;; See if we need to handle the case where MERGE_AT_BOUNDARY is nil
  83     ;; and POS is at beginning of a field, which can also be interpreted
  84     ;; as the end of the previous field.  Note that the case where if
  85     ;; MERGE_AT_BOUNDARY is non-nil (see function comment) is actually the
  86     ;; more natural one; then we avoid treating the beginning of a field
  87     ;; specially.
  88     (unless merge-at-boundary
  89       (let ((field (get-pos-property pos 'field buf)))
  90         (when (not (eq field after-field))
  91           (setf at-field-end t))
  92         (when (not (eq field before-field))
  93           (setf at-field-start t))
  94         (when (and (null field)
  95                    at-field-start
  96                    at-field-end)
  97           ;; If an inserted char would have a nil field while the surrounding
  98           ;; text is non-nil, we're probably not looking at a
  99           ;; zero-length field, but instead at a non-nil field that's
 100           ;; not intended for editing (such as comint's prompts).
 101           (setf at-field-end nil
 102                 at-field-start nil))))
 103     ;; Note about special `boundary' fields:
 104
 105     ;; Consider the case where the point (`.') is between the fields `x' and `y':
 106
 107     ;;  xxxx.yyyy
 108
 109     ;; In this situation, if merge_at_boundary is true, we consider the
 110     ;; `x' and `y' fields as forming one big merged field, and so the end
 111     ;; of the field is the end of `y'.
 112
 113     ;; However, if `x' and `y' are separated by a special `boundary' field
 114     ;; (a field with a `field' char-property of 'boundary), then we ignore
 115     ;; this special field when merging adjacent fields.  Here's the same
 116     ;; situation, but with a `boundary' field between the `x' and `y' fields:
 117
 118     ;;  xxx.BBBByyyy
 119
 120     ;; Here, if point is at the end of `x', the beginning of `y', or
 121     ;; anywhere in-between (within the `boundary' field), we merge all
 122     ;; three fields and consider the beginning as being the beginning of
 123     ;; the `x' field, and the end as being the end of the `y' field.  */
 124
 125     ;; Return field boundary
 126     (values (and beg
 127                  (if at-field-start
 128                      pos
 129                    (let ((p pos))
 130                      (if (and (null merge-at-boundary)
 131                               (eq before-field 'boundary))
 132                          (setf p (previous-single-char-property-change p 'field buf beg-limit))
 133                        (setf p (previous-single-char-property-change p 'field buf beg-limit)))
 134                      (or p
 135                          (begv buf)))))
 136             (and end
 137                  (if at-field-end
 138                      pos
 139                    (progn
 140                      (when (and (null merge-at-boundary)
 141                                 (eq after-field 'boundary))
 142                        (setf pos (next-single-char-property-change pos 'field buf end-limit)))
 143                      (setf pos (next-single-char-property-change pos 'field buf end-limit))
 144                      (or pos
 145                          (zv buf))))))))
 146
 147 (defun make-buffer-string (start end props &optional (buffer (current-buffer)))
 148   "Making strings from buffer contents.
 149
 150 Return a Lisp_String containing the text of the current buffer from
 151 START to END. If text properties are in use and the current buffer has
 152 properties in the range specified, the resulting string will also have
 153 them, if PROPS is nonzero.
 154
 155 We don't want to use plain old make_string here, because it calls
 156 make_uninit_string, which can cause the buffer arena to be
 157 compacted.  make_string has no way of knowing that the data has
 158 been moved, and thus copies the wrong data into the string.  This
 159 doesn't effect most of the other users of make_string, so it should
 160 be left as is.  But we should use this function when conjuring
 161 buffer substrings."
 162   (declare (ignore props))
 163   ;; If the gap intersects with the range we wanna grab, move it.
 164   (if (= start end)
 165       ""
 166     (progn
 167       (when (and (< start (buffer-gap-start buffer))
 168                  (< (buffer-gap-start buffer) end))
 169         (gap-move-to buffer start))
 170       (dformat +debug-v+ "substring: ~a ~a ~a~%" start end (length (buffer-data buffer)))
 171       (subseq (buffer-data buffer)
 172               (buffer-char-to-aref buffer start)
 173               (1+ (buffer-char-to-aref buffer (1- end)))))))
 174
 175 (defun buffer-substring (start end &optional (buffer (current-buffer)))
 176   "Return the contents of part of the current buffer as a string.
 177 The two arguments START and END are character positions;
 178 they can be in either order.
 179 The string returned is multibyte if the buffer is multibyte.
 180
 181 This function copies the text properties of that part of the buffer
 182 into the result string; if you don't want the text properties,
 183 use `buffer-substring-no-properties' instead."
 184   (multiple-value-setq (start end) (validate-region start end buffer))
 185   (make-buffer-string start end t buffer))
 186
 187 (defun buffer-substring-no-properties (start end &optional (buffer (current-buffer)))
 188   "Return the characters of part of the buffer, without the text properties.
 189 The two arguments START and END are character positions;
 190 they can be in either order."
 191   (multiple-value-setq (start end) (validate-region start end buffer))
 192   (make-buffer-string start end nil buffer))
 193
 194
 195 (defun field-string (pos)
 196   "Return the contents of the field surrounding POS as a string.
 197 A field is a region of text with the same `field' property.
 198 If POS is nil, the value of point is used for POS."
 199   (multiple-value-bind (beg end) (find-field pos nil :beg t :end t)
 200     (make-buffer-string beg end t)))
 201
 202 (defun field-beginning (&optional pos escape-from-edge limit)
 203   "Return the beginning of the field surrounding POS.
 204 A field is a region of text with the same `field' property.
 205 If POS is nil, the value of point is used for POS.
 206 If ESCAPE-FROM-EDGE is non-nil and POS is at the beginning of its
 207 field, then the beginning of the *previous* field is returned.
 208 If LIMIT is non-nil, it is a buffer position; if the beginning of the field
 209 is before LIMIT, then LIMIT will be returned instead."
 210     (declare (ignore escape-from-edge))
 211   (multiple-value-bind (beg end) (find-field pos nil :beg-limit limit :beg t)
 212     (declare (ignore end))
 213     beg))
 214
 215 (defun field-end (&optional pos escape-from-edge limit)
 216   "Return the end of the field surrounding POS.
 217 A field is a region of text with the same `field' property.
 218 If POS is nil, the value of point is used for POS.
 219 If ESCAPE-FROM-EDGE is non-nil and POS is at the end of its field,
 220 then the end of the *following* field is returned.
 221 If LIMIT is non-nil, it is a buffer position; if the end of the field
 222 is after LIMIT, then LIMIT will be returned instead."
 223   (declare (ignore escape-from-edge))
 224   (multiple-value-bind (beg end) (find-field pos nil :end-limit limit :end t)
 225     (declare (ignore beg))
 226     end))
 227
 228 (defun constrain-to-field (new-pos old-pos &optional escape-from-edge only-in-line inhibit-capture-property)
 229   "Return the position closest to NEW-POS that is in the same field as OLD-POS.
 230
 231 A field is a region of text with the same `field' property.
 232 If NEW-POS is nil, then the current point is used instead, and set to the
 233 constrained position if that is different.
 234
 235 If OLD-POS is at the boundary of two fields, then the allowable
 236 positions for NEW-POS depends on the value of the optional argument
 237 ESCAPE-FROM-EDGE: If ESCAPE-FROM-EDGE is nil, then NEW-POS is
 238 constrained to the field that has the same `field' char-property
 239 as any new characters inserted at OLD-POS, whereas if ESCAPE-FROM-EDGE
 240 is non-nil, NEW-POS is constrained to the union of the two adjacent
 241 fields.  Additionally, if two fields are separated by another field with
 242 the special value `boundary', then any point within this special field is
 243 also considered to be `on the boundary'.
 244
 245 If the optional argument ONLY-IN-LINE is non-nil and constraining
 246 NEW-POS would move it to a different line, NEW-POS is returned
 247 unconstrained.  This useful for commands that move by line, like
 248 \\[next-line] or \\[beginning-of-line], which should generally respect field boundaries
 249 only in the case where they can still move to the right line.
 250
 251 If the optional argument INHIBIT-CAPTURE-PROPERTY is non-nil, and OLD-POS has
 252 a non-nil property of that name, then any field boundaries are ignored.
 253
 254 Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil."
 255   (let ((orig-point 0)
 256         fwd prev-old prev-new)
 257     (unless new-pos
 258       ;; Use the current point, and afterwards, set it.
 259       (setf new-pos (point)
 260             orig-point new-pos))
 261     (check-type new-pos number)
 262     (check-type old-pos number)
 263     (setf fwd (> new-pos old-pos)
 264           prev-old (1- old-pos)
 265           prev-new (1- new-pos))
 266     (when (and (null *inhibit-field-text-motion*)
 267                (/= new-pos old-pos)
 268                (or (get-char-property new-pos 'field)
 269                    (get-char-property old-pos 'field)
 270                    ;; To recognize field boundaries, we must also look at the
 271                    ;; previous positions; we could use `get_pos_property'
 272                    ;; instead, but in itself that would fail inside non-sticky
 273                    ;; fields (like comint prompts).
 274                    (and (> new-pos (begv))
 275                         (get-char-property prev-new 'field))
 276                    (and (> old-pos (begv))
 277                         (get-char-property prev-old 'field)))
 278                (or (null inhibit-capture-property)
 279                    (and (null (get-pos-property old-pos inhibit-capture-property nil))
 280                         (or (<= old-pos (begv))
 281                             (null (get-char-property old-pos inhibit-capture-property))
 282                             (null (get-char-property prev-old inhibit-capture-property))))))
 283       ;; It is possible that NEW_POS is not within the same field as
 284       ;; OLD_POS; try to move NEW_POS so that it is.
 285       (let ((field-bound (if fwd
 286                              (field-end old-pos escape-from-edge new-pos)
 287                              (field-beginning old-pos escape-from-edge new-pos))))
 288         (when (and
 289                ;; See if ESCAPE_FROM_EDGE caused FIELD_BOUND to jump to the
 290                ;; other side of NEW_POS, which would mean that NEW_POS is
 291                ;; already acceptable, and it's not necessary to constrain it
 292                ;; to FIELD_BOUND.
 293                (if (< field-bound new-pos) fwd (not fwd))
 294                ;; NEW_POS should be constrained, but only if either
 295                ;; ONLY_IN_LINE is nil (in which case any constraint is OK),
 296                ;; or NEW_POS and FIELD_BOUND are on the same line (in which
 297                ;; case the constraint is OK even if ONLY_IN_LINE is non-nil). */
 298                (or (null only-in-line)
 299                    ;; This is the ONLY_IN_LINE case, check that NEW_POS and
 300                    ;; FIELD_BOUND are on the same line by seeing whether
 301                    ;; there's an intervening newline or not.
 302                    (progn
 303                      (multiple-value-bind (p nfound)
 304                          (buffer-scan-newline (current-buffer) new-pos field-bound (if fwd -1 1))
 305                        (declare (ignore p))
 306                        (zerop nfound)))))
 307           ;; Constrain NEW_POS to FIELD_BOUND.
 308           (setf new-pos field-bound))
 309         (when (and orig-point
 310                    (/= new-pos orig-point))
 311           (set-point new-pos))))
 312     new-pos))
 313
 314 (defun npropertize (string &rest props)
 315   "Same as propertize but don't make a copy of STRING."
 316   (declare (type string string))
 317   (let ((ps (make-instance 'pstring
 318                            :data string)))
 319     (create-root-interval ps)
 320     (add-text-properties 0 (pstring-length ps) props ps)
 321     ps))
 322
 323 (defun propertize (string &rest props)
 324   "Return a copy of STRING with text properties added.
 325 First argument is the string to copy.
 326 Remaining arguments form a sequence of PROPERTY VALUE pairs for text
 327 properties to add to the result.
 328 usage: (propertize STRING &rest PROPERTIES)"
 329   (declare (type string string))
 330   (apply #'npropertize (copy-seq string) props))
 331
 332 (defun delete-region (start end &optional (buffer (current-buffer)))
 333   "Delete the text between point and mark.
 334
 335 expects two arguments, positions (integers or markers) specifying
 336 the stretch to be deleted."
 337   (multiple-value-setq (start end) (validate-region start end buffer))
 338   (buffer-delete buffer start (- end start)))
 339
 340 (defmacro save-current-buffer (&body body)
 341   "Save the current buffer; execute BODY; restore the current buffer.
 342 Executes BODY just like `progn'."
 343   (let ((cb (gensym "CB")))
 344     `(let ((,cb (current-buffer)))
 345        (unwind-protect (progn ,@body)
 346          (when (get-buffer ,cb)
 347            (set-buffer cb))))))
 348
 349 (defmacro save-excursion (&body body)
 350   "Save point, mark, and current buffer; execute BODY; restore those things.
 351 Executes BODY just like `progn'.
 352 The values of point, mark and the current buffer are restored
 353 even in case of abnormal exit (throw or error).
 354 *The state of activation of the mark is also restored.
 355
 356 *This construct does not save `deactivate-mark', and therefore
 357 *functions that change the buffer will still cause deactivation
 358 *of the mark at the end of the command.  To prevent that, bind
 359 *`deactivate-mark' with `let'."
 360   (let ((cb (gensym "CB"))
 361         (point (gensym "POINT"))
 362         (mark (gensym "MARK")))
 363     `(let ((,cb (current-buffer))
 364            (,point (copy-marker (point-marker)))
 365            (,mark (copy-marker (mark-marker))))
 366        (unwind-protect (progn ,@body)
 367          (when (get-buffer ,cb)
 368            (set-buffer ,cb)
 369            (setf (buffer-mark-marker ,cb) ,mark
 370                  (buffer-point ,cb) ,point))))))
 371
 372 (defun insert-buffer-substring (buffer start end)
 373   "Insert before point a substring of the contents of buffer.
 374 buffer may be a buffer or a buffer name.
 375 Arguments start and end are character positions specifying the substring.
 376 They default to the values of (point-min) and (point-max) in buffer."
 377   (let* ((buf (get-buffer buffer))
 378          (s (buffer-substring start end)))
 379     (with-current-buffer buf
 380       (insert s))))
 381
 382 (defun preceding-char ()
 383   "Return the character preceding point.
 384 At the beginning of the buffer or accessible region, return #\Nul."
 385   (or (char-before (point))
 386       #\Nul))
 387
 388 (defun following-char ()
 389   "Return the character following point, as a number.
 390 At the end of the buffer or accessible region, return #\Nul."
 391   (if (>= (point) (zv))
 392       #\Nul ; XXX return nil?
 393       (buffer-fetch-char (buffer-char-to-aref (current-buffer) (point))
 394                          (current-buffer))))
 395
 396 (defun bolp ()
 397   "Return t if point is at the beginning of a line."
 398   (or (= (point) (point-min))
 399       (char= (char-before (point)) #\Newline)))
 400
 401 (defun eolp ()
 402   "Return t if point is at the end of a line.
 403 `End of a line' includes point being at the end of the buffer."
 404   (or (= (point) (point-max))
 405       (char= (char-after (point)) #\Newline)))
 406
 407 (defun delete-and-extract-region (start end)
 408   "Delete the text between start and end and return it."
 409   (multiple-value-setq (start end) (validate-region start end))
 410   (if (= start end)
 411       ""
 412     (prog1
 413         (make-buffer-string start end t)
 414       (delete-region start end))))
 415
 416 (defun insert-char (character count &optional inherit)
 417   "Insert COUNT copies of CHARACTER.
 418 Point, and before-insertion markers, are relocated as in the function `insert'.
 419 **The optional third arg INHERIT, if non-nil, says to inherit text properties
 420 **from adjoining text, if those properties are sticky."
 421   (declare (ignore inherit))
 422   (check-type character character)
 423   (check-type count number)
 424   (unless (< count 0)
 425     (dotimes (i count)
 426       (insert character))))
 427
 428 (defun line-beginning-position (n)
 429   "Return the character position of the first character on the current line.
 430 With argument N not nil or 1, move forward N - 1 lines first.
 431 If scan reaches end of buffer, return that position.
 432
 433 This function constrains the returned position to the current field
 434 unless that would be on a different line than the original,
 435 unconstrained result.  If N is nil or 1, and a front-sticky field
 436 starts at point, the scan stops as soon as it starts.  To ignore field
 437 boundaries bind `inhibit-field-text-motion' to t.
 438
 439 This function does not move point."
 440   ;; FIXME: inhibit-point-motion-hooks
 441   (let ((pt (save-excursion
 442               (forward-line (if n (1- n) 0))
 443               (point))))
 444     (constrain-to-field pt (point) (not (eql n 1)) t nil)))
 445
 446 (defun line-end-position (&optional (n 1))
 447   "Return the character position of the last character on the current line.
 448 With argument N not nil or 1, move forward N - 1 lines first.
 449 If scan reaches end of buffer, return that position.
 450
 451 This function constrains the returned position to the current field
 452 unless that would be on a different line than the original,
 453 unconstrained result.  If N is nil or 1, and a rear-sticky field ends
 454 at point, the scan stops as soon as it starts.  To ignore field
 455 boundaries bind `inhibit-field-text-motion' to t.
 456
 457 This function does not move point."
 458   (check-type n integer)
 459   (setf n (- n (if (<= n 0) 1 0)))
 460   (let* ((orig (point))
 461          (end-pos (find-before-next-newline orig nil n)))
 462     (constrain-to-field end-pos orig nil t nil)))
 463
 464 (defun clip-to-bounds (lower num upper)
 465   (max (min num upper) lower))
 466
 467 (defun string-to-char ()
 468   (error "Unimplemented"))
 469
 470 (defun char-to-string ()
 471   (error "Unimplemented"))
 472
 473 (defun buffer-string ()
 474   (error "Unimplemented"))
 475
 476 (defun field-string-no-properties ()
 477   (error "Unimplemented"))
 478
 479 (defun delete-field ()
 480   (error "Unimplemented"))
 481
 482 (defmacro save-current-buffer ()
 483   (error "Unimplemented"))
 484
 485 (defun bufsize ()
 486   (error "Unimplemented"))
 487
 488 (defun point-min-marker ()
 489   (error "Unimplemented"))
 490
 491 (defun point-max-marker ()
 492   (error "Unimplemented"))
 493
 494 (defun gap-position ()
 495   (error "Unimplemented"))
 496
 497 (defun gap-size ()
 498   (error "Unimplemented"))
 499
 500 (defun position-bytes ()
 501   (error "Unimplemented"))
 502
 503 (defun byte-to-position ()
 504   (error "Unimplemented"))
 505
 506 (defun previous-char ()
 507   (error "Unimplemented"))
 508
 509 (defun insert-before-markers ()
 510   (error "Unimplemented"))
 511
 512 (defun insert-and-inherit ()
 513   (error "Unimplemented"))
 514
 515 (defun insert-and-inherit-before-markers ()
 516   (error "Unimplemented"))
 517
 518 (defun user-login-name ()
 519   (error "Unimplemented"))
 520
 521 (defun user-real-login-name ()
 522   (error "Unimplemented"))
 523
 524 (defun user-uid ()
 525   (error "Unimplemented"))
 526
 527 (defun user-real-uid ()
 528   (error "Unimplemented"))
 529
 530 (defun user-full-name ()
 531   (error "Unimplemented"))
 532
 533 (defun emacs-pid ()
 534   (error "Unimplemented"))
 535
 536 (defun current-time ()
 537   (error "Unimplemented"))
 538
 539 (defun format-time-string ()
 540   (error "Unimplemented"))
 541
 542 (defun float-time ()
 543   (error "Unimplemented"))
 544
 545 (defun decode-time ()
 546   (error "Unimplemented"))
 547
 548 (defun encode-time ()
 549   (error "Unimplemented"))
 550
 551 (defun current-time-string ()
 552   (error "Unimplemented"))
 553
 554 (defun current-time-zone ()
 555   (error "Unimplemented"))
 556
 557 (defun set-time-zone-rule ()
 558   (error "Unimplemented"))
 559
 560 (defun system-name ()
 561   (error "Unimplemented"))
 562
 563 (defun message-box ()
 564   (error "Unimplemented"))
 565
 566 (defun message-or-box ()
 567   (error "Unimplemented"))
 568
 569 (defun current-message ()
 570   (error "Unimplemented"))
 571
 572 (defun compare-buffer-substrings ()
 573   (error "Unimplemented"))
 574
 575 (defun subst-char-in-region ()
 576   (error "Unimplemented"))
 577
 578 (defun translate-region-internal ()
 579   (error "Unimplemented"))
 580
 581 (defun widen ()
 582   (error "Unimplemented"))
 583
 584 (defun narrow-to-region ()
 585   (error "Unimplemented"))
 586
 587 (defun save-restriction ()
 588   (error "Unimplemented"))
 589
 590 (defun transpose-regions ()
 591   (error "Unimplemented"))
 592
 593 (provide :lice-0.1/editfns)