home *** CD-ROM | disk | FTP | other *** search
/ Fresh Fish 4 / FreshFish_May-June1994.bin / bbs / may94 / util / edit / jade.lha / Jade / lisp / buffers.jl < prev    next >
Lisp/Scheme  |  1994-04-17  |  16KB  |  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.   (u