« back to all changes in this revision
Viewing changes to lisp/vm-mime.el
- browse files at revision 1077
- compare with another revision
- download diff
- download tarball
- view history from revision 1077
- Committer: Uday S Reddy
- Date: 2011-02-19 13:53:59 UTC
- Revision ID: u.s.reddy@cs.bham.ac.uk-20110219135359-iudunchyb53whg6x
Added and extended a few compatibility functions for xemacs/fsfemacs.
added
removed
lisp/vm-mime.el
65
65
(declare-function set-glyph-baseline "vm-xemacs"
66
66
(glyph spec &optional locale tag-set how-to-add))
67
67
(declare-function set-glyph-face "vm-xemacs" (glyph face))
68
(declare-function delete-extent "vm-xemacs" (extent))
69
68
(declare-function extent-list "vm-xemacs"
70
69
(&optional buffer-or-string from to flags property value))
71
70
(declare-function extent-begin-glyph "vm-xemacs" (extent))
4487
4486
;;----------------------------------------------------------------------------
4488
4487
4489
4488
(defun vm-find-layout-extent-at-point ()
4490
(cond (vm-fsfemacs-p
4491
(let (o-list o retval (found nil))
4492
(setq o-list (overlays-at (point)))
4493
(while (and o-list (not found))
4494
(cond ((overlay-get (car o-list) 'vm-mime-layout)
4495
(setq found t)
4496
(setq retval (car o-list))))
4497
(setq o-list (cdr o-list)))
4498
retval ))
4499
(vm-xemacs-p
4500
(vm-extent-at (point) nil 'vm-mime-layout))))
4489
(vm-extent-at (point) 'vm-mime-layout))
4501
4490
4502
4491
;;;###autoload
4503
4492
(defun vm-mime-run-display-function-at-point (&optional function dispose)
4514
4503
(let ((e (vm-find-layout-extent-at-point))
4515
4504
retval )
4516
4505
(cond ((null e) nil)
4517
(vm-fsfemacs-p
4518
(funcall (or function (overlay-get e 'vm-mime-function))
4519
e))
4520
(vm-xemacs-p
4506
(t
4521
4507
(funcall (or function (vm-extent-property e 'vm-mime-function))
4522
4508
e))))))
4523
4509
5915
5901
(error "Command must be used in a VM Mail mode buffer."))
5916
5902
(when (vm-mail-mode-get-header-contents "MIME-Version")
5917
5903
(error "Can't attach MIME object to already encoded MIME buffer."))
5918
(let (start end e tag-string disposition
5904
(let (start end e tag-string disposition file-name
5919
5905
(fb (list vm-mime-forward-local-external-bodies)))
5920
5906
(when (< (point) (save-excursion (mail-text) (point)))
5921
5907
(mail-text))
5926
5912
(or type "MIME file"))))
5927
5913
(insert tag-string "\n")
5928
5914
(setq end (1- (point)))
5929
(if (and (stringp object) (not mimed))
5930
(progn
5915
(cond ((and (stringp object) (not mimed))
5931
5916
(if (or (vm-mime-types-match "application" type)
5932
5917
(vm-mime-types-match "model" type))
5933
5918
(setq disposition (list "attachment"))
5934
5919
(setq disposition (list "inline")))
5935
5920
(unless no-suggested-filename
5936
(setq type (concat type
5937
"; name=\""
5938
(file-name-nondirectory object) "\"")
5939
disposition (nconc disposition
5940
(list
5941
(concat "filename=\""
5942
(file-name-nondirectory object)
5943
"\""))))))
5944
(setq disposition (list "unspecified")))
5945
(when (listp object)
5946
(setq disposition (nth 3 object)))
5921
(setq file-name (file-name-nondirectory object))
5922
(setq type
5923
(concat type "; name=\"" file-name "\""))
5924
(setq disposition
5925
(nconc disposition
5926
(list (concat "filename=\"" file-name "\""))))))
5927
((listp object)
5928
(setq disposition (nth 3 object)))
5929
(t
5930
(setq disposition (list "unspecified"))))
5947
5931
5948
5932
(cond (vm-fsfemacs-p
5949
5933
(put-text-property start end 'front-sticky nil)
5990
5974
(let ((fb (get-text-property (point) 'vm-mime-forward-local-refs)))
5991
5975
(car fb) ))
5992
5976
(vm-xemacs-p
5993
(let* ((e (vm-extent-at (point) nil 'vm-mime-type))
5977
(let* ((e (vm-extent-at (point) 'vm-mime-type))
5994
5978
(fb (vm-extent-property e 'vm-mime-forward-local-refs)))
5995
5979
(car fb) ))))
5996
5980
5999
5983
(let ((fb (get-text-property (point) 'vm-mime-forward-local-refs)))
6000
5984
(setcar fb val) ))
6001
5985
(vm-xemacs-p
6002
(let* ((e (vm-extent-at (point) nil 'vm-mime-type))
5986
(let* ((e (vm-extent-at (point) 'vm-mime-type))
6003
5987
(fb (vm-extent-property e 'vm-mime-forward-local-refs)))
6004
5988
(setcar fb val) ))))
6005
5989
6008
5992
;; TODO
6009
5993
)
6010
5994
(vm-xemacs-p
6011
(let ((e (vm-extent-at (point) nil 'vm-mime-type)))
5995
(let ((e (vm-extent-at (point) 'vm-mime-type)))
6012
5996
(delete-region (vm-extent-start-position e)
6013
5997
(vm-extent-end-position e))))))
6014
5998
6017
6001
;; TODO
6018
6002
)
6019
6003
(vm-xemacs-p
6020
(let ((e (vm-extent-at (point) nil 'vm-mime-type)))
6004
(let ((e (vm-extent-at (point) 'vm-mime-type)))
6021
6005
(save-excursion
6022
6006
(goto-char (1+ (vm-extent-start-position e)))
6023
6007
(insert " --- DELETED ")
6024
6008
(goto-char (vm-extent-end-position e))
6025
6009
(insert " ---")
6026
(delete-extent e))))))
6010
(vm-delete-extent e))))))
6027
6011
6028
6012
;;;###autoload
6029
6013
(defun vm-mime-change-content-disposition ()
6040
6024
(let ((disp (get-text-property (point) 'vm-mime-disposition)))
6041
6025
(intern (car disp))))
6042
6026
(vm-xemacs-p
6043
(let* ((e (vm-extent-at (point) nil 'vm-mime-disposition))
6027
(let* ((e (vm-extent-at (point) 'vm-mime-disposition))
6044
6028
(disp (vm-extent-property e 'vm-mime-disposition)))
6045
6029
(intern (car disp))))))
6046
6030
6049
6033
(let ((disp (get-text-property (point) 'vm-mime-disposition)))
6050
6034
(setcar disp (symbol-name sym))))
6051
6035
(vm-xemacs-p
6052
(let* ((e (vm-extent-at (point) nil 'vm-mime-disposition))
6036
(let* ((e (vm-extent-at (point) 'vm-mime-disposition))
6053
6037
(disp (vm-extent-property e 'vm-mime-disposition)))
6054
6038
(setcar disp (symbol-name sym))))))
6055
6039
6058
6042
(cond (vm-fsfemacs-p
6059
6043
(get-text-property (point) 'vm-mime-encoding))
6060
6044
(vm-xemacs-p
6061
(let ((e (vm-extent-at (point) nil 'vm-mime-encoding)))
6045
(let ((e (vm-extent-at (point) 'vm-mime-encoding)))
6062
6046
(if e (vm-extent-property e 'vm-mime-encoding))))))
6063
6047
6064
6048
(defun vm-mime-set-attachment-encoding-at-point (sym)
6067
6051
(put-text-property (point) (point) 'vm-mime-encoding sym)
6068
6052
)
6069
6053
(vm-xemacs-p
6070
(let ((e (vm-extent-at (point) nil 'vm-mime-disposition)))
6054
(let ((e (vm-extent-at (point) 'vm-mime-disposition)))
6071
6055
(vm-set-extent-property e 'vm-mime-encoding sym)))))
6072
6056
6073
(defun vm-disallow-overlay-endpoint-insertion (overlay after start end
6074
&optional old-size)
6075
(cond ((null after) nil)
6076
((= start (overlay-start overlay))
6077
(move-overlay overlay end (overlay-end overlay)))
6078
((= start (overlay-end overlay))
6079
(move-overlay overlay (overlay-start overlay) start))))
6057
(defun vm-disallow-overlay-endpoint-insertion
6058
(overlay after start end &optional old-size)
6059
"Hook function called before and after text is inserted at the
6060
endpoint of an OVERLAY. AFTER is true if the call is being made after
6061
insertion. Otherwise, it is being made before insertion. START and
6062
END denote the range of the text inserted. Optional argument
6063
OLD-SIZE is ignored.
6064
6065
This hook does nothing when called before insertion. When it is
6066
called after insertion, it moves the overlay so that the inserted is
6067
excluded from the overlay."
6068
(when after
6069
(cond ((= start (overlay-start overlay))
6070
(move-overlay overlay end (overlay-end overlay)))
6071
((= start (overlay-end overlay))
6072
(move-overlay overlay (overlay-start overlay) start)))))
6080
6073
6081
6074
(defun vm-mime-fake-attachment-overlays (start end &optional prop)
6082
6075
"For all attachments in the region, i.e., pieces of text with
6289
6282
(insert label)
6290
6283
(delete-region (point) (overlay-end o)))))))
6291
6284
(vm-xemacs-p
6292
(let ((e (vm-extent-at (point) nil 'vm-mime-layout)))
6285
(let ((e (vm-extent-at (point) 'vm-mime-layout)))
6293
6286
(if (null e)
6294
6287
(error "No MIME button found at point.")
6295
6288
(setq layout (vm-extent-property e 'vm-mime-layout))
6572
6565
;;Make sure we don't double encode UTF-8 (for example) text.
6573
6566
(setq buffer-file-coding-system (vm-binary-coding-system))
6574
6567
(goto-char (mail-text-start))
6575
(setq e-list (extent-list nil (point) (point-max))
6576
e-list (vm-delete (function
6577
(lambda (e)
6578
(vm-extent-property e 'vm-mime-object)))
6579
e-list t)
6568
(setq e-list (vm-extent-list (point) (point-max) 'vm-mime-object)
6580
6569
e-list (sort e-list (function
6581
6570
(lambda (e1 e2)
6582
6571
(< (vm-extent-end-position e1)
7758
7747
"Replace the mime buttons by attachment buttons."
7759
7748
(interactive)
7760
7749
(cond (vm-xemacs-p
7761
(let ((e-list (extent-list nil (point-min) (point-max))))
7750
(let ((e-list (vm-extent-list (point-min) (point-max))))
7762
7751
;; First collect the extents
7763
7752
(setq e-list
7764
7753
(sort (vm-delete
Loggerhead is a web-based interface for Breezy
Version: 2.0.1