utils.lisp 18 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475
  1. ;;; utils.lisp --- Additional variables, functions and commands
  2. ;; Copyright © 2013–2017 Alex Kost <alezost@gmail.com>
  3. ;; This program is free software; you can redistribute it and/or modify
  4. ;; it under the terms of the GNU General Public License as published by
  5. ;; the Free Software Foundation, either version 3 of the License, or
  6. ;; (at your option) any later version.
  7. ;;
  8. ;; This program is distributed in the hope that it will be useful,
  9. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  11. ;; GNU General Public License for more details.
  12. ;;
  13. ;; You should have received a copy of the GNU General Public License
  14. ;; along with this program. If not, see <http://www.gnu.org/licenses/>.
  15. ;;; Code:
  16. (in-package :stumpwm)
  17. ;;; Floating windows
  18. (defun al/float-window-focus-forward
  19. (window-list &optional (window (group-current-window
  20. (current-group))))
  21. "Focus the next window in WINDOW-LIST after WINDOW."
  22. (let* ((wins (cdr (member window window-list)))
  23. (nw (if wins
  24. (car wins)
  25. ;; If the last window in the list is focused, then
  26. ;; focus the first one.
  27. (car window-list))))
  28. (and nw (focus-window nw))))
  29. (defcommand (al/float-window-other float-group) () ()
  30. "Focus previously focused floating window."
  31. (focus-window (cadr (group-windows (current-group)))))
  32. (defcommand (al/float-window-next float-group) () ()
  33. "Focus next floating window."
  34. (al/float-window-focus-forward
  35. (stumpwm::sort-windows (current-group))))
  36. (defcommand (al/float-window-previous float-group) () ()
  37. "Focus previous floating window."
  38. (al/float-window-focus-forward
  39. (nreverse (stumpwm::sort-windows (current-group)))))
  40. (defcommand (al/move-float-window float-group)
  41. (x y) ((:number "+ X: ") (:number "+ Y: "))
  42. "Move current floating window by X and Y pixels."
  43. (float-window-move-resize
  44. (current-window)
  45. :x (+ (window-x (current-window)) x)
  46. :y (+ (window-y (current-window)) y)))
  47. (defcommand (al/resize-float-window float-group)
  48. (width height) ((:number "+ Width: ") (:number "+ Height: "))
  49. "Resize current floating window by WIDTH and HEIGHT pixels."
  50. (float-window-move-resize
  51. (current-window)
  52. :width (+ (window-width (current-window)) width)
  53. :height (+ (window-height (current-window)) height)))
  54. (defcommand (al/float-window-gravity float-group)
  55. (gravity) ((:gravity "Gravity: "))
  56. "Move current floating window to a particular place of the screen.
  57. GRAVITY controls where the window will appear. Possible values are:
  58. :center, :top, :right, :bottom, :left, :top, :top-left, :bottom-right,
  59. :bottom-left."
  60. (let* ((screen-width (screen-width (current-screen)))
  61. (screen-height (screen-height (current-screen)))
  62. (window-width (+ (window-width (current-window))
  63. (* 2 *float-window-border*)))
  64. (window-height (+ (window-height (current-window))
  65. *float-window-border*
  66. *float-window-title-height*))
  67. (x-right (- screen-width window-width))
  68. (x-center (round (/ x-right 2)))
  69. (y-bottom (- screen-height window-height))
  70. (y-center (round (/ y-bottom 2)))
  71. (coords (ccase gravity
  72. (:center (cons x-center y-center))
  73. (:top-left (cons 0 0))
  74. (:top (cons nil 0))
  75. (:top-right (cons x-right 0))
  76. (:right (cons x-right nil))
  77. (:bottom-right (cons x-right y-bottom))
  78. (:bottom (cons nil y-bottom))
  79. (:bottom-left (cons 0 y-bottom))
  80. (:left (cons 0 nil)))))
  81. (float-window-move-resize
  82. (current-window)
  83. :x (car coords) :y (cdr coords))))
  84. ;;; Windows, frames and groups
  85. (defun al/class-window-p (class &optional (win (current-window)))
  86. "Return T if a window WIN is of class CLASS."
  87. (and win (string= class (window-class win))))
  88. (defcommand al/focus-window-by-class (class) ((:string "Window class: "))
  89. "Focus window class CLASS.
  90. Return the window or nil if there is no such."
  91. (if (al/class-window-p class)
  92. (current-window)
  93. (let ((win (car (or ;; priority to the window from the current group
  94. (find-matching-windows (list :class class) nil nil)
  95. (find-matching-windows (list :class class) t t)))))
  96. (if win
  97. (focus-all win)
  98. (message "No ~a window." class))
  99. win)))
  100. (defcommand al/gmove-to-other-group () ()
  101. "Move the current window to the other group and go to that group."
  102. (let ((group (car (remove-if (lambda (g) (eq g (current-group)))
  103. (screen-groups (current-screen))))))
  104. (if group
  105. (progn (gmove group)
  106. (switch-to-group group))
  107. (echo "There is only one group."))))
  108. (defcommand (al/fother tile-group) () ()
  109. "Jump to the previously selected frame.
  110. This is a substitution for `fother': the problem with `fother' is that
  111. it does nothing if the last frame does not exist anymore. This command
  112. simply moves the focus to the next existing frame."
  113. (let* ((group (current-group))
  114. (frames (group-frames group))
  115. (last-frame (tile-group-last-frame group)))
  116. (if (and last-frame
  117. (find last-frame frames))
  118. (focus-frame group last-frame)
  119. (focus-frame-after group frames))))
  120. (defun al/set-frames (frames &optional (populatep t))
  121. "Display FRAMES in the current group.
  122. The first frame will become the current one and will contain the current
  123. window. If POPULATEP is nil, do not populate the rest frames with
  124. windows."
  125. (let* ((screen (current-screen))
  126. (group (screen-current-group screen))
  127. (head (current-head group))
  128. (cur-window (group-current-window group))
  129. (cur-frame (first frames)))
  130. (mapc (lambda (w)
  131. (setf (window-frame w) cur-frame))
  132. (group-windows group))
  133. (mapc (lambda (f)
  134. (setf (frame-window f) nil))
  135. (rest frames))
  136. (setf (frame-window cur-frame) cur-window
  137. (tile-group-frame-head group head) frames)
  138. (when populatep
  139. (populate-frames group))
  140. (focus-frame group cur-frame)
  141. (update-decoration cur-window)
  142. (sync-frame-windows group cur-frame)))
  143. ;;; Showing and toggling the root window
  144. (defvar *al/window-configuration* nil
  145. "Last saved window configuration.")
  146. (defcommand al/show-root () ()
  147. "Show root window."
  148. (when (cdr (group-frames (current-group)))
  149. ;; Make one frame if necessary.
  150. (only))
  151. (fclear))
  152. (defcommand al/toggle-root () ()
  153. "Toggle between root window and last window configuration."
  154. (if (current-window)
  155. (progn
  156. (setf *al/window-configuration* (dump-group (current-group)))
  157. (al/show-root))
  158. ;; Current window is root.
  159. (if *al/window-configuration*
  160. (restore-group (current-group) *al/window-configuration*)
  161. (echo "There is no saved window configuration yet."))))
  162. ;;; Sending keys to windows
  163. (defcommand al/send-key (key &optional (win (current-window))) (:key)
  164. "Send key press and key release events for KEY to window WIN."
  165. (let ((xwin (window-xwin win)))
  166. (multiple-value-bind (code state) (key-to-keycode+state key)
  167. (flet ((send (event)
  168. (xlib:send-event xwin event (xlib:make-event-mask event)
  169. :display *display*
  170. :root (screen-root (window-screen win))
  171. :x 0 :y 0 :root-x 0 :root-y 0
  172. :window xwin :event-window xwin
  173. :code code
  174. :state state)))
  175. (send :key-press)
  176. (send :key-release)
  177. (xlib:display-finish-output *display*)))))
  178. (defun al/send-keys (keys &key (win (current-window))
  179. (sleep 0) loop loop-quit-var)
  180. "Send keys to the window WIN.
  181. KEYS is a string for `kbd', a list of such strings or functions or a
  182. function returning a string or a list.
  183. SLEEP is a time between sending keys or a function for defining
  184. this time.
  185. If LOOP is t, send keys in a loop (the whole combination of strings,
  186. lists and functions in KEYS will be repeated). It will be broken when
  187. a variable which name is passed to LOOP-QUIT-VAR returns t. Be aware,
  188. infinite loop is not a joke."
  189. (labels ((send-key (key)
  190. (al/send-key (kbd key) win)
  191. ;; (print key)
  192. (sleep (if (numberp sleep)
  193. sleep
  194. (funcall sleep))))
  195. (send-keys (key-def &optional loop)
  196. (loop
  197. do (cond
  198. ((stringp key-def)
  199. (send-key key-def))
  200. ((listp key-def)
  201. (dolist (key key-def) (send-keys key)))
  202. ((functionp key-def)
  203. (send-keys (funcall key-def)))
  204. (t (error "Keys should be a string, a list or a function")))
  205. while (and loop
  206. (null (and loop-quit-var (eval loop-quit-var)))))))
  207. (send-keys keys loop)
  208. (echo "Quitting sending keys.")))
  209. ;;; Interacting with Shepherd user services
  210. ;; The following makes sense only for my shepherd user services, which
  211. ;; can be started in different X instances/displays/VTs:
  212. ;; <https://github.com/alezost/shepherd-config>
  213. (defun al/herd-command (service &optional (action "restart")
  214. (display (getenv "DISPLAY")))
  215. "Return 'herd ACTION SERVICE:DISPLAY' command.
  216. DISPLAY is a display number (can be a number or string optionally
  217. beginning with ':') where a service is started."
  218. (format nil "herd ~a ~a:~a"
  219. action service
  220. (if (numberp display)
  221. display
  222. (string-left-trim ":" display))))
  223. (defun al/shepherd-service-started-p
  224. (service &optional (display (getenv "DISPLAY")))
  225. "Return non-nil, if Shepherd SERVICE is running."
  226. (let ((output (run-shell-command
  227. (al/herd-command service "status" display)
  228. t)))
  229. (search "started" output)))
  230. (defcommand al/toggle-shepherd-service
  231. (service &optional (display (getenv "DISPLAY")))
  232. ((:string "toggle Shepherd service: "))
  233. "Start/stop Shepherd SERVICE on DISPLAY."
  234. (let* ((startedp (al/shepherd-service-started-p service display)))
  235. (run-shell-command (al/herd-command service
  236. (if startedp "stop" "start")
  237. display))
  238. (message (concat "^5*~a~a^7* has been "
  239. (if startedp
  240. "^B^1*stopped"
  241. "^2*started")
  242. "^b^7*.")
  243. service display)))
  244. ;;; Interacting with emacs
  245. (defun al/emacs-window-p (&optional (window (current-window)))
  246. "Return non-nil, if WINDOW is Emacs window in the current frame."
  247. (and (al/class-window-p "Emacs" window)
  248. (or (not (eq (type-of (current-group)) 'tile-group))
  249. (eq (frame-window (tile-group-current-frame (current-group)))
  250. window))))
  251. (defcommand al/send-key-to-emacs (key) ((:key "Key: "))
  252. "Focus emacs window and send KEY to it."
  253. (let ((win (al/focus-window-by-class "Emacs")))
  254. (and win (al/send-key key win))))
  255. (defcommand al/emacs () ()
  256. "Start emacs unless it is already running, in which case focus it."
  257. (run-or-raise (al/herd-command "emacs")
  258. '(:class "Emacs")))
  259. (defcommand al/emacs-eval (arg &optional server-name) ((:shell "emacs-eval: "))
  260. "Evaluate ARG with emacsclient."
  261. (let ((args (list "--eval" arg)))
  262. (when server-name
  263. (setq args (append (list "--socket-name" server-name) args)))
  264. (run-prog "emacsclient" :args args :wait nil :search t)))
  265. (defcommand al/emacs-eval-show (arg) ((:shell "emacs-eval: "))
  266. "Evaluate ARG with emacsclient and raise emacs."
  267. (al/emacs-eval arg)
  268. (or (al/emacs-window-p) (al/emacs)))
  269. (defcommand al/emms-eval (arg &optional (server-name "server-emms"))
  270. ((:shell "emms-eval: "))
  271. "Evaluate ARG with emacsclient."
  272. (al/emacs-eval arg server-name))
  273. (defcommand al/emms-eval-show (arg) ((:shell "emms-eval: "))
  274. "Evaluate ARG with emacsclient and raise emacs."
  275. (al/emms-eval arg)
  276. (or (al/emacs-window-p) (al/emacs)))
  277. ;;; Interacting with conkeror
  278. (defcommand al/conkeror () ()
  279. "Start conkeror unless it is already running, in which case focus it."
  280. (run-or-raise (al/herd-command "conkeror")
  281. '(:class "Conkeror")))
  282. (defcommand al/conkeror-browse (url) ((:shell "Browse URL: "))
  283. "Browse URL with conkeror."
  284. (run-prog "conkeror" :args (list url) :wait nil :search t))
  285. (defcommand al/conkeror-browse-show (url) ((:shell "Browse URL: "))
  286. "Browse URL with conkeror and raise conkeror."
  287. (al/conkeror-browse url)
  288. (al/conkeror))
  289. (defcommand al/conkeror-eval (arg) ((:shell "conkeror-eval: "))
  290. "Evaluate ARG with 'conkeror -f'."
  291. (run-prog "conkeror" :args (list "-f" arg) :wait nil :search t))
  292. (defcommand al/conkeror-eval-show (arg) ((:shell "conkeror-eval: "))
  293. "Evaluate ARG with 'conkeror -f' and raise conkeror."
  294. (al/conkeror-eval arg)
  295. (al/conkeror))
  296. ;;; Interacting with other progs
  297. (defcommand al/xterm () ()
  298. "Start xterm unless it is already running, in which case focus it."
  299. (run-or-raise (al/herd-command "xterm")
  300. '(:class "XTerm")))
  301. (defcommand al/firefox () ()
  302. "Start firefox unless it is already running, in which case focus it."
  303. (run-or-raise (al/herd-command "firefox")
  304. '(:class "Firefox")))
  305. (defcommand al/toggle-unclutter () ()
  306. "Start/stop 'unclutter' on the current display."
  307. (al/toggle-shepherd-service "unclutter"))
  308. ;;; Mode line
  309. (defun al/mode-line-pos (pos)
  310. "Put the mode line at a position POS (can be :TOP or :BOTTOM)."
  311. (let ((screen (current-screen))
  312. (head (current-head)))
  313. (enable-mode-line screen head nil)
  314. (setf *mode-line-position* pos)
  315. (enable-mode-line screen head t)))
  316. (defcommand al/mode-line-on () ()
  317. "Turn the mode line on unconditionally."
  318. (enable-mode-line (current-screen) (current-head) t))
  319. (defcommand al/mode-line-bottom () ()
  320. "Put the mode line on the bottom of the screen."
  321. (al/mode-line-pos :bottom))
  322. (defcommand al/mode-line-top () ()
  323. "Put the mode line on the top of the screen."
  324. (al/mode-line-pos :top))
  325. ;;; Misc
  326. (defun al/random-float (bot top &optional (state *random-state*))
  327. "Return a random float between BOT and TOP bounds."
  328. (+ bot (random (- top bot) state)))
  329. (defun al/get-random-obj (objs)
  330. "Return a random object from alist OBJS.
  331. Each association is a pair of object and its probability (from 0 to
  332. 1). If the total probability is lower than 1, there is a chance to
  333. get nil."
  334. (let ((rnd (random 1.0))
  335. (prob 0))
  336. (loop
  337. for elm in objs
  338. do (setq prob (+ prob (cdr elm)))
  339. if (< rnd prob)
  340. return (car elm))))
  341. (defcommand al/banish-pointer () ()
  342. "Move mouse pointer to the top/center of the current screen."
  343. (let* ((screen (current-screen))
  344. (width (screen-width screen)))
  345. (warp-pointer screen (/ width 2) 0)))
  346. (defcommand al/yank-primary () ()
  347. "Insert X primary selection into the current window."
  348. (window-send-string (get-x-selection)))
  349. (defvar *al/ignore-emacs* nil
  350. "If non-nil, do not treat Emacs specially by `al/switch-frame-or-window'.")
  351. (defun al/switch-frame-or-window (switch-tile switch-float &optional key)
  352. "Select frame or window or emacs window.
  353. If current window is emacs and `*al/ignore-emacs*' is nil, send key
  354. sequence KEY to it.
  355. If current group is tiling, call SWITCH-TILE procedure.
  356. If current group is floating, call SWITCH-FLOAT procedure."
  357. (if (and key
  358. (al/emacs-window-p)
  359. (null *al/ignore-emacs*)
  360. ;; Ignore emacs anyway, if it has a single window.
  361. ;; The following code checks WINDOWS_NUM window property.
  362. ;; You can "teach" emacs to update this property by adding
  363. ;; this to your .emacs:
  364. ;; (add-hook 'window-configuration-change-hook
  365. ;; (lambda () (when (display-graphic-p)
  366. ;; (x-change-window-property
  367. ;; "WINDOWS_NUM"
  368. ;; (string (length (window-list)))
  369. ;; nil nil nil t))))
  370. (let ((windows-num (car (window-property (current-window)
  371. :WINDOWS_NUM))))
  372. (or (null windows-num)
  373. (/= 1 windows-num))))
  374. (al/send-key-to-emacs key)
  375. (if (eq (type-of (current-group)) 'tile-group)
  376. (funcall switch-tile)
  377. (funcall switch-float))))
  378. (defcommand al/other (&optional key) (:key)
  379. "Select previously selected frame or window or emacs window.
  380. If current window is emacs and `*al/ignore-emacs*' is nil, send key
  381. sequence KEY to it.
  382. If current group is tiling, select previously selected frame.
  383. If current group is floating, select previously selected window."
  384. (al/switch-frame-or-window #'al/fother #'al/float-window-other key))
  385. (defcommand al/next (&optional key) (:key)
  386. "Select next frame or window or emacs window.
  387. If current window is emacs and `*al/ignore-emacs*' is nil, send key
  388. sequence KEY to it.
  389. If current group is tiling, select next frame.
  390. If current group is floating, select next window."
  391. (al/switch-frame-or-window #'fnext #'al/float-window-next key))
  392. (defcommand al/toggle-ignore-emacs () ()
  393. "Toggle `*al/ignore-emacs*'."
  394. (setf *al/ignore-emacs* (not *al/ignore-emacs*))
  395. (message "^b^7*Switching between emacs windows ~a^b^7*."
  396. (if *al/ignore-emacs* "^B^1*disabled" "^2*enabled")))
  397. ;;; utils.lisp ends here