home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / imail / imail-browser.scm < prev    next >
Text File  |  2001-06-04  |  25KB  |  694 lines
  1. ;;; -*-Scheme-*-
  2. ;;;
  3. ;;; $Id: imail-browser.scm,v 1.8 2001/06/04 19:26:33 cph Exp $
  4. ;;;
  5. ;;; Copyright (c) 2001 Massachusetts Institute of Technology
  6. ;;;
  7. ;;; This program is free software; you can redistribute it and/or
  8. ;;; modify it under the terms of the GNU General Public License as
  9. ;;; published by the Free Software Foundation; either version 2 of the
  10. ;;; License, or (at your option) any later version.
  11. ;;;
  12. ;;; This program is distributed in the hope that it will be useful,
  13. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. ;;; General Public License for more details.
  16. ;;;
  17. ;;; You should have received a copy of the GNU General Public License
  18. ;;; along with this program; if not, write to the Free Software
  19. ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  20. ;;; 02111-1307, USA.
  21.  
  22. ;;;; IMAIL mail reader: folder browser
  23.  
  24. (declare (usual-integrations))
  25.  
  26. (define (imail-browse-container url)
  27.   (select-buffer (get-imail-browser-buffer url)))
  28.  
  29. (define (get-imail-browser-buffer url)
  30.   (or (list-search-positive (buffer-list)
  31.     (lambda (buffer)
  32.       (eq? (selected-container-url #f buffer) url)))
  33.       (let ((container (open-resource url))
  34.         (buffer
  35.          (new-buffer
  36.           (string-append (url-presentation-name url) "-browser"))))
  37.     (set-buffer-imail-container! buffer container)
  38.     (add-kill-buffer-hook buffer close-browser-container)
  39.     (set-buffer-imail-url-selector! buffer browser-selected-url)
  40.     (receive-modification-events container notice-container-events)
  41.     (rebuild-imail-browser-buffer buffer)
  42.     buffer)))
  43.  
  44. (define (close-browser-container buffer)
  45.   (let ((container (selected-container #f buffer)))
  46.     (if container
  47.     (close-resource container #t))))
  48.  
  49. (define (browser-selected-url mark)
  50.   (let ((info (browser-line-info #f mark)))
  51.     (and info
  52.      (browser-line-info-url info))))
  53.  
  54. (define (rebuild-imail-browser-buffer buffer)
  55.   (buffer-widen! buffer)
  56.   (let ((container (selected-container #t buffer))
  57.     (url (selected-url #f (buffer-point buffer)))
  58.     (marks (all-marked-urls buffer))
  59.     (expanded (all-expanded-containers buffer)))
  60.     (with-read-only-defeated (buffer-start buffer)
  61.       (lambda ()
  62.     (region-delete! (buffer-region buffer))
  63.     (let ((container-url (resource-locator container))
  64.           (mark (mark-left-inserting-copy (buffer-start buffer))))
  65.       (let ((title (url->string container-url)))
  66.         (insert-string title mark)
  67.         (insert-newline mark)
  68.         (insert-chars #\- (string-length title) mark)
  69.         (insert-newline mark))
  70.       (let ((point (mark-right-inserting-copy mark)))
  71.         (insert-browser-lines container-url container-url mark)
  72.         (set-buffer-point! buffer point)
  73.         (mark-temporary! point)))))
  74.     (set-buffer-major-mode! buffer (ref-mode-object imail-browser))
  75.     (buffer-not-modified! buffer)
  76.     (set-buffer-read-only! buffer)
  77.     (set-all-expanded-containers! buffer expanded)
  78.     (set-all-marked-urls! buffer marks)
  79.     (if url
  80.     (call-with-values (lambda () (find-browser-line-for url buffer))
  81.       (lambda (mark match?)
  82.         match?
  83.         (set-buffer-point! buffer mark))))))
  84.  
  85. (define (insert-browser-lines container-1 container-2 mark)
  86.   (for-each (lambda (subfolder-url)
  87.           (insert-browser-line subfolder-url container-2 mark))
  88.         (sort (container-url-contents container-1) browser-url<?)))
  89.  
  90. (define (insert-browser-line url container-url mark)
  91.   (let ((info (make-browser-line-info url)))
  92.     (with-region-marked mark
  93.       (lambda (start end)
  94.     (region-put! start end 'IMAIL-BROWSER-LINE-INFO info))
  95.       (lambda ()
  96.     (insert-string "  " mark)
  97.     (insert-chars #\space (* 4 (browser-url-depth url container-url)) mark)
  98.     (with-region-marked mark
  99.       (lambda (start end)
  100.         (set-region-local-comtabs!
  101.          (make-region start end)
  102.          (let ((comtab (make-comtab)))
  103.            (define-key comtab button1-down
  104.          (ref-command-object imail-browser-mouse-toggle-container))
  105.            (list comtab))))
  106.       (lambda ()
  107.         (insert-char (if (browser-line-info-container-url info)
  108.                  #\+
  109.                  #\space)
  110.              mark)))
  111.     (insert-char #\space mark)
  112.     (insert-string (url-content-name url) mark)
  113.     (insert-newline mark)))))
  114.  
  115. (define (update-container-line-marker mark char)
  116.   (replace-right-char
  117.    (mark+ (line-start mark 0)
  118.       (+ 2
  119.          (* 4
  120.         (browser-url-depth
  121.          (selected-url #t mark)
  122.          (resource-locator
  123.           (selected-container #t (mark-buffer mark)))))))
  124.    char))
  125.  
  126. (define (browser-url-depth url container)
  127.   (let loop ((url* url))
  128.     (let ((container* (container-url url*)))
  129.       (if (eq? container* container)
  130.       0
  131.       (begin
  132.         (if (eq? container* url*)
  133.         (error "URL not in container:" url container))
  134.         (+ 1 (loop container*)))))))
  135.  
  136. (define (make-browser-line-info url)
  137.   (vector url (url-corresponding-container url) #f))
  138.  
  139. (define (browser-line-info-url info)
  140.   (vector-ref info 0))
  141.  
  142. (define (browser-line-info-container-url info)
  143.   (vector-ref info 1))
  144.  
  145. (define (browser-line-info-container-expanded? info)
  146.   (vector-ref info 2))
  147.  
  148. (define (browser-line-info-container-expanded! info)
  149.   (vector-set! info 2 #t))
  150.  
  151. (define (browser-line-info-container-collapsed! info)
  152.   (vector-set! info 2 #f))
  153.  
  154. (define (browser-line-info #!optional error? mark)
  155.   (or (region-get (if (or (default-object? mark) (not mark))
  156.               (current-point)
  157.               mark)
  158.           'IMAIL-BROWSER-LINE-INFO
  159.           #f)
  160.       (and (if (default-object? error?) #t error?)
  161.        (editor-error "Point not on browser line."))))
  162.  
  163. (define (notice-container-events container type arguments)
  164.   (for-each
  165.    (lambda (buffer)
  166.      (case type
  167.        ((CREATE-RESOURCE)
  168.     (let ((url (car arguments)))
  169.       (with-buffer-open buffer
  170.         (lambda ()
  171.           (call-with-values
  172.           (lambda () (find-browser-line-for url buffer))
  173.         (lambda (mark match?)
  174.           (let ((mark (mark-left-inserting-copy mark)))
  175.             (if match?
  176.             (delete-string mark (line-start mark 1 'LIMIT)))
  177.             (insert-browser-line url
  178.                      (resource-locator
  179.                       (selected-container #t buffer))
  180.                      mark)
  181.             (mark-temporary! mark))))))))
  182.        ((DELETE-RESOURCE)
  183.     (let ((url (car arguments)))
  184.       (with-buffer-open buffer
  185.         (lambda ()
  186.           (call-with-values
  187.           (lambda () (find-browser-line-for url buffer))
  188.         (lambda (mark match?)
  189.           (if match?
  190.               (delete-string mark
  191.                      (line-start mark 1 'LIMIT)))))))))))
  192.    (find-browsers-for container)))
  193.  
  194. (define (find-browsers-for container)
  195.   (list-transform-positive (buffer-list)
  196.     (lambda (buffer)
  197.       (or (eq? (selected-container #f buffer) container)
  198.       (memq container (browser-expanded-containers buffer))))))
  199.  
  200. (define (browser-expanded-containers buffer)
  201.   (buffer-get buffer 'IMAIL-BROWSER-EXPANDED-CONTAINERS '()))
  202.  
  203. (define (add-browser-expanded-container! buffer url)
  204.   (let ((container (open-resource url)))
  205.     (receive-modification-events container notice-container-events)
  206.     (buffer-put! buffer
  207.          'IMAIL-BROWSER-EXPANDED-CONTAINERS
  208.          (let ((containers (browser-expanded-containers buffer)))
  209.            (if (memq container containers)
  210.                containers
  211.                (cons container containers))))))
  212.  
  213. (define (remove-browser-expanded-container! buffer url)
  214.   (let ((container (get-memoized-resource url #f)))
  215.     (if container
  216.     (begin
  217.       (close-resource container #f)
  218.       (buffer-put! buffer
  219.                'IMAIL-BROWSER-EXPANDED-CONTAINERS
  220.                (delq! container
  221.                   (browser-expanded-containers buffer)))))))
  222.  
  223. (define (find-browser-line-for url buffer)
  224.   (let loop ((mark (buffer-start buffer)))
  225.     (if (group-end? mark)
  226.     (values mark #f)
  227.     (let ((url* (selected-url #f mark)))
  228.       (cond ((not url*) (loop (line-start mark 1 'LIMIT)))
  229.         ((eq? url* url) (values mark #t))
  230.         ((browser-url<? url url*) (values mark #f))
  231.         (else (loop (line-start mark 1 'LIMIT))))))))
  232.  
  233. (define (browser-url<? url1 url2)
  234.   (string<? (url->string url1) (url->string url2)))
  235.  
  236. (define (url-contained? url1 url2)
  237.   (let loop ((url url1))
  238.     (or (eq? url url2)
  239.     (let ((url* (container-url url)))
  240.       (and (not (eq? url* url))
  241.            (loop url*))))))
  242.  
  243. (define (with-buffer-open buffer thunk)
  244.   (without-text-clipped buffer
  245.     (lambda ()
  246.       (with-read-only-defeated buffer
  247.     (lambda ()
  248.       (let ((value (thunk)))
  249.         (buffer-not-modified! buffer)
  250.         value))))))
  251.  
  252. (define (with-region-marked mark marker thunk)
  253.   (let ((start (mark-right-inserting-copy mark)))
  254.     (let ((value (thunk)))
  255.       (marker start mark)
  256.       (mark-temporary! start)
  257.       value)))
  258.  
  259. (define (mouse-command-mark)
  260.   (let ((button-event (current-button-event)))
  261.     (let ((window (button-event/window button-event)))
  262.       (or (window-coordinates->mark window
  263.                     (button-event/x button-event)
  264.                     (button-event/y button-event))
  265.       (buffer-end (window-buffer window))))))
  266.  
  267. (define (replace-right-char mark char)
  268.   (group-replace-char! (mark-group mark)
  269.                (mark-index mark)
  270.                char))
  271.  
  272. (define-major-mode imail-browser read-only "IMAIL Browser"
  273.   "Major mode in effect in IMAIL folder browser.
  274. Each line summarizes a single mail folder (or container).
  275. You can move using the usual cursor motion commands.
  276.  
  277. Type \\[imail-browser-flag-folder-deletion] to flag a folder for Deletion.
  278. Type \\[imail-browser-mark] to Mark a folder for later commands.
  279.   Most commands operate on the marked folders and use the current folder
  280.   if no folders are marked.  Use a numeric prefix argument to operate on
  281.   the next ARG (or previous -ARG if ARG<0) folders, or just `1'
  282.   to operate on the current folder only.  Prefix arguments override marks.
  283. Type \\[imail-browser-unmark] to Unmark a folder.
  284. Type \\[imail-browser-unmark-backward] to back up one line and unmark.
  285. Type \\[imail-browser-do-flagged-delete] to eXecute the deletions requested.
  286. Type \\[imail-browser-view-selected-folder] to Find the current line's folder
  287.   (or browse it in another buffer, if it is a container).
  288. Type \\[imail-browser-view-selected-container] to browse the current line's container in another buffer.
  289. Type \\[imail-browser-view-container] to browse this container's container.
  290. Type \\[imail-browser-toggle-container] to show the contents of this line's container in the buffer,
  291.   or hide them if they are already shown.
  292. Type \\[imail-browser-do-rename] to rename a folder or move the marked folders to another container.
  293. Type \\[imail-browser-do-copy] to copy folders.
  294. Type \\[imail-browser-revert] to read the container again.  This discards all deletion-flags.
  295.  
  296. \\{imail-browser}"
  297.   (lambda (buffer)
  298.     (local-set-variable! truncate-lines #t buffer)
  299.     (buffer-put! buffer 'REVERT-BUFFER-METHOD imail-browser-revert-buffer)
  300.     (event-distributor/invoke! (ref-variable imail-browser-mode-hook buffer)
  301.                    buffer)))
  302.  
  303. (define-variable imail-browser-mode-hook
  304.   "An event distributor that is invoked when entering IMAIL Browser mode."
  305.   (make-event-distributor))
  306.  
  307. (define (imail-browser-revert-buffer buffer dont-use-auto-save? dont-confirm?)
  308.   dont-use-auto-save?
  309.   (if (or dont-confirm? (prompt-for-yes-or-no? "Revert IMAIL browser buffer"))
  310.       (rebuild-imail-browser-buffer buffer)))
  311.  
  312. (define-key 'imail-browser #\+ 'imail-create-folder)
  313. (define-key 'imail-browser #\C 'imail-browser-do-copy)
  314. (define-key 'imail-browser #\D 'imail-browser-do-delete)
  315. (define-key 'imail-browser #\R 'imail-browser-do-rename)
  316.  
  317. (define-key 'imail-browser #\? 'describe-mode)
  318. (define-key 'imail-browser #\c 'imail-browser-view-selected-container)
  319. (define-key 'imail-browser #\d 'imail-browser-flag-folder-deletion)
  320. (define-key 'imail-browser #\f 'imail-browser-view-selected-folder)
  321. (define-key 'imail-browser #\g 'imail-browser-revert)
  322. (define-key 'imail-browser #\h 'describe-mode)
  323. (define-key 'imail-browser #\m 'imail-browser-mark)
  324. (define-key 'imail-browser #\q 'imail-browser-quit)
  325. (define-key 'imail-browser #\t 'imail-browser-toggle-container)
  326. (define-key 'imail-browser #\u 'imail-browser-unmark)
  327. (define-key 'imail-browser #\x 'imail-browser-do-flagged-delete)
  328. (define-key 'imail-browser #\^ 'imail-browser-view-container)
  329.  
  330. (define-key 'imail-browser #\return 'imail-browser-view-selected-folder)
  331. (define-key 'imail-browser #\rubout 'imail-browser-unmark-backward)
  332. (define-key 'imail-browser #\M-rubout 'imail-browser-unmark-all-folders)
  333.  
  334. (define-command imail-browser-view-selected-folder
  335.   "Visit the folder or container named on this line.
  336. If this line names a resource that is both a folder and a container,
  337. this command visits it as a folder."
  338.   ()
  339.   (lambda ()
  340.     (let ((url (selected-url)))
  341.       (if (folder-url? url)
  342.       ((ref-command imail) (url->string url))
  343.       (editor-error "Not a selectable folder.")))))
  344.  
  345. (define-command imail-browser-view-selected-container
  346.   "Browse the container named on this line."
  347.   ()
  348.   (lambda ()
  349.     (let ((info (browser-line-info)))
  350.       (let ((container (browser-line-info-container-url info)))
  351.     (if container
  352.         (imail-browse-container container)
  353.         (editor-error "Not a selectable container."))))))
  354.  
  355. (define-command imail-browser-view-container
  356.   "Browse the container of the resource being viewed in this buffer.
  357. With prefix arg, prompt for the container to browse."
  358.   (lambda ()
  359.     (list
  360.      (and (command-argument)
  361.       (prompt-for-container "Browse IMAIL container" #f
  362.                 'HISTORY 'IMAIL-BROWSER-VIEW-CONTAINER
  363.                 'REQUIRE-MATCH? #t))))
  364.   (lambda (url-string)
  365.     (imail-browse-container
  366.      (or (and url-string (imail-parse-partial-url url-string))
  367.      (let ((resource
  368.         (or (selected-container #f)
  369.             (selected-folder #f))))
  370.        (if resource
  371.            (container-url-for-prompt resource)
  372.            (editor-error "This is not an IMAIL buffer.")))))))
  373.  
  374. (define-command imail-browser-mouse-toggle-container
  375.   "Show the contents of the container pointed at.
  376. Like \\[imail-browser-toggle-container] except that the container is
  377. selected by the position of the mouse rather than point."
  378.   ()
  379.   (lambda ()
  380.     ((ref-command imail-browser-toggle-container) (mouse-command-mark))))
  381.  
  382. (define-command imail-browser-toggle-container
  383.   "Show the contents of the container named by this line.
  384. The contents are inserted immediately after this line,
  385. indented slightly to indicate where they are contained.
  386. If the containers contents are currently shown, then hide them instead."
  387.   "d"
  388.   (lambda (mark)
  389.     (let ((info (browser-line-info #t mark)))
  390.       (if (not (browser-line-info-container-url info))
  391.       (editor-error "Not on a container line."))
  392.       (if (browser-line-info-container-expanded? info)
  393.       (browser-collapse-container info mark)
  394.       (browser-expand-container info mark)))))
  395.  
  396. (define (browser-expand-container info mark)
  397.   (let ((container (browser-line-info-container-url info))
  398.     (buffer (mark-buffer mark)))
  399.     (with-buffer-open buffer
  400.       (lambda ()
  401.     (let ((mark (mark-left-inserting-copy (line-start mark 1 'LIMIT))))
  402.       (insert-browser-lines container
  403.                 (selected-container-url #t buffer)
  404.                 mark)
  405.       (mark-temporary! mark))
  406.     (update-container-line-marker mark #\-)
  407.     (add-browser-expanded-container! buffer container)
  408.     (browser-line-info-container-expanded! info)))))
  409.  
  410. (define (browser-collapse-container info mark)
  411.   (let ((container (browser-line-info-container-url info))
  412.     (buffer (mark-buffer mark)))
  413.     (with-buffer-open buffer
  414.       (lambda ()
  415.     (let ((start (line-start mark 1 'LIMIT)))
  416.       (let loop ((end start))
  417.         (if (and (not (group-end? end))
  418.              (let ((url (selected-url #f end)))
  419.                (and url
  420.                 (url-contained? url container))))
  421.         (loop (line-start end 1 'LIMIT))
  422.         (delete-string start end))))
  423.     (update-container-line-marker mark #\+)
  424.     (remove-browser-expanded-container! buffer container)
  425.     (browser-line-info-container-collapsed! info)))))
  426.  
  427. (define-command imail-browser-revert
  428.   "Re-read the contents of the buffer."
  429.   ()
  430.   (lambda () (revert-buffer (selected-buffer) #t #t)))
  431.  
  432. (define-command imail-browser-quit
  433.   "Kill the selected buffer.
  434. Discards any pending changes."
  435.   ()
  436.   (lambda () (kill-buffer-interactive (selected-buffer))))
  437.  
  438. (define-command imail-browser-flag-folder-deletion
  439.   "Mark the folder under point to be deleted.
  440. With prefix argument, mark the next N folders for deletion."
  441.   "p"
  442.   (lambda (n) (imail-browser-mark-lines n #\D)))
  443.  
  444. (define-command imail-browser-mark
  445.   "Mark the current (or next ARG) folder.
  446. Use \\[imail-browser-unmark-all-folders] to remove all marks."
  447.   "p"
  448.   (lambda (n) (imail-browser-mark-lines n #\*)))
  449.  
  450. (define-command imail-browser-unmark
  451.   "Unmark the current (or next ARG) folders."
  452.   "p"
  453.   (lambda (n) (imail-browser-mark-lines n #\space)))
  454.  
  455. (define-command imail-browser-unmark-backward
  456.   "Move up lines and remove marks there.
  457. Optional prefix ARG says how many lines to unmark; default is one line."
  458.   "p"
  459.   (lambda (n) ((ref-command imail-browser-unmark) (- n))))
  460.  
  461. (define-command imail-browser-unmark-all-folders
  462.   "Remove a specific mark (or any mark) from every folder.
  463. After this command, type the mark character to remove, 
  464. or type RET to remove all marks."
  465.   "cRemove marks (RET means all)"
  466.   (lambda (mark-char)
  467.     (let ((buffer (selected-buffer)))
  468.       (with-buffer-open buffer
  469.     (lambda ()
  470.       (let loop ((mark (line-start (buffer-start buffer) 0)))
  471.         (if (not (group-end? mark))
  472.         (begin
  473.           (if (and (or (char=? mark-char #\return)
  474.                    (char=? (extract-right-char mark) mark-char))
  475.                (selected-url #f mark))
  476.               (replace-right-char mark #\space))
  477.           (let ((mark (line-start mark 1 #f)))
  478.             (if mark
  479.             (loop mark)))))))))))
  480.  
  481. (define (imail-browser-mark-lines n mark-char)
  482.   (with-buffer-open (selected-buffer)
  483.     (lambda ()
  484.       (cond ((> n 0)
  485.          (let loop ((n n) (mark (line-start (current-point) 0)))
  486.            (if (selected-url #f mark)
  487.            (begin
  488.              (replace-right-char mark mark-char)
  489.              (let ((mark (line-start mark 1 'ERROR)))
  490.                (set-current-point! mark)
  491.                (if (> n 1)
  492.                (loop (- n 1) mark))))
  493.            (editor-failure))))
  494.         ((< n 0)
  495.          (let loop ((n n) (mark (line-start (current-point) -1 'ERROR)))
  496.            (set-current-point! mark)
  497.            (if (selected-url #f mark)
  498.            (begin
  499.              (replace-right-char mark mark-char)
  500.              (if (< n -1)
  501.              (loop (+ n 1) (line-start mark -1 'ERROR))))
  502.            (editor-failure))))))))
  503.  
  504. (define-command imail-browser-do-copy
  505.   "Copy all marked (or next ARG) folders, or copy the current folder.
  506. When operating on just the current folder, you specify the new name.
  507. When operating on multiple or marked folders, you specify a container,
  508. and new copies of these folders are made in that container
  509. with the same names that the folders currently have."
  510.   "P"
  511.   (lambda (argument)
  512.     (browser-transfer-resources "copy" "copied" argument copy-folder)))
  513.  
  514. (define-command imail-browser-do-rename
  515.   "Rename current folder or all marked (or next ARG) folders.
  516. When renaming just the current folder, you specify the new name.
  517. When renaming multiple or marked folders, you specify a container."
  518.   "P"
  519.   (lambda (argument)
  520.     (browser-transfer-resources "rename" "renamed" argument rename-resource)))
  521.  
  522. (define (browser-transfer-resources present-tense past-tense argument
  523.                     operation)
  524.   (call-with-values (lambda () (browser-url-list argument (current-point)))
  525.     (lambda (mark urls)
  526.       (cond ((not (pair? urls))
  527.          (message "No folders to " present-tense "."))
  528.         ((pair? (cdr urls))
  529.          (let ((container
  530.             (imail-parse-partial-url
  531.              (prompt-for-container (string-append
  532.                         (string-capitalize present-tense)
  533.                         " folders into")
  534.                        #f
  535.                        'HISTORY 'IMAIL-BROWSER-TRANSFER-N
  536.                        'HISTORY-INDEX 0
  537.                        'REQUIRE-MATCH? #t))))
  538.            (for-each
  539.         (lambda (url)
  540.           (operation url
  541.                  (make-content-url container
  542.                            (url-content-name url))))
  543.         urls)
  544.            (message "Folders " past-tense " into "
  545.             (url->string container))))
  546.         (else
  547.          (let* ((url (car urls))
  548.             (new-url
  549.              (imail-parse-partial-url
  550.               (prompt-for-url (string-append
  551.                        (string-capitalize present-tense)
  552.                        " folder to")
  553.                       #f
  554.                       'HISTORY 'IMAIL-BROWSER-TRANSFER-1
  555.                       'HISTORY-INDEX 0)))
  556.             (new-url
  557.              (if (container-url? new-url)
  558.              (make-content-url new-url (url-content-name url))
  559.              new-url)))
  560.            (operation url new-url)
  561.            (message "Folder " past-tense " to " (url->string new-url)))))
  562.       (set-current-point! mark)
  563.       (mark-temporary! mark))))
  564.  
  565. (define-command imail-browser-do-flagged-delete
  566.   "Delete the folders that are flagged for deletion."
  567.   ()
  568.   (lambda ()
  569.     (let ((buffer (selected-buffer)))
  570.       (with-buffer-open buffer
  571.     (lambda ()
  572.       (browser-internal-do-delete (browser-marked-urls buffer #\D)))))))
  573.  
  574. (define-command imail-browser-do-delete
  575.   "Delete all marked (or next ARG) folders."
  576.   "P"
  577.   (lambda (argument)
  578.     (with-buffer-open (selected-buffer)
  579.       (lambda ()
  580.     (call-with-values
  581.         (lambda () (browser-url-list argument (current-point)))
  582.       (lambda (mark urls)
  583.         (browser-internal-do-delete urls)
  584.         (set-current-point! mark)
  585.         (mark-temporary! mark)))))))
  586.  
  587. (define (browser-internal-do-delete urls)
  588.   (if (pair? urls)
  589.       (if (if (pair? (cdr urls))
  590.           (cleanup-pop-up-buffers
  591.            (lambda ()
  592.          (browser-pop-up-urls-window urls)
  593.          (prompt-for-yes-or-no? "Delete these folders")))
  594.           (prompt-for-yes-or-no?
  595.            (string-append "Delete folder " (url->string (car urls)))))
  596.       (for-each delete-resource urls))))
  597.  
  598. (define (browser-pop-up-urls-window urls)
  599.   (pop-up-temporary-buffer " *imail-browser-folders*"
  600.                '(READ-ONLY SHRINK-WINDOW)
  601.     (lambda (buffer window)
  602.       (local-set-variable! truncate-partial-width-windows #f buffer)
  603.       (write-strings-densely
  604.        (map url->string urls)
  605.        (mark->output-port (buffer-point buffer))
  606.        (window-x-size (or window (car (buffer-windows buffer))))))))
  607.  
  608. (define (browser-url-list argument mark)
  609.   (if argument
  610.       (browser-next-n-urls (command-argument-numeric-value argument) mark)
  611.       (values (mark-left-inserting-copy (line-start mark 0))
  612.           (let ((urls (browser-marked-urls (mark-buffer mark) #\*)))
  613.         (if (pair? urls)
  614.             urls
  615.             (list (selected-url #t mark)))))))
  616.  
  617. (define (browser-marked-urls buffer mark-char)
  618.   (let loop ((mark (buffer-start buffer)) (result '()))
  619.     (let ((char (extract-right-char mark)))
  620.       (if char
  621.       (loop (line-start mark 1 'ERROR)
  622.         (let ((url
  623.                (and (eq? char mark-char)
  624.                 (selected-url #f mark))))
  625.           (if url
  626.               (cons url result)
  627.               result)))
  628.       (reverse! result)))))
  629.  
  630. (define (browser-next-n-urls n mark)
  631.   (cond ((> n 0)
  632.      (let loop ((n n) (mark (line-start mark 0)) (urls '()))
  633.        (let ((n (- n 1))
  634.          (mark (line-start mark 1 'ERROR))
  635.          (urls (cons (selected-url #t mark) urls)))
  636.          (if (> n 0)
  637.          (loop n mark urls)
  638.          (values (mark-left-inserting-copy mark)
  639.              (reverse! urls))))))
  640.     ((< n 0)
  641.      (let loop ((n n) (mark (line-start mark -1 'ERROR)) (urls '()))
  642.        (let ((n (+ n 1))
  643.          (urls (cons (selected-url #t mark) urls)))
  644.          (if (< n 0)
  645.          (loop n (line-start mark -1 'ERROR) urls)
  646.          (values (mark-right-inserting-copy mark)
  647.              urls)))))
  648.     (else
  649.      (values (mark-left-inserting-copy (line-start mark 0))
  650.          '()))))
  651.  
  652. (define (all-marked-urls buffer)
  653.   (let loop ((mark (buffer-start buffer)) (result '()))
  654.     (let ((char (extract-right-char mark)))
  655.       (if char
  656.       (loop (line-start mark 1 'ERROR)
  657.         (let ((url (selected-url #f mark)))
  658.           (if url
  659.               (cons (cons char url) result)
  660.               result)))
  661.       (reverse! result)))))
  662.  
  663. (define (set-all-marked-urls! buffer alist)
  664.   (with-buffer-open buffer
  665.     (lambda ()
  666.       (for-each (lambda (c.u)
  667.           (call-with-values
  668.               (lambda () (find-browser-line-for (cdr c.u) buffer))
  669.             (lambda (mark match?)
  670.               (if match?
  671.               (replace-right-char mark (car c.u))))))
  672.         alist))))
  673.  
  674. (define (all-expanded-containers buffer)
  675.   (let loop ((mark (buffer-start buffer)) (result '()))
  676.     (let ((result
  677.        (let ((info (browser-line-info #f mark)))
  678.          (if (and info (browser-line-info-container-expanded? info))
  679.          (cons (browser-line-info-container-url info) result)
  680.          result)))
  681.       (mark (line-start mark 1 #f)))
  682.       (if mark
  683.       (loop mark result)
  684.       (sort result browser-url<?)))))
  685.  
  686. (define (set-all-expanded-containers! buffer urls)
  687.   ;; URLS is sorted so that all containers appear before their contents.
  688.   (for-each
  689.    (lambda (url)
  690.      (call-with-values (lambda () (find-browser-line-for url buffer))
  691.        (lambda (mark match?)
  692.      (if match?
  693.          (browser-expand-container (browser-line-info #t mark) mark)))))
  694.    urls))