home *** CD-ROM | disk | FTP | other *** search
/ SGI Developer Toolbox 6.1 / SGI Developer Toolbox 6.1 - Disc 4.iso / public / GNU / emacs.inst / emacs19.idb / usr / gnu / lib / emacs / site-lisp / uniquify.el.z / uniquify.el
Encoding:
Text File  |  1994-08-02  |  6.9 KB  |  204 lines
  1. ;;; uniquify.el  Unique buffer names in a rational way
  2. ;;; Time stamp <89/06/05 11:50:27 gildea>
  3. ;;; Copyright (c) 1989 Free Software Foundation, Inc.
  4.  
  5. ;;; This program is free software; you can redistribute it and/or modify
  6. ;;; it under the terms of the GNU General Public License version 1 as
  7. ;;; published by the Free Software Foundation.
  8.  
  9. ;;; This program is distributed in the hope that it will be useful,
  10. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12. ;;; GNU General Public License for more details.
  13.  
  14. ;;; This file is not part of GNU Emacs.
  15.  
  16. ;;; Doesn't correctly handle new buffer names created by M-x write-file
  17.  
  18. ;;; Originally by Dick King <king@kestrel> 15 May 86
  19. ;;; Converted for Emacs 18 by Stephen Gildea <gildea@bbn.com>
  20. ;;; Make minimum-buffer-name-dir-content 0 truly non-invasive  gildea 23 May 89
  21. ;;; Some cleanup.  minimum-buffer-name-dir-content default 0 gildea 01 Jun 89
  22.  
  23. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  24. ;;; From gildea@bbn.com Wed Jun  7 18:27:04 1989
  25. ;;; To: info-gnu-emacs@prep.ai.mit.edu
  26. ;;; Subject: new version of uniquify.el
  27. ;;; Date: Wed, 07 Jun 89 13:36:40 -0400
  28. ;;; From: Stephen Gildea <gildea@bbn.com>
  29. ;;; 
  30. ;;; Uniquify is a package that allows your buffers to have intelligent
  31. ;;; names if you are editting more than one file with the same name.  The
  32. ;;; package uses the name of the enclosing directory or directories to
  33. ;;; generate unique buffer names.
  34. ;;; 
  35. ;;; The version posted here causes no modifications at all to non-conflicting
  36. ;;; buffer names when minimum-buffer-name-dir-content is 0, which was also
  37. ;;; changed to be the default.  It also cleans up some of the cruft in the
  38. ;;; previous version.
  39. ;;; 
  40. ;;;  < Stephen
  41. ;;; 
  42. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  43.  
  44. (provide 'uniquify)
  45.  
  46. (defvar mnemonic-buffer-names t
  47.   "*If non-nil, uniquifies buffer names with parts of directory name.")
  48.  
  49. (defvar minimum-buffer-name-dir-content 0
  50.   "*Minimum parts of directory pathname included in buffer name.")
  51.  
  52. (defmacro uniquify-push (item list)
  53.   (` (setq (, list) (cons (, item) (, list)))))
  54.  
  55. (defmacro fix-list-base (a)
  56.   (` (car (, a))))
  57.  
  58. (defmacro fix-list-filename (a)
  59.   (` (car (cdr (, a)))))
  60.  
  61. (defmacro fix-list-buffer (a)
  62.   (` (car (cdr (cdr (, a))))))
  63.  
  64. (defmacro uniquify-cadddr (a)
  65.   (` (car (cdr (cdr (cdr (, a)))))))
  66.  
  67.  
  68. ;;; Main entry point.
  69.  
  70. (defun rationalize-file-buffer-names (&optional newbuffile newbuf)
  71.   "Makes file buffer names unique by adding segments from pathname.
  72. If minimum-buffer-name-dir-content > 0, always pulls that many
  73. pathname elements.  Arguments cause only a subset of buffers to be renamed."
  74.   (interactive)
  75.   (let (fix-list
  76.     non-file-buffer-names
  77.     (depth minimum-buffer-name-dir-content))
  78.     (mapcar 'distribute-buffer-name-stuff (buffer-list))
  79.     ;; selects buffers whose names may need changing, and others that
  80.     ;; may conflict. 
  81.     (setq fix-list
  82.       (sort fix-list 'backward-filename-string-lessp-fix-list-filename))
  83.     ;; bringing conflicting names together
  84.     (rationalize-a-list fix-list depth)
  85.     (mapcar 'do-the-buffers-you-couldnt-rationalize fix-list)))
  86.  
  87.  
  88. (defun distribute-buffer-name-stuff (buffer)
  89.   ;; Sets the free variables fix-list and non-file-buffer-names.
  90.   ;; Uses free variables newbuffile and newbuf.
  91.   (let* ((bfn (if (eq buffer newbuf)
  92.           (expand-file-name newbuffile)
  93.         (buffer-file-name buffer)))
  94.      (rawname (and bfn (file-name-nondirectory bfn)))
  95.      (deserving (and rawname
  96.              (or (not newbuffile)
  97.                  (equal rawname
  98.                     (file-name-nondirectory newbuffile))))))
  99.     (if deserving
  100.     (uniquify-push (list rawname bfn buffer nil) fix-list)
  101.       (uniquify-push (list (buffer-name buffer)) non-file-buffer-names))))
  102.  
  103.  
  104. (defun backward-filename-string-lessp-fix-list-filename (s1 s2)
  105.   (backward-filename-string-lessp
  106.    (fix-list-filename s1) (fix-list-filename s2)))
  107.  
  108. (defun backward-filename-string-lessp (s1 s2)
  109.   (let ((s1f (file-name-nondirectory s1))
  110.     (s2f (file-name-nondirectory s2)))
  111.     (and (not (equal s2f ""))
  112.      (or (string-lessp s1f s2f)
  113.          (and (equal s1f s2f)
  114.           (let ((s1d (file-name-directory s1))
  115.             (s2d (file-name-directory s2)))
  116.             (and (not (<= (length s2d) 1))
  117.              (or (<= (length s1d) 1)
  118.                  (backward-filename-string-lessp
  119.                   (substring s1d 0 -1)
  120.                   (substring s2d 0 -1))))))))))
  121.  
  122. (defun do-the-buffers-you-couldnt-rationalize (item)
  123.   (or (uniquify-cadddr item) nil))    ;maybe better in the future
  124.  
  125. (defun rationalize-a-list (fix-list depth)
  126.   (let (conflicting-sublist
  127.     (old-name "")
  128.     proposed-name possibly-resolvable)
  129.     (mapcar 'go-through-an-item-on-fix-list fix-list)
  130.     (flush-fix-list)))
  131.  
  132. (defun go-through-an-item-on-fix-list (item)
  133.   (setq proposed-name (get-proposed-name))
  134.   (if (not (equal proposed-name old-name))
  135.       (flush-fix-list))      
  136.   (uniquify-push item conflicting-sublist)
  137.   (setq old-name proposed-name))
  138.  
  139. (defun get-proposed-name ()
  140.   (let (index (extra-string "") (n depth)
  141.           (base (fix-list-base item)) (fn (fix-list-filename item)))
  142.     (while (and (> n 0)
  143.         (setq index (string-match
  144.                  (concat "/[^/]*/"
  145.                      (regexp-quote extra-string)
  146.                      (regexp-quote base)
  147.                      "\\'")
  148.                  fn)))
  149.       (setq extra-string (substring fn 
  150.                     (if (zerop index) 0 (1+ index))
  151.                     (- (length base)))
  152.         n (1- n)))
  153.     (if (zerop n) (setq possibly-resolvable t))
  154.     (if (string-equal extra-string "")
  155.     base
  156.       (concat base "|" extra-string))))
  157.  
  158. (defun flush-fix-list ()
  159.   (or (null conflicting-sublist)
  160.       (and (null (cdr conflicting-sublist))
  161.        (not (assoc old-name non-file-buffer-names))
  162.        (or (rename-the-buffer (car conflicting-sublist) old-name)
  163.            t))
  164.       (if possibly-resolvable
  165.       (rationalize-a-list conflicting-sublist (1+ depth))))
  166.   (setq conflicting-sublist nil))
  167.  
  168. (defun rename-the-buffer (item newname)
  169.   (let ((buffer (fix-list-buffer item)))
  170.     (if (not (equal newname (buffer-name buffer)))
  171.     (let ((unset (current-buffer)))
  172.       (set-buffer buffer)
  173.       (rename-buffer newname)
  174.       (set-buffer unset))))
  175.   (rplaca (nthcdr 3 item) t))
  176.  
  177. ;;; Hooks from the rest of Emacs
  178.  
  179. (defun create-file-buffer (filename)    ;from files.el
  180.   "Creates a suitably named buffer for visiting FILENAME, and returns it."
  181.   (let ((base (file-name-nondirectory filename)))
  182.     (let ((buf (generate-new-buffer base)))
  183.       (if mnemonic-buffer-names
  184.       (rationalize-file-buffer-names filename buf))
  185.       buf)))
  186.  
  187. (defun dired-find-buffer (dirname)    ;from dired.el
  188.   (let ((blist (buffer-list))
  189.     found)
  190.     (while blist
  191.       (save-excursion
  192.         (set-buffer (car blist))
  193.     (if (and (eq major-mode 'dired-mode)
  194.          (equal dired-directory dirname))
  195.         (setq found (car blist)
  196.           blist nil)
  197.       (setq blist (cdr blist)))))
  198.     (or found
  199.     (progn (if (string-match "/$" dirname)
  200.            (setq dirname (substring dirname 0 -1)))
  201.            (create-file-buffer (if mnemonic-buffer-names
  202.                        dirname
  203.                      (file-name-nondirectory dirname)))))))
  204.