;;; -*- Emacs-Lisp -*-
;;; MARCHE interface for `dired'.
;;; dmarche.el version 1.1 (Purely beta version!)
;;; (c ) 1993,1997 HIROSE Yuuji [yuuji@ae.keio.ac.jp]
;;; $Id$
;;; Last modified Fri Jan 17 11:19:11 1997 on supra

;; This software is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY.  No author or distributor
;; accepts responsibility to anyone for the consequences of using it
;; or for whether it serves any particular purpose or works at all,
;; unless he says so in writing.  Refer to the GNU Emacs General Public
;; License for full details.

;; Everyone is granted permission to copy, modify and redistribute
;; this software, but only under the conditions described in the
;; GNU Emacs General Public License.   A copy of this license is
;; supposed to have been given to you along with this software so you
;; can know your rights and responsibilities.  It should be in a
;; file named COPYING.  Among other things, the copyright notice
;; and this notice must be preserved on all copies.

;;;
;;;	  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@ae.keio.ac.jp
;;;						pcs39334@asciinet.or.jp

; 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]\\)[Zz]$" 	"gzip -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-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")

(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)

(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-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 (set-buffer (get-buffer-create showbuffer)))
	    (am-start-proc-with-queue
	     buf (concat "nice " cmd) 'am-refresh-kanji))
	;;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)
	(set-buffer (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))
	(setq fill-prefix nil fill-column (- (screen-width) 4)))
       (t				;if file
	(set-buffer curbuf)
	(setq am-dired-inspected-file showbuffer)
	(set-buffer (get-buffer-create (setq buf showbuffer)))
	(insert-file-contents file))
       )))
    (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: