;;; arc-mode.el --- simple editing of archives
-;; Copyright (C) 1995, 1997, 1998 Free Software Foundation, Inc.
+;; Copyright (C) 1995, 1997, 1998, 2003 Free Software Foundation, Inc.
;; Author: Morten Welinder <terra@diku.dk>
;; Keywords: archives msdog editing major-mode
;;
;; 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-
;; Each member header points to the next. The archive is
;; terminated by a bogus header with a zero next link.
;; -------------------------------------
-;; HOOKS: `foo' means one the the supported archive types.
+;; HOOKS: `foo' means one of the supported archive types.
;;
;; archive-mode-hook
;; archive-foo-mode-hook
: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))
;; ------------------------------
;; Zip archive configuration
-(defcustom archive-zip-use-pkzip (memq system-type '(ms-dos windows-nt))
- "*If non-nil then pkzip option are used instead of zip options.
-Only set to true for msdog systems!"
- :type 'boolean
- :group 'archive-zip)
-
(defcustom archive-zip-extract
- (if archive-zip-use-pkzip '("pkunzip" "-e" "-o-") '("unzip" "-qq" "-c"))
+ (if (locate-file "unzip" nil 'file-executable-p)
+ '("unzip" "-qq" "-c")
+ (if (locate-file "pkunzip" nil 'file-executable-p)
+ '("pkunzip" "-e" "-o-")
+ '("unzip" "-qq" "-c")))
"*Program and its options to run in order to extract a zip file member.
Extraction should happen to standard output. Archive and member name will
be added. If `archive-zip-use-pkzip' is non-nil then this program is
;; names.
(defcustom archive-zip-expunge
- (if archive-zip-use-pkzip '("pkzip" "-d") '("zip" "-d" "-q"))
+ (if (locate-file "zip" nil 'file-executable-p)
+ '("zip" "-d" "-q")
+ (if (locate-file "pkzip" nil 'file-executable-p)
+ '("pkzip" "-d")
+ '("zip" "-d" "-q")))
"*Program and its options to run in order to delete zip file members.
Archive and member names will be added."
:type '(list (string :tag "Program")
:group 'archive-zip)
(defcustom archive-zip-update
- (if archive-zip-use-pkzip '("pkzip" "-u") '("zip" "-q"))
+ (if (locate-file "zip" nil 'file-executable-p)
+ '("zip" "-q")
+ (if (locate-file "pkzip" nil 'file-executable-p)
+ '("pkzip" "-u" "-P")
+ '("zip" "-q")))
"*Program and its options to run in order to update a zip file member.
Options should ensure that specified directory will be put into the zip
file. Archive and member name will be added."
:group 'archive-zip)
(defcustom archive-zip-update-case
- (if archive-zip-use-pkzip archive-zip-update '("zip" "-q" "-k"))
+ (if (locate-file "zip" nil 'file-executable-p)
+ '("zip" "-q" "-k")
+ (if (locate-file "pkzip" nil 'file-executable-p)
+ '("pkzip" "-u" "-P")
+ '("zip" "-q" "-k")))
"*Program and its options to run in order to update a case fiddled zip member.
Options should ensure that specified directory will be put into the zip file.
Archive and member name will be added."
;; -------------------------------------------------------------------------
;; 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 nil "*Local keymap for archive mode listings.")
-(defvar archive-file-name-indent nil "*Column where file names start.")
+(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 nil "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.")
+(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)
(make-variable-buffer-local 'archive-member-coding-system)
(defvar archive-alternate-display nil
- "*Non-nil when alternate information is shown.")
+ "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.")
+(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.")
+(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-file-name-coding-system nil)
+(make-variable-buffer-local 'archive-file-name-coding-system)
+(put 'archive-file-name-coding-system 'permanent-local t)
+
(defvar archive-files nil
"Vector of file descriptors.
Each descriptor is a vector of the form
;; -------------------------------------------------------------------------
;; Section: Support functions.
+(eval-when-compile
+ (defsubst byte-after (pos)
+ "Like char-after but an eight-bit char is converted to unibyte."
+ (multibyte-char-to-unibyte (char-after pos)))
+ (defsubst insert-unibyte (&rest args)
+ "Like insert but don't make unibyte string and eight-bit char multibyte."
+ (dolist (elt args)
+ (if (integerp elt)
+ (insert (if (< elt 128) elt (decode-char 'eight-bit elt)))
+ (insert (string-to-multibyte elt)))))
+ )
+
(defsubst archive-name (suffix)
(intern (concat "archive-" (symbol-name archive-subtype) "-" suffix)))
(if (stringp str)
(setq len (length str))
(setq str (buffer-substring str (+ str len))))
+ (setq str (string-as-unibyte str))
(let ((result 0)
(i 0))
(while (< i len)
result))
(defun archive-int-to-mode (mode)
- "Turn an integer like 0700 (i.e., 448) into a mode string like -rwx------"
- (let ((str (make-string 10 ?-)))
- (or (zerop (logand 16384 mode)) (aset str 0 ?d))
- (or (zerop (logand 8192 mode)) (aset str 0 ?c)) ; completeness
- (or (zerop (logand 256 mode)) (aset str 1 ?r))
- (or (zerop (logand 128 mode)) (aset str 2 ?w))
- (or (zerop (logand 64 mode)) (aset str 3 ?x))
- (or (zerop (logand 32 mode)) (aset str 4 ?r))
- (or (zerop (logand 16 mode)) (aset str 5 ?w))
- (or (zerop (logand 8 mode)) (aset str 6 ?x))
- (or (zerop (logand 4 mode)) (aset str 7 ?r))
- (or (zerop (logand 2 mode)) (aset str 8 ?w))
- (or (zerop (logand 1 mode)) (aset str 9 ?x))
- (or (zerop (logand 1024 mode)) (aset str 3 (if (zerop (logand 64 mode))
- ?S ?s)))
- (or (zerop (logand 2048 mode)) (aset str 6 (if (zerop (logand 8 mode))
- ?S ?s)))
- str))
+ "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.
(defun archive-dostime (time)
"Stringify dos packed TIME record."
(let ((hour (logand (ash time -11) 31))
- (minute (logand (ash time -5) 53))
+ (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 9)
-;; (substring str 4 7)
-;; (substring str 20 24))))
+(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-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)
(funcall default-major-mode)
(if (and (not force) archive-files) nil
(let* ((type (archive-find-type))
- (typename (copy-sequence (symbol-name type))))
- (aset typename 0 (upcase (aref typename 0)))
+ (typename (capitalize (symbol-name type))))
(kill-all-local-variables)
(make-local-variable 'archive-subtype)
(setq archive-subtype type)
(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.
(make-local-variable 'archive-file-list-start)
(make-local-variable 'archive-file-list-end)
(make-local-variable 'archive-file-name-indent)
+ (setq archive-file-name-coding-system
+ (or file-name-coding-system
+ default-file-name-coding-system
+ locale-coding-system))
+ (if default-enable-multibyte-characters
+ (set-buffer-multibyte 'to))
(archive-summarize nil)
(setq buffer-read-only t))))
(define-key archive-mode-map [down] 'archive-next-line)
(define-key archive-mode-map "o" 'archive-extract-other-window)
(define-key archive-mode-map "p" 'archive-previous-line)
+ (define-key archive-mode-map "q" 'quit-window)
(define-key archive-mode-map "\C-p" 'archive-previous-line)
(define-key archive-mode-map [up] 'archive-previous-line)
(define-key archive-mode-map "r" 'archive-rename-entry)
;; Not a nice "solution" but it'll have to do
(define-key archive-mode-map "\C-xu" 'archive-undo)
(define-key archive-mode-map "\C-_" 'archive-undo))
- (substitute-key-definition 'undo 'archive-undo
- archive-mode-map global-map))
+ (define-key archive-mode-map [remap advertised-undo] 'archive-undo)
+ (define-key archive-mode-map [remap undo] 'archive-undo))
(define-key archive-mode-map
(if archive-lemacs 'button2 [mouse-2]) 'archive-mouse-extract)
(if archive-lemacs
() ; out of luck
- ;; Get rid of the Edit menu bar item to save space.
- (define-key archive-mode-map [menu-bar edit] 'undefined)
(define-key archive-mode-map [menu-bar immediate]
(cons "Immediate" (make-sparse-keymap "Immediate")))
(define-key archive-mode-map [menu-bar immediate alternate]
- '("Alternate Display" . archive-alternate-display))
- (put 'archive-alternate-display 'menu-enable
- '(boundp (archive-name "alternate-display")))
+ '(menu-item "Alternate Display" archive-alternate-display
+ :enable (boundp (archive-name "alternate-display"))
+ :help "Toggle alternate file info display"))
(define-key archive-mode-map [menu-bar immediate view]
- '("View This File" . archive-view))
+ '(menu-item "View This File" archive-view
+ :help "Display file at cursor in View Mode"))
(define-key archive-mode-map [menu-bar immediate display]
- '("Display in Other Window" . archive-display-other-window))
+ '(menu-item "Display in Other Window" archive-display-other-window
+ :help "Display file at cursor in another window"))
(define-key archive-mode-map [menu-bar immediate find-file-other-window]
- '("Find in Other Window" . archive-extract-other-window))
+ '(menu-item "Find in Other Window" archive-extract-other-window
+ :help "Edit file at cursor in another window"))
(define-key archive-mode-map [menu-bar immediate find-file]
- '("Find This File" . archive-extract))
+ '(menu-item "Find This File" archive-extract
+ :help "Extract file at cursor and edit it"))
(define-key archive-mode-map [menu-bar mark]
(cons "Mark" (make-sparse-keymap "Mark")))
(define-key archive-mode-map [menu-bar mark unmark-all]
- '("Unmark All" . archive-unmark-all-files))
+ '(menu-item "Unmark All" archive-unmark-all-files
+ :help "Unmark all marked files"))
(define-key archive-mode-map [menu-bar mark deletion]
- '("Flag" . archive-flag-deleted))
+ '(menu-item "Flag" archive-flag-deleted
+ :help "Flag file at cursor for deletion"))
(define-key archive-mode-map [menu-bar mark unmark]
- '("Unflag" . archive-unflag))
+ '(menu-item "Unflag" archive-unflag
+ :help "Unmark file at cursor"))
(define-key archive-mode-map [menu-bar mark mark]
- '("Mark" . archive-mark))
+ '(menu-item "Mark" archive-mark
+ :help "Mark file at cursor"))
(define-key archive-mode-map [menu-bar operate]
(cons "Operate" (make-sparse-keymap "Operate")))
(define-key archive-mode-map [menu-bar operate chown]
- '("Change Owner..." . archive-chown-entry))
- (put 'archive-chown-entry 'menu-enable
- '(fboundp (archive-name "chown-entry")))
+ '(menu-item "Change Owner..." archive-chown-entry
+ :enable (fboundp (archive-name "chown-entry"))
+ :help "Change owner of marked files"))
(define-key archive-mode-map [menu-bar operate chgrp]
- '("Change Group..." . archive-chgrp-entry))
- (put 'archive-chgrp-entry 'menu-enable
- '(fboundp (archive-name "chgrp-entry")))
+ '(menu-item "Change Group..." archive-chgrp-entry
+ :enable (fboundp (archive-name "chgrp-entry"))
+ :help "Change group ownership of marked files"))
(define-key archive-mode-map [menu-bar operate chmod]
- '("Change Mode..." . archive-chmod-entry))
- (put 'archive-chmod-entry 'menu-enable
- '(fboundp (archive-name "chmod-entry")))
+ '(menu-item "Change Mode..." archive-chmod-entry
+ :enable (fboundp (archive-name "chmod-entry"))
+ :help "Change mode (permissions) of marked files"))
(define-key archive-mode-map [menu-bar operate rename]
- '("Rename to..." . archive-rename-entry))
- (put 'archive-rename-entry 'menu-enable
- '(fboundp (archive-name "rename-entry")))
+ '(menu-item "Rename to..." archive-rename-entry
+ :enable (fboundp (archive-name "rename-entry"))
+ :help "Rename marked files"))
;;(define-key archive-mode-map [menu-bar operate copy]
- ;; '("Copy to..." . archive-copy))
+ ;; '(menu-item "Copy to..." archive-copy))
(define-key archive-mode-map [menu-bar operate expunge]
- '("Expunge Marked Files" . archive-expunge))
+ '(menu-item "Expunge Marked Files" archive-expunge
+ :help "Delete all flagged files from archive"))
))
(let* ((item1 '(archive-subfile-mode " Archive"))
(string-match "\\.[aA][rR][cC]$"
(or buffer-file-name (buffer-name))))
'arc)
- (t (error "Buffer format not recognized.")))))
+ (t (error "Buffer format not recognized")))))
;; -------------------------------------------------------------------------
(defun archive-summarize (&optional shut-up)
"Parse the contents of the archive file in the current buffer.
Optional argument SHUT-UP, if non-nil, means don't print messages
when parsing the archive."
(widen)
- (set-buffer-multibyte nil)
(let (buffer-read-only)
(or shut-up
(message "Parsing archive file..."))
(apply
(function concat)
(mapcar
- (function
+ (function
(lambda (fil)
;; Using `concat' here copies the text also, so we can add
;; properties without problems.
(let ((text (concat (aref fil 0) "\n")))
(if archive-lemacs
() ; out of luck
- (put-text-property (aref fil 1) (aref fil 2)
- 'mouse-face 'highlight
- text))
+ (add-text-properties
+ (aref fil 1) (aref fil 2)
+ '(mouse-face highlight
+ help-echo "mouse-2: extract this file into a buffer")
+ text))
text)))
files)))
(setq archive-file-list-end (point-marker)))
If FNAME can be uniquely created in DIR, it is returned unaltered.
If FNAME is something our underlying filesystem can't grok, or if another
file by that name already exists in DIR, a unique new name is generated
-using `make-temp-name', and the generated name is returned."
+using `make-temp-file', and the generated name is returned."
(let ((fullname (expand-file-name fname dir))
(alien (string-match file-name-invalid-regexp fname)))
(if (or alien (file-exists-p fullname))
- (make-temp-name
+ (make-temp-file
(expand-file-name
- (if (and (eq system-type 'ms-dos) (not (msdos-long-file-names)))
+ (if (if (fboundp 'msdos-long-file-names)
+ (not (msdos-long-file-names)))
"am"
"arc-mode.")
dir))
(let ((coding
(or coding-system-for-read
(and set-auto-coding-function
- (funcall set-auto-coding-function
- filename (- (point-max) (point-min))))
+ (save-excursion
+ (funcall set-auto-coding-function
+ filename (- (point-max) (point-min)))))
;; dos-w32.el defines find-operation-coding-system for
;; DOS/Windows systems which preserves the coding-system
;; of existing files. We want it to act here as if the
(setq last-coding-system-used coding))
(set-buffer-modified-p nil)
(kill-local-variable 'buffer-file-coding-system)
- (after-insert-file-set-buffer-file-coding-system (- (point-max)
- (point-min))))))
+ (after-insert-file-set-coding (- (point-max) (point-min))))))
(defun archive-mouse-extract (event)
"Extract a file whose name you click on."
view-p
(string-match file-name-invalid-regexp ename)))
(buffer (get-buffer bufname))
- (just-created nil))
+ (just-created nil)
+ (file-name-coding archive-file-name-coding-system))
(if buffer
nil
(setq archive (archive-maybe-copy archive))
(make-local-variable 'local-write-file-hooks)
(add-hook 'local-write-file-hooks 'archive-write-file-member)
(setq archive-subfile-mode descr)
+ (setq archive-file-name-coding-system file-name-coding)
(if (and
(null
(let (;; We may have to encode file name arguement for
;; external programs.
(coding-system-for-write
(and enable-multibyte-characters
- file-name-coding-system))
+ archive-file-name-coding-system))
;; We read an archive member by no-conversion at
;; first, then decode appropriately by calling
;; archive-set-buffer-as-visiting-file later.
(if (aref descr 3)
;; Set the file modes, but make sure we can read it.
(set-file-modes tmpfile (logior ?\400 (aref descr 3))))
- (if enable-multibyte-characters
- (setq ename
- (encode-coding-string ename file-name-coding-system)))
- (let ((exitcode (apply 'call-process
- (car command)
- nil
- nil
- nil
- (append (cdr command) (list archive ename)))))
+ (setq ename
+ (encode-coding-string ename archive-file-name-coding-system))
+ (let* ((coding-system-for-write 'no-conversion)
+ (exitcode (apply 'call-process
+ (car command)
+ nil
+ nil
+ nil
+ (append (cdr command)
+ (list archive ename)))))
(if (equal exitcode 0)
nil
(error "Updating was unsuccessful (%S)" exitcode))))
(if (fboundp func)
(progn
(funcall func (buffer-file-name)
- (if enable-multibyte-characters
- (encode-coding-string newname file-name-coding-system)
- newname)
+ (encode-coding-string newname
+ archive-file-name-coding-system)
descr)
(archive-resummarize))
(error "Renaming is not supported for this archive type"))))
(setq archive-files nil)
(let ((revert-buffer-function nil)
(coding-system-for-read 'no-conversion))
- (set-buffer-multibyte nil)
(revert-buffer t t))
(archive-mode)
(goto-char archive-file-list-start)
files
visual)
(while (and (< (+ p 29) (point-max))
- (= (char-after p) ?\C-z)
- (> (char-after (1+ p)) 0))
+ (= (byte-after p) ?\C-z)
+ (> (byte-after (1+ p)) 0))
(let* ((namefld (buffer-substring (+ p 2) (+ p 2 13)))
(fnlen (or (string-match "\0" namefld) 13))
- (efnname (substring namefld 0 fnlen))
+ (efnname (decode-coding-string (substring namefld 0 fnlen)
+ archive-file-name-coding-system))
(csize (archive-l-e (+ p 15) 4))
(moddate (archive-l-e (+ p 19) 2))
(modtime (archive-l-e (+ p 21) 2))
(defun archive-arc-rename-entry (archive newname descr)
(if (string-match "[:\\\\/]" newname)
- (error "File names in arc files may not contain a path"))
+ (error "File names in arc files must not contain a directory component"))
(if (> (length newname) 12)
(error "File names in arc files are limited to 12 characters"))
(let ((name (concat newname (substring "\0\0\0\0\0\0\0\0\0\0\0\0\0"
(save-restriction
(save-excursion
(widen)
- (set-buffer-multibyte nil)
(goto-char (+ archive-proper-file-start (aref descr 4) 2))
(delete-char 13)
- (insert name)))))
+ (insert-unibyte name)))))
;; -------------------------------------------------------------------------
;; Section: Lzh Archives
(maxlen 8)
files
visual)
- (while (progn (goto-char p)
+ (while (progn (goto-char p) ;beginning of a base header.
(looking-at "\\(.\\|\n\\)\\(.\\|\n\\)-l[hz][0-9ds]-"))
- (let* ((hsize (char-after p))
- (csize (archive-l-e (+ p 7) 4))
- (ucsize (archive-l-e (+ p 11) 4))
- (modtime (archive-l-e (+ p 15) 2))
- (moddate (archive-l-e (+ p 17) 2))
- (hdrlvl (char-after (+ p 20)))
- (fnlen (char-after (+ p 21)))
- (efnname (let ((str (buffer-substring (+ p 22) (+ p 22 fnlen))))
- (if file-name-coding-system
- (decode-coding-string str file-name-coding-system)
- (string-as-multibyte str))))
- (fiddle (string= efnname (upcase efnname)))
- (ifnname (if fiddle (downcase efnname) efnname))
- (width (string-width ifnname))
- (p2 (+ p 22 fnlen))
- (creator (if (>= (- hsize fnlen) 24) (char-after (+ p2 2)) 0))
- mode modestr uid gid text path prname
- )
- (if (= hdrlvl 0)
- (setq mode (if (= creator ?U) (archive-l-e (+ p2 8) 2) ?\666)
- uid (if (= creator ?U) (archive-l-e (+ p2 10) 2))
- gid (if (= creator ?U) (archive-l-e (+ p2 12) 2)))
- (if (= creator ?U)
- (let* ((p3 (+ p2 3))
- (hsize (archive-l-e p3 2))
- (etype (char-after (+ p3 2))))
- (while (not (= hsize 0))
+ (let* ((hsize (byte-after p)) ;size of the base header (level 0 and 1)
+ (csize (archive-l-e (+ p 7) 4)) ;size of a compressed file to follow (level 0 and 2),
+ ;size of extended headers + the compressed file to follow (level 1).
+ (ucsize (archive-l-e (+ p 11) 4)) ;size of an uncompressed file.
+ (time1 (archive-l-e (+ p 15) 2)) ;date/time (MSDOS format in level 0, 1 headers
+ (time2 (archive-l-e (+ p 17) 2)) ;and UNIX format in level 2 header.)
+ (hdrlvl (byte-after (+ p 20))) ;header level
+ thsize ;total header size (base + extensions)
+ fnlen efnname fiddle ifnname width p2 creator
+ neh ;beginning of next extension header (level 1 and 2)
+ mode modestr uid gid text dir prname
+ gname uname modtime moddate)
+ (if (= hdrlvl 3) (error "can't handle lzh level 3 header type"))
+ (when (or (= hdrlvl 0) (= hdrlvl 1))
+ (setq fnlen (byte-after (+ p 21))) ;filename length
+ (setq efnname (let ((str (buffer-substring (+ p 22) (+ p 22 fnlen)))) ;filename from offset 22
+ (decode-coding-string
+ str archive-file-name-coding-system)))
+ (setq p2 (+ p 22 fnlen))) ;
+ (if (= hdrlvl 1)
+ (progn ;specific to level 1 header
+ (setq creator (if (>= (- hsize fnlen) 24) (byte-after (+ p2 2)) 0))
+ (setq neh (+ p2 3)))
+ (if (= hdrlvl 2)
+ (progn ;specific to level 2 header
+ (setq creator (byte-after (+ p 23)) )
+ (setq neh (+ p 24)))))
+ (if neh ;if level 1 or 2 we expect extension headers to follow
+ (let* ((ehsize (archive-l-e neh 2)) ;size of the extension header
+ (etype (byte-after (+ neh 2)))) ;extension type
+ (while (not (= ehsize 0))
(cond
- ((= etype 2) (let ((i (+ p3 3)))
- (while (< i (+ p3 hsize))
- (setq path (concat path
- (if (= (char-after i)
+ ((= etype 1) ;file name
+ (let ((i (+ neh 3)))
+ (while (< i (+ neh ehsize))
+ (setq efnname (concat efnname (char-to-string (byte-after i))))
+ (setq i (1+ i)))))
+ ((= etype 2) ;directory name
+ (let ((i (+ neh 3)))
+ (while (< i (+ neh ehsize))
+ (setq dir (concat dir
+ (if (= (byte-after i)
255)
"/"
(char-to-string
(char-after i)))))
(setq i (1+ i)))))
- ((= etype 80) (setq mode (archive-l-e (+ p3 3) 2)))
- ((= etype 81) (progn (setq uid (archive-l-e (+ p3 3) 2))
- (setq gid (archive-l-e (+ p3 5) 2))))
+ ((= etype 80) ;Unix file permission
+ (setq mode (archive-l-e (+ neh 3) 2)))
+ ((= etype 81) ;UNIX file group/user ID
+ (progn (setq uid (archive-l-e (+ neh 3) 2))
+ (setq gid (archive-l-e (+ neh 5) 2))))
+ ((= etype 82) ;UNIX file group name
+ (let ((i (+ neh 3)))
+ (while (< i (+ neh ehsize))
+ (setq gname (concat gname (char-to-string (char-after i))))
+ (setq i (1+ i)))))
+ ((= etype 83) ;UNIX file user name
+ (let ((i (+ neh 3)))
+ (while (< i (+ neh ehsize))
+ (setq uname (concat uname (char-to-string (char-after i))))
+ (setq i (1+ i)))))
)
- (setq p3 (+ p3 hsize))
- (setq hsize (archive-l-e p3 2))
- (setq etype (char-after (+ p3 2)))))))
- (setq prname (if path (concat path ifnname) ifnname))
+ (setq neh (+ neh ehsize))
+ (setq ehsize (archive-l-e neh 2))
+ (setq etype (byte-after (+ neh 2))))
+ ;;get total header size for level 1 and 2 headers
+ (setq thsize (- neh p))))
+ (if (= hdrlvl 0) ;total header size
+ (setq thsize hsize))
+ (setq fiddle (if efnname (string= efnname (upcase efnname))))
+ (setq ifnname (if fiddle (downcase efnname) efnname))
+ (setq prname (if dir (concat dir ifnname) ifnname))
+ (setq width (if prname (string-width prname) 0))
(setq modestr (if mode (archive-int-to-mode mode) "??????????"))
+ (setq moddate (if (= hdrlvl 2)
+ (archive-unixdate time1 time2) ;level 2 header in UNIX format
+ (archive-dosdate time2))) ;level 0 and 1 header in DOS format
+ (setq modtime (if (= hdrlvl 2)
+ (archive-unixtime time1 time2)
+ (archive-dostime time1)))
(setq text (if archive-alternate-display
(format " %8d %5S %5S %s"
ucsize
(format " %10s %8d %-11s %-8s %s"
modestr
ucsize
- (archive-dosdate moddate)
- (archive-dostime modtime)
- ifnname)))
+ moddate
+ modtime
+ prname)))
(setq maxlen (max maxlen width)
totalsize (+ totalsize ucsize)
visual (cons (vector text
- (- (length text) (length ifnname))
+ (- (length text) (length prname))
(length text))
visual)
files (cons (vector prname ifnname fiddle mode (1- p))
- files)
- p (+ p hsize 2 csize))))
+ files))
+ (cond ((= hdrlvl 1)
+ (setq p (+ p hsize 2 csize)))
+ ((or (= hdrlvl 2) (= hdrlvl 0))
+ (setq p (+ p thsize 2 csize))))
+ ))
(goto-char (point-min))
- (set-buffer-multibyte default-enable-multibyte-characters)
(let ((dash (concat (if archive-alternate-display
"- -------- ----- ----- "
"- ---------- -------- ----------- -------- ")
(let ((sum 0))
(while (> count 0)
(setq count (1- count)
- sum (+ sum (char-after p))
+ sum (+ sum (byte-after p))
p (1+ p)))
(logand sum 255)))
(save-restriction
(save-excursion
(widen)
- (set-buffer-multibyte nil)
(let* ((p (+ archive-proper-file-start (aref descr 4)))
- (oldhsize (char-after p))
- (oldfnlen (char-after (+ p 21)))
+ (oldhsize (byte-after p))
+ (oldfnlen (byte-after (+ p 21)))
(newfnlen (length newname))
(newhsize (+ oldhsize newfnlen (- oldfnlen)))
buffer-read-only)
(error "The file name is too long"))
(goto-char (+ p 21))
(delete-char (1+ oldfnlen))
- (insert newfnlen newname)
+ (insert-unibyte newfnlen newname)
(goto-char p)
(delete-char 2)
- (insert newhsize (archive-lzh-resum p newhsize))))))
+ (insert-unibyte newhsize (archive-lzh-resum p newhsize))))))
(defun archive-lzh-ogm (newval files errtxt ofs)
(save-restriction
(save-excursion
(widen)
- (set-buffer-multibyte nil)
(while files
(let* ((fil (car files))
(p (+ archive-proper-file-start (aref fil 4)))
- (hsize (char-after p))
- (fnlen (char-after (+ p 21)))
+ (hsize (byte-after p))
+ (fnlen (byte-after (+ p 21)))
(p2 (+ p 22 fnlen))
- (creator (if (>= (- hsize fnlen) 24) (char-after (+ p2 2)) 0))
+ (creator (if (>= (- hsize fnlen) 24) (byte-after (+ p2 2)) 0))
buffer-read-only)
(if (= creator ?U)
(progn
(setq newval (funcall newval (archive-l-e (+ p2 ofs) 2))))
(goto-char (+ p2 ofs))
(delete-char 2)
- (insert (logand newval 255) (lsh newval -8))
+ (insert-unibyte (logand newval 255) (lsh newval -8))
(goto-char (1+ p))
(delete-char 1)
- (insert (archive-lzh-resum (1+ p) hsize)))
+ (insert-unibyte (archive-lzh-resum (1+ p) hsize)))
(message "Member %s does not have %s field"
(aref fil 1) errtxt)))
(setq files (cdr files))))))
(defun archive-zip-summarize ()
(goto-char (- (point-max) (- 22 18)))
(search-backward-regexp "[P]K\005\006")
- (let ((p (1+ (archive-l-e (+ (point) 16) 4)))
+ (let ((p (+ (point-min) (archive-l-e (+ (point) 16) 4)))
(maxlen 8)
(totalsize 0)
files
visual)
(while (string= "PK\001\002" (buffer-substring p (+ p 4)))
- (let* ((creator (char-after (+ p 5)))
+ (let* ((creator (byte-after (+ p 5)))
(method (archive-l-e (+ p 10) 2))
(modtime (archive-l-e (+ p 12) 2))
(moddate (archive-l-e (+ p 14) 2))
(fclen (archive-l-e (+ p 32) 2))
(lheader (archive-l-e (+ p 42) 4))
(efnname (let ((str (buffer-substring (+ p 46) (+ p 46 fnlen))))
- (if file-name-coding-system
- (decode-coding-string str file-name-coding-system)
- (string-as-multibyte str))))
+ (decode-coding-string
+ str archive-file-name-coding-system)))
(isdir (and (= ucsize 0)
(string= (file-name-nondirectory efnname) "")))
(mode (cond ((memq creator '(2 3)) ; Unix + VMS
(logior ?\444
(if isdir (logior 16384 ?\111) 0)
(if (zerop
- (logand 1 (char-after (+ p 38))))
+ (logand 1 (byte-after (+ p 38))))
?\222 0)))
(t nil)))
(modestr (if mode (archive-int-to-mode mode) "??????????"))
(apply 'vector (nreverse files))))
(defun archive-zip-extract (archive name)
- (if archive-zip-use-pkzip
+ (if (equal (car archive-zip-extract) "pkzip")
(archive-*-extract archive name archive-zip-extract)
(archive-extract-by-stdout archive name archive-zip-extract)))
(save-restriction
(save-excursion
(widen)
- (set-buffer-multibyte nil)
(while files
(let* ((fil (car files))
(p (+ archive-proper-file-start (car (aref fil 4))))
- (creator (char-after (+ p 5)))
+ (creator (byte-after (+ p 5)))
(oldmode (aref fil 3))
(newval (archive-calc-mode oldmode newmode t))
buffer-read-only)
(cond ((memq creator '(2 3)) ; Unix + VMS
(goto-char (+ p 40))
(delete-char 2)
- (insert (logand newval 255) (lsh newval -8)))
+ (insert-unibyte (logand newval 255) (lsh newval -8)))
((memq creator '(0 5 6 7 10 11 15)) ; Dos etc.
(goto-char (+ p 38))
- (insert (logior (logand (char-after (point)) 254)
- (logand (logxor 1 (lsh newval -7)) 1)))
+ (insert-unibyte (logior (logand (byte-after (point)) 254)
+ (logand (logxor 1 (lsh newval -7)) 1)))
(delete-char 1))
(t (message "Don't know how to change mode for this member"))))
(setq files (cdr files))))))
(modtime (archive-l-e (+ p 16) 2))
(ucsize (archive-l-e (+ p 20) 4))
(namefld (buffer-substring (+ p 38) (+ p 38 13)))
- (dirtype (char-after (+ p 4)))
- (lfnlen (if (= dirtype 2) (char-after (+ p 56)) 0))
- (ldirlen (if (= dirtype 2) (char-after (+ p 57)) 0))
+ (dirtype (byte-after (+ p 4)))
+ (lfnlen (if (= dirtype 2) (byte-after (+ p 56)) 0))
+ (ldirlen (if (= dirtype 2) (byte-after (+ p 57)) 0))
(fnlen (or (string-match "\0" namefld) 13))
(efnname (let ((str
(concat
(buffer-substring (+ p 58)
(+ p 58 lfnlen -1))
(substring namefld 0 fnlen)))))
- (if file-name-coding-system
- (decode-coding-string str file-name-coding-system)
- (string-as-multibyte str))))
+ (decode-coding-string
+ str archive-file-name-coding-system)))
(fiddle (and (= lfnlen 0) (string= efnname (upcase efnname))))
(ifnname (if fiddle (downcase efnname) efnname))
(width (string-width ifnname))
(archive-dosdate moddate)
(archive-dostime modtime)
ifnname)))
- (setq maxlen (max maxlen (length width))
+ (setq maxlen (max maxlen width)
totalsize (+ totalsize ucsize)
visual (cons (vector text
(- (length text) (length ifnname))
(defun archive-zoo-extract (archive name)
(archive-extract-by-stdout archive name archive-zoo-extract))
;; -------------------------------------------------------------------------
+;; This line was a mistake; it is kept now for compatibility.
+;; rms 15 Oct 98
(provide 'archive-mode)
-;; arc-mode.el ends here.
+(provide 'arc-mode)
+
+;;; arc-mode.el ends here
HCoop / bpt / emacs.git / blobdiff