home *** CD-ROM | disk | FTP | other *** search
/ Fresh Fish 5 / FreshFish_July-August1994.bin / bbs / util / jade-3.0.lha / Jade / lisp / buffers.jl < prev    next >
Encoding:
Text File  |  1994-04-18  |  15.7 KB  |  454 lines
  1. ;;;; buffers.jl -- High-level buffer/file handling
  2. ;;;  Copyright (C) 1993, 1994 John Harper <jsh@ukc.ac.uk>
  3.  
  4. ;;; This file is part of Jade.
  5.  
  6. ;;; Jade is free software; you can redistribute it and/or modify it
  7. ;;; under the terms of the GNU General Public License as published by
  8. ;;; the Free Software Foundation; either version 2, or (at your option)
  9. ;;; any later version.
  10.  
  11. ;;; Jade is distributed in the hope that it will be useful, but
  12. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14. ;;; GNU General Public License for more details.
  15.  
  16. ;;; You should have received a copy of the GNU General Public License
  17. ;;; along with Jade; see the file COPYING.  If not, write to
  18. ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  
  20. (defvar auto-save-p t
  21.   "When t files are auto-save'd regularly.")
  22. (defvar default-auto-save-interval 120
  23.   "The number of seconds between each auto-save.")
  24.  
  25. (defvar make-backup-files t
  26.   "When non-nil backups of files are made when they are saved.")
  27. (defvar backup-by-copying nil
  28.   "When non-nil all file backups are made by copying the file, not by
  29. renaming it.")
  30.  
  31. (defvar amiga-use-file-req-p t
  32.   "*AMIGA ONLY*
  33. When non-nil the normal ASL file requester is used when file names are
  34. prompted for.")
  35.  
  36. (setq default-buffer (current-buffer))
  37.  
  38. (defvar buffer-list (cons default-buffer nil)
  39.   "List of buffers in most-recently-used order. Each window has it's own.")
  40. (set-window-variable 'buffer-list)
  41.  
  42. (defvar standard-output default-buffer
  43.   "Stream that `prin?' writes its output to by default")
  44. (defvar standard-input default-buffer
  45.   "Stream that `read' takes it's input from by default")
  46.  
  47. (defvar buffer-file-modtime 0
  48.   "Holds the modification time of the file this buffer was loaded from")
  49. (set-buffer-variable 'buffer-file-modtime)
  50.  
  51. (defun goto-buffer (buf)
  52.   "(goto-buffer BUFFER)
  53. Switch the current buffer to BUFFER which can either be a buffer-object
  54. or a string naming an existing buffer. The selected buffer is moved to
  55. the head of the buffer list."
  56.   (cond
  57.     ((stringp buf)
  58.       (setq buf (get-buffer buf)))
  59.     ((bufferp buf))
  60.     (t
  61.       (title "error: bad arg to goto-buffer")
  62.       (return)))
  63.   (setq buffer-list (cons buf (delq buf buffer-list)))
  64.   (set-current-buffer buf))
  65.  
  66. (defun open-file (name &aux buf)
  67.   "(open-file FILE-NAME)
  68. If no buffer containing file FILE-NAME exits try to create one.
  69.   After creating a new buffer (named after the file's (not path) name)
  70. it first call the hook `read-file-hook' with arguments `(file-name buffer)'
  71. If this hook returns nil (ie, no members of the hook decided to read the
  72. file into memory) the file is read into the buffer verbatim.
  73.   Once the file is in memory, through the hook or otherwise, this function
  74. then tries to initialise the correct editing mode for the file.
  75.   `open-file' always returns the buffer holding the file, or nil if it
  76. doesn't exist."
  77.   (unless (setq buf (get-file-buffer name))
  78.     (when (setq buf (make-buffer (base-name name)))
  79.       (add-buffer buf buffer-list)
  80.       (with-buffer buf
  81.     (unless (eval-hook 'read-file-hook name buf)
  82.       (set-file-name buf name)
  83.       (if (file-exists-p name)
  84.           (read-buffer name)
  85.         (title "New file")))
  86.     (set-buffer-modified buf nil)
  87.     (when auto-save-p
  88.       (setq auto-save-interval default-auto-save-interval))
  89.     (setq
  90.       buffer-file-modtime (file-modtime name)
  91.       last-save-time (current-time))
  92.     (when (auto-save-file-newer-p name)
  93.       (title "warning: auto-saved file is newer")
  94.       (beep))
  95.     (when (and (file-exists-p name) (not (file-writeable-p name)))
  96.       (set-buffer-read-only buf t))
  97.     (setq keymap-path (cons global-keymap nil))
  98.     (eval-hook 'open-file-hook buf)
  99.     (init-mode buf))))
  100.   buf)
  101.  
  102. (defun find-file (&optional name)
  103.   "(find-file [FILE-NAME])
  104. Sets the current buffer to that containing the file FILE-NAME, if FILE-NAME
  105. is unspecified it will be prompted for. If the file is not already in memory
  106. `open-file' will be used to load it."
  107.   (unless name
  108.     (setq name (funcall (if (and (amiga-p) amiga-use-file-req-p) 'file-req 'prompt-for-file)
  109.             "Find file: "
  110.             (path-name (file-name)))))
  111.   (when name
  112.     (goto-buffer (open-file name))))
  113.  
  114. (defun find-file-read-only (&optional name)
  115.   "(find-file-read-only [FILE-NAME])
  116. Similar to `find-file' except that the buffer is edited in read-only mode."
  117.   (unless name
  118.     (setq name (funcall (if (and (amiga-p) amiga-use-file-req-p) 'file-req 'prompt-for-file)
  119.             "Find file read-only:"
  120.             (path-name (file-name)))))
  121.   (when name
  122.     (let
  123.     ((buf (open-file name)))
  124.       (when buf
  125.     (set-buffer-read-only buf t)
  126.     (goto-buffer buf)))))
  127.  
  128. (defun open-alternate-file (name &optional buf)
  129.   "(open-alternate-file FILE-NAME [BUFFER] )
  130. Kills BUFFER and returns a buffer containing FILE-NAME (through the
  131. `kill-buffer' and `open-file' functions)."
  132.   (when (stringp name)
  133.     (when (null buf)
  134.       (setq buf (current-buffer)))
  135.     (kill-buffer buf)
  136.     (open-file name)))
  137.  
  138. (defun find-alternate-file (&optional name)
  139.   "(find-alternate-file [FILE-NAME])
  140. If FILE-NAME is unspecified one will be prompted for. The current buffer
  141. is killed and one editing FILE-NAME is found."
  142.   (unless name
  143.     (setq name (funcall (if (and (amiga-p) amiga-use-file-req-p) 'file-req 'prompt-for-file)
  144.             "Find alternate file: "
  145.             (path-name (file-name)))))
  146.   (when name
  147.     (goto-buffer (open-alternate-file name))))
  148.  
  149. (defun write-file (buf &optional name)
  150.   "(write-file BUFFER [FILE-NAME] )
  151. Writes the contents of BUFFER to the file FILE-NAME, or to the one
  152. that it is associated with."
  153.   (unless (stringp name)
  154.     (setq name (file-name buf)))
  155.   (unless (eval-hook 'write-file-hook buf name)
  156.     (when (and make-backup-files (file-regular-p name))
  157.       (let
  158.       ((backup-name (concat name ?~)))
  159.     (if backup-by-copying
  160.         (copy-file name backup-name)
  161.       (when (and (file-owner-p name)
  162.              (= (file-nlinks name) 1))
  163.         (when (file-exists-p backup-name)
  164.           (delete-file backup-name))
  165.         (rename-file name backup-name)))))
  166.     (write-buffer name buf)))
  167.  
  168. (defun save-file (&optional buf &aux name)
  169.   "(save-file [BUFFER])
  170. Saves the buffer BUFFER, or the current buffer, to the file that it is
  171. associated with, then sets the number of modifications made to this file
  172. to zero.
  173. Note: if no changes have been made to this buffer, it won't be saved."
  174.   (unless (bufferp buf)
  175.     (setq buf (current-buffer)))
  176.   (with-buffer buf
  177.     (if (not (buffer-modified-p))
  178.     (title "no changes need to be saved!")
  179.       (setq name (file-name))
  180.       (when (and
  181.          (> (file-modtime name) buffer-file-modtime)
  182.          (not (ask-yes-or-no "File on disk has changed since it was loaded, save anyway")))
  183.     (return nil))
  184.       (when (write-file buf)
  185.     (set-buffer-modified buf nil)
  186.     (setq
  187.       last-save-time (current-time)
  188.       last-save-changes (buffer-changes)
  189.       last-user-save-changes (buffer-changes))
  190.     (setq buffer-file-modtime (file-modtime name))
  191.     (delete-auto-save-file)
  192.     (format t "Saved file %S." name)))))
  193.  
  194. (defun save-file-as (&optional name buf &aux old-name)
  195.   "(save-file-as [FILE-NAME] [BUFFER])
  196. Saves the buffer BUFFER, or the current one, to the file FILE-NAME,
  197. resetting the name of the buffer and the file that it is associated with
  198. to reflect FILE-NAME. Also sets the modification count to zero."
  199.   (unless name
  200.     (setq name
  201.       (if (and (amiga-p) amiga-use-file-req-p)
  202.       (file-req "Write file:" (path-name (file-name)) t)
  203.     (prompt-for-file "Write file: " (path-name (file-name))))))
  204.   (unless (bufferp buf)
  205.     (setq buf (current-buffer)))
  206.   (with-buffer buf
  207.     (setq old-name (file-name))
  208.     (set-file-name buf name)
  209.     (set-buffer-name buf (base-name name))
  210.     (when (write-file buf)
  211.       (set-buffer-modified buf nil)
  212.       (setq
  213.     last-save-time (current-time)
  214.     last-save-changes (buffer-changes)
  215.     last-user-save-changes (buffer-changes))
  216.       (setq buffer-file-modtime (file-modtime name))
  217.       (delete-file (make-auto-save-name old-name))
  218.       (format t "Saved file %S." name))))
  219.  
  220. (defun insert-file (&optional name buf)
  221.   "(insert-file [FILE-NAME] [BUFFER])
  222. Inserts the file FILE-NAME (may be prompted for) into the buffer BUFFER (or
  223. the current one) before the cursor position."
  224.   (unless name
  225.     (setq name (funcall (if (and (amiga-p) amiga-use-file-req-p) 'file-req 'prompt-for-file)
  226.             "Insert file: "
  227.             (path-name (file-name)))))
  228.   (unless (bufferp buf)
  229.     (setq buf (current-buffer)))
  230.   (with-buffer buf
  231.     (insert (read-file name))))
  232.  
  233. (defun open-buffer (name &aux buf)
  234.   "(open-buffer NAME)
  235. If no buffer called NAME exists, creates one and adds it to the main
  236. buffer-list. Always returns the buffer."
  237.   (unless (setq buf (get-buffer name))
  238.     (when (setq buf (make-buffer name))
  239.       (add-buffer buf)))
  240.   buf)
  241.  
  242. (defun kill-buffer (&optional buf)
  243.   "(kill-buffer [BUFFER])
  244. Destroys BUFFER (can be an actual buffer or name of a buffer), first
  245. checks whether or not we're allowed to with the function `check-changes'.
  246.   If it can be deleted, all windows displaying this buffer are switched
  247. to the buffer at the head of the buffer-list, and BUFFER is removed
  248. from the buffer-list (if it was in it)."
  249.   (or buf
  250.       (setq buf (prompt-for-buffer (concat "Buffer to kill (default: "
  251.                        (buffer-name) ?\))))
  252.       (return))
  253.   (when (equal buf "")
  254.     (setq buf (current-buffer)))
  255.   (cond
  256.    ((bufferp buf))
  257.    ((stringp buf)
  258.       (setq buf (get-buffer buf))))
  259.   (when (and buf (check-changes buf))
  260.     (remove-buffer buf)
  261.     (unless (buffer-special-p buf)
  262.       (kill-mode buf)
  263.       (destroy-buffer buf))))
  264.  
  265. (defun rotate-buffers-forward (&aux head end)
  266.   "(rotate-buffers-forward)
  267. Moves the buffer at the head of the buffer-list to be last in the list, the
  268. new head of the buffer-list is displayed in the current window."
  269.   (setq
  270.     head (car buffer-list)
  271.     end (nthcdr (1- (length buffer-list)) buffer-list))
  272.   (rplacd end (cons head nil))
  273.   (setq buffer-list (cdr buffer-list))
  274.   (set-current-buffer (car buffer-list)))
  275.  
  276. ;(defun rotate-buffers-backward (&aux end)
  277. ;  "(rotate-buffers-backward)
  278. ;Moves the buffer at the end of the buffer-list to be first in the list, the
  279. ;new head of the buffer-list is displayed in the current window."
  280. ;  (setq
  281. ;    end (nthcdr (- 2 (length buffer-list)) buffer-list)
  282. ;    buffer-list (cons (last buffer-list) buffer-list))
  283. ;  (rplacd end nil)
  284. ;  (set-current-buffer (car buffer-list)))
  285.  
  286. (defun check-changes (&optional buf)
  287.   "(check-changes [BUFFER])
  288. Returns t if it is ok to kill BUFFER, or the current buffer. If unsaved
  289. changes have been made to it the user is asked whether (s)he minds losing
  290. them."
  291.   (or (not (buffer-modified-p buf))
  292.       (ask-yes-or-no (format-string "OK to lose change(s) to buffer %s"
  293.                     (base-name (buffer-name buf))))))
  294.  
  295. (defun goto-mark (mark)
  296.   "(goto-mark MARK)
  297. Switches (if necessary) to the buffer containing MARK at the position
  298. of the mark. If the file containing MARK is not in memory then we
  299. attempt to load it with `open-file'."
  300.   (when (markp mark)
  301.     (let*
  302.     ((file (mark-file mark))
  303.      (pos (mark-pos mark)))
  304.       (when (stringp file)
  305.     (setq file (open-file file)))
  306.       (set-auto-mark)
  307.       (goto-buffer file)
  308.       (goto pos))))
  309.  
  310. (defun set-auto-mark ()
  311.   "(set-auto-mark)
  312. Sets the mark `auto-mark' to the current position (buffer & cursor-pos)."
  313.   (set-mark auto-mark (cursor-pos) (current-buffer))
  314.   (title "Set auto-mark."))
  315.  
  316. (defun swap-cursor-and-auto-mark ()
  317.   "(swap-cursor-and-auto-mark)
  318. Sets the `auto-mark' to the current position and then sets the current
  319. position (buffer and cursor-pos) to the old value of `auto-mark'."
  320.   (let*
  321.       ((a-m-file (mark-file auto-mark))
  322.        (a-m-pos (dup-pos (mark-pos auto-mark))))
  323.     (set-auto-mark)
  324.     (when (stringp a-m-file)
  325.       (setq a-m-file (open-file a-m-file)))
  326.     (set-current-buffer a-m-file)
  327.     (goto a-m-pos)))
  328.  
  329. (defun split-line-indent ()
  330.   "(split-line-indent)
  331. Inserts a newline at the cursor position and then indents the new line
  332. created to the indentation of the one above it."
  333.   (let*
  334.       ((old-indent-pos (next-line 1 (indent-pos))))
  335.     (split-line)
  336.     (if (empty-line-p)
  337.     (goto old-indent-pos)
  338.       (set-indent-pos old-indent-pos))))
  339.  
  340. (defun make-auto-save-name (name)
  341.   "(make-auto-save-name FILE-NAME)
  342. Returns a string naming the file used to hold the auto-save'd file for
  343. file FILE-NAME."
  344.   (concat (path-name name) ?# (base-name name) ?#))
  345.  
  346. (defun auto-save-function (buf)
  347.   "(auto-save-function BUFFER)
  348. Automatically called when BUFFER is due to be automatically saved.
  349. This function calls the hook `auto-save-hook', if this returns nil it then
  350. saves it to the file specified by `make-auto-save-name' appiled to the
  351. name of the file stored in BUFFER."
  352.   (format t "Auto-saving %S..." (buffer-name buf))
  353.   (refresh-all)
  354.   (flush-output)
  355.   (with-buffer buf
  356.     (if (or (eval-hook 'auto-save-hook buf)
  357.         (write-buffer (make-auto-save-name (file-name))))
  358.     (format t "done.")
  359.       (format t "*error* can't auto-save.")
  360.       nil)))
  361.  
  362. (defun delete-auto-save-file (&optional buf)
  363.   "(delete-auto-save-file [BUFFER])
  364. Deletes the file used to store the auto-save'd copy of the file stored in
  365. BUFFER, if such a file exists."
  366.   (let
  367.       ((a-name (make-auto-save-name (file-name buf))))
  368.     (when (file-exists-p a-name)
  369.       (delete-file a-name))))
  370.  
  371. (defun auto-save-file-newer-p (name)
  372.   "(auto-save-file-newer-p FILE-NAME)
  373. Returns t if there exists an automatically saved copy of file FILE-NAME
  374. which is newer than FILE-NAME."
  375.   (let*
  376.       ((recover-name (make-auto-save-name name)))
  377.     (> (file-modtime recover-name) (file-modtime name))))
  378.  
  379. (defun recover-file (&optional buf)
  380.   "(recover-file [BUFFER])
  381. Loads the auto-saved copy of the file stored in BUFFER into BUFFER
  382. overwriting its current contents (if any changes are to be lost the user
  383. will have to agree to this)."
  384.   (let*
  385.       ((recover-name (make-auto-save-name (file-name buf))))
  386.     (unless buf
  387.       (setq buf (current-buffer)))
  388.     (when (and (file-exists-p recover-name) (check-changes buf))
  389.       (with-buffer buf
  390.     (read-buffer recover-name)
  391.     (set-buffer-modified buf nil)
  392.     (setq last-save-time (current-time))
  393.     (title (concat "using " recover-name " as "(file-name buf)))))
  394.     buf))
  395.  
  396. (defun revert-buffer (&optional buf)
  397.   "(revert-buffer [BUFFER])
  398. Restores the contents of BUFFER (or current buffer) to the contents of the
  399. file it was loaded from."
  400.   (unless buf
  401.     (setq buf (current-buffer)))
  402.   (if (and (auto-save-file-newer-p (file-name buf))
  403.        (ask-yes-or-no "auto-saved file is newer, use it?"))
  404.       (recover-file buf)
  405.     (when (check-changes buf)
  406.       (with-buffer buf
  407.     (unless (eval-hook 'read-file-hook (file-name buf) buf)
  408.       (read-buffer (file-name buf)))
  409.     (set-buffer-modified buf nil)
  410.     (setq last-save-time (current-time))))))
  411.  
  412. (defun switch-to-buffer ()
  413.   "(switch-to-buffer)
  414. Prompt for the name of a buffer and display it in the current window."
  415.   (let*
  416.       ((def (buffer-name (nth 1 buffer-list)))
  417.        (buf (prompt-for-buffer (concat "Switch to Buffer: (default: " def ?\)))))
  418.     (when buf
  419.       (goto-buffer (if (equal buf "") def buf)))))
  420.  
  421. (defun goto-line ()
  422.   "(goto-line)
  423. Prompt for a line number and move the cursor to it."
  424.   (set-auto-mark)
  425.   (goto (pos nil (read-from-string (prompt "Line: ")))))
  426.  
  427. (defun file-newer-than-file-p (file1 file2)
  428.   (> (file-modtime file1) (file-modtime file2)))
  429.  
  430. (defun save-some-buffers ()
  431.   "(save-some-buffers)
  432. Asks whether or not to save any modified buffers, returns t if no modified
  433. buffers are left."
  434.   (let*
  435.       ((bufs buffer-list)
  436.        buf
  437.        (unsaved-files-p nil))
  438.     (while (consp bufs)
  439.       (setq buf (car bufs))
  440.       (when (and (buffer-modified-p buf) (not (buffer-special-p buf)))
  441.     (if (ask-y-or-n (concat "Save buffer " (buffer-name buf)))
  442.         (unless (save-file buf)
  443.           (setq unsaved-files-p t))
  444.       (setq unsaved-files-p t)))
  445.       (setq bufs (cdr bufs)))
  446.     (not unsaved-files-p)))
  447.  
  448. (defun save-and-quit ()
  449.   "(save-and-quit)
  450. Calls `save-some-buffers' and quits (after asking whether it's ok to lose any
  451. unsaved buffers)."
  452.   (when (or (save-some-buffers) (ask-yes-or-no "Unsaved buffers exist: quit anyway?"))
  453.     (throw 'quit 0)))
  454.