home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 January / usenetsourcesnewsgroupsinfomagicjanuary1994.iso / sources / unix / volume11 / test.el / part02 / tst-achieve.el < prev    next >
Encoding:
Text File  |  1987-09-08  |  12.2 KB  |  361 lines
  1. ;; achieve.el -- functions to achieve a captured state of an emacs session
  2. ;; This is file 2 of two files in the "regression" part of the "test" package.
  3. ;; See also capture.el
  4. ;; Carl Lagoze, Franklin Davis
  5. ;; Copyright 1987 Wang Institute of Graduate Studies
  6. ;; $Header: tst-achieve.el,v 1.8 87/07/29 22:50:12 bliven Exp $
  7.  
  8. (provide 'tst-achieve)
  9.  
  10. (defun member (elt list)
  11.   "Returns non-nil if ELT is an element of LIST.  Comparison done with equal.
  12. The value is actually the tail of LIST whose car is ELT."
  13.   (while (and list (not (equal elt (car list))))
  14.     (setq list (cdr list)))
  15.   list)
  16.  
  17. (defmacro cadr (l)
  18.   (list 'car (list 'cdr l)))
  19.  
  20. (defmacro cddr (l)
  21.   (list 'cdr (list 'cdr l)))
  22.  
  23. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  24. ;; interactive functions
  25.  
  26. (defun tst-read-state-from-file (statevar file)
  27.   "Read a captured emacs session state into STATE VARIABLE from FILE."
  28.   (interactive "xState variable to read into: \nfFile Name: ")
  29.   (let ()
  30.     (save-excursion
  31.       (message "Reading file...")
  32.       (switch-to-buffer (make-temp-name "state"))
  33.       (insert-file file)
  34.       (goto-char (point-min))
  35.       (message "Getting state from file...")
  36.       (set statevar (read (current-buffer)))
  37.       (kill-buffer (current-buffer))
  38.       statevar
  39.       )                    ; save-excursion
  40.     )                    ; let
  41.   )                    ; defun tst-read-state-from-file
  42.  
  43. (defun tst-achieve-state-from-file (file &optional no-process)
  44.   "Achieve a captured emacs session state from a FILE."
  45.   (interactive "fFile Name: ")
  46.   (let (state)
  47.     (tst-read-state-from-file 'state file)
  48.     (tst-achieve-state state no-process)
  49.     )                    ; let
  50.   )                    ; defun tst-achieve-state-from-file
  51.  
  52.  
  53. (defun tst-achieve-state (state &optional no-process)
  54.   "Achieve the saved state of an emacs session from variable STATE.
  55. If tst-achieve-buffers-nondestructively is non nil, buffers not in
  56. STATE are not killed.  If NO_PROCESS is non nil, processes are not achieved."
  57.   (interactive "XState to achieve: ")
  58.   (let ()
  59.     (tst-achieve-bufs-state (cadr (assoc 'buffers state)))
  60.     (message "Achieving state of windows...")
  61.     (delete-other-windows)
  62.     (tst-achieve-windows-state (cadr (assoc 'windows state)))
  63.     (or no-process
  64.     (tst-achieve-processes-state (cadr (assoc 'processes state))))
  65.     (tst-achieve-globals-state (cadr (assoc 'session state)))
  66.     (if (interactive-p)
  67.     (message (concat "Achieved state from " state ".")))
  68.     )                    ;let
  69.   )                    ;defun tst-achieve-state
  70.  
  71.  
  72. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  73. ;; globals
  74.  
  75. (defun tst-achieve-globals-state (ses-state)
  76.   "Achieve global attributes saved in STATE"
  77.   (message "Achieving state of globals...")
  78.   (tst-achieve-syms (cadr (assoc 'global-bound-syms ses-state)) nil)
  79.   ;; (tst-achieve-ses-functions-state)
  80.   ;; (tst-achieve-recursive-level-state) ; only the level is captured, not 
  81.                     ; the actual stack, so useless
  82.   (ding) (ding)
  83.   )                    ;defun tst-achieve-globals-state
  84.     
  85. (defun tst-achieve-syms (pairs localflag)
  86.   "Set the value of symbols to those values in the list of PAIRS.  Make
  87. variable local first if LOCALFLAG non nil.
  88. Each element of PAIRS looks like (symbol-name . symbol-value)"
  89.     (mapcar
  90.                     ; the lambda here allows
  91.                     ; mapcar to pass a second
  92.                     ; argument localflag to
  93.                     ; function tst-achieve-sym,
  94.                     ; while applying it to every
  95.                     ; element in list pairs
  96.      '(lambda (pair)
  97.     (tst-achieve-sym pair localflag))
  98.      pairs)
  99.   ) ;defun tst-achieve-syms
  100.  
  101. (defun tst-achieve-sym (pair localflag)
  102.   "Set the variable named by SYMBOL-NAME-PAIR to value.  Make variable
  103. local first if LOCALFLAG not nil. 
  104. SYMBOL-NAME-PAIR looks like (symbol-name . symbol-value)."
  105.   (if localflag (make-local-variable (car pair)))
  106.   (cond ((equal (car pair) t) nil)    ; no-op on "t" or "nil"
  107.     ((equal (car pair) nil) nil)
  108.     (t (set (car pair) (tst-convert-object (cdr pair))))
  109.     )                ; cond
  110.   )                    ; defun tst-achieve-sym
  111.  
  112. (defun tst-convert-object (object)
  113.   "Convert all descriptions of compound objects, e.g. markers,
  114. processes, windows, into the actual objects." 
  115.   (cond ((null object) object)
  116.     ((vectorp object) object)
  117.     ((atom object) object)
  118.     ((equal (car object) 'marker) (tst-convert-marker object))
  119.     ((equal (car object) 'process) (tst-convert-process object))
  120.     ((equal (car object) 'window) nil) ; can't do anything here with window
  121.     ((and (listp object)
  122.           (atom (cdr object))
  123.           (cdr object))
  124.                     ; object is a dotted pair
  125.      (cons (tst-convert-object (car object))
  126.            (tst-convert-object (cdr object))))
  127.     ((listp object) (mapcar 'tst-convert-object object))
  128.     (t object)
  129.     )                ; cond
  130.   )                    ; defun tst-convert-object
  131.  
  132.  
  133. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  134. ;;; processes
  135.  
  136. (defun tst-achieve-processes-state (processes-desc)
  137.   "Achieve processes captured in a state, but only if interactive."
  138.   (message "Achieving state of processes...")
  139.   (mapcar 'tst-convert-process processes-desc)
  140.   )                    ; tst-achieve-processes-state
  141.  
  142. (defun tst-convert-process (process-desc)
  143.   "Create the process described by PROCESS-DESC.  
  144. PROCESS-DESC looks like (process (command (comstring argstrings))
  145. ;(exit-status 0) (filter filter-func) (name namestring) 
  146. ;(sentinel sentinel-func) (status runstat))"
  147.   (let (proc live procname) 
  148.     (setq procname (cadr (assoc 'name (cddr process-desc))))
  149.     (setq live (and 
  150.         (car (read-from-string procname))
  151.         (eq (process-status procname) 'run)))
  152.     (if live
  153.     (get-process (cadr (assoc 'name (cdr process-desc))))
  154.                     ; else
  155.       (save-excursion
  156.     (setq proc
  157.           (apply 'start-process 
  158.              (cadr (assoc 'name (cdr process-desc)))
  159.              (cadr (assoc 'buffer (cdr process-desc)))
  160.              (cadr (assoc 'command (cdr process-desc)))
  161.              )            ; apply
  162.           )                ; setq
  163.     (set-process-filter
  164.      proc
  165.      (cadr (assoc 'filter (cdr process-desc))))
  166.     (set-process-sentinel
  167.      proc
  168.      (cadr (assoc 'sentinel (cdr process-desc))))
  169. ;;;    (set-marker
  170. ;;;     (process-mark proc) 
  171. ;;;     (cadr (assoc 'position
  172. ;;;              (cadr (assoc 'process-mark (cdr process-desc)))))
  173. ;;;     (process-buffer proc))
  174.     proc
  175.     )                ; save-excursion
  176.       )                    ; if
  177.     )                    ; let
  178.   )                    ; defun tst-convert-process
  179.  
  180. (defun tst-convert-marker (marker-desc)
  181.   "Create the marker described by MARKER-DESC.  
  182. MARKER-DESC looks like (marker (position 23) (buffer bufname)).
  183. Bufname is a string, and the list (buffer bufname) may be nil if no
  184. buffer is associated."
  185.   (set-marker (make-marker)
  186.           (cadr (assoc 'position (cdr marker-desc)))
  187.           (if (null (cadr (assoc 'buffer (cdr marker-desc)))) nil
  188.         (get-buffer (cadr (assoc 'buffer (cdr marker-desc)))))
  189.           )                ; set-marker
  190.   )                    ; defun tst-convert-marker
  191.  
  192.  
  193. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  194. ;; buffers
  195.  
  196. (defun tst-achieve-bufs-state (bufs-states)
  197.   "Achieve the buffer states as saved in BUFS-STATES.
  198. See tst-capture-buffers-state for definition of BUFS-STATES.
  199. If tst-achieve-buffers-nondestructively is t, buffers not in state are
  200. not killed." 
  201.                     ; Local Variables
  202.   (let ((state-buf-list) (buf-list))
  203.     
  204.     ;; setup each buffer that's in bufs-states
  205.     (message "Achieving state of buffers...")
  206.     (mapcar 'tst-achieve-buf-state bufs-states) 
  207.  
  208.     ;; delete superfluous buffers
  209.     (setq state-buf-list (mapcar 'tst-state-get-buf-name bufs-states))
  210.     (setq buf-list (mapcar 'buffer-name (buffer-list)))
  211.     (if (and (boundp tst-achieve-buffers-nondestructively)
  212.          tst-achieve-buffers-nondestructively)
  213.     nil
  214.       ;; else
  215.       (while buf-list 
  216.     (if (not (member (car buf-list) state-buf-list))
  217.         (progn
  218.           (kill-buffer (car buf-list))
  219.           (message (concat "Killing buffer " (car buf-list) "...")))
  220.       (setq buf-list (cdr buf-list))
  221.       )                ; if
  222.     )                ; while
  223.       )                    ; if
  224.     )                    ; let
  225.   )                    ; defun tst-achieve-bufs-state
  226.  
  227.  
  228. (defun tst-achieve-buf-state (buf-state)
  229.   "Achieve the buffer state in BUF-STATE.  See tst-capture-buffer-state
  230. for definition of BUF-STATE."
  231.                                         ; Local Variables
  232.   (let ()
  233.                                         ; create buffer, set file
  234.     (set-buffer (get-buffer-create (cadr (assoc 'buf-state-name buf-state))))
  235.     (set-visited-file-name (cadr (assoc 'buf-state-file buf-state)))
  236.  
  237.                                         ; clear buffer contents and refill
  238.     (if buffer-read-only (toggle-read-only))
  239.     (delete-region (point-min) (point-max))
  240.     (insert (cadr (assoc 'buf-state-contents buf-state)))
  241.  
  242.                                         ; set point and mark
  243.     (set-mark (cadr (assoc 'buf-state-mark buf-state)))
  244.     (goto-char (cadr (assoc 'buf-state-point buf-state)))
  245.  
  246.                     ; set buffer flag(s)
  247.     (set-buffer-modified-p (cadr (assoc 'buf-state-modified buf-state)))
  248.  
  249.                                         ; set local variables
  250.     (kill-all-local-variables)
  251.     (tst-achieve-local-vars (cadr (assoc 'buf-state-local-vars buf-state)))
  252.     (use-local-map (cadr (assoc 'buf-state-local-map buf-state)))
  253.     ) ; let
  254.   ) ; defun tst-achieve-buf-state
  255.  
  256. (defun tst-achieve-local-vars (pairs)
  257.   "Take list of (VARIABLE . VALUE) pairs and makes local variables 
  258. initialized to the value." 
  259.   (let ((localflag t))
  260.     (mapcar
  261.                     ; the lambda here allows
  262.                     ; mapcar to pass a second
  263.                     ; argument localflag to
  264.                     ; function tst-achieve-sym
  265.                     ; while applying it to every
  266.                     ; element in list pairs
  267.      '(lambda (pair)
  268.     (tst-achieve-sym pair localflag))
  269.      pairs)
  270.     )                    ; let
  271.   )                    ; defun tst-achieve-local-vars
  272.  
  273. (defun tst-state-get-buf-name (bufstate)
  274.   "Get name of buffer from BUFSTATE.  See tst-capture-buffer-state for 
  275. definition fo BUFSTATE."
  276.   (cadr (assoc 'buf-state-name bufstate))
  277.   ) ; defun tst-state-get-buf-name
  278.  
  279.  
  280. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  281. ;; windows
  282.  
  283. (defun tst-achieve-windows-state (wstates)
  284.   "Set the state of all windows to that described in the input list"
  285.   (let ((sibling) (leftc-edges))
  286.     (if (assoc 'split wstates)
  287.     (progn
  288.       (setq leftc-edges
  289.         (cadr (assoc 'window-edges
  290.                  (car (cadr (assoc 'children wstates))))))
  291.       (if (equal 'h (cadr (assoc 'split wstates)))
  292.           (split-window-horizontally
  293.            (-
  294.         (cadr (cdr leftc-edges))
  295.         (car leftc-edges)
  296.         )
  297.            )
  298.         ;else vertical split
  299.         (split-window-vertically
  300.          (-
  301.           (cadr (cddr leftc-edges))
  302.           (cadr leftc-edges)
  303.           )
  304.          )
  305.         )                ;if
  306.       (setq sibling (next-window))
  307.       ;descend to the left child
  308.       (tst-achieve-windows-state (car (cadr (assoc 'children wstates))))
  309.       ;go to the right child and achieve that
  310.       (select-window sibling)
  311.       (tst-achieve-windows-state
  312.        (cadr (cadr (assoc 'children wstates))))
  313.       )                ;progn
  314.       (tst-achieve-window-state wstates)
  315.       )                    ;if assoc splits...
  316.     )                    ;let
  317.   )                    ;defun
  318.  
  319. (defun tst-achieve-window-state (wstate)
  320.   "Set the state of the current window to that discribed in the input
  321.    a-list"
  322.   (let ()
  323.     (set-window-buffer (selected-window) (cadr (assoc 'window-buffer wstate)))
  324.     (set-window-point (selected-window) (cadr (assoc 'window-point wstate)))
  325.     (set-window-start (selected-window) (cadr (assoc 'window-start wstate)))
  326.     )                    ;let
  327.   )                    ;defun tst-achieve-window-state
  328.  
  329. (defun tst-find-cur-window (wstates)
  330.   "Given an input list of WINDOW STATES, find the one that is the current
  331.    window of the of the state.  This window has the attribute 'current-window
  332.    set to t.  Return t when this window is found."
  333.   (let ()
  334.     (if (assoc 'children wstates) ;if is is a compound window
  335.     ; descend down the left subtree
  336.     (if (not (tst-find-cur-window (car (cadr (assoc 'children wstates)))))
  337.         ;now only descend down right subtree if left was unsuccessful
  338.         (tst-find-cur-window (cadr (cadr (assoc 'children wstates))))
  339.       )                ;if goto-cur...
  340.       ; if it is a single window go to it if current-window is true
  341.       (if (cadr (assoc 'current-window wstates))
  342.       (tst-goto-described-window wstates)
  343.     )                ;if assoc 'current-window
  344.       )                    ;if assoc 'children...
  345.     )                    ;let
  346.   )                    ;defun
  347.  
  348. (defun tst-goto-described-window (wstate)
  349.   "Given an input WINDOW STATE, cycle through existing windows until we
  350.    settle in the one with edges of the one described in the state"
  351.   (let ()
  352.     (while (not (equal (window-edges (selected-window))
  353.                (cadr (assoc 'window-edges wstate))
  354.                )
  355.         )
  356.       (select-window (next-window))
  357.       )                    ;while
  358.     )                    ;let
  359.   )                    ;defun tst-goto-described-window
  360.  
  361.