diff options
Diffstat (limited to 'lisp/arc-mode.el')
| -rw-r--r-- | lisp/arc-mode.el | 1077 |
1 files changed, 540 insertions, 537 deletions
diff --git a/lisp/arc-mode.el b/lisp/arc-mode.el index c09f78e0d24..c998a8a1f1a 100644 --- a/lisp/arc-mode.el +++ b/lisp/arc-mode.el @@ -1,4 +1,4 @@ -;;; arc-mode.el --- simple editing of archives +;;; arc-mode.el --- simple editing of archives -*- lexical-binding: t; -*- ;; Copyright (C) 1995, 1997-1998, 2001-2020 Free Software Foundation, ;; Inc. @@ -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 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 Y -;; Add new member N N N N N N -;; Delete member Y Y Y Y N Y -;; Rename member Y Y N N N N -;; Chmod - Y Y - N N -;; Chown - Y - - N N -;; Chgrp - Y - - N N +;; Arc Lzh Zip Zoo Rar 7z Ar +;; -------------------------------------------------- +;; View listing Intern Intern Intern Intern Y Y Y +;; Extract member Y Y Y Y Y Y Y +;; Save changed member Y Y Y Y N Y Y +;; Add new member N N N N N N N +;; Delete member Y Y Y Y N Y N +;; Rename member Y Y N N N N N +;; Chmod - Y Y - N N N +;; Chown - Y - - N N N +;; Chgrp - Y - - N N N ;; ;; Special thanks to Bill Brodie <wbrodie@panix.com> for very useful tips ;; on the first released version of this package. @@ -101,6 +101,8 @@ ;;; Code: +(eval-when-compile (require 'cl-lib)) + ;; ------------------------------------------------------------------------- ;;; Section: Configuration. @@ -108,22 +110,6 @@ "Simple editing of archives." :group 'data) -(defgroup archive-arc nil - "ARC-specific options to archive." - :group 'archive) - -(defgroup archive-lzh nil - "LZH-specific options to archive." - :group 'archive) - -(defgroup archive-zip nil - "ZIP-specific options to archive." - :group 'archive) - -(defgroup archive-zoo nil - "ZOO-specific options to archive." - :group 'archive) - (defcustom archive-tmpdir ;; make-temp-name is safe here because we use this name ;; to create a directory. @@ -131,35 +117,48 @@ (expand-file-name (if (eq system-type 'ms-dos) "ar" "archive.tmp") temporary-file-directory)) "Directory for temporary files made by `arc-mode.el'." - :type 'directory - :group 'archive) + :type 'directory) (defcustom archive-remote-regexp "^/[^/:]*[^/:.]:" "Regexp recognizing archive files names that are not local. A non-local file is one whose file name is not proper outside Emacs. A local copy of the archive will be used when updating." - :type 'regexp - :group 'archive) + :type 'regexp) (define-obsolete-variable-alias 'archive-extract-hooks 'archive-extract-hook "24.3") (defcustom archive-extract-hook nil "Hook run when an archive member has been extracted." - :type 'hook - :group 'archive) + :type 'hook) (defcustom archive-visit-single-files nil "If non-nil, opening an archive with a single file visits that file. If nil, visiting such an archive displays the archive summary." :version "25.1" :type '(choice (const :tag "Visit the single file" t) - (const :tag "Show the archive summary" nil)) - :group 'archive) + (const :tag "Show the archive summary" nil))) + +(defcustom archive-hidden-columns '(Ids) + "Columns hidden from display." + :version "28.1" + :type '(set (const Mode) + (const Ids) + (const Date&Time) + (const Ratio))) + +(defconst archive-alternate-hidden-columns '(Mode Date&Time) + "Columns hidden when `archive-alternate-display' is used.") + ;; ------------------------------ ;; Arc archive configuration ;; We always go via a local file since there seems to be no reliable way ;; to extract to stdout without junk getting added. + +(defgroup archive-arc nil + "ARC-specific options to archive." + :group 'archive) + (defcustom archive-arc-extract '("arc" "x") "Program and its options to run in order to extract an arc file member. @@ -168,8 +167,7 @@ name will be added." :type '(list (string :tag "Program") (repeat :tag "Options" :inline t - (string :format "%v"))) - :group 'archive-arc) + (string :format "%v")))) (defcustom archive-arc-expunge '("arc" "d") @@ -178,8 +176,7 @@ Archive and member names will be added." :type '(list (string :tag "Program") (repeat :tag "Options" :inline t - (string :format "%v"))) - :group 'archive-arc) + (string :format "%v")))) (defcustom archive-arc-write-file-member '("arc" "u") @@ -188,11 +185,14 @@ Archive and member name will be added." :type '(list (string :tag "Program") (repeat :tag "Options" :inline t - (string :format "%v"))) - :group 'archive-arc) + (string :format "%v")))) ;; ------------------------------ ;; Lzh archive configuration +(defgroup archive-lzh nil + "LZH-specific options to archive." + :group 'archive) + (defcustom archive-lzh-extract '("lha" "pq") "Program and its options to run in order to extract an lzh file member. @@ -201,8 +201,7 @@ be added." :type '(list (string :tag "Program") (repeat :tag "Options" :inline t - (string :format "%v"))) - :group 'archive-lzh) + (string :format "%v")))) (defcustom archive-lzh-expunge '("lha" "d") @@ -211,8 +210,7 @@ Archive and member names will be added." :type '(list (string :tag "Program") (repeat :tag "Options" :inline t - (string :format "%v"))) - :group 'archive-lzh) + (string :format "%v")))) (defcustom archive-lzh-write-file-member '("lha" "a") @@ -221,8 +219,7 @@ Archive and member name will be added." :type '(list (string :tag "Program") (repeat :tag "Options" :inline t - (string :format "%v"))) - :group 'archive-lzh) + (string :format "%v")))) ;; ------------------------------ ;; Zip archive configuration @@ -231,6 +228,10 @@ Archive and member name will be added." (when 7z (file-name-nondirectory 7z)))) +(defgroup archive-zip nil + "ZIP-specific options to archive." + :group 'archive) + (defcustom archive-zip-extract (cond ((executable-find "unzip") '("unzip" "-qq" "-c")) (archive-7z-program `(,archive-7z-program "x" "-so")) @@ -242,8 +243,7 @@ be added." :type '(list (string :tag "Program") (repeat :tag "Options" :inline t - (string :format "%v"))) - :group 'archive-zip) + (string :format "%v")))) ;; For several reasons the latter behavior is not desirable in general. ;; (1) It uses more disk space. (2) Error checking is worse or non- @@ -260,8 +260,7 @@ Archive and member names will be added." :type '(list (string :tag "Program") (repeat :tag "Options" :inline t - (string :format "%v"))) - :group 'archive-zip) + (string :format "%v")))) (defcustom archive-zip-update (cond ((executable-find "zip") '("zip" "-q")) @@ -274,8 +273,7 @@ file. Archive and member name will be added." :type '(list (string :tag "Program") (repeat :tag "Options" :inline t - (string :format "%v"))) - :group 'archive-zip) + (string :format "%v")))) (defcustom archive-zip-update-case (cond ((executable-find "zip") '("zip" "-q" "-k")) @@ -288,8 +286,7 @@ Archive and member name will be added." :type '(list (string :tag "Program") (repeat :tag "Options" :inline t - (string :format "%v"))) - :group 'archive-zip) + (string :format "%v")))) (declare-function msdos-long-file-names "msdos.c") (defcustom archive-zip-case-fiddle (and (eq system-type 'ms-dos) @@ -300,11 +297,14 @@ that uses caseless file names. In addition, this flag forces members added/updated in the zip archive to be truncated to DOS 8+3 file-name restrictions." :type 'boolean - :version "27.1" - :group 'archive-zip) + :version "27.1") ;; ------------------------------ ;; Zoo archive configuration +(defgroup archive-zoo nil + "ZOO-specific options to archive." + :group 'archive) + (defcustom archive-zoo-extract '("zoo" "xpq") "Program and its options to run in order to extract a zoo file member. @@ -313,8 +313,7 @@ be added." :type '(list (string :tag "Program") (repeat :tag "Options" :inline t - (string :format "%v"))) - :group 'archive-zoo) + (string :format "%v")))) (defcustom archive-zoo-expunge '("zoo" "DqPP") @@ -323,8 +322,7 @@ Archive and member names will be added." :type '(list (string :tag "Program") (repeat :tag "Options" :inline t - (string :format "%v"))) - :group 'archive-zoo) + (string :format "%v")))) (defcustom archive-zoo-write-file-member '("zoo" "a") @@ -333,11 +331,14 @@ Archive and member name will be added." :type '(list (string :tag "Program") (repeat :tag "Options" :inline t - (string :format "%v"))) - :group 'archive-zoo) + (string :format "%v")))) ;; ------------------------------ ;; 7z archive configuration +(defgroup archive-7z nil + "7Z-specific options to archive." + :group 'archive) + (defcustom archive-7z-extract `(,(or archive-7z-program "7z") "x" "-so") "Program and its options to run in order to extract a 7z file member. @@ -347,8 +348,7 @@ be added." :type '(list (string :tag "Program") (repeat :tag "Options" :inline t - (string :format "%v"))) - :group 'archive-7z) + (string :format "%v")))) (defcustom archive-7z-expunge `(,(or archive-7z-program "7z") "d") @@ -358,8 +358,7 @@ Archive and member names will be added." :type '(list (string :tag "Program") (repeat :tag "Options" :inline t - (string :format "%v"))) - :group 'archive-7z) + (string :format "%v")))) (defcustom archive-7z-update `(,(or archive-7z-program "7z") "u") @@ -370,18 +369,17 @@ file. Archive and member name will be added." :type '(list (string :tag "Program") (repeat :tag "Options" :inline t - (string :format "%v"))) - :group 'archive-7z) + (string :format "%v")))) ;; ------------------------------------------------------------------------- ;;; Section: Variables (defvar archive-subtype nil "Symbol describing archive type.") -(defvar archive-file-list-start nil "Position of first contents line.") -(defvar archive-file-list-end nil "Position just after last contents line.") -(defvar archive-proper-file-start nil "Position of real archive's start.") +(defvar-local archive-file-list-start nil "Position of first contents line.") +(defvar-local archive-file-list-end nil "Position just after last contents line.") +(defvar-local archive-proper-file-start nil "Position of real archive's start.") (defvar archive-read-only nil "Non-nil if the archive is read-only on disk.") -(defvar archive-local-name nil "Name of local copy of remote archive.") +(defvar-local archive-local-name nil "Name of local copy of remote archive.") (defvar archive-mode-map (let ((map (make-keymap))) (set-keymap-parent map special-mode-map) @@ -393,6 +391,7 @@ file. Archive and member name will be added." (define-key map "e" 'archive-extract) (define-key map "f" 'archive-extract) (define-key map "\C-m" 'archive-extract) + (define-key map "C" 'archive-copy-file) (define-key map "m" 'archive-mark) (define-key map "n" 'archive-next-line) (define-key map "\C-n" 'archive-next-line) @@ -428,11 +427,13 @@ file. Archive and member name will be added." (cons "Immediate" (make-sparse-keymap "Immediate"))) (define-key map [menu-bar immediate alternate] '(menu-item "Alternate Display" archive-alternate-display - :enable (boundp (archive-name "alternate-display")) :help "Toggle alternate file info display")) (define-key map [menu-bar immediate view] '(menu-item "View This File" archive-view :help "Display file at cursor in View Mode")) + (define-key map [menu-bar immediate view] + '(menu-item "Copy This File" archive-copy-file + :help "Copy file at cursor to another location")) (define-key map [menu-bar immediate display] '(menu-item "Display in Other Window" archive-display-other-window :help "Display file at cursor in another window")) @@ -483,36 +484,58 @@ file. Archive and member name will be added." :help "Delete all flagged files from archive")) map) "Local keymap for archive mode listings.") -(defvar archive-file-name-indent nil "Column where file names start.") +(defvar-local archive-file-name-indent nil "Column where file names start.") -(defvar archive-remote nil "Non-nil if the archive is outside file system.") -(make-variable-buffer-local 'archive-remote) +(defvar-local archive-remote nil "Non-nil if the archive is outside file system.") (put 'archive-remote 'permanent-local t) -(defvar archive-member-coding-system nil "Coding-system of archive member.") -(make-variable-buffer-local 'archive-member-coding-system) +(defvar-local archive-member-coding-system nil "Coding-system of archive member.") -(defvar archive-alternate-display nil +(defvar-local archive-alternate-display nil "Non-nil when alternate information is shown.") -(make-variable-buffer-local 'archive-alternate-display) (put 'archive-alternate-display 'permanent-local t) (defvar archive-superior-buffer nil "In archive members, points to archive.") (put 'archive-superior-buffer 'permanent-local t) -(defvar archive-subfile-mode nil "Non-nil in archive member buffers.") -(make-variable-buffer-local 'archive-subfile-mode) +(defvar-local archive-subfile-mode nil + "Non-nil in archive member buffers. +Its value is an `archive--file-desc'.") (put 'archive-subfile-mode 'permanent-local t) -(defvar archive-file-name-coding-system nil) -(make-variable-buffer-local 'archive-file-name-coding-system) +(defvar-local archive-file-name-coding-system nil) (put 'archive-file-name-coding-system 'permanent-local t) -(defvar archive-files nil - "Vector of file descriptors. -Each descriptor is a vector of the form - [EXT-FILE-NAME INT-FILE-NAME CASE-FIDDLED MODE ...]") -(make-variable-buffer-local 'archive-files) +(cl-defstruct (archive--file-desc + (:constructor nil) + (:constructor archive--file-desc + ;; ext-file-name and int-file-name are usually `eq' + ;; except when int-file-name is the downcased + ;; ext-file-name. + (ext-file-name int-file-name mode size time + &key pos ratio uid gid))) + ext-file-name int-file-name + (mode nil :type integer) + (size nil :type integer) + (time nil :type string) + (ratio nil :type string) + uid gid + pos) + +;; Features in formats: +;; +;; ARC: size, date&time (date and time strings internally generated) +;; LZH: size, date&time, mode, uid, gid (mode, date, time generated, ugid:int) +;; ZIP: size, date&time, mode (mode, date, time generated) +;; ZOO: size, date&time (date and time strings internally generated) +;; AR : size, date&time, mode, user, group (internally generated) +;; RAR: size, date&time, ratio (all as strings, using `lsar') +;; 7Z : size, date&time (all as strings, using `7z' or `7za') +;; +;; LZH has alternate display (with UID/GID i.s.o MODE/DATE/TIME + +(defvar-local archive-files nil + "Vector of `archive--file-desc' objects.") ;; ------------------------------------------------------------------------- ;;; Section: Support functions. @@ -520,9 +543,9 @@ Each descriptor is a vector of the form (defun arc-insert-unibyte (&rest args) "Like insert but don't make unibyte string and eight-bit char multibyte." (dolist (elt args) - (if (integerp elt) - (insert (if (< elt 128) elt (decode-char 'eight-bit elt))) - (insert elt)))) + (insert (if (and (integerp elt) (>= elt 128)) + (decode-char 'eight-bit elt) + elt)))) (defsubst archive-name (suffix) (intern (concat "archive-" (symbol-name archive-subtype) "-" suffix))) @@ -544,73 +567,19 @@ in which case a second argument, length LEN, should be supplied." (aref str (- len i))))) result)) -(defun archive-int-to-mode (mode) - "Turn an integer like 0700 (i.e., 448) into a mode string like -rwx------." - ;; FIXME: merge with tar-grind-file-mode. - (string - (if (zerop (logand 8192 mode)) - (if (zerop (logand 16384 mode)) ?- ?d) - ?c) ; completeness - (if (zerop (logand 256 mode)) ?- ?r) - (if (zerop (logand 128 mode)) ?- ?w) - (if (zerop (logand 64 mode)) - (if (zerop (logand 2048 mode)) ?- ?S) - (if (zerop (logand 2048 mode)) ?x ?s)) - (if (zerop (logand 32 mode)) ?- ?r) - (if (zerop (logand 16 mode)) ?- ?w) - (if (zerop (logand 8 mode)) - (if (zerop (logand 1024 mode)) ?- ?S) - (if (zerop (logand 1024 mode)) ?x ?s)) - (if (zerop (logand 4 mode)) ?- ?r) - (if (zerop (logand 2 mode)) ?- ?w) - (if (zerop (logand 1 mode)) ?- ?x))) - -(defun archive-calc-mode (oldmode newmode &optional error) +(define-obsolete-function-alias 'archive-int-to-mode + 'file-modes-number-to-symbolic "28.1") + +(defun archive-calc-mode (oldmode newmode) "From the integer OLDMODE and the string NEWMODE calculate a new file mode. NEWMODE may be an octal number including a leading zero in which case it will become the new mode.\n NEWMODE may also be a relative specification like \"og-rwx\" in which case -OLDMODE will be modified accordingly just like chmod(2) would have done.\n -If optional third argument ERROR is non-nil an error will be signaled if -the mode is invalid. If ERROR is nil then nil will be returned." - (cond ((string-match "^0[0-7]*$" newmode) - (let ((result 0) - (len (length newmode)) - (i 1)) - (while (< i len) - (setq result (+ (ash result 3) (aref newmode i) (- ?0)) - i (1+ i))) - (logior (logand oldmode 65024) result))) - ((string-match "^\\([agou]+\\)\\([---+=]\\)\\([rwxst]+\\)$" newmode) - (let ((who 0) - (result oldmode) - (op (aref newmode (match-beginning 2))) - (bits 0) - (i (match-beginning 3))) - (while (< i (match-end 3)) - (let ((rwx (aref newmode i))) - (setq bits (logior bits (cond ((= rwx ?r) 292) - ((= rwx ?w) 146) - ((= rwx ?x) 73) - ((= rwx ?s) 3072) - ((= rwx ?t) 512))) - i (1+ i)))) - (while (< who (match-end 1)) - (let* ((whoc (aref newmode who)) - (whomask (cond ((= whoc ?a) 4095) - ((= whoc ?u) 1472) - ((= whoc ?g) 2104) - ((= whoc ?o) 7)))) - (if (= op ?=) - (setq result (logand result (lognot whomask)))) - (if (= op ?-) - (setq result (logand result (lognot (logand whomask bits)))) - (setq result (logior result (logand whomask bits))))) - (setq who (1+ who))) - result)) - (t - (if error - (error "Invalid mode specification: %s" newmode))))) +OLDMODE will be modified accordingly just like chmod(2) would have done." + ;; FIXME: Use `file-modes-symbolic-to-number'! + (if (string-match "\\`0[0-7]*\\'" newmode) + (logior (logand oldmode #o177000) (string-to-number newmode 8)) + (file-modes-symbolic-to-number newmode oldmode))) (defun archive-dosdate (date) "Stringify dos packed DATE record." @@ -622,7 +591,8 @@ the mode is invalid. If ERROR is nil then nil will be returned." (format "%2d-%s-%d" day (aref ["Jan" "Feb" "Mar" "Apr" "May" "Jun" - "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"] (1- month)) + "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"] + (1- month)) year)))) (defun archive-dostime (time) @@ -658,10 +628,12 @@ Does not signal an error if optional argument NOERROR is non-nil." (if (and (>= (point) archive-file-list-start) (< no (length archive-files))) (let ((item (aref archive-files no))) - (if (vectorp item) + (if (and (archive--file-desc-p item) + (let ((mode (archive--file-desc-mode item))) + (zerop (logand 16384 mode)))) item (if (not noerror) - (error "Entry is not a regular member of the archive")))) + (user-error "Entry is not a regular member of the archive")))) (if (not noerror) (error "Line does not describe a member of the archive"))))) ;; ------------------------------------------------------------------------- @@ -684,41 +656,34 @@ archive. ;; mode on and off. You can corrupt things that way. (if (zerop (buffer-size)) ;; At present we cannot create archives from scratch - (funcall (or (default-value 'major-mode) 'fundamental-mode)) + (funcall (or (default-value 'major-mode) #'fundamental-mode)) (if (and (not force) archive-files) nil (kill-all-local-variables) (let* ((type (archive-find-type)) (typename (capitalize (symbol-name type)))) - (make-local-variable 'archive-subtype) - (setq archive-subtype type) + (setq-local archive-subtype type) ;; Buffer contains treated image of file before the file contents - (make-local-variable 'revert-buffer-function) - (setq revert-buffer-function 'archive-mode-revert) - (auto-save-mode 0) + (add-function :around (local 'revert-buffer-function) + #'archive--mode-revert) - (add-hook 'write-contents-functions 'archive-write-file nil t) + (add-hook 'write-contents-functions #'archive-write-file nil t) - (make-local-variable 'require-final-newline) - (setq require-final-newline nil) - (make-local-variable 'local-enable-local-variables) - (setq local-enable-local-variables nil) + (setq-local truncate-lines t) + (setq-local require-final-newline nil) + (setq-local local-enable-local-variables nil) ;; Prevent loss of data when saving the file. - (make-local-variable 'file-precious-flag) - (setq file-precious-flag t) + (setq-local file-precious-flag t) - (make-local-variable 'archive-read-only) ;; Archives which are inside other archives and whose ;; names are invalid for this OS, can't be written. - (setq archive-read-only - (or (not (file-writable-p (buffer-file-name))) - (and archive-subfile-mode - (string-match file-name-invalid-regexp - (aref archive-subfile-mode 0))))) - - ;; Should we use a local copy when accessing from outside Emacs? - (make-local-variable 'archive-local-name) + (setq-local archive-read-only + (or (not (file-writable-p (buffer-file-name))) + (and archive-subfile-mode + (string-match file-name-invalid-regexp + (archive--file-desc-ext-file-name + archive-subfile-mode))))) ;; An archive can contain another archive whose name is invalid ;; on local filesystem. Treat such archives as remote. @@ -728,16 +693,12 @@ archive. (string-match file-name-invalid-regexp (buffer-file-name))))) - (setq major-mode 'archive-mode) + (setq major-mode #'archive-mode) (setq mode-name (concat typename "-Archive")) ;; Run archive-foo-mode-hook and archive-mode-hook (run-mode-hooks (archive-name "mode-hook") 'archive-mode-hook) (use-local-map archive-mode-map)) - (make-local-variable 'archive-proper-file-start) - (make-local-variable 'archive-file-list-start) - (make-local-variable 'archive-file-list-end) - (make-local-variable 'archive-file-name-indent) (setq archive-file-name-coding-system (or file-name-coding-system default-file-name-coding-system @@ -803,7 +764,7 @@ when parsing the archive." (let ((create-lockfiles nil) ; avoid changing dir mtime by lock_file (inhibit-read-only t)) (setq archive-proper-file-start (copy-marker (point-min) t)) - (set (make-local-variable 'change-major-mode-hook) 'archive-desummarize) + (add-hook 'change-major-mode-hook #'archive-desummarize nil t) (or shut-up (message "Parsing archive file...")) (buffer-disable-undo (current-buffer)) @@ -825,27 +786,35 @@ when parsing the archive." (goto-char archive-file-list-start) (archive-next-line no))) +(cl-defstruct (archive--file-summary + (:constructor nil) + (:constructor archive--file-summary (text name-start name-end))) + text name-start name-end) + (defun archive-summarize-files (files) "Insert a description of a list of files annotated with proper mouse face." (setq archive-file-list-start (point-marker)) - (setq archive-file-name-indent (if files (aref (car files) 1) 0)) + ;; Here we assume that they all start at the same column. + (setq archive-file-name-indent + ;; FIXME: We assume chars=columns (no double-wide chars and such). + (if files (archive--file-summary-name-start (car files)) 0)) ;; We don't want to do an insert for each element since that takes too ;; long when the archive -- which has to be moved in memory -- is large. (insert - (apply - #'concat - (mapcar - (lambda (fil) - ;; Using `concat' here copies the text also, so we can add - ;; properties without problems. - (let ((text (concat (aref fil 0) "\n"))) - (add-text-properties - (aref fil 1) (aref fil 2) - '(mouse-face highlight - help-echo "mouse-2: extract this file into a buffer") - text) - text)) - files))) + (mapconcat + (lambda (fil) + ;; Using `concat' here copies the text also, so we can add + ;; properties without problems. + (let ((text (concat (archive--file-summary-text fil) "\n"))) + (add-text-properties + (archive--file-summary-name-start fil) + (archive--file-summary-name-end fil) + '(mouse-face highlight + help-echo "mouse-2: extract this file into a buffer") + text) + text)) + files + "")) (setq archive-file-list-end (point-marker))) (defun archive-alternate-display () @@ -854,7 +823,27 @@ To avoid very long lines archive mode does not show all information. This function changes the set of information shown for each files." (interactive) (setq archive-alternate-display (not archive-alternate-display)) + (setq-local archive-hidden-columns + (if archive-alternate-display + archive-alternate-hidden-columns + (eval (car (or (get 'archive-hidden-columns 'customized-value) + (get 'archive-hidden-columns 'standard-value))) + t))) (archive-resummarize)) + +(defun archive-hideshow-column (column) + "Toggle visibility of COLUMN." + (interactive + (list (intern + (completing-read "Toggle visibility of: " + '(Mode Ids Ratio Date&Time) + nil t)))) + (setq-local archive-hidden-columns + (if (memq column archive-hidden-columns) + (remove column archive-hidden-columns) + (cons column archive-hidden-columns))) + (archive-resummarize)) + ;; ------------------------------------------------------------------------- ;;; Section: Local archive copy handling @@ -899,7 +888,8 @@ using `make-temp-file', and the generated name is returned." ;; "foo.zip:bar.zip", which is invalid on DOS/Windows. ;; So use the actual name if available. (archive-name - (or (and archive-subfile-mode (aref archive-subfile-mode 0)) + (or (and archive-subfile-mode (archive--file-desc-ext-file-name + archive-subfile-mode)) archive))) (setq archive-local-name (archive-unique-fname archive-name archive-tmpdir)) @@ -918,6 +908,7 @@ using `make-temp-file', and the generated name is returned." (lno (archive-get-lineno)) (inhibit-read-only t)) (if unchanged nil + ;; FIXME: Use archive-resummarize? (setq archive-files nil) (erase-buffer) (insert-file-contents name) @@ -968,7 +959,7 @@ using `make-temp-file', and the generated name is returned." (delete-file tmpfile))))) (defun archive-file-name-handler (op &rest args) - (or (eq op 'file-exists-p) + (or (eq op #'file-exists-p) (let ((file-name-handler-alist nil)) (apply op args)))) @@ -1002,14 +993,83 @@ using `make-temp-file', and the generated name is returned." (kill-local-variable 'buffer-file-coding-system) (after-insert-file-set-coding (- (point-max) (point-min)))))) +(defun archive-goto-file (file) + "Go to FILE in the current buffer. +FILE should be a relative file name. If FILE can't be found, +return nil. Otherwise point is returned." + (let ((start (point)) + found) + (goto-char (point-min)) + (while (and (not found) + (not (eobp))) + (forward-line 1) + (when-let ((descr (archive-get-descr t))) + (when (equal (archive--file-desc-ext-file-name descr) file) + (setq found t)))) + (if (not found) + (progn + (goto-char start) + nil) + (point)))) + +(defun archive-next-file-displayer (file regexp n) + "Return a closure to display the next file after FILE that matches REGEXP." + (let ((short (replace-regexp-in-string "\\`.*:" "" file)) + next) + (archive-goto-file short) + (while (and (not next) + ;; Stop if we reach the end/start of the buffer. + (if (> n 0) + (not (eobp)) + (not (save-excursion + (beginning-of-line) + (bobp))))) + (archive-next-line n) + (when-let ((descr (archive-get-descr t))) + (let ((candidate (archive--file-desc-ext-file-name descr)) + (buffer (current-buffer))) + (when (and candidate + (string-match-p regexp candidate)) + (setq next (lambda () + (kill-buffer (current-buffer)) + (switch-to-buffer buffer) + (archive-extract))))))) + (unless next + ;; If we didn't find a next/prev file, then restore + ;; point. + (archive-goto-file short)) + next)) + +(defun archive-copy-file (file new-name) + "Copy FILE to a location specified by NEW-NAME. +Interactively, FILE is the file at point, and the function prompts +for NEW-NAME." + (interactive + (let ((name (archive--file-desc-ext-file-name (archive-get-descr)))) + (list name + (read-file-name (format "Copy %s to: " name))))) + (when (file-directory-p new-name) + (setq new-name (expand-file-name file new-name))) + (when (and (file-exists-p new-name) + (not (yes-or-no-p (format "%s already exists; overwrite? " + new-name)))) + (user-error "Not overwriting %s" new-name)) + (let* ((descr (archive-get-descr)) + (archive (buffer-file-name)) + (extractor (archive-name "extract")) + (ename (archive--file-desc-ext-file-name descr))) + (with-temp-buffer + (archive--extract-file extractor archive ename) + (write-region (point-min) (point-max) new-name)))) + (defun archive-extract (&optional other-window-p event) "In archive mode, extract this entry of the archive into its own buffer." (interactive (list nil last-input-event)) (if event (posn-set-point (event-end event))) (let* ((view-p (eq other-window-p 'view)) (descr (archive-get-descr)) - (ename (aref descr 0)) - (iname (aref descr 1)) + (ename (archive--file-desc-ext-file-name descr)) + (iname (archive--file-desc-int-file-name descr)) (archive-buffer (current-buffer)) (arcdir default-directory) (archive (buffer-file-name)) @@ -1038,32 +1098,12 @@ using `make-temp-file', and the generated name is returned." (abbreviate-file-name buffer-file-name)) ;; Set the default-directory to the dir of the superior buffer. (setq default-directory arcdir) - (make-local-variable 'archive-superior-buffer) - (setq archive-superior-buffer archive-buffer) + (setq-local archive-superior-buffer archive-buffer) (add-hook 'write-file-functions #'archive-write-file-member nil t) (setq archive-subfile-mode descr) (setq archive-file-name-coding-system file-name-coding) (if (and - (null - (let (;; We may have to encode the file name argument for - ;; external programs. - (coding-system-for-write - (and enable-multibyte-characters - archive-file-name-coding-system)) - ;; We read an archive member by no-conversion at - ;; first, then decode appropriately by calling - ;; archive-set-buffer-as-visiting-file later. - (coding-system-for-read 'no-conversion) - ;; Avoid changing dir mtime by lock_file - (create-lockfiles nil)) - (condition-case err - (if (fboundp extractor) - (funcall extractor archive ename) - (archive-*-extract archive ename - (symbol-value extractor))) - (error - (ding (message "%s" (error-message-string err))) - nil)))) + (null (archive--extract-file extractor archive ename)) just-created) (progn (set-buffer-modified-p nil) @@ -1096,6 +1136,27 @@ using `make-temp-file', and the generated name is returned." (other-window-p (switch-to-buffer-other-window buffer)) (t (switch-to-buffer buffer)))))) +(defun archive--extract-file (extractor archive ename) + (let (;; We may have to encode the file name argument for + ;; external programs. + (coding-system-for-write + (and enable-multibyte-characters + archive-file-name-coding-system)) + ;; We read an archive member by no-conversion at + ;; first, then decode appropriately by calling + ;; archive-set-buffer-as-visiting-file later. + (coding-system-for-read 'no-conversion) + ;; Avoid changing dir mtime by lock_file + (create-lockfiles nil)) + (condition-case err + (if (fboundp extractor) + (funcall extractor archive ename) + (archive-*-extract archive ename + (symbol-value extractor))) + (error + (ding (message "%s" (error-message-string err))) + nil)))) + (defun archive-*-extract (archive name command) (let* ((default-directory (file-name-as-directory archive-tmpdir)) (tmpfile (expand-file-name (file-name-nondirectory name) @@ -1253,7 +1314,7 @@ using `make-temp-file', and the generated name is returned." t) (defun archive-*-write-file-member (archive descr command) - (let* ((ename (aref descr 0)) + (let* ((ename (archive--file-desc-ext-file-name descr)) (tmpfile (expand-file-name ename archive-tmpdir)) (top (directory-file-name (file-name-as-directory archive-tmpdir))) (default-directory (file-name-as-directory top))) @@ -1270,9 +1331,10 @@ using `make-temp-file', and the generated name is returned." ;; further processing clobbers it (we restore it in ;; archive-write-file-member, above). (setq archive-member-coding-system last-coding-system-used) - (if (aref descr 3) + (if (archive--file-desc-mode descr) ;; Set the file modes, but make sure we can read it. - (set-file-modes tmpfile (logior ?\400 (aref descr 3)))) + (set-file-modes tmpfile + (logior ?\400 (archive--file-desc-mode descr)))) (setq ename (encode-coding-string ename archive-file-name-coding-system)) (let* ((coding-system-for-write 'no-conversion) @@ -1376,7 +1438,7 @@ Use \\[archive-unmark-all-files] to remove all marks." "Change the protection bits associated with all marked or this member. The new protection bits can either be specified as an octal number or as a relative change like \"g+rw\" as for chmod(2)." - (interactive "sNew mode (octal or relative): ") + (interactive "sNew mode (octal or symbolic): ") (if archive-read-only (error "Archive is read-only")) (let ((func (archive-name "chmod-entry"))) (if (fboundp func) @@ -1415,7 +1477,9 @@ as a relative change like \"g+rw\" as for chmod(2)." (goto-char archive-file-list-start) (while (< (point) archive-file-list-end) (if (= (following-char) ?D) - (setq files (cons (aref (archive-get-descr) 0) files))) + (setq files (cons (archive--file-desc-ext-file-name + (archive-get-descr)) + files))) (forward-line 1))) (setq files (nreverse files)) (and files @@ -1461,12 +1525,11 @@ as a relative change like \"g+rw\" as for chmod(2)." (error "Renaming is not supported for this archive type")))) ;; Revert the buffer and recompute the dired-like listing. -(defun archive-mode-revert (&optional _no-auto-save _no-confirm) +(defun archive--mode-revert (orig-fun &rest args) (let ((no (archive-get-lineno))) (setq archive-files nil) - (let ((revert-buffer-function nil) - (coding-system-for-read 'no-conversion)) - (revert-buffer t t)) + (let ((coding-system-for-read 'no-conversion)) + (apply orig-fun t t (cddr args))) (archive-mode) (goto-char archive-file-list-start) (archive-next-line no))) @@ -1477,15 +1540,135 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (interactive) (let ((inhibit-read-only t)) (undo))) + +(defun archive--fit (str len) + (let* ((spaces (- len (string-width str))) + (pre (/ spaces 2))) + (if (< spaces 1) + (substring str 0 len) + (concat (make-string pre ?\s) str (make-string (- spaces pre) ?\s))))) + +(defun archive--fit2 (str1 str2 len) + (let* ((spaces (- len (string-width str1) (string-width str2)))) + (if (< spaces 1) + (substring (concat str1 str2) 0 len) + (concat str1 (make-string spaces ?\s) str2)))) + +(defun archive--enabled-p (column) + (not (memq column archive-hidden-columns))) + +(defun archive--summarize-descs (descs) + (goto-char (point-min)) + (if (null descs) + (progn (insert "M ... Filename\n") + (insert "- ----- ---------------\n") + (archive-summarize-files nil) + (insert "- ----- ---------------\n")) + (let* ((sample (car descs)) + (maxsize 0) + (maxidlen 0) + (totalsize 0) + (times (archive--enabled-p 'Date&Time)) + (ids (and (archive--enabled-p 'Ids) + (or (archive--file-desc-uid sample) + (archive--file-desc-gid sample)))) + ;; For ratio, date/time, and mode, we presume that + ;; they're either present on all entries or on nonel, and that they + ;; take the same space on each of them. + (ratios (and (archive--enabled-p 'Ratio) + (archive--file-desc-ratio sample))) + (ratiolen (if ratios (string-width ratios))) + (timelen (length (archive--file-desc-time sample))) + (samplemode (and (archive--enabled-p 'Mode) + (archive--file-desc-mode sample))) + (modelen (length (if samplemode (file-modes-number-to-symbolic samplemode))))) + (dolist (desc descs) + (when ids + (let* ((uid (archive--file-desc-uid desc)) + (gid (archive--file-desc-uid desc)) + (len (cond + ((not uid) (string-width gid)) + ((not gid) (string-width uid)) + (t (+ (string-width uid) (string-width gid) 1))))) + (if (> len maxidlen) (setq maxidlen len)))) + (let ((size (archive--file-desc-size desc))) + (cl-incf totalsize size) + (if (> size maxsize) (setq maxsize size)))) + (let* ((sizelen (length (number-to-string maxsize))) + (dash + (concat + "- " + (if (> modelen 0) (concat (make-string modelen ?-) " ")) + (if ids (concat (make-string maxidlen ?-) " ")) + (make-string sizelen ?-) " " + (if ratios (concat (make-string (1+ ratiolen) ?-) " ")) + " " + (if times (concat (make-string timelen ?-) " ")) + "----------------\n")) + (startcol (+ 2 + (if (> modelen 0) (+ 2 modelen) 0) + (if ids (+ maxidlen 2) 0) + sizelen 2 + (if ratios (+ 2 ratiolen) 0) + (if times (+ timelen 2) 0)))) + (insert + (concat "M " + (if (> modelen 0) (concat (archive--fit "Mode" modelen) " ")) + (if ids (concat (archive--fit2 "Uid" "Gid" maxidlen) " ")) + (archive--fit "Size" sizelen) " " + (if ratios (concat (archive--fit "Cmp" (1+ ratiolen)) " ")) + " " + (if times (concat (archive--fit "Date&time" timelen) " ")) + " Filename\n")) + (insert dash) + (archive-summarize-files + (mapcar (lambda (desc) + (let* ((size (number-to-string + (archive--file-desc-size desc))) + (text + (concat " " + (when (> modelen 0) + (concat (file-modes-number-to-symbolic + (archive--file-desc-mode desc)) + " ")) + (when ids + (concat (archive--fit2 + (archive--file-desc-uid desc) + (archive--file-desc-gid desc) + maxidlen) " ")) + (make-string (- sizelen (length size)) ?\s) + size + " " + (when ratios + (concat (archive--file-desc-ratio desc) + "% ")) + " " + (when times + (concat (archive--file-desc-time desc) + " ")) + (archive--file-desc-int-file-name desc)))) + (archive--file-summary + text startcol (length text)))) + descs)) + (insert dash) + (insert (format (format "%%%dd %%s %%d files\n" + (+ 2 + (if (> modelen 0) (+ 2 modelen) 0) + (if ids (+ maxidlen 2) 0) + sizelen)) + totalsize + (make-string (+ (if times (+ 2 timelen) 0) + (if ratios (+ 2 ratiolen) 0) 1) + ?\s) + (length descs)))))) + (apply #'vector descs)) + ;; ------------------------------------------------------------------------- ;;; Section: Arc Archives (defun archive-arc-summarize () (let ((p 1) - (totalsize 0) - (maxlen 8) - files - visual) + files) (while (and (< (+ p 29) (point-max)) (= (get-byte p) ?\C-z) (> (get-byte (1+ p)) 0)) @@ -1498,48 +1681,28 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (modtime (archive-l-e (+ p 21) 2)) (ucsize (archive-l-e (+ p 25) 4)) (fiddle (string= efnname (upcase efnname))) - (ifnname (if fiddle (downcase efnname) efnname)) - (text (format " %8d %-11s %-8s %s" - ucsize - (archive-dosdate moddate) - (archive-dostime modtime) - ifnname))) - (setq maxlen (max maxlen fnlen) - totalsize (+ totalsize ucsize) - visual (cons (vector text - (- (length text) (length ifnname)) - (length text)) - visual) - files (cons (vector efnname ifnname fiddle nil (1- p)) + (ifnname (if fiddle (downcase efnname) efnname))) + (setq files (cons (archive--file-desc + efnname ifnname nil ucsize + (concat (archive-dosdate moddate) + " " (archive-dostime modtime)) + :pos (1- p)) files) p (+ p 29 csize)))) - (goto-char (point-min)) - (let ((dash (concat "- -------- ----------- -------- " - (make-string maxlen ?-) - "\n"))) - (insert "M Length Date Time File\n" - dash) - (archive-summarize-files (nreverse visual)) - (insert dash - (format " %8d %d file%s" - totalsize - (length files) - (if (= 1 (length files)) "" "s")) - "\n")) - (apply #'vector (nreverse files)))) + (archive--summarize-descs (nreverse files)))) (defun archive-arc-rename-entry (newname descr) (if (string-match "[:\\/]" newname) (error "File names in arc files must not contain a directory component")) (if (> (length newname) 12) (error "File names in arc files are limited to 12 characters")) - (let ((name (concat newname (substring "\0\0\0\0\0\0\0\0\0\0\0\0\0" - (length newname)))) + (let ((name (concat newname (make-string (- 13 (length newname)) ?\0))) (inhibit-read-only t)) (save-restriction (save-excursion (widen) - (goto-char (+ archive-proper-file-start (aref descr 4) 2)) + (goto-char (+ archive-proper-file-start 2 + (archive--file-desc-pos descr))) (delete-char 13) (arc-insert-unibyte name))))) ;; ------------------------------------------------------------------------- @@ -1547,10 +1710,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (defun archive-lzh-summarize (&optional start) (let ((p (or start 1)) ;; 1 for .lzh, something further on for .exe - (totalsize 0) - (maxlen 8) - files - visual) + files) (while (progn (goto-char p) ;beginning of a base header. (looking-at "\\(.\\|\n\\)\\(.\\|\n\\)-l[hz][0-9ds]-")) (let* ((hsize (get-byte p)) ;size of the base header (level 0 and 1) @@ -1561,9 +1721,9 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (time2 (archive-l-e (+ p 17) 2)) ;and UNIX format in level 2 header.) (hdrlvl (get-byte (+ p 20))) ;header level thsize ;total header size (base + extensions) - fnlen efnname osid fiddle ifnname width p2 + fnlen efnname osid fiddle ifnname p2 neh ;beginning of next extension header (level 1 and 2) - mode modestr uid gid text dir prname + mode uid gid dir prname gname uname modtime moddate) (if (= hdrlvl 3) (error "can't handle lzh level 3 header type")) (when (or (= hdrlvl 0) (= hdrlvl 1)) @@ -1576,26 +1736,26 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (setq neh (+ p2 3)) ;specific to level 1 header (if (= hdrlvl 2) (setq neh (+ p 24)))) ;specific to level 2 header - (if neh ;if level 1 or 2 we expect extension headers to follow + (if neh ;if level 1 or 2 we expect extension headers to follow (let* ((ehsize (archive-l-e neh 2)) ;size of the extension header (etype (get-byte (+ neh 2)))) ;extension type (while (not (= ehsize 0)) - (cond - ((= etype 1) ;file name + (cond + ((= etype 1) ;file name (let ((i (+ neh 3))) (while (< i (+ neh ehsize)) (setq efnname (concat efnname (char-to-string (get-byte i)))) (setq i (1+ i))))) - ((= etype 2) ;directory name + ((= etype 2) ;directory name (let ((i (+ neh 3))) (while (< i (+ neh ehsize)) - (setq dir (concat dir - (if (= (get-byte i) - 255) - "/" - (char-to-string - (char-after i))))) - (setq i (1+ i))))) + (setq dir (concat dir + (if (= (get-byte i) + 255) + "/" + (char-to-string + (char-after i))))) + (setq i (1+ i))))) ((= etype 80) ;Unix file permission (setq mode (archive-l-e (+ neh 3) 2))) ((= etype 81) ;UNIX file group/user ID @@ -1611,7 +1771,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (while (< i (+ neh ehsize)) (setq uname (concat uname (char-to-string (char-after i)))) (setq i (1+ i))))) - ) + ) (setq neh (+ neh ehsize)) (setq ehsize (archive-l-e neh 2)) (setq etype (get-byte (+ neh 2)))) @@ -1637,60 +1797,25 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." ((= 0 osid) (string= efnname (upcase efnname))))) (setq ifnname (if fiddle (downcase efnname) efnname)) (setq prname (if dir (concat dir ifnname) ifnname)) - (setq width (if prname (string-width prname) 0)) - (setq modestr (if mode (archive-int-to-mode mode) "??????????")) (setq moddate (if (= hdrlvl 2) (archive-unixdate time1 time2) ;level 2 header in UNIX format (archive-dosdate time2))) ;level 0 and 1 header in DOS format (setq modtime (if (= hdrlvl 2) (archive-unixtime time1 time2) (archive-dostime time1))) - (setq text (if archive-alternate-display - (format " %8d %5S %5S %s" - ucsize - (or uid "?") - (or gid "?") - ifnname) - (format " %10s %8d %-11s %-8s %s" - modestr - ucsize - moddate - modtime - prname))) - (setq maxlen (max maxlen width) - totalsize (+ totalsize ucsize) - visual (cons (vector text - (- (length text) (length prname)) - (length text)) - visual) - files (cons (vector prname ifnname fiddle mode (1- p)) - files)) + (push (archive--file-desc + prname ifnname mode ucsize + (concat moddate " " modtime) + :pos (1- p) + :uid (or uname (if uid (number-to-string uid))) + :gid (or gname (if gid (number-to-string gid)))) + files) (cond ((= hdrlvl 1) (setq p (+ p hsize 2 csize))) ((or (= hdrlvl 2) (= hdrlvl 0)) (setq p (+ p thsize 2 csize)))) )) - (goto-char (point-min)) - (let ((dash (concat (if archive-alternate-display - "- -------- ----- ----- " - "- ---------- -------- ----------- -------- ") - (make-string maxlen ?-) - "\n")) - (header (if archive-alternate-display - "M Length Uid Gid File\n" - "M Filemode Length Date Time File\n")) - (sumline (if archive-alternate-display - " %8.0f %d file%s" - " %8.0f %d file%s"))) - (insert header dash) - (archive-summarize-files (nreverse visual)) - (insert dash - (format sumline - totalsize - (length files) - (if (= 1 (length files)) "" "s")) - "\n")) - (apply #'vector (nreverse files)))) + (archive--summarize-descs (nreverse files)))) (defconst archive-lzh-alternate-display t) @@ -1709,7 +1834,8 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (save-restriction (save-excursion (widen) - (let* ((p (+ archive-proper-file-start (aref descr 4))) + (let* ((p (+ archive-proper-file-start + (archive--file-desc-pos descr))) (oldhsize (get-byte p)) (oldfnlen (get-byte (+ p 21))) (newfnlen (length newname)) @@ -1729,7 +1855,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (save-restriction (widen) (dolist (fil files) - (let* ((p (+ archive-proper-file-start (aref fil 4))) + (let* ((p (+ archive-proper-file-start (archive--file-desc-pos fil))) (hsize (get-byte p)) (fnlen (get-byte (+ p 21))) (p2 (+ p 22 fnlen)) @@ -1746,7 +1872,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (delete-char 1) (arc-insert-unibyte (archive-lzh-resum (1+ p) hsize))) (message "Member %s does not have %s field" - (aref fil 1) errtxt))))))) + (archive--file-desc-int-file-name fil) errtxt))))))) (defun archive-lzh-chown-entry (newuid files) (archive-lzh-ogm newuid files "an uid" 10)) @@ -1756,8 +1882,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (defun archive-lzh-chmod-entry (newmode files) (archive-lzh-ogm - ;; This should work even though newmode will be dynamically accessed. - (lambda (old) (archive-calc-mode old newmode t)) + (lambda (old) (archive-calc-mode old newmode)) files "a unix-style mode" 8)) ;; ------------------------------------------------------------------------- @@ -1794,11 +1919,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (goto-char (- (point-max) (- 22 18))) (search-backward-regexp "[P]K\005\006") (let ((p (archive-l-e (+ (point) 16) 4)) - (maxlen 8) - (totalsize 0) - files - visual - emacs-int-has-32bits) + files) (when (or (= p #xffffffff) (= p -1)) ;; If the offset of end-of-central-directory is 0xFFFFFFFF, this ;; is a Zip64 extended ZIP file format, and we need to glean the @@ -1824,7 +1945,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (fnlen (archive-l-e (+ p 28) 2)) (exlen (archive-l-e (+ p 30) 2)) (fclen (archive-l-e (+ p 32) 2)) - (lheader (archive-l-e (+ p 42) 4)) + ;; (lheader (archive-l-e (+ p 42) 4)) (efnname (let ((str (buffer-substring (+ p 46) (+ p 46 fnlen)))) (decode-coding-string str archive-file-name-coding-system))) @@ -1848,44 +1969,18 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (logand 1 (get-byte (+ p 38)))) ?\222 0))) (t nil))) - (modestr (if mode (archive-int-to-mode mode) "??????????")) (fiddle (and archive-zip-case-fiddle - (not (not (memq creator '(0 2 4 5 9)))) + (memq creator '(0 2 4 5 9)) (string= (upcase efnname) efnname))) - (ifnname (if fiddle (downcase efnname) efnname)) - (width (string-width ifnname)) - (text (format " %10s %8d %-11s %-8s %s" - modestr - ucsize - (archive-dosdate moddate) - (archive-dostime modtime) - ifnname))) - (setq maxlen (max maxlen width) - totalsize (+ totalsize ucsize) - visual (cons (vector text - (- (length text) (length ifnname)) - (length text)) - visual) - files (cons (if isdir - nil - (vector efnname ifnname fiddle mode - (list (1- p) lheader))) - files) + (ifnname (if fiddle (downcase efnname) efnname))) + (setq files (cons (archive--file-desc + efnname ifnname mode ucsize + (concat (archive-dosdate moddate) + " " (archive-dostime modtime)) + :pos (1- p)) + files) p (+ p 46 fnlen exlen fclen)))) - (goto-char (point-min)) - (let ((dash (concat "- ---------- -------- ----------- -------- " - (make-string maxlen ?-) - "\n"))) - (insert "M Filemode Length Date Time File\n" - dash) - (archive-summarize-files (nreverse visual)) - (insert dash - (format " %8d %d file%s" - totalsize - (length files) - (if (= 1 (length files)) "" "s")) - "\n")) - (apply #'vector (nreverse files)))) + (archive--summarize-descs (nreverse files)))) (defun archive-zip-extract (archive name) (cond @@ -1910,21 +2005,27 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." name) archive-zip-extract)))) +(defun archive--file-desc-case-fiddled (fd) + (not (eq (archive--file-desc-int-file-name fd) + (archive--file-desc-ext-file-name fd)))) + (defun archive-zip-write-file-member (archive descr) (archive-*-write-file-member archive descr - (if (aref descr 2) archive-zip-update-case archive-zip-update))) + (if (archive--file-desc-case-fiddled descr) + archive-zip-update-case archive-zip-update))) (defun archive-zip-chmod-entry (newmode files) (save-restriction (save-excursion (widen) (dolist (fil files) - (let* ((p (+ archive-proper-file-start (car (aref fil 4)))) + (let* ((p (+ archive-proper-file-start + (archive--file-desc-pos fil))) (creator (get-byte (+ p 5))) - (oldmode (aref fil 3)) - (newval (archive-calc-mode oldmode newmode t)) + (oldmode (archive--file-desc-mode fil)) + (newval (archive-calc-mode oldmode newmode)) (inhibit-read-only t)) (cond ((memq creator '(2 3)) ; Unix (goto-char (+ p 40)) @@ -1943,10 +2044,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (defun archive-zoo-summarize () (let ((p (1+ (archive-l-e 25 4))) - (maxlen 8) - (totalsize 0) - files - visual) + files) (while (and (string= "\334\247\304\375" (buffer-substring p (+ p 4))) (> (archive-l-e (+ p 6) 4) 0)) (let* ((next (1+ (archive-l-e (+ p 6) 4))) @@ -1973,36 +2071,14 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (decode-coding-string str archive-file-name-coding-system))) (fiddle (and (= lfnlen 0) (string= efnname (upcase efnname)))) - (ifnname (if fiddle (downcase efnname) efnname)) - (width (string-width ifnname)) - (text (format " %8d %-11s %-8s %s" - ucsize - (archive-dosdate moddate) - (archive-dostime modtime) - ifnname))) - (setq maxlen (max maxlen width) - totalsize (+ totalsize ucsize) - visual (cons (vector text - (- (length text) (length ifnname)) - (length text)) - visual) - files (cons (vector efnname ifnname fiddle nil (1- p)) + (ifnname (if fiddle (downcase efnname) efnname))) + (setq files (cons (archive--file-desc + efnname ifnname nil ucsize + (concat (archive-dosdate moddate) + " " (archive-dostime modtime))) files) p next))) - (goto-char (point-min)) - (let ((dash (concat "- -------- ----------- -------- " - (make-string maxlen ?-) - "\n"))) - (insert "M Length Date Time File\n" - dash) - (archive-summarize-files (nreverse visual)) - (insert dash - (format " %8d %d file%s" - totalsize - (length files) - (if (= 1 (length files)) "" "s")) - "\n")) - (apply #'vector (nreverse files)))) + (archive--summarize-descs (nreverse files)))) (defun archive-zoo-extract (archive name) (archive-extract-by-stdout archive name archive-zoo-extract)) @@ -2014,17 +2090,16 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." ;; 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 "lsar" nil t nil "-l" (or file copy)) - (if copy (delete-file copy)) + (unwind-protect + (call-process "lsar" nil t nil "-l" (or file copy)) + (if copy (delete-file copy))) (goto-char (point-min)) - (re-search-forward "^\\(\s+=+\s*\\)+\n") + (re-search-forward "^\\(?:\s+=+\\)+\s*\n") (while (looking-at (concat "^\s+[0-9.]+\s+D?-+\s+" ; Flags "\\([0-9-]+\\)\s+" ; Size - "\\([-0-9.%]+\\)\s+" ; Ratio + "\\([-0-9.]+\\)%?\s+" ; Ratio "\\([0-9a-zA-Z]+\\)\s+" ; Mode "\\([0-9-]+\\)\s+" ; Date "\\([0-9:]+\\)\s+" ; Time @@ -2033,36 +2108,14 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (goto-char (match-end 0)) (let ((name (match-string 6)) (size (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 - ;; Size, Ratio. - size (match-string 2) - ;; Date, Time. - (match-string 4) (match-string 5)) + (push (archive--file-desc name name nil + ;; Size + (string-to-number size) + ;; Date&Time. + (concat (match-string 4) " " (match-string 5)) + :ratio (match-string 2)) 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)))) + (archive--summarize-descs (nreverse files)))) (defun archive-rar-extract (archive name) ;; unrar-free seems to have no way to extract to stdout or even to a file. @@ -2109,9 +2162,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." ;;; Section: 7z Archives (defun archive-7z-summarize () - (let ((maxname 10) - (maxsize 5) - (file buffer-file-name) + (let ((file buffer-file-name) (files ())) (with-temp-buffer (call-process archive-7z-program nil t nil "l" "-slt" file) @@ -2128,29 +2179,9 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (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) + (push (archive--file-desc name name nil (string-to-number size) time) 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)))) + (archive--summarize-descs (nreverse files)))) (defun archive-7z-extract (archive name) ;; 7z doesn't provide a `quiet' option to suppress non-essential @@ -2177,79 +2208,43 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (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--name (name) + "Return the external name represented by the entry NAME. +NAME is expected to be the 16-bytes part of an ar record." + (cond ((equal name "// ") + (propertize ".<ExtNamesTable>." 'face 'italic)) + ((equal name "/ ") + (propertize ".<LookupTable>." 'face 'italic)) + ((string-match "/? *\\'" name) + ;; FIXME: Decode? Add support for longer names? + (substring name 0 (match-beginning 0))))) + (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 ())) + (let* ((files ())) (goto-char (point-min)) (search-forward "!<arch>\n") (while (looking-at archive-ar-file-header-re) - (let ((name (match-string 1)) - extname - (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)))) + (let* ((name (match-string 1)) + extname + (time (string-to-number (match-string 2))) + (user (match-string 3)) + (group (match-string 4)) + (mode (string-to-number (match-string 5) 8)) + (sizestr (match-string 6)) + (size (string-to-number sizestr))) ;; Move to the beginning of the data. (goto-char (match-end 0)) (setq time (format-time-string "%Y-%m-%d %H:%M" time)) - (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 extname (archive-ar--name 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 extname nil mode - time user group size) + (push (archive--file-desc extname extname mode size time + :uid user :gid group) 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)))) + (archive--summarize-descs (nreverse files)))) (defun archive-ar-extract (archive name) (let ((destbuf (current-buffer)) @@ -2266,10 +2261,11 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (let ((this (match-string 1))) (setq size (string-to-number (match-string 6))) (goto-char (match-end 0)) - (if (equal name this) + (if (equal name (archive-ar--name this)) (setq from (point)) ;; Move to the end of the data. - (forward-char size) (if (eq ?\n (char-after)) (forward-char 1))))) + (forward-char size) + (if (eq ?\n (char-after)) (forward-char 1))))) (when from (set-buffer-multibyte nil) (with-current-buffer destbuf @@ -2279,6 +2275,13 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." ;; Inform the caller that the call succeeded. t)))))) +(defun archive-ar-write-file-member (archive descr) + (archive-*-write-file-member + archive + descr + '("ar" "r"))) + + ;; ------------------------------------------------------------------------- ;; This line was a mistake; it is kept now for compatibility. ;; rms 15 Oct 98 |