Mercurial > hg > xemacs-beta

comparison lisp/vm/vm-misc.el @ 54:05472e90ae02 r19-16-pre2

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-16-pre2
author cvs
date Mon, 13 Aug 2007 08:57:55 +0200
parents c53a95d3c46d
children 131b0175ea99
comparison
equal deleted inserted replaced
53:875393c1a535 54:05472e90ae02
90 (not (string= s ""))) 90 (not (string= s "")))
91 (setq list (cons s list))) 91 (setq list (cons s list)))
92 (nreverse list)) ; jwz: fixed order 92 (nreverse list)) ; jwz: fixed order
93 (and work-buffer (kill-buffer work-buffer))))))) 93 (and work-buffer (kill-buffer work-buffer)))))))
94 94
95 (defun vm-parse-structured-header (string &optional sepchar keep-quotes)
96 (if (null string)
97 ()
98 (let ((work-buffer nil))
99 (save-excursion
100 (unwind-protect
101 (let ((list nil)
102 (nonspecials "^\"\\( \t\n\r\f")
103 start s char sp+sepchar)
104 (if sepchar
105 (setq nonspecials (concat nonspecials (list sepchar))
106 sp+sepchar (concat "\t\f\n\r " (list sepchar))))
107 (setq work-buffer (generate-new-buffer "*vm-work*"))
108 (buffer-disable-undo work-buffer)
109 (set-buffer work-buffer)
110 (insert string)
111 (goto-char (point-min))
112 (skip-chars-forward "\t\f\n\r ")
113 (setq start (point))
114 (while (not (eobp))
115 (skip-chars-forward nonspecials)
116 (setq char (following-char))
117 (cond ((looking-at "[ \t\n\r\f]")
118 (delete-char 1))
119 ((= char ?\\)
120 (forward-char 1)
121 (if (not (eobp))
122 (forward-char 1)))
123 ((and sepchar (= char sepchar))
124 (setq s (buffer-substring start (point)))
125 (if (or (null (string-match "^[\t\f\n\r ]+$" s))
126 (not (string= s "")))
127 (setq list (cons s list)))
128 (skip-chars-forward sp+sepchar)
129 (setq start (point)))
130 ((looking-at " \t\n\r\f")
131 (skip-chars-forward " \t\n\r\f"))
132 ((= char ?\")
133 (let ((done nil))
134 (if keep-quotes
135 (forward-char 1)
136 (delete-char 1))
137 (while (not done)
138 (if (null (re-search-forward "[\\\"]" nil t))
139 (setq done t)
140 (setq char (char-after (1- (point))))
141 (cond ((char-equal char ?\\)
142 (delete-char -1)
143 (if (eobp)
144 (setq done t)
145 (forward-char 1)))
146 (t (if (not keep-quotes)
147 (delete-char -1))
148 (setq done t)))))))
149 ((= char ?\()
150 (let ((done nil)
151 (pos (point))
152 (parens 1))
153 (forward-char 1)
154 (while (not done)
155 (if (null (re-search-forward "[\\()]" nil t))
156 (setq done t)
157 (setq char (char-after (1- (point))))
158 (cond ((char-equal char ?\\)
159 (if (eobp)
160 (setq done t)
161 (forward-char 1)))
162 ((char-equal char ?\()
163 (setq parens (1+ parens)))
164 (t
165 (setq parens (1- parens)
166 done (zerop parens))))))
167 (delete-region pos (point))))))
168 (setq s (buffer-substring start (point)))
169 (if (and (null (string-match "^[\t\f\n\r ]+$" s))
170 (not (string= s "")))
171 (setq list (cons s list)))
172 (nreverse list))
173 (and work-buffer (kill-buffer work-buffer)))))))
174
95 (defun vm-write-string (where string) 175 (defun vm-write-string (where string)
96 (if (bufferp where) 176 (if (bufferp where)
97 (vm-save-buffer-excursion 177 (vm-save-buffer-excursion
98 (set-buffer where) 178 (set-buffer where)
99 (goto-char (point-max)) 179 (goto-char (point-max))
106 (insert string) 186 (insert string)
107 ;; correct for VM's uses of this function--- 187 ;; correct for VM's uses of this function---
108 ;; writing out message separators 188 ;; writing out message separators
109 (setq buffer-file-type nil) 189 (setq buffer-file-type nil)
110 ;; Tell XEmacs/MULE to pick the correct newline conversion. 190 ;; Tell XEmacs/MULE to pick the correct newline conversion.
111 (and (vm-xemacs-mule-p) 191 (and vm-xemacs-mule-p
112 (set-file-coding-system 'no-conversion nil)) 192 (set-file-coding-system 'no-conversion nil))
113 (write-region (point-min) (point-max) where t 'quiet)) 193 (write-region (point-min) (point-max) where t 'quiet))
114 (and temp-buffer (kill-buffer temp-buffer)))))) 194 (and temp-buffer (kill-buffer temp-buffer))))))
115 195
116 (defmacro vm-marker (pos &optional buffer) 196 (defmacro vm-marker (pos &optional buffer)
341 ((vectorp object) (apply 'vector (mapcar 'vm-copy object))) 421 ((vectorp object) (apply 'vector (mapcar 'vm-copy object)))
342 ((stringp object) (copy-sequence object)) 422 ((stringp object) (copy-sequence object))
343 ((markerp object) (copy-marker object)) 423 ((markerp object) (copy-marker object))
344 (t object))) 424 (t object)))
345 425
346 (defun vm-xemacs-p () 426 (defun vm-multiple-frames-possible-p ()
347 (let ((case-fold-search nil)) 427 (cond (vm-xemacs-p
348 (string-match "XEmacs" emacs-version))) 428 (or (memq 'win (device-matching-specifier-tag-list))
349 429 (featurep 'tty-frames)))
350 (defun vm-xemacs-mule-p () 430 (vm-fsfemacs-19-p
351 (and (vm-xemacs-p) 431 (fboundp 'make-frame))))
352 (featurep 'mule) 432
353 (fboundp 'set-file-coding-system) 433 (defun vm-mouse-support-possible-p ()
354 (fboundp 'get-coding-system))) 434 (cond (vm-xemacs-p
355 435 (featurep 'window-system))
356 (defun vm-fsfemacs-19-p () 436 (vm-fsfemacs-19-p
357 (and (string-match "^19" emacs-version) 437 (fboundp 'track-mouse))))
358 (not (string-match "XEmacs\\|Lucid" emacs-version)))) 438
359 439 (defun vm-mouse-support-possible-here-p ()
360 ;; make-frame might be defined and still not work. This would 440 (cond (vm-xemacs-p
361 ;; be true since the user could be running on a tty and using 441 (memq 'win (device-matching-specifier-tag-list)))
362 ;; XEmacs 19.12, or using FSF Emacs 19.28 (or prior FSF Emacs versions). 442 (vm-fsfemacs-19-p
363 ;; 443 (eq window-system 'x))))
364 ;; make-frame works on ttys in FSF Emacs 19.29, but other than
365 ;; looking at the version number I don't know a sane way to
366 ;; test for it without just running make-frame. I'll just
367 ;; let it not work for now... someone will complain eventually
368 ;; and I'll think of something.
369 (defun vm-multiple-frames-possible-p ()
370 (or (and (boundp 'window-system) (not (eq window-system nil)))
371 (and (fboundp 'device-type) (eq (device-type) 'x))))
372
373 (defun vm-mouse-support-possible-p ()
374 (vm-multiple-frames-possible-p))
375 444
376 (defun vm-menu-support-possible-p () 445 (defun vm-menu-support-possible-p ()
377 (or (and (boundp 'window-system) 446 (cond (vm-xemacs-p
378 (or (eq window-system 'x) 447 (featurep 'menubar))
379 (eq window-system 'ns) ;; NextStep 448 (vm-fsfemacs-19-p
380 (eq window-system 'win32))) 449 (fboundp 'menu-bar-mode))))
381 (and (fboundp 'device-type) (eq (device-type) 'x)))) 450
382
383 (defun vm-toolbar-support-possible-p () 451 (defun vm-toolbar-support-possible-p ()
384 (and (vm-xemacs-p) 452 (and vm-xemacs-p (featurep 'toolbar)))
385 (vm-multiple-frames-possible-p)
386 (featurep 'toolbar)))
387 453
388 (defun vm-multiple-fonts-possible-p () 454 (defun vm-multiple-fonts-possible-p ()
389 (or (eq window-system 'x) 455 (cond (vm-xemacs-p
390 (and (fboundp 'device-type) 456 (eq (device-type) 'x))
391 (eq (device-type) 'x)))) 457 (vm-fsfemacs-19-p
458 (or (eq window-system 'x)
459 (eq window-system 'win32)))))
392 460
393 (defun vm-run-message-hook (message &optional hook-variable) 461 (defun vm-run-message-hook (message &optional hook-variable)
394 (save-excursion 462 (save-excursion
395 (set-buffer (vm-buffer-of message)) 463 (set-buffer (vm-buffer-of message))
396 (vm-save-restriction 464 (vm-save-restriction
433 (if (equal (aref vect 5) "") 501 (if (equal (aref vect 5) "")
434 (aset vect 5 (vm-current-time-zone))) 502 (aset vect 5 (vm-current-time-zone)))
435 ;; save this work so we won't have to do it again 503 ;; save this work so we won't have to do it again
436 (setq vm-sortable-date-alist 504 (setq vm-sortable-date-alist
437 (cons (cons string 505 (cons (cons string
438 (timezone-make-date-sortable 506 (condition-case nil
439 (format "%s %s %s %s %s" 507 (timezone-make-date-sortable
440 (aref vect 1) 508 (format "%s %s %s %s %s"
441 (aref vect 2) 509 (aref vect 1)
442 (aref vect 3) 510 (aref vect 2)
443 (aref vect 4) 511 (aref vect 3)
444 (aref vect 5)))) 512 (aref vect 4)
513 (aref vect 5)))
514 (error "1970010100:00:00")))
445 vm-sortable-date-alist)) 515 vm-sortable-date-alist))
446 ;; return result 516 ;; return result
447 (cdr (car vm-sortable-date-alist))))) 517 (cdr (car vm-sortable-date-alist)))))
448 518
449 (defun vm-current-time-zone () 519 (defun vm-current-time-zone ()
495 (or (get-file-buffer file) 565 (or (get-file-buffer file)
496 (and (fboundp 'file-truename) 566 (and (fboundp 'file-truename)
497 (get-file-buffer (file-truename file))))) 567 (get-file-buffer (file-truename file)))))
498 568
499 (defun vm-set-region-face (start end face) 569 (defun vm-set-region-face (start end face)
500 (cond ((fboundp 'make-overlay) 570 (let ((e (vm-make-extent start end)))
501 (let ((o (make-overlay start end))) 571 (vm-set-extent-property e 'face face)))
502 (overlay-put o 'face face)))
503 ((fboundp 'make-extent)
504 (let ((o (make-extent start end)))
505 (set-extent-property o 'face face)))))
506 572
507 (defun vm-default-buffer-substring-no-properties (beg end &optional buffer) 573 (defun vm-default-buffer-substring-no-properties (beg end &optional buffer)
508 (let ((s (if buffer 574 (let ((s (if buffer
509 (save-excursion 575 (save-excursion
510 (set-buffer buffer) 576 (set-buffer buffer)
514 (copy-sequence s))) 580 (copy-sequence s)))
515 581
516 (fset 'vm-buffer-substring-no-properties 582 (fset 'vm-buffer-substring-no-properties
517 (cond ((fboundp 'buffer-substring-no-properties) 583 (cond ((fboundp 'buffer-substring-no-properties)
518 (function buffer-substring-no-properties)) 584 (function buffer-substring-no-properties))
519 ((vm-xemacs-p) 585 (vm-xemacs-p
520 (function buffer-substring)) 586 (function buffer-substring))
521 (t (function vm-default-buffer-substring-no-properties)))) 587 (t (function vm-default-buffer-substring-no-properties))))
522 588
523 (defun vm-buffer-string-no-properties () 589 (defun vm-buffer-string-no-properties ()
524 (vm-buffer-substring-no-properties (point-min) (point-max))) 590 (vm-buffer-substring-no-properties (point-min) (point-max)))
533 (set-buffer target-buffer) 599 (set-buffer target-buffer)
534 (insert-buffer-substring buffer start end) 600 (insert-buffer-substring buffer start end)
535 (set-buffer buffer)) 601 (set-buffer buffer))
536 (set-buffer target-buffer))) 602 (set-buffer target-buffer)))
537 603
538 (if (fboundp 'overlay-get) 604 (if (not (fboundp 'vm-extent-property))
539 (fset 'vm-extent-property 'overlay-get) 605 (if (fboundp 'overlay-get)
540 (fset 'vm-extent-property 'extent-property)) 606 (fset 'vm-extent-property 'overlay-get)
541 607 (fset 'vm-extent-property 'extent-property)))
542 (if (fboundp 'overlay-put) 608
543 (fset 'vm-set-extent-property 'overlay-put) 609 (if (not (fboundp 'vm-set-extent-property))
544 (fset 'vm-set-extent-property 'set-extent-property)) 610 (if (fboundp 'overlay-put)
545 611 (fset 'vm-set-extent-property 'overlay-put)
546 (if (fboundp 'move-overlay) 612 (fset 'vm-set-extent-property 'set-extent-property)))
547 (fset 'vm-set-extent-endpoints 'move-overlay) 613
548 (fset 'vm-set-extent-endpoints 'set-extent-endpoints)) 614 (if (not (fboundp 'vm-set-extent-endpoints))
549 615 (if (fboundp 'move-overlay)
550 (if (fboundp 'make-overlay) 616 (fset 'vm-set-extent-endpoints 'move-overlay)
551 (fset 'vm-make-extent 'make-overlay) 617 (fset 'vm-set-extent-endpoints 'set-extent-endpoints)))
552 (fset 'vm-make-extent 'make-extent)) 618
553 619 (if (not (fboundp 'vm-make-extent))
554 (if (fboundp 'overlay-end) 620 (if (fboundp 'make-overlay)
555 (fset 'vm-extent-end-position 'overlay-end) 621 (fset 'vm-make-extent 'make-overlay)
556 (fset 'vm-extent-end-position 'extent-end-position)) 622 (fset 'vm-make-extent 'make-extent)))
557 623
558 (if (fboundp 'overlay-start) 624 (if (not (fboundp 'vm-extent-end-position))
559 (fset 'vm-extent-start-position 'overlay-start) 625 (if (fboundp 'overlay-end)
560 (fset 'vm-extent-start-position 'extent-start-position)) 626 (fset 'vm-extent-end-position 'overlay-end)
561 627 (fset 'vm-extent-end-position 'extent-end-position)))
562 (if (fboundp 'delete-overlay) 628
563 (fset 'vm-detach-extent 'delete-overlay) 629 (if (not (fboundp 'vm-extent-start-position))
564 (fset 'vm-detach-extent 'detach-extent)) 630 (if (fboundp 'overlay-start)
565 631 (fset 'vm-extent-start-position 'overlay-start)
566 (if (fboundp 'overlay-properties) 632 (fset 'vm-extent-start-position 'extent-start-position)))
567 (fset 'vm-extent-properties 'overlay-properties) 633
568 (fset 'vm-extent-properties 'extent-properties)) 634 (if (not (fboundp 'vm-detach-extent))
635 (if (fboundp 'delete-overlay)
636 (fset 'vm-detach-extent 'delete-overlay)
637 (fset 'vm-detach-extent 'detach-extent)))
638
639 (if (not (fboundp 'vm-extent-properties))
640 (if (fboundp 'overlay-properties)
641 (fset 'vm-extent-properties 'overlay-properties)
642 (fset 'vm-extent-properties 'extent-properties)))
569 643
570 (defun vm-copy-extent (e) 644 (defun vm-copy-extent (e)
571 (let ((props (vm-extent-properties e)) 645 (let ((props (vm-extent-properties e))
572 (ee (vm-make-extent (vm-extent-start-position e) 646 (ee (vm-make-extent (vm-extent-start-position e)
573 (vm-extent-end-position e)))) 647 (vm-extent-end-position e))))