wl/wl-dnd.el

   1 ;;; wl-dnd.el -- dragdrop support on Wanderlust.
   2
   3 ;; Copyright 1998,1999,2000 Yuuichi Teranishi <teranisi@gohome.org>
   4
   5 ;; Author: Yuuichi Teranishi <teranisi@gohome.org>
   6 ;; Keywords: mail, net news
   7
   8 ;; This file is part of Wanderlust (Yet Another Message Interface on Emacsen).
   9
  10 ;; This program is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14 ;;
  15 ;; This program is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19 ;;
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24 ;;
  25
  26 ;;; Commentary:
  27 ;;
  28
  29 ;;; Code:
  30 ;;
  31
  32 (provide 'wl-dnd)
  33
  34 (static-cond
  35  ((featurep 'offix)
  36   (defun start-drag (event what &optional typ)
  37     (if (numberp typ)
  38         (funcall (intern "offix-start-drag") event what typ)
  39       (funcall (intern "offix-start-drag") event what))))
  40  ((featurep 'cde)
  41   (defun start-drag (event what &optional typ)
  42     (if (not typ)
  43         (funcall (intern "cde-start-drag-internal") event nil
  44                  (list what))
  45       (funcall (intern "cde-start-drag-internal") event t what))))
  46  (t (defun start-drag (event what &optional typ))))
  47
  48 (defun wl-dnd-start-drag (event)
  49   (interactive "@e")
  50   (mouse-set-point event)
  51   (start-drag event (concat
  52                      wl-summary-buffer-folder-name " "
  53                      (int-to-string (wl-summary-message-number)))))
  54
  55 (defun wl-dnd-drop-func (event object text)
  56   (interactive "@e")
  57   (mouse-set-point event)
  58   (beginning-of-line)
  59   (when (looking-at "^[ ]*\\([^\\[].+\\):.*\n")
  60     (let* ((src-spec (save-match-data
  61                        (split-string (nth 2 (car (cdr object)))
  62                                      " ")))
  63            (src-fld (nth 0 src-spec))
  64            (number  (string-to-int (nth 1 src-spec)))
  65            target)
  66       (setq target
  67             (wl-folder-get-folder-name-by-id (get-text-property
  68                                               (point)
  69                                               'wl-folder-entity-id)))
  70       (message "%s is dropped at %s." number
  71                (buffer-substring (match-beginning 1)
  72                                  (match-end 1)))
  73       (set-buffer (wl-summary-get-buffer src-fld))
  74       (save-match-data
  75         (wl-summary-jump-to-msg number))
  76       (wl-summary-refile target number)
  77       (select-window (get-buffer-window (current-buffer)))
  78       ))
  79   t)
  80
  81 (defun wl-dnd-default-drop-message (event object)
  82   (message "Dropping here is meaningless.")
  83   t)
  84
  85 (defun wl-dnd-set-drop-target (beg end)
  86   (let (ext substr)
  87     (setq ext (make-extent beg end))
  88     (set-extent-property
  89      ext
  90      'experimental-dragdrop-drop-functions
  91      '((wl-dnd-drop-func t t (buffer-substring beg end))))))
  92 ;    (set-extent-property ext 'mouse-face 'highlight)))
  93
  94 (defun wl-dnd-set-drag-starter (beg end)
  95   (let (ext kmap)
  96     (setq ext (make-extent beg end))
  97 ;    (set-extent-property ext 'mouse-face 'isearch)
  98     (setq kmap (make-keymap))
  99     (define-key kmap [button1] 'wl-dnd-start-drag)
 100     (set-extent-property ext 'keymap kmap)))
 101
 102 ;;; wl-dnd.el ends here