home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / gnu / lucid / help-lucid-emacs / text0440.txt < prev    next >
Encoding:
Text File  |  1993-07-14  |  16.5 KB  |  562 lines
  1. Hi,
  2.  
  3. I've just written my new hm--dired-menu.el Version 1.03 for the lemacs. I've
  4. tested it under SunOS 4.1.3 and under Linux, but only with the lemacs 19.4.
  5. But I think it should work with lemacs 19.6 too. This file provides a Pulldown
  6. and PopUp menu for the dired mode and requires the files dired.el and 
  7. mode-motion.el, which are in the normal distribution of the lemacs. There
  8. are some installation hints in the file header.
  9.  
  10.  
  11. I hope you will enjoy the menus,
  12.  
  13. Heiko
  14.  
  15. PS: I think we need a new newsgroup (alt.lucid-emacs.source) to post lisp
  16.     code especially for the lemacs, because I think this newsgroup should
  17.     only be used for help questions and answers and the newsgroup 
  18.     gnu.emacs.sources should only be used to post code for the GNU emacs.
  19.  
  20.  
  21.  
  22. ----- cut here -----
  23. ;;;  hm--dired-menu.el: A menu for the dired-mode.
  24. ;;;  v1.03; 2 Jun 1993
  25. ;;;  Copyright (C) 1993  Heiko Muenkel
  26. ;;;  email: muenkel@tnt.uni-hannover.de
  27. ;;;
  28. ;;;  This program is free software; you can redistribute it and/or modify
  29. ;;;  it under the terms of the GNU General Public License as published by
  30. ;;;  the Free Software Foundation; either version 1, or (at your option)
  31. ;;;  any later version.
  32. ;;;
  33. ;;;  This program is distributed in the hope that it will be useful,
  34. ;;;  but WITHOUT ANY WARRANTY; without even the implied warranty of
  35. ;;;  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  36. ;;;  GNU General Public License for more details.
  37. ;;;
  38. ;;;  You should have received a copy of the GNU General Public License
  39. ;;;  along with this program; if not, write to the Free Software
  40. ;;;  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  41. ;;;
  42. ;;; 
  43. ;;; Installation: 
  44. ;;;   Put hm--dired-menu.el in a load-path- directory (lisp/dired for example).
  45. ;;;   Write the following line in your .emacs- file:
  46. ;;;
  47. ;;;   (load-library "hm--dired-menu")
  48. ;;;  
  49. ;;;   If you want to load this file only, if you use the dired-mode, you
  50. ;;;   you should instead write the above line at the end of the dired.el 
  51. ;;;   file (don't forget to recompile the dired.el after that).
  52. ;;; 
  53.  
  54.  
  55. (provide 'hm--dired-menu)
  56. (require 'dired)
  57. (require 'mode-motion)
  58.  
  59.  
  60.  
  61. ; Try to set the max-lisp-eval-depth higher, if one of the following
  62. ; function fails with the message that the max lisp eval depth is
  63. ; excided.
  64.  
  65. (if (< max-lisp-eval-depth 400)
  66.     (setq max-lisp-eval-depth 400))
  67.  
  68.  
  69. ;; Popup and Pulldown Menu
  70.  
  71.  
  72. (defvar hm--dired-menu nil "*A list with the menue Dired.")
  73.  
  74.  
  75. (setq hm--dired-menu
  76.        '("Dired Menu"
  77.      ("Mark"
  78. ;      ["Mark file" dired-mark-file t]
  79.       ["Mark subdir or file" dired-mark-subdir-or-file t]
  80.       ["Mark region" hm--dired-mark-region t]
  81.       ["Mark files regexp..." dired-mark-files-regexp t]
  82.       ["Mark directories" dired-mark-directories t]
  83. ;      ["Mark subdir files" dired-mark-subdir-files nil]
  84.       ["Mark executables" dired-mark-executables t]
  85.       ["Mark symlinks" dired-mark-symlinks t]
  86.       "----"
  87.       ["Unmark file" dired-unmark-subdir-or-file t]
  88.       ["Unmark all files" (dired-unflag-all-files nil) t]
  89.       ["Query unmark all files..." (dired-unflag-all-files nil t) t]
  90.       )
  91.      "----"
  92.      ("Copy/Link"
  93.       ["Copy files..." dired-do-copy t]
  94.       ["Copy regexp files..." dired-do-copy-regexp t]
  95.       "----"
  96.       ["Sym-link files in directory..." dired-do-symlink t]
  97.       ["Sym-link regexp files in directory..." 
  98.        dired-do-symlink-regexp t]
  99.       "----"
  100.       ["Hard-link files in directory..." dired-do-hardlink t]
  101.       ["Hard-link regexp files in directory..." 
  102.        dired-do-hardlink-regexp t]
  103.       )
  104.      ("Rename"
  105.       ["Rename files..." dired-do-move t]
  106.       ["Rename regexp files..." dired-do-rename-regexp t]
  107.       "----"
  108.       ["Downcase files..." dired-downcase t]
  109.       ["Upcase files..." dired-upcase t]
  110.       )
  111.      ("Delete"
  112.       ["Delete marked files..." dired-do-delete t]
  113.       ["Delete flaged files..." dired-do-deletions t]
  114.       "----"
  115.       ["Flag file" dired-flag-file-deleted t]
  116.       ["Flag regexp files..."  dired-flag-regexp-files t]
  117.       ["Flag backup files" dired-clean-directory t]
  118.       ["Flag auto save files" dired-flag-auto-save-files t]
  119.       "----"
  120.       ["Unflag file" dired-unflag t]
  121.       ["Unflag backup files" dired-backup-unflag t]
  122.       ["Unflag all files" (dired-unflag-all-files nil) t]
  123.       ["Query unflag all files..." (dired-unflag-all-files nil) t]
  124.       )
  125.      ("Shell commands"
  126.       ["Compress files..." dired-do-compress t]
  127.       ["Uncompress files..." dired-do-uncompress t]
  128.       ["Print files..." dired-do-print t]
  129.       ["Shell command on files..." dired-do-shell-command t]
  130.       ["Byte compile files..." dired-do-byte-compile t]
  131.       "----"
  132.       ("Compare"
  133.        ["Backup diff" dired-backup-diff t]
  134.        ["Diff file..." dired-diff t]
  135.        )
  136.       ("File properties"
  137.        ["Change mod of files..." dired-do-chmod t]
  138.        ["Change group of files..." dired-do-chgrp t]
  139.        ["Change owner of files..." dired-do-chown t]
  140.        )
  141.       )
  142.      ("Load/Find"
  143.       ["Load file" dired-do-load t]
  144.       ["Find file" dired-find-file t]
  145.       ["Find file other window" dired-find-file-other-window t]
  146.       ["View file" dired-view-file t]
  147.       )
  148.      "----"
  149.      ("Directory"
  150.       ("Goto"
  151.        ["Up directory" dired-up-directory t]
  152.        )
  153.       "----"
  154.       ["Dired..." dired t]
  155.       ["Dired other window..." dired-other-window t]
  156.       ["Quit" dired-quit t]
  157.       "----"
  158.       ["Create directory..." dired-create-directory t]
  159.       "----"
  160.       ["Insert subdir" dired-insert-subdir t]
  161. ;      ["Maybe insert subdir" dired-maybe-insert-subdir t]
  162.       ["Hide subdir" dired-kill-subdir t]
  163.       ["Hide all subdirs..." dired-kill-tree t]
  164. ;      ["Build subdir alist" dired-build-subdir-alist t]
  165.       )
  166.      ("Goto"
  167.       ["Next Page" scroll-up t]
  168.       ["Next dirline" dired-next-dirline t]
  169.       ["Next marked file" dired-next-marked-file t]
  170. ;      ["Next line" dired-next-line t]
  171.       ["End of buffer" end-of-buffer t]
  172.       "----"
  173.       ["Previous Page" scroll-down t]
  174.       ["Previous dirline" dired-prev-dirline t]
  175.       ["Previous marked file" dired-prev-marked-file t]
  176. ;            ["Previous line" dired-previous-line t]
  177.       ["Begin of buffer" beginning-of-buffer t]
  178.       "----"
  179.       ["File..." dired-goto-file t]
  180.       ["Headerline..." dired-goto-subdir t]
  181.       ["Subdir down" dired-tree-down t]
  182.       ["Subdir up" dired-tree-up t]
  183.       )
  184.      ("Customize"
  185.       ["Undisplay line or subdir" dired-kill-line-or-subdir t]
  186. ;      ["Undisplay line" dired-kill-line t]
  187. ;      ["Undisplay subdir" dired-kill-subdir t]
  188.       ["Undisplay tree" dired-kill-tree t]
  189.       ["Undisplay marked lines" dired-do-kill t]
  190.       "----"
  191. ;      ["(Un)Hide subdir" dired-hide-subdir t]
  192. ;      ["Hide all subdirs" dired-hide-subdir t]
  193.       ["Toggle sort by date/name" dired-sort-toggle-or-edit t]
  194.       ["Hide '.' files" hm--dired-hide-.-files t]
  195.       ["Show '.' files" hm--dired-show-.-files t]
  196.       ["Edit ls switches..." (dired-sort-toggle-or-edit t) t]
  197.       "----"
  198.       ["Redisplay all files" revert-buffer t]
  199.       ["Redisplay all marked files" dired-do-redisplay t]
  200.       ["Undo" dired-undo t]
  201.       "----"
  202.       ["Set no of active buffers" hm--dired-set-no-of-active-buffers
  203.        t]
  204.       ["Define mouse bottons" hm--dired-define-keys t]
  205. ;;;;      ["Kill all dired buffers" 
  206. ;      ["Summary" dired-summary t]
  207.       ["Why" dired-why t]
  208.       )
  209.      ))
  210.  
  211.  
  212. (defun hm--install-dired-menu ()
  213.   "Installs the Dired menu at the menubar."
  214.   (if (and current-menubar (not (assoc "Dired" current-menubar)))
  215.       (progn
  216.     (set-buffer-menubar (copy-sequence current-menubar))
  217.     (add-menu nil "Dired" (cdr hm--dired-menu)))))
  218.  
  219.  
  220. (defun hm--popup-dired-menu (event)
  221.   "Display the Dired Menu."
  222.   (interactive "@e")
  223.   (mouse-set-point event)
  224.   (hm--dired-make-submenu-with-subdirs)
  225.   (popup-menu hm--dired-menu))
  226.  
  227.  
  228.  
  229. ;; Highlighting
  230.  
  231.  
  232. (defun hm--dired-highlight ()
  233.   "Highlights the lines in the dired buffer under the mouse."
  234. ;  (require 'mode-motion)
  235.   (setq mode-motion-hook 'mode-motion-highlight-line))
  236.  
  237.  
  238.  
  239. ;; Find file with the mouse
  240.  
  241.  
  242. (defun hm--dired-mouse-find-file (event)
  243.   "Function for find-file with the mouse."
  244.   (interactive "e")
  245.   (mouse-set-point event)
  246.   (dired-find-file))
  247.  
  248.  
  249.  
  250. ;; Functions and Variables which limits the number of dired buffers 
  251.  
  252.  
  253. (defvar hm--dirbuffer-list nil "*List with all dired buffers")
  254.  
  255.  
  256. (defun hm--dired-put-dirbuffer-in-list ()
  257.   (setq hm--dirbuffer-list (append hm--dirbuffer-list (list (buffer-name)))))
  258.  
  259.  
  260. (defvar hm--dired-old-buffer-name nil
  261.   "Holds the old buffername.")
  262.  
  263.  
  264. (defun hm--dired-kill-oldest-n-buffers (n)
  265.   "Kill the oldest n dired buffers."
  266.   (buffer-name)
  267.   (cond ((zerop n))
  268.     (t (cond ((equal (buffer-name) (car hm--dirbuffer-list))
  269.           (setq hm--dirbuffer-list 
  270.             (cdr (append hm--dirbuffer-list (list (buffer-name)))))
  271.           (hm--dired-kill-oldest-n-buffers n))
  272.          ((equal hm--dired-old-buffer-name (car hm--dirbuffer-list))
  273.           (setq hm--dirbuffer-list 
  274.             (cdr (append hm--dirbuffer-list 
  275.                      (list hm--dired-old-buffer-name))))
  276.           (hm--dired-kill-oldest-n-buffers n))
  277.          (t (kill-buffer (car hm--dirbuffer-list))
  278.             (setq hm--dirbuffer-list
  279.               (cdr hm--dirbuffer-list))
  280.             (hm--dired-kill-oldest-n-buffers (- n 1)))))))
  281.   
  282.  
  283. (defvar hm--dired-no-of-active-buffers 2 
  284. "*nil = all dired buffers will be active;
  285. n = only n dired buffers will be active;")
  286.  
  287.  
  288. (defun hm--dired-kill-oldest-buffers ()
  289.   "Kill the oldest dired buffers, so that only 
  290. hm--dired-no-of-active-buffers will be active after 
  291. this function call."
  292.   (interactive)
  293.   (if (and hm--dired-no-of-active-buffers
  294.        (< hm--dired-no-of-active-buffers (length hm--dirbuffer-list)))
  295.       (hm--dired-kill-oldest-n-buffers 
  296.        (- (length hm--dirbuffer-list) hm--dired-no-of-active-buffers))))
  297.  
  298.  
  299. (defun hm--dired-set-no-of-active-buffers (n)
  300.   "Set the number of active dired buffers.
  301. A negative value or 0 or 1 means, that no buffers will be killed."
  302.   (interactive "nMax no of active dired buffers (0 = no limit, 2, 3, 4,...): ")
  303.   (if (<= n 1)
  304.       (setq hm--dired-no-of-active-buffers nil)
  305.     (setq hm--dired-no-of-active-buffers n))
  306.   (hm--dired-kill-oldest-buffers))
  307.  
  308.  
  309. (defvar old-buf nil 
  310.   "This variable is normaly declared in the file dired.el and is
  311. used in the hm--dired-menu to determine the last visted dired-buffer.
  312. This is nessessary, because there is no other way (a hook for example)
  313. to do that.")
  314.  
  315.  
  316. (defun hm--dired-update-bufferlist-and-kill-oldest-buffers ()
  317.   (hm--dired-put-dirbuffer-in-list)
  318.   (setq hm--dired-old-buffer-name (buffer-name old-buf))
  319.   (switch-to-buffer (buffer-name))
  320.   (hm--dired-kill-oldest-buffers))
  321.  
  322.  
  323.  
  324. ;; Mark files in region for Copy, Delete ...
  325.  
  326.  
  327. (defun hm--dired-mark-region ()
  328.   "Mark all Files in the region."
  329.   (interactive)
  330.   (let ((start (region-beginning))
  331.     (end (region-end))
  332.     (position (point)))
  333.     (goto-char start)
  334.     (beginning-of-line)
  335.     (setq start (point))
  336.     (dired-mark-files-in-region start end)
  337.     (goto-char position)
  338.     (zmacs-deactivate-region)))
  339.  
  340.  
  341. ;; Functions and Variables for hiding and showing dot-files.
  342.  
  343.  
  344. (defvar hm--dired-hide-.-files "t = .-files are hide in the current buffer")
  345.  
  346. (setq hm--dired-hide-.-files nil)
  347.  
  348. ;(make-variable-buffer-local 'hm--dired-hide-.-files)
  349.  
  350.  
  351. (defun hm--dired-hide-.-files-in-buffer (buffer)
  352.   "Hide .-files in the dired-mode in the buffer buffer."
  353.   (set-buffer buffer)
  354.   (setq hm--dired-hide-.-files t)
  355.   (add-menu-item '("Dired") "Up directory" 'dired-up-directory t "Mark")
  356.   (setq dired-listing-switches "-l")
  357.   (setq dired-actual-switches "-l")
  358.   (revert-buffer))
  359.  
  360.  
  361. (defun hm--dired-hide-.-files-in-buffer-list (buffer-list)
  362.   "Hide .-files in the dired-mode in all buffers of the buffer-list."
  363.   (if buffer-list
  364.       (progn
  365.     (hm--dired-hide-.-files-in-buffer (car buffer-list))
  366.     (hm--dired-hide-.-files-in-buffer-list (cdr buffer-list)))))
  367.  
  368.  
  369. (defun hm--dired-hide-.-files ()
  370.   "Hide .-files in the dired-mode in all buffers."
  371.   (interactive)
  372.   (save-excursion
  373.     (if (not hm--dired-hide-.-files)
  374.     (progn
  375.       (setq hm--dired-menu 
  376.         (append '()
  377.             (list (car hm--dired-menu)
  378.                   ["Up directory" dired-up-directory t]
  379.                   "----")
  380.             (cdr hm--dired-menu)))
  381.       (hm--dired-hide-.-files-in-buffer-list hm--dirbuffer-list)))))
  382.  
  383.  
  384. (defun hm--dired-show-.-files-in-buffer (buffer)
  385.   "Show .-files in the dired-mode in buffer buffer."
  386.   (set-buffer buffer)
  387.   (setq hm--dired-hide-.-files nil)
  388.   (delete-menu-item '("Dired" "Up directory"))
  389.   (setq dired-listing-switches "-al")
  390.   (setq dired-actual-switches "-al")
  391.   (revert-buffer))
  392.  
  393.  
  394. (defun hm--dired-show-.-files-in-buffer-list (buffer-list)
  395.   "Show .-files in the dired-mode in all buffers of the buffer-list."
  396.   (if buffer-list
  397.       (progn
  398.     (hm--dired-show-.-files-in-buffer (car buffer-list))
  399.     (hm--dired-show-.-files-in-buffer-list (cdr buffer-list)))))
  400.  
  401.  
  402. (defun hm--dired-show-.-files ()
  403.   "Show .-files in the dired-mode in all buffers."
  404.   (interactive)
  405.   (save-excursion
  406.     (if hm--dired-hide-.-files
  407.     (progn
  408.       (setq hm--dired-menu 
  409.         (append '()
  410.             (list (car hm--dired-menu))
  411.             (cdr (cdr (cdr hm--dired-menu)))))
  412.       (hm--dired-show-.-files-in-buffer-list hm--dirbuffer-list)))))
  413.  
  414.  
  415.  
  416. ;; Clearing a buffer
  417.  
  418.  
  419. (defun hm--clear-buffer (buffer)
  420.   "Functions clears the buffer."
  421.   (interactive "bBuffername")
  422.   (delete-region (point-min) (point-max)))
  423.  
  424.  
  425.  
  426. ;; Functions which builds a submenu with the subdirectories
  427. ;; of the current directory.
  428.  
  429.  
  430. (defvar hm--dired-ls-flags "-AFL" 
  431.   "*A String with the flags used in the function hm--dired-ls for
  432. the ls command. This function is used to build the Menu
  433. (\"Dired\" \"Directory\" \"Goto\"). Be carefull if you want to
  434. change this variable. The ls command must append a / on all files
  435. which are directories. The original flags are -AFL.")
  436.  
  437.  
  438. (defun hm--dired-ls ()
  439. "List the current directory in the buffer *hm-dired-tmp*."
  440.   (interactive)
  441.   (switch-to-buffer "*hm-dired-tmp*")
  442.   (hm--clear-buffer "*hm-dired-tmp*")
  443.   (call-process "ls" nil "*hm-dired-tmp*" nil hm--dired-ls-flags)
  444.   (goto-char (point-min)))
  445.  
  446.  
  447. (defun hm--dired-get-next-dir ()
  448. "Returns the next directoryname of the current buffer as string." 
  449.   (interactive)
  450.   (let ((repeat-search-p t)
  451.     (subdirectory nil))
  452.     (while repeat-search-p
  453.       (forward-word 1)
  454.       (end-of-line)
  455.       (if (not (char-after (point)))
  456.       (setq repeat-search-p nil)
  457.        (cond ((char-equal (char-after (- (point) 1)) ?/)
  458.           (set-mark (point))
  459.           (beginning-of-line)
  460.           (exchange-point-and-mark)
  461.           (setq subdirectory
  462.             (buffer-substring (mark t) (- (point) 1)))
  463.           (setq repeat-search-p nil)))))
  464.     subdirectory))
  465.  
  466.  
  467. ; The foolowing recursive function is correct, but fails if to many
  468. ; files are in a directory and the max-lisp-eval-depth is to small (Then
  469. ; the max-lisp-eval-depth exceeds.)
  470.  
  471. ;(defun hm--dired-get-next-dir ()
  472. ;"Returns the next directoryname of the current buffer as string." 
  473. ;; (interactive)
  474. ;  (forward-word 1)
  475. ;  (end-of-line)
  476. ;   (if (not (char-after (point)))
  477. ;       nil
  478. ;     (progn
  479. ;       (cond ((char-equal (char-after (- (point) 1)) ?/)
  480. ;          (set-mark (point))
  481. ;          (beginning-of-line)
  482. ;          (exchange-point-and-mark)
  483. ;          (buffer-substring (mark t) (- (point) 1)))
  484. ;         (t (hm--dired-get-next-dir))))))
  485.  
  486.  
  487. (defun hm--dired-make-subdirlist (subdirname)
  488. "Function returns a list with the subdirmenu."
  489.   (cond ((not subdirname) ())
  490.     (t (cons (vector subdirname
  491.              (list 'dired subdirname)
  492.              t)
  493.          (hm--dired-make-subdirlist (hm--dired-get-next-dir))))))
  494.  
  495.  
  496. (defun hm--dired-make-submenu-with-subdirs ()
  497.   "Function generates the goto submenu with the subdir entrys."
  498.   (interactive)
  499.   (let ((submenu nil))
  500.     (save-excursion
  501.       (hm--dired-ls)
  502.       (setq submenu
  503.         (hm--dired-make-subdirlist (hm--dired-get-next-dir)))
  504.       (kill-buffer "*hm-dired-tmp*"))
  505.     (add-menu '("Dired" "Directory") 
  506.           "Goto"
  507.           (cons
  508.            ["Up directory" dired-up-directory t]
  509.            (cons
  510.         "----"
  511.         submenu)))))
  512.  
  513.  
  514. (defun hm--dired-build-subdir-pulldown-menu ()
  515. "Hook-Function which builds a new subdir menu, if one selects the
  516. menubar in the Dired-mode. It is an activate-menubar-hook."
  517.   (if (string-equal mode-name "Dired")
  518.       (hm--dired-make-submenu-with-subdirs)))
  519.  
  520.  
  521.  
  522. ;; Adding Hooks
  523.  
  524.  
  525. (add-hook 'activate-menubar-hook 'hm--dired-build-subdir-pulldown-menu)
  526.  
  527.  
  528. (add-hook 'dired-mode-hook 'hm--dired-highlight)
  529.  
  530.  
  531. (add-hook 'dired-mode-hook 'hm--install-dired-menu)
  532.  
  533.  
  534. (add-hook 'dired-mode-hook ;'dired-after-readin-hook 
  535.       'hm--dired-update-bufferlist-and-kill-oldest-buffers)
  536.  
  537.  
  538. ;; Defining the mouse buttons
  539.  
  540. (defun hm--dired-define-keys ()
  541.   "Function defines keys for the hm--dired-menu.
  542. This function is used in the dired menu."
  543.   (define-key dired-mode-map '(button2) 'hm--dired-mouse-find-file)
  544.   (define-key dired-mode-map '(button3) 'hm--popup-dired-menu))
  545.  
  546. (hm--dired-define-keys)
  547. ----- cut here -----
  548.  
  549.  
  550.  
  551. --
  552. ________________________________________________________________________________
  553.  
  554. Dipl.-Ing. Heiko Muenkel           Universitaet Hannover
  555.                    Institut fuer Theoretische Nachrichtentechnik
  556.                    und Informationsverarbeitung
  557. muenkel@tnt.uni-hannover.de        Appelstrasse 9A
  558. fax:    +49-511-762-5333           D-3000 Hannover 1
  559. phone:  +49-511-762-5323           Germany
  560. ________________________________________________________________________________
  561.  
  562.