home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / unix / volume11 / test.el / part02 / tst-capture.el < prev    next >
Lisp/Scheme  |  1987-09-08  |  18KB  |  459 lines
  1. ;; capture.el -- functions to capture the state of an emacs session 
  2. ;; This is file 1 of two files in the "regression" part of the "test" package.
  3. ;; See also achieve.el
  4. ;; Carl Lagoze, Franklin Davis
  5. ;; Copyright 1987 Wang Institute of Graduate Studies
  6. ;; $Header: tst-capture.el,v 1.21 87/07/29 17:24:58 davis Exp $
  7.  
  8. (provide 'tst-capture)
  9.  
  10. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  11. ;;; some utilities
  12.  
  13. (defmacro cadr (l)
  14.   (list 'car (list 'cdr l)))
  15.  
  16. (defun member (elt list)
  17.   "Returns non-nil if ELT is an element of LIST.  Comparison done with equal.
  18. The value is actually the tail of LIST whose car is ELT."
  19.   (while (and list (not (equal elt (car list))))
  20.     (setq list (cdr list)))
  21.   list)
  22.  
  23.  
  24. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  25. ;; variables
  26.  
  27. (defvar tst-vars-exclude-default (list "values" "obarray")
  28.   "* Default list of global variable names to be excluded by 
  29. tst-capture-state and tst-capture-state-to-file")
  30.  
  31.  
  32. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  33. ;; the interactive functions
  34.  
  35. (defun tst-capture-state-to-file (file bufs-list vars-exclude)
  36.   "Write the current state of the emacs session to FILE.
  37. BUFS-LIST is a list of buffer names to capture; if nil all buffers
  38. will be captured.  
  39. VARS-EXCLUDE is a list of global variables to exclude.  See 
  40. tst-capture-state for documentation."
  41.   (interactive "FFile name to write current state to:
  42. xList of buffers to capture (nil for all): 
  43. xList global vars to exclude (all; none; nil for default excl. list): ")
  44.   (let (state)
  45.      (tst-capture-state 'state bufs-list vars-exclude)
  46.      (tst-write-state-to-file state file)
  47.     )                    ;let
  48.   )                    ;defun tst-capture-state-to-file
  49.  
  50. (defun tst-write-state-to-file (state file)
  51.   "Write variable STATE containing captured emacs session state to FILE."
  52.   (interactive "XState Name: \nFFile name to write state to: ")
  53.   (let ()
  54.     (message "Writing state to file...")
  55.     (save-excursion
  56.       (switch-to-buffer (make-temp-name "state"))
  57.       (prin1 state (current-buffer))
  58.       (write-file file)
  59.       (kill-buffer (current-buffer))
  60.       )                    ; save-excursion
  61.     )                    ; let
  62.   )                    ; defun tst-write-state-to-file
  63.  
  64.  
  65. (defun tst-capture-state (statevar bufs-list vars-exclude)
  66.   "Set variable STATE to the current state of the emacs session.
  67. BUFS-LIST is a list of buffer names to capture; if nil all buffers
  68. will be captured.  
  69. VARS-EXCLUDE is a list of global variables to exclude; 
  70. if value is nil, default list tst-vars-exclude-default will be used; 
  71. if value is 'all' all global variables will be excluded (not captured); 
  72. if value is 'none' no global variables will be excluded (everything captured).
  73. nil is returned in place of excluded variable if it exists.
  74.  
  75. An exclude-list rather than an include-list is used because it's 
  76. most important to exclude particularly nasty variables.  Would be nice to
  77. extend this to have an include-list; perhaps also reg-exp for buffer names."
  78.   (interactive "SState Variable: 
  79. xList of buffers to capture (nil for all): 
  80. xList global vars to exclude (all; none; nil for default excl. list): ")
  81.   (let ()
  82.     (makunbound statevar)        ; don't want to capture old state var.
  83.     (if (not (listp bufs-list))
  84.          (error "Buffer-list must be a list of strings or nil")
  85.       ) ; if
  86.     (set statevar (list (tst-capture-globals-state vars-exclude)
  87.                         (tst-capture-processes-state)
  88.                         (tst-capture-buffers-state bufs-list)
  89.                         (tst-capture-windows-state)
  90.                         ))
  91.     (message "Capturing state...done")
  92.     ) ;let
  93.   ) ;defun tst-capture-state
  94.  
  95.  
  96. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  97. ;; globals capture
  98.  
  99. (defun tst-capture-globals-state (vars-exclude)
  100.   "Capture global attributes of an Emacs session. 
  101. VARS-EXCLUDE is a list of global variables to exclude; 
  102. if value is nil, default list tst-vars-exclude-default will be used; 
  103. if value is 'all' all global variables will be excluded (not captured); 
  104. if value is 'none' no global variables will be excluded (everything captured)."
  105.   (let ()
  106.     (message "Capturing state of globals...")
  107.     (cond ((null vars-exclude)
  108.        (setq vars-exclude tst-vars-exclude-default))
  109.       ((equal vars-exclude 'none) (setq vars-exclude nil))
  110.       )
  111.     (list 'session
  112.           (list
  113.            (if (equal vars-exclude 'all)
  114.            nil
  115.                     ; else
  116.          (tst-capture-global-syms-state vars-exclude))
  117. ;;       (tst-capture-recursive-level-state)
  118.            )                ; list
  119.           )                ;list 'session
  120.     )                    ;let
  121.   )                    ;defun tst-capture-globals-state
  122.  
  123. (defun tst-capture-global-syms-state (vars-exclude)
  124.   "Return the names and values of all global variables except VARS-EXCLUDE
  125.    as a single element a-list with the key 'global-vars.  The second element 
  126.    of the alist is a list of two element lists.  Each two element list 
  127.    consists of a global variable name and its value."
  128.   (list 'global-bound-syms
  129.     (delq nil            ; remove "nil" from results
  130.           (mapcar
  131.                     ; the lambda here allows
  132.                     ; mapcar to pass a second
  133.                     ; argument vars-exclude to
  134.                     ; function
  135.                     ; tst-get-bound-val-from-string
  136.                     ; while applying it to every
  137.                     ; element in list (all-completions...) 
  138.            '(lambda (sym-string)
  139.           (tst-get-bound-val-from-string sym-string vars-exclude))
  140.            (all-completions "" obarray 'boundp))
  141.           )                ; delq
  142.     )                ; list
  143.   )                    ; defun tst-capture-global-vars-state
  144.  
  145. (defun tst-get-bound-val-from-string (sym-string vars-exclude)
  146.   "Given a SYMBOL-NAME return a cons of the symbol and its value.  The cons
  147. looks like (symbol . value).  Note that storing new values in this cons does 
  148. not change the symbol's value.  Returns nil if SYMBOL-NAME in VARS-EXCLUDE."
  149.   (cond ((not (stringp sym-string)) nil)
  150.     ((member sym-string vars-exclude) nil) ; return nil for excluded vars
  151.     (t (cons (car (read-from-string sym-string))
  152.          (tst-convert-compound-symbols
  153.           (eval (car (read-from-string sym-string))))))
  154.     ) ; cond
  155.   ) ;defun tst-get-bound-val-from-string
  156.      
  157. (defun tst-convert-compound-symbols (sym)
  158.   "Given a SYMBOL, convert all marker or process objects to descriptions
  159. of these objects.  SYMBOL may be a list or atom or dotted pair."
  160.   (cond ((null sym) sym)
  161.     ((vectorp sym) sym)
  162.     ((numberp sym) sym)
  163.     ((and (listp sym)
  164.           (atom (cdr sym))
  165.           (cdr sym))        ; be sure it's not nil
  166.      (cons                ; sym is a dotted pair
  167.       (tst-convert-compound-symbols (car sym))
  168.       (tst-convert-compound-symbols (cdr sym))))
  169.     ((and (listp sym) (atom (car (cdr sym)))) ; simple list
  170.      (mapcar 'tst-convert-compound-symbols sym))
  171.     ((atom sym)
  172.      (cond ((markerp  sym) (tst-convert-marker-symbol sym))
  173.            ((processp sym) (tst-convert-process-symbol sym))
  174.            ((windowp  sym) (list 'window
  175.                      (tst-capture-window-state sym nil)))
  176.            (t  sym)            ; not a complex object
  177.            )            ; cond
  178.      )
  179.     (t sym)
  180.     )                ; cond
  181.   )                    ; defun tst-convert-compound-symbols
  182.  
  183.  
  184. ;;; the following function is not used, but could be if someone wanted this 
  185. (defun tst-capture-recursive-level-state ()
  186.   "Capture the current recursive editing state (only the level)"
  187.   (let ()
  188.     (list 'recursive-level (recursion-depth))
  189.     ) ;let
  190.   ) ;tst-capture-recursive-level-state
  191.  
  192.  
  193.  
  194. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  195. ;; processes
  196.  
  197. (defun tst-capture-processes-state ()
  198.   "Capture processes attributes of an EMACS session"
  199.   (message "Capturing state of processes...")
  200.   (list 'processes (tst-convert-compound-symbols (process-list)))
  201.   )                    ;defun tst-capture-processes-state
  202.  
  203. (defun tst-convert-process-symbol (p)
  204.   "Convert a process object into a list ('process <process-command>
  205.    <process-exit-status> <process-filter> <process-name> <process-sentenel>
  206.    <process-status>"
  207.   (if (processp p)
  208.       (list
  209.        'process
  210.        (list 'buffer (if (process-buffer p) (buffer-name (process-buffer p))
  211.                nil))
  212.        (list 'process-mark (tst-convert-marker-symbol (process-mark p)))
  213.        (list 'command (process-command p))
  214.        (list 'exit-status (process-exit-status p))
  215.        (list 'filter (process-filter p))
  216.        (list 'name (process-name p))
  217.        (list 'sentinel (process-sentinel p))
  218.        (list 'status (process-status p))
  219.        )                ; list
  220.     )                    ;if 
  221.   )                    ;defun tst-convert-process-symbol
  222.  
  223.  
  224. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  225. ;; buffers
  226.  
  227. (defun tst-capture-buffers-state (capture-bufs-list)
  228.   "Return the states of all the active buffers in this session as a 
  229.    single element a-list with the key 'buffers.  The second element of the
  230.    alist is a list, each element of which is the state of an active buffer."
  231.                     ; Local Variables
  232.   (let ((bufflist) (buff-state))
  233.     (message "Capturing state of buffers...")
  234.     (setq bufflist (buffer-list))
  235.     (save-excursion
  236.       (while bufflist
  237.     (if (or (null capture-bufs-list) ; get all if no capture-bufs-list
  238.                     ; or get this buffer if in list
  239.         (member (buffer-name (car bufflist)) capture-bufs-list))
  240.         (progn
  241.           (set-buffer (car bufflist))
  242.           (setq buff-state
  243.             (append buff-state
  244.                 (list (tst-capture-buffer-state))))
  245.           )                ; progn
  246.       )                ; if
  247.     (setq bufflist (cdr bufflist))
  248.         )                ; while
  249.       )                    ; save-excursion
  250.     (cons 'buffers (list buff-state))
  251.     )                    ; let
  252.   )                    ; defun tst-capture-buffers-state
  253.  
  254.  
  255. (defun tst-capture-buffer-state ()
  256.   "Return the state of the current buffer.  The state is returned as an
  257.    a-list"
  258.                                         ; Local Variables
  259.   (let ()
  260.     (list
  261.      (list 'buf-state-name (buffer-name))
  262.      (list 'buf-state-file (buffer-file-name))
  263.      (list 'buf-state-point (point))
  264.      (list 'buf-state-mark (mark))
  265.      (list 'buf-state-contents (buffer-string))
  266.      (list 'buf-state-modified (buffer-modified-p))
  267.      (list 'buf-state-local-map (current-local-map))
  268.      (list 'buf-state-local-vars
  269.            (mapcar 'tst-convert-compound-symbols (buffer-local-variables)))
  270.      ) ; list
  271.     ) ; let
  272.   ) ; defun tst-capture-buffer-state
  273.  
  274.  
  275. (defun tst-convert-marker-symbol (marker-symbol)
  276.   "Convert a marker object into a list (marker <point-value> <buffer>)"
  277.   (if (markerp marker-symbol)
  278.       (list
  279.        'marker
  280.        (list 'position (marker-position marker-symbol))
  281.        (if (null (marker-position marker-symbol)) nil ; no buf name if nil pos.
  282.      (list 'buffer (buffer-name (marker-buffer marker-symbol))))
  283.        )                ; list
  284.     )                    ; if
  285.   )                    ;defun tst-convert-marker-symbol
  286.  
  287.  
  288. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  289. ;; windows
  290.  
  291. (defun tst-capture-windows-state ()
  292.   "Return the state of emacs windows as a two element a-list.  The first
  293.    element is the key 'windows.  The second element is a list 
  294.    representation of the binary tree abstraction of the window state.  This
  295.    tree is built by walking the windows (starting at the window positioned
  296.    at 0,0) and doing a shift-reduce parse on the window-list.  This parse
  297.    has two productions:
  298.      0: reduce two windows to a combined window when their top/bottom
  299.         edges are common.
  300.      1: reduce two windows to a combined window when their right/left
  301.         edges are common.
  302.    The parser has three states:
  303.      0: The start state.  The stack is empty
  304.      1: 1 element on the stack
  305.      2: >1 element on the stack"
  306.   (let ((stack) (state) (cur-window))
  307.     (message "Capturing state of windows...")
  308.     (save-window-excursion
  309.       (setq cur-window (selected-window))
  310.       (while (not (equal '(0 0) ;go to the upper left window
  311.                          (list (car (window-edges)) (cadr (window-edges)))))
  312.         (select-window (next-window))
  313.          )                              ;while
  314.                     ;always shift first window
  315.       (setq stack (tst-shift-window-stack stack cur-window))
  316.       (setq state 1)                    ;state 1 when 1 element on stack
  317.       ; At this point the base (0,0) window is on the stack and we are in
  318.       ; state 1.  Loop until we return to the condition where the state is
  319.       ; 1 and the next window is the base window (reduced to the final state)
  320.       (while (not (and (equal '(0 0) 
  321.                          (list
  322.               (car (window-edges (next-window)))
  323.               (cadr (window-edges (next-window)))
  324.               )
  325.              )
  326.                        (= state 1)
  327.                ))
  328.         (if (= state 1)             ;always shift
  329.              (progn
  330.                (select-window (next-window))
  331.                (setq stack (tst-shift-window-stack stack cur-window))
  332.                (setq state 2)
  333.                )                        ;progn
  334.           (progn                        ;state 2
  335.             (if (equal
  336.                  (tst-get-window-bottom-edge (cadr stack))
  337.                  (tst-get-window-top-edge (car stack)))
  338.                 (progn                  ;reduce by v rule
  339.                   (setq stack (tst-reduce-window-stack stack 'v))
  340.                   (if (= 1 (length stack))
  341.                       (progn
  342.                         (setq state 1)
  343.                         )               ;progn
  344.                     )                   ;if
  345.                   )                     ;progn
  346.               (progn
  347.                 (if (equal
  348.                      (tst-get-window-right-edge (cadr stack))
  349.                      (tst-get-window-left-edge (car stack)))
  350.                     (progn
  351.                       (setq stack (tst-reduce-window-stack stack 'h))
  352.                       (if (= 1 (length stack))
  353.                           (progn
  354.                             (setq state 1)
  355.                             )           ;progn
  356.                         )                       ;if
  357.                       )
  358.                   (progn
  359.                     (select-window (next-window))
  360.                     (setq stack (tst-shift-window-stack stack cur-window))
  361.                     )                     ;progn
  362.                   )                     ;if equal left and right edge
  363.                 )                       ;progn-else of if top and bottom equal
  364.               )                         ;if equal top and bottom edge
  365.             )                           ;progn - state 2
  366.           )                             ;if equal state 1
  367.         )                               ;while not accept state
  368.       )                                 ;save window excursion
  369.     (list 'windows (car stack))
  370.     )                                   ;let
  371.   )                                     ;defun tst-capture-windows-state
  372.   
  373. (defun tst-shift-window-stack (stack cur-window)
  374.   "Perform a shift in the LR parse of the window configuration tree (i.e. put
  375.    the state of the current window on top of the parse stack"
  376.   (let ()
  377.     (cons (tst-capture-window-state (selected-window) cur-window) stack)
  378.     )                                   ;let
  379.   )                                     ;shift-window-state
  380.  
  381. (defun tst-reduce-window-stack (stack rule)
  382.   "Perform a reduce in the LR parse of the window configuration tree.  A reduce
  383.    always pops two elements off the parse stack and pushes a new element that
  384.    is a description of the 'combined' elements that were popped.  The input 
  385.    argument rule is either 'v' if the two items at the top of the stack were 
  386.    split vertically, or 'h' if the two items at the top of the stack were
  387.    split horizontally"
  388.    (let ((wstatet) (wstatet-1) (combined) (edgest) (edgest-1))
  389.      (setq wstatet (car stack))
  390.      (setq wstatet-1 (cadr stack))
  391.      (setq stack (cdr (cdr stack)))
  392.      (setq combined (list
  393.                      (list 'children (list wstatet-1 wstatet))
  394.                      (list 'split rule)))
  395.      (setq edgest (cadr (assoc 'window-edges wstatet)))
  396.      (setq edgest-1 (cadr (assoc 'window-edges wstatet-1)))
  397.      (setq combined (cons (list 'window-edges (list
  398.                                 (car edgest-1)
  399.                                 (cadr edgest-1)
  400.                                 (cadr (cdr edgest))
  401.                                 (cadr (cdr (cdr edgest)))
  402.                                 )
  403.                  )
  404.            combined))
  405.  
  406.      (setq stack (cons combined stack))
  407.      )                                  ;let
  408.    )                                    ;defun tst-reduce-window-stack
  409.  
  410. (defun tst-get-window-top-edge (wstate)
  411.   "Return the coordinates of the top edge of input window as a three element
  412.    list consisting of (left-column row right-column)"
  413.   (let ((edges))
  414.     (setq edges (cadr (assoc 'window-edges wstate)))
  415.     (list (car edges) (cadr edges) (cadr (cdr edges)))
  416.     )                                   ;let
  417.   )                                     ;defun tst-reg-get-top-edge
  418.  
  419. (defun tst-get-window-bottom-edge (wstate)
  420.   "Return the coordinates of the bottom edge of nput window as a three element
  421.    list consisting of (left-column row right-column)"
  422.   (let ((edges))
  423.     (setq edges (cadr (assoc 'window-edges wstate)))
  424.     (list (car edges) (cadr (cdr (cdr edges))) (cadr (cdr edges)))
  425.     )                                   ;let
  426.   )                                     ;defun tst-reg-get-top-edge
  427.  
  428. (defun tst-get-window-left-edge (wstate)
  429.   "Return the coordinates of the left edge of input window as a three element
  430.    list consisting of (top-row column bottom-row)"
  431.   (let ((edges))
  432.     (setq edges (cadr (assoc 'window-edges wstate)))
  433.     (list (cadr edges) (car edges) (cadr (cdr (cdr edges))))
  434.     )                                   ;let
  435.   )                                     ;defun tst-reg-get-left-edge
  436.  
  437. (defun tst-get-window-right-edge (wstate)
  438.   "Return the coordinates of the right edge of input window as a three element
  439.    list consisting of (top-row column bottom-row)"
  440.   (let ((edges))
  441.     (setq edges (cadr (assoc 'window-edges wstate)))
  442.     (list (cadr edges) (cadr (cdr edges)) (cadr (cdr (cdr edges))))
  443.     )                                   ;let
  444.   )                                     ;defun tst-reg-get-right-edge
  445.  
  446. (defun tst-capture-window-state (window cur-window)
  447.   "Return the state of the window as an a-list."
  448.   (let ()
  449.     (list
  450.      (list 'window-edges (window-edges))
  451.      (list 'window-buffer (buffer-name))
  452.      (list 'window-start (window-start))
  453.      (list 'window-point (window-point))
  454.      (list 'current-window (equal window cur-window))
  455.      )
  456.     )
  457.   )
  458.  
  459.