;;; sawfish-homebrew.jl --- custom sawfish functions

;; Author: Mark Triggs <mst@dishevelled.net>
;; Time-stamp: "2004-12-24 10:03:38 mst"

;; This file is free software; you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by the
;; Free Software Foundation; either version 2, or (at your option) any
;; later version.

;; This file is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the Free
;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
;; 02111-1307, USA.

;;; Code:

(defvar notify-progs nil "Commands which when run should popup a 'Loading' text
box")
(defvar mst-windows-on-own-workspace nil)

(defvar meta-key "Hyper")

(defun meta+ (key)
  (concat meta-key "-" key))

;; load certain windows on their own workspace. Don't place a window on a
;; different workspace if there are already other similar windows around.
(add-hook 'before-add-window-hook
          (lambda (new-window)
            (mapc #'(lambda (regex)
                      (when (string-match regex (window-name new-window))
                        (unless (filter-windows
                                 (lambda (w)
                                   (and (string-match regex (window-name w))
                                        (not (equal w new-window)))))
                          (select-workspace (find-free-workspace))
                          (set-input-focus new-window))))
                  mst-windows-on-own-workspace)))


(custom-set-typed-variable
 (quote wm-modifier-value) (quote (hyper)) (quote modifier-list))


(defun try-require (sym)
  (condition-case nil
      (require sym)
    (error nil)))

(and (try-require 'waffle) (waffle-initialize))
(try-require 'message)

(setq orig-system system)
(add-hook 'add-window-hook (lambda () (do-message nil)))
(defun system (cmd #!optional quiet)
  (when (and (member (car (string-split " " cmd)) notify-progs)
             (not quiet)
             (prog-available (list (car (string-split " " cmd)))))
    (do-message (concat "Loading " (car (string-split " " cmd)) "...")))
  (orig-system cmd))


(defvar clipboard-preview-clip-length 60)

(defun clipboard-preview ()
  "Show the contents of the clipboard in a message window"
  (let ((c (string-replace "\n" " " (x-get-selection 'PRIMARY))))
    (if (< (length c) clipboard-preview-clip-length)
        (do-message-until-timeout c)
      (do-message-until-timeout (format nil "%s ..."
                          (substring c 0 clipboard-preview-clip-length))))))


(defun do-message-until-timeout (message &optional (timeout 1))
  (do-message message)
  (make-timer (lambda () (do-message nil)) timeout))

(defun do-message (str)
  (if (boundp 'fancy-message)
      (if str
          (fancy-message
           (if (consp str) str (list str))
           `((background . ,(get-color "black"))
             (foreground . ,(get-color "white"))
             (padding . ,(cons 10 10))
             (border-width . 1)
             (border-color . ,(get-color "white"))))
        (hide-fancy-message))
    (display-message str)))

(defun prog-available (commands)
  "Return the first command in the list of commands that is avaiable on the
  system."
  (cond ((null commands) nil)
        ((some #'identity
               (mapcar (lambda (dir)
                         (file-exists-p
                          (concat dir "/" (car commands))))
                       (string-split ":" (getenv "PATH"))))
         (car commands))
        (t (prog-available (cdr commands)))))


(defun jump-exec-available (programs)
  "Given a list of lists of the form (\"command\" \"command line arguments\"
\"Window Title Regexp\" \"Closure to execute if focused\"), find the entry
whose command exists on the system, and return a closure which calls
jump-or-exec."
  (let ((match (car (member-if
                     (lambda (entry)
                       (prog-available (list (car entry))))
                     programs))))
    (if match
        (list jump-or-exec (nth 2 match)
              (concat (car match) " " (cadr match))
              (nth 3 match))
      (lambda () nil))))

(defun workspace-mostly-empty-p (w)
  "Find a workspace with no visible windows"
  (null (workspace-windows w)))

(defun find-free-workspace ()
  "Find a free workspace and jump to it"
  (interactive)
  (let ((counter 0))
    (while (not (workspace-mostly-empty-p counter))
      (setq counter (+ counter 1)))
    counter))

(defun jump-or-exec (re prog #!optional onfocused)
  "jump to a window matched by re, or start program otherwise."
  ;; if a function onfocused is passed, it will be called if the window
  ;; is already focused
  (catch 'return
    (let ((wind (and re (get-window-by-name-re re))))
      (if (functionp onfocused)         ; check if already focused
          (let ((curwin (input-focus)))
            (if curwin
                (if (string-match re (window-name curwin))
                    (progn
                      (funcall onfocused)
                      (throw 'return))))))
      (if (windowp wind)
          (display-window wind)
        (when prog
          (system (concat prog " &")))))))

(defun window-workspace (w)
  (car (window-get w 'workspaces)))

(defun some (pred lst)
  (cond ((null lst) nil)
        ((pred (car lst)) t)
        (t (some pred (cdr lst)))))

(defun monitor-off ()
  "Switch off my monitor"
  (system "xset dpms force off &"))

(defun battery ()
  "show the current battery level"
  (system "osdbattery &"))

(bind-keys global-keymap
 	(meta+ "v") '(type-in (x-get-selection 'PRIMARY) (input-focus)))

(defmacro push (what where)
  `(setq ,where (cons ,what ,where)))

(defmacro pop (where)
  `(prog1
       (car ,where)
     (setq ,where (cdr ,where))))

(defun get-window-by-class-re (regexp)
  (car (sort (filter-windows
              (lambda (w) (string-match regexp (window-class w))))
             (lambda (w1 w2) (< (window-workspace w1)
                                (window-workspace w2))))))

(defmacro save-pointer-excursion (&rest body)
  (let ((old-position (gensym)))
    `(let ((,old-position (query-pointer)))
       (unwind-protect (progn ,@body)
         (warp-cursor (car ,old-position) (cdr ,old-position))))))

(defun refocus-firebird ()
  (interactive)
  (let ((firebird (get-window-by-name-re "Firefox")))
    (when (= current-workspace (window-workspace firebird))
      (display-window firebird)
      (let ((position (window-position firebird)))
        (save-pointer-excursion
         (warp-cursor (+ (car position) 10) (+ (cdr position) 80))
         (synthesize-event "button1-click" firebird))))))

(provide 'sawfish-homebrew)