;;; arc-mode.el --- simple editing of archives
;; Copyright (C) 1995, 1997, 1998, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
+;; 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
;; Author: Morten Welinder <terra@gnu.org>
;; Keywords: archives msdog editing major-mode
;; This file is part of GNU Emacs.
-;; GNU Emacs is free software; you can redistribute it and/or modify
+;; 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 3, or (at your option)
-;; any later version.
+;; the Free Software Foundation, either version 3 of the License, 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
;; 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., 51 Franklin Street, Fifth Floor,
-;; Boston, MA 02110-1301, USA.
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
: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")
(string :format "%v")))
:group 'archive-zip)
-;; For several reasons the latter behaviour is not desirable in general.
+;; For several reasons the latter behavior 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.
(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"
(define-key map "M" 'archive-chmod-entry)
(define-key map "G" 'archive-chgrp-entry)
(define-key map "O" 'archive-chown-entry)
+ ;; Let mouse-1 follow the link.
+ (define-key map [follow-link] 'mouse-face)
(if (fboundp 'command-remapping)
(progn
(string-match "\\.[aA][rR][cC]$"
(or buffer-file-name (buffer-name))))
'arc)
- ;; This pattern modelled on the BSD/GNU+Linux `file' command.
+ ;; This pattern modeled on the BSD/GNU+Linux `file' command.
;; Have seen capital "LHA's", and file has lower case "LHa's" too.
;; Note this regexp is also in archive-exe-p.
((looking-at "MZ\\(.\\|\n\\)\\{34\\}LH[aA]'s SFX ") 'lzh-exe)
;; -------------------------------------------------------------------------
;;; Section: Member extraction
+(defun archive-try-jka-compr ()
+ (when (and auto-compression-mode
+ (jka-compr-get-compression-info buffer-file-name))
+ (let* ((basename (file-name-nondirectory buffer-file-name))
+ (tmpname (if (string-match ":\\([^:]+\\)\\'" basename)
+ (match-string 1 basename) basename))
+ (tmpfile (make-temp-file (file-name-sans-extension tmpname)
+ nil
+ (file-name-extension tmpname 'period))))
+ (unwind-protect
+ (progn
+ (let ((coding-system-for-write 'no-conversion)
+ ;; Don't re-compress this data just before decompressing it.
+ (jka-compr-inhibit t))
+ (write-region (point-min) (point-max) tmpfile nil 'quiet))
+ (erase-buffer)
+ (let ((coding-system-for-read 'no-conversion))
+ (insert-file-contents tmpfile)))
+ (delete-file tmpfile)))))
+
(defun archive-file-name-handler (op &rest args)
(or (eq op 'file-exists-p)
(let ((file-name-handler-alist nil))
(car (find-operation-coding-system
'insert-file-contents
(cons filename (current-buffer)) 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)
+ (unless (or coding-system-for-read
+ enable-multibyte-characters)
+ (setq coding
+ (coding-system-change-text-conversion coding 'raw-text)))
+ (unless (memq coding '(nil 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)
(progn
(set-buffer-modified-p nil)
(kill-buffer buffer))
+ (archive-try-jka-compr) ;Pretty ugly hack :-(
(archive-set-buffer-as-visiting-file ename)
(goto-char (point-min))
(rename-buffer bufname)
nil
nil
(append (cdr command) (list archive name))))
- (cond ((and (numberp exit-status) (= exit-status 0))
+ (cond ((and (numberp exit-status) (zerop exit-status))
(if (not (file-exists-p tmpfile))
(ding (message "`%s': no such file or directory" tmpfile))
(insert-file-contents tmpfile)
(file-name-nondirectory buffer-file-name)
""))))
(with-current-buffer arcbuf
- (or (eq major-mode 'archive-mode)
+ (or (derived-mode-p 'archive-mode)
(error "Buffer is not an archive buffer"))
(if archive-read-only
(error "Archive is read-only")))
;; 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))
+ (write-region nil nil 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
nil
(append (cdr command)
(list archive ename)))))
- (if (equal exitcode 0)
- nil
- (error "Updating was unsuccessful (%S)" exitcode))))
+ (or (zerop exitcode)
+ (error "Updating was unsuccessful (%S)" exitcode))))
(archive-delete-local tmpfile))))
(defun archive-write-file (&optional file)
str archive-file-name-coding-system)))
(isdir (and (= ucsize 0)
(string= (file-name-nondirectory efnname) "")))
- (mode (cond ((memq creator '(2 3)) ; Unix + VMS
+ (mode (cond ((memq creator '(2 3)) ; Unix
(archive-l-e (+ p 40) 2))
((memq creator '(0 5 6 7 10 11 15)) ; Dos etc.
(logior ?\444
(oldmode (aref fil 3))
(newval (archive-calc-mode oldmode newmode t))
(inhibit-read-only t))
- (cond ((memq creator '(2 3)) ; Unix + VMS
+ (cond ((memq creator '(2 3)) ; Unix
(goto-char (+ p 40))
(delete-char 2)
(insert-unibyte (logand newval 255) (lsh newval -8)))
(with-current-buffer destbuf
;; Do it within the `widen'.
(insert-buffer-substring archivebuf from (+ from size)))
- (set-buffer-multibyte t)
+ (set-buffer-multibyte 'to)
;; Inform the caller that the call succeeded.
t)))))