home *** CD-ROM | disk | FTP | other *** search
/ ftp.freefriends.org / ftp.freefriends.org.tar / ftp.freefriends.org / arnold / Source / gwm-dist.tar.gz / gwm-dist.tar / home-gwm / jerq-menus.gwm < prev    next >
Text File  |  1993-07-07  |  8KB  |  278 lines
  1. ; JERQ MENUS
  2. ; ==========
  3.  
  4. ;;File: jerq-menus.gwm -- default root/window/icon menus
  5. ;;Author: colas@mirsa.inria.fr (Colas NAHABOO) -- Bull Research FRANCE
  6. ;;Revision: 1.4 -- July 20 1989
  7. ;;State: Exp
  8. ;;GWM Version: 1.4
  9.  
  10. ; create menus with lists of xterms and xloads
  11. ; ============================================
  12.  
  13. (defname-in-screen-to ()  xterm-pop xload-pop)
  14.  
  15. (defaults-to
  16.     xterm-list ()
  17.     xterm-rsh-list ()
  18.     xterm-telnet-list ())
  19.  
  20. (de host-part (item)
  21.     (if (eq (type item) 'list)
  22.         (# 0 item)
  23.         item))
  24.  
  25. (de extra-part (item)
  26.     (if (eq (type item) 'list)
  27.         (+ " -l " (# 1 item))
  28.         ""))
  29.  
  30. (for screen (list-of-screens)
  31.     (with (fsm pop-fsm menu ())
  32.  
  33.       (if (not (boundp 'root-pop)) 
  34.           (: root-pop
  35.          (menu-make
  36.              (item-make "New" (jerq-menus.new-xterm))
  37.              (item-make "Reshape" (jerq-menus.pick do-resize))
  38.              (item-make "Tromp" (jerq-menus.pick do-iconify))
  39.              (item-make "Move" (jerq-menus.pick do-move))
  40.              (item-make "Top" (jerq-menus.pick raise-window))
  41.              (item-make "Bottom" (jerq-menus.pick lower-window))
  42.              (item-make "Current" (jerq-menus.pick do-current))
  43.              (item-make "Push" (jerq-menus.pick do-push))
  44.              (item-make "Delete" (jerq-menus.pick do-kill-window)))))
  45.  
  46.       (: window-pop root-pop)    ; We ARE the Phone Company!
  47.  
  48.       (if (not (boundp 'alt-root-pop)) (progn 
  49.           (: alt-root-items (list
  50.              '(item-make "Refresh" (refresh))
  51.              '(item-make "Restart" (restart))
  52.              '(item-make "Reload" (load ".gwmrc"))
  53.              '(item-make "Tromp All" (tromp-all))
  54.              '(item-make "Untromp All" (untromp-all))
  55.              '(item-make "Window Info" (jerq-menus.pick window-info))
  56.              '(item-make 
  57.              "Wool infos" (progn
  58.                         (hashinfo)(gcinfo)
  59.                         (wlcfinfo)(meminfo)))
  60.              '(item-make "Exec cut" 
  61.              (execute-string (+ "(? " cut-buffer ")")))
  62.              '(item-make "End" (end))))
  63.     (if want-kill-session
  64.         (insert-at '(item-make "Kill session" 
  65.                 (progn
  66.                 (! "kill" "-9" (getenv "session_pid"))
  67.                 (for w (list-of-windows)
  68.                     (move-window w 4000 4000))
  69.                 (end)))
  70.             alt-root-items
  71.             (length alt-root-items)))
  72.         (: alt-root-pop (eval (+ '(menu-make) alt-root-items)))))
  73.  
  74.       (if (not (boundp 'icon-pop)) (: icon-pop window-pop))
  75.       
  76.       (: xterm-pop (eval (+
  77.         '(menu-make
  78.              (item-make "." (! "/bin/sh" "-c" (+ "exec xterm -display " x-screen-name " -ut -n `hostname`"))))
  79.          (mapfor host xterm-list
  80.               (list 'item-make (no-domains host) (list 'rxterm host)))
  81.              (mapfor host xterm-rsh-list
  82.               (list 'item-make (no-domains (host-part host)) (list 'rsh host)))
  83.              (mapfor host xterm-telnet-list
  84.               (list 'item-make (no-domains (host-part host)) (list 'telnet host))))))))
  85.  
  86. (df rxterm (host)
  87.     (! "/bin/sh" "-c" (+ "DISPLAY=" x-screen-name
  88.     " rxterm " host "</dev/null")))
  89.  
  90. (df rsh (item)
  91.     (! "/bin/sh" "-c" (+ "DISPLAY=" x-screen-name
  92.     " exec xterm -ut -n " (no-domains (host-part item))
  93.     " -e rsh " (host-part item) (extra-part item))))
  94.  
  95. (df telnet (host)
  96.     (! "/bin/sh" "-c" (+ "DISPLAY=" x-screen-name
  97.     " exec xterm -ut -n " (no-domains host)
  98.     " -e telnet " host)))
  99.  
  100. (de pop-root-menu ()
  101.     (set-colormap-focus ())    ; bugged on dpx???
  102.     (pop-menu root-pop 2))
  103.  
  104. (: target (cursor-make "target"))
  105. (: sweep (cursor-make "sweep"))
  106. (: push (cursor-make "push"))
  107.  
  108. (: freeze-server 0)
  109.     ; debugging - I only want an active pointer grab here anyway, not
  110.     ; a server grab.
  111.  
  112. (de do-move nil
  113.     (with (cursor sweep)
  114.         (warp-pointer 0 0 window)
  115.         (move-window)
  116.         (unpop-menu jerq-menus.target)
  117.         (raise-window)
  118.         (warp-pointer
  119.             (/ window-width 2)
  120.             (/ window-height 2)
  121.             window)))
  122.  
  123. (de do-push nil
  124.     (with (cursor push)
  125.         (move-window)
  126.         (unpop-menu jerq-menus.target)
  127.         (raise-window)))
  128.  
  129. (de do-resize nil
  130.     (with (cursor blit-arrow)
  131.         (resize-window)
  132.         (unpop-menu jerq-menus.target)
  133.         (raise-window)))
  134.  
  135. (de do-current nil
  136. ;    (unpop-menu jerq-menus.target)
  137.     (current))
  138.  
  139. (de do-kill-window nil
  140.     (if (not (delete-window))
  141.         (kill-window)))
  142.  
  143. (de do-iconify nil
  144.     (iconify-window)
  145.     (if (= window-status 'window)
  146.         (progn (raise-window))))
  147.  
  148. (de tromp-all nil
  149.     (for window (list-of-windows)
  150.     (if (and (= window-status 'window)
  151.          (not (# 'no-tromp-all window-property)))
  152.         (iconify-window))))
  153.  
  154. (de untromp-all nil
  155.     (for window (list-of-windows)
  156.     (if (and (= window-status 'icon)
  157.          (not window-starts-iconic))
  158.         (iconify-window))))
  159.  
  160. (: jerq-menus.fsm1
  161.     (fsm-make
  162.     (state-make
  163. ;        (on (buttonpress 1 any) (jerq-menus.abort))
  164. ;        (on (buttonpress 2 any) (jerq-menus.abort))
  165.         (on (buttonpress 3 any) (jerq-menus.prime))
  166.         (on (buttonrelease any any) (unpop-menu))
  167.         (on (user-event 'kludge) (jerq-menus.hit)))
  168. ))
  169.  
  170. (: jerq-menus.fsm2
  171.     (fsm-make
  172.     (: start (state-make
  173.         (on (buttonpress 1 any) (jerq-menus.abort))
  174.         (on (buttonpress 2 any) (jerq-menus.abort))
  175.         (on (buttonpress 3 any) (jerq-menus.start) finish)))
  176.     (: finish (state-make
  177.         (on (buttonrelease 3 any) (jerq-menus.end) start)))
  178. ))
  179.  
  180. (: jerq-menus.target (with (fsm jerq-menus.fsm1 cursor target)
  181.     (menu-make (with (fsm nil) (bar-make ())))))
  182. (: jerq-menus.sweep (with (fsm jerq-menus.fsm2 cursor sweep)
  183.     (menu-make (with (fsm nil) (bar-make ())))))
  184.  
  185. (move-window (menu-wob jerq-menus.target) -10 -10)
  186. (move-window (menu-wob jerq-menus.sweep)  -10 -10)
  187.  
  188. (df jerq-menus.pick (act)
  189.     (: jerq-menus.action (list act))
  190.     (primitive-pop-menu jerq-menus.target 'here))
  191.  
  192. (de jerq-menus.reshape nil
  193.     (primitive-pop-menu jerq-menus.sweep 'here))
  194.  
  195. (de jerq-menus.abort nil
  196.     (unpop-menu))
  197.  
  198. (df jerq-menus.prime nil
  199.     (: jerq-menus.wob (wob-at-coords (current-event-x) (current-event-y)))
  200.     (send-user-event 'kludge (menu-wob jerq-menus.target)))
  201.  
  202. (de jerq-menus.hit nil
  203.     (unpop-menu)    ; Want to remove, but xterm can't take it...
  204.     (with (_w jerq-menus.wob)
  205.         (if (and _w (not (= _w root-window)))
  206.             (with (window _w) (eval jerq-menus.action)))))
  207.  
  208. (de jerq-menus.start nil
  209.     (: jerq-menus.x (current-event-x))
  210.     (: jerq-menus.y (current-event-y))
  211. )
  212.  
  213. (de jerq-menus.end nil
  214.     (unpop-menu)
  215.     (move-window 4000 4000)
  216.     (resize-window (- (current-event-x) jerq-menus.x)
  217.                (- (current-event-y) jerq-menus.y))
  218.     (move-window jerq-menus.x jerq-menus.y)
  219. )
  220.  
  221. (de jtest nil
  222.     (jerq-menus.pick jerq-menus.reshape))
  223.  
  224. (de jerq-menus.new-xterm nil
  225.     (if (boundp 'primitive-pop-menu)
  226.         (primitive-pop-menu xterm-pop)
  227.         (pop-menu xterm-pop)))
  228.  
  229. ;; icon-group-pop: give the user a menu with which to select which member of
  230. ;; the icon group to de-iconify.  If there's no icon-group, or it has only
  231. ;; one member, then we just de-iconify.
  232. ;; Note: icon-groups MUST be loaded!
  233.  
  234. (defun icon-group-pop (w)
  235.     (with (window w items () icon-pop ())
  236.     (if window-group
  237.         (progn
  238.         (for window window-group
  239.             (if (or (= 'icon window-status) (not window-is-mapped))
  240.             (: items (+ items (list
  241.                 (list
  242.                     'item-make
  243.                     (if (= "icon" window-icon-name)
  244.                     (window-name)
  245.                     (window-icon-name))
  246.                     (list 'deiconify-this-window window)))))))
  247.         (if (> (length items) 1)
  248.             (progn
  249.             (: icon-pop (menu-make-from-list (+ (list
  250.                 (list
  251.                 'item-make
  252.                 "all"
  253.                 (list 'deiconify-all window))) items)))
  254.             (menu-default-action icon-pop
  255.                          (list 'deiconify-all window))
  256.                 (pop-menu icon-pop))
  257.             ; Else only one icon in group (rest are mapped)
  258.             (deiconify-all window)))
  259.         ; Else no window group
  260.         (do-iconify))
  261. ))
  262.  
  263. (defun deiconify-this-window (w)
  264.     (with (window w)
  265.     (map-window)
  266.     (currtop nil)))
  267.  
  268. (defun deiconify-all (w)
  269.     (with (window w)
  270.     (for window (+ (sublist 1 (length window-group) window-group)
  271.                (list (# 0 window-group)))
  272.         (if (or (= 'icon window-status) (not window-is-mapped))
  273.         (progn
  274.             (map-window)
  275.             (currtop nil))))
  276.     (with (window (# 0 window-group))
  277.         (unmap-window window-icon))))
  278.