;;; -*- Emacs-Lisp -*-
;;; Multi format Archive file handler for Emacs.
;;; <marche>
;;; arch.el version 1.4
;;; (c)1993 by HIROSE Yuuji.[yuuji@ae.keio.ac.jp]
;;; Last modified Thu Feb 10 16:43:42 1994 on gloria
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program; see the file COPYING. If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
;;;
;;; This program enables your Emacs to walk through the archive file
;;; and to inspect its contents. Now you can say,
;;;
;;; "Mon Emacs marche dans les archives!"
;;;
;;; Document:
;;;
;;; Multi format ARChived file Handler for Emacs: [MARCHE]
;;;
;;;[What is MARCHE?]
;;;
;;; When you visit an archive file created by LHA, ZIP, ARC, or
;;; ARJ after loading MARCHE, the contents of the archive will be
;;; shown in a buffer. In this buffer, you can view, edit or make
;;; other operations to a file by typing some key on the file name.
;;;
;;;[Preparation]
;;;
;;; Since all the extraction or other kinds of jobs will be done
;;; by corresponding archivers, you have to put them in command
;;; search path. Then write the following sentences in your .emacs.
;;;
;;; (defvar am-file-name-regexp "\\.\\(lzh\\|arj\\|arc\\|zip\\|zoo\\)$"
;;; "*Regexp of file-name to be handled with [MARCHE].")
;;; (setq auto-mode-alist
;;; (cons (cons am-file-name-regexp 'arc-mode)
;;; auto-mode-alist))
;;; (autoload 'arc-mode "arch" "Archived file mode." t)
;;;
;;;[Listing Buffer]
;;;
;;; After the preparation of the preceding section, when you open
;;; the file with extension .lzh or so, the editing mode will turn
;;; automatically to archive file mode. And the listing table of the
;;; archive will be displayed in the current buffer. Here are the
;;; key definitions in the listing buffer.
;;;
;;; n, j next line
;;; p, k previous line
;;; C-n / C-p next/previous line without inspection
;;; RET, v view file
;;; LF(C-j) assume cursor position as file
;;; e, f find file
;;; TAB mark current file
;;; SPACE, m mark current file and next line
;;; BS cancel mark on the previous line
;;; u unpack marked files from archive
;;; d delete marked files in archive
;;; g re-read contents from disk
;;; G ditto(change listing switch of archiver)
;;; * mark files by regexp
;;; z reverse all marks
;;; . inspect current file
;;; ; toggle inspect mode
;;; + / - enlarge/shrink window
;;; q quit
;;;
;;; By default on unix or unix-like OS, MARCHE starts up in
;;; inspect mode in which the contents of file is automatically
;;; shown in other window. You may feel this bothering on the slow
;;; machine or in huge archive files. In those case, you had better
;;; move cursor with standard next-line (C-n) or previous-line
;;; (C-p), or type `;' (semicolon) in the listing buffer to toggle
;;; inspect mode.
;;;
;;;[View Mode]
;;;
;;; Typing return key in the listing buffer extracts the file on
;;; the line of the cursor to the standard output and takes it into
;;; marche-view-mode's buffer. Here are the key definitions of
;;; marche-view-mode.
;;;
;;; SPC / BS scroll up/down by 1 page
;;; j,e / k,y scroll up/down by 1 line
;;; d / u scroll up/down by half window
;;; g / G goto beginning/end of the buffer
;;; o other-window
;;; / isearch forward
;;; ? isearch backward
;;; h help
;;; q quit marche-view-mode
;;;
;;;[Editing Mode]
;;;
;;; By typing `f' in the listing buffer, you can extract the file
;;; at the position of the cursor to the disk and edit it. Of
;;; course, you can edit it normally because it is a normal file on
;;; the disk. You need to remember that pressing the key normally
;;; assigned to the function save-buffer(C-x C-s by default) saves
;;; the current buffer and updates the archive in which the file
;;; belongs. And pressing the key normally assigned to the function
;;; kill-buffer(C-x k by default) kills the current buffer and
;;; removes the file extracted temporarily on the disk (This means
;;; that temporary file will remain on the disk when you kill-emacs
;;; without C-x k).
;;;
;;;[Customizations]
;;;
;;; *customizable variables*
;;;
;;; Here are the customizable variables. Parenthesized values are
;;; their defaults.
;;;
;;; am-unpack-tmpdir
;;; Directory name where the file to edit is extracted.
;;; ($TMP, /tmp, /usr/tmp, c:/tmp, / are searched in sequence)
;;; am-inspect-mode
;;; Inspect mode at startup(t, but always nil on DOS)
;;; am-contents-height
;;; Height of inspect buffer(1/3 of screen-height)
;;; am-nonshow-file-names
;;; Regexp of file name require no inspection.
;;; (None. Set the pattern except the value of
;;; am-nonshow-file-names-default which has standard binary
;;; type file names on DOS.)
;;; am-queueing-method
;;; ('newestonly) On file inspection, MARCHE invokes the
;;; archiver to get the head of contents, but doesn't
;;; execute directly those process. All the processes are
;;; stacked onto the process queue if other processes are
;;; running. `am-queueing-method' controls how the new
;;; process request goes into the queue. There are 3
;;; possible methods, 'normal is for historically ordered
;;; queue, 'reverse is for reverse of 'normal, 'newestonly
;;; keeps only the newest one.
;;; am-discard-process-queue-when-view
;;; (nil) Whether delete the process entry to be done for
;;; file inspection from the queue or not, when you type `v'
;;; (am-view-file) or `.' (am-this-line). By default,
;;; MARCHE restricts the number of simultaneous process for
;;; inspection according to the machine performance which is
;;; automatically checked at the startup of MARCHE. The
;;; process invoked when the number of running processes
;;; exceeds the limit, is only stored to queue and waits for
;;; being executed. Non-nil for this variable cause
;;; deletion of all of the entry of process queue. Notice
;;; that this value cause practical effect only when the
;;; value of am-queueing-method is 'normal or 'reverse.
;;;
;;; *hook variables*
;;;
;;; Here are the all hook variables of MARCHE.
;;;
;;; arc-mode-hook will be parsed at
;;; the end of initialization of arc-mode.
;;; am-setup-edit-mode-map-hook will be parsed at
;;; the first time of find-file in archive
;;; am-view-mode-hook will be parsed at
;;; every time before entering view-mode
;;; marche-load-hook will be parsed at
;;; loading this file(at the end of this file).
;;;
;;; *To change archivers*
;;;
;;; By default, MARCHE selects the archiver by the extension of
;;; the file as follows (parenthesized values are for MS-DOS):
;;;
;;; .arc -> arc/arc (parc/parc)
;;; .arj -> ???/unarj (arj/arj)
;;; .lzh -> lha/lha
;;; .zip -> zip/unzip
;;; .zoo -> zoo/zoo
;;;
;;; You can change these settings by setq-ing the Lisp variable:
;;; am-archiver-alist. It is formed as follows.
;;; '( ("EXTENSION" "Archiver(to extract)"
;;; "Switch_to_make_listing_table"
;;; "Switch_to_extract_contents_to_standard_output"
;;; "Switch_to_extract(with force overwriting)"
;;; "Archiver(to make) Switch_to_update"
;;; "Archiver Switch_to_delete_files")
;;; ("EXTENSION" ...)
;;; )
;;; See the value of am-archiver-alist-default as an example, please.
;;;
;;;[Q and A]
;;;
;;; *Error "Sorry unknown table format" occurs.
;;;
;;; Since there are various archivers in the world, some of them
;;; create the listing table that MARCHE cannot analyze (Zoo is one
;;; of them). If you see the error message above, check up the
;;; column of the beginning of the file name field, and make a
;;; declaration with the name of the archiver in your .emacs.
;;;
;;; (put 'zoo 'file-name-column 46)
;;;
;;; Above example tells MARCHE that file name field starts at the
;;; 46th column. If you find any further errors, send a bug report
;;; to me, please.
;;;
;;; *Cursor doesn't go file name field.
;;;
;;; Sometimes file name field goes improper position because file
;;; size is too large and file size field takes too many columns.
;;; In this case, MARCHE fails to extract the file name at view or
;;; edit. To avoid this, move the cursor on the file name field and
;;; type C-j there. MARCHE will assume that position as the file
;;; name field.
;;;
;;; *There is no `overwrite-switch' at extraction with my archiver.
;;;
;;; Write `(put 'ArchiverName 'ask-overwrite t)' in your .emacs.
;;; If there are same files on the destination directory of the
;;; extraction, Emacs will ask you whether you can delete them or
;;; not. However, the extraction is aborted if there are any files
;;; that should not be removed.
;;;
;;; *My archiver does not allow / as a path delimiter(MS-DOS).
;;;
;;; Write (put 'ArchvierName 'use-backslash t) in your .emacs.
;;;
;;;[Tricks]
;;;
;;; MARCHE assumes that listing tables output by archivers as follows:
;;;
;;; MARCHE ver 1.4 (C)1994 by yuuji |<-titles
;;; Size Time Date Name |<-column table
;;; ----- ----- -------- -------------- |<-section line
;;; 62936 15:42 94/02/10 arch.el |<-table
;;; : | :
;;; ----- ----- -------- -------------- |<-section line
;;;
;;; The important things are the column table and section lines.
;;; Notice that `name' stands for a file name and the section lines
;;; stand for the limits of the file names. The archivers I have
;;; (except zoo) take this format, so I have selected this analysis.
;;;
;;; The name identification of the packed files is done by strings
;;; in the file name column. Therefore, if there exist any files
;;; having same file name, MARCHE is unable to tell one from the
;;; other. This might happen when the archive is listed with `lha
;;; l' so that directory names have been eliminated. If this
;;; happens frequently, change default setting of lha's table
;;; listing switch to "v".
;;;
;;;[Copying]
;;;
;;; This program is distributed as a free software. The author is
;;; not responsible for any possible defects caused by this
;;; software.
;;;
;;; Comments and bug reports are welcome. Don't hesitated to report.
;;; My possible e-mail address is following.
;;;
;;;
;;; yuuji@ae.keio.ac.jp
;;; pcs39334@ASCII-NET
;;;
;;; Japanese document follows:
;;;
;;; アーカイブファイルモード: marche [まるしぇ]
;;;
;;;【marcheとは】
;;;
;;; LHa, ZIP, ARC, ARJ などのアーカイバを用いて作成されたアーカイ
;;; ブファイルをオープンすると、中に入っているファイル一覧の画面を表
;;; 示します。この画面で、カーソルを目的のファイル名に合わせて操作す
;;; ることで、そのファイルの内容を閲覧したり、編集したりすることがで
;;; きます。
;;;
;;;【準備】
;;;
;;; アーカイブファイルの展開処理等は、全てアーカイバを呼び出すこと
;;; で行っています。各アーカイブファイルを扱うためのアーカイバは用意
;;; しておく必要があります。次に、以下の行を .emacs に入れて下さい。
;;;
;;; (defvar am-file-name-regexp "\\.\\(lzh\\|arj\\|arc\\|zip\\|zoo\\)$"
;;; "*[まるしぇ]を起動するファイル名の正規表現.")
;;; (setq auto-mode-alist
;;; (cons (cons am-file-name-regexp 'arc-mode)
;;; auto-mode-alist))
;;; (autoload 'arc-mode "arch" "Archived file mode." t)
;;;
;;;【一覧画面】
;;;
;;; 前項の設定により、.lzh などの拡張子の付くファイルをオープンす
;;; ると、自動的にアーカイブファイルモードになり、アーカイブファイル
;;; の内容一覧画面が表示されます。この画面でのキー操作には以下のもの
;;; があります。
;;;
;;; n,j 次の行へ
;;; p,k 前の行へ
;;; C-n / C-p ファイルの先頭表示をせずに 次/前 の行へ
;;; RET ファイルの内容の閲覧(view)
;;; LF(C-j) カーソル位置をファイルとみなす
;;; e,f ファイルの編集
;;; TAB ファイルのマーク
;;; SPACE ファイルをマークして次の行へ
;;; BS 直前の行のマークの解除
;;; u マークファイルの展開(extract)
;;; d マークファイルの削除
;;; g アーカイブファイルの再読み込み
;;; G 同上(アーカイバのリスト表示スイッチ変更)
;;; S SJIS判定優先モードON/OFF
;;; z ファイルのマークの反転
;;; * 正規表現によるファイル一括マーク
;;; . カレントファイルの先頭表示
;;; ; ファイル先頭表示モードON/OFF
;;; + / - ウィンドウ拡大/縮小
;;; q 終了
;;;
;;; unixベースのOSではファイル先頭表示モードが有効になっています。
;;; 遅いマシンや大きいアーカイブファイルの中では普通の next-line
;;; (C-n) と previous-line (C-p) でカーソル移動するか、 「;」(セミコ
;;; ロン) を押して直視モードをOFFにした方が良いでしょう。
;;;
;;;【view-mode】
;;;
;;; 一覧画面でリターンキーを押すと、カーソル位置のファイルを(標準
;;; 出力に)展開し、その中味を表示すると共にまるしぇの view-mode に移
;;; 行します。このモードでは、次のキーが使用できます。
;;;
;;; SPC / BS 一画面スクロールアップ/ダウン
;;; j,e / k,y 一行スクロールアップ/ダウン
;;; d / u 半画面スクロールアップ/ダウン
;;; g / G ファイルの先頭へ/末尾へ
;;; o other-window
;;; h ヘルプ
;;; q view-mode を抜ける
;;; / 後方検索
;;; ? 後方検索
;;;
;;;【編集モード】
;;;
;;; 一覧画面で f を押すことにより、カーソル位置のファイルを(ディス
;;; ク上に)展開し、そのファイルを編集します。これは普通のファイルな
;;; ので、一般のファイルと同様に編集できます。ただし、通常時に
;;; save-buffer が割当てられているキー(標準で C-x C-s)を押すと、カレ
;;; ントバッファをセーブすると同時にアーカイブ中の該当ファイルを更新
;;; します。同様に、通常時 kill-buffer が割当てられているキー(標準で
;;; C-x k)を押すと、カレントバッファを削除すると共にディスク上に臨時
;;; に展開したファイルを消去します(逆に C-x k せずに Emacs を終了す
;;; ると臨時ファイルがディスク上に残ります)。
;;;
;;;【カスタマイズ】
;;;
;;; ・カスタマイズ変数
;;;
;;; 動作を決定する以下の変数が設定可能です。括弧内に示されているも
;;; のがデフォルト値です。
;;;
;;; am-unpack-tmpdir
;;; edit-file で一時的にファイルを展開するディレクトリ
;;; (環境変数TMP, /tmp, /usr/tmp, c:/tmp, / の順で参照)
;;; am-inspect-mode
;;; ファイルの先頭表示モード(t ただしMSDOSでは常にnil)
;;; am-contents-height
;;; ファイルの先頭表示バッファの高さ(画面の1/3)
;;; am-nonshow-file-names
;;; ファイルの先頭表示をしないファイル名の正規表現
;;; (なし。am-nonshow-file-names-default にDOSの標準的なバイ
;;; ナリファイルのパターンが設定されているのでその値以外を
;;; 設定します)
;;; am-queueing-method
;;; ファイルの先頭表示のために起動するプロセスは一旦キューに
;;; 入れられて順次起動されますが、プロセスをキューに入れる方
;;; 法を指定します。プロセスの発生した順番にキューに入れる時
;;; は 'normal を、 逆順に入れる時は 'reverse を、古いキュー
;;; は捨てて新しいものだけを入れる時は 'newestonly を指定し
;;; ます(デフォルトは 'newestonly)。 ある程度高速なマシンで
;;; は 'reverse を指定するとカーソルをたくさん動かした時にも
;;; カーソル位置のファイルの内容の表示が優先されるので快適で
;;; す。
;;; am-discard-process-queue-when-view
;;; v による am-view-file および . による am-this-line の時
;;; に、ファイルの先頭表示をするために起動するためのプロセス
;;; の予定表を消去するかどうか(nil)。 デフォルトではファイル
;;; 一覧画面で n や p を連打したときにファイルの先頭部を表示
;;; させるためのプロセスを複数起動することになりますが、まる
;;; しぇでは組み込み時に測ったマシンの能力に応じて同時に起動
;;; するプロセス個数の上限を決めています。上限を超えている時
;;; に発生したプロセス起動要求はキューに入れられて順次起動さ
;;; れるのを待ちます。この変数を nil 以外にセットするとキュー
;;; に入っている起動予定プロセスをすべて削除します。
;;; am-queueing-method の値が 'normal か 'reverse の時にのみ
;;; 実用的な意味をもちます。
;;;
;;; ・hook変数
;;;
;;; 次の hook 変数を用意しています。
;;;
;;; arc-mode-hook
;;; arc-mode の初期化が終わった時
;;; am-setup-edit-mode-map-hook
;;; アーカイブ中のファイル編集時、キーマップを変更した直後
;;; am-view-mode-hook
;;; ファイル閲覧の view-mode に入る直前(キーマップロード後)
;;; marche-load-hook
;;; このファイルをロードする時(ファイルの最後)
;;;
;;; ・アーカイバの変更
;;;
;;; 標準設定では、ファイルの拡張子により、次のアーカイバ(圧縮用/展
;;; 開用)を使用するようになっています(括弧内はMS-DOSでの設定)。
;;;
;;; .arc → arc/arc (parc/parc)
;;; .arj → ???/unarj (arj/arj)
;;; .lzh → lha/lha
;;; .zip → zip/unzip
;;; .zoo → zoo/zoo
;;;
;;; この設定は、Lisp 変数 am-archiver-alist によって行います。これは、
;;; '( ("拡張子" "(展開用)アーカイバ名"
;;; "ファイルリスト表示用スイッチ"
;;; "ファイルを標準出力に書き出すスイッチ"
;;; "(強制上書きオプション付き)展開スイッチ"
;;; "(圧縮用)アーカイバ名 更新スイッチ"
;;; "アーカイバ名 ファイル削除スイッチ")
;;; ("拡張子" ... 以下同様 )
;;; )
;;; のように設定します。具体例は、変数 am-archiver-alist-default の
;;; 値を参照して下さい。
;;;
;;;【こんな時は】
;;;
;;; ・"Sorry unknown table format" と言われてしまう。
;;;
;;; 世の中いろいろアーカイバがあるので、「まるしぇ」で解析できない
;;; 書式のテーブルを表示するものがあるかもしれません(実はzooもその一
;;; つ)。もしお手持ちのアーカイバのテーブル表示に対して、このメッセー
;;; ジが表示されたら、そのバッファのテーブルのファイル名フィールドの
;;; カラム位置を調べ、その時のアーカイバの名前と共に次のような宣言を
;;; して下さい。
;;;
;;; (put 'zoo 'file-name-column 46)
;;;
;;; 上の例は、zoo の出力するテーブル表示に対して、ファイル名フィール
;;; ドが46カラム目から始まることを「まるしぇ」にあらかじめ教え込みま
;;; す。もし、これを指示しても unknown と出た場合は、作者までご一報
;;; 下さい。
;;;
;;; ・リスト表示のファイル名が予定の位置からずれてしまう。
;;;
;;; ファイルが巨大でサイズを表す数字の桁が大きく右にはみ出てしまっ
;;; たりして、ファイル名フィールドが予定の位置からずれてしまう(nやp
;;; で移動した時にファイル名の先頭にカーソルが行かない)ことがありま
;;; す。こうなると、view しようとしても正しいファイル名を取得できな
;;; くなってしまいます。このようなときは、いったんカーソルをファイル
;;; 名の上に移し、そこで C-j を押します。それ以後ファイル名フィール
;;; ドをカーソル位置の場所であるとみなします。
;;;
;;; ・アーカイバに展開時の強制上書きスイッチがない。
;;;
;;; (put 'アーカイバ名 'ask-overwrite t) として下さい。もし、展開
;;; 先ディレクトリに同名のファイルがあった場合、それを消去して良いか
;;; Emacs 側で質問します。ただし、一つでも消してはいけないファイルが
;;; あった場合は、展開を中止します。
;;;
;;; ・パスデリミタとして \ しか認めない(MS-DOS)。
;;;
;;; (put 'アーカイバ名 'use-backslash t) として下さい。
;;;
;;;【種明かし】
;;;
;;; ・テーブルフォーマット
;;;
;;; アーカイバの出力するテーブルは、次のようなフォーマットであると
;;; 仮定しています。
;;;
;;; MARCHE ver 1.4 (C)1994 by yuuji |←タイトルなど
;;; Size Time Date Name |←項目見出し
;;; ----- ----- -------- -------------- |←上罫線
;;; 62936 15:42 94/02/10 arch.el |←実際のテーブル
;;; : | :
;;; ----- ----- -------- -------------- |←下罫線
;;;
;;; これらのうち重要なのは、項目見出しと上下罫線です。項目見出しの
;;; うちファイル名を示すものに `name' という文字列が含まれることと、
;;; 上下罫線がテーブルの上下範囲を示している必要があります。手元のアー
;;; カイバでは(zoo以外)どれもこのフォーマットに基づいていたので、こ
;;; のような解析方法を採用しました。
;;;
;;; ・アーカイブファイル中のファイル名
;;;
;;; 中味のファイルの識別は、ファイル名フィールドの文字列(つまり表
;;; 示するファイル名)によって行っています。従って、一アーカイブ中に
;;; 同じファイル名のものがあった場合、「まるしぇ」はそれを区別出来ま
;;; せん。これが問題になるのは、lha l によって、ディレクトリ名が省略
;;; されている場合でしょうから、このようなケースが多い方は、lha用の
;;; デフォルトの「テーブル表示スイッチ」を "v" として下さい。
;;;
;;;【謝辞】
;;;
;;; Nop.Mさん, Paciさん, Rijさん, bauerさん, かずやさん, たりゃー
;;; 佐々木さん, ほんまたけるさん, りゅさんには ASCII-NET において貴
;;; 重なコメントを頂きました。慶應義塾大管理工学科の森川修君には動作
;;; 報告と仕様に関する助言を頂きました。ここに感謝申し上げます。
;;;
;;;【取り扱い】
;;;
;;; このプログラムは、フリーソフトウェアとして配布いたします。この
;;; プログラムを使用して生じたいかなる結果に対しても作者は一切の責任
;;; を負わないものといたしますが、コメントやバグレポートは大いに歓迎
;;; いたします。お気軽にご連絡下さい。連絡は以下のアドレスまでお願い
;;; いたします(1994/3現在)。
;;; yuuji@ae.keio.ac.jp
;;; pcs39334@ASCII-NET
(defconst am-version
"$Id$"
"Version number of running marche."
)
(defconst am-on-dos (eq system-type 'ms-dos)
"T if marche is running on DOS."
)
(defconst am-file-ignore-case
(or (eq system-type 'ms-dos) (eq system-type 'vax-vms))
"T if marche is running on OS which ignores file name case."
)
(defconst debug (string= (getenv "USER") "yuuji"))
(defvar am-archiver-alist nil
"*Customizable association list of filename pattern to using archiver."
)
(defvar am-file-name-regexp "\\.\\(lzh\\|arj\\|arc\\|zip\\|zoo\\)$"
"*Regexp of file name arc-mode should begin.")
(defvar am-archiver-alist-default
(list
;; ext cmd view print extract udpate delete
;; quiet quiet overwrt with command with command
(if am-on-dos
'("lzh" "lha" "v" "p -n2" "e -xmc" "lha u" "lha d")
'("lzh" "lha" "l" "ptq" "xvf" "lha u" "lha d"))
(if am-on-dos
'("arc" "parc" "v" "p" "xo" "parc a" "parc d")
'("arc" "arc" "l" "p" "e" "arc u" "arc d"))
'("zip" "unzip" "-lU" "-p" "-xo" "zip -u" "zip -d")
(if am-on-dos
'("arj" "arj" "v" "p" "x -y" "arj u" "arj d")
'("arj" "unarj" "v" "p" "x -y" "echo Sorry." "echo sorry"))
'("zoo" "zoo" "l" "ep" "eSO" "zoo u" "zoo D")
)
"Default association list of filename extension to archiver and its
miscellaneous switches. It consists of following elements:
'(("EXT" "ARCHIVER" "LIST" "PRINT" EXTRACT" UPDATE" "DELETE")
...)
EXT is the extension of file name, ARCHIVER is the name of archiver to
handle the file whose extension is EXT, LIST is the switch(option) of
archiver for listing contents, PRINT is the switch to print contents of
file (in archive) to standard output, EXTRACT is the switch to extract
file without overwrite-ask, UPDATE is the both archiver name and its
switch to update file, and DELETE is also the archiver name and its
deletion switch."
)
(if (not am-on-dos) nil
(put 'parc 'ask-overwrite t)
(put 'lha 'hack-stdin t)
(put 'arj 'use-backslash t))
(put 'zoo 'file-name-column (if am-on-dos 46 49))
(defvar am-table-begin-regexp "^[ \t]*[-=][-=][-=][-=]"
"Regexp of the top edge of archive listing table."
)
(defvar am-table-end-regexp "^[ \t]*[-=][-=][-=][-=]"
"Regexp of the bottom edge of archive listing table."
)
(defvar am-file-name-column nil)
(defvar am-delete-buffer "*delete*")
(defvar am-update-buffer "*update*")
(defvar am-unpack-buffer "*Unpack*")
(defvar am-unlink-command "rm -f"
"*Name of command string to unlink files.")
(defvar am-unpack-tmpdir (if (and am-on-dos debug) "j:/tmp" nil)
"By default, edited file will be extacted into directory where
(getenv \\"TMP\\") indicates. If you want extract them into other directory,
set that name in this variable."
)
(defmacro am-get-command (x) (list 'nth 1 x))
(defmacro am-get-listing (x) (list 'nth 2 x))
(defmacro am-get-print (x) (list 'nth 3 x))
(defmacro am-get-extract (x) (list 'nth 4 x))
(defmacro am-get-update (x) (list 'nth 5 x))
(defmacro am-get-delete (x) (list 'nth 6 x))
(defmacro am-detect-range () (list 'min 5000 (list 'point-max)))
(defvar am-nemacs-raw-code 3)
(defvar am-sjis-flag am-on-dos
"Assume file contents consist of sjis."
)
(defvar am-archive-file-name nil
"Keeps file name of the archive.")
;;;
;; Version 1.x
;;;
(defconst am-can-inspect (and (fboundp 'start-process)
(fboundp 'set-process-sentinel)
(fboundp 'interrupt-process))
"T if running OS can have multi process.")
(defvar am-inspect-mode am-can-inspect
"*T for viewing the contents of file on other window.")
(defvar am-contents-height (/ (screen-height) 3)
"*Window height of the file-contents buffer.")
(defvar am-current-process nil
"Holds process object.")
(defvar am-nonshow-file-names-default
"\\.\\(com\\|exe\\|obj\\|o\\|dvi\\|lib\\|a\\|fmt\\|.df\\)$"
"Inihibit showing contents on this filename.")
(defvar am-nonshow-file-names nil)
(setq am-nonshow-file-name-regexp
(concat am-file-name-regexp "\\|"
(if am-nonshow-file-names (concat am-nonshow-file-names "\\|"))
am-nonshow-file-names-default))
(defvar am-process-queue nil "Queue used for process of inspection.")
(defvar am-max-process 3
"*Maximum number of process running at the same time.")
(defvar am-queueing-method 'newestonly
"*Method of queueing of process for inspection. Possible methods are...
'normal new process entry goes to bottom of queue.
'reverse new process entry goes top of queue.
'newestonly keeps only newest process request.")
(defvar am-discard-process-queue-when-view nil
"*If non-nil, discard process queue (not running yet) when
`view-file' entered. If you want to see all the headers of files, set this
variable to nil.")
(defvar am-children-list nil
"Holds the child files of archive file."
)
(defvar am-favorite-listing nil
"Keeps the temporary listing switch to view listing of the table."
)
;;;
;; Marche functions
;;;
(defun am-version ()
(interactive)
(message am-version)
)
(defun am-toggle-inspect ()
(interactive)
;;(if (not am-can-inspect)
;; (error "Can't enter inspect mode on this system(%s)." system-type))
(setq am-inspect-mode (not am-inspect-mode))
(message "Set inspect mode %s" (if am-inspect-mode "ON" "OFF")))
(defun am-toggle-sjis-flag ()
(interactive)
(setq am-sjis-flag (not am-sjis-flag))
(message "Set SJIS flag %s" (if am-sjis-flag "ON" "OFF"))
)
(defun am-refresh-kanji (&optional proc mes)
"Check kanji code of currnet buffer and refresh it so that it
will be readable."
(let (code (buffer-read-only nil))
(save-excursion
(if (and proc (processp proc)) (set-buffer (process-buffer proc)))
(setq buffer-read-only nil)
(cond
((boundp 'MULE)
(setq code (detect-code-category (point-min) (am-detect-range)))
(if (listp code) (setq code (car code)))
(if (eq code t) nil
(code-convert (point-min) (point-max) code *internal*)))
((boundp 'NEMACS)
(setq code (check-region-kanji-code (point-min) (am-detect-range)))
;;(message "Guess it as %s in %s" code (buffer-name))(sit-for 2)
(if (and code (not (eq am-nemacs-raw-code code)))
(convert-region-kanji-code
(point-min) (point-max) code am-nemacs-raw-code)))))
(set-buffer-modified-p nil))
)
(defun am-call-command (cmd buf &optional convert)
"Call process CMD and put output into buffer BUF. If optional
third arg CONVERT is `t', check current kanji coding-system of
output string and convert it into displayable one."
(let ((default-kanji-process-code (if am-sjis-flag 1 3))
(default-process-coding-system
(and (boundp 'MULE)
(list (if am-sjis-flag *sjis* *autoconv*)))))
(call-process shell-file-name nil buf 1
(if (eq system-type 'ms-dos) "/c" "-c") cmd))
(if convert (am-refresh-kanji))
)
(defun am-convert-slash (path)
(let ((p (copy-sequence path))(i 0)(len (length path)))
(while (< i len)
(if (= (aref p i) ?/) (aset p i ?\\ ))
(setq i (1+ i)))
p)
)
(defun am-convert-backslash (path)
(let ((p (copy-sequence path))(i 0)(len (length path)))
(while (< i len)
(if (= (aref p i) ?\\ ) (aset p i ?/))
(setq i (1+ i)))
p)
)
(defun am-make-directory (dir)
(am-call-command
(concat "mkdir " (if am-on-dos (am-convert-slash dir) dir)) nil)
(if (file-directory-p dir) nil
(error "Cannot create %s." dir))
)
(defun am-build-command (type list file &optional arg)
"Build command line in order to do the job of TYPE,
referring the argument LIST and FILE."
(let ((cmd (am-get-command list)))
(if (get (intern cmd) 'use-backslash)
(setq file (am-convert-slash (copy-sequence file))))
(cond
((eq type 'listing)
(concat cmd " "
(or am-favorite-listing
(am-get-listing list))
" " file
(if (get (intern cmd) 'hack-stdin) " *.*")))
((eq type 'print)
(concat cmd " " (am-get-print list) " " file))
((eq type 'extract)
(concat cmd " " (am-get-extract list) " " file " " arg))
((eq type 'delete)
(concat (am-get-delete list) " " file " " arg))
((eq type 'update)
(concat (am-get-update list) " " file " " arg))
))
)
(defun am-get-file-name ()
"Get file name on current line."
(cond
((am-on-file-name-line-p)
(move-to-column am-file-name-column)
(if (= (current-column) am-file-name-column)
(buffer-substring
(point)
(save-excursion
(skip-chars-forward "^ \t\n" (point-end-of-line)) (point)))))
(t nil))
)
(defun am-view-k (arg)
(interactive "p")
(scroll-down arg))
(defun am-view-j (arg)
(interactive "p")
(scroll-up arg))
(defun am-view-d (arg)
(interactive "P")
(if arg
(scroll-up arg)
(scroll-up (/ (window-height) 2))))
(defun am-view-u (arg)
(interactive "P")
(if arg (scroll-down arg)
(scroll-down (/ (window-height) 2))))
(defun am-view-SPC ()
(interactive)
(scroll-up (- (window-height) 2)))
(defun am-view-BS ()
(interactive)
(scroll-down (- (window-height) 2)))
(defun am-view-bottom ()
(interactive)
(set-mark-command nil)
(goto-char (1- (point-max))))
(defun am-view-q ()
(interactive)
(if (eq major-mode 'am-view-mode)
(let ((parent am-parent-buffer))
(set-buffer-modified-p nil)
;;(if am-current-process
;; (progn
;; (if (eq (process-status am-current-process) 'run)
;; (interrupt-process am-current-process))
;; (delete-process am-current-process)))
(bury-buffer (current-buffer))
(switch-to-buffer parent))))
(defun am-view-search-next (arg)
(interactive "p")
(search-forward search-last-string nil t arg)
)
(defun am-view-search-prev (arg)
(interactive "p")
(search-backward search-last-string nil t arg)
)
(defvar am-view-mode-map nil
"Key map used in view-mode in arc-mode."
)
(defun am-set-view-mode-map ()
"Set `less' oriented extended view mode map."
(if am-view-mode-map nil
(setq am-view-mode-map (copy-keymap global-map))
(define-key am-view-mode-map " " 'am-view-SPC)
(define-key am-view-mode-map "\C-h" 'am-view-BS)
(define-key am-view-mode-map "\C-?" 'am-view-BS)
(define-key am-view-mode-map "b" 'am-view-BS)
(define-key am-view-mode-map "j" 'am-view-j)
(define-key am-view-mode-map "e" 'am-view-j)
(define-key am-view-mode-map "k" 'am-view-k)
(define-key am-view-mode-map "h" 'describe-mode)
(define-key am-view-mode-map "y" 'am-view-k)
(define-key am-view-mode-map "/" 'isearch-forward)
(define-key am-view-mode-map "?" 'isearch-backward)
(define-key am-view-mode-map "n" 'am-view-search-next)
(define-key am-view-mode-map "N" 'am-view-search-prev)
(define-key am-view-mode-map "d" 'am-view-d)
(define-key am-view-mode-map "u" 'am-view-u)
(define-key am-view-mode-map "o" 'other-window)
(define-key am-view-mode-map "g" 'beginning-of-buffer)
(define-key am-view-mode-map "<" 'beginning-of-buffer)
(define-key am-view-mode-map ">" 'am-view-bottom)
(define-key am-view-mode-map "G" 'am-view-bottom)
(define-key am-view-mode-map "q" 'am-view-q)
)
)
(defun am-prepare-view-contents (buffer)
(message "Call: %s..." cmd)
(if am-can-inspect
(let (code pmax)
(if am-discard-process-queue-when-view (am-flush-process-queue))
(make-local-variable 'am-current-process)
(set-buffer buffer) ;for assertion
(setq am-current-process
(start-process "marche:View" buffer shell-file-name "-c" cmd))
(if (boundp 'MULE)
(set-process-coding-system
am-current-process (if am-sjis-flag *sjis* *autoconv*) nil))
(set-process-sentinel am-current-process ;;do nothing on exit
'(lambda (proc mes) ())
;;; 'am-refresh-kanji
)
(sit-for 1)
(while (and (= (point) (point-min))
(eq (process-status am-current-process) 'run))
(goto-char (point-max)) (sleep-for 1)) ;;sit-for is not good.
(cond
((boundp 'NEMACS)
(set-buffer buffer)
(setq code (check-region-kanji-code
(point-min) (setq pmax (point-max))))
(if (and code (not (eq am-nemacs-raw-code code)))
(progn
(set-process-kanji-code am-current-process code)
(convert-region-kanji-code
(point-min) pmax code am-nemacs-raw-code)))
)))
(am-call-command cmd buffer t))
(goto-char (point-min))
(switch-to-buffer buffer)
)
(defun am-view-mode ()
"View mode for marche.
scroll up (page): \\[am-view-SPC]
scroll down(page): \\[am-view-BS]
scroll up (half): \\[am-view-d]
scroll down(half): \\[am-view-u]
scroll up (line): \\[am-view-j]
scroll down(line): \\[am-view-k]
beginning of buf: \\[beginning-of-buffer]
end of buf: \\[am-view-bottom]"
(interactive)
(setq mode-name "marche:view"
major-mode 'am-view-mode)
(am-set-view-mode-map)
(setq buffer-read-only t)
(use-local-map am-view-mode-map)
)
(defun am-view-buffer-name (archive file)
(concat "*" file " in " (file-name-nondirectory archive) "*"))
(defun am-show-buffer-name (archive file)
(concat "*" (file-name-nondirectory archive) ":" file "*"))
(defun am-view-file ()
"Call archive print command to view contents of file."
(interactive)
(if (not (am-on-file-name-line-p)) (error "Not on file name."))
(let*((curbuf (current-buffer))
(file (am-get-file-name))
(archive (file-name-nondirectory am-archive-file-name))
(buffer (am-view-buffer-name am-archive-file-name file))
(cmd (concat (am-build-command
'print am-archive-list archive) " " file)))
(if (get-buffer buffer)
(switch-to-buffer buffer)
(setq am-children-list (cons buffer am-children-list))
(set-buffer (get-buffer-create buffer))
(erase-buffer)
(run-hooks 'am-view-mode-hook)
(make-local-variable 'am-parent-buffer)
(setq am-parent-buffer curbuf)
(am-prepare-view-contents buffer)
(goto-char (point-min))
(set-buffer-modified-p nil)
(am-view-mode)))
)
(defun am-message-job-done (joblist)
(message "Process [%s...] done."
(substring (nth 1 joblist) 5
(min (- (screen-width) 12) (length (nth 1 joblist)))))
)
(defun am-chop-queue (entry)
(if (null am-process-queue)
(am-message-job-done entry)
(let ((qlist am-process-queue) (i 0) (len (length am-process-queue)) queue)
(if (null
(catch 'found
(while (< i len)
(if (equal (nth i am-process-queue) entry) (throw 'found t))
(setq i (1+ i)))))
(progn
(am-message-job-done entry)
;;(error "Process queueing failed. Send bug report to author.")
))
(if (= i 0)
(setq am-process-queue (cdr am-process-queue))
(let ((x (nthcdr (1- i) am-process-queue)))
(setcdr x (nthcdr (1+ i) am-process-queue))))
(if (setq queue (nth (1- am-max-process) am-process-queue))
(am-start-proc-with-queue
(nth 0 queue) (nth 1 queue) (nth 2 queue) t))
))
)
(defun am-start-proc-with-queue (buffer command sentinel &optional chop)
(let (entry proc (len (length am-process-queue)))
(setq entry (list buffer command sentinel))
(if (null chop)
(cond
((eq am-queueing-method 'normal)
(setq am-process-queue (append am-process-queue (list entry))))
((eq am-queueing-method 'reverse)
(if (<= len am-max-process)
(setq am-process-queue (append am-process-queue (list entry)))
(setcdr (nthcdr (1- am-max-process) am-process-queue)
(cons entry (nthcdr am-max-process am-process-queue)))))
((eq am-queueing-method 'newestonly)
(if (< len am-max-process)
(setq am-process-queue (append am-process-queue (list entry)))
(setcdr (nthcdr (1- am-max-process) am-process-queue)
(list entry)))))
)
(setq am-max-process (max 1 am-max-process))
(if (and (> (length am-process-queue) am-max-process)
(null chop)) nil
(message "Starting %s..." command)
(save-excursion
(set-buffer buffer)
(erase-buffer)
(insert "\n") ;This newline works as start-process flag.
(setq proc
(start-process
"marche:show" buffer shell-file-name "-c" command))
(set-marker (process-mark proc) (point-min)))
(if (boundp 'MULE)
(set-process-coding-system
proc (if am-sjis-flag *sjis* *autoconv*) nil))
(set-process-sentinel
proc (list 'lambda '(proc mes)
(list sentinel 'proc 'mes)
(list 'am-chop-queue (list 'quote entry))))))
)
(defun am-flush-process-queue ()
(if am-process-queue
(let ((curbuf (current-buffer)))
(mapcar '(lambda (entry)
(let ((buf (car entry)))
(if (and (or (bufferp buf) (stringp buf))
(get-buffer buf))
(progn
(set-buffer buf)
(if (= (buffer-size) 0)
(kill-buffer buf))))))
am-process-queue)
(set-buffer curbuf)))
(setq am-process-queue nil)
)
(defun am-suitable-max-process ()
"Guess the number of processes emacs can run at the same time without
losing reasonable response.
** This version returns purely tentative score! **
** PLEASE TELL ME PROPERER VALUE **
"
(let ((curtime (current-time-string)) time (i 0) result
(mes "Checking your machine/system's performance."))
(message "%s." mes)
(while (string= curtime (current-time-string)))
(message "%s.." mes)
(setq curtime (current-time-string))
(while (string= curtime (current-time-string))
(setq i (1+ i)))
(setq result
(cond ((< i 1000) 1) ;maybe under 486SX(20MHz) or Sparc1
((< i 2000) 2) ;maybe under Sparc1+
((< i 3000) 3) ;maybe under Sparc2
((< i 5000) 4) ;maybe under Sparc10
((< i 10000) 5) ;???
((< i 20000) 6) ;????
(t 10) ;??????
))
(message "%s...Done(count:%d, level:%d)" mes i result)
(sit-for 1) ;bothering?? (^^;)
result)
)
(defun am-show-contents (file)
;;(if (not am-can-inspect)
;; (error "You can't inspect the head of file on this system."))
(let*((archive (file-name-nondirectory am-archive-file-name))
proc (arclist am-archive-list)
(viewbuffer (am-view-buffer-name archive file))
(showbuffer (am-show-buffer-name archive file))
buf (win (selected-window)) (curbuf (current-buffer))
(nulbuf "*marche*") (case-fold-search am-file-ignore-case))
(cond ;;`buf' should be set in each condition.
;;dired-mode hack
((eq major-mode 'dired-mode) (am-dired-prepare-contents))
;;if file name matches with binary file name regexp.
((string-match am-nonshow-file-name-regexp file)
(set-buffer (get-buffer-create showbuffer))
(setq buf showbuffer)
(if (> (buffer-size) 0) nil
(insert (format "%s in %s" file archive))
(set-buffer-modified-p nil)
(set-buffer curbuf) ;;to activate am-children-list
(setq am-children-list (cons showbuffer am-children-list))))
;;if the beginning of the file has alredy been shown.
((and (get-buffer showbuffer)
(progn (set-buffer showbuffer) (> (buffer-size) 0)))
(setq buf showbuffer))
;;if the file has already been viewed.
((get-buffer viewbuffer)(setq buf viewbuffer))
(am-can-inspect ;;t ;;else show the head of file contents.
(if (null (get-buffer showbuffer))
(setq am-children-list (cons showbuffer am-children-list)))
(get-buffer-create showbuffer)
(setq buf showbuffer)
(set-buffer curbuf)
(am-start-proc-with-queue
buf (concat "nice "
(am-build-command 'print arclist archive)
" " file " | head -"
(int-to-string (screen-height)))
'am-refresh-kanji))
(t ;;maybe on DOS. show current archive name.
(if (null (get-buffer nulbuf))
(setq am-children-list (cons nulbuf am-children-list)))
(set-buffer (get-buffer-create nulbuf))
(erase-buffer)
(insert (format "** %s **\n" archive))
(setq buf nulbuf)))
(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))
(bury-buffer (current-buffer))
(select-window win)
(switch-to-buffer curbuf))
)
(defun am-change-column (arg)
"Change am-file-name-column to the column where cursor belongs,
and call am-view-file."
(interactive "P")
(if (not arg) (skip-chars-backward "^ \n\t"))
(setq am-file-name-column (current-column))
(message "Change file name column to %d." am-file-name-column)
)
(defun am-unkown-table ()
(error "Sorry, unknown table format. Tell me archiver you always use.")
)
(defun am-on-file-name-line-p ()
(and (>= (point) am-begin-position) (< (point) am-end-position))
)
(defun am-guess-file-name-column ()
"Guess the column of the file names in the listing table, and return it."
(let ((case-fold-search t) col)
(save-excursion
(goto-char (point-min))
(while (not (eobp))
(beginning-of-line)
(insert " ")
(next-line 1))
(goto-char (point-min))
(cond
((re-search-forward am-table-begin-regexp nil t)
(forward-line 1)
(setq am-begin-position (point))
(if (search-backward "name" nil t)
(setq col (current-column))
(or
(setq col (get (intern-soft (am-get-command am-archive-list))
'file-name-column))
(am-unkown-table)))
(goto-char am-begin-position)
(move-to-column col)
(skip-chars-backward "^ \t^\n" ;`^' for zip
(point-beginning-of-line))
(setq col (current-column)) ;This will be the answer.
(goto-char (point-max))
(and (and (re-search-backward am-table-end-regexp nil t)
(> am-begin-position
(setq am-end-position
(progn (forward-line -1) (point-end-of-line))))))
col)
(t (am-unkown-table)))))
)
(defun am-next-line (arg)
"Move to next line and set cursor on the file name maybe."
(interactive "p")
(next-line arg)
(end-of-line)
(backward-char 1)
(if (am-on-file-name-line-p)
(let ((file (am-get-file-name)))
(move-to-column am-file-name-column)
(if (looking-at " ") (am-next-line arg)
(skip-chars-backward "^ \t" (point-end-of-line))
(if am-inspect-mode (am-show-contents file))))
(beginning-of-line))
)
(defun am-previous-line (arg)
"Move to previous line and set cursor on the file name maybe."
(interactive "p")
(am-next-line (- arg))
)
(defun am-this-line ()
(interactive)
(if (string= (substring (recent-keys) -1) (substring (recent-keys) -2 -1))
(let ((file (am-get-file-name)))
(if (null file) nil
(and (get-buffer (am-show-buffer-name am-archive-file-name file))
(kill-buffer (am-show-buffer-name am-archive-file-name file)))
(and (get-buffer (am-view-buffer-name am-archive-file-name file))
(kill-buffer (am-view-buffer-name am-archive-file-name file)))
)))
(if am-discard-process-queue-when-view (am-flush-process-queue))
(let ((am-inspect-mode t))
(am-next-line 0))
)
(defun am-enlarge-window (arg)
(interactive "p")
(if (one-window-p) nil
(let ((oldh am-contents-height))
(setq am-contents-height (- am-contents-height arg))
(cond
((< am-contents-height 4) (setq am-contents-height 4))
((< (window-height) 6)
(setq am-contents-height (1- am-contents-height))))
(message "Set inspect height to %d" am-contents-height)
(enlarge-window (- oldh am-contents-height))))
)
(defun am-shrink-window (arg)
(interactive "p")
(am-enlarge-window (- arg)))
(defun am-kill-relevant-buffers (buflist)
(while buflist
(if (get-buffer (car buflist)) (kill-buffer (car buflist)))
(setq buflist (cdr buflist))))
(defun am-quit ()
(interactive)
(let ((config am-initial-configuration))
(set-buffer-modified-p nil)
(save-excursion
(am-kill-relevant-buffers am-children-list))
(kill-buffer (current-buffer))
(if (and (= (screen-width) (nth 0 config))
(= (screen-height) (nth 1 config)))
(set-window-configuration (nth 2 config))))
)
(defun am-mark-file-forward (arg &optional sw)
"Mark current file."
(interactive "p")
(move-to-column am-file-name-column)
(if (and (= (current-column) am-file-name-column)
(am-on-file-name-line-p))
(let ((file (am-get-file-name)))
(setq buffer-read-only nil)
(set-buffer-modified-p t) ;to avoid locking
(skip-chars-backward "^ \*" (point-beginning-of-line))
(backward-char 1) ;goto position to mark
(cond
((eq sw 'mark) (delete-char 1) (insert " ") (backward-char 1))
((eq sw 'unmark) (delete-char 1) (insert "*") (backward-char 1)))
(cond
((looking-at " ") ;set mark
(replace-match "*")
(setq am-marked-file-list
(cons (list file (count-lines (point-min) (point)))
am-marked-file-list)))
((looking-at "\\*") ;erase mark
(replace-match " ")
(setq am-marked-file-list
(delq (assoc file am-marked-file-list)
am-marked-file-list))) ;Humm. More strict logic!
(t (error "Illegal format of table.")))
(am-next-line arg)
(if debug (message "%s" am-marked-file-list))
(setq buffer-read-only t)
(set-buffer-modified-p nil)
))
)
(defun am-mark-file ()
"Mark file and stay here."
(interactive)
(am-mark-file-forward 0)
)
(defun am-unmark-file-backward ()
"Move to previous file and unmark it, if neccessary."
(interactive)
(am-previous-line 1)
(am-mark-file-forward 0 'unmark)
)
(defun am-ask-overwrite (list)
(let ((file (car list)))
(if (file-exists-p file)
(if (y-or-n-p
(format "%s is in %s. remove?" file default-directory))
(delete-file file)
(error "Aborted."))
(if (file-exists-p file) (error "Cannot unlink %s" file))
))
)
(defun am-revert-buffer ()
"Replace the buffer with the archive contents on disk and initialize all."
(interactive)
(setq am-process-queue nil) ;;flush process queue
(let ((line (count-lines (point-min) (point))))
(set-buffer-modified-p nil)
(setq buffer-file-name am-archive-file-name)
(message "Reverting buffer...")
(save-excursion
(let ((buf (current-buffer))
(tmpbuf "*Reverting buffer, wait...*"))
(switch-to-buffer tmpbuf) ;; for beauty:->
(set-buffer buf)
(am-kill-relevant-buffers am-children-list)
(setq am-children-list nil)
(unwind-protect
(am-initiate-buffer)
(kill-buffer tmpbuf))))
(setq buffer-read-only t)
(set-buffer-modified-p nil)
(goto-line line)
(move-to-column am-file-name-column)
(if (and (am-on-file-name-line-p)
am-inspect-mode)
(am-show-contents (am-get-file-name)))
(message "Reverting buffer...Done."))
)
(defun am-change-listing (cmd)
(interactive "sListing switch: ")
(setq am-favorite-listing cmd)
(am-revert-buffer)
)
(defun am-unpack-files (arg)
"Call archiver with extract command on marked file(s)."
(interactive "P")
(let*((archiver(am-get-command am-archive-list))
(cmd (concat archiver " "
(am-get-extract am-archive-list) " "))
(archive (concat am-archive-file-name " "))
(flist (if (or arg (null am-marked-file-list))
(list (list (am-get-file-name) nil))
am-marked-file-list))
(files (if arg (am-get-file-name)
(mapconcat 'car (reverse flist) " ")))
(curbuf (current-buffer))
dest-dir)
(if (string= files "") (error "No file(s) specified."))
(save-window-excursion ;list files and ask output directory.
(pop-to-buffer (get-buffer-create "*Unpack file list*"))
(erase-buffer)
(insert files)
(let ((fill-prefix nil)(fill-column 78))
(fill-region (point-min) (point-max)))
(goto-char (point-max))
;;(if (> (window-height) (count-lines 1 (point)))
;; (shrink-window (- (window-height) (count-lines 1 (point)) 3)))
(unwind-protect
(progn
(setq dest-dir
(read-file-name
"Extract to..: " default-directory t nil))
(if (eq dest-dir t) (setq dest-dir default-directory))
(if (and (not (file-directory-p dest-dir))
(y-or-n-p (format "Makedir %s?" dest-dir)))
(am-make-directory dest-dir))
(if (not (string-match "/$" dest-dir))
(setq dest-dir (concat dest-dir "/"))))
(kill-buffer (current-buffer))))
;;canonicalize directory name
(with-output-to-temp-buffer am-unpack-buffer
(set-buffer (get-buffer am-unpack-buffer))
(setq default-directory dest-dir) ;is buffer local variable.
(princ (format "Extract {%s} from %s \n" files archive))
(if (get (intern archiver) 'ask-overwrite)
(mapcar 'am-ask-overwrite flist))
(am-call-command (concat cmd archive files) t)))
)
(defun am-delete-files (arg)
"Call archiver with extract command on marked file(s)."
(interactive "P")
(let*((list am-archive-list)
(archive (concat am-archive-file-name " "))
(flist (if (null am-marked-file-list)
(list (list (am-get-file-name) nil))
am-marked-file-list))
(files (if arg (am-get-file-name)
(mapconcat 'car (reverse flist) " ")))
(curbuf (current-buffer))
yes)
(if (string= files "") (error "No file(s) specified."))
(save-window-excursion ;list files and ask output directory.
(pop-to-buffer (get-buffer-create "*Delete file list*"))
(erase-buffer)
(insert files)
(let ((fill-prefix nil)(fill-column 76))
(fill-region (point-min) (point-max)))
(goto-char (point-max))
;;(if (> (window-height) (count-lines 1 (point)))
;; (shrink-window (- (window-height) (count-lines 1 (point)) 3)))
(unwind-protect
(setq yes (y-or-n-p "Delete these files?"))
(kill-buffer (get-buffer "*Delete file list*"))))
(if yes
(progn
(with-output-to-temp-buffer am-delete-buffer
(set-buffer (get-buffer am-delete-buffer))
(princ (format "Delete {%s} from %s \n" files archive))
(am-call-command
(am-build-command 'delete list archive files) t)
(princ "Done."))
(set-buffer curbuf)
(am-revert-buffer))
))
)
(defun am-save-buffer (&optional arg)
"Save this buffer and update archive."
(interactive "p")
(save-excursion
(if (buffer-modified-p)
(let ((command am-update-command)
(pbuf am-parent-buffer))
(save-buffer arg)
(set-buffer (get-buffer-create am-update-buffer))
(setq default-directory am-unpack-tmpdir)
(message "Call %s..." command)
(am-call-command command t)
(message "Call %s...Done" command))
(message "No changes need to be saved")))
)
(defun am-kill-buffer (arg)
"Kill buffer and erase temporary file."
(interactive "bKill buffer and erase file: ")
(if (or (and (stringp arg) (string= (buffer-name) arg))
(eq (current-buffer) arg))
(delete-file (if am-on-dos (downcase (buffer-file-name))
(buffer-file-name))))
(kill-buffer arg)
)
(defun am-find-file (filelist)
(if (stringp (car filelist))
(let ((file (car filelist)))
(if (not (file-exists-p file))
(error "Unpack trouble on %s in %s" file default-directory)
(find-file file)
(make-local-variable 'am-parent-archive)
(setq am-parent-archive archive)
(make-local-variable 'am-parent-buffer)
(setq am-parent-buffer curbuf)
(make-local-variable 'am-myname)
(setq am-myname file)
(make-local-variable 'am-update-command)
(setq am-update-command (am-build-command 'update list archive file))
(make-local-variable 'am-edit-mode-map)
(am-setup-edit-mode-map)
(use-local-map am-edit-mode-map)
(global-set-key "\ex" 'execute-extended-command)
)))
)
(defun am-edit-file (arg)
"Extract file(s) and edit it. If universal-argument ARG is non-nil,
edit the file where cursor exists instead of marked files."
(interactive "P")
(let*((list am-archive-list)
(archive (concat am-archive-file-name " "))
(archiver (am-get-command list))
(flist (if (or arg (null am-marked-file-list))
(list (list (am-get-file-name) nil))
am-marked-file-list))
(files (if arg (am-get-file-name)
(mapconcat 'car (reverse flist) " ")))
(curbuf (current-buffer)))
(if (string= files "") (error "No file(s) specified."))
(set-buffer (get-buffer-create am-unpack-buffer))
(setq default-directory am-unpack-tmpdir)
(if (file-directory-p default-directory) nil
(am-make-directory default-directory))
(if (get (intern archiver) 'ask-overwrite)
(mapcar 'am-ask-overwrite flist))
(am-call-command (am-build-command 'extract list archive files) nil)
(mapcar 'am-find-file flist)
(message
(substitute-command-keys
"Type \\[am-kill-buffer] to both kill-buffer and erase temporary file."))
(sit-for 3)
(message
(substitute-command-keys
"Type \\[am-save-buffer] to both save-buffer and update archive."))
(set-buffer curbuf)
)
)
(defvar am-edit-mode-map nil
"Key map used in archive file edit mode."
)
(defun am-setup-edit-mode-map ()
(if am-edit-mode-map nil
(message "Setting up edit mode keymap...")
(setq am-edit-mode-map
(if (current-local-map) (copy-keymap (current-local-map))
(make-sparse-keymap)))
(mapcar '(lambda (key) (define-key am-edit-mode-map key 'am-save-buffer))
(where-is-internal 'save-buffer))
(mapcar '(lambda (key) (define-key am-edit-mode-map key 'am-kill-buffer))
(where-is-internal 'kill-buffer))
(run-hooks 'am-setup-edit-mode-map-hook)
(message "Setting up edit mode keymap...Done."))
)
(defun am-get-marks ()
"Read mark information from current buffer."
(save-excursion
(goto-char am-begin-position)
(setq am-marked-file-list nil)
(move-to-column am-file-name-column)
(while (< (point) am-end-position)
(skip-chars-backward "^^* \n")
(forward-char -1)
(if (= (following-char) ?*)
(setq am-marked-file-list
(cons (list (am-get-file-name)
(count-lines (point-min) (point)))
am-marked-file-list)))
(am-next-line 1)))
)
(defun am-undo (arg)
"Undo function for listing buffer."
(interactive "P")
(setq buffer-read-only nil)
(set-buffer-modified-p t)
(undo arg)
(am-get-marks)
(set-buffer-modified-p nil)
(setq buffer-read-only t)
)
(defun am-mark-files-regexp (regexp)
"Mark files matching with REGEXP."
(interactive "sMarking regexp: ")
(save-excursion
(goto-char am-begin-position)
(while (< (point) am-end-position)
(move-to-column am-file-name-column)
(if (string-match regexp (am-get-file-name)) ;is file-name
(am-mark-file-forward 1 'mark) ;force marking
(am-next-line 1))
))
)
(defun am-reverse-marks ()
"Reverse all marks."
(interactive)
(save-excursion
(goto-char am-begin-position)
(while (< (point) am-end-position)
(am-mark-file-forward 1)))
)
(defun am-mark-unmark-all ()
"Mark or unmark all files."
(interactive)
(save-excursion
(let((action (if am-marked-file-list 'unmark 'mark)))
(goto-char am-begin-position)
(while (< (point) am-end-position)
(am-mark-file-forward 1 action))))
(move-to-column am-file-name-column)
)
(defvar arc-mode-map nil
"Key map used in arc-mode."
)
(if arc-mode-map
nil
(setq arc-mode-map (make-keymap))
(suppress-keymap arc-mode-map)
(define-key arc-mode-map "\C-m" 'am-view-file)
(define-key arc-mode-map "\C-j" 'am-change-column)
(define-key arc-mode-map "v" 'am-view-file)
(define-key arc-mode-map "V" 'am-version)
(define-key arc-mode-map "e" 'am-edit-file)
(define-key arc-mode-map "f" 'am-edit-file)
(define-key arc-mode-map "g" 'am-revert-buffer)
(define-key arc-mode-map "G" 'am-change-listing)
(define-key arc-mode-map "n" 'am-next-line)
(define-key arc-mode-map "j" 'am-next-line)
(define-key arc-mode-map "p" 'am-previous-line)
(define-key arc-mode-map "k" 'am-previous-line)
(define-key arc-mode-map " " 'am-mark-file-forward)
(define-key arc-mode-map "m" 'am-mark-file-forward)
(define-key arc-mode-map "u" 'am-unpack-files)
(define-key arc-mode-map "d" 'am-delete-files)
(define-key arc-mode-map "*" 'am-mark-files-regexp)
(define-key arc-mode-map "z" 'am-reverse-marks)
(define-key arc-mode-map "w" 'am-mark-unmark-all)
(define-key arc-mode-map "S" 'am-toggle-sjis-flag)
(define-key arc-mode-map ";" 'am-toggle-inspect)
(define-key arc-mode-map "." 'am-this-line)
(define-key arc-mode-map "o" 'other-window)
(define-key arc-mode-map "+" 'am-enlarge-window)
(define-key arc-mode-map "-" 'am-shrink-window)
(define-key arc-mode-map "\C-_" 'am-undo)
(define-key arc-mode-map "\C-i" 'am-mark-file)
(define-key arc-mode-map "\C-?" 'am-unmark-file-backward)
(define-key arc-mode-map "q" 'am-quit)
)
(defun am-insert-listing ()
"Erase narrowed whole buffer and call archive to insert listing."
(goto-char (point-min))
(am-call-command
(am-build-command 'listing am-archive-list am-archive-file-name) t)
)
(defun am-initiate-buffer ()
(setq buffer-read-only nil)
(save-excursion
(if am-file-name-column
(progn (delete-region (point-min) (point-max)) (widen)))
(erase-buffer)
(am-insert-listing)
(make-local-variable 'am-file-name-column)
(make-local-variable 'am-begin-position)
(make-local-variable 'am-end-position)
(setq am-file-name-column (am-guess-file-name-column))
(make-local-variable 'am-marked-file-list)
(setq am-marked-file-list nil)
(setq buffer-read-only t)
(set-buffer-modified-p nil))
;;Why find-file-noselect enclose after-find-file in save-excursion???
;;So two codes have no effects...
;;(goto-char am-begin-position)
;;(move-to-column am-file-name-column);;save-excursion
)
(defun am-get-buffer (file)
"Get arc-mode buffer named FILE."
(let ((list (buffer-list)))
(save-excursion
(catch 'found
(while list
(set-buffer (car list))
(if (and
(string= am-archive-file-name file)
(string-match
(regexp-quote (file-name-nondirectory file)) (buffer-name)))
(throw 'found (car list)))
(setq list (cdr list))))))
)
;;;
;; Override function
;;;
(if (fboundp 'am:saved-find-file-noselect) nil
(fset 'am:saved-find-file-noselect (symbol-function 'find-file-noselect))
(defun find-file-noselect (filename &optional nowarn)
(setq filename (expand-file-name filename))
(let ((buf (am-get-buffer filename)) ;find arc-mode buffer
(case-fold-search am-file-ignore-case))
(if buf (set-buffer buf)
(if (string-match am-file-name-regexp filename)
(save-excursion
(setq buf (generate-new-buffer
(file-name-nondirectory filename)))
(set-buffer buf)
(erase-buffer)
(setq default-directory (file-name-directory filename))
(setq buffer-file-name filename)
;;Entrust normal-mode with error operations.
(normal-mode t)) ;;must be (arc-mode);;
(setq buf (am:saved-find-file-noselect filename nowarn))))
buf)))
(defun arc-mode (&optional arg)
"Major mode for handling archive files as `miel', file browser on DOS,
does. Select the file by typing \\[am-previous-line] or \\[am-next-line]
and do the action to that file. Following actions are available.
\\[am-view-file] View file
\\[am-edit-file] Edit file
\\[am-mark-file-forward] Mark file forward
\\[am-unmark-file-backward] Unmark previous file
\\[am-mark-file] Mark/unmark current file
\\[am-mark-files-regexp] Mark files by regexp
\\[am-reverse-marks] Reverse marks
\\[am-mark-unmark-all] Mark/unmark all
\\[am-unpack-files] Unpack marked files
\\[am-delete-files] Delete marked files
\\[am-toggle-inspect] Toggle inspect mode
\\[am-this-line] Force to display this file
\\[other-window] Other window
\\[am-enlarge-window] Enlarge window
\\[am-shrink-window] Shrink window
\\[am-undo] Undo
\\[am-revert-buffer] Revert buffer
\\[am-change-listing] Change listing command
\\[am-change-column] Assume current column as file name
\\[am-quit] Quit Marche
To customize marche, use the hook variable `marche-load-hook',
`arc-mode-hook', `am-setup-edit-mode-map-hook' and `am-view-mode-hook'.
To change the archiver, set the variable am-archiver-alist referring the
value of am-archiver-alist-default."
(interactive "P")
(make-local-variable 'am-initial-configuration)
(setq am-initial-configuration
(list (screen-width) (screen-height) (current-window-configuration)))
(auto-save-mode 0)
(goto-char (point-min))
(make-local-variable 'am-archive-file-name)
(if am-archive-file-name nil
(setq am-archive-file-name (buffer-file-name))
(setq buffer-file-name nil)) ;;Disconnect to the file
(make-local-variable 'am-archive-list)
(setq am-archive-list
(assoc (substring am-archive-file-name -3)
(append am-archiver-alist am-archiver-alist-default)))
(make-local-variable 'am-children-list)
(make-local-variable 'am-favorite-listing)
(setq mode-name
(concat "marche:" (am-get-command am-archive-list)))
(setq major-mode 'arc-mode)
(am-initiate-buffer)
(message
"If my guess of file name column is wrong, type C-j on the file name.")
(run-hooks 'arc-mode-hook)
(use-local-map arc-mode-map)
)
(fset 'marche 'arc-mode)
(provide 'arc-mode)
(provide 'arch)
(provide 'marche)
(run-hooks 'marche-load-hook)
(setq am-unpack-tmpdir
(or am-unpack-tmpdir
(and (getenv "TMP") (am-convert-backslash (getenv "TMP")))
(and (file-directory-p "/tmp") "/tmp") ;for UN*X
(and (file-directory-p "/usr/tmp") "/usr/tmp")
(and (file-directory-p "c:/tmp") "c:/tmp") ;for DOS
"/"))
(setq am-max-process (am-suitable-max-process))
;; --------------- General sub functions ---------------
(defun point-beginning-of-line ()
(save-excursion (beginning-of-line)(point))
)
(defun point-end-of-line ()
(save-excursion (end-of-line)(point))
)
;;;$Log$
;;;Revision 1.4 1994/02/10 07:43:56 yuuji
;;;Dressed up for voyage.
;;;
; Revision 1.3 1993/12/24 08:24:44 yuuji
; Start-process with queue.
;
; Revision 1.1 93/12/12 22:34:24 yuuji
; Limit the maximum number of simultaneous running process.
;
; Revision 1.0 93/12/12 06:41:19 yuuji
; Support miel-like inspection.
;
; Revision 0.9 1993/09/25 18:38:14 yuuji
; C-j adjusts misplaced file name field.
; Fix updation/delete-tmp-file bug.
;
; Revision 0.7 1993/06/21 07:20:14 yuuji
; Fix english document.
; Enable recursive marche.
;
;;;慶応義塾理工学研究科管理工学専攻 広瀬雄二
;;;Faculty of Science and technology, KEIO Univ.
;;;HIROSE, Yuuji. [yuuji@ae.keio.ac.jp, pcs39334@ASCII-NET]
;--
;;;英語版ドキュメント:
;;;筑波大学大学院物理学研究科 桂川直己
;;;Institute of Phyisics, Univ. of Tsukuba
;;;KATSURAGAWA, Naoki. [katsura@prc.tsukuba.ac.jp, net66331@ASCII-NET]
; Local variables:
; fill-prefix: ";;; "
; paragraph-start: "^$\\| \\|;;;$"
; paragraph-separate: "^$\\| \\|;;;$"
; End:
yuuji