From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: Richard Stallman Newsgroups: gmane.emacs.devel Subject: [csh@freecode.dk: policy-switch.el 0.1] Date: Fri, 20 Jul 2007 09:42:21 -0400 Message-ID: Reply-To: rms@gnu.org NNTP-Posting-Host: lo.gmane.org Content-Type: text/plain; charset=ISO-8859-15 X-Trace: sea.gmane.org 1184938938 3741 80.91.229.12 (20 Jul 2007 13:42:18 GMT) X-Complaints-To: usenet@sea.gmane.org NNTP-Posting-Date: Fri, 20 Jul 2007 13:42:18 +0000 (UTC) To: emacs-devel@gnu.org Original-X-From: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Fri Jul 20 15:42:16 2007 Return-path: Envelope-to: ged-emacs-devel@m.gmane.org Original-Received: from lists.gnu.org ([199.232.76.165]) by lo.gmane.org with esmtp (Exim 4.50) id 1IBskI-0002G8-BM for ged-emacs-devel@m.gmane.org; Fri, 20 Jul 2007 15:42:15 +0200 Original-Received: from localhost ([127.0.0.1] helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.43) id 1IBskH-0004A8-En for ged-emacs-devel@m.gmane.org; Fri, 20 Jul 2007 09:42:13 -0400 Original-Received: from mailman by lists.gnu.org with tmda-scanned (Exim 4.43) id 1IBsjE-0003MI-W6 for emacs-devel@gnu.org; Fri, 20 Jul 2007 09:41:09 -0400 Original-Received: from exim by lists.gnu.org with spam-scanned (Exim 4.43) id 1IBsjD-0003Ka-DB for emacs-devel@gnu.org; Fri, 20 Jul 2007 09:41:08 -0400 Original-Received: from [199.232.76.173] (helo=monty-python.gnu.org) by lists.gnu.org with esmtp (Exim 4.43) id 1IBsjD-0003KK-4i for emacs-devel@gnu.org; Fri, 20 Jul 2007 09:41:07 -0400 Original-Received: from fencepost.gnu.org ([140.186.70.10]) by monty-python.gnu.org with esmtp (Exim 4.60) (envelope-from ) id 1IBsjC-0006c0-FG for emacs-devel@gnu.org; Fri, 20 Jul 2007 09:41:06 -0400 Original-Received: from rms by fencepost.gnu.org with local (Exim 4.60) (envelope-from ) id 1IBskP-0004gV-Jh; Fri, 20 Jul 2007 09:42:21 -0400 X-detected-kernel: Linux 2.6, seldom 2.4 (older, 4) X-BeenThere: emacs-devel@gnu.org X-Mailman-Version: 2.1.5 Precedence: list List-Id: "Emacs development discussions." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Original-Sender: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Errors-To: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Xref: news.gmane.org gmane.emacs.devel:75181 Archived-At: This seems possibly interesting. Would people please take a look at this? Please tell me how much you like it, and any ideas you have for making it better. ------- Start of forwarded message ------- X-Spam-Status: No, score=0.0 required=5.0 tests=UNPARSEABLE_RELAY autolearn=failed version=3.1.0 From: csh@freecode.dk (Christoffer S. Hansen) To: gnu-emacs-sources@gnu.org Organization: Church of Emacs Date: Wed, 18 Jul 2007 23:27:13 +0200 MIME-Version: 1.0 Content-Type: text/plain; charset=us-ascii Subject: policy-switch.el 0.1 policy-switch.el provides a flexible way of switching between window configurations that are persistent and can be inspected (currently an unsupported feature in standard GNU Emacs). A "policy" is an alist of window configurations referenced by a key (name of policy). Hope you find this feature useful. ;;; policy-switch.el -- Window configuration navigation utility. ;; Copyright (C) 2007 Christoffer S. Hansen ;; Author: Christoffer S. Hansen ;; Version: 0.1 ;; Keywords: window configuration, persistence ;; Maintainer: Christoffer S. Hansen ;; URL: http://www.emacswiki.org/cgi-bin/wiki/PolicySwitch ;; Time-stamp: <2007-07-18 18:35:41 csh> ;; This file is not part of GNU Emacs. ;; This file is part of policy-switch. ;; policy-switch 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. ;; Commentary: ;; This file allows you to navigate sets of window configurations ;; (policies) conveniently. ;; ;; BASIC SETUP: ;; ;; The following file should be in your load path: ;; ;; (add-to-list 'load-path "/path/to/policy-switch") ;; (require 'policy-switch) ;; ;; To achieve persistence across sessions, add the following to your ;; .emacs: ;; ;; (add-hook 'desktop-save-hook 'policy-switch-remove-unprintable-entities) ;; ;; ;; Restoring of a config within a session is automatically done when ;; the config's buffer objects are not alive anymore. However, some ;; modes can alter their content significantly, yet still keep the ;; buffer object alive. If the actual content upon creation time is ;; important to keep in a config's buffer, consider adding these major ;; modes to the `policy-switch-live-buffer-modes-restore' variable. ;; Then, the buffers will _always_ be restored when a config is ;; selected ;; ;; KEYBINDINGS ;; ;; The following is a suggested set of global keybindings for ;; policy-switch; binding all keys to the `C-c g' prefix: ;; ;; (global-set-key (kbd "C-c g n") 'policy-switch-policy-next) ;; (global-set-key (kbd "C-c g a") 'policy-switch-policy-add) ;; (global-set-key (kbd "C-c g g") 'policy-switch-policy-goto) ;; (global-set-key (kbd "C-c g p") 'policy-switch-policy-prev) ;; (global-set-key (kbd "C-c g r") 'policy-switch-policy-remove) ;; (global-set-key (kbd "C-c g N") 'policy-switch-config-next) ;; (global-set-key (kbd "C-c g P") 'policy-switch-config-prev) ;; (global-set-key (kbd "C-c g G") 'policy-switch-config-goto) ;; (global-set-key (kbd "C-c g A") 'policy-switch-config-add) ;; (global-set-key (kbd "C-c g R") 'policy-switch-config-remove) ;; (global-set-key (kbd "C-c g u") 'policy-switch-config-restore) ;; (global-set-key (kbd "C-c g m") 'policy-switch-toggle-mode-line) ;; To make full benefit of policy-switch it is useful to install the ;; planner libraries since they are used to achieve persistence of ;; gnus and bbdb buffer major modes. If not installed, they are ;; ignored by policy-switch (unless you provide a suitable replacement ;; function for them, see the documentation of ;; policy-switch-buffer-mode-handlers) ;; Code: (require 'cl) (require 'winner) (require 'desktop) (defvar policy-switch-policies-list () "List of all policies maintained by policy-switch. The list has the following form: ( (( . ( (( . ))))))") (defcustom policy-switch-live-buffer-modes-restore '(gnus-summary-mode gnus-article-mode bbdb-mode dictionary-mode help-mode) "List of major modes that needs to be restored in spite of a live buffer object being present.") (defcustom policy-switch-config-restore-policy 'needs-restoring "Specifies when to restore the config when selected. Valid values are: 'always Always restore the config. 'needs-restoring Restore the config when `policy-switch-config-needs-restoring', returns t. 'never Never restore the config automatically. ") (defcustom policy-switch-mode-line-p t "Whether policy status should be shown in the mode line.") (defcustom policy-switch-buffer-mode-handlers '((w3m-mode . policy-switch-buffer-info-w3m) (gnus-summary-mode . policy-switch-buffer-info-gnus) (bbdb-mode . policy-switch-buffer-info-bbdb) (help-mode . policy-switch-buffer-info-help) (dictionary-mode . policy-switch-buffer-info-dictionary) (gnus-article-mode . policy-switch-buffer-info-gnus)) "Alist of handler functions for buffer major modes. When a config is created this list is used to determine what function should have the responsibilty of creating buffer recover strings (if buffer is restorable by desktop, desktop takes precedence and this variable is not used). The string must be parsable by the Lisp interpreter and is evaluated whenever a config, whose buffers have their matching major-modes included, needs to be restored. The buffer from which the restore string must be created is current in the call. Functions take no arguments and must return the restored buffer object.") (defvar policy-switch-mode-line-elm nil) (defun policy-switch-policies-list-make-empty () "Make policy list empty." (setq policy-switch-policies-list nil)) (defun policy-switch-policy-add (name) "Add a policy with `NAME' to policy-switch." (interactive "MPolicy name: ") (when (assoc-string name policy-switch-policies-list) (error "Policy already exists")) (setq policy-switch-policies-list (append (list (list name ())) policy-switch-policies-list)) (message "Policy \"%s\" added" name)) (defun policy-switch-policy-remove (name) "Remove a policy given by NAME from policy-switch." (interactive (list (if policy-switch-policies-list (cond ((= (length policy-switch-policies-list) 1) (car (policy-switch-policy-get))) (t (completing-read "Remove policy: " (mapcar (lambda (policy) (car policy)) policy-switch-policies-list) nil t nil nil (caar policy-switch-policies-list) t))) nil))) (let ((policy-to-remove (policy-switch-policy-get name))) (setq policy-switch-policies-list (remq nil (mapcar (lambda (policy) (if (string= (car policy) (car policy-to-remove)) nil policy)) policy-switch-policies-list))) (message "Policy \"%s\" removed" name))) ;; getter's and setter's for policy list internals (defun policy-switch-policy-get (&optional policy-name) "Get the policy list specified by POLICY-NAME. Report error if policy do not exist or if policy list is empty." (let ((policy nil)) (setq policy-name (if (not policy-name) (caar policy-switch-policies-list) policy-name)) (if policy-switch-policies-list (progn (setq policy (assoc-string policy-name policy-switch-policies-list)) (if (not policy) (error "Policy \"%s\" do not exist" policy-name) policy)) (error "No policies defined")))) (defun policy-switch-configs-get (policy &optional raise-error-p) "Get the configs list specified by POLICY (policy is assumed to exist and extracted from call to `policy-switch-policy-get').If RAISE-ERROR-P is non-nil, report error if configs list is empty." (let ((configs-list (cadr policy))) (if (and raise-error-p (not configs-list)) (error "Configs list is empty in policy \"%s\"" (car policy)) configs-list))) (defun policy-switch-config-get (configname configs-list &optional raise-error-p) "Get the config specified by `CONFIGNAME' in the `CONFIGS-LIST'." (let* ((configname (if (not configname) (caar configs-list) configname)) (config (assoc-string configname configs-list))) (if (and raise-error-p (not config)) (error "Config \"%s\" do not exist" configname) config))) (defun policy-switch-config-window-obj (&optional config) "Retrieve window config object from `CONFIG', if given. Otherwise, get window config object from current config in current policy." (let ((config (if (not config) (policy-switch-config-get nil (policy-switch-configs-get (policy-switch-policy-get))) config))) (cadr config))) (defun policy-switch-config-win-data (&optional config) "Retrieve window data from `CONFIG', if given. Otherwise, get window data from current config in current policy." (let ((config (if (not config) (policy-switch-config-get nil (policy-switch-configs-get (policy-switch-policy-get))) config))) (caddr config))) (defun policy-switch-configs-list-make-empty (&optional policy-name) "Remove all configs in policy `POLICY', if given. Otherwise, remove all configs in current policy." (interactive) (let ((policy (policy-switch-policy-get policy-name))) (setcdr policy nil))) (defun policy-switch-config-add (name) "Add current config to current policy) and assign `NAME'." (interactive (list (if policy-switch-policies-list (read-string "Config name: ") nil))) (let* ((policy (policy-switch-policy-get)) (configs (policy-switch-configs-get policy)) (config (policy-switch-config-get name configs))) (when config (error "Config \"%s\" exists in policy \"%s\"" name (car policy))) (setq configs (append (list (list name (current-window-configuration) (policy-switch-window-info))) configs)) (setcdr policy (list configs)) (message "Config \"%s\" added to policy \"%s\"" name (car policy)))) (defun policy-switch-window-info (&optional config-win-data) "Get window data from current window configuration." (let ((window-data ())) (dolist (buffer-data (winner-win-data)) (let* ((buffer-obj (cdr buffer-data)) (old-win-data (assoc (car buffer-data) config-win-data))) (setcdr buffer-data (list buffer-obj (if old-win-data (nth (- (length old-win-data) 2) old-win-data) (policy-switch-buffer-info-string buffer-obj)) (buffer-name buffer-obj))) (setq window-data (append window-data (list buffer-data))))) window-data)) (defun policy-switch-config-remove (name) "Remove config with `NAME' from current policy." (interactive (list (if policy-switch-policies-list (cond ((<= (length (policy-switch-configs-get (policy-switch-policy-get))) 1) (caar (policy-switch-configs-get (policy-switch-policy-get)))) (t (completing-read "Remove config: " (mapcar (lambda (config) (car config)) (policy-switch-configs-get (policy-switch-policy-get))) nil t nil nil (caar (policy-switch-configs-get (policy-switch-policy-get))) t))) nil))) (let* ((policy (policy-switch-policy-get)) (configs (policy-switch-configs-get policy t)) (config (policy-switch-config-get name configs t))) (setq configs (remove config configs)) (setcdr policy (list configs)) (message "Config \"%s\" removed from policy \"%s\"" name (car policy)))) ;; Navigation functions (defun policy-switch-policy-next () "Switch to next policy." (interactive) (if policy-switch-policies-list (progn (when (> (length policy-switch-policies-list) 1) (setq policy-switch-policies-list (append (list (nth 1 policy-switch-policies-list)) (nthcdr 2 policy-switch-policies-list) (list (car policy-switch-policies-list))))) (policy-switch-set-window-configuration)) (error "Policy list is empty"))) (defun policy-switch-policy-prev () "Switch to next policy." (interactive) (if policy-switch-policies-list (progn (when (> (length policy-switch-policies-list) 1) (setq policy-switch-policies-list (append (last policy-switch-policies-list) (butlast policy-switch-policies-list 1)))) (policy-switch-set-window-configuration)) (error "Policy list is empty"))) (defun policy-switch-pos-policy (policy-name) "Index of policy with `POLICY-NAME' in the policy-list." (when (not policy-switch-policies-list) (error "No policies defined"))) (defun policy-switch-policy-goto (policy-name) "Goto policy by name." (interactive ;; FIXME: Should work a' la' config-goto (list (if policy-switch-policies-list (completing-read "Goto policy: " (mapcar (lambda (policy) (car policy)) policy-switch-policies-list) nil t) nil))) (let* ((policy (policy-switch-policy-get policy-name)) (pos-elem (position policy policy-switch-policies-list))) (when (> (length policy-switch-policies-list) 1) (setq policy-switch-policies-list (append (subseq policy-switch-policies-list pos-elem) (subseq policy-switch-policies-list 0 pos-elem)))) (policy-switch-set-window-configuration))) ;; config navigation functions (defun policy-switch-config-next (&optional policy-name) "Switch to next config in policy `POLICY-NAME' (defaults to current policy)." (interactive) (let* ((policy (policy-switch-policy-get policy-name)) (configs (policy-switch-configs-get policy t))) (when (> (length configs) 1) (setq configs (append (list (nth 1 configs)) (nthcdr 2 configs) (list (car configs)))) (setcdr policy (list configs))) (policy-switch-set-window-configuration))) (defun policy-switch-config-prev (&optional policy-name) "Switch to previous config in policy `POLICY-NAME' (defaults to current policy)." (interactive) (let* ((policy (policy-switch-policy-get policy-name)) (configs (policy-switch-configs-get policy t))) (when (> (length configs) 1) (setq configs (append (last configs) (butlast configs 1))) (setcdr policy (list configs))) (policy-switch-set-window-configuration))) (defun policy-switch-config-goto (config-name &optional policy-name) "Switch to config `CONFIG-NAME' (if interactively called,provide auto-completion) in policy `POLICY-NAME' (defaults to current policy)." (interactive (list (if policy-switch-policies-list (cond ((<= (length (policy-switch-configs-get (policy-switch-policy-get))) 1) (caar (policy-switch-configs-get (policy-switch-policy-get)))) (t (completing-read "Goto config: " (mapcar (lambda (config) (car config)) (policy-switch-configs-get (policy-switch-policy-get))) nil t nil nil (caar (policy-switch-configs-get (policy-switch-policy-get))) t))) nil))) (let* ((policy (policy-switch-policy-get policy-name)) (configs (policy-switch-configs-get policy t)) (config (policy-switch-config-get config-name configs t)) (pos-elem (position config configs))) (when (> (length configs) 1) (setq configs (append (subseq configs pos-elem) (subseq configs 0 pos-elem))) (setcdr policy (list configs))) (policy-switch-set-window-configuration))) (defun policy-switch-set-window-configuration () "Set the window configuration to the value of the current config in the current policy." (let* ((policy (policy-switch-policy-get)) (configs (policy-switch-configs-get policy)) (config (policy-switch-config-get nil configs)) (config-name (car config)) (config-obj (policy-switch-config-window-obj)) (config-win-data (policy-switch-config-win-data config))) (when (or (equal policy-switch-config-restore-policy 'always) (and (equal policy-switch-config-restore-policy 'needs-restoring) (policy-switch-config-needs-restoring config-name (car policy)))) (policy-switch-config-restore config-name (car policy)) (setq config-obj (policy-switch-config-window-obj))) (if config-obj (progn (set-window-configuration config-obj) (message "Config: \"%s\" in policy \"%s\"" config-name (car policy))) (message "Policy \"%s\" do not have any configs" (car policy))))) (defun policy-switch-config-needs-restoring (&optional name policy-name) "Check if config with `NAME' in policy with `POLICY-NAME' needs restoring. Defaults to current config in current policy. A config needs restoring if any of its buffer objects are nil. Return nil if restoring is needed, false otherwise." (catch 'needs-restoring (dolist (buffer-restore-data config-win-data) (let* ((buf-data (cdr buffer-restore-data)) (buf-object (car buf-data))) (when (policy-switch-buffer-restore-p buf-object) (throw 'needs-restoring t)))) nil)) (defun policy-switch-config-restore (&optional name policy-name) "Restore config with `NAME' in policy with `POLICY-NAME'(Config defaults to current config in current policy)." (interactive) (let* ((policy (policy-switch-policy-get policy-name)) (configs (policy-switch-configs-get policy t)) (config (policy-switch-config-get name configs t)) (config-win-data (policy-switch-config-win-data config)) (restorable 0)) (when (interactive-p) (policy-switch-remove-unprintable-entities)) (delete-other-windows) (setq restorable (policy-switch-config-split-windows config-win-data)) (setq configs (append (list (list (car config) (current-window-configuration) (policy-switch-window-info config-win-data))) (remq config configs))) (setcdr policy (list configs)) (message (if (= (length restorable) 0) "All buffers restored" "%s buffer(s) failed to restore" (length restorable))))) (defun policy-switch-policy-restore (policy-name) "Restore policy with POLICY-NAME." (let* ((policy (policy-switch-policy-get policy-name)) (configs (policy-switch-configs-get policy t))) (dolist (config configs) (policy-switch-config-restore (car config) policy-name)))) (defun policy-switch-policies-restore () "Restore policies." (save-window-excursion (dolist (policy policy-switch-policies-list) (policy-switch-policy-restore (car policy))))) (defun policy-switch-config-split-windows (config-data) "Restore policy config from `CONFIG-DATA'." (let ((index 0) (vert-split nil) (hoz-split nil) (not-restorable ()) (split-num 0)) (dolist (buffer-info config-data) (let* ((win-data (car buffer-info)) (buffer-data (cdr buffer-info)) (buf-object (car buffer-data)) (restore-string (nth (- (length buffer-data) 2) buffer-data)) (buf-name (car (last buffer-data)))) ;; split until first horizantal or vertical border or end reached (dolist (buf-data (nthcdr (1+ index) config-data)) (when (< split-num 2) ;; I should split vertically (cond ((and (not vert-split) (= (car win-data) (caar buf-data))) (setq vert-split (split-window nil (- (cadar buf-data) (nth 1 win-data)) nil)) (setq split-num (1+ split-num))) ;; I should split horizontally ((and (not hoz-split) (= (nth 1 win-data) (nth 1 (car buf-data)))) (setq hoz-split (split-window nil (- (caar buf-data) (car win-data)) t)) (setq split-num (1+ split-num)))))) (when (policy-switch-buffer-restore-p buf-object) (setq buf-object (policy-switch-config-restore-buffer restore-string buf-name))) (if buf-object (set-window-buffer nil buf-object) (setq not-restorable (append (list buffer-name) not-restorable))) (cond (vert-split (select-window vert-split) (setq vert-split nil)) (hoz-split (select-window hoz-split) (setq hoz-split nil)) (t (other-window 1))) (setq index (1+ index) split-num 0))) not-restorable)) (defun policy-switch-buffer-restore-p (buffer-obj) "Returns non-nil if buffer given by BUFFER-OBJ should be restored." (or (not (buffer-live-p buf-object)) (null buf-object) (find (cdr (assoc 'major-mode (buffer-local-variables buffer-obj))) policy-switch-live-buffer-modes-restore))) (defun policy-switch-config-restore-buffer (restore-string buf-name) "Restore buffer with `RESTORE-STRING'." (cond (restore-string (save-window-excursion (eval (read restore-string)))) (buf-name (get-buffer-create buf-name)))) (defun policy-switch-buffer-info-string (buffer) "Get restorable info in string form for BUFFER. String must be parsable by the Lisp interpreter. Use desktop to retrieve restore info (if `desktop-save-buffer-p' returns non-nil). Otherwise, look in `policy-switch-mode-handlers' for appropriate function to call." (let* ((create-buffer-string) (buffer-info (policy-switch-buffer-info buffer)) (buffer-mode (cdr (assoc 'major-mode (buffer-local-variables)))) (restore-function (cdr (assoc buffer-mode policy-switch-buffer-mode-handlers)))) (setq create-buffer-string (cond ((apply 'desktop-save-buffer-p buffer-info) (concat "(let ((desktop-buffer-ok-count 0)\n" "(desktop-first-buffer nil)\n" "(desktop-buffer-fail-count 0))\n" "(" (if (or (not (integerp desktop-restore-eager)) (if (zerop desktop-restore-eager) nil (setq desktop-restore-eager (1- desktop-restore-eager)))) "desktop-create-buffer" "desktop-append-buffer-args") " " desktop-file-version (let ((temp-string)) (dolist (e buffer-info) (setq temp-string (concat temp-string "\n " (desktop-value-to-string e)))) temp-string) ")\n" "desktop-first-buffer)\n\n")) (restore-function (funcall restore-function)) ((when (buffer-file-name) (concat "(find-file \"" (buffer-file-name) "\")\n" "(current-buffer)\n\n"))))))) (defun policy-switch-buffer-info-w3m () "Restorable buffer info for w3m buffers." (concat "(progn\n" "(save-window-excursion\n" "(delete-other-windows)\n" "(w3m-goto-url-new-session \"" w3m-current-url "\")\n" "(current-buffer)))\n\n")) (defun policy-switch-buffer-info-dictionary () "Restorable buffer info for dictionary buffers." (save-excursion (goto-char (point-min)) (when (search-forward "definitions found" nil t) (forward-line 4) (concat "(progn\n" "(save-window-excursion\n" "(delete-other-windows)\n" "(dictionary-search \"" (current-word) "\")\n" "(current-buffer)))\n\n")))) (defun policy-switch-buffer-info-help () "Restorable buffer info for *help* buffers." (save-excursion (goto-char (point-min)) (let ((doc-word) (first-line (buffer-substring-no-properties (line-beginning-position) (line-end-position)))) (string-match "[^\[:space:\]]*" first-line) (setq doc-word (match-string 0 first-line)) (concat "(progn\n" "(save-window-excursion\n" "(delete-other-windows)\n" "(describe-" (if (string-match "variable" first-line) "variable " "function '") doc-word ")\n" "(car (remove nil (mapcar (lambda (buf-data)\n" "(if (equal 'help-mode\n" "(cdr (assoc 'major-mode (buffer-local-variables (cdr buf-data)))))\n" "(cdr buf-data)\n" "nil))\n" "(winner-win-data))))))\n\n")))) (defun policy-switch-buffer-info-bbdb () "Restorable buffer info for *help* buffers." (when (featurep 'planner-bbdb) (concat "(let ((buffer-obj nil))\n" "(progn\n" "(save-window-excursion\n" "(delete-other-windows)\n" "(planner-bbdb-browse-url \n" "\"" (substring (car (split-string (planner-bbdb-annotation-from-bbdb) "]")) 2) "\")\n" "(setq buffer-obj (car (remove nil (mapcar (lambda (buf-data)\n" "(if (equal '" (symbol-name (cdr (assoc 'major-mode (buffer-local-variables buffer)))) "\n" "(cdr (assoc 'major-mode (buffer-local-variables (cdr buf-data)))))\n" "(cdr buf-data)\n" "nil))\n" "(winner-win-data))))))))\n\n"))) (defun policy-switch-buffer-info-gnus () "Restorable buffer info for gnus article and gnus summary buffers." (when (featurep 'planner-gnus) (concat "(let ((buffer-obj nil))\n" "(progn\n" "(save-window-excursion\n" "(delete-other-windows)\n" "(planner-gnus-browse-url \n" "\"" (substring (car (split-string (planner-gnus-annotation) "]")) 2) "\")\n" "(setq buffer-obj (car (remove nil (mapcar (lambda (buf-data)\n" "(if (equal '" (symbol-name (cdr (assoc 'major-mode (buffer-local-variables buffer)))) "\n" "(cdr (assoc 'major-mode (buffer-local-variables (cdr buf-data)))))\n" "(cdr buf-data)\n" "nil))\n" "(winner-win-data))))))))\n\n"))) (defun policy-switch-buffer-info (buffer) "Retrieve buffer info from BUFFER." (set-buffer buffer) (list ;; basic information (desktop-file-name (buffer-file-name) desktop-dirname) (buffer-name) major-mode ;; minor modes (let (ret) (mapc #'(lambda (minor-mode) (and (boundp minor-mode) (symbol-value minor-mode) (let* ((special (assq minor-mode desktop-minor-mode-table)) (value (cond (special (cadr special)) ((functionp minor-mode) minor-mode)))) (when value (add-to-list 'ret value))))) (mapcar #'car minor-mode-alist)) ret) ;; point and mark, and read-only status (point) (list (mark t) mark-active) buffer-read-only ;; auxiliary information (when (functionp desktop-save-buffer) (funcall desktop-save-buffer dirname)) ;; local variables (let ((locals desktop-locals-to-save) (loclist (buffer-local-variables)) (ll)) (while locals (let ((here (assq (car locals) loclist))) (if here (setq ll (cons here ll)) (when (member (car locals) loclist) (setq ll (cons (car locals) ll))))) (setq locals (cdr locals))) ll))) (defun policy-switch-remove-unprintable-entities () "Remove unprintable entities from policy-switch-policies-list." (dolist (policy policy-switch-policies-list) (let* ((configs (policy-switch-configs-get policy)) (config (policy-switch-config-get nil configs)) (config-name (car config)) (config-obj (policy-switch-config-window-obj config)) (config-win-data (policy-switch-config-win-data config))) (dolist (config configs) (setcar (cdr config) nil) (dolist (buffer-data (policy-switch-config-win-data config)) (setcar (cdr buffer-data) nil)))))) (defun policy-switch-toggle-mode-line () "Toggle mode line." (interactive) (setq policy-switch-mode-line-p (not policy-switch-mode-line-p))) ;; Mode Line (when (not policy-switch-mode-line-elm) (let ((mode-line mode-line-format)) (setq policy-switch-mode-line-elm '(policy-switch-mode-line-p (:eval (format "[%s %s:%s %s] " ; [ : ] (if policy-switch-policies-list (car (policy-switch-policy-get)) "None") (int-to-string (length policy-switch-policies-list)) (if (and policy-switch-policies-list (policy-switch-configs-get (policy-switch-policy-get))) (car (policy-switch-config-get nil (policy-switch-configs-get (policy-switch-policy-get)))) "None") (int-to-string (if policy-switch-policies-list (length (policy-switch-configs-get (policy-switch-policy-get))) 0)))))) (let ((pos (position 'mode-line-modes mode-line))) (setcdr mode-line (append (subseq mode-line 0 pos) (list policy-switch-mode-line-elm) (nthcdr pos mode-line)))))) (provide 'policy-switch) ;; policy-switch.el ends here _______________________________________________ gnu-emacs-sources mailing list gnu-emacs-sources@gnu.org http://lists.gnu.org/mailman/listinfo/gnu-emacs-sources ------- End of forwarded message -------