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 (require 'product)
  33 (product-provide (provide 'wl-dnd) (require 'wl-version))
  34
  35 (static-cond
  36  ((featurep 'offix)
  37   (defun start-drag (event what &optional typ)
  38     (if (numberp typ)
  39         (funcall (intern "offix-start-drag") event what typ)
  40       (funcall (intern "offix-start-drag") event what))))
  41  ((featurep 'cde)
  42   (defun start-drag (event what &optional typ)
  43     (if (not typ)
  44         (funcall (intern "cde-start-drag-internal") event nil
  45                  (list what))
  46       (funcall (intern "cde-start-drag-internal") event t what))))
  47  (t (defun start-drag (event what &optional typ))))
  48
  49 (defun wl-dnd-start-drag (event)
  50   (interactive "@e")
  51   (mouse-set-point event)
  52   (start-drag event (concat
  53                      wl-summary-buffer-folder-name " "
  54                      (int-to-string (wl-summary-message-number)))))
  55
  56 (defun wl-dnd-drop-func (event object text)
  57   (interactive "@e")
  58   (mouse-set-point event)
  59   (beginning-of-line)
  60   (when (looking-at "^[ ]*\\([^\\[].+\\):.*\n")
  61     (let* ((src-spec (save-match-data
  62                        (split-string (nth 2 (car (cdr object)))
  63                                      " ")))
  64            (src-fld (nth 0 src-spec))
  65            (number  (string-to-int (nth 1 src-spec)))
  66            target)
  67       (setq target
  68             (wl-folder-get-folder-name-by-id (get-text-property
  69                                               (point)
  70                                               'wl-folder-entity-id)))
  71       (message "%s is dropped at %s." number
  72                (buffer-substring (match-beginning 1)
  73                                  (match-end 1)))
  74       (set-buffer (wl-summary-get-buffer src-fld))
  75       (save-match-data
  76         (wl-summary-jump-to-msg number))
  77       (wl-summary-refile target number)
  78       (select-window (get-buffer-window (current-buffer)))
  79       ))
  80   t)
  81
  82 (defun wl-dnd-default-drop-message (event object)
  83   (message "Dropping here is meaningless.")
  84   t)
  85
  86 (defun wl-dnd-set-drop-target (beg end)
  87   (let (ext substr)
  88     (setq ext (make-extent beg end))
  89     (set-extent-property
  90      ext
  91      'experimental-dragdrop-drop-functions
  92      '((wl-dnd-drop-func t t (buffer-substring beg end))))))
  93 ;    (set-extent-property ext 'mouse-face 'highlight)))
  94
  95 (defun wl-dnd-set-drag-starter (beg end)
  96   (let (ext kmap)
  97     (setq ext (make-extent beg end))
  98 ;    (set-extent-property ext 'mouse-face 'isearch)
  99     (setq kmap (make-keymap))
 100     (define-key kmap [button1] 'wl-dnd-start-drag)
 101     (set-extent-property ext 'keymap kmap)))
 102
 103 ;;; wl-dnd.el ends here