;;; arc-mode.el --- simple editing of archives
-;; Copyright (C) 1995, 1997, 1998, 2003, 2005 Free Software Foundation, Inc.
+;; Copyright (C) 1995, 1997, 1998, 2002, 2003, 2004,
+;; 2005 Free Software Foundation, Inc.
;; Author: Morten Welinder <terra@gnu.org>
;; Keywords: archives msdog editing major-mode
;; 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.
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
;;; Commentary:
(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"
+ "Directory for temporary files made by `arc-mode.el'."
:type 'directory
:group 'archive)
;; Zip archive configuration
(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")))
+ (if (and (not (executable-find "unzip"))
+ (executable-find "pkunzip"))
+ '("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
;; names.
(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")))
+ (if (and (not (executable-find "zip"))
+ (executable-find "pkzip"))
+ '("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."
:type '(list (string :tag "Program")
: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")))
+ (if (and (not (executable-find "zip"))
+ (executable-find "pkzip"))
+ '("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."
: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")))
+ (if (and (not (executable-find "zip"))
+ (executable-find "pkzip"))
+ '("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."
(substitute-key-definition 'undo 'archive-undo map global-map))
(define-key map
- (if (featurep 'xemacs) 'button2 [mouse-2]) 'archive-mouse-extract)
+ (if (featurep 'xemacs) 'button2 [mouse-2]) 'archive-extract)
(if (featurep 'xemacs)
() ; out of luck
(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 argument, length, should be supplied."
+ "Convert little endian string/vector STR to integer.
+Alternatively, STR may be a buffer position in the current buffer
+in which case a second argument, length LEN, should be supplied."
(if (stringp str)
(setq len (length str))
(setq str (buffer-substring str (+ str len))))
(format "%02d:%02d:%02d" hour minute second)))
(defun archive-unixdate (low high)
- "Stringify unix (LOW HIGH) date."
+ "Stringify Unix (LOW HIGH) date."
(let ((str (current-time-string (cons high low))))
(format "%s-%s-%s"
(substring str 8 10)
(substring str 20 24))))
(defun archive-unixtime (low high)
- "Stringify unix (LOW HIGH) time."
+ "Stringify Unix (LOW HIGH) time."
(let ((str (current-time-string (cons high low))))
(substring str 11 19)))
(defun archive-get-descr (&optional noerror)
"Return the descriptor vector for file at point.
-Does not signal an error if optional second argument NOERROR is non-nil."
+Does not signal an error if optional argument NOERROR is non-nil."
(let ((no (archive-get-lineno)))
(if (and (>= (point) archive-file-list-start)
(< no (length archive-files)))
;; 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))
+ (add-hook 'write-contents-functions 'archive-write-file nil t))
(make-local-variable 'require-final-newline)
(setq require-final-newline nil)
(setq major-mode 'archive-mode)
(setq mode-name (concat typename "-Archive"))
;; Run archive-foo-mode-hook and archive-mode-hook
- (run-hooks (archive-name "mode-hook") '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)
;; Archive mode is suitable only for specially formatted data.
(put 'archive-mode 'mode-class 'special)
-;; -------------------------------------------------------------------------
-;; Section: Key maps
(let ((item1 '(archive-subfile-mode " Archive")))
(or (member item1 minor-mode-alist)
when parsing the archive."
(widen)
(set-buffer-multibyte nil)
- (let (buffer-read-only)
+ (let ((inhibit-read-only t))
(or shut-up
(message "Parsing archive file..."))
(buffer-disable-undo (current-buffer))
"Recreate the contents listing of an archive."
(let ((modified (buffer-modified-p))
(no (archive-get-lineno))
- buffer-read-only)
+ (inhibit-read-only t))
(widen)
(delete-region (point-min) archive-proper-file-start)
(archive-summarize t)
- (set-buffer-modified-p modified)
+ (restore-buffer-modified-p modified)
(goto-char archive-file-list-start)
(archive-next-line no)))
(apply
(function concat)
(mapcar
- (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 (featurep 'xemacs)
- () ; out of luck
- (add-text-properties
- (aref fil 1) (aref fil 2)
- '(mouse-face highlight
- help-echo "mouse-2: extract this file into a buffer")
- text))
- text)))
+ (lambda (fil)
+ ;; Using `concat' here copies the text also, so we can add
+ ;; properties without problems.
+ (let ((text (concat (aref fil 0) "\n")))
+ (if (featurep 'xemacs)
+ () ; out of luck
+ (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.
+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))
(modified (buffer-modified-p))
(coding-system-for-read 'no-conversion)
(lno (archive-get-lineno))
- buffer-read-only)
+ (inhibit-read-only t))
(if unchanged nil
(setq archive-files nil)
(erase-buffer)
(kill-local-variable 'buffer-file-coding-system)
(after-insert-file-set-coding (- (point-max) (point-min))))))
-(defun archive-mouse-extract (event)
- "Extract a file whose name you click on."
- (interactive "e")
- (mouse-set-point event)
- (switch-to-buffer
- (save-excursion
- (archive-extract)
- (current-buffer))))
+(define-obsolete-function-alias 'archive-mouse-extract 'archive-extract "22.1")
-(defun archive-extract (&optional other-window-p)
+(defun archive-extract (&optional other-window-p event)
"In archive mode, extract this entry of the archive into its own buffer."
- (interactive)
+ (interactive (list nil last-input-event))
+ (if event (mouse-set-point event))
(let* ((view-p (eq other-window-p 'view))
(descr (archive-get-descr))
(ename (aref descr 0))
(setq archive (archive-maybe-copy archive))
(setq buffer (get-buffer-create bufname))
(setq just-created t)
- (save-excursion
- (set-buffer buffer)
+ (with-current-buffer buffer
(setq buffer-file-name
(expand-file-name (concat arcname ":" iname)))
(setq buffer-file-truename
(setq default-directory arcdir)
(make-local-variable 'archive-superior-buffer)
(setq archive-superior-buffer archive-buffer)
- (make-local-variable 'local-write-file-hooks)
- (add-hook 'local-write-file-hooks 'archive-write-file-member)
+ (add-hook 'write-file-functions 'archive-write-file-member nil t)
(setq archive-subfile-mode descr)
(if (and
(null
(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)
+ (when (derived-mode-p 'archive-mode)
+ (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-functions '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))
(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))))))))
+ (cond
+ (view-p (view-buffer buffer (and just-created 'kill-buffer)))
+ ((eq other-window-p 'display) (display-buffer buffer))
+ (other-window-p (switch-to-buffer-other-window buffer))
+ (t (switch-to-buffer buffer))))))
(defun archive-*-extract (archive name command)
(let* ((default-directory (file-name-as-directory archive-tmpdir))
(read-buffer "Buffer containing archive: "
;; Find first archive buffer and suggest that
(let ((bufs (buffer-list)))
- (while (and bufs (not (eq (save-excursion
- (set-buffer (car bufs))
- major-mode)
- 'archive-mode)))
- (setq bufs (cdr bufs)))
+ (while (and bufs
+ (not (with-current-buffer (car bufs)
+ (derived-mode-p 'archive-mode))))
+ (setq bufs (cdr bufs)))
(if bufs
(car bufs)
(error "There are no archive buffers")))
(if buffer-file-name
(file-name-nondirectory buffer-file-name)
""))))
- (save-excursion
- (set-buffer arcbuf)
+ (with-current-buffer arcbuf
(or (eq major-mode 'archive-mode)
(error "Buffer is not an archive buffer"))
(if archive-read-only
(error "An archive buffer cannot be added to itself"))
(if (string= name "")
(error "Archive members may not be given empty names"))
- (let ((func (save-excursion (set-buffer arcbuf)
- (archive-name "add-new-member")))
+ (let ((func (with-current-buffer arcbuf
+ (archive-name "add-new-member")))
(membuf (current-buffer)))
(if (fboundp func)
- (save-excursion
- (set-buffer arcbuf)
+ (with-current-buffer arcbuf
(funcall func buffer-file-name membuf name))
(error "Adding a new member is not supported for this archive type"))))
;; -------------------------------------------------------------------------
(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)))))
+ (let ((writer (with-current-buffer archive-superior-buffer
+ (archive-name "write-file-member")))
+ (archive (with-current-buffer archive-superior-buffer
+ (archive-maybe-copy (buffer-file-name)))))
(if (fboundp writer)
(funcall writer archive archive-subfile-mode)
(archive-*-write-file-member archive
(beginning-of-line)
(let ((sign (if (>= p 0) +1 -1))
(modified (buffer-modified-p))
- buffer-read-only)
+ (inhibit-read-only t))
(while (not (zerop p))
(if (archive-get-descr t)
(progn
(insert type)))
(forward-line sign)
(setq p (- p sign)))
- (set-buffer-modified-p modified))
+ (restore-buffer-modified-p modified))
(archive-next-line 0))
(defun archive-unflag (p)
"In archive mode, un-mark this member if it is marked to be deleted.
With a prefix argument, un-mark that many files forward."
(interactive "p")
- (archive-flag-deleted p ? ))
+ (archive-flag-deleted p ?\s))
(defun archive-unflag-backwards (p)
"In archive mode, un-mark this member if it is marked to be deleted.
With a prefix argument, un-mark that many members backward."
(interactive "p")
- (archive-flag-deleted (- p) ? ))
+ (archive-flag-deleted (- p) ?\s))
(defun archive-unmark-all-files ()
"Remove all marks."
(interactive)
(let ((modified (buffer-modified-p))
- buffer-read-only)
+ (inhibit-read-only t))
(save-excursion
(goto-char archive-file-list-start)
(while (< (point) archive-file-list-end)
- (or (= (following-char) ? )
- (progn (delete-char 1) (insert ? )))
+ (or (= (following-char) ?\s)
+ (progn (delete-char 1) (insert ?\s)))
(forward-line 1)))
- (set-buffer-modified-p modified)))
+ (restore-buffer-modified-p modified)))
(defun archive-mark (p)
"In archive mode, mark this member for group operations.
(defun archive-chmod-entry (new-mode)
"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)"
+as a relative change like \"g+rw\" as for chmod(2)."
(interactive "sNew mode (octal or relative): ")
(if archive-read-only (error "Archive is read-only"))
(let ((func (archive-name "chmod-entry")))
(append (cdr command) (cons archive files))))
(defun archive-rename-entry (newname)
- "Change the name associated with this entry in the tar file."
+ "Change the name associated with this entry in the archive file."
(interactive "sNew name: ")
(if archive-read-only (error "Archive is read-only"))
(if (string= newname "")
(descr (archive-get-descr)))
(if (fboundp func)
(progn
- (funcall func (buffer-file-name)
+ (funcall func
(if enable-multibyte-characters
(encode-coding-string newname file-name-coding-system)
newname)
"Undo in an archive buffer.
This doesn't recover lost files, it just undoes changes in the buffer itself."
(interactive)
- (let (buffer-read-only)
+ (let ((inhibit-read-only t))
(undo)))
;; -------------------------------------------------------------------------
;; Section: Arc Archives
"\n"))
(apply 'vector (nreverse files))))
-(defun archive-arc-rename-entry (archive newname descr)
+(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))))
- buffer-read-only)
+ (inhibit-read-only t))
(save-restriction
(save-excursion
(widen)
(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
+ fnlen efnname fiddle ifnname width p2
neh ;beginning of next extension header (level 1 and 2)
mode modestr uid gid text dir prname
gname uname modtime moddate)
(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)))
+ (setq neh (+ p2 3)) ;specific to level 1 header
(if (= hdrlvl 2)
- (progn ;specific to level 2 header
- (setq creator (char-after (+ p 23)) )
- (setq neh (+ p 24)))))
+ (setq neh (+ p 24)))) ;specific to level 2 header
(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
p (1+ p)))
(logand sum 255)))
-(defun archive-lzh-rename-entry (archive newname descr)
+(defun archive-lzh-rename-entry (newname descr)
(save-restriction
(save-excursion
(widen)
(oldfnlen (char-after (+ p 21)))
(newfnlen (length newname))
(newhsize (+ oldhsize newfnlen (- oldfnlen)))
- buffer-read-only)
+ (inhibit-read-only t))
(if (> newhsize 255)
(error "The file name is too long"))
(goto-char (+ p 21))
(insert newhsize (archive-lzh-resum p newhsize))))))
(defun archive-lzh-ogm (newval files errtxt ofs)
- (save-restriction
- (save-excursion
+ (save-excursion
+ (save-restriction
(widen)
(set-buffer-multibyte nil)
- (while files
- (let* ((fil (car files))
- (p (+ archive-proper-file-start (aref fil 4)))
+ (dolist (fil files)
+ (let* ((p (+ archive-proper-file-start (aref fil 4)))
(hsize (char-after p))
(fnlen (char-after (+ p 21)))
(p2 (+ p 22 fnlen))
(creator (if (>= (- hsize fnlen) 24) (char-after (+ p2 2)) 0))
- buffer-read-only)
+ (inhibit-read-only t))
(if (= creator ?U)
(progn
(or (numberp newval)
(delete-char 1)
(insert (archive-lzh-resum (1+ p) hsize)))
(message "Member %s does not have %s field"
- (aref fil 1) errtxt)))
- (setq files (cdr files))))))
+ (aref fil 1) errtxt)))))))
(defun archive-lzh-chown-entry (newuid files)
(archive-lzh-ogm newuid files "an uid" 10))
(defun archive-lzh-chmod-entry (newmode files)
(archive-lzh-ogm
;; This should work even though newmode will be dynamically accessed.
- (function (lambda (old) (archive-calc-mode old newmode t)))
+ (lambda (old) (archive-calc-mode old newmode t))
files "a unix-style mode" 8))
;; -------------------------------------------------------------------------
;; Section: Zip Archives
visual)
(while (string= "PK\001\002" (buffer-substring p (+ p 4)))
(let* ((creator (char-after (+ p 5)))
- (method (archive-l-e (+ p 10) 2))
+ ;; (method (archive-l-e (+ p 10) 2))
(modtime (archive-l-e (+ p 12) 2))
(moddate (archive-l-e (+ p 14) 2))
(ucsize (archive-l-e (+ p 24) 4))
(save-excursion
(widen)
(set-buffer-multibyte nil)
- (while files
- (let* ((fil (car files))
- (p (+ archive-proper-file-start (car (aref fil 4))))
+ (dolist (fil files)
+ (let* ((p (+ archive-proper-file-start (car (aref fil 4))))
(creator (char-after (+ p 5)))
(oldmode (aref fil 3))
(newval (archive-calc-mode oldmode newmode t))
- buffer-read-only)
+ (inhibit-read-only t))
(cond ((memq creator '(2 3)) ; Unix + VMS
(goto-char (+ p 40))
(delete-char 2)
(logand (logxor 1 (lsh newval -7)) 1)))
(delete-char 1))
(t (message "Don't know how to change mode for this member"))))
- (setq files (cdr files))))))
+ ))))
;; -------------------------------------------------------------------------
;; Section: Zoo Archives