cgit.sxemacs.org Git - packages/blob - xemacs-packages/os-utils/arc-mode.el

   1 ;;; arc-mode.el --- simple editing of archives
   2
   3 ;; Copyright (C) 1995, 1997 Free Software Foundation, Inc.
   4
   5 ;; Author: Morten Welinder <terra@diku.dk>
   6 ;; Keywords: archives msdog editing major-mode
   7 ;; Favourite-brand-of-beer: None, I hate beer.
   8
   9 ;; This file is part of XEmacs.
  10
  11 ;; XEmacs is free software; you can redistribute it and/or modify it
  12 ;; under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; XEmacs is distributed in the hope that it will be useful, but
  17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  19 ;; General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  23 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  24 ;; 02111-1307, USA.
  25
  26 ;;; Synched up with: GNU Emacs 20.2, with differences in comparing chars with
  27 ;;; `eq' instead of `=', and applying `char-int' to various `memq's, and
  28 ;;; using #o instead of ?\ for octal numbers.  See also inline comments.
  29
  30 ;;; Commentary:
  31
  32 ;; NAMING: "arc" is short for "archive" and does not refer specifically
  33 ;; to files whose name end in ".arc"
  34 ;;
  35 ;; This code does not decode any files internally, although it does
  36 ;; understand the directory level of the archives.  For this reason,
  37 ;; you should expect this code to need more fiddling than tar-mode.el
  38 ;; (although it at present has fewer bugs :-)  In particular, I have
  39 ;; not tested this under Ms-Dog myself.
  40 ;; -------------------------------------
  41 ;; INTERACTION: arc-mode.el should play together with
  42 ;;
  43 ;; * ange-ftp.el: Remote archives (i.e., ones that ange-ftp has brought
  44 ;;                to you) are handled by doing all updates on a local
  45 ;;                copy.  When you make changes to a remote file the
  46 ;;                changes will first take effect when the archive buffer
  47 ;;                is saved.  You will be warned about this.
  48 ;;
  49 ;; * dos-fns.el:  (Part of Emacs 19).  You get automatic ^M^J <--> ^J
  50 ;;                conversion.
  51 ;;
  52 ;; arc-mode.el does not work well with crypt++.el; for the archives as
  53 ;; such this could be fixed (but wouldn't be useful) by declaring such
  54 ;; archives to be "remote".  For the members this is a general Emacs
  55 ;; problem that 19.29's file formats may fix.
  56 ;; -------------------------------------
  57 ;; ARCHIVE TYPES: Currently only the archives below are handled, but the
  58 ;; structure for handling just about anything is in place.
  59 ;;
  60 ;;                        Arc     Lzh     Zip     Zoo
  61 ;;                        --------------------------------
  62 ;; View listing           Intern  Intern  Intern  Intern
  63 ;; Extract member         Y       Y       Y       Y
  64 ;; Save changed member    Y       Y       Y       Y
  65 ;; Add new member         N       N       N       N
  66 ;; Delete member          Y       Y       Y       Y
  67 ;; Rename member          Y       Y       N       N
  68 ;; Chmod                  -       Y       Y       -
  69 ;; Chown                  -       Y       -       -
  70 ;; Chgrp                  -       Y       -       -
  71 ;;
  72 ;; Special thanks to Bill Brodie <wbrodie@panix.com> for very useful tips
  73 ;; on the first released version of this package.
  74 ;;
  75 ;; This code is partly based on tar-mode.el from Emacs.
  76 ;; -------------------------------------
  77 ;; ARCHIVE STRUCTURES:
  78 ;; (This is mostly for myself.)
  79 ;;
  80 ;; ARC         A series of (header,file).  No interactions among members.
  81 ;;
  82 ;; LZH         A series of (header,file).  Headers are checksummed.  No
  83 ;;             interaction among members.
  84 ;;
  85 ;; ZIP         A series of (lheader,fil) followed by a "central directory"
  86 ;;             which is a series of (cheader) followed by an end-of-
  87 ;;             central-dir record possibly followed by junk.  The e-o-c-d
  88 ;;             links to c-d.  cheaders link to lheaders which are basically
  89 ;;             cut-down versions of the cheaders.
  90 ;;
  91 ;; ZOO         An archive header followed by a series of (header,file).
  92 ;;             Each member header points to the next.  The archive is
  93 ;;             terminated by a bogus header with a zero next link.
  94 ;; -------------------------------------
  95 ;; HOOKS: `foo' means one of the supported archive types.
  96 ;;
  97 ;; archive-mode-hook
  98 ;; archive-foo-mode-hook
  99 ;; archive-extract-hooks
 100
 101 ;;; Code:
 102
 103 ;; -------------------------------------------------------------------------
 104 ;; Section: Configuration.
 105
 106 (defgroup archive nil
 107   "Simple editing of archives."
 108   :group 'data)
 109
 110 (defgroup archive-arc nil
 111   "ARC-specific options to archive."
 112   :group 'archive)
 113
 114 (defgroup archive-lzh nil
 115   "LZH-specific options to archive."
 116   :group 'archive)
 117
 118 (defgroup archive-zip nil
 119   "ZIP-specific options to archive."
 120   :group 'archive)
 121
 122 (defgroup archive-zoo nil
 123   "ZOO-specific options to archive."
 124   :group 'archive)
 125
 126
 127 (defcustom archive-dos-members t
 128   "*If non-nil then recognize member files using ^M^J as line terminator."
 129   :type 'boolean
 130   :group 'archive)
 131
 132 (defcustom archive-tmpdir
 133   (expand-file-name
 134    (make-temp-name (if (eq system-type 'ms-dos) "ar" "archive.tmp"))
 135    (or (getenv "TMPDIR") (getenv "TMP") "/tmp"))
 136   "*Directory for temporary files made by arc-mode.el"
 137   :type 'directory
 138   :group 'archive)
 139
 140 (defcustom archive-remote-regexp "^/[^/:]*[^/:.]:"
 141   "*Regexp recognizing archive files names that are not local.
 142 A non-local file is one whose file name is not proper outside Emacs.
 143 A local copy of the archive will be used when updating."
 144   :type 'regexp
 145   :group 'archive)
 146
 147 (defcustom archive-extract-hooks nil
 148   "*Hooks to run when an archive member has been extracted."
 149   :type 'hook
 150   :group 'archive)
 151 ;; ------------------------------
 152 ;; Arc archive configuration
 153
 154 ;; We always go via a local file since there seems to be no reliable way
 155 ;; to extract to stdout without junk getting added.
 156 (defcustom archive-arc-extract
 157   '("arc" "x")
 158   "*Program and its options to run in order to extract an arc file member.
 159 Extraction should happen to the current directory.  Archive and member
 160 name will be added."
 161   :type '(list (string :tag "Program")
 162                 (repeat :tag "Options"
 163                         :inline t
 164                         (string :format "%v")))
 165   :group 'archive-arc)
 166
 167 (defcustom archive-arc-expunge
 168   '("arc" "d")
 169   "*Program and its options to run in order to delete arc file members.
 170 Archive and member names will be added."
 171   :type '(list (string :tag "Program")
 172                 (repeat :tag "Options"
 173                         :inline t
 174                         (string :format "%v")))
 175   :group 'archive-arc)
 176
 177 (defcustom archive-arc-write-file-member
 178   '("arc" "u")
 179   "*Program and its options to run in order to update an arc file member.
 180 Archive and member name will be added."
 181   :type '(list (string :tag "Program")
 182                 (repeat :tag "Options"
 183                         :inline t
 184                         (string :format "%v")))
 185   :group 'archive-arc)
 186 ;; ------------------------------
 187 ;; Lzh archive configuration
 188
 189 (defcustom archive-lzh-extract
 190   '("lha" "pq")
 191   "*Program and its options to run in order to extract an lzh file member.
 192 Extraction should happen to standard output.  Archive and member name will
 193 be added."
 194   :type '(list (string :tag "Program")
 195                 (repeat :tag "Options"
 196                         :inline t
 197                         (string :format "%v")))
 198   :group 'archive-lzh)
 199
 200 (defcustom archive-lzh-expunge
 201   '("lha" "d")
 202   "*Program and its options to run in order to delete lzh file members.
 203 Archive and member names will be added."
 204   :type '(list (string :tag "Program")
 205                 (repeat :tag "Options"
 206                         :inline t
 207                         (string :format "%v")))
 208   :group 'archive-lzh)
 209
 210 (defcustom archive-lzh-write-file-member
 211   '("lha" "a")
 212   "*Program and its options to run in order to update an lzh file member.
 213 Archive and member name will be added."
 214   :type '(list (string :tag "Program")
 215                 (repeat :tag "Options"
 216                         :inline t
 217                         (string :format "%v")))
 218   :group 'archive-lzh)
 219 ;; ------------------------------
 220 ;; Zip archive configuration
 221
 222 (defcustom archive-zip-use-pkzip (memq system-type '(ms-dos windows-nt))
 223   "*If non-nil then pkzip option are used instead of zip options.
 224 Only set to true for msdog systems!"
 225   :type 'boolean
 226   :group 'archive-zip)
 227
 228 (defcustom archive-zip-extract
 229   (if archive-zip-use-pkzip '("pkunzip" "-e") '("unzip" "-qq" "-c"))
 230   "*Program and its options to run in order to extract a zip file member.
 231 Extraction should happen to standard output.  Archive and member name will
 232 be added.  If `archive-zip-use-pkzip' is non-nil then this program is
 233 expected to extract to a file junking the directory part of the name."
 234   :type '(list (string :tag "Program")
 235                 (repeat :tag "Options"
 236                         :inline t
 237                         (string :format "%v")))
 238   :group 'archive-zip)
 239
 240 ;; For several reasons the latter behaviour is not desirable in general.
 241 ;; (1) It uses more disk space.  (2) Error checking is worse or non-
 242 ;; existent.  (3) It tends to do funny things with other systems' file
 243 ;; names.
 244
 245 (defcustom archive-zip-expunge
 246   (if archive-zip-use-pkzip '("pkzip" "-d") '("zip" "-d" "-q"))
 247   "*Program and its options to run in order to delete zip file members.
 248 Archive and member names will be added."
 249   :type '(list (string :tag "Program")
 250                 (repeat :tag "Options"
 251                         :inline t
 252                         (string :format "%v")))
 253   :group 'archive-zip)
 254
 255 (defcustom archive-zip-update
 256   (if archive-zip-use-pkzip '("pkzip" "-u") '("zip" "-q"))
 257   "*Program and its options to run in order to update a zip file member.
 258 Options should ensure that specified directory will be put into the zip
 259 file.  Archive and member name will be added."
 260   :type '(list (string :tag "Program")
 261                 (repeat :tag "Options"
 262                         :inline t
 263                         (string :format "%v")))
 264   :group 'archive-zip)
 265
 266 (defcustom archive-zip-update-case
 267   (if archive-zip-use-pkzip archive-zip-update '("zip" "-q" "-k"))
 268   "*Program and its options to run in order to update a case fiddled zip member.
 269 Options should ensure that specified directory will be put into the zip file.
 270 Archive and member name will be added."
 271   :type '(list (string :tag "Program")
 272                 (repeat :tag "Options"
 273                         :inline t
 274                         (string :format "%v")))
 275   :group 'archive-zip)
 276
 277 (defcustom archive-zip-case-fiddle t
 278   "*If non-nil then zip file members are case fiddled.
 279 Case fiddling will only happen for members created by a system that
 280 uses caseless file names."
 281   :type 'boolean
 282   :group 'archive-zip)
 283 ;; ------------------------------
 284 ;; Zoo archive configuration
 285
 286 (defcustom archive-zoo-extract
 287   '("zoo" "xpq")
 288   "*Program and its options to run in order to extract a zoo file member.
 289 Extraction should happen to standard output.  Archive and member name will
 290 be added."
 291   :type '(list (string :tag "Program")
 292                 (repeat :tag "Options"
 293                         :inline t
 294                         (string :format "%v")))
 295   :group 'archive-zoo)
 296
 297 (defcustom archive-zoo-expunge
 298   '("zoo" "DqPP")
 299   "*Program and its options to run in order to delete zoo file members.
 300 Archive and member names will be added."
 301   :type '(list (string :tag "Program")
 302                 (repeat :tag "Options"
 303                         :inline t
 304                         (string :format "%v")))
 305   :group 'archive-zoo)
 306
 307 (defcustom archive-zoo-write-file-member
 308   '("zoo" "a")
 309   "*Program and its options to run in order to update a zoo file member.
 310 Archive and member name will be added."
 311   :type '(list (string :tag "Program")
 312                 (repeat :tag "Options"
 313                         :inline t
 314                         (string :format "%v")))
 315   :group 'archive-zoo)
 316 ;; -------------------------------------------------------------------------
 317 ;; Section: Variables
 318
 319 (defvar archive-subtype nil "*Symbol describing archive type.")
 320 (defvar archive-file-list-start nil "*Position of first contents line.")
 321 (defvar archive-file-list-end nil "*Position just after last contents line.")
 322 (defvar archive-proper-file-start nil "*Position of real archive's start.")
 323 (defvar archive-read-only nil "*Non-nil if the archive is read-only on disk.")
 324 (defvar archive-remote nil "*Non-nil if the archive is outside file system.")
 325 (defvar archive-local-name nil "*Name of local copy of remote archive.")
 326 (defvar archive-mode-map nil "*Local keymap for archive mode listings.")
 327 (defvar archive-file-name-indent nil "*Column where file names start.")
 328
 329 (defvar archive-alternate-display nil
 330   "*Non-nil when alternate information is shown.")
 331 (make-variable-buffer-local 'archive-alternate-display)
 332 (put 'archive-alternate-display 'permanent-local t)
 333
 334 (defvar archive-superior-buffer nil "*In archive members, points to archive.")
 335 (put 'archive-superior-buffer 'permanent-local t)
 336
 337 (defvar archive-subfile-mode nil "*Non-nil in archive member buffers.")
 338 (make-variable-buffer-local 'archive-subfile-mode)
 339 (put 'archive-subfile-mode 'permanent-local t)
 340
 341 (defvar archive-subfile-dos nil
 342   "Negation of `buffer-file-type', which see.")
 343 (make-variable-buffer-local 'archive-subfile-dos)
 344 (put 'archive-subfile-dos 'permanent-local t)
 345
 346 (defvar archive-files nil
 347   "Vector of file descriptors.
 348 Each descriptor is a vector of the form
 349  [EXT-FILE-NAME INT-FILE-NAME CASE-FIDDLED MODE ...]")
 350 (make-variable-buffer-local 'archive-files)
 351
 352 ;; XEmacs change: `archive-lemacs' removed, `running-xemacs' used instead.
 353
 354 ;; -------------------------------------------------------------------------
 355 ;; Section: Support functions.
 356
 357 (defsubst archive-name (suffix)
 358   (intern (concat "archive-" (symbol-name archive-subtype) "-" suffix)))
 359
 360 (defun archive-l-e (str &optional len)
 361   "Convert little endian string/vector to integer.
 362 Alternatively, first argument may be a buffer position in the current buffer
 363 in which case a second argument, length, should be supplied."
 364   (if (stringp str)
 365       (setq len (length str))
 366     (setq str (buffer-substring str (+ str len))))
 367   (let ((result 0)
 368         (i 0))
 369     (while (< i len)
 370       (setq i (1+ i)
 371             result (+ (ash result 8) (aref str (- len i)))))
 372     result))
 373
 374 (defun archive-int-to-mode (mode)
 375   "Turn an integer like 0700 (i.e., 448) into a mode string like -rwx------"
 376   (let ((str (make-string 10 ?-)))
 377     (or (zerop (logand 16384 mode)) (aset str 0 ?d))
 378     (or (zerop (logand  8192 mode)) (aset str 0 ?c)) ; completeness
 379     (or (zerop (logand   256 mode)) (aset str 1 ?r))
 380     (or (zerop (logand   128 mode)) (aset str 2 ?w))
 381     (or (zerop (logand    64 mode)) (aset str 3 ?x))
 382     (or (zerop (logand    32 mode)) (aset str 4 ?r))
 383     (or (zerop (logand    16 mode)) (aset str 5 ?w))
 384     (or (zerop (logand     8 mode)) (aset str 6 ?x))
 385     (or (zerop (logand     4 mode)) (aset str 7 ?r))
 386     (or (zerop (logand     2 mode)) (aset str 8 ?w))
 387     (or (zerop (logand     1 mode)) (aset str 9 ?x))
 388     (or (zerop (logand  1024 mode)) (aset str 3 (if (zerop (logand 64 mode))
 389                                                     ?S ?s)))
 390     (or (zerop (logand  2048 mode)) (aset str 6 (if (zerop (logand  8 mode))
 391                                                     ?S ?s)))
 392     str))
 393
 394 (defun archive-calc-mode (oldmode newmode &optional error)
 395   "From the integer OLDMODE and the string NEWMODE calculate a new file mode.
 396 NEWMODE may be an octal number including a leading zero in which case it
 397 will become the new mode.\n
 398 NEWMODE may also be a relative specification like \"og-rwx\" in which case
 399 OLDMODE will be modified accordingly just like chmod(2) would have done.\n
 400 If optional third argument ERROR is non-nil an error will be signaled if
 401 the mode is invalid.  If ERROR is nil then nil will be returned."
 402   (cond ((string-match "^0[0-7]*$" newmode)
 403          (let ((result 0)
 404                (len (length newmode))
 405                (i 1))
 406            (while (< i len)
 407              (setq result (+ (lsh result 3) (aref newmode i) (- ?0))
 408                    i (1+ i)))
 409            (logior (logand oldmode 65024) result)))
 410         ((string-match "^\\([agou]+\\)\\([---+=]\\)\\([rwxst]+\\)$" newmode)
 411          (let ((who 0)
 412                (result oldmode)
 413                (op (aref newmode (match-beginning 2)))
 414                (bits 0)
 415                (i (match-beginning 3)))
 416            (while (< i (match-end 3))
 417              (let ((rwx (aref newmode i)))
 418                (setq bits (logior bits (cond ((= rwx ?r)  292)
 419                                              ((= rwx ?w)  146)
 420                                              ((= rwx ?x)   73)
 421                                              ((= rwx ?s) 3072)
 422                                              ((= rwx ?t)  512)))
 423                      i (1+ i))))
 424            (while (< who (match-end 1))
 425              (let* ((whoc (aref newmode who))
 426                     (whomask (cond ((= whoc ?a) 4095)
 427                                    ((= whoc ?u) 1472)
 428                                    ((= whoc ?g) 2104)
 429                                    ((= whoc ?o)    7))))
 430                (if (= op ?=)
 431                    (setq result (logand result (lognot whomask))))
 432                (if (= op ?-)
 433                    (setq result (logand result (lognot (logand whomask bits))))
 434                  (setq result (logior result (logand whomask bits)))))
 435              (setq who (1+ who)))
 436            result))
 437         (t
 438          (if error
 439              (error "Invalid mode specification: %s" newmode)))))
 440
 441 (defun archive-dosdate (date)
 442   "Stringify dos packed DATE record."
 443   (let ((year (+ 1980 (logand (ash date -9) 127)))
 444         (month (logand (ash date -5) 15))
 445         (day (logand date 31)))
 446     (if (or (> month 12) (< month 1))
 447         ""
 448       (format "%2d-%s-%d"
 449               day
 450               (aref ["Jan" "Feb" "Mar" "Apr" "May" "Jun"
 451                      "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"] (1- month))
 452               year))))
 453
 454 (defun archive-dostime (time)
 455   "Stringify dos packed TIME record."
 456   (let ((hour (logand (ash time -11) 31))
 457         (minute (logand (ash time -5) 53))
 458         (second (* 2 (logand time 31)))) ; 2 seconds resolution
 459     (format "%02d:%02d:%02d" hour minute second)))
 460
 461 ;;(defun archive-unixdate (low high)
 462 ;;  "Stringify unix (LOW HIGH) date."
 463 ;;  (let ((str (current-time-string (cons high low))))
 464 ;;    (format "%s-%s-%s"
 465 ;;          (substring str 8 9)
 466 ;;          (substring str 4 7)
 467 ;;          (substring str 20 24))))
 468
 469 ;;(defun archive-unixtime (low high)
 470 ;;  "Stringify unix (LOW HIGH) time."
 471 ;;  (let ((str (current-time-string (cons high low))))
 472 ;;    (substring str 11 19)))
 473
 474 (defun archive-get-lineno ()
 475   (if (>= (point) archive-file-list-start)
 476       (count-lines archive-file-list-start
 477                    (save-excursion (beginning-of-line) (point)))
 478     0))
 479
 480 (defun archive-get-descr (&optional noerror)
 481   "Return the descriptor vector for file at point.
 482 Does not signal an error if optional second argument NOERROR is non-nil."
 483   (let ((no (archive-get-lineno)))
 484     (if (and (>= (point) archive-file-list-start)
 485              (< no (length archive-files)))
 486         (let ((item (aref archive-files no)))
 487           (if (vectorp item)
 488               item
 489             (if (not noerror)
 490                 (error "Entry is not a regular member of the archive"))))
 491       (if (not noerror)
 492           (error "Line does not describe a member of the archive")))))
 493 ;; -------------------------------------------------------------------------
 494 ;; Section: the mode definition
 495
 496 ;;;###autoload
 497 (defun archive-mode (&optional force)
 498   "Major mode for viewing an archive file in a dired-like way.
 499 You can move around using the usual cursor motion commands.
 500 Letters no longer insert themselves.
 501 Type `e' to pull a file out of the archive and into its own buffer;
 502 or click mouse-2 on the file's line in the archive mode buffer.
 503
 504 If you edit a sub-file of this archive (as with the `e' command) and
 505 save it, the contents of that buffer will be saved back into the
 506 archive.
 507
 508 \\{archive-mode-map}"
 509   ;; This is not interactive because you shouldn't be turning this
 510   ;; mode on and off.  You can corrupt things that way.
 511   (if (zerop (buffer-size))
 512       ;; At present we cannot create archives from scratch
 513       (funcall default-major-mode)
 514     (if (and (not force) archive-files) nil
 515       (let* ((type (archive-find-type))
 516              (typename (copy-sequence (symbol-name type))))
 517         (aset typename 0 (upcase (aref typename 0)))
 518         (kill-all-local-variables)
 519         (make-local-variable 'archive-subtype)
 520         (setq archive-subtype type)
 521
 522         ;; Buffer contains treated image of file before the file contents
 523         (make-local-variable 'revert-buffer-function)
 524         (setq revert-buffer-function 'archive-mode-revert)
 525         (auto-save-mode 0)
 526         (make-local-variable 'local-write-file-hooks)
 527         (add-hook 'local-write-file-hooks 'archive-write-file)
 528
 529         ;; Real file contents is binary
 530         (make-local-variable 'require-final-newline)
 531         (setq require-final-newline nil)
 532         (make-local-variable 'enable-local-variables)
 533         (setq enable-local-variables nil)
 534         (if (boundp 'default-buffer-file-type)
 535             (setq buffer-file-type t))
 536
 537         (make-local-variable 'archive-read-only)
 538         (setq archive-read-only (not (file-writable-p (buffer-file-name))))
 539
 540         ;; Should we use a local copy when accessing from outside Emacs?
 541         (make-local-variable 'archive-local-name)
 542         (make-local-variable 'archive-remote)
 543         (setq archive-remote (string-match archive-remote-regexp
 544                                            (buffer-file-name)))
 545
 546         (setq major-mode 'archive-mode)
 547         (setq mode-name (concat typename "-Archive"))
 548         ;; Run archive-foo-mode-hook and archive-mode-hook
 549         (run-hooks (archive-name "mode-hook") 'archive-mode-hook)
 550         (use-local-map archive-mode-map))
 551
 552       (make-local-variable 'archive-proper-file-start)
 553       (make-local-variable 'archive-file-list-start)
 554       (make-local-variable 'archive-file-list-end)
 555       (make-local-variable 'archive-file-name-indent)
 556       (archive-summarize)
 557       (setq buffer-read-only t))))
 558
 559 ;; Archive mode is suitable only for specially formatted data.
 560 (put 'archive-mode 'mode-class 'special)
 561
 562 ;; XEmacs addition
 563 (defun archive-quit ()
 564   "Bury the current archive buffer."
 565   (interactive)
 566   (bury-buffer))
 567
 568 ;; -------------------------------------------------------------------------
 569 ;; Section: Key maps
 570
 571 (if archive-mode-map nil
 572   (setq archive-mode-map (make-keymap))
 573   (suppress-keymap archive-mode-map)
 574   (define-key archive-mode-map " " 'archive-next-line)
 575   (define-key archive-mode-map "a" 'archive-alternate-display)
 576   ;;(define-key archive-mode-map "c" 'archive-copy)
 577   (define-key archive-mode-map "d" 'archive-flag-deleted)
 578   (define-key archive-mode-map "\C-d" 'archive-flag-deleted)
 579   (define-key archive-mode-map "e" 'archive-extract)
 580   (define-key archive-mode-map "f" 'archive-extract)
 581   (define-key archive-mode-map "\C-m" 'archive-extract)
 582   (define-key archive-mode-map "g" 'revert-buffer)
 583   (define-key archive-mode-map "h" 'describe-mode)
 584   (define-key archive-mode-map "m" 'archive-mark)
 585   (define-key archive-mode-map "n" 'archive-next-line)
 586   (define-key archive-mode-map "\C-n" 'archive-next-line)
 587   (define-key archive-mode-map [down] 'archive-next-line)
 588   (define-key archive-mode-map "o" 'archive-extract-other-window)
 589   (define-key archive-mode-map "p" 'archive-previous-line)
 590   (define-key archive-mode-map "\C-p" 'archive-previous-line)
 591   (define-key archive-mode-map [up] 'archive-previous-line)
 592   (define-key archive-mode-map "r" 'archive-rename-entry)
 593   (define-key archive-mode-map "u" 'archive-unflag)
 594   (define-key archive-mode-map "\M-\C-?" 'archive-unmark-all-files)
 595   (define-key archive-mode-map "v" 'archive-view)
 596   (define-key archive-mode-map "x" 'archive-expunge)
 597   ;; XEmacs: "\177" -> 'backspace and 'delete.
 598   (define-key archive-mode-map 'backspace 'archive-unflag-backwards)
 599   (define-key archive-mode-map 'delete 'archive-unflag-backwards)
 600   (define-key archive-mode-map "E" 'archive-extract-other-window)
 601   (define-key archive-mode-map "M" 'archive-chmod-entry)
 602   (define-key archive-mode-map "G" 'archive-chgrp-entry)
 603   (define-key archive-mode-map "O" 'archive-chown-entry)
 604
 605   (if running-xemacs
 606       (progn
 607         ;; Not a nice "solution" but it'll have to do
 608         (define-key archive-mode-map "q" 'archive-quit)
 609         (define-key archive-mode-map "\C-xu" 'archive-undo)
 610         (define-key archive-mode-map "\C-_" 'archive-undo))
 611     (substitute-key-definition 'undo 'archive-undo
 612                                archive-mode-map global-map))
 613
 614   (define-key archive-mode-map
 615     (if running-xemacs 'button2 [mouse-2]) 'archive-mouse-extract)
 616
 617   (if running-xemacs
 618       ()                                ; out of luck
 619     ;; Get rid of the Edit menu bar item to save space.
 620     (define-key archive-mode-map [menu-bar edit] 'undefined)
 621
 622     (define-key archive-mode-map [menu-bar immediate]
 623       (cons "Immediate" (make-sparse-keymap "Immediate")))
 624     (define-key archive-mode-map [menu-bar immediate alternate]
 625       '("Alternate Display" . archive-alternate-display))
 626     (put 'archive-alternate-display 'menu-enable
 627          '(boundp (archive-name "alternate-display")))
 628     (define-key archive-mode-map [menu-bar immediate view]
 629       '("View This File" . archive-view))
 630     (define-key archive-mode-map [menu-bar immediate display]
 631       '("Display in Other Window" . archive-display-other-window))
 632     (define-key archive-mode-map [menu-bar immediate find-file-other-window]
 633       '("Find in Other Window" . archive-extract-other-window))
 634     (define-key archive-mode-map [menu-bar immediate find-file]
 635       '("Find This File" . archive-extract))
 636
 637     (define-key archive-mode-map [menu-bar mark]
 638       (cons "Mark" (make-sparse-keymap "Mark")))
 639     (define-key archive-mode-map [menu-bar mark unmark-all]
 640       '("Unmark All" . archive-unmark-all-files))
 641     (define-key archive-mode-map [menu-bar mark deletion]
 642       '("Flag" . archive-flag-deleted))
 643     (define-key archive-mode-map [menu-bar mark unmark]
 644       '("Unflag" . archive-unflag))
 645     (define-key archive-mode-map [menu-bar mark mark]
 646       '("Mark" . archive-mark))
 647
 648     (define-key archive-mode-map [menu-bar operate]
 649       (cons "Operate" (make-sparse-keymap "Operate")))
 650     (define-key archive-mode-map [menu-bar operate chown]
 651       '("Change Owner..." . archive-chown-entry))
 652     (put 'archive-chown-entry 'menu-enable
 653          '(fboundp (archive-name "chown-entry")))
 654     (define-key archive-mode-map [menu-bar operate chgrp]
 655       '("Change Group..." . archive-chgrp-entry))
 656     (put 'archive-chgrp-entry 'menu-enable
 657          '(fboundp (archive-name "chgrp-entry")))
 658     (define-key archive-mode-map [menu-bar operate chmod]
 659       '("Change Mode..." . archive-chmod-entry))
 660     (put 'archive-chmod-entry 'menu-enable
 661          '(fboundp (archive-name "chmod-entry")))
 662     (define-key archive-mode-map [menu-bar operate rename]
 663       '("Rename to..." . archive-rename-entry))
 664     (put 'archive-rename-entry 'menu-enable
 665          '(fboundp (archive-name "rename-entry")))
 666     ;;(define-key archive-mode-map [menu-bar operate copy]
 667     ;;  '("Copy to..." . archive-copy))
 668     (define-key archive-mode-map [menu-bar operate expunge]
 669       '("Expunge Marked Files" . archive-expunge))
 670   ))
 671
 672 (let* ((item1 '(archive-subfile-mode " Archive"))
 673        (item2 '(archive-subfile-dos " Dos"))
 674        (items (if (memq system-type '(ms-dos windows-nt))
 675                   (list item1) ; msdog has its own indicator
 676                 (list item1 item2))))
 677   (or (member item1 minor-mode-alist)
 678       (setq minor-mode-alist (append items minor-mode-alist))))
 679 ;; -------------------------------------------------------------------------
 680 (defun archive-find-type ()
 681   (widen)
 682   (goto-char (point-min))
 683   ;; The funny [] here make it unlikely that the .elc file will be treated
 684   ;; as an archive by other software.
 685   (let (case-fold-search)
 686     (cond ((looking-at "[P]K\003\004") 'zip)
 687           ((looking-at "..-l[hz][0-9]-") 'lzh)
 688           ((looking-at "....................[\334]\247\304\375") 'zoo)
 689           ((and (looking-at "\C-z")     ; signature too simple, IMHO
 690                 (string-match "\\.[aA][rR][cC]$"
 691                               (or buffer-file-name (buffer-name))))
 692            'arc)
 693           (t (error "Buffer format not recognized.")))))
 694 ;; -------------------------------------------------------------------------
 695 (defun archive-summarize ()
 696   "Parse the contents of the archive file in the current buffer.
 697 Place a dired-like listing on the front;
 698 then narrow to it, so that only that listing
 699 is visible (and the real data of the buffer is hidden)."
 700   (widen)
 701   (let (buffer-read-only)
 702     (message "Parsing archive file...")
 703     (buffer-disable-undo (current-buffer))
 704     (setq archive-files (funcall (archive-name "summarize")))
 705     (message "Parsing archive file...done.")
 706     (setq archive-proper-file-start (point-marker))
 707     (narrow-to-region (point-min) (point))
 708     (set-buffer-modified-p nil)
 709     (buffer-enable-undo))
 710   (goto-char archive-file-list-start)
 711   (archive-next-line 0))
 712
 713 (defun archive-resummarize ()
 714   "Recreate the contents listing of an archive."
 715   (let ((modified (buffer-modified-p))
 716         (no (archive-get-lineno))
 717         buffer-read-only)
 718     (widen)
 719     (delete-region (point-min) archive-proper-file-start)
 720     (archive-summarize)
 721     (set-buffer-modified-p modified)
 722     (goto-char archive-file-list-start)
 723     (archive-next-line no)))
 724
 725 (defun archive-summarize-files (files)
 726   "Insert a description of a list of files annotated with proper mouse face."
 727   (setq archive-file-list-start (point-marker))
 728   (setq archive-file-name-indent (if files (aref (car files) 1) 0))
 729   ;; We don't want to do an insert for each element since that takes too
 730   ;; long when the archive -- which has to be moved in memory -- is large.
 731   (insert
 732    (apply
 733     (function concat)
 734     (mapcar
 735      (function
 736       (lambda (fil)
 737         ;; Using `concat' here copies the text also, so we can add
 738         ;; properties without problems.
 739         (let ((text (concat (aref fil 0) "\n")))
 740           ;; XEmacs change: enabled for XEmacs too.
 741           (put-text-property (aref fil 1) (aref fil 2)
 742                              'mouse-face 'highlight
 743                              text)
 744           text)))
 745      files)))
 746   (setq archive-file-list-end (point-marker)))
 747
 748 (defun archive-alternate-display ()
 749   "Toggle alternative display.
 750 To avoid very long lines some archive mode don't show all information.
 751 This function changes the set of information shown for each files."
 752   (interactive)
 753   (setq archive-alternate-display (not archive-alternate-display))
 754   (archive-resummarize))
 755 ;; -------------------------------------------------------------------------
 756 ;; Section: Local archive copy handling
 757
 758 (defun archive-maybe-copy (archive)
 759   (if archive-remote
 760       (let ((start (point-max)))
 761         (setq archive-local-name (expand-file-name
 762                                   (file-name-nondirectory archive)
 763                                   archive-tmpdir))
 764         (make-directory archive-tmpdir t)
 765         (save-restriction
 766           (widen)
 767           (write-region start (point-max) archive-local-name nil 'nomessage))
 768         archive-local-name)
 769     (if (buffer-modified-p) (save-buffer))
 770     archive))
 771
 772 (defun archive-maybe-update (unchanged)
 773   (if archive-remote
 774       (let ((name archive-local-name)
 775             (modified (buffer-modified-p))
 776             buffer-read-only)
 777         (if unchanged nil
 778           (erase-buffer)
 779           (insert-file-contents name)
 780           (archive-mode t))
 781         (archive-delete-local name)
 782         (if (not unchanged)
 783             (message "Archive file must be saved for changes to take effect"))
 784         (set-buffer-modified-p (or modified (not unchanged))))))
 785
 786 (defun archive-delete-local (name)
 787   "Delete file NAME and its parents up to and including `archive-tmpdir'."
 788   (let ((again t)
 789         (top (directory-file-name (file-name-as-directory archive-tmpdir))))
 790     (condition-case nil
 791         (delete-file name)
 792       (error nil))
 793     (while again
 794       (setq name (directory-file-name (file-name-directory name)))
 795       (condition-case nil
 796           (delete-directory name)
 797         (error nil))
 798       (if (string= name top) (setq again nil)))))
 799 ;; -------------------------------------------------------------------------
 800 ;; Section: Member extraction
 801
 802 (defun archive-mouse-extract (event)
 803   "Extract a file whose name you click on."
 804   (interactive "e")
 805   (mouse-set-point event)
 806   (switch-to-buffer
 807    (save-excursion
 808      (archive-extract)
 809      (current-buffer))))
 810
 811 (defun archive-extract (&optional other-window-p)
 812   "In archive mode, extract this entry of the archive into its own buffer."
 813   (interactive)
 814   (let* ((view-p (eq other-window-p 'view))
 815          (descr (archive-get-descr))
 816          (ename (aref descr 0))
 817          (iname (aref descr 1))
 818          (archive-buffer (current-buffer))
 819          (arcdir default-directory)
 820          (archive (buffer-file-name))
 821          (arcname (file-name-nondirectory archive))
 822          (bufname (concat (file-name-nondirectory iname) " (" arcname ")"))
 823          (extractor (archive-name "extract"))
 824          (read-only-p (or archive-read-only view-p))
 825          (buffer (get-buffer bufname))
 826          (just-created nil))
 827       (if buffer
 828           nil
 829         (setq archive (archive-maybe-copy archive))
 830         (setq buffer (get-buffer-create bufname))
 831         (setq just-created t)
 832         (save-excursion
 833           (set-buffer buffer)
 834           (setq buffer-file-name
 835                 (expand-file-name (concat arcname ":" iname)))
 836           (setq buffer-file-truename
 837                 (abbreviate-file-name buffer-file-name))
 838           ;; Set the default-directory to the dir of the superior buffer.
 839           (setq default-directory arcdir)
 840           (make-local-variable 'archive-superior-buffer)
 841           (setq archive-superior-buffer archive-buffer)
 842           (make-local-variable 'local-write-file-hooks)
 843           (add-hook 'local-write-file-hooks 'archive-write-file-member)
 844           (setq archive-subfile-mode descr)
 845           (setq archive-subfile-dos nil)
 846           (if (boundp 'default-buffer-file-type)
 847               (setq buffer-file-type t))
 848           (if (fboundp extractor)
 849               (funcall extractor archive ename)
 850             (archive-*-extract archive ename (symbol-value extractor)))
 851           (if archive-dos-members (archive-check-dos))
 852           (goto-char (point-min))
 853           (rename-buffer bufname)
 854           (setq buffer-read-only read-only-p)
 855           (setq buffer-undo-list nil)
 856           (set-buffer-modified-p nil)
 857           (setq buffer-saved-size (buffer-size))
 858           (normal-mode)
 859           ;; Just in case an archive occurs inside another archive.
 860           (if (eq major-mode 'archive-mode)
 861               (setq archive-remote t))
 862           (run-hooks 'archive-extract-hooks))
 863         (archive-maybe-update t))
 864       (if view-p
 865           ;; XEmacs change: `view-buffer's 2nd arg difference
 866           (progn
 867             (view-buffer buffer)
 868             (and just-created (setq view-exit-action 'kill-buffer)))
 869         (if (eq other-window-p 'display)
 870             (display-buffer buffer)
 871           (if other-window-p
 872               (switch-to-buffer-other-window buffer)
 873             (switch-to-buffer buffer))))))
 874
 875 (defun archive-*-extract (archive name command)
 876   (let* ((default-directory (file-name-as-directory archive-tmpdir))
 877          (tmpfile (expand-file-name (file-name-nondirectory name)
 878                                     default-directory)))
 879     (make-directory (directory-file-name default-directory) t)
 880     (apply 'call-process
 881            (car command)
 882            nil
 883            nil
 884            nil
 885            (append (cdr command) (list archive name)))
 886     (insert-file-contents tmpfile)
 887     (archive-delete-local tmpfile)))
 888
 889 (defun archive-extract-by-stdout (archive name command)
 890   (let ((binary-process-output t)) ; for Ms-Dos
 891     (apply 'call-process
 892            (car command)
 893            nil
 894            t
 895            nil
 896            (append (cdr command) (list archive name)))))
 897
 898 (defun archive-extract-other-window ()
 899   "In archive mode, find this member in another window."
 900   (interactive)
 901   (archive-extract t))
 902
 903 (defun archive-display-other-window ()
 904   "In archive mode, display this member in another window."
 905   (interactive)
 906   (archive-extract 'display))
 907
 908 (defun archive-view ()
 909   "In archive mode, view the member on this line."
 910   (interactive)
 911   (archive-extract 'view))
 912
 913 (defun archive-add-new-member (arcbuf name)
 914   "Add current buffer to the archive in ARCBUF naming it NAME."
 915   (interactive
 916    (list (get-buffer
 917           (read-buffer "Buffer containing archive: "
 918                        ;; Find first archive buffer and suggest that
 919                        (let ((bufs (buffer-list)))
 920                          (while (and bufs (not (eq (save-excursion
 921                                                      (set-buffer (car bufs))
 922                                                      major-mode)
 923                                                    'archive-mode)))
 924                            (setq bufs (cdr bufs)))
 925                          (if bufs
 926                              (car bufs)
 927                            (error "There are no archive buffers")))
 928                        t))
 929          (read-string "File name in archive: "
 930                       (if buffer-file-name
 931                           (file-name-nondirectory buffer-file-name)
 932                         ""))))
 933   (save-excursion
 934     (set-buffer arcbuf)
 935     (or (eq major-mode 'archive-mode)
 936         (error "Buffer is not an archive buffer"))
 937     (if archive-read-only
 938         (error "Archive is read-only")))
 939   (if (eq arcbuf (current-buffer))
 940       (error "An archive buffer cannot be added to itself"))
 941   (if (string= name "")
 942       (error "Archive members may not be given empty names"))
 943   (let ((func (save-excursion (set-buffer arcbuf)
 944                               (archive-name "add-new-member")))
 945         (membuf (current-buffer)))
 946     (if (fboundp func)
 947         (save-excursion
 948           (set-buffer arcbuf)
 949           (funcall func buffer-file-name membuf name))
 950       (error "Adding a new member is not supported for this archive type"))))
 951 ;; -------------------------------------------------------------------------
 952 ;; Section: IO stuff
 953
 954 (defun archive-check-dos (&optional force)
 955   "*Possibly handle a buffer with ^M^J terminated lines."
 956   (save-restriction
 957     (widen)
 958     (save-excursion
 959       (goto-char (point-min))
 960       (setq archive-subfile-dos
 961             (or force (not (search-forward-regexp "[^\r]\n" nil t))))
 962       (if (boundp 'default-buffer-file-type)
 963           (setq buffer-file-type (not archive-subfile-dos)))
 964       (if archive-subfile-dos
 965           (let ((modified (buffer-modified-p)))
 966             (buffer-disable-undo (current-buffer))
 967             (goto-char (point-min))
 968             (while (search-forward "\r\n" nil t)
 969               (replace-match "\n"))
 970             (buffer-enable-undo)
 971             (set-buffer-modified-p modified))))))
 972
 973 (defun archive-write-file-member ()
 974   (if archive-subfile-dos
 975       (save-restriction
 976         (widen)
 977         (save-excursion
 978           (goto-char (point-min))
 979           ;; We don't want our ^M^J <--> ^J changes to show in the undo list
 980           (let ((undo-list buffer-undo-list))
 981             (unwind-protect
 982                 (progn
 983                   (setq buffer-undo-list t)
 984                   (while (search-forward "\n" nil t)
 985                     (replace-match "\r\n"))
 986                   (setq archive-subfile-dos nil)
 987                   (if (boundp 'default-buffer-file-type)
 988                       (setq buffer-file-type t))
 989                   ;; OK, we're now have explicit ^M^Js -- save and re-unixfy
 990                   (archive-write-file-member))
 991               (progn
 992                 (archive-check-dos t)
 993                 (setq buffer-undo-list undo-list))))
 994           t))
 995     (save-excursion
 996       (save-restriction
 997         (message "Updating archive...")
 998         (widen)
 999         (let ((writer  (save-excursion (set-buffer archive-superior-buffer)
1000                                        (archive-name "write-file-member")))
1001               (archive (save-excursion (set-buffer archive-superior-buffer)
1002                                        (buffer-file-name))))
1003           (if (fboundp writer)
1004               (funcall writer archive archive-subfile-mode)
1005             (archive-*-write-file-member archive
1006                                          archive-subfile-mode
1007                                          (symbol-value writer))))
1008         (set-buffer-modified-p nil)
1009         (message "Updating archive...done")
1010         (set-buffer archive-superior-buffer)
1011         (revert-buffer)
1012         t))))
1013
1014 (defun archive-*-write-file-member (archive descr command)
1015   (let* ((ename (aref descr 0))
1016          (tmpfile (expand-file-name ename archive-tmpdir))
1017          (top (directory-file-name (file-name-as-directory archive-tmpdir)))
1018          (default-directory (file-name-as-directory top)))
1019     (unwind-protect
1020         (progn
1021           (make-directory (file-name-directory tmpfile) t)
1022           (write-region (point-min) (point-max) tmpfile nil 'nomessage)
1023           (if (aref descr 3)
1024               ;; Set the file modes, but make sure we can read it.
1025               (set-file-modes tmpfile (logior #o400 (aref descr 3))))
1026           (let ((exitcode (apply 'call-process
1027                                  (car command)
1028                                  nil
1029                                  nil
1030                                  nil
1031                                  (append (cdr command) (list archive ename)))))
1032             (if (equal exitcode 0)
1033                 nil
1034               (error "Updating was unsuccessful (%S)" exitcode))))
1035       (archive-delete-local tmpfile))))
1036
1037 (defun archive-write-file ()
1038   (save-excursion
1039     (write-region archive-proper-file-start (point-max) buffer-file-name nil t)
1040     (set-buffer-modified-p nil)
1041     t))
1042 ;; -------------------------------------------------------------------------
1043 ;; Section: Marking and unmarking.
1044
1045 (defun archive-flag-deleted (p &optional type)
1046   "In archive mode, mark this member to be deleted from the archive.
1047 With a prefix argument, mark that many files."
1048   (interactive "p")
1049   (or type (setq type ?D))
1050   (beginning-of-line)
1051   (let ((sign (if (>= p 0) +1 -1))
1052         (modified (buffer-modified-p))
1053         buffer-read-only)
1054     (while (not (zerop p))
1055       (if (archive-get-descr t)
1056           (progn
1057             (delete-char 1)
1058             (insert type)))
1059       (forward-line sign)
1060       (setq p (- p sign)))
1061     (set-buffer-modified-p modified))
1062   (archive-next-line 0))
1063
1064 (defun archive-unflag (p)
1065   "In archive mode, un-mark this member if it is marked to be deleted.
1066 With a prefix argument, un-mark that many files forward."
1067   (interactive "p")
1068   (archive-flag-deleted p ? ))
1069
1070 (defun archive-unflag-backwards (p)
1071   "In archive mode, un-mark this member if it is marked to be deleted.
1072 With a prefix argument, un-mark that many members backward."
1073   (interactive "p")
1074   (archive-flag-deleted (- p) ? ))
1075
1076 (defun archive-unmark-all-files ()
1077   "Remove all marks."
1078   (interactive)
1079   (let ((modified (buffer-modified-p))
1080         buffer-read-only)
1081     (save-excursion
1082       (goto-char archive-file-list-start)
1083       (while (< (point) archive-file-list-end)
1084         (or (= (following-char) ? )
1085             (progn (delete-char 1) (insert ? )))
1086         (forward-line 1)))
1087     (set-buffer-modified-p modified)))
1088
1089 (defun archive-mark (p)
1090   "In archive mode, mark this member for group operations.
1091 With a prefix argument, mark that many members.
1092 Use \\[archive-unmark-all-files] to remove all marks."
1093   (interactive "p")
1094   (archive-flag-deleted p ?*))
1095
1096 (defun archive-get-marked (mark &optional default)
1097   (let (files)
1098     (save-excursion
1099       (goto-char archive-file-list-start)
1100       (while (< (point) archive-file-list-end)
1101         (if (= (following-char) mark)
1102             (setq files (cons (archive-get-descr) files)))
1103         (forward-line 1)))
1104     (or (nreverse files)
1105         (and default
1106              (list (archive-get-descr))))))
1107 ;; -------------------------------------------------------------------------
1108 ;; Section: Operate
1109
1110 (defun archive-next-line (p)
1111   (interactive "p")
1112   (forward-line p)
1113   (or (eobp)
1114       (forward-char archive-file-name-indent)))
1115
1116 (defun archive-previous-line (p)
1117   (interactive "p")
1118   (archive-next-line (- p)))
1119
1120 (defun archive-chmod-entry (new-mode)
1121   "Change the protection bits associated with all marked or this member.
1122 The new protection bits can either be specified as an octal number or
1123 as a relative change like \"g+rw\" as for chmod(2)"
1124   (interactive "sNew mode (octal or relative): ")
1125   (if archive-read-only (error "Archive is read-only"))
1126   (let ((func (archive-name "chmod-entry")))
1127     (if (fboundp func)
1128         (progn
1129           (funcall func new-mode (archive-get-marked ?* t))
1130           (archive-resummarize))
1131       (error "Setting mode bits is not supported for this archive type"))))
1132
1133 (defun archive-chown-entry (new-uid)
1134   "Change the owner of all marked or this member."
1135   (interactive "nNew uid: ")
1136   (if archive-read-only (error "Archive is read-only"))
1137   (let ((func (archive-name "chown-entry")))
1138     (if (fboundp func)
1139         (progn
1140           (funcall func new-uid (archive-get-marked ?* t))
1141           (archive-resummarize))
1142       (error "Setting owner is not supported for this archive type"))))
1143
1144 (defun archive-chgrp-entry (new-gid)
1145   "Change the group of all marked or this member."
1146   (interactive "nNew gid: ")
1147   (if archive-read-only (error "Archive is read-only"))
1148   (let ((func (archive-name "chgrp-entry")))
1149     (if (fboundp func)
1150         (progn
1151           (funcall func new-gid (archive-get-marked ?* t))
1152           (archive-resummarize))
1153       (error "Setting group is not supported for this archive type"))))
1154
1155 (defun archive-expunge ()
1156   "Do the flagged deletions."
1157   (interactive)
1158   (let (files)
1159     (save-excursion
1160       (goto-char archive-file-list-start)
1161       (while (< (point) archive-file-list-end)
1162         (if (= (following-char) ?D)
1163             (setq files (cons (aref (archive-get-descr) 0) files)))
1164         (forward-line 1)))
1165     (setq files (nreverse files))
1166     (and files
1167          (or (not archive-read-only)
1168              (error "Archive is read-only"))
1169          (or (yes-or-no-p (format "Really delete %d member%s? "
1170                                   (length files)
1171                                   (if (null (cdr files)) "" "s")))
1172              (error "Operation aborted"))
1173          (let ((archive (archive-maybe-copy (buffer-file-name)))
1174                (expunger (archive-name "expunge")))
1175            (if (fboundp expunger)
1176                (funcall expunger archive files)
1177              (archive-*-expunge archive files (symbol-value expunger)))
1178            (archive-maybe-update nil)
1179            (if archive-remote
1180                (archive-resummarize)
1181              (revert-buffer))))))
1182
1183 (defun archive-*-expunge (archive files command)
1184   (apply 'call-process
1185          (car command)
1186          nil
1187          nil
1188          nil
1189          (append (cdr command) (cons archive files))))
1190
1191 (defun archive-rename-entry (newname)
1192   "Change the name associated with this entry in the tar file."
1193   (interactive "sNew name: ")
1194   (if archive-read-only (error "Archive is read-only"))
1195   (if (string= newname "")
1196       (error "Archive members may not be given empty names"))
1197   (let ((func (archive-name "rename-entry"))
1198         (descr (archive-get-descr)))
1199     (if (fboundp func)
1200         (progn
1201           (funcall func (buffer-file-name) newname descr)
1202           (archive-resummarize))
1203       (error "Renaming is not supported for this archive type"))))
1204
1205 (defun archive-mode-revert (&optional no-autosave no-confirm)
1206   "Revert the buffer and recompute the dired-like listing."
1207   (let ((no (archive-get-lineno)))
1208     (setq archive-files nil)
1209     (let ((revert-buffer-function nil))
1210       (revert-buffer t t))
1211     (archive-mode)
1212     (goto-char archive-file-list-start)
1213     (archive-next-line no)))
1214
1215 (defun archive-undo ()
1216   "Undo in an archive buffer.
1217 This doesn't recover lost files, it just undoes changes in the buffer itself."
1218   (interactive)
1219   (let (buffer-read-only)
1220     (undo)))
1221 ;; -------------------------------------------------------------------------
1222 ;; Section: Arc Archives
1223
1224 (defun archive-arc-summarize ()
1225   (let ((p 1)
1226         (totalsize 0)
1227         (maxlen 8)
1228         files
1229         visual)
1230     (while (and (< (+ p 29) (point-max))
1231                 (eq (char-after p) ?\C-z)
1232                 (> (char-after (1+ p)) 0))
1233       (let* ((namefld (buffer-substring (+ p 2) (+ p 2 13)))
1234              (fnlen   (or (string-match "\0" namefld) 13))
1235              (efnname (substring namefld 0 fnlen))
1236              (csize   (archive-l-e (+ p 15) 4))
1237              (moddate (archive-l-e (+ p 19) 2))
1238              (modtime (archive-l-e (+ p 21) 2))
1239              (ucsize  (archive-l-e (+ p 25) 4))
1240              (fiddle  (string= efnname (upcase efnname)))
1241              (ifnname (if fiddle (downcase efnname) efnname))
1242              (text    (format "  %8d  %-11s  %-8s  %s"
1243                               ucsize
1244                               (archive-dosdate moddate)
1245                               (archive-dostime modtime)
1246                               ifnname)))
1247         (setq maxlen (max maxlen fnlen)
1248               totalsize (+ totalsize ucsize)
1249               visual (cons (vector text
1250                                    (- (length text) (length ifnname))
1251                                    (length text))
1252                            visual)
1253               files (cons (vector efnname ifnname fiddle nil (1- p))
1254                           files)
1255               p (+ p 29 csize))))
1256     (goto-char (point-min))
1257     (let ((dash (concat "- --------  -----------  --------  "
1258                         (make-string maxlen ?-)
1259                         "\n")))
1260       (insert "M   Length  Date         Time      File\n"
1261               dash)
1262       (archive-summarize-files (nreverse visual))
1263       (insert dash
1264               (format "  %8d                         %d file%s"
1265                       totalsize
1266                       (length files)
1267                       (if (= 1 (length files)) "" "s"))
1268               "\n"))
1269     (apply 'vector (nreverse files))))
1270
1271 (defun archive-arc-rename-entry (archive newname descr)
1272   (if (string-match "[:\\\\/]" newname)
1273       (error "File names in arc files may not contain a path"))
1274   (if (> (length newname) 12)
1275       (error "File names in arc files are limited to 12 characters"))
1276   (let ((name (concat newname (substring "\0\0\0\0\0\0\0\0\0\0\0\0\0"
1277                                          (length newname))))
1278         buffer-read-only)
1279     (save-restriction
1280       (save-excursion
1281         (widen)
1282         (goto-char (+ archive-proper-file-start (aref descr 4) 2))
1283         (delete-char 13)
1284         (insert name)))))
1285 ;; -------------------------------------------------------------------------
1286 ;; Section: Lzh Archives
1287
1288 (defun archive-lzh-summarize ()
1289   (let ((p 1)
1290         (totalsize 0)
1291         (maxlen 8)
1292         files
1293         visual)
1294     (while (progn (goto-char p) (looking-at "..-l[hz][0-9]-"))
1295       (let* ((hsize   (char-after p))
1296              (csize   (archive-l-e (+ p 7) 4))
1297              (ucsize  (archive-l-e (+ p 11) 4))
1298              (modtime (archive-l-e (+ p 15) 2))
1299              (moddate (archive-l-e (+ p 17) 2))
1300              (fnlen   (char-after (+ p 21)))
1301              (efnname (buffer-substring (+ p 22) (+ p 22 fnlen)))
1302              (fiddle  (string= efnname (upcase efnname)))
1303              (ifnname (if fiddle (downcase efnname) efnname))
1304              (p2      (+ p 22 fnlen))
1305              (creator (if (>= (- hsize fnlen) 24) (char-after (+ p2 2)) 0))
1306              (mode    (if (eq creator ?U) (archive-l-e (+ p2 8) 2) #o666))
1307              (modestr (if mode (archive-int-to-mode mode) "??????????"))
1308              (uid     (if (eq creator ?U) (archive-l-e (+ p2 10) 2)))
1309              (gid     (if (eq creator ?U) (archive-l-e (+ p2 12) 2)))
1310              (text    (if archive-alternate-display
1311                           (format "  %8d  %5S  %5S  %s"
1312                                   ucsize
1313                                   (or uid "?")
1314                                   (or gid "?")
1315                                   ifnname)
1316                         (format "  %10s  %8d  %-11s  %-8s  %s"
1317                                 modestr
1318                                 ucsize
1319                                 (archive-dosdate moddate)
1320                                 (archive-dostime modtime)
1321                                 ifnname))))
1322         (setq maxlen (max maxlen fnlen)
1323               totalsize (+ totalsize ucsize)
1324               visual (cons (vector text
1325                                    (- (length text) (length ifnname))
1326                                    (length text))
1327                            visual)
1328               files (cons (vector efnname ifnname fiddle mode (1- p))
1329                           files)
1330               p (+ p hsize 2 csize))))
1331     (goto-char (point-min))
1332     (let ((dash (concat (if archive-alternate-display
1333                             "- --------  -----  -----  "
1334                           "- ----------  --------  -----------  --------  ")
1335                         (make-string maxlen ?-)
1336                         "\n"))
1337           (header (if archive-alternate-display
1338                        "M   Length    Uid    Gid  File\n"
1339                     "M   Filemode    Length  Date         Time      File\n"))
1340           (sumline (if archive-alternate-display
1341                        "  %8d                %d file%s"
1342                      "              %8d                         %d file%s")))
1343       (insert header dash)
1344       (archive-summarize-files (nreverse visual))
1345       (insert dash
1346               (format sumline
1347                       totalsize
1348                       (length files)
1349                       (if (= 1 (length files)) "" "s"))
1350               "\n"))
1351     (apply 'vector (nreverse files))))
1352
1353 (defconst archive-lzh-alternate-display t)
1354
1355 (defun archive-lzh-extract (archive name)
1356   (archive-extract-by-stdout archive name archive-lzh-extract))
1357
1358 (defun archive-lzh-resum (p count)
1359   (let ((sum 0))
1360     (while (> count 0)
1361       (setq count (1- count)
1362             sum (+ sum (char-after p))
1363             p (1+ p)))
1364     (logand sum 255)))
1365
1366 (defun archive-lzh-rename-entry (archive newname descr)
1367   (save-restriction
1368     (save-excursion
1369       (widen)
1370       (let* ((p        (+ archive-proper-file-start (aref descr 4)))
1371              (oldhsize (char-after p))
1372              (oldfnlen (char-after (+ p 21)))
1373              (newfnlen (length newname))
1374              (newhsize (+ oldhsize newfnlen (- oldfnlen)))
1375              buffer-read-only)
1376         (if (> newhsize 255)
1377             (error "The file name is too long"))
1378         (goto-char (+ p 21))
1379         (delete-char (1+ oldfnlen))
1380         (insert newfnlen newname)
1381         (goto-char p)
1382         (delete-char 2)
1383         (insert newhsize (archive-lzh-resum p newhsize))))))
1384
1385 (defun archive-lzh-ogm (newval files errtxt ofs)
1386   (save-restriction
1387     (save-excursion
1388       (widen)
1389       (while files
1390         (let* ((fil (car files))
1391                (p (+ archive-proper-file-start (aref fil 4)))
1392                (hsize   (char-after p))
1393                (fnlen   (char-after (+ p 21)))
1394                (p2      (+ p 22 fnlen))
1395                (creator (if (>= (- hsize fnlen) 24) (char-after (+ p2 2)) 0))
1396                buffer-read-only)
1397           (if (= creator ?U)
1398               (progn
1399                 (or (numberp newval)
1400                     (setq newval (funcall newval (archive-l-e (+ p2 ofs) 2))))
1401                 (goto-char (+ p2 ofs))
1402                 (delete-char 2)
1403                 (insert (logand newval 255) (lsh newval -8))
1404                 (goto-char (1+ p))
1405                 (delete-char 1)
1406                 (insert (archive-lzh-resum (1+ p) hsize)))
1407             (message "Member %s does not have %s field"
1408                      (aref fil 1) errtxt)))
1409         (setq files (cdr files))))))
1410
1411 (defun archive-lzh-chown-entry (newuid files)
1412   (archive-lzh-ogm newuid files "an uid" 10))
1413
1414 (defun archive-lzh-chgrp-entry (newgid files)
1415   (archive-lzh-ogm newgid files "a gid" 12))
1416
1417 (defun archive-lzh-chmod-entry (newmode files)
1418   (archive-lzh-ogm
1419    ;; This should work even though newmode will be dynamically accessed.
1420    (function (lambda (old) (archive-calc-mode old newmode t)))
1421    files "a unix-style mode" 8))
1422 ;; -------------------------------------------------------------------------
1423 ;; Section: Zip Archives
1424
1425 (defun archive-zip-summarize ()
1426   (goto-char (- (point-max) (- 22 18)))
1427   (search-backward-regexp "[P]K\005\006")
1428   (let ((p (1+ (archive-l-e (+ (point) 16) 4)))
1429         (maxlen 8)
1430         (totalsize 0)
1431         files
1432         visual)
1433     (while (string= "PK\001\002" (buffer-substring p (+ p 4)))
1434       (let* ((creator (char-after (+ p 5)))
1435              (method  (archive-l-e (+ p 10) 2))
1436              (modtime (archive-l-e (+ p 12) 2))
1437              (moddate (archive-l-e (+ p 14) 2))
1438              (ucsize  (archive-l-e (+ p 24) 4))
1439              (fnlen   (archive-l-e (+ p 28) 2))
1440              (exlen   (archive-l-e (+ p 30) 2))
1441              (fclen   (archive-l-e (+ p 32) 2))
1442              (lheader (archive-l-e (+ p 42) 4))
1443              (efnname (buffer-substring (+ p 46) (+ p 46 fnlen)))
1444              (isdir   (and (= ucsize 0)
1445                            (string= (file-name-nondirectory efnname) "")))
1446              (mode    (cond ((memq (char-int creator) '(2 3)) ; Unix + VMS
1447                              (archive-l-e (+ p 40) 2))
1448                             ((memq (char-int creator)
1449                                    '(0 5 6 7 10 11)) ; Dos etc.
1450                              (logior #o444
1451                                      (if isdir (logior 16384 #o111) 0)
1452                                      (if (zerop
1453                                           (logand 1 (char-after (+ p 38))))
1454                                          #o222 0)))
1455                             (t nil)))
1456              (modestr (if mode (archive-int-to-mode mode) "??????????"))
1457              (fiddle  (and archive-zip-case-fiddle
1458                            (not (not (memq (char-int creator) '(0 2 4 5 9))))))
1459              (ifnname (if fiddle (downcase efnname) efnname))
1460              (text    (format "  %10s  %8d  %-11s  %-8s  %s"
1461                               modestr
1462                               ucsize
1463                               (archive-dosdate moddate)
1464                               (archive-dostime modtime)
1465                               ifnname)))
1466         (setq maxlen (max maxlen fnlen)
1467               totalsize (+ totalsize ucsize)
1468               visual (cons (vector text
1469                                    (- (length text) (length ifnname))
1470                                    (length text))
1471                            visual)
1472               files (cons (if isdir
1473                               nil
1474                             (vector efnname ifnname fiddle mode
1475                                     (list (1- p) lheader)))
1476                           files)
1477               p (+ p 46 fnlen exlen fclen))))
1478     (goto-char (point-min))
1479     (let ((dash (concat "- ----------  --------  -----------  --------  "
1480                         (make-string maxlen ?-)
1481                         "\n")))
1482       (insert "M Filemode      Length  Date         Time      File\n"
1483               dash)
1484       (archive-summarize-files (nreverse visual))
1485       (insert dash
1486               (format "              %8d                         %d file%s"
1487                       totalsize
1488                       (length files)
1489                       (if (= 1 (length files)) "" "s"))
1490               "\n"))
1491     (apply 'vector (nreverse files))))
1492
1493 (defun archive-zip-extract (archive name)
1494   (if archive-zip-use-pkzip
1495       (archive-*-extract archive name archive-zip-extract)
1496     (archive-extract-by-stdout archive name archive-zip-extract)))
1497
1498 (defun archive-zip-write-file-member (archive descr)
1499   (archive-*-write-file-member
1500    archive
1501    descr
1502    (if (aref descr 2) archive-zip-update-case archive-zip-update)))
1503
1504 (defun archive-zip-chmod-entry (newmode files)
1505   (save-restriction
1506     (save-excursion
1507       (widen)
1508       (while files
1509         (let* ((fil (car files))
1510                (p (+ archive-proper-file-start (car (aref fil 4))))
1511                (creator (char-after (+ p 5)))
1512                (oldmode (aref fil 3))
1513                (newval  (archive-calc-mode oldmode newmode t))
1514                buffer-read-only)
1515           (cond ((memq (char-int creator) '(2 3)) ; Unix + VMS
1516                  (goto-char (+ p 40))
1517                  (delete-char 2)
1518                  (insert (logand newval 255) (lsh newval -8)))
1519                 ((memq (char-int creator) '(0 5 6 7 10 11)) ; Dos etc.
1520                  (goto-char (+ p 38))
1521                  (insert (logior (logand (char-after (point)) 254)
1522                                  (logand (logxor 1 (lsh newval -7)) 1)))
1523                  (delete-char 1))
1524                 (t (message "Don't know how to change mode for this member"))))
1525         (setq files (cdr files))))))
1526 ;; -------------------------------------------------------------------------
1527 ;; Section: Zoo Archives
1528
1529 (defun archive-zoo-summarize ()
1530   (let ((p (1+ (archive-l-e 25 4)))
1531         (maxlen 8)
1532         (totalsize 0)
1533         files
1534         visual)
1535     (while (and (string= "\334\247\304\375" (buffer-substring p (+ p 4)))
1536                 (> (archive-l-e (+ p 6) 4) 0))
1537       (let* ((next    (1+ (archive-l-e (+ p 6) 4)))
1538              (moddate (archive-l-e (+ p 14) 2))
1539              (modtime (archive-l-e (+ p 16) 2))
1540              (ucsize  (archive-l-e (+ p 20) 4))
1541              (namefld (buffer-substring (+ p 38) (+ p 38 13)))
1542              (dirtype (char-after (+ p 4)))
1543              (lfnlen  (if (= dirtype 2) (char-after (+ p 56)) 0))
1544              (ldirlen (if (= dirtype 2) (char-after (+ p 57)) 0))
1545              (fnlen   (+ ldirlen
1546                          (if (> lfnlen 0)
1547                              (1- lfnlen)
1548                            (or (string-match "\0" namefld) 13))))
1549              (efnname (concat
1550                        (if (> ldirlen 0)
1551                            (concat (buffer-substring
1552                                     (+ p 58 lfnlen) (+ p 58 lfnlen ldirlen -1))
1553                                    "/")
1554                          "")
1555                        (if (> lfnlen 0)
1556                            (buffer-substring (+ p 58) (+ p 58 lfnlen -1))
1557                          (substring namefld 0 fnlen))))
1558              (fiddle  (and (= lfnlen 0) (string= efnname (upcase efnname))))
1559              (ifnname (if fiddle (downcase efnname) efnname))
1560              (text    (format "  %8d  %-11s  %-8s  %s"
1561                               ucsize
1562                               (archive-dosdate moddate)
1563                               (archive-dostime modtime)
1564                               ifnname)))
1565         (setq maxlen (max maxlen fnlen)
1566               totalsize (+ totalsize ucsize)
1567               visual (cons (vector text
1568                                    (- (length text) (length ifnname))
1569                                    (length text))
1570                            visual)
1571               files (cons (vector efnname ifnname fiddle nil (1- p))
1572                           files)
1573               p next)))
1574     (goto-char (point-min))
1575     (let ((dash (concat "- --------  -----------  --------  "
1576                         (make-string maxlen ?-)
1577                         "\n")))
1578       (insert "M   Length  Date         Time      File\n"
1579               dash)
1580       (archive-summarize-files (nreverse visual))
1581       (insert dash
1582               (format "  %8d                         %d file%s"
1583                       totalsize
1584                       (length files)
1585                       (if (= 1 (length files)) "" "s"))
1586               "\n"))
1587     (apply 'vector (nreverse files))))
1588
1589 (defun archive-zoo-extract (archive name)
1590   (archive-extract-by-stdout archive name archive-zoo-extract))
1591 ;; -------------------------------------------------------------------------
1592
1593 ;; XEmacs addition
1594 ;;;###autoload(add-to-list 'auto-mode-alist '("\\.\\(?:arc\\|[ejw]ar\\|zip\\|lzh\\|zoo\\)\\'" . archive-mode))
1595
1596 (provide 'archive-mode)
1597 (provide 'arc-mode)
1598
1599 ;;; arc-mode.el ends here.