;;; arc-mode.el --- simple editing of archives
-;; Copyright (C) 1995, 1997, 1998, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
+;; Copyright (C) 1995, 1997, 1998, 2001, 2002, 2003, 2004, 2005, 2006,
+;; 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
;; Author: Morten Welinder <terra@gnu.org>
-;; Keywords: archives msdog editing major-mode
+;; Keywords: files archives msdog editing major-mode
;; Favourite-brand-of-beer: None, I hate beer.
;; This file is part of GNU Emacs.
:group 'archive)
(defcustom archive-remote-regexp "^/[^/:]*[^/:.]:"
- "*Regexp recognizing archive files names that are not local.
+ "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."
+ "Hooks to run when an archive member has been extracted."
:type 'hook
:group 'archive)
;; ------------------------------
;; to extract to stdout without junk getting added.
(defcustom archive-arc-extract
'("arc" "x")
- "*Program and its options to run in order to extract an arc file member.
+ "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")
(defcustom archive-arc-expunge
'("arc" "d")
- "*Program and its options to run in order to delete arc file members.
+ "Program and its options to run in order to delete arc file members.
Archive and member names will be added."
:type '(list (string :tag "Program")
(repeat :tag "Options"
(defcustom archive-arc-write-file-member
'("arc" "u")
- "*Program and its options to run in order to update an arc file member.
+ "Program and its options to run in order to update an arc file member.
Archive and member name will be added."
:type '(list (string :tag "Program")
(repeat :tag "Options"
(defcustom archive-lzh-extract
'("lha" "pq")
- "*Program and its options to run in order to extract an lzh file member.
+ "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")
(defcustom archive-lzh-expunge
'("lha" "d")
- "*Program and its options to run in order to delete lzh file members.
+ "Program and its options to run in order to delete lzh file members.
Archive and member names will be added."
:type '(list (string :tag "Program")
(repeat :tag "Options"
(defcustom archive-lzh-write-file-member
'("lha" "a")
- "*Program and its options to run in order to update an lzh file member.
+ "Program and its options to run in order to update an lzh file member.
Archive and member name will be added."
:type '(list (string :tag "Program")
(repeat :tag "Options"
(executable-find "pkunzip"))
'("pkunzip" "-e" "-o-")
'("unzip" "-qq" "-c"))
- "*Program and its options to run in order to extract a zip file member.
+ "Program and its options to run in order to extract a zip file member.
Extraction should happen to standard output. Archive and member name will
be added."
:type '(list (string :tag "Program")
(executable-find "pkzip"))
'("pkzip" "-d")
'("zip" "-d" "-q"))
- "*Program and its options to run in order to delete zip file members.
+ "Program and its options to run in order to delete zip file members.
Archive and member names will be added."
:type '(list (string :tag "Program")
(repeat :tag "Options"
(executable-find "pkzip"))
'("pkzip" "-u" "-P")
'("zip" "-q"))
- "*Program and its options to run in order to update a zip file member.
+ "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."
:type '(list (string :tag "Program")
(executable-find "pkzip"))
'("pkzip" "-u" "-P")
'("zip" "-q" "-k"))
- "*Program and its options to run in order to update a case fiddled zip member.
+ "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")
:group 'archive-zip)
(defcustom archive-zip-case-fiddle t
- "*If non-nil then zip file members may be down-cased.
+ "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
(defcustom archive-zoo-extract
'("zoo" "xpq")
- "*Program and its options to run in order to extract a zoo file member.
+ "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")
(defcustom archive-zoo-expunge
'("zoo" "DqPP")
- "*Program and its options to run in order to delete zoo file members.
+ "Program and its options to run in order to delete zoo file members.
Archive and member names will be added."
:type '(list (string :tag "Program")
(repeat :tag "Options"
(defcustom archive-zoo-write-file-member
'("zoo" "a")
- "*Program and its options to run in order to update a zoo file member.
+ "Program and its options to run in order to update a zoo file member.
Archive and member name will be added."
:type '(list (string :tag "Program")
(repeat :tag "Options"
;; mode on and off. You can corrupt things that way.
(if (zerop (buffer-size))
;; At present we cannot create archives from scratch
- (funcall default-major-mode)
+ (funcall (or (default-value 'major-mode) 'fundamental-mode))
(if (and (not force) archive-files) nil
(let* ((type (archive-find-type))
(typename (capitalize (symbol-name type))))
(or file-name-coding-system
default-file-name-coding-system
locale-coding-system))
- (if default-enable-multibyte-characters
+ (if (default-value 'enable-multibyte-characters)
(set-buffer-multibyte 'to))
(archive-summarize nil)
(setq buffer-read-only t))))
;; The funny [] here make it unlikely that the .elc file will be treated
;; as an archive by other software.
(let (case-fold-search)
- (cond ((looking-at "[P]K\003\004") 'zip)
+ (cond ((looking-at "\\(PK00\\)?[P]K\003\004") 'zip)
((looking-at "..-l[hz][0-9ds]-") 'lzh)
((looking-at "....................[\334]\247\304\375") 'zoo)
((and (looking-at "\C-z") ; signature too simple, IMHO
file by that name already exists in DIR, a unique new name is generated
using `make-temp-file', and the generated name is returned."
(let ((fullname (expand-file-name fname dir))
- (alien (string-match file-name-invalid-regexp fname)))
- (if (or alien (file-exists-p fullname))
- (make-temp-file
+ (alien (string-match file-name-invalid-regexp fname))
+ (tmpfile
(expand-file-name
(if (if (fboundp 'msdos-long-file-names)
(not (msdos-long-file-names)))
"am"
"arc-mode.")
- dir))
+ dir)))
+ (if (or alien (file-exists-p fullname))
+ (progn
+ ;; Maked sure all the leading directories in
+ ;; archive-local-name exist under archive-tmpdir, so that
+ ;; the directory structure recorded in the archive is
+ ;; reconstructed in the temporary directory.
+ (make-directory (file-name-directory tmpfile) t)
+ (make-temp-file tmpfile))
+ ;; Maked sure all the leading directories in `fullname' exist
+ ;; under archive-tmpdir. This is necessary for nested archives
+ ;; (`archive-extract' sets `archive-remote' to t in case
+ ;; an archive occurs inside another archive).
+ (make-directory (file-name-directory fullname) t)
fullname)))
(defun archive-maybe-copy (archive)
archive)))
(setq archive-local-name
(archive-unique-fname archive-name archive-tmpdir))
- ;; Maked sure all the leading directories in
- ;; archive-local-name exist under archive-tmpdir, so that
- ;; the directory structure recorded in the archive is
- ;; reconstructed in the temporary directory.
- (make-directory (file-name-directory archive-local-name) t)
(save-restriction
(widen)
(write-region start (point-max) archive-local-name nil 'nomessage))
(apply 'vector (nreverse files))))
(defun archive-zip-extract (archive name)
- (if (equal (car archive-zip-extract) "pkzip")
+ (if (member-ignore-case (car archive-zip-extract) '("pkunzip" "pkzip"))
(archive-*-extract archive name archive-zip-extract)
- (archive-extract-by-stdout archive name archive-zip-extract)))
+ (archive-extract-by-stdout
+ archive
+ ;; unzip expands wildcards in NAME, so we need to quote it. But
+ ;; not on DOS/Windows, since that fails extraction on those
+ ;; systems, and file names with wildcards in zip archives don't
+ ;; work there anyway.
+ ;; FIXME: Does pkunzip need similar treatment?
+ (if (and (not (memq system-type '(windows-nt ms-dos)))
+ (equal (car archive-zip-extract) "unzip"))
+ (shell-quote-argument name)
+ name)
+ archive-zip-extract)))
(defun archive-zip-write-file-member (archive descr)
(archive-*-write-file-member
;; Ratio ; Date'
" +\\([0-9%]+\\) +\\([-0-9]+\\)"
;; Time ; Attr.
- " +\\([0-9:]+\\) +......"
+ " +\\([0-9:]+\\) +[^ \n]\\{6,10\\}"
;; CRC; Meth ; Var.
" +[0-9A-F]+ +[^ \n]+ +[0-9.]+\n"))
(goto-char (match-end 0))
(search-forward "!<arch>\n")
(while (looking-at archive-ar-file-header-re)
(let ((name (match-string 1))
+ extname
;; Emacs will automatically use float here because those
;; timestamps don't fit in our ints.
(time (string-to-number (match-string 2)))
(size (string-to-number (match-string 6))))
;; Move to the beginning of the data.
(goto-char (match-end 0))
- (cond
- ((equal name "// ")
- ;; FIXME: todo
- nil)
- ((equal name "/ ")
- ;; FIXME: todo
- nil)
- (t
- (setq time
- (format-time-string
- "%Y-%m-%d %H:%M"
- (let ((high (truncate (/ time 65536))))
- (list high (truncate (- time (* 65536.0 high)))))))
- (setq name (substring name 0 (string-match "/? *\\'" name)))
- (setq user (substring user 0 (string-match " +\\'" user)))
- (setq group (substring group 0 (string-match " +\\'" group)))
- (setq mode (tar-grind-file-mode mode))
- ;; Move to the end of the data.
- (forward-char size) (if (eq ?\n (char-after)) (forward-char 1))
- (setq size (number-to-string size))
- (if (> (length name) maxname) (setq maxname (length name)))
- (if (> (length time) maxtime) (setq maxtime (length time)))
- (if (> (length user) maxuser) (setq maxuser (length user)))
- (if (> (length group) maxgroup) (setq maxgroup (length group)))
- (if (> (length mode) maxmode) (setq maxmode (length mode)))
- (if (> (length size) maxsize) (setq maxsize (length size)))
- (push (vector name name nil mode
- time user group size)
- files)))))
+ (setq time
+ (format-time-string
+ "%Y-%m-%d %H:%M"
+ (let ((high (truncate (/ time 65536))))
+ (list high (truncate (- time (* 65536.0 high)))))))
+ (setq extname
+ (cond ((equal name "// ")
+ (propertize ".<ExtNamesTable>." 'face 'italic))
+ ((equal name "/ ")
+ (propertize ".<LookupTable>." 'face 'italic))
+ ((string-match "/? *\\'" name)
+ (substring name 0 (match-beginning 0)))))
+ (setq user (substring user 0 (string-match " +\\'" user)))
+ (setq group (substring group 0 (string-match " +\\'" group)))
+ (setq mode (tar-grind-file-mode mode))
+ ;; Move to the end of the data.
+ (forward-char size) (if (eq ?\n (char-after)) (forward-char 1))
+ (setq size (number-to-string size))
+ (if (> (length name) maxname) (setq maxname (length name)))
+ (if (> (length time) maxtime) (setq maxtime (length time)))
+ (if (> (length user) maxuser) (setq maxuser (length user)))
+ (if (> (length group) maxgroup) (setq maxgroup (length group)))
+ (if (> (length mode) maxmode) (setq maxmode (length mode)))
+ (if (> (length size) maxsize) (setq maxsize (length size)))
+ (push (vector name extname nil mode
+ time user group size)
+ files)))
(setq files (nreverse files))
(goto-char (point-min))
(let* ((format (format "%%%ds %%%ds/%%-%ds %%%ds %%%ds %%s"
(save-restriction
;; We may be in archive-mode or not, so either with or without
;; narrowing and with or without a prepended summary.
- (widen)
- (search-forward "!<arch>\n")
- (while (and (not from) (looking-at archive-ar-file-header-re))
- (let ((this (match-string 1)))
- (setq size (string-to-number (match-string 6)))
- (goto-char (match-end 0))
- (setq this (substring this 0 (string-match "/? *\\'" this)))
- (if (equal name this)
- (setq from (point))
- ;; Move to the end of the data.
- (forward-char size) (if (eq ?\n (char-after)) (forward-char 1)))))
- (when from
- (set-buffer-multibyte nil)
- (with-current-buffer destbuf
- ;; Do it within the `widen'.
- (insert-buffer-substring archivebuf from (+ from size)))
- (set-buffer-multibyte 'to)
- ;; Inform the caller that the call succeeded.
- t)))))
+ (save-excursion
+ (widen)
+ (search-forward "!<arch>\n")
+ (while (and (not from) (looking-at archive-ar-file-header-re))
+ (let ((this (match-string 1)))
+ (setq size (string-to-number (match-string 6)))
+ (goto-char (match-end 0))
+ (if (equal name this)
+ (setq from (point))
+ ;; Move to the end of the data.
+ (forward-char size) (if (eq ?\n (char-after)) (forward-char 1)))))
+ (when from
+ (set-buffer-multibyte nil)
+ (with-current-buffer destbuf
+ ;; Do it within the `widen'.
+ (insert-buffer-substring archivebuf from (+ from size)))
+ (set-buffer-multibyte 'to)
+ ;; Inform the caller that the call succeeded.
+ t))))))
;; -------------------------------------------------------------------------
;; This line was a mistake; it is kept now for compatibility.
HCoop / bpt / emacs.git / blobdiff