root/trunk/lisp/arc-mode.el

;;; arc-mode.el --- simple editing of archives

;; Copyright (C) 1995, 1997, 1998, 2001, 2002, 2003, 2004,
;;   2005, 2006, 2007, 2008 Free Software Foundation, Inc.

;; Author: Morten Welinder <terra@gnu.org>
;; 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 3, 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., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Commentary:

;; NAMING: "arc" is short for "archive" and does not refer specifically
;; to files whose name end in ".arc"
;;
;; This code does not decode any files internally, although it does
;; understand the directory level of the archives.  For this reason,
;; you should expect this code to need more fiddling than tar-mode.el
;; (although it at present has fewer bugs :-)  In particular, I have
;; not tested this under Ms-Dog myself.
;; -------------------------------------
;; INTERACTION: arc-mode.el should play together with
;;
;; * ange-ftp.el: Remote archives (i.e., ones that ange-ftp has brought
;;                to you) are handled by doing all updates on a local
;;                copy.  When you make changes to a remote file the
;;                changes will first take effect when the archive buffer
;;                is saved.  You will be warned about this.
;;
;; * dos-fns.el:  (Part of Emacs 19).  You get automatic ^M^J <--> ^J
;;                conversion.
;;
;; arc-mode.el does not work well with crypt++.el; for the archives as
;; such this could be fixed (but wouldn't be useful) by declaring such
;; archives to be "remote".  For the members this is a general Emacs
;; problem that 19.29's file formats may fix.
;; -------------------------------------
;; ARCHIVE TYPES: Currently only the archives below are handled, but the
;; structure for handling just about anything is in place.
;;
;;                        Arc     Lzh     Zip     Zoo
;;                        --------------------------------
;; View listing           Intern  Intern  Intern  Intern
;; Extract member         Y       Y       Y       Y
;; Save changed member    Y       Y       Y       Y
;; Add new member         N       N       N       N
;; Delete member          Y       Y       Y       Y
;; Rename member          Y       Y       N       N
;; Chmod                  -       Y       Y       -
;; Chown                  -       Y       -       -
;; Chgrp                  -       Y       -       -
;;
;; Special thanks to Bill Brodie <wbrodie@panix.com> for very useful tips
;; on the first released version of this package.
;;
;; This code is partly based on tar-mode.el from Emacs.
;; -------------------------------------
;; ARCHIVE STRUCTURES:
;; (This is mostly for myself.)
;;
;; ARC         A series of (header,file).  No interactions among members.
;;
;; 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-
;;             central-dir record possibly followed by junk.  The e-o-c-d
;;             links to c-d.  cheaders link to lheaders which are basically
;;             cut-down versions of the cheaders.
;;
;; ZOO         An archive header followed by a series of (header,file).
;;             Each member header points to the next.  The archive is
;;             terminated by a bogus header with a zero next link.
;; -------------------------------------
;; HOOKS: `foo' means one of the supported archive types.
;;
;; archive-mode-hook
;; archive-foo-mode-hook
;; archive-extract-hooks

;;; Code:

;; -------------------------------------------------------------------------
;; Section: Configuration.

(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.
(defcustom archive-arc-extract
  '("arc" "x")
  "*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."
  :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."
  :type '(list (string :tag "Program")
                (repeat :tag "Options"
                        :inline t
                        (string :format "%v")))
  :group 'archive-arc)
;; ------------------------------
;; Lzh archive configuration

(defcustom archive-lzh-extract
  '("lha" "pq")
  "*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."
  :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."
  :type '(list (string :tag "Program")
                (repeat :tag "Options"
                        :inline t
                        (string :format "%v")))
  :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."
  :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.

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

(defcustom archive-zoo-extract
  '("zoo" "xpq")
  "*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."
  :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."
  :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-local-name nil "Name of local copy of remote archive.")
(defvar archive-mode-map
  (let ((map (make-keymap)))
    (suppress-keymap map)
    (define-key map " " 'archive-next-line)
    (define-key map "a" 'archive-alternate-display)
    ;;(define-key map "c" 'archive-copy)
    (define-key map "d" 'archive-flag-deleted)
    (define-key map "\C-d" 'archive-flag-deleted)
    (define-key map "e" 'archive-extract)
    (define-key map "f" 'archive-extract)
    (define-key map "\C-m" 'archive-extract)
    (define-key map "g" 'revert-buffer)
    (define-key map "h" 'describe-mode)
    (define-key map "m" 'archive-mark)
    (define-key map "n" 'archive-next-line)
    (define-key map "\C-n" 'archive-next-line)
    (define-key map [down] 'archive-next-line)
    (define-key map "o" 'archive-extract-other-window)
    (define-key map "p" 'archive-previous-line)
    (define-key map "q" 'quit-window)
    (define-key map "\C-p" 'archive-previous-line)
    (define-key map [up] 'archive-previous-line)
    (define-key map "r" 'archive-rename-entry)
    (define-key map "u" 'archive-unflag)
    (define-key map "\M-\C-?" 'archive-unmark-all-files)
    (define-key map "v" 'archive-view)
    (define-key map "x" 'archive-expunge)
    (define-key map "\177" 'archive-unflag-backwards)
    (define-key map "E" 'archive-extract-other-window)
    (define-key map "M" 'archive-chmod-entry)
    (define-key map "G" 'archive-chgrp-entry)
    (define-key map "O" 'archive-chown-entry)

    (if (fboundp 'command-remapping)
        (progn
          (define-key map [remap advertised-undo] 'archive-undo)
          (define-key map [remap undo] 'archive-undo))
      (substitute-key-definition 'advertised-undo 'archive-undo map global-map)
      (substitute-key-definition 'undo 'archive-undo map global-map))

    (define-key map
      (if (featurep 'xemacs) 'button2 [mouse-2]) 'archive-extract)

    (if (featurep 'xemacs)
        ()                              ; out of luck

      (define-key map [menu-bar immediate]
        (cons "Immediate" (make-sparse-keymap "Immediate")))
      (define-key map [menu-bar immediate alternate]
        '(menu-item "Alternate Display" archive-alternate-display
          :enable (boundp (archive-name "alternate-display"))
          :help "Toggle alternate file info display"))
      (define-key map [menu-bar immediate view]
        '(menu-item "View This File" archive-view
          :help "Display file at cursor in View Mode"))
      (define-key map [menu-bar immediate display]
        '(menu-item "Display in Other Window" archive-display-other-window
          :help "Display file at cursor in another window"))
      (define-key map [menu-bar immediate find-file-other-window]
        '(menu-item "Find in Other Window" archive-extract-other-window
          :help "Edit file at cursor in another window"))
      (define-key map [menu-bar immediate find-file]
        '(menu-item "Find This File" archive-extract
          :help "Extract file at cursor and edit it"))

      (define-key map [menu-bar mark]
        (cons "Mark" (make-sparse-keymap "Mark")))
      (define-key map [menu-bar mark unmark-all]
        '(menu-item "Unmark All" archive-unmark-all-files
          :help "Unmark all marked files"))
      (define-key map [menu-bar mark deletion]
        '(menu-item "Flag" archive-flag-deleted
          :help "Flag file at cursor for deletion"))
      (define-key map [menu-bar mark unmark]
        '(menu-item "Unflag" archive-unflag
          :help "Unmark file at cursor"))
      (define-key map [menu-bar mark mark]
        '(menu-item "Mark" archive-mark
          :help "Mark file at cursor"))

      (define-key map [menu-bar operate]
        (cons "Operate" (make-sparse-keymap "Operate")))
      (define-key map [menu-bar operate chown]
        '(menu-item "Change Owner..." archive-chown-entry
          :enable (fboundp (archive-name "chown-entry"))
          :help "Change owner of marked files"))
      (define-key map [menu-bar operate chgrp]
        '(menu-item "Change Group..." archive-chgrp-entry
          :enable (fboundp (archive-name "chgrp-entry"))
          :help "Change group ownership of marked files"))
      (define-key map [menu-bar operate chmod]
        '(menu-item "Change Mode..." archive-chmod-entry
          :enable (fboundp (archive-name "chmod-entry"))
          :help "Change mode (permissions) of marked files"))
      (define-key map [menu-bar operate rename]
        '(menu-item "Rename to..." archive-rename-entry
          :enable (fboundp (archive-name "rename-entry"))
          :help "Rename marked files"))
      ;;(define-key map [menu-bar operate copy]
      ;;  '(menu-item "Copy to..." archive-copy))
      (define-key map [menu-bar operate expunge]
        '(menu-item "Expunge Marked Files" archive-expunge
          :help "Delete all flagged files from archive"))
      map))
  "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.")
(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.")
(put 'archive-superior-buffer 'permanent-local t)

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

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

;; -------------------------------------------------------------------------
;; Section: Support functions.

(defsubst archive-name (suffix)
  (intern (concat "archive-" (symbol-name archive-subtype) "-" suffix)))

(defun archive-l-e (str &optional len float)
  "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.
FLOAT, if non-nil, means generate and return a float instead of an integer
\(use this for numbers that can overflow the Emacs integer)."
  (if (stringp str)
      (setq len (length str))
    (setq str (buffer-substring str (+ str len))))
  (let ((result 0)
        (i 0))
    (while (< i len)
      (setq i (1+ i)
            result (+ (if float (* result 256.0) (ash result 8))
                      (aref str (- len i)))))
    result))

(defun archive-int-to-mode (mode)
  "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.
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
OLDMODE will be modified accordingly just like chmod(2) would have done.\n
If optional third argument ERROR is non-nil an error will be signaled if
the mode is invalid.  If ERROR is nil then nil will be returned."
  (cond ((string-match "^0[0-7]*$" newmode)
         (let ((result 0)
               (len (length newmode))
               (i 1))
           (while (< i len)
             (setq result (+ (lsh result 3) (aref newmode i) (- ?0))
                   i (1+ i)))
           (logior (logand oldmode 65024) result)))
        ((string-match "^\\([agou]+\\)\\([---+=]\\)\\([rwxst]+\\)$" newmode)
         (let ((who 0)
               (result oldmode)
               (op (aref newmode (match-beginning 2)))
               (bits 0)
               (i (match-beginning 3)))
           (while (< i (match-end 3))
             (let ((rwx (aref newmode i)))
               (setq bits (logior bits (cond ((= rwx ?r)  292)
                                             ((= rwx ?w)  146)
                                             ((= rwx ?x)   73)
                                             ((= rwx ?s) 3072)
                                             ((= rwx ?t)  512)))
                     i (1+ i))))
           (while (< who (match-end 1))
             (let* ((whoc (aref newmode who))
                    (whomask (cond ((= whoc ?a) 4095)
                                   ((= whoc ?u) 1472)
                                   ((= whoc ?g) 2104)
                                   ((= whoc ?o)    7))))
               (if (= op ?=)
                   (setq result (logand result (lognot whomask))))
               (if (= op ?-)
                   (setq result (logand result (lognot (logand whomask bits))))
                 (setq result (logior result (logand whomask bits)))))
             (setq who (1+ who)))
           result))
        (t
         (if error
             (error "Invalid mode specification: %s" newmode)))))

(defun archive-dosdate (date)
  "Stringify dos packed DATE record."
  (let ((year (+ 1980 (logand (ash date -9) 127)))
        (month (logand (ash date -5) 15))
        (day (logand date 31)))
    (if (or (> month 12) (< month 1))
        ""
      (format "%2d-%s-%d"
              day
              (aref ["Jan" "Feb" "Mar" "Apr" "May" "Jun"
                     "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"] (1- month))
              year))))

(defun archive-dostime (time)
  "Stringify dos packed TIME record."
  (let ((hour (logand (ash time -11) 31))
        (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 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-get-lineno ()
  (if (>= (point) archive-file-list-start)
      (count-lines archive-file-list-start
                   (save-excursion (beginning-of-line) (point)))
    0))

(defun archive-get-descr (&optional noerror)
  "Return the descriptor vector for file at point.
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)))
        (let ((item (aref archive-files no)))
          (if (vectorp item)
              item
            (if (not noerror)
                (error "Entry is not a regular member of the archive"))))
      (if (not noerror)
          (error "Line does not describe a member of the archive")))))
;; -------------------------------------------------------------------------
;; Section: the mode definition

;;;###autoload
(defun archive-mode (&optional force)
  "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.

If you edit a sub-file of this archive (as with the `e' command) and
save it, the contents of that buffer will be saved back into the
archive.

\\{archive-mode-map}"
  ;; This is not interactive because you shouldn't be turning this
  ;; 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)
    (if (and (not force) archive-files) nil
      (let* ((type (archive-find-type))
             (typename (capitalize (symbol-name type))))
        (kill-all-local-variables)
        (make-local-variable 'archive-subtype)
        (setq archive-subtype type)

        ;; Buffer contains treated image of file before the file contents
        (make-local-variable 'revert-buffer-function)
        (setq revert-buffer-function 'archive-mode-revert)
        (auto-save-mode 0)

        ;; Remote archives are not written by a hook.
        (if archive-remote nil
          (add-hook 'write-contents-functions 'archive-write-file nil t))

        (make-local-variable 'require-final-newline)
        (setq require-final-newline nil)
        (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)
        ;; 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)

        ;; 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"))
        ;; Run archive-foo-mode-hook and 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)
      (make-local-variable 'archive-file-list-start)
      (make-local-variable 'archive-file-list-end)
      (make-local-variable 'archive-file-name-indent)
      (archive-summarize nil)
      (setq buffer-read-only t))))

;; Archive mode is suitable only for specially formatted data.
(put 'archive-mode 'mode-class 'special)

(let ((item1 '(archive-subfile-mode " Archive")))
  (or (member item1 minor-mode-alist)
      (setq minor-mode-alist (cons item1 minor-mode-alist))))
;; -------------------------------------------------------------------------
(defun archive-find-type ()
  (widen)
  (goto-char (point-min))
  ;; 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)
          ((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)
          ;; This pattern modelled 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)
          (t (error "Buffer format not recognized")))))
;; -------------------------------------------------------------------------
(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).
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
        (message "Parsing archive file...done."))
    (setq archive-proper-file-start (point-marker))
    (narrow-to-region (point-min) (point))
    (set-buffer-modified-p nil)
    (buffer-enable-undo))
  (goto-char archive-file-list-start)
  (archive-next-line 0))

(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."
  (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
  ;; long when the archive -- which has to be moved in memory -- is large.
  (insert
   (apply
    (function concat)
    (mapcar
     (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