X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/6eb236e7193583a15d1b0154f5ca078cfab29ed9..beb402deed11deee9fdaddb986cc7c51c14082d0:/lisp/arc-mode.el diff --git a/lisp/arc-mode.el b/lisp/arc-mode.el index b31a59fbab..2c2569bb97 100644 --- a/lisp/arc-mode.el +++ b/lisp/arc-mode.el @@ -1,29 +1,30 @@ ;;; arc-mode.el --- simple editing of archives -;;; Copyright (C) 1995 Free Software Foundation, Inc. +;; Copyright (C) 1995, 1997, 1998, 2003 Free Software Foundation, Inc. -;; Author: Morten Welinder (terra@diku.dk) +;; Author: Morten Welinder ;; Keywords: archives msdog editing major-mode ;; Favourite-brand-of-beer: None, I hate beer. -;;; This file is part of GNU Emacs. -;;; -;;; 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 2, 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 -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with GNU Emacs; see the file COPYING. If not, write to -;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; This file is part of GNU Emacs. + +;; 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 2, 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 +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Commentary: -;; + ;; NAMING: "arc" is short for "archive" and does not refer specifically ;; to files whose name end in ".arc" ;; @@ -76,6 +77,12 @@ ;; ;; LZH A series of (header,file). Headers are checksummed. No ;; interaction among members. +;; Headers come in three flavours called level 0, 1 and 2 headers. +;; Level 2 header is free of DOS specific restrictions and most +;; prevalently used. Also level 1 and 2 headers consist of base +;; and extension headers. For more details see +;; http://homepage1.nifty.com/dangan/en/Content/Program/Java/jLHA/Notes/Notes.html +;; http://www.osirusoft.com/joejared/lzhformat.html ;; ;; ZIP A series of (lheader,fil) followed by a "central directory" ;; which is a series of (cheader) followed by an end-of- @@ -87,7 +94,7 @@ ;; Each member header points to the next. The archive is ;; terminated by a bogus header with a zero next link. ;; ------------------------------------- -;; HOOKS: `foo' means one the the supported archive types. +;; HOOKS: `foo' means one of the supported archive types. ;; ;; archive-mode-hook ;; archive-foo-mode-hook @@ -98,155 +105,257 @@ ;; ------------------------------------------------------------------------- ;; Section: Configuration. -(defvar archive-dos-members t - "*If non-nil then recognize member files using ^M^J as line terminator -and do The Right Thing.") - -(defvar archive-tmpdir - (expand-file-name - (make-temp-name (if (eq system-type 'ms-dos) "ar" "archive.tmp")) - (or (getenv "TMPDIR") (getenv "TMP") "/tmp")) - "*Directory for temporary files made by arc-mode.el") - -(defvar archive-remote-regexp "^/[^/:]*[^/:.]:" - "*Regexp recognizing archive files names that are not local (i.e., are -not proper file names outside Emacs). A local copy a the archive will -be used when updating.") - -(defvar archive-extract-hooks nil - "*Hooks to run when an archive member has been extracted.") +(defgroup archive nil + "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. + (make-temp-name + (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) + +(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) + +(defcustom archive-extract-hooks nil + "*Hooks to run when an archive member has been extracted." + :type 'hook + :group 'archive) ;; ------------------------------ ;; 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. -(defvar archive-arc-extract +(defcustom archive-arc-extract '("arc" "x") - "*Program and its options to run in order to extract an arc file member -to the current directory. Archive and member name will be added.") - -(defvar archive-arc-expunge + "*Program and its options to run in order to extract an arc file member. +Extraction should happen to the current directory. Archive and member +name will be added." + :type '(list (string :tag "Program") + (repeat :tag "Options" + :inline t + (string :format "%v"))) + :group 'archive-arc) + +(defcustom archive-arc-expunge '("arc" "d") "*Program and its options to run in order to delete arc file members. -Archive and member names will be added.") - -(defvar archive-arc-write-file-member +Archive and member names will be added." + :type '(list (string :tag "Program") + (repeat :tag "Options" + :inline t + (string :format "%v"))) + :group 'archive-arc) + +(defcustom archive-arc-write-file-member '("arc" "u") "*Program and its options to run in order to update an arc file member. -Archive and member name will be added.") +Archive and member name will be added." + :type '(list (string :tag "Program") + (repeat :tag "Options" + :inline t + (string :format "%v"))) + :group 'archive-arc) ;; ------------------------------ ;; Lzh archive configuration -(defvar archive-lzh-extract +(defcustom archive-lzh-extract '("lha" "pq") - "*Program and its options to run in order to extract an lzh file member -to standard output. Archive and member name will be added.") - -(defvar archive-lzh-expunge + "*Program and its options to run in order to extract an lzh 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-lzh) + +(defcustom archive-lzh-expunge '("lha" "d") "*Program and its options to run in order to delete lzh file members. -Archive and member names will be added.") - -(defvar archive-lzh-write-file-member +Archive and member names will be added." + :type '(list (string :tag "Program") + (repeat :tag "Options" + :inline t + (string :format "%v"))) + :group 'archive-lzh) + +(defcustom archive-lzh-write-file-member '("lha" "a") "*Program and its options to run in order to update an lzh file member. -Archive and member name will be added.") +Archive and member name will be added." + :type '(list (string :tag "Program") + (repeat :tag "Options" + :inline t + (string :format "%v"))) + :group 'archive-lzh) ;; ------------------------------ ;; Zip archive configuration -(defvar archive-zip-use-pkzip (memq system-type '(ms-dos windows-nt)) - "*If non-nil then all zip options default to values suitable when using -pkzip and pkunzip. Only set to true for msdog systems!") - -(defvar archive-zip-extract - (if archive-zip-use-pkzip '("pkunzip" "-e") '("unzip" "-qq" "-c")) - "*Program and its options to run in order to extract a zip file member -to standard output. Archive and member name will be added.\n -If `archive-zip-use-pkzip' is non-nil then this program is expected to -extract to a file junking the directory part of the name.") - -;; For several reasons the latter behaviour is not desireable in general. +(defcustom archive-zip-extract + (if (locate-file "unzip" nil 'file-executable-p) + '("unzip" "-qq" "-c") + (if (locate-file "pkunzip" nil 'file-executable-p) + '("pkunzip" "-e" "-o-") + '("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. If `archive-zip-use-pkzip' is non-nil then this program is +expected to extract to a file junking the directory part of the name." + :type '(list (string :tag "Program") + (repeat :tag "Options" + :inline t + (string :format "%v"))) + :group 'archive-zip) + +;; For several reasons the latter behaviour is not desirable in general. ;; (1) It uses more disk space. (2) Error checking is worse or non- ;; existent. (3) It tends to do funny things with other systems' file ;; names. -(defvar archive-zip-expunge - (if archive-zip-use-pkzip '("pkzip" "-d") '("zip" "-d" "-q")) +(defcustom archive-zip-expunge + (if (locate-file "zip" nil 'file-executable-p) + '("zip" "-d" "-q") + (if (locate-file "pkzip" nil 'file-executable-p) + '("pkzip" "-d") + '("zip" "-d" "-q"))) "*Program and its options to run in order to delete zip file members. -Archive and member names will be added.") - -(defvar archive-zip-update - (if archive-zip-use-pkzip '("pkzip" "-u") '("zip" "-q")) +Archive and member names will be added." + :type '(list (string :tag "Program") + (repeat :tag "Options" + :inline t + (string :format "%v"))) + :group 'archive-zip) + +(defcustom archive-zip-update + (if (locate-file "zip" nil 'file-executable-p) + '("zip" "-q") + (if (locate-file "pkzip" nil 'file-executable-p) + '("pkzip" "-u" "-P") + '("zip" "-q"))) "*Program and its options to run in order to update a zip file member. Options should ensure that specified directory will be put into the zip -file. Archive and member name will be added.") - -(defvar archive-zip-update-case - (if archive-zip-use-pkzip archive-zip-update '("zip" "-q" "-k")) - "*Program and its options to run in order to update a case fiddled -zip file member. Options should ensure that specified directory will -be put into the zip file. Archive and member name will be added.") - -(defvar archive-zip-case-fiddle t - "*If non-nil then zip file members are mapped to lower case if created -by a system that under single case file names.") +file. Archive and member name will be added." + :type '(list (string :tag "Program") + (repeat :tag "Options" + :inline t + (string :format "%v"))) + :group 'archive-zip) + +(defcustom archive-zip-update-case + (if (locate-file "zip" nil 'file-executable-p) + '("zip" "-q" "-k") + (if (locate-file "pkzip" nil 'file-executable-p) + '("pkzip" "-u" "-P") + '("zip" "-q" "-k"))) + "*Program and its options to run in order to update a case fiddled zip member. +Options should ensure that specified directory will be put into the zip file. +Archive and member name will be added." + :type '(list (string :tag "Program") + (repeat :tag "Options" + :inline t + (string :format "%v"))) + :group 'archive-zip) + +(defcustom archive-zip-case-fiddle t + "*If non-nil then zip file members may be down-cased. +This case fiddling will only happen for members created by a system +that uses caseless file names." + :type 'boolean + :group 'archive-zip) ;; ------------------------------ ;; Zoo archive configuration -(defvar archive-zoo-extract +(defcustom archive-zoo-extract '("zoo" "xpq") - "*Program and its options to run in order to extract a zoo file member -to standard output. Archive and member name will be added.") - -(defvar archive-zoo-expunge + "*Program and its options to run in order to extract a zoo 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-zoo) + +(defcustom archive-zoo-expunge '("zoo" "DqPP") "*Program and its options to run in order to delete zoo file members. -Archive and member names will be added.") - -(defvar archive-zoo-write-file-member +Archive and member names will be added." + :type '(list (string :tag "Program") + (repeat :tag "Options" + :inline t + (string :format "%v"))) + :group 'archive-zoo) + +(defcustom archive-zoo-write-file-member '("zoo" "a") "*Program and its options to run in order to update a zoo file member. -Archive and member name will be added.") +Archive and member name will be added." + :type '(list (string :tag "Program") + (repeat :tag "Options" + :inline t + (string :format "%v"))) + :group 'archive-zoo) ;; ------------------------------------------------------------------------- ;; 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 archive-read-only nil "*Non-nil if the archive is read-only on disk.") -(defvar archive-remote nil "*Non-nil if the archive is outside file system.") -(defvar archive-local-name nil "*Name of local copy of remote archive.") -(defvar archive-mode-map nil "*Local keymap for archive mode listings.") -(defvar archive-file-name-indent nil "*Column where file names start.") +(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 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 archive-mode-map nil "Local keymap for archive mode listings.") +(defvar 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) +(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 archive-alternate-display nil - "*Non-nil when alternate information is shown.") + "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.") +(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.") +(defvar archive-subfile-mode nil "Non-nil in archive member buffers.") (make-variable-buffer-local 'archive-subfile-mode) (put 'archive-subfile-mode 'permanent-local t) -;; buffer-file-type is a per-buffer variable in the msdog configuration -(if (boundp 'buffer-file-type) nil - (defvar buffer-file-type nil - "*Nil for dos-style text file, non-nil otherwise.") - (make-variable-buffer-local 'buffer-file-type) - (put 'buffer-file-type 'permanent-local t) - (setq-default buffer-file-type nil)) - -(defvar archive-subfile-dos nil - "Negation of `buffer-file-type' which see.") -(make-variable-buffer-local 'archive-subfile-dos) -(put 'archive-subfile-dos 'permanent-local t) - -(defvar archive-files nil "Vector of file descriptors. Each descriptor is -a vector of [ext-file-name int-file-name case-fiddled mode ...]") +(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) (defvar archive-lemacs @@ -259,9 +368,9 @@ a vector of [ext-file-name int-file-name case-fiddled mode ...]") (intern (concat "archive-" (symbol-name archive-subtype) "-" suffix))) (defun archive-l-e (str &optional len) - "Convert little endian string/vector to integer. Alternatively, first -argument may be a buffer position in the current buffer in which case a -second arguemnt, length, should be supplied." + "Convert little endian string/vector to integer. +Alternatively, first argument may be a buffer position in the current buffer +in which case a second argument, length, should be supplied." (if (stringp str) (setq len (length str)) (setq str (buffer-substring str (+ str len)))) @@ -273,28 +382,28 @@ second arguemnt, length, should be supplied." result)) (defun archive-int-to-mode (mode) - "Turn an integer like 0700 (i.e., 448) into a mode string like -rwx------" - (let ((str (make-string 10 ?-))) - (or (zerop (logand 16384 mode)) (aset str 0 ?d)) - (or (zerop (logand 8192 mode)) (aset str 0 ?c)) ; completeness - (or (zerop (logand 256 mode)) (aset str 1 ?r)) - (or (zerop (logand 128 mode)) (aset str 2 ?w)) - (or (zerop (logand 64 mode)) (aset str 3 ?x)) - (or (zerop (logand 32 mode)) (aset str 4 ?r)) - (or (zerop (logand 16 mode)) (aset str 5 ?w)) - (or (zerop (logand 8 mode)) (aset str 6 ?x)) - (or (zerop (logand 4 mode)) (aset str 7 ?r)) - (or (zerop (logand 2 mode)) (aset str 8 ?w)) - (or (zerop (logand 1 mode)) (aset str 9 ?x)) - (or (zerop (logand 1024 mode)) (aset str 3 (if (zerop (logand 64 mode)) - ?S ?s))) - (or (zerop (logand 2048 mode)) (aset str 6 (if (zerop (logand 8 mode)) - ?S ?s))) - str)) + "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 1024 mode)) ?- ?S) + (if (zerop (logand 1024 mode)) ?x ?s)) + (if (zerop (logand 32 mode)) ?- ?r) + (if (zerop (logand 16 mode)) ?- ?w) + (if (zerop (logand 8 mode)) + (if (zerop (logand 2048 mode)) ?- ?S) + (if (zerop (logand 2048 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) - "From the integer OLDMODE and the string NEWMODE calculate a new file -mode.\n + "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 @@ -356,22 +465,22 @@ the mode is invalid. If ERROR is nil then nil will be returned." (defun archive-dostime (time) "Stringify dos packed TIME record." (let ((hour (logand (ash time -11) 31)) - (minute (logand (ash time -5) 53)) + (minute (logand (ash time -5) 63)) (second (* 2 (logand time 31)))) ; 2 seconds resolution (format "%02d:%02d:%02d" hour minute second))) -;;(defun archive-unixdate (low high) -;; "Stringify unix (LOW HIGH) date." -;; (let ((str (current-time-string (cons high low)))) -;; (format "%s-%s-%s" -;; (substring str 8 9) -;; (substring str 4 7) -;; (substring str 20 24)))) +(defun archive-unixdate (low high) + "Stringify unix (LOW HIGH) date." + (let ((str (current-time-string (cons high low)))) + (format "%s-%s-%s" + (substring str 8 10) + (substring str 4 7) + (substring str 20 24)))) -;;(defun archive-unixtime (low high) -;; "Stringify unix (LOW HIGH) time." -;; (let ((str (current-time-string (cons high low)))) -;; (substring str 11 19))) +(defun archive-unixtime (low high) + "Stringify unix (LOW HIGH) time." + (let ((str (current-time-string (cons high low)))) + (substring str 11 19))) (defun archive-get-lineno () (if (>= (point) archive-file-list-start) @@ -380,8 +489,8 @@ the mode is invalid. If ERROR is nil then nil will be returned." 0)) (defun archive-get-descr (&optional noerror) - "Return the descriptor vector for file at point. Do not signal an error -if optional second argument NOERROR is non-nil." + "Return the descriptor vector for file at point. +Does not signal an error if optional second argument NOERROR is non-nil." (let ((no (archive-get-lineno))) (if (and (>= (point) archive-file-list-start) (< no (length archive-files))) @@ -397,8 +506,8 @@ if optional second argument NOERROR is non-nil." ;;;###autoload (defun archive-mode (&optional force) - "Major mode for viewing an archive file as a dired-like listing of its -contents. You can move around using the usual cursor motion commands. + "Major mode for viewing an archive file in a dired-like way. +You can move around using the usual cursor motion commands. Letters no longer insert themselves. Type `e' to pull a file out of the archive and into its own buffer; or click mouse-2 on the file's line in the archive mode buffer. @@ -415,8 +524,7 @@ archive. (funcall default-major-mode) (if (and (not force) archive-files) nil (let* ((type (archive-find-type)) - (typename (copy-sequence (symbol-name type)))) - (aset typename 0 (upcase (aref typename 0))) + (typename (capitalize (symbol-name type)))) (kill-all-local-variables) (make-local-variable 'archive-subtype) (setq archive-subtype type) @@ -425,24 +533,40 @@ archive. (make-local-variable 'revert-buffer-function) (setq revert-buffer-function 'archive-mode-revert) (auto-save-mode 0) - (make-local-variable 'local-write-file-hooks) - (add-hook 'local-write-file-hooks 'archive-write-file) - ;; Real file contents is binary + ;; Remote archives are not written by a hook. + (if archive-remote nil + (make-local-variable 'write-contents-hooks) + (add-hook 'write-contents-hooks 'archive-write-file)) + (make-local-variable 'require-final-newline) (setq require-final-newline nil) - (make-local-variable 'enable-local-variables) - (setq enable-local-variables nil) - (setq buffer-file-type t) + (make-local-variable 'local-enable-local-variables) + (setq local-enable-local-variables nil) + + ;; Prevent loss of data when saving the file. + (make-local-variable 'file-precious-flag) + (setq file-precious-flag t) (make-local-variable 'archive-read-only) - (setq archive-read-only (not (file-writable-p (buffer-file-name)))) + ;; 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) - (make-local-variable 'archive-remote) - (setq archive-remote (string-match archive-remote-regexp - (buffer-file-name))) + + ;; An archive can contain another archive whose name is invalid + ;; on local filesystem. Treat such archives as remote. + (or archive-remote + (setq archive-remote + (or (string-match archive-remote-regexp (buffer-file-name)) + (string-match file-name-invalid-regexp + (buffer-file-name))))) (setq major-mode 'archive-mode) (setq mode-name (concat typename "-Archive")) @@ -454,7 +578,7 @@ archive. (make-local-variable 'archive-file-list-start) (make-local-variable 'archive-file-list-end) (make-local-variable 'archive-file-name-indent) - (archive-summarize) + (archive-summarize nil) (setq buffer-read-only t)))) ;; Archive mode is suitable only for specially formatted data. @@ -481,6 +605,7 @@ archive. (define-key archive-mode-map [down] 'archive-next-line) (define-key archive-mode-map "o" 'archive-extract-other-window) (define-key archive-mode-map "p" 'archive-previous-line) + (define-key archive-mode-map "q" 'quit-window) (define-key archive-mode-map "\C-p" 'archive-previous-line) (define-key archive-mode-map [up] 'archive-previous-line) (define-key archive-mode-map "r" 'archive-rename-entry) @@ -499,72 +624,76 @@ archive. ;; Not a nice "solution" but it'll have to do (define-key archive-mode-map "\C-xu" 'archive-undo) (define-key archive-mode-map "\C-_" 'archive-undo)) - (substitute-key-definition 'undo 'archive-undo - archive-mode-map global-map)) + (define-key archive-mode-map [remap advertised-undo] 'archive-undo) + (define-key archive-mode-map [remap undo] 'archive-undo)) (define-key archive-mode-map (if archive-lemacs 'button2 [mouse-2]) 'archive-mouse-extract) (if archive-lemacs () ; out of luck - ;; Get rid of the Edit menu bar item to save space. - (define-key archive-mode-map [menu-bar edit] 'undefined) (define-key archive-mode-map [menu-bar immediate] (cons "Immediate" (make-sparse-keymap "Immediate"))) (define-key archive-mode-map [menu-bar immediate alternate] - '("Alternate Display" . archive-alternate-display)) - (put 'archive-alternate-display 'menu-enable - '(boundp (archive-name "alternate-display"))) + '(menu-item "Alternate Display" archive-alternate-display + :enable (boundp (archive-name "alternate-display")) + :help "Toggle alternate file info display")) (define-key archive-mode-map [menu-bar immediate view] - '("View This File" . archive-view)) + '(menu-item "View This File" archive-view + :help "Display file at cursor in View Mode")) (define-key archive-mode-map [menu-bar immediate display] - '("Display in Other Window" . archive-display-other-window)) + '(menu-item "Display in Other Window" archive-display-other-window + :help "Display file at cursor in another window")) (define-key archive-mode-map [menu-bar immediate find-file-other-window] - '("Find in Other Window" . archive-extract-other-window)) + '(menu-item "Find in Other Window" archive-extract-other-window + :help "Edit file at cursor in another window")) (define-key archive-mode-map [menu-bar immediate find-file] - '("Find This File" . archive-extract)) + '(menu-item "Find This File" archive-extract + :help "Extract file at cursor and edit it")) (define-key archive-mode-map [menu-bar mark] (cons "Mark" (make-sparse-keymap "Mark"))) (define-key archive-mode-map [menu-bar mark unmark-all] - '("Unmark All" . archive-unmark-all-files)) + '(menu-item "Unmark All" archive-unmark-all-files + :help "Unmark all marked files")) (define-key archive-mode-map [menu-bar mark deletion] - '("Flag" . archive-flag-deleted)) + '(menu-item "Flag" archive-flag-deleted + :help "Flag file at cursor for deletion")) (define-key archive-mode-map [menu-bar mark unmark] - '("Unflag" . archive-unflag)) + '(menu-item "Unflag" archive-unflag + :help "Unmark file at cursor")) (define-key archive-mode-map [menu-bar mark mark] - '("Mark" . archive-mark)) + '(menu-item "Mark" archive-mark + :help "Mark file at cursor")) (define-key archive-mode-map [menu-bar operate] (cons "Operate" (make-sparse-keymap "Operate"))) (define-key archive-mode-map [menu-bar operate chown] - '("Change Owner..." . archive-chown-entry)) - (put 'archive-chown-entry 'menu-enable - '(fboundp (archive-name "chown-entry"))) + '(menu-item "Change Owner..." archive-chown-entry + :enable (fboundp (archive-name "chown-entry")) + :help "Change owner of marked files")) (define-key archive-mode-map [menu-bar operate chgrp] - '("Change Group..." . archive-chgrp-entry)) - (put 'archive-chgrp-entry 'menu-enable - '(fboundp (archive-name "chgrp-entry"))) + '(menu-item "Change Group..." archive-chgrp-entry + :enable (fboundp (archive-name "chgrp-entry")) + :help "Change group ownership of marked files")) (define-key archive-mode-map [menu-bar operate chmod] - '("Change Mode..." . archive-chmod-entry)) - (put 'archive-chmod-entry 'menu-enable - '(fboundp (archive-name "chmod-entry"))) + '(menu-item "Change Mode..." archive-chmod-entry + :enable (fboundp (archive-name "chmod-entry")) + :help "Change mode (permissions) of marked files")) (define-key archive-mode-map [menu-bar operate rename] - '("Rename to..." . archive-rename-entry)) - (put 'archive-rename-entry 'menu-enable - '(fboundp (archive-name "rename-entry"))) + '(menu-item "Rename to..." archive-rename-entry + :enable (fboundp (archive-name "rename-entry")) + :help "Rename marked files")) ;;(define-key archive-mode-map [menu-bar operate copy] - ;; '("Copy to..." . archive-copy)) + ;; '(menu-item "Copy to..." archive-copy)) (define-key archive-mode-map [menu-bar operate expunge] - '("Expunge Marked Files" . archive-expunge)) + '(menu-item "Expunge Marked Files" archive-expunge + :help "Delete all flagged files from archive")) )) (let* ((item1 '(archive-subfile-mode " Archive")) - (item2 '(archive-subfile-dos " Dos")) - (items (if (memq system-type '(ms-dos windows-nt)) - (list item1) ; msdog has its own indicator - (list item1 item2)))) + (items (list item1))) (or (member item1 minor-mode-alist) (setq minor-mode-alist (append items minor-mode-alist)))) ;; ------------------------------------------------------------------------- @@ -575,25 +704,30 @@ archive. ;; as an archive by other software. (let (case-fold-search) (cond ((looking-at "[P]K\003\004") 'zip) - ((looking-at "..-l[hz][0-9]-") 'lzh) + ((looking-at "..-l[hz][0-9ds]-") 'lzh) ((looking-at "....................[\334]\247\304\375") 'zoo) ((and (looking-at "\C-z") ; signature too simple, IMHO (string-match "\\.[aA][rR][cC]$" (or buffer-file-name (buffer-name)))) 'arc) - (t (error "Buffer format not recognized."))))) + (t (error "Buffer format not recognized"))))) ;; ------------------------------------------------------------------------- -(defun archive-summarize () +(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; then narrow to it, so that only that listing -is visible (and the real data of the buffer is hidden)." +is visible (and the real data of the buffer is hidden). +Optional argument SHUT-UP, if non-nil, means don't print messages +when parsing the archive." (widen) + (set-buffer-multibyte nil) (let (buffer-read-only) - (message "Parsing archive file...") + (or shut-up + (message "Parsing archive file...")) (buffer-disable-undo (current-buffer)) (setq archive-files (funcall (archive-name "summarize"))) - (message "Parsing archive file...done.") + (or shut-up + (message "Parsing archive file...done.")) (setq archive-proper-file-start (point-marker)) (narrow-to-region (point-min) (point)) (set-buffer-modified-p nil) @@ -608,13 +742,13 @@ is visible (and the real data of the buffer is hidden)." buffer-read-only) (widen) (delete-region (point-min) archive-proper-file-start) - (archive-summarize) + (archive-summarize t) (set-buffer-modified-p modified) (goto-char archive-file-list-start) (archive-next-line no))) (defun archive-summarize-files (files) - "Insert a desciption of a list of files annotated with proper mouse face" + "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)) ;; We don't want to do an insert for each element since that takes too @@ -623,61 +757,96 @@ is visible (and the real data of the buffer is hidden)." (apply (function concat) (mapcar - (function + (function (lambda (fil) ;; Using `concat' here copies the text also, so we can add ;; properties without problems. (let ((text (concat (aref fil 0) "\n"))) (if archive-lemacs () ; out of luck - (put-text-property (aref fil 1) (aref fil 2) - 'mouse-face 'highlight - text)) + (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))) (setq archive-file-list-end (point-marker))) (defun archive-alternate-display () - "Toggle alternative display. To avoid very long lines some archive mode -don't show all information. This function changes the set of information -shown for each files." + "Toggle alternative display. +To avoid very long lines some archive mode don't show all information. +This function changes the set of information shown for each files." (interactive) (setq archive-alternate-display (not archive-alternate-display)) (archive-resummarize)) ;; ------------------------------------------------------------------------- ;; Section: Local archive copy handling +(defun archive-unique-fname (fname dir) + "Make sure a file FNAME can be created uniquely in directory DIR. + +If FNAME can be uniquely created in DIR, it is returned unaltered. +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 + (expand-file-name + (if (if (fboundp 'msdos-long-file-names) + (not (msdos-long-file-names))) + "am" + "arc-mode.") + dir)) + fullname))) + (defun archive-maybe-copy (archive) - (if archive-remote - (let ((start (point-max))) - (setq archive-local-name (expand-file-name - (file-name-nondirectory archive) - archive-tmpdir)) - (make-directory archive-tmpdir t) - (save-restriction - (widen) - (write-region start (point-max) archive-local-name nil 'nomessage)) - archive-local-name) - (if (buffer-modified-p) (save-buffer)) - archive)) + (let ((coding-system-for-write 'no-conversion)) + (if archive-remote + (let ((start (point-max)) + ;; Sometimes ARCHIVE is invalid while its actual name, as + ;; recorded in its parent archive, is not. For example, an + ;; archive bar.zip inside another archive foo.zip gets a name + ;; "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)) + archive))) + (make-directory archive-tmpdir t) + (setq archive-local-name + (archive-unique-fname archive-name archive-tmpdir)) + (save-restriction + (widen) + (write-region start (point-max) archive-local-name nil 'nomessage)) + archive-local-name) + (if (buffer-modified-p) (save-buffer)) + archive))) (defun archive-maybe-update (unchanged) (if archive-remote (let ((name archive-local-name) (modified (buffer-modified-p)) + (coding-system-for-read 'no-conversion) + (lno (archive-get-lineno)) buffer-read-only) (if unchanged nil + (setq archive-files nil) (erase-buffer) (insert-file-contents name) - (archive-mode t)) + (archive-mode t) + (goto-char archive-file-list-start) + (archive-next-line lno)) (archive-delete-local name) (if (not unchanged) - (message "Archive file must be saved for changes to take effect")) + (message + "Buffer `%s' must be saved for changes to take effect" + (buffer-name (current-buffer)))) (set-buffer-modified-p (or modified (not unchanged)))))) (defun archive-delete-local (name) - "Delete (robust) the file NAME and its parents up to and including the -value of `archive-tmpdir'." + "Delete file NAME and its parents up to and including `archive-tmpdir'." (let ((again t) (top (directory-file-name (file-name-as-directory archive-tmpdir)))) (condition-case nil @@ -692,6 +861,42 @@ value of `archive-tmpdir'." ;; ------------------------------------------------------------------------- ;; Section: Member extraction +(defun archive-file-name-handler (op &rest args) + (or (eq op 'file-exists-p) + (let ((file-name-handler-alist nil)) + (apply op args)))) + +(defun archive-set-buffer-as-visiting-file (filename) + "Set the current buffer as if it were visiting FILENAME." + (save-excursion + (goto-char (point-min)) + (let ((coding + (or coding-system-for-read + (and set-auto-coding-function + (save-excursion + (funcall set-auto-coding-function + filename (- (point-max) (point-min))))) + ;; dos-w32.el defines find-operation-coding-system for + ;; DOS/Windows systems which preserves the coding-system + ;; of existing files. We want it to act here as if the + ;; extracted file existed. + (let ((file-name-handler-alist + '(("" . archive-file-name-handler)))) + (car (find-operation-coding-system 'insert-file-contents + filename 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) + (setq last-coding-system-used coding)) + (set-buffer-modified-p nil) + (kill-local-variable 'buffer-file-coding-system) + (after-insert-file-set-buffer-file-coding-system (- (point-max) + (point-min)))))) + (defun archive-mouse-extract (event) "Extract a file whose name you click on." (interactive "e") @@ -714,7 +919,11 @@ value of `archive-tmpdir'." (arcname (file-name-nondirectory archive)) (bufname (concat (file-name-nondirectory iname) " (" arcname ")")) (extractor (archive-name "extract")) - (read-only-p (or archive-read-only view-p)) + ;; Members with file names which aren't valid for the + ;; underlying filesystem, are treated as read-only. + (read-only-p (or archive-read-only + view-p + (string-match file-name-invalid-regexp ename))) (buffer (get-buffer bufname)) (just-created nil)) (if buffer @@ -735,56 +944,94 @@ value of `archive-tmpdir'." (make-local-variable 'local-write-file-hooks) (add-hook 'local-write-file-hooks 'archive-write-file-member) (setq archive-subfile-mode descr) - (setq archive-subfile-dos nil - buffer-file-type t) - (if (fboundp extractor) - (funcall extractor archive ename) - (archive-*-extract archive ename (symbol-value extractor))) - (if archive-dos-members (archive-check-dos)) - (goto-char (point-min)) - (rename-buffer bufname) - (setq buffer-read-only read-only-p) - (setq buffer-undo-list nil) - (set-buffer-modified-p nil) - (setq buffer-saved-size (buffer-size)) - (normal-mode) - ;; Just in case an archive occurs inside another archive. - (if (eq major-mode 'archive-mode) - (setq archive-remote t)) - (run-hooks 'archive-extract-hooks)) + (if (and + (null + (let (;; We may have to encode file name arguement for + ;; external programs. + (coding-system-for-write + (and enable-multibyte-characters + 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)) + (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)))) + just-created) + (progn + (set-buffer-modified-p nil) + (kill-buffer buffer)) + (archive-set-buffer-as-visiting-file ename) + (goto-char (point-min)) + (rename-buffer bufname) + (setq buffer-read-only read-only-p) + (setq buffer-undo-list nil) + (set-buffer-modified-p nil) + (setq buffer-saved-size (buffer-size)) + (normal-mode) + ;; Just in case an archive occurs inside another archive. + (if (eq major-mode 'archive-mode) + (progn + (setq archive-remote t) + (if read-only-p (setq archive-read-only t)) + ;; We will write out the archive ourselves if it is + ;; part of another archive. + (remove-hook 'write-contents-hooks 'archive-write-file t))) + (run-hooks 'archive-extract-hooks) + (if archive-read-only + (message "Note: altering this archive is not implemented.")))) (archive-maybe-update t)) - (if view-p - (progn - (view-buffer buffer) - (and just-created (setq view-exit-action 'kill-buffer))) - (if (eq other-window-p 'display) - (display-buffer buffer) - (if other-window-p - (switch-to-buffer-other-window buffer) - (switch-to-buffer buffer)))))) + (or (not (buffer-name buffer)) + (progn + (if view-p + (view-buffer buffer (and just-created 'kill-buffer)) + (if (eq other-window-p 'display) + (display-buffer buffer) + (if other-window-p + (switch-to-buffer-other-window buffer) + (switch-to-buffer buffer)))))))) (defun archive-*-extract (archive name command) (let* ((default-directory (file-name-as-directory archive-tmpdir)) (tmpfile (expand-file-name (file-name-nondirectory name) - default-directory))) + default-directory)) + exit-status success) (make-directory (directory-file-name default-directory) t) - (apply 'call-process - (car command) - nil - nil - nil - (append (cdr command) (list archive name))) - (insert-file-contents tmpfile) - (archive-delete-local tmpfile))) + (setq exit-status + (apply 'call-process + (car command) + nil + nil + nil + (append (cdr command) (list archive name)))) + (cond ((and (numberp exit-status) (= exit-status 0)) + (if (not (file-exists-p tmpfile)) + (ding (message "`%s': no such file or directory" tmpfile)) + (insert-file-contents tmpfile) + (setq success t))) + ((numberp exit-status) + (ding + (message "`%s' exited with status %d" (car command) exit-status))) + ((stringp exit-status) + (ding (message "`%s' aborted: %s" (car command) exit-status))) + (t + (ding (message "`%s' failed" (car command))))) + (archive-delete-local tmpfile) + success)) (defun archive-extract-by-stdout (archive name command) - (let ((binary-process-output t)) ; for Ms-Dos - (apply 'call-process - (car command) - nil - t - nil - (append (cdr command) (list archive name))))) + (apply 'call-process + (car command) + nil + t + nil + (append (cdr command) (list archive name)))) (defun archive-extract-other-window () "In archive mode, find this member in another window." @@ -802,8 +1049,7 @@ value of `archive-tmpdir'." (archive-extract 'view)) (defun archive-add-new-member (arcbuf name) - "Add the file in the current buffer to the archive in ARCBUF naming it -NAME." + "Add current buffer to the archive in ARCBUF naming it NAME." (interactive (list (get-buffer (read-buffer "Buffer containing archive: " @@ -843,64 +1089,29 @@ NAME." ;; ------------------------------------------------------------------------- ;; Section: IO stuff -(defun archive-check-dos (&optional force) - "*If this looks like a buffer with ^M^J as line terminator then remove -those ^Ms and set archive-subfile-dos." - (save-restriction - (widen) - (save-excursion - (goto-char (point-min)) - (setq archive-subfile-dos - (or force (not (search-forward-regexp "[^\r]\n" nil t)))) - (setq buffer-file-type (not archive-subfile-dos)) - (if archive-subfile-dos - (let ((modified (buffer-modified-p))) - (buffer-disable-undo (current-buffer)) - (goto-char (point-min)) - (while (search-forward "\r\n" nil t) - (replace-match "\n")) - (buffer-enable-undo) - (set-buffer-modified-p modified)))))) - (defun archive-write-file-member () - (if archive-subfile-dos - (save-restriction - (widen) - (save-excursion - (goto-char (point-min)) - ;; We don't want our ^M^J <--> ^J changes to show in the undo list - (let ((undo-list buffer-undo-list)) - (unwind-protect - (progn - (setq buffer-undo-list t) - (while (search-forward "\n" nil t) - (replace-match "\r\n")) - (setq archive-subfile-dos nil) - (setq buffer-file-type t) - ;; OK, we're now have explicit ^M^Js -- save and re-unixfy - (archive-write-file-member)) - (progn - (archive-check-dos t) - (setq buffer-undo-list undo-list)))) - t)) - (save-excursion - (save-restriction - (message "Updating archive...") - (widen) - (let ((writer (save-excursion (set-buffer archive-superior-buffer) - (archive-name "write-file-member"))) - (archive (save-excursion (set-buffer archive-superior-buffer) - (buffer-file-name)))) - (if (fboundp writer) - (funcall writer archive archive-subfile-mode) - (archive-*-write-file-member archive - archive-subfile-mode - (symbol-value writer)))) + (save-excursion + (save-restriction + (message "Updating archive...") + (widen) + (let ((writer (save-excursion (set-buffer archive-superior-buffer) + (archive-name "write-file-member"))) + (archive (save-excursion (set-buffer archive-superior-buffer) + (archive-maybe-copy (buffer-file-name))))) + (if (fboundp writer) + (funcall writer archive archive-subfile-mode) + (archive-*-write-file-member archive + archive-subfile-mode + (symbol-value writer))) (set-buffer-modified-p nil) - (message "Updating archive...done") - (set-buffer archive-superior-buffer) - (revert-buffer) - t)))) + (message "Updating archive...done")) + (set-buffer archive-superior-buffer) + (if (not archive-remote) (revert-buffer) (archive-maybe-update nil)))) + ;; Restore the value of last-coding-system-used, so that basic-save-buffer + ;; won't reset the coding-system of this archive member. + (if (local-variable-p 'archive-member-coding-system) + (setq last-coding-system-used archive-member-coding-system)) + t) (defun archive-*-write-file-member (archive descr command) (let* ((ename (aref descr 0)) @@ -910,10 +1121,22 @@ those ^Ms and set archive-subfile-dos." (unwind-protect (progn (make-directory (file-name-directory tmpfile) t) - (write-region (point-min) (point-max) tmpfile nil 'nomessage) + ;; If the member is itself an archive, write it without + ;; 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)) + ;; 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 + ;; archive-write-file-member, above). + (setq archive-member-coding-system last-coding-system-used) (if (aref descr 3) ;; Set the file modes, but make sure we can read it. (set-file-modes tmpfile (logior ?\400 (aref descr 3)))) + (if enable-multibyte-characters + (setq ename + (encode-coding-string ename file-name-coding-system))) (let ((exitcode (apply 'call-process (car command) nil @@ -925,10 +1148,12 @@ those ^Ms and set archive-subfile-dos." (error "Updating was unsuccessful (%S)" exitcode)))) (archive-delete-local tmpfile)))) -(defun archive-write-file () +(defun archive-write-file (&optional file) (save-excursion - (write-region archive-proper-file-start (point-max) buffer-file-name nil t) - (set-buffer-modified-p nil) + (let ((coding-system-for-write 'no-conversion)) + (write-region archive-proper-file-start (point-max) + (or file buffer-file-name) nil t) + (set-buffer-modified-p nil)) t)) ;; ------------------------------------------------------------------------- ;; Section: Marking and unmarking. @@ -1009,8 +1234,7 @@ Use \\[archive-unmark-all-files] to remove all marks." (archive-next-line (- p))) (defun archive-chmod-entry (new-mode) - "Change the protection bits associated with all marked or this member -in the archive.\n\ + "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): ") @@ -1090,15 +1314,21 @@ as a relative change like \"g+rw\" as for chmod(2)" (descr (archive-get-descr))) (if (fboundp func) (progn - (funcall func (buffer-file-name) newname descr) + (funcall func (buffer-file-name) + (if enable-multibyte-characters + (encode-coding-string newname file-name-coding-system) + newname) + descr) (archive-resummarize)) (error "Renaming is not supported for this archive type")))) ;; Revert the buffer and recompute the dired-like listing. -(defun archive-mode-revert (&optional no-autosave no-confirm) +(defun archive-mode-revert (&optional no-auto-save no-confirm) (let ((no (archive-get-lineno))) (setq archive-files nil) - (let ((revert-buffer-function nil)) + (let ((revert-buffer-function nil) + (coding-system-for-read 'no-conversion)) + (set-buffer-multibyte nil) (revert-buffer t t)) (archive-mode) (goto-char archive-file-list-start) @@ -1162,7 +1392,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (defun archive-arc-rename-entry (archive newname descr) (if (string-match "[:\\\\/]" newname) - (error "File names in arc files may not contain a path")) + (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" @@ -1171,6 +1401,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (save-restriction (save-excursion (widen) + (set-buffer-multibyte nil) (goto-char (+ archive-proper-file-start (aref descr 4) 2)) (delete-char 13) (insert name))))) @@ -1183,23 +1414,90 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (maxlen 8) files visual) - (while (progn (goto-char p) (looking-at "..-l[hz][0-9]-")) - (let* ((hsize (char-after p)) - (csize (archive-l-e (+ p 7) 4)) - (ucsize (archive-l-e (+ p 11) 4)) - (modtime (archive-l-e (+ p 15) 2)) - (moddate (archive-l-e (+ p 17) 2)) - (fnlen (char-after (+ p 21))) - (efnname (buffer-substring (+ p 22) (+ p 22 fnlen))) - (fiddle (string= efnname (upcase efnname))) - (ifnname (if fiddle (downcase efnname) efnname)) - (p2 (+ p 22 fnlen)) - (creator (if (>= (- hsize fnlen) 24) (char-after (+ p2 2)) 0)) - (mode (if (= creator ?U) (archive-l-e (+ p2 8) 2) ?\666)) - (modestr (if mode (archive-int-to-mode mode) "??????????")) - (uid (if (= creator ?U) (archive-l-e (+ p2 10) 2))) - (gid (if (= creator ?U) (archive-l-e (+ p2 12) 2))) - (text (if archive-alternate-display + (while (progn (goto-char p) ;beginning of a base header. + (looking-at "\\(.\\|\n\\)\\(.\\|\n\\)-l[hz][0-9ds]-")) + (let* ((hsize (char-after p)) ;size of the base header (level 0 and 1) + (csize (archive-l-e (+ p 7) 4)) ;size of a compressed file to follow. + (ucsize (archive-l-e (+ p 11) 4)) ;size of an uncompressed file. + (time1 (archive-l-e (+ p 15) 2)) ;date/time (MSDOS format in level 0, 1 headers + (time2 (archive-l-e (+ p 17) 2)) ;and UNIX format in level 2 header.) + (hdrlvl (char-after (+ p 20))) ;header level + thsize ;total header size (base + extensions) + fnlen efnname fiddle ifnname width p2 creator + neh ;beginning of next extension header (level 1 and 2) + mode modestr uid gid text dir prname + gname uname modtime moddate) + (if (= hdrlvl 3) (error "can't handle lzh level 3 header type")) + (when (or (= hdrlvl 0) (= hdrlvl 1)) + (setq fnlen (char-after (+ p 21))) ;filename length + (setq efnname (let ((str (buffer-substring (+ p 22) (+ p 22 fnlen)))) ;filename from offset 22 + (if file-name-coding-system + (decode-coding-string str file-name-coding-system) + (string-as-multibyte str)))) + (setq p2 (+ p 22 fnlen))) ; + (if (= hdrlvl 1) + (progn ;specific to level 1 header + (setq creator (if (>= (- hsize fnlen) 24) (char-after (+ p2 2)) 0)) + (setq neh (+ p2 3))) + (if (= hdrlvl 2) + (progn ;specific to level 2 header + (setq creator (char-after (+ p 23)) ) + (setq neh (+ p 24))))) + (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 (char-after (+ neh 2)))) ;extension type + (while (not (= ehsize 0)) + (cond + ((= etype 1) ;file name + (let ((i (+ neh 3))) + (while (< i (+ neh ehsize)) + (setq efnname (concat efnname (char-to-string (char-after i)))) + (setq i (1+ i))))) + ((= etype 2) ;directory name + (let ((i (+ neh 3))) + (while (< i (+ neh ehsize)) + (setq dir (concat dir + (if (= (char-after 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 + (progn (setq uid (archive-l-e (+ neh 3) 2)) + (setq gid (archive-l-e (+ neh 5) 2)))) + ((= etype 82) ;UNIX file group name + (let ((i (+ neh 3))) + (while (< i (+ neh ehsize)) + (setq gname (concat gname (char-to-string (char-after i)))) + (setq i (1+ i))))) + ((= etype 83) ;UNIX file user name + (let ((i (+ neh 3))) + (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 (char-after (+ neh 2)))) + ;;get total header size for level 1 and 2 headers + (setq thsize (- neh p)))) + (if (= hdrlvl 0) ;total header size + (setq thsize hsize)) + (setq fiddle (if efnname (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 "?") @@ -1208,19 +1506,20 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (format " %10s %8d %-11s %-8s %s" modestr ucsize - (archive-dosdate moddate) - (archive-dostime modtime) - ifnname)))) - (setq maxlen (max maxlen fnlen) + moddate + modtime + prname))) + (setq maxlen (max maxlen width) totalsize (+ totalsize ucsize) visual (cons (vector text - (- (length text) (length ifnname)) + (- (length text) (length prname)) (length text)) visual) - files (cons (vector efnname ifnname fiddle mode (1- p)) + files (cons (vector prname ifnname fiddle mode (1- p)) files) - p (+ p hsize 2 csize)))) + p (+ p thsize 2 csize)))) (goto-char (point-min)) + (set-buffer-multibyte default-enable-multibyte-characters) (let ((dash (concat (if archive-alternate-display "- -------- ----- ----- " "- ---------- -------- ----------- -------- ") @@ -1259,6 +1558,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (save-restriction (save-excursion (widen) + (set-buffer-multibyte nil) (let* ((p (+ archive-proper-file-start (aref descr 4))) (oldhsize (char-after p)) (oldfnlen (char-after (+ p 21))) @@ -1278,6 +1578,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (save-restriction (save-excursion (widen) + (set-buffer-multibyte nil) (while files (let* ((fil (car files)) (p (+ archive-proper-file-start (aref fil 4))) @@ -1317,7 +1618,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (defun archive-zip-summarize () (goto-char (- (point-max) (- 22 18))) (search-backward-regexp "[P]K\005\006") - (let ((p (1+ (archive-l-e (+ (point) 16) 4))) + (let ((p (+ (point-min) (archive-l-e (+ (point) 16) 4))) (maxlen 8) (totalsize 0) files @@ -1332,12 +1633,15 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (exlen (archive-l-e (+ p 30) 2)) (fclen (archive-l-e (+ p 32) 2)) (lheader (archive-l-e (+ p 42) 4)) - (efnname (buffer-substring (+ p 46) (+ p 46 fnlen))) + (efnname (let ((str (buffer-substring (+ p 46) (+ p 46 fnlen)))) + (if file-name-coding-system + (decode-coding-string str file-name-coding-system) + (string-as-multibyte str)))) (isdir (and (= ucsize 0) (string= (file-name-nondirectory efnname) ""))) (mode (cond ((memq creator '(2 3)) ; Unix + VMS (archive-l-e (+ p 40) 2)) - ((memq creator '(0 5 6 7 10 11)) ; Dos etc. + ((memq creator '(0 5 6 7 10 11 15)) ; Dos etc. (logior ?\444 (if isdir (logior 16384 ?\111) 0) (if (zerop @@ -1346,15 +1650,17 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (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)))))) + (not (not (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 fnlen) + (setq maxlen (max maxlen width) totalsize (+ totalsize ucsize) visual (cons (vector text (- (length text) (length ifnname)) @@ -1382,7 +1688,7 @@ 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 archive-zip-use-pkzip + (if (equal (car archive-zip-extract) "pkzip") (archive-*-extract archive name archive-zip-extract) (archive-extract-by-stdout archive name archive-zip-extract))) @@ -1396,6 +1702,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (save-restriction (save-excursion (widen) + (set-buffer-multibyte nil) (while files (let* ((fil (car files)) (p (+ archive-proper-file-start (car (aref fil 4)))) @@ -1407,7 +1714,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (goto-char (+ p 40)) (delete-char 2) (insert (logand newval 255) (lsh newval -8))) - ((memq creator '(0 5 6 7 10 11)) ; Dos etc. + ((memq creator '(0 5 6 7 10 11 15)) ; Dos etc. (goto-char (+ p 38)) (insert (logior (logand (char-after (point)) 254) (logand (logxor 1 (lsh newval -7)) 1))) @@ -1430,16 +1737,34 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (modtime (archive-l-e (+ p 16) 2)) (ucsize (archive-l-e (+ p 20) 4)) (namefld (buffer-substring (+ p 38) (+ p 38 13))) + (dirtype (char-after (+ p 4))) + (lfnlen (if (= dirtype 2) (char-after (+ p 56)) 0)) + (ldirlen (if (= dirtype 2) (char-after (+ p 57)) 0)) (fnlen (or (string-match "\0" namefld) 13)) - (efnname (substring namefld 0 fnlen)) - (fiddle (string= efnname (upcase efnname))) + (efnname (let ((str + (concat + (if (> ldirlen 0) + (concat (buffer-substring + (+ p 58 lfnlen) + (+ p 58 lfnlen ldirlen -1)) + "/") + "") + (if (> lfnlen 0) + (buffer-substring (+ p 58) + (+ p 58 lfnlen -1)) + (substring namefld 0 fnlen))))) + (if file-name-coding-system + (decode-coding-string str file-name-coding-system) + (string-as-multibyte str)))) + (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 fnlen) + (setq maxlen (max maxlen width) totalsize (+ totalsize ucsize) visual (cons (vector text (- (length text) (length ifnname)) @@ -1466,6 +1791,10 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (defun archive-zoo-extract (archive name) (archive-extract-by-stdout archive name archive-zoo-extract)) ;; ------------------------------------------------------------------------- +;; This line was a mistake; it is kept now for compatibility. +;; rms 15 Oct 98 (provide 'archive-mode) -;; arc-mode.el ends here. +(provide 'arc-mode) + +;;; arc-mode.el ends here