;;; arc-mode.el --- simple editing of archives
;; Copyright (C) 1995, 1997, 1998, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007 Free Software Foundation, Inc.
+;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
;; Author: Morten Welinder <terra@gnu.org>
;; Keywords: archives msdog editing major-mode
;; This file is part of GNU Emacs.
-;; GNU Emacs is free software; you can redistribute it and/or modify
+;; GNU Emacs 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 3, or (at your option)
-;; any later version.
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-;; Boston, MA 02110-1301, USA.
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; ARCHIVE TYPES: Currently only the archives below are handled, but the
;; structure for handling just about anything is in place.
;;
-;; Arc Lzh Zip Zoo
-;; --------------------------------
-;; View listing Intern Intern Intern Intern
-;; Extract member Y Y Y Y
-;; Save changed member Y Y Y Y
-;; Add new member N N N N
-;; Delete member Y Y Y Y
-;; Rename member Y Y N N
-;; Chmod - Y Y -
-;; Chown - Y - -
-;; Chgrp - Y - -
+;; Arc Lzh Zip Zoo Rar
+;; ----------------------------------------
+;; View listing Intern Intern Intern Intern Y
+;; Extract member Y Y Y Y Y
+;; Save changed member Y Y Y Y N
+;; Add new member N N N N N
+;; Delete member Y Y Y Y N
+;; Rename member Y Y N N N
+;; Chmod - Y Y - N
+;; Chown - Y - - N
+;; Chgrp - Y - - N
;;
;; Special thanks to Bill Brodie <wbrodie@panix.com> for very useful tips
;; on the first released version of this package.
;;; Code:
;; -------------------------------------------------------------------------
-;; Section: Configuration.
+;;; Section: Configuration.
(defgroup archive nil
"Simple editing of archives."
(string :format "%v")))
:group 'archive-zoo)
;; -------------------------------------------------------------------------
-;; Section: Variables
+;;; Section: Variables
(defvar archive-subtype nil "Symbol describing archive type.")
(defvar archive-file-list-start nil "Position of first contents line.")
(define-key map "M" 'archive-chmod-entry)
(define-key map "G" 'archive-chgrp-entry)
(define-key map "O" 'archive-chown-entry)
+ ;; Let mouse-1 follow the link.
+ (define-key map [follow-link] 'mouse-face)
(if (fboundp 'command-remapping)
(progn
(make-variable-buffer-local 'archive-files)
;; -------------------------------------------------------------------------
-;; Section: Support functions.
+;;; Section: Support functions.
(eval-when-compile
(defsubst byte-after (pos)
(if (not noerror)
(error "Line does not describe a member of the archive")))))
;; -------------------------------------------------------------------------
-;; Section: the mode definition
+;;; Section: the mode definition
;;;###autoload
(defun archive-mode (&optional force)
;; Have seen capital "LHA's", and file has lower case "LHa's" too.
;; Note this regexp is also in archive-exe-p.
((looking-at "MZ\\(.\\|\n\\)\\{34\\}LH[aA]'s SFX ") 'lzh-exe)
+ ((looking-at "Rar!") 'rar)
+ ((looking-at "!<arch>\n") 'ar)
+ ((and (looking-at "MZ")
+ (re-search-forward "Rar!" (+ (point) 100000) t))
+ 'rar-exe)
(t (error "Buffer format not recognized")))))
;; -------------------------------------------------------------------------
+
+(defun archive-desummarize ()
+ (let ((inhibit-read-only t)
+ (modified (buffer-modified-p)))
+ (widen)
+ (delete-region (point-min) archive-proper-file-start)
+ (restore-buffer-modified-p modified)))
+
+
(defun archive-summarize (&optional shut-up)
"Parse the contents of the archive file in the current buffer.
Place a dired-like listing on the front;
when parsing the archive."
(widen)
(let ((inhibit-read-only t))
+ (setq archive-proper-file-start (copy-marker (point-min) t))
+ (set (make-local-variable 'change-major-mode-hook) 'archive-desummarize)
(or shut-up
(message "Parsing archive file..."))
(buffer-disable-undo (current-buffer))
(defun archive-resummarize ()
"Recreate the contents listing of an archive."
- (let ((modified (buffer-modified-p))
- (no (archive-get-lineno))
- (inhibit-read-only t))
- (widen)
- (delete-region (point-min) archive-proper-file-start)
+ (let ((no (archive-get-lineno)))
+ (archive-desummarize)
(archive-summarize t)
- (restore-buffer-modified-p modified)
(goto-char archive-file-list-start)
(archive-next-line no)))
(setq archive-alternate-display (not archive-alternate-display))
(archive-resummarize))
;; -------------------------------------------------------------------------
-;; Section: Local archive copy handling
+;;; Section: Local archive copy handling
(defun archive-unique-fname (fname dir)
"Make sure a file FNAME can be created uniquely in directory DIR.
(error nil))
(if (string= name top) (setq again nil)))))
;; -------------------------------------------------------------------------
-;; Section: Member extraction
+;;; Section: Member extraction
+
+(defun archive-try-jka-compr ()
+ (when (and auto-compression-mode
+ (jka-compr-get-compression-info buffer-file-name))
+ (let* ((basename (file-name-nondirectory buffer-file-name))
+ (tmpname (if (string-match ":\\([^:]+\\)\\'" basename)
+ (match-string 1 basename) basename))
+ (tmpfile (make-temp-file (file-name-sans-extension tmpname)
+ nil
+ (file-name-extension tmpname 'period))))
+ (unwind-protect
+ (progn
+ (let ((coding-system-for-write 'no-conversion)
+ ;; Don't re-compress this data just before decompressing it.
+ (jka-compr-inhibit t))
+ (write-region (point-min) (point-max) tmpfile nil 'quiet))
+ (erase-buffer)
+ (let ((coding-system-for-read 'no-conversion))
+ (insert-file-contents tmpfile)))
+ (delete-file tmpfile)))))
(defun archive-file-name-handler (op &rest args)
(or (eq op 'file-exists-p)
(car (find-operation-coding-system
'insert-file-contents
(cons filename (current-buffer)) t))))))
- (if (and (not coding-system-for-read)
- (not enable-multibyte-characters))
- (setq coding
- (coding-system-change-text-conversion coding 'raw-text)))
- (if (and coding
- (not (eq coding 'no-conversion)))
- (decode-coding-region (point-min) (point-max) coding)
+ (unless (or coding-system-for-read
+ enable-multibyte-characters)
+ (setq coding
+ (coding-system-change-text-conversion coding 'raw-text)))
+ (unless (memq coding '(nil no-conversion))
+ (decode-coding-region (point-min) (point-max) coding)
(setq last-coding-system-used coding))
(set-buffer-modified-p nil)
(kill-local-variable 'buffer-file-coding-system)
(progn
(set-buffer-modified-p nil)
(kill-buffer buffer))
+ (archive-try-jka-compr) ;Pretty ugly hack :-(
(archive-set-buffer-as-visiting-file ename)
(goto-char (point-min))
(rename-buffer bufname)
(archive-maybe-update t))
(or (not (buffer-name buffer))
(cond
- (view-p (view-buffer buffer (and just-created 'kill-buffer)))
+ (view-p (view-buffer
+ buffer (and just-created 'kill-buffer-if-not-modified)))
((eq other-window-p 'display) (display-buffer buffer))
(other-window-p (switch-to-buffer-other-window buffer))
(t (switch-to-buffer buffer))))))
nil
nil
(append (cdr command) (list archive name))))
- (cond ((and (numberp exit-status) (= exit-status 0))
+ (cond ((and (numberp exit-status) (zerop exit-status))
(if (not (file-exists-p tmpfile))
(ding (message "`%s': no such file or directory" tmpfile))
(insert-file-contents tmpfile)
(file-name-nondirectory buffer-file-name)
""))))
(with-current-buffer arcbuf
- (or (eq major-mode 'archive-mode)
+ (or (derived-mode-p 'archive-mode)
(error "Buffer is not an archive buffer"))
(if archive-read-only
(error "Archive is read-only")))
(funcall func buffer-file-name membuf name))
(error "Adding a new member is not supported for this archive type"))))
;; -------------------------------------------------------------------------
-;; Section: IO stuff
+;;; Section: IO stuff
(defun archive-write-file-member ()
(save-excursion
;; the dired-like listing we created.
(if (eq major-mode 'archive-mode)
(archive-write-file tmpfile)
- (write-region (point-min) (point-max) tmpfile nil 'nomessage))
+ (write-region nil nil tmpfile nil 'nomessage))
;; basic-save-buffer needs last-coding-system-used to have
;; the value used to write the file, so save it before any
;; further processing clobbers it (we restore it in
nil
(append (cdr command)
(list archive ename)))))
- (if (equal exitcode 0)
- nil
- (error "Updating was unsuccessful (%S)" exitcode))))
+ (or (zerop exitcode)
+ (error "Updating was unsuccessful (%S)" exitcode))))
(archive-delete-local tmpfile))))
(defun archive-write-file (&optional file)
(set-buffer-modified-p nil))
t))
;; -------------------------------------------------------------------------
-;; Section: Marking and unmarking.
+;;; Section: Marking and unmarking.
(defun archive-flag-deleted (p &optional type)
"In archive mode, mark this member to be deleted from the archive.
(and default
(list (archive-get-descr))))))
;; -------------------------------------------------------------------------
-;; Section: Operate
+;;; Section: Operate
(defun archive-next-line (p)
(interactive "p")
(let ((inhibit-read-only t))
(undo)))
;; -------------------------------------------------------------------------
-;; Section: Arc Archives
+;;; Section: Arc Archives
(defun archive-arc-summarize ()
(let ((p 1)
(delete-char 13)
(insert-unibyte name)))))
;; -------------------------------------------------------------------------
-;; Section: Lzh Archives
+;;; Section: Lzh Archives
(defun archive-lzh-summarize (&optional start)
(let ((p (or start 1)) ;; 1 for .lzh, something further on for .exe
files "a unix-style mode" 8))
;; -------------------------------------------------------------------------
-;; Section: Lzh Self-Extracting .exe Archives
+;;; Section: Lzh Self-Extracting .exe Archives
;;
;; No support for modifying these files. It looks like the lha for unix
;; program (as of version 1.14i) can't create or retain the DOS exe part.
"Extract a member from an LZH self-extracting exe, for `archive-mode'.")
;; -------------------------------------------------------------------------
-;; Section: Zip Archives
+;;; Section: Zip Archives
(defun archive-zip-summarize ()
(goto-char (- (point-max) (- 22 18)))
(t (message "Don't know how to change mode for this member"))))
))))
;; -------------------------------------------------------------------------
-;; Section: Zoo Archives
+;;; Section: Zoo Archives
(defun archive-zoo-summarize ()
(let ((p (1+ (archive-l-e 25 4)))
(defun archive-zoo-extract (archive name)
(archive-extract-by-stdout archive name archive-zoo-extract))
+
+;; -------------------------------------------------------------------------
+;;; Section: Rar Archives
+
+(defun archive-rar-summarize (&optional file)
+ ;; File is used internally for `archive-rar-exe-summarize'.
+ (unless file (setq file buffer-file-name))
+ (let* ((copy (file-local-copy file))
+ (maxname 10)
+ (maxsize 5)
+ (files ()))
+ (with-temp-buffer
+ (call-process "unrar-free" nil t nil "--list" (or file copy))
+ (if copy (delete-file copy))
+ (goto-char (point-min))
+ (re-search-forward "^-+\n")
+ (while (looking-at (concat " \\(.*\\)\n" ;Name.
+ ;; Size ; Packed.
+ " +\\([0-9]+\\) +[0-9]+"
+ ;; Ratio ; Date'
+ " +\\([0-9%]+\\) +\\([-0-9]+\\)"
+ ;; Time ; Attr.
+ " +\\([0-9:]+\\) +......"
+ ;; CRC; Meth ; Var.
+ " +[0-9A-F]+ +[^ \n]+ +[0-9.]+\n"))
+ (goto-char (match-end 0))
+ (let ((name (match-string 1))
+ (size (match-string 2)))
+ (if (> (length name) maxname) (setq maxname (length name)))
+ (if (> (length size) maxsize) (setq maxsize (length size)))
+ (push (vector name name nil nil
+ ;; Size, Ratio.
+ size (match-string 3)
+ ;; Date, Time.
+ (match-string 4) (match-string 5))
+ files))))
+ (setq files (nreverse files))
+ (goto-char (point-min))
+ (let* ((format (format " %%s %%s %%%ds %%5s %%s" maxsize))
+ (sep (format format "--------" "-----" (make-string maxsize ?-)
+ "-----" ""))
+ (column (length sep)))
+ (insert (format format " Date " "Time " "Size " "Ratio" " Filename") "\n")
+ (insert sep (make-string maxname ?-) "\n")
+ (archive-summarize-files (mapcar (lambda (desc)
+ (let ((text
+ (format format
+ (aref desc 6)
+ (aref desc 7)
+ (aref desc 4)
+ (aref desc 5)
+ (aref desc 1))))
+ (vector text
+ column
+ (length text))))
+ files))
+ (insert sep (make-string maxname ?-) "\n")
+ (apply 'vector files))))
+
+(defun archive-rar-extract (archive name)
+ ;; unrar-free seems to have no way to extract to stdout or even to a file.
+ (if (file-name-absolute-p name)
+ ;; The code below assumes the name is relative and may do undesirable
+ ;; things otherwise.
+ (error "Can't extract files with non-relative names")
+ (let ((dest (make-temp-file "arc-rar" 'dir)))
+ (unwind-protect
+ (progn
+ (call-process "unrar-free" nil nil nil
+ "--extract" archive name dest)
+ (insert-file-contents-literally (expand-file-name name dest)))
+ (delete-file (expand-file-name name dest))
+ (while (file-name-directory name)
+ (setq name (directory-file-name (file-name-directory name)))
+ (delete-directory (expand-file-name name dest)))
+ (delete-directory dest)))))
+
+;;; Section: Rar self-extracting .exe archives.
+
+(defun archive-rar-exe-summarize ()
+ (let ((tmpfile (make-temp-file "rarexe")))
+ (unwind-protect
+ (progn
+ (goto-char (point-min))
+ (re-search-forward "Rar!")
+ (write-region (match-beginning 0) (point-max) tmpfile)
+ (archive-rar-summarize tmpfile))
+ (delete-file tmpfile))))
+
+(defun archive-rar-exe-extract (archive name)
+ (let* ((tmpfile (make-temp-file "rarexe"))
+ (buf (find-buffer-visiting archive))
+ (tmpbuf (unless buf (generate-new-buffer " *rar-exe*"))))
+ (unwind-protect
+ (progn
+ (with-current-buffer (or buf tmpbuf)
+ (save-excursion
+ (save-restriction
+ (if buf
+ ;; point-max unwidened is assumed to be the end of the
+ ;; summary text and the beginning of the actual file data.
+ (progn (goto-char (point-max)) (widen))
+ (insert-file-contents-literally archive)
+ (goto-char (point-min)))
+ (re-search-forward "Rar!")
+ (write-region (match-beginning 0) (point-max) tmpfile))))
+ (archive-rar-extract tmpfile name))
+ (if tmpbuf (kill-buffer tmpbuf))
+ (delete-file tmpfile))))
+
+
+;;; Section `ar' archives.
+
+;; TODO: we currently only handle the basic format of ar archives,
+;; not the GNU nor the BSD extensions. As it turns out, this is sufficient
+;; for .deb packages.
+
+(autoload 'tar-grind-file-mode "tar-mode")
+
+(defconst archive-ar-file-header-re
+ "\\(.\\{16\\}\\)\\([ 0-9]\\{12\\}\\)\\([ 0-9]\\{6\\}\\)\\([ 0-9]\\{6\\}\\)\\([ 0-7]\\{8\\}\\)\\([ 0-9]\\{10\\}\\)`\n")
+
+(defun archive-ar-summarize ()
+ ;; File is used internally for `archive-rar-exe-summarize'.
+ (let* ((maxname 10)
+ (maxtime 16)
+ (maxuser 5)
+ (maxgroup 5)
+ (maxmode 8)
+ (maxsize 5)
+ (files ()))
+ (goto-char (point-min))
+ (search-forward "!<arch>\n")
+ (while (looking-at archive-ar-file-header-re)
+ (let ((name (match-string 1))
+ ;; Emacs will automatically use float here because those
+ ;; timestamps don't fit in our ints.
+ (time (string-to-number (match-string 2)))
+ (user (match-string 3))
+ (group (match-string 4))
+ (mode (string-to-number (match-string 5) 8))
+ (size (string-to-number (match-string 6))))
+ ;; Move to the beginning of the data.
+ (goto-char (match-end 0))
+ (cond
+ ((equal name "// ")
+ ;; FIXME: todo
+ nil)
+ ((equal name "/ ")
+ ;; FIXME: todo
+ nil)
+ (t
+ (setq time
+ (format-time-string
+ "%Y-%m-%d %H:%M"
+ (let ((high (truncate (/ time 65536))))
+ (list high (truncate (- time (* 65536.0 high)))))))
+ (setq name (substring name 0 (string-match "/? *\\'" name)))
+ (setq user (substring user 0 (string-match " +\\'" user)))
+ (setq group (substring group 0 (string-match " +\\'" group)))
+ (setq mode (tar-grind-file-mode mode))
+ ;; Move to the end of the data.
+ (forward-char size) (if (eq ?\n (char-after)) (forward-char 1))
+ (setq size (number-to-string size))
+ (if (> (length name) maxname) (setq maxname (length name)))
+ (if (> (length time) maxtime) (setq maxtime (length time)))
+ (if (> (length user) maxuser) (setq maxuser (length user)))
+ (if (> (length group) maxgroup) (setq maxgroup (length group)))
+ (if (> (length mode) maxmode) (setq maxmode (length mode)))
+ (if (> (length size) maxsize) (setq maxsize (length size)))
+ (push (vector name name nil mode
+ time user group size)
+ files)))))
+ (setq files (nreverse files))
+ (goto-char (point-min))
+ (let* ((format (format "%%%ds %%%ds/%%-%ds %%%ds %%%ds %%s"
+ maxmode maxuser maxgroup maxsize maxtime))
+ (sep (format format (make-string maxmode ?-)
+ (make-string maxuser ?-)
+ (make-string maxgroup ?-)
+ (make-string maxsize ?-)
+ (make-string maxtime ?-) ""))
+ (column (length sep)))
+ (insert (format format " Mode " "User" "Group" " Size "
+ " Date " "Filename")
+ "\n")
+ (insert sep (make-string maxname ?-) "\n")
+ (archive-summarize-files (mapcar (lambda (desc)
+ (let ((text
+ (format format
+ (aref desc 3)
+ (aref desc 5)
+ (aref desc 6)
+ (aref desc 7)
+ (aref desc 4)
+ (aref desc 1))))
+ (vector text
+ column
+ (length text))))
+ files))
+ (insert sep (make-string maxname ?-) "\n")
+ (apply 'vector files))))
+
+(defun archive-ar-extract (archive name)
+ (let ((destbuf (current-buffer))
+ (archivebuf (find-file-noselect archive))
+ (from nil) size)
+ (with-current-buffer archivebuf
+ (save-restriction
+ ;; We may be in archive-mode or not, so either with or without
+ ;; narrowing and with or without a prepended summary.
+ (widen)
+ (search-forward "!<arch>\n")
+ (while (and (not from) (looking-at archive-ar-file-header-re))
+ (let ((this (match-string 1)))
+ (setq size (string-to-number (match-string 6)))
+ (goto-char (match-end 0))
+ (setq this (substring this 0 (string-match "/? *\\'" this)))
+ (if (equal name this)
+ (setq from (point))
+ ;; Move to the end of the data.
+ (forward-char size) (if (eq ?\n (char-after)) (forward-char 1)))))
+ (when from
+ (set-buffer-multibyte nil)
+ (with-current-buffer destbuf
+ ;; Do it within the `widen'.
+ (insert-buffer-substring archivebuf from (+ from size)))
+ (set-buffer-multibyte 'to)
+ ;; Inform the caller that the call succeeded.
+ t)))))
+
;; -------------------------------------------------------------------------
;; This line was a mistake; it is kept now for compatibility.
;; rms 15 Oct 98
HCoop / bpt / emacs.git / blobdiff