src/TeXmacs/progs/remote/tmfs-menu.scm

   1
   2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   3 ;;
   4 ;; MODULE      : tmfs-menu.scm
   5 ;; DESCRIPTION : menus for user accounts on the TeXmacs server
   6 ;; COPYRIGHT   : (C) 2006  Joris van der Hoeven
   7 ;;
   8 ;; This software falls under the GNU general public license version 3 or later.
   9 ;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
  10 ;; in the root directory or <http://www.gnu.org/licenses/gpl-3.0.html>.
  11 ;;
  12 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  13
  14 (texmacs-module (remote tmfs-menu)
  15   (:use (remote tmfs-remote)))
  16
  17 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  18 ;; Menu for setting properties
  19 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  20
  21 (define (std-property-types)
  22   '(owner type date read write classify-type classify-value project))
  23
  24 (define (remote-set-property-menu-entry type)
  25   (list (upcase-first type)
  26         (lambda () (interactive-remote-set-property type))))
  27
  28 (tm-define (remote-set-property-menu)
  29   (let* ((l1 (or (remote-get-property-types) '()))
  30          (l2 (list-difference l1 (std-property-types)))
  31          (l3 (list-sort (map symbol->string l2) string<=?)))
  32     (menu-dynamic
  33       ,@(map remote-set-property-menu-entry l3)
  34       ---
  35       ("Other" (interactive-remote-set-property-and-value)))))
  36
  37 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  38 ;; Menu for setting the current project
  39 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  40
  41 (define (remote-set-project-menu-entry val new-file old-file)
  42   (list (list 'check val "v" (lambda () (== new-file old-file)))
  43         (lambda () (remote-set-property "project" new-file))))
  44
  45 (tm-define (remote-set-project-menu)
  46   (let* ((l1 (or (remote-get-projects) '()))
  47          (l2 (list-sort l1 (lambda (x y) (string<=? (car x) (car y)))))
  48          (prj (remote-get-property "project")))
  49     (menu-dynamic
  50       ,@(map (lambda (x) (remote-set-project-menu-entry (car x) (cdr x) prj))
  51              l2))))
  52
  53 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  54 ;; Main remote file menu
  55 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  56
  57 (menu-bind remote-file-menu
  58   ("New file" (interactive remote-new-file))
  59   ---
  60   (when (remote-buffer?)
  61     (-> "Permissions"
  62         ("Owner" (check "o" (remote-permission? (get-name-buffer) "owner"))
  63          (interactive-remote-set-property "owner"))
  64         ("Read" (check "o" (remote-permission? (get-name-buffer) "read"))
  65          (interactive-remote-set-property "read"))
  66         ("Write" (check "o" (remote-permission? (get-name-buffer) "write"))
  67          (interactive-remote-set-property "write")))
  68     (-> "Properties" (link remote-set-property-menu)))
  69   (-> "Project"
  70       (when (remote-buffer?)
  71         ("None" (remote-set-property "project" ""))
  72         ---
  73         (link remote-set-project-menu)
  74         ---)
  75       ("Create" (interactive remote-new-project)))
  76   (-> "Transfer"
  77       ("Export to remote server"
  78        (choose-file interactive-remote-export "Export to remote server" ""))
  79       (when (not (remote-buffer?))
  80         ("Export current file"
  81          (interactive-remote-export (get-name-buffer))))
  82       (when (remote-buffer?)
  83         ("Import current file"
  84          (choose-file (lambda (u) (remote-import (get-name-buffer) u))
  85                       "Import from remote server" ""))))
  86   (-> "Browse"
  87       ("Home directory" (remote-home-directory))
  88       (when (remote-buffer?)
  89         ("File information" (remote-file-information)))))