+;; -------------------------------------------------------------------------
+;;; Section: 7z Archives
+
+(defun archive-7z-summarize ()
+ (let ((maxname 10)
+ (maxsize 5)
+ (file buffer-file-name)
+ (files ()))
+ (with-temp-buffer
+ (call-process "7z" nil t nil "l" "-slt" file)
+ (goto-char (point-min))
+ (re-search-forward "^-+\n")
+ (while (re-search-forward "^Path = \\(.*\\)\n" nil t)
+ (goto-char (match-end 0))
+ (let ((name (match-string 1))
+ (size (save-excursion
+ (and (re-search-forward "^Size = \\(.*\\)\n")
+ (match-string 1))))
+ (time (save-excursion
+ (and (re-search-forward "^Modified = \\(.*\\)\n")
+ (match-string 1)))))
+ (if (> (length name) maxname) (setq maxname (length name)))
+ (if (> (length size) maxsize) (setq maxsize (length size)))
+ (push (vector name name nil nil time nil nil size)
+ files))))
+ (setq files (nreverse files))
+ (goto-char (point-min))
+ (let* ((format (format " %%%ds %%s %%s" maxsize))
+ (sep (format format (make-string maxsize ?-) "-------------------" ""))
+ (column (length sep)))
+ (insert (format format "Size " "Date Time " " Filename") "\n")
+ (insert sep (make-string maxname ?-) "\n")
+ (archive-summarize-files (mapcar (lambda (desc)
+ (let ((text
+ (format format
+ (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-7z-extract (archive name)
+ (let ((tmpfile (make-temp-file "7z-stderr")))
+ ;; 7z doesn't provide a `quiet' option to suppress non-essential
+ ;; stderr messages. So redirect stderr to a temp file and display it
+ ;; in the echo area when it contains error messages.
+ (prog1 (archive-extract-by-stdout
+ archive name archive-7z-extract tmpfile)
+ (with-temp-buffer
+ (insert-file-contents tmpfile)
+ (unless (search-forward "Everything is Ok" nil t)
+ (message "%s" (buffer-string)))
+ (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))
+ extname
+ ;; 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))
+ (setq time
+ (format-time-string
+ "%Y-%m-%d %H:%M"
+ (let ((high (truncate (/ time 65536))))
+ (list high (truncate (- time (* 65536.0 high)))))))
+ (setq extname
+ (cond ((equal name "// ")
+ (propertize ".<ExtNamesTable>." 'face 'italic))
+ ((equal name "/ ")
+ (propertize ".<LookupTable>." 'face 'italic))
+ ((string-match "/? *\\'" name)
+ (substring name 0 (match-beginning 0)))))
+ (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 extname 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.
+ (save-excursion
+ (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))
+ (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))))))