X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/ae940284fa77a6928f5162b7de859e67bdc7506c..791ffe1ce251f03d8cd51b4f67b56b975bd12083:/lisp/arc-mode.el diff --git a/lisp/arc-mode.el b/lisp/arc-mode.el index d3e4c9f3e3..fb6155dfd4 100644 --- a/lisp/arc-mode.el +++ b/lisp/arc-mode.el @@ -1,10 +1,10 @@ ;;; arc-mode.el --- simple editing of archives -;; Copyright (C) 1995, 1997, 1998, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc. +;; Copyright (C) 1995, 1997, 1998, 2001, 2002, 2003, 2004, 2005, 2006, +;; 2007, 2008, 2009, 2010 Free Software Foundation, Inc. ;; Author: Morten Welinder -;; Keywords: archives msdog editing major-mode +;; Keywords: files archives msdog editing major-mode ;; Favourite-brand-of-beer: None, I hate beer. ;; This file is part of GNU Emacs. @@ -52,17 +52,17 @@ ;; ARCHIVE TYPES: Currently only the archives below are handled, but the ;; structure for handling just about anything is in place. ;; -;; 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 +;; Arc Lzh Zip Zoo Rar 7z +;; -------------------------------------------- +;; View listing Intern Intern Intern Intern Y Y +;; Extract member Y Y Y Y Y Y +;; Save changed member Y Y Y Y N N +;; Add new member N N N N N N +;; Delete member Y Y Y Y N N +;; Rename member Y Y N N N N +;; Chmod - Y Y - N N +;; Chown - Y - - N N +;; Chgrp - Y - - N N ;; ;; Special thanks to Bill Brodie for very useful tips ;; on the first released version of this package. @@ -217,17 +217,17 @@ Archive and member name will be added." ;; Zip archive configuration (defcustom archive-zip-extract - (if (and (not (executable-find "unzip")) - (executable-find "pkunzip")) - '("pkunzip" "-e" "-o-") - '("unzip" "-qq" "-c")) + (cond ((executable-find "unzip") '("unzip" "-qq" "-c")) + ((executable-find "7z") '("7z" "x" "-so")) + ((executable-find "pkunzip") '("pkunzip" "-e" "-o-")) + (t '("unzip" "-qq" "-c"))) "Program and its options to run in order to extract a zip file member. Extraction should happen to standard output. Archive and member name will be added." :type '(list (string :tag "Program") - (repeat :tag "Options" - :inline t - (string :format "%v"))) + (repeat :tag "Options" + :inline t + (string :format "%v"))) :group 'archive-zip) ;; For several reasons the latter behavior is not desirable in general. @@ -315,6 +315,20 @@ Archive and member name will be added." :inline t (string :format "%v"))) :group 'archive-zoo) +;; ------------------------------ +;; 7z archive configuration + +(defcustom archive-7z-extract + '("7z" "x" "-so") + "Program and its options to run in order to extract a 7z file member. +Extraction should happen to standard output. Archive and member name will +be added." + :type '(list (string :tag "Program") + (repeat :tag "Options" + :inline t + (string :format "%v"))) + :group 'archive-7z) + ;; ------------------------------------------------------------------------- ;;; Section: Variables @@ -638,7 +652,7 @@ archive. ;; mode on and off. You can corrupt things that way. (if (zerop (buffer-size)) ;; At present we cannot create archives from scratch - (funcall default-major-mode) + (funcall (or (default-value 'major-mode) 'fundamental-mode)) (if (and (not force) archive-files) nil (let* ((type (archive-find-type)) (typename (capitalize (symbol-name type)))) @@ -698,7 +712,7 @@ archive. (or file-name-coding-system default-file-name-coding-system locale-coding-system)) - (if default-enable-multibyte-characters + (if (default-value 'enable-multibyte-characters) (set-buffer-multibyte 'to)) (archive-summarize nil) (setq buffer-read-only t)))) @@ -716,7 +730,7 @@ archive. ;; The funny [] here make it unlikely that the .elc file will be treated ;; as an archive by other software. (let (case-fold-search) - (cond ((looking-at "[P]K\003\004") 'zip) + (cond ((looking-at "\\(PK00\\)?[P]K\003\004") 'zip) ((looking-at "..-l[hz][0-9ds]-") 'lzh) ((looking-at "....................[\334]\247\304\375") 'zoo) ((and (looking-at "\C-z") ; signature too simple, IMHO @@ -732,6 +746,7 @@ archive. ((and (looking-at "MZ") (re-search-forward "Rar!" (+ (point) 100000) t)) 'rar-exe) + ((looking-at "7z\274\257\047\034") '7z) (t (error "Buffer format not recognized"))))) ;; ------------------------------------------------------------------------- @@ -818,15 +833,27 @@ If FNAME is something our underlying filesystem can't grok, or if another file by that name already exists in DIR, a unique new name is generated using `make-temp-file', and the generated name is returned." (let ((fullname (expand-file-name fname dir)) - (alien (string-match file-name-invalid-regexp fname))) - (if (or alien (file-exists-p fullname)) - (make-temp-file + (alien (string-match file-name-invalid-regexp fname)) + (tmpfile (expand-file-name (if (if (fboundp 'msdos-long-file-names) (not (msdos-long-file-names))) "am" "arc-mode.") - dir)) + dir))) + (if (or alien (file-exists-p fullname)) + (progn + ;; Maked sure all the leading directories in + ;; archive-local-name exist under archive-tmpdir, so that + ;; the directory structure recorded in the archive is + ;; reconstructed in the temporary directory. + (make-directory (file-name-directory tmpfile) t) + (make-temp-file tmpfile)) + ;; Maked sure all the leading directories in `fullname' exist + ;; under archive-tmpdir. This is necessary for nested archives + ;; (`archive-extract' sets `archive-remote' to t in case + ;; an archive occurs inside another archive). + (make-directory (file-name-directory fullname) t) fullname))) (defun archive-maybe-copy (archive) @@ -843,11 +870,6 @@ using `make-temp-file', and the generated name is returned." archive))) (setq archive-local-name (archive-unique-fname archive-name archive-tmpdir)) - ;; Maked sure all the leading directories in - ;; archive-local-name exist under archive-tmpdir, so that - ;; the directory structure recorded in the archive is - ;; reconstructed in the temporary directory. - (make-directory (file-name-directory archive-local-name) t) (save-restriction (widen) (write-region start (point-max) archive-local-name nil 'nomessage)) @@ -1040,8 +1062,8 @@ using `make-temp-file', and the generated name is returned." (archive-maybe-update t)) (or (not (buffer-name buffer)) (cond - (view-p (view-buffer - buffer (and just-created 'kill-buffer-if-not-modified))) + (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)))))) @@ -1074,11 +1096,11 @@ using `make-temp-file', and the generated name is returned." (archive-delete-local tmpfile) success)) -(defun archive-extract-by-stdout (archive name command) +(defun archive-extract-by-stdout (archive name command &optional stderr-file) (apply 'call-process (car command) nil - t + (if stderr-file (list t stderr-file) t) nil (append (cdr command) (list archive name)))) @@ -1780,9 +1802,22 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (apply 'vector (nreverse files)))) (defun archive-zip-extract (archive name) - (if (equal (car archive-zip-extract) "pkzip") - (archive-*-extract archive name archive-zip-extract) - (archive-extract-by-stdout archive name archive-zip-extract))) + (cond + ((member-ignore-case (car archive-zip-extract) '("pkunzip" "pkzip")) + (archive-*-extract archive name archive-zip-extract)) + ((equal (car archive-zip-extract) "7z") + (let ((archive-7z-extract archive-zip-extract)) + (archive-7z-extract archive name))) + (t + (archive-extract-by-stdout + archive + ;; unzip expands wildcards in NAME, so we need to quote it. + ;; FIXME: Does pkunzip need similar treatment? + ;; (7z doesn't need to quote wildcards) + (if (equal (car archive-zip-extract) "unzip") + (shell-quote-argument name) + name) + archive-zip-extract)))) (defun archive-zip-write-file-member (archive descr) (archive-*-write-file-member @@ -1902,7 +1937,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." ;; Ratio ; Date' " +\\([0-9%]+\\) +\\([-0-9]+\\)" ;; Time ; Attr. - " +\\([0-9:]+\\) +......" + " +\\([0-9:]+\\) +[^ \n]\\{6,10\\}" ;; CRC; Meth ; Var. " +[0-9A-F]+ +[^ \n]+ +[0-9.]+\n")) (goto-char (match-end 0)) @@ -1990,7 +2025,65 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (if tmpbuf (kill-buffer tmpbuf)) (delete-file tmpfile)))) +;; ------------------------------------------------------------------------- +;;; 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, @@ -2015,6 +2108,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (search-forward "!\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))) @@ -2024,35 +2118,33 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (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 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 ".." 'face 'italic)) + ((equal name "/ ") + (propertize ".." '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" @@ -2091,25 +2183,25 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (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 "!\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))))) + (save-excursion + (widen) + (search-forward "!\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)))))) ;; ------------------------------------------------------------------------- ;; This line was a mistake; it is kept now for compatibility.