comparison lisp/arc-mode.el @ 63889:abe14daaa679

Bind inhibit-read-only rather than buffer-read-only. (archive-zip-extract, archive-zip-expunge) (archive-zip-update, archive-zip-update-case): Use executable-find. (archive-resummarize, archive-flag-deleted, archive-unmark-all-files): Use restore-buffer-modified-p. (archive-extract, archive-add-new-member, archive-write-file-member): Use with-current-buffer. (archive-lzh-ogm, archive-zip-chmod-entry): Use dolist.

63888:ccf4a0e5ff34

  :group 'archive-lzh)
;; ------------------------------
;; 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")))
  "*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")

;; (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.

(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."
  :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."
  :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"

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)
    (or shut-up
	(message "Parsing archive file..."))
    (buffer-disable-undo (current-buffer))
    (setq archive-files (funcall (archive-name "summarize")))
    (or shut-up

(defun archive-resummarize ()
  "Recreate the contents listing of an archive."
  (let ((modified (buffer-modified-p))
	(no (archive-get-lineno))
	buffer-read-only)
    (widen)
    (delete-region (point-min) archive-proper-file-start)
    (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 description of a list of files annotated with proper mouse face."

  (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)

      (if buffer
          nil
	(setq archive (archive-maybe-copy archive))
        (setq buffer (get-buffer-create bufname))
        (setq just-created t)
        (save-excursion
          (set-buffer buffer)
          (setq buffer-file-name
                (expand-file-name (concat arcname ":" iname)))
          (setq buffer-file-truename
                (abbreviate-file-name buffer-file-name))
          ;; Set the default-directory to the dir of the superior buffer.

  (interactive
   (list (get-buffer
	  (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)))
			 (if bufs
			     (car bufs)
			   (error "There are no archive buffers")))
		       t))
	 (read-string "File name in archive: "
		      (if buffer-file-name
			  (file-name-nondirectory buffer-file-name)
			""))))
  (save-excursion
    (set-buffer arcbuf)
    (or (eq major-mode 'archive-mode)
	(error "Buffer is not an archive buffer"))
    (if archive-read-only
	(error "Archive is read-only")))
  (if (eq arcbuf (current-buffer))
      (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")))
	(membuf (current-buffer)))
    (if (fboundp func)
	(save-excursion
	  (set-buffer arcbuf)
	  (funcall func buffer-file-name membuf name))
      (error "Adding a new member is not supported for this archive type"))))
;; -------------------------------------------------------------------------
;; Section: IO stuff

(defun archive-write-file-member ()
  (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)))

  (interactive "p")
  (or type (setq type ?D))
  (beginning-of-line)
  (let ((sign (if (>= p 0) +1 -1))
	(modified (buffer-modified-p))
        buffer-read-only)
    (while (not (zerop p))
      (if (archive-get-descr t)
          (progn
            (delete-char 1)
            (insert type)))
      (forward-line sign)
      (setq p (- p sign)))
    (set-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."

(defun archive-unmark-all-files ()
  "Remove all marks."
  (interactive)
  (let ((modified (buffer-modified-p))
	buffer-read-only)
    (save-excursion
      (goto-char archive-file-list-start)
      (while (< (point) archive-file-list-end)
        (or (= (following-char) ? )
            (progn (delete-char 1) (insert ? )))
        (forward-line 1)))
    (set-buffer-modified-p modified)))

(defun archive-mark (p)
  "In archive mode, mark this member for group operations.
With a prefix argument, mark that many members.
Use \\[archive-unmark-all-files] to remove all marks."

(defun archive-undo ()
  "Undo in an archive buffer.
This doesn't recover lost files, it just undoes changes in the buffer itself."
  (interactive)
  (let (buffer-read-only)
    (undo)))
;; -------------------------------------------------------------------------
;; Section: Arc Archives

(defun archive-arc-summarize ()

      (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)
    (save-restriction
      (save-excursion
	(widen)
	(set-buffer-multibyte nil)
	(goto-char (+ archive-proper-file-start (aref descr 4) 2))

      (let* ((p        (+ archive-proper-file-start (aref descr 4)))
	     (oldhsize (char-after p))
	     (oldfnlen (char-after (+ p 21)))
	     (newfnlen (length newname))
	     (newhsize (+ oldhsize newfnlen (- oldfnlen)))
	     buffer-read-only)
	(if (> newhsize 255)
	    (error "The file name is too long"))
	(goto-char (+ p 21))
	(delete-char (1+ oldfnlen))
	(insert newfnlen newname)

(defun archive-lzh-ogm (newval files errtxt ofs)
  (save-restriction
    (save-excursion
      (widen)
      (set-buffer-multibyte nil)
      (while files
	(let* ((fil (car files))
	       (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)
	  (if (= creator ?U)
	      (progn
		(or (numberp newval)
		    (setq newval (funcall newval (archive-l-e (+ p2 ofs) 2))))
		(goto-char (+ p2 ofs))

		(insert (logand newval 255) (lsh newval -8))
		(goto-char (1+ p))
		(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))))))

(defun archive-lzh-chown-entry (newuid files)
  (archive-lzh-ogm newuid files "an uid" 10))

(defun archive-lzh-chgrp-entry (newgid files)

(defun archive-zip-chmod-entry (newmode files)
  (save-restriction
    (save-excursion
      (widen)
      (set-buffer-multibyte nil)
      (while files
	(let* ((fil (car files))
	       (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)
	  (cond ((memq creator '(2 3)) ; Unix + VMS
		 (goto-char (+ p 40))
		 (delete-char 2)
		 (insert (logand newval 255) (lsh newval -8)))
		((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)))
		 (delete-char 1))
		(t (message "Don't know how to change mode for this member"))))
	(setq files (cdr files))))))
;; -------------------------------------------------------------------------
;; Section: Zoo Archives

(defun archive-zoo-summarize ()
  (let ((p (1+ (archive-l-e 25 4)))

63889:abe14daaa679

  :group 'archive-lzh)
;; ------------------------------
;; Zip archive configuration

(defcustom archive-zip-extract
  (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
expected to extract to a file junking the directory part of the name."
  :type '(list (string :tag "Program")

;; (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.

(defcustom archive-zip-expunge
  (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")
		(repeat :tag "Options"
			:inline t
			(string :format "%v")))
  :group 'archive-zip)

(defcustom archive-zip-update
  (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."
  :type '(list (string :tag "Program")
		(repeat :tag "Options"
			:inline t
			(string :format "%v")))
  :group 'archive-zip)

(defcustom archive-zip-update-case
  (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."
  :type '(list (string :tag "Program")
		(repeat :tag "Options"

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 ((inhibit-read-only t))
    (or shut-up
	(message "Parsing archive file..."))
    (buffer-disable-undo (current-buffer))
    (setq archive-files (funcall (archive-name "summarize")))
    (or shut-up

(defun archive-resummarize ()
  "Recreate the contents listing of an archive."
  (let ((modified (buffer-modified-p))
	(no (archive-get-lineno))
	(inhibit-read-only t))
    (widen)
    (delete-region (point-min) archive-proper-file-start)
    (archive-summarize t)
    (restore-buffer-modified-p modified)
    (goto-char archive-file-list-start)
    (archive-next-line no)))

(defun archive-summarize-files (files)
  "Insert a description of a list of files annotated with proper mouse face."

  (if archive-remote
      (let ((name archive-local-name)
	    (modified (buffer-modified-p))
	    (coding-system-for-read 'no-conversion)
	    (lno (archive-get-lineno))
	    (inhibit-read-only t))
	(if unchanged nil
	  (setq archive-files nil)
	  (erase-buffer)
	  (insert-file-contents name)
	  (archive-mode t)

      (if buffer
          nil
	(setq archive (archive-maybe-copy archive))
        (setq buffer (get-buffer-create bufname))
        (setq just-created t)
        (with-current-buffer buffer
          (setq buffer-file-name
                (expand-file-name (concat arcname ":" iname)))
          (setq buffer-file-truename
                (abbreviate-file-name buffer-file-name))
          ;; Set the default-directory to the dir of the superior buffer.

  (interactive
   (list (get-buffer
	  (read-buffer "Buffer containing archive: "
		       ;; Find first archive buffer and suggest that
		       (let ((bufs (buffer-list)))
			 (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")))
		       t))
	 (read-string "File name in archive: "
		      (if buffer-file-name
			  (file-name-nondirectory buffer-file-name)
			""))))
  (with-current-buffer arcbuf
    (or (eq major-mode 'archive-mode)
	(error "Buffer is not an archive buffer"))
    (if archive-read-only
	(error "Archive is read-only")))
  (if (eq arcbuf (current-buffer))
      (error "An archive buffer cannot be added to itself"))
  (if (string= name "")
      (error "Archive members may not be given empty names"))
  (let ((func (with-current-buffer arcbuf
                (archive-name "add-new-member")))
	(membuf (current-buffer)))
    (if (fboundp func)
	(with-current-buffer arcbuf
	  (funcall func buffer-file-name membuf name))
      (error "Adding a new member is not supported for this archive type"))))
;; -------------------------------------------------------------------------
;; Section: IO stuff

(defun archive-write-file-member ()
  (save-excursion
    (save-restriction
      (message "Updating archive...")
      (widen)
      (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
				       archive-subfile-mode
				       (symbol-value writer)))

  (interactive "p")
  (or type (setq type ?D))
  (beginning-of-line)
  (let ((sign (if (>= p 0) +1 -1))
	(modified (buffer-modified-p))
        (inhibit-read-only t))
    (while (not (zerop p))
      (if (archive-get-descr t)
          (progn
            (delete-char 1)
            (insert type)))
      (forward-line sign)
      (setq p (- p sign)))
    (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."

(defun archive-unmark-all-files ()
  "Remove all marks."
  (interactive)
  (let ((modified (buffer-modified-p))
	(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 ? )))
        (forward-line 1)))
    (restore-buffer-modified-p modified)))

(defun archive-mark (p)
  "In archive mode, mark this member for group operations.
With a prefix argument, mark that many members.
Use \\[archive-unmark-all-files] to remove all marks."

(defun archive-undo ()
  "Undo in an archive buffer.
This doesn't recover lost files, it just undoes changes in the buffer itself."
  (interactive)
  (let ((inhibit-read-only t))
    (undo)))
;; -------------------------------------------------------------------------
;; Section: Arc Archives

(defun archive-arc-summarize ()

      (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))))
	(inhibit-read-only t))
    (save-restriction
      (save-excursion
	(widen)
	(set-buffer-multibyte nil)
	(goto-char (+ archive-proper-file-start (aref descr 4) 2))

      (let* ((p        (+ archive-proper-file-start (aref descr 4)))
	     (oldhsize (char-after p))
	     (oldfnlen (char-after (+ p 21)))
	     (newfnlen (length newname))
	     (newhsize (+ oldhsize newfnlen (- oldfnlen)))
	     (inhibit-read-only t))
	(if (> newhsize 255)
	    (error "The file name is too long"))
	(goto-char (+ p 21))
	(delete-char (1+ oldfnlen))
	(insert newfnlen newname)

(defun archive-lzh-ogm (newval files errtxt ofs)
  (save-restriction
    (save-excursion
      (widen)
      (set-buffer-multibyte nil)
      (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))
	       (inhibit-read-only t))
	  (if (= creator ?U)
	      (progn
		(or (numberp newval)
		    (setq newval (funcall newval (archive-l-e (+ p2 ofs) 2))))
		(goto-char (+ p2 ofs))

		(insert (logand newval 255) (lsh newval -8))
		(goto-char (1+ p))
		(delete-char 1)
		(insert (archive-lzh-resum (1+ p) hsize)))
	    (message "Member %s does not have %s field"
		     (aref fil 1) errtxt)))))))

(defun archive-lzh-chown-entry (newuid files)
  (archive-lzh-ogm newuid files "an uid" 10))

(defun archive-lzh-chgrp-entry (newgid files)

(defun archive-zip-chmod-entry (newmode files)
  (save-restriction
    (save-excursion
      (widen)
      (set-buffer-multibyte nil)
      (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))
	       (inhibit-read-only t))
	  (cond ((memq creator '(2 3)) ; Unix + VMS
		 (goto-char (+ p 40))
		 (delete-char 2)
		 (insert (logand newval 255) (lsh newval -8)))
		((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)))
		 (delete-char 1))
		(t (message "Don't know how to change mode for this member"))))
        ))))
;; -------------------------------------------------------------------------
;; Section: Zoo Archives

(defun archive-zoo-summarize ()
  (let ((p (1+ (archive-l-e 25 4)))