cgit.sxemacs.org Git - packages/blob - xemacs-packages/xwem/lisp/xwem-launcher.el

   1 ;;; xwem-launcher.el --- Program launcher for XWEM.
   2
   3 ;; Copyright (C) 2003-2005 by XWEM Org.
   4
   5 ;; Author: Zajcev Evgeny <zevlg@yandex.ru>
   6 ;; Created: Thu Dec  4 16:32:11 MSK 2003
   7 ;; Keywords: xwem, xlib
   8 ;; X-CVS: $Id: xwem-launcher.el,v 1.11 2005-04-04 19:54:13 lg Exp $
   9
  10 ;; This file is part of XWEM.
  11
  12 ;; XWEM is free software; you can redistribute it and/or modify it
  13 ;; under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 2, or (at your option)
  15 ;; any later version.
  16
  17 ;; XWEM is distributed in the hope that it will be useful, but WITHOUT
  18 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
  19 ;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public
  20 ;; License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  24 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  25 ;; 02111-1307, USA.
  26
  27 ;;; Synched up with: Not in FSF
  28
  29 ;;; Commentary:
  30
  31 ;; External programs launcher for XWEM.
  32
  33 ;;; TODO:
  34 ;;    * Assume argument in quotas as single argument, i.e. do not make
  35 ;;      splitting inside quotas.
  36
  37 ;;; Code:
  38 \f
  39 (eval-and-compile
  40   (require 'completer)
  41   (require 'comint)
  42   (autoload 'executable-find "executable")
  43   )
  44
  45 (require 'xlib-xlib)
  46 (require 'xlib-tray)
  47 (require 'xlib-xpm)
  48
  49 (require 'xwem-load)
  50
  51 (defgroup xwem-launcher nil
  52   "Group to customize XWEM's programs launcher."
  53   :prefix "xwem-"
  54   :group 'xwem)
  55
  56 (defcustom xwem-launcher-beep-done nil
  57   "*Non-nil mean beep when execution of program done.
  58 Beep performed using \(xwem-play-sound 'ready\)."
  59   :type 'boolean
  60   :group 'xwem-launcher)
  61
  62 (defcustom xwem-launcher-function 'xwem-execute-program
  63   "Function to be used to execute external program."
  64   :type 'function
  65   :group 'xwem-launcher)
  66
  67 (defcustom xwem-launcher-abbrev-table nil
  68   "Abbrev table used by `xwem-launcher-query'."
  69   :type 'list
  70   :group 'xwem-launcher)
  71
  72 (defcustom xwem-launcher-history nil
  73   "History of `xwem-launcher-query'ies."
  74   :type 'list
  75   :group 'xwem-launcher)
  76
  77 (defcustom xwem-launcher-split-type 'xwem-execute-program-other-win-vertical
  78   "Window split type, when launching program in other window."
  79   :type '(choice
  80           (const :tag "Horizontal" xwem-execute-program-other-win-horizontal)
  81           (const :tag "Vertical" xwem-execute-program-other-win-vertical))
  82   :group 'xwem-launcher)
  83
  84 (defcustom xwem-launcher-frame-type 'xwem-execute-program-other-frame
  85   "Type of frame, when launching program in other frame."
  86   :type '(choice
  87           (const :tag "Normal frame" xwem-execute-program-other-frame)
  88           (const :tag "Embedded frame" xwem-execute-program-embedded-frame))
  89   :group 'xwem-launcher)
  90
  91 (defcustom xwem-xterm-program "xterm"
  92   "Name of terminal emulator program."
  93   :type 'string
  94   :group 'xwem-launcher)
  95
  96 (defcustom xwem-xterm-font-argument "-fn"
  97   "Program key to specify in order to change font."
  98   :type 'string
  99   :group 'xwem-launcher)
 100
 101 (defcustom xwem-xterm-font1 ""
 102   "Default xterm font."
 103   :type 'string
 104   :group 'xwem-launcher)
 105
 106 (defcustom xwem-xterm-font2 "10x20"
 107   "Second xterm font."
 108   :type 'string
 109   :group 'xwem-launcher)
 110
 111 (defcustom xwem-xterm-font3 "9x15"
 112   "Third xterm font."
 113   :type 'string
 114   :group 'xwem-launcher)
 115
 116 (defcustom xwem-xterm-font4 "fixed"
 117   "Forth xterm font."
 118   :type 'string
 119   :group 'xwem-launcher)
 120
 121 (defcustom xwem-lupe-program "lupe"
 122   "Xmag like mignifier program."
 123   :type 'string
 124   :group 'xwem-launcher)
 125
 126 (defcustom xwem-lupe-arguments "-noshape -nohud"
 127   "Argument to pass to `xwem-lupe-program'."
 128   :type 'string
 129   :group 'xwem-launcher)
 130
 131 (defcustom xwem-xlock-program "xlock"
 132   "Program to run in order to lock X display."
 133   :type 'string
 134   :group 'xwem-launcher)
 135
 136 (defcustom xwem-xlock-arguments "-mode image"
 137   "Arguments to supply `xwem-xlock-program'."
 138   :type 'string
 139   :group 'xwem-launcher)
 140
 141 ;;; Launcher dockapp button
 142 (defcustom xwem-launch-dock-width 24
 143   "*Launcher dockapp width."
 144   :type 'number
 145   :group 'xwem-launcher)
 146
 147 (defcustom xwem-launch-dock-height 24
 148   "*Launcher dockapp height."
 149   :type 'number
 150   :group 'xwem-launcher)
 151
 152 (defcustom xwem-launch-dock-thick 2
 153   "*Launcher dockapp border thickness."
 154   :type 'number
 155   :group 'xwem-launcher)
 156
 157 ;;; Internal variables
 158
 159 (defvar xwem-launcher-shell-completion-table nil
 160   "*Completion table in used by `xwem-completer'.")
 161
 162 ;; Executing program
 163 (defun xwem-launcher-build-shell-completion-table (&optional rehash)
 164   "Scan `exec-path' to build completion table of executables."
 165   (if (and xwem-launcher-shell-completion-table (not rehash))
 166       xwem-launcher-shell-completion-table
 167
 168     (setq xwem-launcher-shell-completion-table
 169           (apply 'nconc
 170                  (mapcar #'(lambda (dir)
 171                              (mapcar 'list (directory-files dir nil nil t t)))
 172                          exec-path)))))
 173
 174 (defun xwem-launcher-shell-complete (&optional undo mode)
 175   "Complete the previous command or display possibilities if done
 176 twice in a row.  If called with a prefix, undo the last completion."
 177   (interactive "P")
 178   (if undo
 179       (completer-undo)
 180
 181     (setq completer-string nil)
 182     (if (string-match ".*[ \t].*" (buffer-substring (point-min) (point-max)))
 183         (comint-dynamic-complete-filename)
 184
 185       ;; Complete application
 186       (completer-complete-goto "^ \t\n\"" completer-words
 187                                (xwem-launcher-build-shell-completion-table)
 188                                #'(lambda (w)
 189                                    (executable-find (car w)))))))
 190
 191 (defun xwem-launcher-read-command (prompt &optional initial-input)
 192   "Read command name prompting PROMPT.
 193 Just linke `read-shell-command', but installs
 194 `xwem-launcher-abbrev-table' as abbrev table, `xwem-launcher-history'
 195 as history of commands and `xwem-launcher-shell-completion-table' as table
 196 to performe completions.
 197 INITIAL-INPUT is self-described."
 198   (let ((minibuffer-completion-table nil)
 199         (keymap (copy-keymap read-shell-command-map)))
 200     (xwem-unwind-protect
 201         (progn
 202           (define-key read-shell-command-map
 203             (kbd "TAB") 'xwem-launcher-shell-complete)
 204           (xwem-read-from-minibuffer
 205            prompt initial-input read-shell-command-map
 206            nil 'xwem-launcher-history xwem-launcher-abbrev-table))
 207       (setq read-shell-command-map keymap))))
 208
 209 (defun xwem-launcher-parse-arguments (cmd-str &optional keep-quotes-p)
 210   "Parse CMD-STR by spliting it to arguments list.
 211 If optional KEEP-QUOTES-P is non-nil, quotes in quoted arguments are kept."
 212   (let ((scmd (split-string cmd-str " "))
 213         qarg args cmd)
 214     (while scmd
 215       (if (string-match "^['\"]" (car scmd))
 216           (setq qarg (car scmd))
 217         (when (stringp qarg)
 218           (setq qarg (concat qarg " " (car scmd)))))
 219       (if (and (stringp qarg)
 220                (string-match "['\"]$" (car scmd)))
 221           (setq args (cons (if keep-quotes-p
 222                                qarg
 223                              (substring qarg 1 (1- (length qarg))))
 224                            args)
 225                 qarg nil)
 226         (setq args (cons (car scmd) args)))
 227       (setq scmd (cdr scmd)))
 228     ;; Pre-normalise command and its arguments
 229     (setq args (remove "" (nreverse args))
 230           cmd (executable-find (car args)))
 231     (when cmd
 232       (cons cmd (cdr args)))))
 233
 234 (defun xwem-launcher-normalize-cmd (cmd)
 235   "Normalize command CMD string.
 236 Return normalized command string, or signal error if CMD can't be
 237 normalized."
 238   (let ((pargs (xwem-launcher-parse-arguments cmd t)))
 239     (unless pargs
 240       (error 'xwem-error (format "Can't normalize command: %S" cmd)))
 241     (mapconcat #'identity pargs " ")))
 242
 243 ;;;###xwem-autoload
 244 (defun xwem-launcher-query (&optional prompt)
 245   "Query for command to launch using PROMPT."
 246   (let ((cmd (xwem-launcher-read-command (or prompt "XWEM-Run: "))))
 247     (xwem-launcher-normalize-cmd cmd)))
 248
 249 ;;;###autoload(autoload 'xwem-run-program "xwem-launcher" "" t)
 250 (define-xwem-command xwem-run-program (command)
 251   "Run COMMAND."
 252   (xwem-interactive "eRun command: ")
 253   (xwem-execute-program command))
 254
 255 (defun xwem-next-job-number ()
 256   "Return next job number for use by xwem."
 257   (let ((job-number 1))
 258     (while (get-process (format "xwem-run-%d" job-number))
 259       (setq job-number (1+ job-number)))
 260     job-number))
 261
 262 ;;;###autoload
 263 (defun xwem-execute-program (command &optional buffer-name)
 264   "Execute COMMAND in buffer with BUFFER-NAME.
 265 Unlike `background' do not use shell."
 266   (let* ((cmdargs
 267           ;; Do it under `condition-case', due to split-string
 268           ;; args-out-of-range bug.
 269           (condition-case nil
 270               (xwem-launcher-parse-arguments command)
 271             (t (list command))))
 272          (prg (car cmdargs))
 273          (args (cdr cmdargs))
 274          (emacs-env (getenv "EMACS"))
 275          (job-number (xwem-next-job-number))
 276          (job-name (format "xwem-run-%d" job-number))
 277          proc)
 278
 279     (unless buffer-name
 280       (setq buffer-name (format " *%s*" job-name)))
 281
 282     (with-current-buffer (get-buffer-create buffer-name)
 283       ;; Sometimes `default-directory' became nil for some reason, I
 284       ;; don't know why.  Maybe XEmacs bug? --lg
 285       (unless default-directory
 286         (setq default-directory (expand-file-name "~/")))
 287
 288       (erase-buffer)
 289       (insert (format "--- Working directory: %S\n%% %S\n"
 290                       default-directory command))
 291
 292       ;; Set our EMACS environment variable so comint-exec doesn't do it
 293       ;; for us.  Note that if the environment is already set, we may
 294       ;; not want to do it again.
 295       (unless emacs-env
 296         (setenv "EMACS" "xwem"))
 297
 298       (setq proc (get-buffer-process
 299                   (comint-exec buffer-name job-name prg nil args)))
 300       (comint-mode)
 301       ;; COND because the proc may have died before the G-B-P is called.
 302       (cond (proc (set-process-sentinel proc 'xwem-program-sentinel)
 303                   (xwem-message 'note "Job [%d] '%s' PID=%d"
 304                                 job-number command (process-id proc))))
 305       (setq mode-name "XWEM-Run")
 306
 307       ;; Restore our Emacs environment variable to its previous state.
 308       (setenv "EMACS" emacs-env)
 309
 310       proc)))
 311
 312 (defun xwem-program-sentinel (process msg)
 313   "Called when PROCESS changed state to MSG."
 314   (let ((ms (match-data))) ; barf
 315     (unwind-protect
 316          (let ((msg (cond ((string= msg "finished\n") "Done")
 317                           ((string-match "^exited" msg)
 318                            (concat "Exit " (substring msg 28 -1)))
 319                           ((zerop (length msg)) "Continuing")
 320                           (t (concat (upcase (substring msg 0 1))
 321                                      (substring msg 1 -1))))))
 322            (when xwem-launcher-beep-done
 323              (xwem-play-sound 'ready))
 324            (xwem-message 'note "Job [%s] %s '%s'" (process-name process)
 325                          msg (mapconcat #'identity
 326                                         (process-command process) " "))
 327            (if (null (buffer-name (process-buffer process)))
 328                (set-process-buffer process nil) ; WHY? Olin.
 329
 330              (if (memq (process-status process) '(signal exit))
 331                  (with-current-buffer (process-buffer process)
 332                    (let ((at-end (eobp)))
 333                      (save-excursion
 334                        (goto-char (point-max))
 335                        (insert ?\n msg ?\x20
 336                                (substring (current-time-string) 11 19) ?\n))
 337                      (if at-end (goto-char (point-max))))
 338                    (set-buffer-modified-p nil)))))
 339       (store-match-data ms))))
 340
 341 ;;;###xwem-autoload
 342 (defun xwem-execute-program-expecting (cmd &optional manage-type cl-plist non-block)
 343   "Execute CMD expecting till client will be managed.
 344 MANAGE-TYPE specifies which manage type to use in expectance.
 345 CL-PLIST is properties for expected client.
 346 Return managed client unless NON-BLOCK is non-nil."
 347   (setq cmd (xwem-launcher-normalize-cmd cmd))
 348
 349   (let* ((job-num (xwem-next-job-number))
 350          (expt (list manage-type
 351                      (nconc (list 'job-num job-num) cl-plist)
 352                      '(eval t)))
 353          ccls)
 354     (xwem-manda-add-expectance expt)
 355     (xwem-execute-program cmd)
 356     (unless non-block
 357       (while (memq expt xwem-manage-expectances)
 358         (dispatch-event (next-event)))
 359
 360       ;; Find a client
 361       (setq ccls xwem-clients)
 362       (while (and ccls (not (= job-num
 363                                (or (xwem-client-property (car ccls) 'job-num) -1))))
 364         (setq ccls (cdr ccls)))
 365       (when (car ccls)
 366         (xwem-client-set-property (car ccls) 'executed-command cmd))
 367       (car ccls))))
 368
 369 (defun xwem-execute-program-other-win (cmd type &optional select-p)
 370   "Execute CMD in other XWEM window, making TYPE split if needed.
 371 TYPE is one of 'horizontal of 'vertical.
 372 If SELECT-P is non-nil - select newly created client.
 373 Return newly created client."
 374   (let ((own (xwem-window-other 1))
 375         cl)
 376     ;; Check is there split needed
 377     (when (eq own (xwem-win-selected))
 378       (if (eq type 'horizontal)
 379           (xwem-window-split-horizontally 0)
 380         (xwem-window-split-vertically 0))
 381       (setq own (xwem-win-next (xwem-win-selected))))
 382
 383     (setq cl (xwem-execute-program-expecting
 384               cmd nil `(expect-win ,(xwem-win-id own))))
 385     (when select-p
 386       (xwem-select-client cl))
 387     cl))
 388
 389 (defun xwem-execute-program-other-win-horizontal (cmd &optional select-p)
 390   "Execute CMD in other XWEM window, making horizontal split if needed."
 391   (xwem-execute-program-other-win cmd 'horizontal select-p))
 392
 393 (defun xwem-execute-program-other-win-vertical (cmd &optional select-p)
 394   "Execute CMD in other XWEM window, making vertical split if needed."
 395   (xwem-execute-program-other-win cmd 'vertical select-p))
 396
 397 (defun xwem-execute-program-other-frame (cmd &optional select-p)
 398   "Execute CMD in other XWEM frame.
 399 If SELECT-P is non-nil select newly managed client."
 400   (let* ((oframe (or (xwem-frame-other (xwem-frame-selected))
 401                      (xwem-make-frame-1 'desktop :noselect t)))
 402          (cl (xwem-execute-program-expecting
 403               cmd nil `(expect-win ,(xwem-win-id (xwem-frame-selwin oframe))))))
 404     (when select-p
 405       (xwem-select-client cl))
 406     cl))
 407
 408 (defun xwem-execute-program-embedded-frame (cmd &optional select-p)
 409   "Execute CMD in linkaged frame or in embedded XWEM frame."
 410   (let* ((oframe (or (xwem-frame-other (xwem-frame-selected) 'linkage)
 411                      (xwem-make-frame-1 'embedded :noselect t)))
 412          (cl (xwem-execute-program-expecting
 413               cmd nil `(expect-win ,(xwem-win-id (xwem-frame-selwin oframe))))))
 414     (when select-p
 415       (xwem-select-client cl))
 416     cl))
 417
 418 ;;;; XWEM commands.
 419
 420 ;;;###autoload(autoload 'xwem-launcher-turn-on-horizontal-split-type "xwem-launcher" "" t)
 421 (define-xwem-command xwem-launcher-turn-on-horizontal-split-type ()
 422   "Set `xwem-launcher-split-type' to `xwem-execute-program-other-win-horizontal'."
 423   (xwem-interactive)
 424
 425   (setq xwem-launcher-split-type 'xwem-execute-program-other-win-horizontal)
 426   (xwem-message 'info "Launcher split type HORIZONTAL on."))
 427
 428 ;;;###autoload(autoload 'xwem-launcher-turn-on-vertical-split-type "xwem-launcher" "" t)
 429 (define-xwem-command xwem-launcher-turn-on-vertical-split-type ()
 430   "Set `xwem-launcher-split-type' to `xwem-execute-program-other-win-vertical'."
 431   (xwem-interactive)
 432
 433   (setq xwem-launcher-split-type 'xwem-execute-program-other-win-vertical)
 434   (xwem-message 'info "Launcher split type VERTICAL on."))
 435
 436 ;;;###autoload(autoload 'xwem-launcher-toggle-split-type "xwem-launcher" "" t)
 437 (define-xwem-command xwem-launcher-toggle-split-type (arg)
 438   "Toggle `xwem-launcher-split-type'.
 439 Without prefix ARG set it to vertical, with prefix ARG set it to horizontal."
 440   (xwem-interactive "P")
 441
 442   (if arg
 443       (xwem-launcher-turn-on-horizontal-split-type)
 444     (xwem-launcher-turn-on-vertical-split-type)))
 445
 446 ;;;###autoload(autoload 'xwem-launcher-turn-on-normal-frame-type "xwem-launcher" "" t)
 447 (define-xwem-command xwem-launcher-turn-on-normal-frame-type ()
 448   "Set `xwem-launcher-frame-type' to `xwem-execute-program-other-frame', aka normal frame type."
 449   (xwem-interactive)
 450
 451   (setq xwem-launcher-frame-type 'xwem-execute-program-other-frame)
 452   (xwem-message 'info "Other frame NORMAL type on."))
 453
 454 ;;;###autoload(autoload 'xwem-launcher-turn-on-embedded-frame-type "xwem-launcher" "" t)
 455 (define-xwem-command xwem-launcher-turn-on-embedded-frame-type ()
 456   "Set `xwem-launcher-frame-type' to `xwem-execute-program-embedded-frame' aka embedded frame type."
 457   (xwem-interactive)
 458
 459   (setq xwem-launcher-frame-type 'xwem-execute-program-embedded-frame)
 460   (xwem-message 'info "Other frame EMBEDDED type on."))
 461
 462 ;;;###autoload(autoload 'xwem-launcher-toggle-frame-type "xwem-launcher" "" t)
 463 (define-xwem-command xwem-launcher-toggle-frame-type (arg)
 464   "Toggle `xwem-launcher-frame-type'.
 465 Without prefix ARG set it to normal, with prefix ARG set it to embedded."
 466   (xwem-interactive "P")
 467
 468   (if arg
 469       (xwem-launcher-turn-on-normal-frame-type)
 470     (xwem-launcher-turn-on-embedded-frame-type)))
 471
 472 ;;;###autoload(autoload 'xwem-launch-program "xwem-launcher" "" t)
 473 (define-xwem-command xwem-launch-program (cmd &optional arg)
 474   "Run CMD program in background.
 475 If used with prefix ARG (\\<xwem-global-map>\\[xwem-universal-argument]), installs
 476 expectance on selected window (i.e. when client window performe
 477 MapWindow, it will be managed to window where expectance setuped
 478 regardless selected window at map moment.  It is usefull to do so when
 479 you start application with large start time, such as Mozilla or
 480 AcrobatReader, and you want continue doing things not wainting untill
 481 application window maps.
 482 If used with numeric prefix ARG, then that number specifies how many
 483 programs to run."
 484   (xwem-interactive "_eLaunch program: \nP")
 485
 486   (cond ((listp arg)
 487          (xwem-execute-program-expecting
 488           cmd nil `(expect-win ,(xwem-win-id (xwem-win-selected)))))
 489
 490         ((numberp arg)
 491          (while (> arg 0)
 492            (xwem-execute-program cmd)
 493            (setq arg (1- arg))))
 494         (t (error 'xwem-error "Invalid arg: %s" arg))))
 495
 496 ;;;###autoload(autoload 'xwem-launch-program-other-win "xwem-launcher" "" t)
 497 (define-xwem-command xwem-launch-program-other-win (cmd &optional arg)
 498   "Run program in other window.
 499 If prefix ARG is specified - select newly created client.
 500 Window spliting (if needed) is controled by `xwem-launcher-split-type'."
 501   (xwem-interactive "_eLaunch Other Win: \nP")
 502
 503   (funcall xwem-launcher-split-type cmd arg))
 504
 505 ;;;###autoload(autoload 'xwem-launch-program-other-frame "xwem-launcher" "" t)
 506 (define-xwem-command xwem-launch-program-other-frame (cmd &optional arg)
 507   "Run programm in other frame.
 508 If prefix ARG is specified - select newly created client."
 509   (xwem-interactive "_eLaunch Other Frame: \nP")
 510
 511   (funcall xwem-launcher-frame-type cmd arg))
 512
 513 (defsubst xwem-launch (cmd)
 514   "Execute CMD using `xwem-launcher'."
 515   (funcall xwem-launcher-function cmd))
 516
 517 ;;;###autoload
 518 (defun xwem-launch-generic-program (cmd sarg)
 519   "Run generic program CMD with arguments SARG."
 520   (xwem-launch (mapconcat #'identity (list cmd sarg) " ")))
 521
 522 ;; Executing xterm
 523 (defun xwem-xterm-construct-cmd (arg)
 524   "Construct xterm command according to ARG."
 525   (let ((fn (symbol-value
 526              (intern-soft (concat "xwem-xterm-font" (int-to-string arg)))))
 527         (cmd xwem-xterm-program))
 528
 529     (when (and (stringp fn) (> (length fn) 0))
 530       (setq cmd (concat cmd " " xwem-xterm-font-argument " " fn)))
 531     cmd))
 532
 533 ;;;###autoload(autoload 'xwem-launch-xterm "xwem-launcher" "" t)
 534 (define-xwem-command xwem-launch-xterm (arg)
 535   "Run xterm program `xwem-xterm-program' with ARG as font argument."
 536   (xwem-interactive "p")
 537
 538   (let ((cmd (xwem-xterm-construct-cmd arg)))
 539     (xwem-launch cmd)))
 540
 541 ;;;###autoload(autoload 'xwem-launch-xterm-other-win "xwem-launcher" "" t)
 542 (define-xwem-command xwem-launch-xterm-other-win (arg)
 543   "Execute xterm in other window, ARG have same meaning as in `xwem-launch-xterm'."
 544   (xwem-interactive "p")
 545
 546   (let ((xwem-launcher-function xwem-launcher-split-type))
 547     (xwem-launch-xterm arg)))
 548
 549 ;;;###autoload(autoload 'xwem-launch-xterm-other-frame "xwem-launcher" "" t)
 550 (define-xwem-command xwem-launch-xterm-other-frame (arg)
 551   "Execute xterm in other frame, ARG have same meaning as in `xwem-launch-xterm'."
 552   (xwem-interactive "p")
 553
 554   (let ((xwem-launcher-function xwem-launcher-frame-type))
 555     (xwem-launch-xterm arg)))
 556
 557 ;; Executing lupe
 558 ;;;###autoload(autoload 'xwem-launch-lupe "xwem-launcher" "" t)
 559 (define-xwem-command xwem-launch-lupe (arg)
 560   "Run lupe `xwem-lupe-program' with `xwem-lupe-arguments'.
 561 Prefix ARG is actually unused."
 562   (xwem-interactive "P")
 563
 564   (xwem-launch-generic-program xwem-lupe-program xwem-lupe-arguments))
 565
 566 ;;;###autoload(autoload 'xwem-launch-lupe-other-win "xwem-launcher" "" t)
 567 (define-xwem-command xwem-launch-lupe-other-win (arg)
 568   "Run lupe in other window.
 569 Prefix ARG is actually unused."
 570   (xwem-interactive "P")
 571
 572   (let ((xwem-launcher-function xwem-launcher-split-type))
 573     (xwem-launch-lupe arg)))
 574
 575 ;;;###autoload(autoload 'xwem-launch-lupe-other-frame "xwem-launcher" "" t)
 576 (define-xwem-command xwem-launch-lupe-other-frame (arg)
 577   "Run lupe in other frame.
 578 Prefix ARG is actually unused."
 579   (xwem-interactive "P")
 580
 581   (let ((xwem-launcher-function xwem-launcher-frame-type))
 582     (xwem-launch-lupe arg)))
 583
 584 ;;;###autoload(autoload 'xwem-launch-xlock "xwem-launcher" "" t)
 585 (define-xwem-command xwem-launch-xlock ()
 586   "Launch `xwem-xlock-program' with `xwem-xlock-arguments'."
 587   (xwem-interactive)
 588
 589   (xwem-launch-generic-program xwem-xlock-program xwem-xlock-arguments))
 590
 591 ;;;; Launcher dockapp
 592 (define-xwem-face xwem-launch-dock-face
 593   `(((medium) (:foreground "gray70"))
 594     ((light) (:foreground "white"))
 595     ((dark) (:foreground "black"))
 596     (t (:foreground "gray70" :background "black")))
 597   "Default background face for launcher docks."
 598   :group 'xwem-launcher
 599   :group 'xwem-faces)
 600
 601 (defvar xwem-launch-dock-keymap
 602   (let ((map (make-sparse-keymap)))
 603     (define-key map [button1] 'xwem-launch-dock-down)
 604     (define-key map [button1up] 'xwem-launch-dock-launch)
 605     (define-key map [button3] 'xwem-launch-dock-menu)
 606     map)
 607   "Keymap for launch docks.")
 608
 609 ;; Macroses to access ladock internals
 610 (defmacro xwem-ladock-state (win)
 611   `(X-Win-get-prop ,win 'ladock-state))
 612 (defsetf xwem-ladock-state (win) (state)
 613   `(X-Win-put-prop ,win 'ladock-state ,state))
 614 (defmacro xwem-ladock-action (win)
 615   `(X-Win-get-prop ,win 'ladock-action))
 616 (defsetf xwem-ladock-action (win) (action)
 617   `(X-Win-put-prop ,win 'ladock-action ,action))
 618 (defmacro xwem-ladock-pixmap (win)
 619   `(X-Win-get-prop ,win 'ladock-pixmap))
 620 (defsetf xwem-ladock-pixmap (win) (action)
 621   `(X-Win-put-prop ,win 'ladock-pixmap ,action))
 622
 623 ;;;###autoload(autoload 'xwem-launch-dock-down "xwem-launcher" "" t)
 624 (define-xwem-command xwem-launch-dock-down (ev)
 625   "Default command when button is down."
 626   (xwem-interactive (list xwem-last-event))
 627   (unless (button-event-p ev)
 628     (error 'xwem-error "`xwem-launch-dock-down' must be bound to mouse event"))
 629
 630   ;; Push the button
 631   (setf (xwem-ladock-state (X-Event-win xwem-last-xevent)) 'down)
 632   (xwem-ladock-redraw (X-Event-win xwem-last-xevent)))
 633
 634 ;;;###autoload(autoload 'xwem-launch-dock-launch "xwem-launcher" "" t)
 635 (define-xwem-command xwem-launch-dock-launch (ev)
 636   "Launch command for launch dock."
 637   (xwem-interactive (list xwem-last-event))
 638   (unless (button-event-p ev)
 639     (error 'xwem-error "`xwem-launch-dock-up' must be bound to mouse event"))
 640
 641   ;; Pop the button
 642   (setf (xwem-ladock-state (X-Event-win xwem-last-xevent)) 'up)
 643   (xwem-ladock-redraw (X-Event-win xwem-last-xevent))
 644
 645   (when (and (< (X-Event-xbutton-event-x xwem-last-xevent)
 646                 xwem-launch-dock-width)
 647              (< (X-Event-xbutton-event-y xwem-last-xevent)
 648                 xwem-launch-dock-height))
 649     ;; React on ButtonRelease only if it released within ladock
 650     ;; window.
 651     (let* ((action (xwem-ladock-action (X-Event-win xwem-last-xevent)))
 652            (atype (car action))
 653            (acmd (cdr action)))
 654       (cond ((eq atype 'elisp) (eval (read acmd)))
 655             ((eq atype 'cmd) (xwem-execute-program acmd))
 656             (t (xwem-message 'warning "Unknown action type=`%s'" atype))))))
 657
 658 ;;;###autoload(autoload 'xwem-launch-dock-menu "xwem-launcher" "" t)
 659 (define-xwem-command xwem-launch-dock-menu (action)
 660   "Popup menu."
 661   (xwem-interactive (list (xwem-ladock-action (X-Event-win xwem-last-xevent))))
 662
 663   (let ((cls (delq nil (mapcar #'(lambda (cl)
 664                                    (and (string-match (cdr action)
 665                                                       (xwem-cl-wm-command cl))
 666                                         cl))
 667                                xwem-clients)))
 668         menu)
 669
 670     ;; Sort clients
 671     (setq cls (sort cls #'(lambda (cl1 cl2)
 672                             (and (xwem-frame-p (xwem-cl-frame cl1))
 673                                  (xwem-frame-p (xwem-cl-frame cl2))
 674                                  (> (xwem-frame-num (xwem-cl-frame cl1))
 675                                     (xwem-frame-num (xwem-cl-frame cl2)))))))
 676
 677     (setq menu
 678           (list "Clients" :filter
 679                 #'(lambda (not-used)
 680                     (nconc
 681                      (mapcar #'(lambda (cl)
 682                                  (let ((frame (xwem-cl-frame cl))
 683                                        (name (xwem-cl-wm-name cl)))
 684                                    (vector
 685                                     (if (xwem-frame-p frame)
 686                                         (format "[%d](%s): %s"
 687                                                 (xwem-frame-num (xwem-cl-frame cl))
 688                                                 (xwem-frame-name (xwem-cl-frame cl))
 689                                                 name)
 690                                       name)
 691                                     `(xwem-cl-pop-to-client ,cl)
 692                                     :active (xwem-non-dummy-client-p cl))))
 693                              cls)
 694                      (list
 695                       "---"
 696                       (vector "Destroy"
 697                               `(xwem-launch-button-stop
 698                                 ,(X-Event-win xwem-last-xevent) t)))))))
 699     (xwem-popup-menu menu)))
 700
 701 (define-xwem-deffered xwem-ladock-redraw (xwin)
 702   "Redraw launcher button dock XWIN."
 703   (xwem-misc-draw-shadow
 704    (X-Win-dpy xwin) (xwem-ladock-pixmap xwin)
 705    (xwem-face-get-gc 'xwem-launch-dock-face
 706      (if (eq (xwem-ladock-state xwin) 'down) '(dark) '(light)))
 707    (xwem-face-get-gc 'xwem-launch-dock-face
 708      (if (eq (xwem-ladock-state xwin) 'down) '(light) '(dark)))
 709    0 0 xwem-launch-dock-width xwem-launch-dock-height xwem-launch-dock-thick)
 710
 711   (XCopyArea (xwem-dpy) (xwem-ladock-pixmap xwin) xwin
 712              (XDefaultGC (xwem-dpy)) 0 0
 713              xwem-launch-dock-width xwem-launch-dock-height 0 0))
 714
 715 (defun xwem-ladock-evhandler (xdpy xwin xev)
 716   "On XDPY and launcher dock XWIN handle event XEV."
 717   (X-Event-CASE xev
 718     ((:X-Expose :X-MapNotify)
 719      (xwem-ladock-redraw xwin))
 720
 721     ((:X-ButtonPress :X-ButtonRelease)
 722      (xwem-overriding-local-map xwem-launch-dock-keymap
 723        (xwem-dispatch-command-xevent xev)))
 724
 725     (:X-DestroyNotify
 726      (xwem-launch-button-stop
 727       (X-Event-xdestroywindow-window xev)))))
 728
 729 (defun xwem-launch-button-stop (xwin &optional force)
 730   "Destoy launch dockapp button XWIN.
 731 If FORCE is non-nil also destroy XWIN."
 732   (XFreePixmap (X-Win-dpy xwin) (xwem-ladock-pixmap xwin))
 733
 734   (setf (xwem-ladock-pixmap xwin) nil
 735         (xwem-ladock-state xwin)nil
 736         (xwem-ladock-action xwin)nil)
 737
 738   ;; Remove events handler
 739   (X-Win-EventHandler-rem xwin 'xwem-ladock-evhandler)
 740
 741   (when force
 742     (XDestroyWindow (X-Win-dpy xwin) xwin)))
 743
 744 ;;;###autoload
 745 (defun xwem-launch-button-start (xpm-file action &optional dockid
 746                                           dockgroup dockalign)
 747   "Create new dockapp button with XPM-FILE image and doing ACTION on click.
 748 ACTION is cons cell wher car is one of 'elisp or 'cmd and cdr is string.
 749 For 'elisp car, cdr is real elisp expression, to evaluate on click.
 750 For 'cmd  car, cdr is cmd to run on click."
 751   (let ((xwin (XCreateWindow (xwem-dpy) nil 0 0
 752                              xwem-launch-dock-width
 753                              xwem-launch-dock-height
 754                              0 nil nil nil
 755                              (make-X-Attr
 756                               :event-mask (Xmask-or XM-Exposure XM-StructureNotify
 757                                                     XM-ButtonPress XM-ButtonRelease)
 758                               :override-redirect t))))
 759
 760     ;; Create pixmap
 761     (setf (xwem-ladock-pixmap xwin)
 762           (XCreatePixmap
 763            (xwem-dpy) (make-X-Pixmap :dpy (xwem-dpy)
 764                                      :id (X-Dpy-get-id (xwem-dpy)))
 765            xwin (XDefaultDepth (xwem-dpy))
 766            xwem-launch-dock-width xwem-launch-dock-height)
 767           (xwem-ladock-state xwin) 'up
 768           (xwem-ladock-action xwin) action)
 769
 770     ;; Initial pixmaps setup
 771     (XFillRectangle (xwem-dpy) (xwem-ladock-pixmap xwin)
 772                     (xwem-face-get-gc 'xwem-launch-dock-face '(medium)) 0 0
 773                     (X-Pixmap-width (xwem-ladock-pixmap xwin))
 774                     (X-Pixmap-height (xwem-ladock-pixmap xwin)))
 775     (let* ((ipix (X:xpm-pixmap-from-file
 776                   (xwem-dpy) xwin (expand-file-name xpm-file xwem-icons-dir)))
 777            (imask (X:xpm-pixmap-from-file
 778                    (xwem-dpy) xwin (expand-file-name xpm-file xwem-icons-dir) t))
 779            (x-orig (/ (- xwem-launch-dock-width (X-Pixmap-width ipix)) 2))
 780            (y-orig (/ (- xwem-launch-dock-height (X-Pixmap-height ipix)) 2))
 781            (clgc (XCreateGC
 782                   (xwem-dpy) ipix
 783                   (make-X-Gc :dpy (xwem-dpy)
 784                              :id (X-Dpy-get-id (xwem-dpy))
 785                              :clip-x-origin x-orig
 786                              :clip-y-origin y-orig
 787                              :clip-mask imask))))
 788       ;; Copy to our pixmap
 789       (XCopyArea (xwem-dpy) ipix (xwem-ladock-pixmap xwin) clgc
 790                  0 0 (X-Pixmap-width ipix) (X-Pixmap-height ipix)
 791                  x-orig y-orig)
 792       ;; Release resources
 793       (XFreeGC (xwem-dpy) clgc)
 794       (XFreePixmap (xwem-dpy) imask)
 795       (XFreePixmap (xwem-dpy) ipix))
 796
 797     (when xwem-misc-turbo-mode
 798       (XSetWindowBackgroundPixmap (xwem-dpy) xwin (xwem-ladock-pixmap xwin)))
 799
 800     ;; Install events handler
 801     (X-Win-EventHandler-add xwin 'xwem-ladock-evhandler nil
 802                             (list X-Expose X-MapNotify X-ButtonPress
 803                                   X-ButtonRelease X-DestroyNotify))
 804
 805     (xwem-XTrayInit (xwem-dpy) xwin dockid dockgroup dockalign)
 806     xwin))
 807
 808 \f
 809 ;;;; Open file
 810 ;;;###autoload
 811 (defcustom xwem-open-file-commands-alist
 812   '(("\\.\\(ps\\|ps_pages\\|eps\\)\\'" . "gv")
 813     ("\\.pdf\\'" . "xpdf")
 814     ("\\.\\(jpe?g\\|gif\\|png\\)\\'" . "display")
 815     ("\\.dvi\\'" . "xdvi")
 816     ("\\.chm\\'" . "xchm")
 817     ("\\.djvu\\'" . "djview")
 818     ("\\.txt\\'" . "xterm -e less"))
 819   "*Alist specifying how to view special types of files.
 820 `xwem-open-file-commands-alist' can be dynamically changed by
 821 `xwemw-open-file' when registering new file extensions, so we
 822 recommend to use `xwem-desktop' package to save/restore
 823 `xwem-open-file-commands-alist' value between sessions."
 824   :group 'xwem-launcher
 825   :type '(repeat (cons (string :tag "Regexp")
 826                        (string :tag "Command"))))
 827
 828 (defcustom xwem-open-file-registration 'query
 829   "*Defines the behaviour of `xwem-open-file' when file extension is
 830 not defined in `xwem-open-file-commands-alist'.
 831
 832  nil - Do nothing.
 833  t - Register new extensions in `xwem-open-file-commands-alist'.
 834  query - Query about registration."
 835   :group 'xwem-launcher
 836   :type '(choice (const :tag "No registration" nil)
 837                  (const :tag "Auto registration" t)
 838                  (const :tag "Query for registration" query)))
 839
 840 ;;;###xwem-autoload
 841 (defun xwem-file-find-command (filename)
 842   "Find appropriate command to open FILENAME file."
 843   (let ((cmds xwem-open-file-commands-alist))
 844     (while (and cmds (not (string-match (caar cmds) filename)))
 845       (setq cmds (cdr cmds)))
 846     (cdr (car cmds))))
 847
 848 ;;;###autoload(autoload 'xwem-open-file "xwem-launcher" "Open file with appopriate command" t)
 849 (define-xwem-command xwem-open-file (file &optional command)
 850   "Open FILE with command specified by COMMAND.
 851 If prefix arg is specified, expicitely query for the COMMAND."
 852   (xwem-interactive
 853    (let* ((file (expand-file-name (xwem-read-filename "Find File: ")))
 854           (cmd (xwem-file-find-command file)))
 855      (when (or xwem-prefix-arg
 856                (not cmd))
 857        (setq cmd (xwem-read-external-command "Command: "))
 858        ;; Try to register FILE extension in
 859        ;; `xwem-open-file-commands-alist'.
 860        (when (and (not xwem-prefix-arg)
 861                   xwem-open-file-registration)
 862          (let ((fext (and (string-match "\\.\\([^.]+\\)\\'" file)
 863                           (match-string 1 file))))
 864            (when (and fext
 865                       (or (eq xwem-open-file-registration t)
 866                           (xwem-under-minibuffer
 867                            (y-or-n-p (format "Register '%s' extension?: "
 868                                              fext)))))
 869              (push (cons (concat "\\." fext "\\'") cmd)
 870                    xwem-open-file-commands-alist)))))
 871        (list file cmd)))
 872
 873   ;; Fixate FILE in case `xwem-open-file' called non-interactively
 874   (setq file (expand-file-name file))
 875   (unless command
 876     (setq command (xwem-file-find-command file)))
 877
 878   (xwem-launch (format "%s '%s'" command file)))
 879
 880 \f
 881 (provide 'xwem-launcher)
 882
 883 ;;; xwem-launcher.el ends here