;;; -*- Emacs-Lisp -*-
;;; MARCHE interface for `dired'
;;; (c) 1993,1997,2000 HIROSE Yuuji [yuuji@gentei.org]
;;; $Id: dmarche.el,v 1.2 2000/12/14 14:20:30 yuuji Exp $
;;; Last modified Thu Dec 14 23:18:04 2000 on firestorm

;;; [Commentary]
;;;	  After  loading this,  you  can  inspect the  head  of file  or
;;;	contents of archive  when you move  cursor  up/down by p/n.  And
;;;	typing RET cause suitable motion according to the file type.  To
;;;	disable  file  inspection, type `:',  and  to disable only  file
;;;	inspection of archives, type `;' anywhere in the dired buffer.

;;; [Japanese]

;;;	  このプログラムをロードすると、dired で n/p を押した時にファイ
;;;	ルの中身を隣のバッファに表示します(まるしぇ風)。また RET を押す
;;;	と、カーソル位置のファイルの種別によって適切な動作を選びます。ファ
;;;	イルの中身の表示をやめるには「:」を、 アーカイブの中身の表示をや
;;;	めるには「;」を押して下さい。
;;;
;;;						       yuuji@gentei.org

; To activate this function, add next hook description to your ~/.emacs.
; 
;  (setq dired-load-hook
;        '(lambda ()
;           (load "dired-x")
;           (require 'dmarche)))
;

(require 'dired)
(or (featurep 'dired-extra)
    (load-library "dired-x"))
;(require 'dired-extra)
(require 'arch)

(defvar am-dired-view-command-alist-default
  '(("\\.uu"		"uudx")
    ;;Major archives are registered in arch.el
    ;("\\.tex$"		"Jlatex")
    ;("\\.dvi$"		"xdvi")
    ;("\\.lzh$"		"lha")
    ;;("\\.tar.Z$" 	"zcat * | tar vtf -")
    ;("\\.arj$"		"unarj v")
    ;("\\.zip$"		"unzip -l")
    ;("\\.arc$"		"arc l")
    ("\\.t\\(ar.\\|[ag]\\)[Gg]?[Zz]$" 	"gzip -dc < * | tar vtf -")
    ("\\.tar.bz2$" 	"bzip2 -dc < * | tar vtf -")
    ("\\.\\(g\\|\\)z$"	"gzip -l")
    )
  "Default command to view contents of the unusual files.")

(defvar am-dired-view-command-alist nil
  "*User defined value of 'am-dired-view-command-default.")

(defvar am-dired-inspect-header t
  "*Non-nil says inspect file contents on dired-next-line and
dired-previous-line.")

(defvar am-dired-inspect-bytes 4000
  "*Bytes of inspect buffer reads in")

(defvar am-dired-binary-file-regexp
  (concat
   "\\.\\(jpg\\|gif\\|png\\|exe\\|o\\|class"
   "\\|obj\\|bmp\\|tiff?\\|aux\\|mp3\\|mid\\|swp\\)$")
  "*Regexp of binary files' extension, which is no worse to inspect.")

(defvar am-dired-view-key "\C-m" "*Default key of view file.")
(defvar am-dired-next-key "n"	"*Default key of am-dired-next-line")
(defvar am-dired-prev-key "p"	"*Default key of am-dired-previous-line")
(defvar am-toggle-key	  ";"	"*Default key of am-toggle-inspect")
(defvar am-dired-toggle-key ":"	"*Default key of am-dired-toggle-inspect")
(defvar am-dired-this-key "."	"*Default key of am-dired-toggle-inspect")
(defvar am-dired-no-cache nil	"*Do not leave inspect buffer for cache")
(defvar am-dired-inspected-file-buffers nil)
(make-variable-buffer-local 'am-dired-inspected-file-buffers)
(setq-default am-dired-inspected-file-buffers nil)

(define-key dired-mode-map am-dired-view-key 'dired-view-or-shell-command)
(define-key dired-mode-map am-dired-next-key 'am-dired-next-line)
(define-key dired-mode-map am-dired-prev-key 'am-dired-previous-line)
(define-key dired-mode-map am-toggle-key     'am-toggle-inspect)
(define-key dired-mode-map am-dired-this-key 'am-dired-this-line)
(define-key dired-mode-map am-dired-toggle-key 'am-dired-toggle-inspect)

(defun dired-view-or-shell-command ()
  "If filename on cursor has extension which is defined in
dired-auto-shell-command-alist, call 'dired-do-shell-command,
if any, call 'dired-view-file"
  (interactive)
  (let ((file (file-name-nondirectory (dired-get-filename))) found
	(alist (append dired-auto-shell-command-alist
		       dired-auto-shell-command-alist-default)))
    (while (and (not found) alist)
      (if (string-match (car (car alist)) file)
	  (setq found t)
	(setq alist (cdr alist))))
    (if found
	(dired-do-shell-command t)
      (dired-view-file))))

(or (boundp 'am-dired-inspected-file)
    (setq dired-mode-hook (cons 'am-dired-startup dired-mode-hook)))

(defvar am-dired-inspected-file nil)
(defun am-dired-startup ()
  (make-local-variable 'am-inspected-file)
  (make-local-variable 'am-favorite-listing))

(defun am-dired-next-line (arg)
  (interactive "p")
  (if (and am-dired-inspected-file (get-buffer am-dired-inspected-file))
      (save-excursion	  ;to avoid missing current-buffer in 18.55
	(kill-buffer (get-buffer am-dired-inspected-file))))
  (dired-next-line arg)
  (let ((file (dired-get-filename nil t)))
    (if (and file am-dired-inspect-header) (am-dired-show-contents file))))

(defun am-dired-previous-line (arg)
  (interactive "p")
  (am-dired-next-line (- arg)))

(defun am-dired-this-line ()
  (interactive)
  (let ((file (dired-get-filename nil t)))
    (if (and file am-dired-inspect-header) (am-dired-show-contents file))))
  

(defun am-dired-toggle-inspect ()
  (interactive)
  (setq am-dired-inspect-header (not am-dired-inspect-header))
  (message "Set inspect mode(dired) %s"
	   (if am-dired-inspect-header "ON" "OFF")))

(defun am-fn-assoc (fn list)
  (catch 'found
    (while list
      (if (string-match (car (car list)) fn)
	  (throw 'found t))
      (setq list (cdr list))))
  list)

(defun am-string-width (string)
  (cond
   ((boundp 'MULE) (string-width string))
   (t (let ((tmpbuf "*am-tmpbuf*") (curbuf (current-buffer)))
	(set-buffer (get-buffer-create tmpbuf))
	(erase-buffer)
	(fundamental-mode)
	(insert string)
	(unwind-protect
	    (current-column)
	  (kill-buffer tmpbuf)
	  (set-buffer curbuf))))))

(defun am-dired-kill-cache-buffers ()
  (let ((bufs am-dired-inspected-file-buffers))
  (while bufs
    (if (get-buffer (car bufs)) (kill-buffer (car bufs)))
    (setq bufs (cdr bufs)))
  (and am-dired-inspected-file (get-buffer am-dired-inspected-file)
       (kill-buffer am-dired-inspected-file))
  nil))

(defun am-dired-register-cache (buffer)
  "Register buffer to cached file buffer list."
  (if (null am-dired-inspected-file-buffers)
      (let ((kbf kill-buffer-hook))
	(set (make-local-variable 'kill-buffer-hook)
	     (cons 'am-dired-kill-cache-buffers kbf))))
  (or (memq buffer am-dired-inspected-file-buffers)
      (setq am-dired-inspected-file-buffers
	    (cons buffer am-dired-inspected-file-buffers))))


(defun am-dired-show-contents (file)
  (let*((file (file-name-nondirectory file))
	(showbuffer (concat "***" file "***"))
	cmd buf (win (selected-window)) (curbuf (current-buffer))
	(alist (append am-archiver-alist am-archiver-alist-default))
	(alist2 (append am-dired-view-command-alist
			am-dired-view-command-alist-default))
	(nulbuf "*dmarche*") (case-fold-search am-file-ignore-case))

    (cond	;;`buf' should be set in each condition.

     ;;if the beginning of the file has alredy been shown.
     ((and (get-buffer showbuffer)
	   (progn (set-buffer showbuffer) (> (buffer-size) 0)))
      (setq buf showbuffer))

     ((or
       ;;Match with marche-built-in archiver listing table.
       (prog1
	   (and (string-match am-file-name-regexp file)
		(setq alist (am-fn-assoc file alist)))
	 (if alist (setq cmd (am-build-command 'listing (car alist) file))))
       ;;Match with am-dired-view-command-alist
       (prog1
	   (setq alist2 (am-fn-assoc file alist2))
	 (if alist2
	     (let ((dired-auto-shell-command-alist alist)
		   dired-auto-shell-command-alist-default)
	       (setq cmd
		     (dired-shell-stuff-it (car (cdr (car alist2)))
					   (list file) nil))))))
      (if (and am-can-inspect am-inspect-mode)
	  (progn			;if in archive-inspect mode.
	    (setq buf (get-buffer-create showbuffer))
	    (am-start-proc-with-queue
	     buf (concat "nice " cmd) 'am-refresh-kanji)
	    (if am-dired-no-cache (setq am-dired-inspected-file buf)
	      (set-buffer curbuf)
	      (am-dired-register-cache buf)))
	;;Not in arvhie-inspect mode.
	(setq am-dired-inspected-file nulbuf)
	(setq buf (set-buffer (get-buffer-create nulbuf)))
	(erase-buffer)
	(insert "*** " file " ***")
	(set-buffer-modified-p nil)))
     (t					;else(normal file or directory)
      (cond
       ((file-directory-p file)		;if directory
	(setq am-dired-inspected-file showbuffer
	      buf showbuffer)
	(get-buffer-create buf)
	;; (mapcar
;; 	 (function
;; 	  (lambda (x)
;; 	    (let ((s (format "%s\t" x)))
;; 	      (if (> (+ (current-column) (am-string-width s)) (screen-width))
;; 		  (insert "\n"))
;; 	      (insert s))))
;; 	 (file-name-all-completions "" file))
	(am-start-proc-with-queue
	 buf (concat "ls -FC " file "/.") 'am-refresh-kanji)
	(if am-dired-no-cache (setq am-dired-inspected-file buf)
	  (set-buffer curbuf)
	  (am-dired-register-cache buf))
	(setq fill-prefix nil fill-column (- (screen-width) 4)))
       ((string-match am-nonshow-file-names-default file)
	(setq buf (get-buffer-create " *am-dired binary buffer*"))
	(set-buffer buf)
	(erase-buffer)
	(insert "Binary file: " file))
       (t				;if file
	(set-buffer curbuf)
	(setq am-dired-inspected-file showbuffer)
	(set-buffer (get-buffer-create (setq buf showbuffer)))
	(insert-file-contents file nil 0 am-dired-inspect-bytes)))))

    (if buf
	(progn
	  (select-window win)
	  (pop-to-buffer buf)
	  (am-set-view-mode-map)
	  (use-local-map am-view-mode-map)
	  (shrink-window (- (window-height) am-contents-height 1))
	  (goto-char (point-min))
	  (set-buffer-modified-p nil)
	  (bury-buffer (current-buffer))))
    (select-window win)
    (switch-to-buffer curbuf)))

(run-hooks 'dmarche-load-hook)
(provide 'dmarche)

; Local variables: 
; fill-prefix: ";;;	" 
; paragraph-start: "^$\\|\\|;;;$" 
; paragraph-separate: "^$\\|\\|;;;$" 
; End: