1 |
;;; arc-mode.el --- simple editing of archives |
;;; arc-mode.el --- simple editing of archives |
2 |
|
|
3 |
;; Copyright (C) 1995, 1997, 1998 Free Software Foundation, Inc. |
;; Copyright (C) 1995, 1997, 1998, 2003 Free Software Foundation, Inc. |
4 |
|
|
5 |
;; Author: Morten Welinder <terra@diku.dk> |
;; Author: Morten Welinder <terra@diku.dk> |
6 |
;; Keywords: archives msdog editing major-mode |
;; Keywords: archives msdog editing major-mode |
77 |
;; |
;; |
78 |
;; LZH A series of (header,file). Headers are checksummed. No |
;; LZH A series of (header,file). Headers are checksummed. No |
79 |
;; interaction among members. |
;; interaction among members. |
80 |
|
;; Headers come in three flavours called level 0, 1 and 2 headers. |
81 |
|
;; Level 2 header is free of DOS specific restrictions and most |
82 |
|
;; prevalently used. Also level 1 and 2 headers consist of base |
83 |
|
;; and extension headers. For more details see |
84 |
|
;; http://homepage1.nifty.com/dangan/en/Content/Program/Java/jLHA/Notes/Notes.html |
85 |
|
;; http://www.osirusoft.com/joejared/lzhformat.html |
86 |
;; |
;; |
87 |
;; ZIP A series of (lheader,fil) followed by a "central directory" |
;; ZIP A series of (lheader,fil) followed by a "central directory" |
88 |
;; which is a series of (cheader) followed by an end-of- |
;; which is a series of (cheader) followed by an end-of- |
324 |
;; ------------------------------------------------------------------------- |
;; ------------------------------------------------------------------------- |
325 |
;; Section: Variables |
;; Section: Variables |
326 |
|
|
327 |
(defvar archive-subtype nil "*Symbol describing archive type.") |
(defvar archive-subtype nil "Symbol describing archive type.") |
328 |
(defvar archive-file-list-start nil "*Position of first contents line.") |
(defvar archive-file-list-start nil "Position of first contents line.") |
329 |
(defvar archive-file-list-end nil "*Position just after last contents line.") |
(defvar archive-file-list-end nil "Position just after last contents line.") |
330 |
(defvar archive-proper-file-start nil "*Position of real archive's start.") |
(defvar archive-proper-file-start nil "Position of real archive's start.") |
331 |
(defvar archive-read-only nil "*Non-nil if the archive is read-only on disk.") |
(defvar archive-read-only nil "Non-nil if the archive is read-only on disk.") |
332 |
(defvar archive-local-name nil "*Name of local copy of remote archive.") |
(defvar archive-local-name nil "Name of local copy of remote archive.") |
333 |
(defvar archive-mode-map nil "*Local keymap for archive mode listings.") |
(defvar archive-mode-map nil "Local keymap for archive mode listings.") |
334 |
(defvar archive-file-name-indent nil "*Column where file names start.") |
(defvar archive-file-name-indent nil "Column where file names start.") |
335 |
|
|
336 |
(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.") |
337 |
(make-variable-buffer-local 'archive-remote) |
(make-variable-buffer-local 'archive-remote) |
338 |
(put 'archive-remote 'permanent-local t) |
(put 'archive-remote 'permanent-local t) |
339 |
|
|
341 |
(make-variable-buffer-local 'archive-member-coding-system) |
(make-variable-buffer-local 'archive-member-coding-system) |
342 |
|
|
343 |
(defvar archive-alternate-display nil |
(defvar archive-alternate-display nil |
344 |
"*Non-nil when alternate information is shown.") |
"Non-nil when alternate information is shown.") |
345 |
(make-variable-buffer-local 'archive-alternate-display) |
(make-variable-buffer-local 'archive-alternate-display) |
346 |
(put 'archive-alternate-display 'permanent-local t) |
(put 'archive-alternate-display 'permanent-local t) |
347 |
|
|
348 |
(defvar archive-superior-buffer nil "*In archive members, points to archive.") |
(defvar archive-superior-buffer nil "In archive members, points to archive.") |
349 |
(put 'archive-superior-buffer 'permanent-local t) |
(put 'archive-superior-buffer 'permanent-local t) |
350 |
|
|
351 |
(defvar archive-subfile-mode nil "*Non-nil in archive member buffers.") |
(defvar archive-subfile-mode nil "Non-nil in archive member buffers.") |
352 |
(make-variable-buffer-local 'archive-subfile-mode) |
(make-variable-buffer-local 'archive-subfile-mode) |
353 |
(put 'archive-subfile-mode 'permanent-local t) |
(put 'archive-subfile-mode 'permanent-local t) |
354 |
|
|
469 |
(second (* 2 (logand time 31)))) ; 2 seconds resolution |
(second (* 2 (logand time 31)))) ; 2 seconds resolution |
470 |
(format "%02d:%02d:%02d" hour minute second))) |
(format "%02d:%02d:%02d" hour minute second))) |
471 |
|
|
472 |
;;(defun archive-unixdate (low high) |
(defun archive-unixdate (low high) |
473 |
;; "Stringify unix (LOW HIGH) date." |
"Stringify unix (LOW HIGH) date." |
474 |
;; (let ((str (current-time-string (cons high low)))) |
(let ((str (current-time-string (cons high low)))) |
475 |
;; (format "%s-%s-%s" |
(format "%s-%s-%s" |
476 |
;; (substring str 8 9) |
(substring str 8 10) |
477 |
;; (substring str 4 7) |
(substring str 4 7) |
478 |
;; (substring str 20 24)))) |
(substring str 20 24)))) |
479 |
|
|
480 |
;;(defun archive-unixtime (low high) |
(defun archive-unixtime (low high) |
481 |
;; "Stringify unix (LOW HIGH) time." |
"Stringify unix (LOW HIGH) time." |
482 |
;; (let ((str (current-time-string (cons high low)))) |
(let ((str (current-time-string (cons high low)))) |
483 |
;; (substring str 11 19))) |
(substring str 11 19))) |
484 |
|
|
485 |
(defun archive-get-lineno () |
(defun archive-get-lineno () |
486 |
(if (>= (point) archive-file-list-start) |
(if (>= (point) archive-file-list-start) |
624 |
;; Not a nice "solution" but it'll have to do |
;; Not a nice "solution" but it'll have to do |
625 |
(define-key archive-mode-map "\C-xu" 'archive-undo) |
(define-key archive-mode-map "\C-xu" 'archive-undo) |
626 |
(define-key archive-mode-map "\C-_" 'archive-undo)) |
(define-key archive-mode-map "\C-_" 'archive-undo)) |
627 |
(substitute-key-definition 'undo 'archive-undo |
(define-key archive-mode-map [remap advertised-undo] 'archive-undo) |
628 |
archive-mode-map global-map)) |
(define-key archive-mode-map [remap undo] 'archive-undo)) |
629 |
|
|
630 |
(define-key archive-mode-map |
(define-key archive-mode-map |
631 |
(if archive-lemacs 'button2 [mouse-2]) 'archive-mouse-extract) |
(if archive-lemacs 'button2 [mouse-2]) 'archive-mouse-extract) |
757 |
(apply |
(apply |
758 |
(function concat) |
(function concat) |
759 |
(mapcar |
(mapcar |
760 |
(function |
(function |
761 |
(lambda (fil) |
(lambda (fil) |
762 |
;; Using `concat' here copies the text also, so we can add |
;; Using `concat' here copies the text also, so we can add |
763 |
;; properties without problems. |
;; properties without problems. |
795 |
(if (or alien (file-exists-p fullname)) |
(if (or alien (file-exists-p fullname)) |
796 |
(make-temp-file |
(make-temp-file |
797 |
(expand-file-name |
(expand-file-name |
798 |
(if (and (fboundp 'msdos-long-file-names) |
(if (if (fboundp 'msdos-long-file-names) |
799 |
(not (msdos-long-file-names))) |
(not (msdos-long-file-names))) |
800 |
"am" |
"am" |
801 |
"arc-mode.") |
"arc-mode.") |
802 |
dir)) |
dir)) |
1392 |
|
|
1393 |
(defun archive-arc-rename-entry (archive newname descr) |
(defun archive-arc-rename-entry (archive newname descr) |
1394 |
(if (string-match "[:\\\\/]" newname) |
(if (string-match "[:\\\\/]" newname) |
1395 |
(error "File names in arc files may not contain a path")) |
(error "File names in arc files must not contain a directory component")) |
1396 |
(if (> (length newname) 12) |
(if (> (length newname) 12) |
1397 |
(error "File names in arc files are limited to 12 characters")) |
(error "File names in arc files are limited to 12 characters")) |
1398 |
(let ((name (concat newname (substring "\0\0\0\0\0\0\0\0\0\0\0\0\0" |
(let ((name (concat newname (substring "\0\0\0\0\0\0\0\0\0\0\0\0\0" |
1414 |
(maxlen 8) |
(maxlen 8) |
1415 |
files |
files |
1416 |
visual) |
visual) |
1417 |
(while (progn (goto-char p) |
(while (progn (goto-char p) ;beginning of a base header. |
1418 |
(looking-at "\\(.\\|\n\\)\\(.\\|\n\\)-l[hz][0-9ds]-")) |
(looking-at "\\(.\\|\n\\)\\(.\\|\n\\)-l[hz][0-9ds]-")) |
1419 |
(let* ((hsize (char-after p)) |
(let* ((hsize (char-after p)) ;size of the base header (level 0 and 1) |
1420 |
(csize (archive-l-e (+ p 7) 4)) |
(csize (archive-l-e (+ p 7) 4)) ;size of a compressed file to follow. |
1421 |
(ucsize (archive-l-e (+ p 11) 4)) |
(ucsize (archive-l-e (+ p 11) 4)) ;size of an uncompressed file. |
1422 |
(modtime (archive-l-e (+ p 15) 2)) |
(time1 (archive-l-e (+ p 15) 2)) ;date/time (MSDOS format in level 0, 1 headers |
1423 |
(moddate (archive-l-e (+ p 17) 2)) |
(time2 (archive-l-e (+ p 17) 2)) ;and UNIX format in level 2 header.) |
1424 |
(hdrlvl (char-after (+ p 20))) |
(hdrlvl (char-after (+ p 20))) ;header level |
1425 |
(fnlen (char-after (+ p 21))) |
thsize ;total header size (base + extensions) |
1426 |
(efnname (let ((str (buffer-substring (+ p 22) (+ p 22 fnlen)))) |
fnlen efnname fiddle ifnname width p2 creator |
1427 |
|
neh ;beginning of next extension header (level 1 and 2) |
1428 |
|
mode modestr uid gid text dir prname |
1429 |
|
gname uname modtime moddate) |
1430 |
|
(if (= hdrlvl 3) (error "can't handle lzh level 3 header type")) |
1431 |
|
(when (or (= hdrlvl 0) (= hdrlvl 1)) |
1432 |
|
(setq fnlen (char-after (+ p 21))) ;filename length |
1433 |
|
(setq efnname (let ((str (buffer-substring (+ p 22) (+ p 22 fnlen)))) ;filename from offset 22 |
1434 |
(if file-name-coding-system |
(if file-name-coding-system |
1435 |
(decode-coding-string str file-name-coding-system) |
(decode-coding-string str file-name-coding-system) |
1436 |
(string-as-multibyte str)))) |
(string-as-multibyte str)))) |
1437 |
(fiddle (string= efnname (upcase efnname))) |
(setq p2 (+ p 22 fnlen))) ; |
1438 |
(ifnname (if fiddle (downcase efnname) efnname)) |
(if (= hdrlvl 1) |
1439 |
(width (string-width ifnname)) |
(progn ;specific to level 1 header |
1440 |
(p2 (+ p 22 fnlen)) |
(setq creator (if (>= (- hsize fnlen) 24) (char-after (+ p2 2)) 0)) |
1441 |
(creator (if (>= (- hsize fnlen) 24) (char-after (+ p2 2)) 0)) |
(setq neh (+ p2 3))) |
1442 |
mode modestr uid gid text path prname |
(if (= hdrlvl 2) |
1443 |
) |
(progn ;specific to level 2 header |
1444 |
(if (= hdrlvl 0) |
(setq creator (char-after (+ p 23)) ) |
1445 |
(setq mode (if (= creator ?U) (archive-l-e (+ p2 8) 2) ?\666) |
(setq neh (+ p 24))))) |
1446 |
uid (if (= creator ?U) (archive-l-e (+ p2 10) 2)) |
(if neh ;if level 1 or 2 we expect extension headers to follow |
1447 |
gid (if (= creator ?U) (archive-l-e (+ p2 12) 2))) |
(let* ((ehsize (archive-l-e neh 2)) ;size of the extension header |
1448 |
(if (= creator ?U) |
(etype (char-after (+ neh 2)))) ;extension type |
1449 |
(let* ((p3 (+ p2 3)) |
(while (not (= ehsize 0)) |
|
(hsize (archive-l-e p3 2)) |
|
|
(etype (char-after (+ p3 2)))) |
|
|
(while (not (= hsize 0)) |
|
1450 |
(cond |
(cond |
1451 |
((= etype 2) (let ((i (+ p3 3))) |
((= etype 1) ;file name |
1452 |
(while (< i (+ p3 hsize)) |
(let ((i (+ neh 3))) |
1453 |
(setq path (concat path |
(while (< i (+ neh ehsize)) |
1454 |
|
(setq efnname (concat efnname (char-to-string (char-after i)))) |
1455 |
|
(setq i (1+ i))))) |
1456 |
|
((= etype 2) ;directory name |
1457 |
|
(let ((i (+ neh 3))) |
1458 |
|
(while (< i (+ neh ehsize)) |
1459 |
|
(setq dir (concat dir |
1460 |
(if (= (char-after i) |
(if (= (char-after i) |
1461 |
255) |
255) |
1462 |
"/" |
"/" |
1463 |
(char-to-string |
(char-to-string |
1464 |
(char-after i))))) |
(char-after i))))) |
1465 |
(setq i (1+ i))))) |
(setq i (1+ i))))) |
1466 |
((= etype 80) (setq mode (archive-l-e (+ p3 3) 2))) |
((= etype 80) ;Unix file permission |
1467 |
((= etype 81) (progn (setq uid (archive-l-e (+ p3 3) 2)) |
(setq mode (archive-l-e (+ neh 3) 2))) |
1468 |
(setq gid (archive-l-e (+ p3 5) 2)))) |
((= etype 81) ;UNIX file group/user ID |
1469 |
|
(progn (setq uid (archive-l-e (+ neh 3) 2)) |
1470 |
|
(setq gid (archive-l-e (+ neh 5) 2)))) |
1471 |
|
((= etype 82) ;UNIX file group name |
1472 |
|
(let ((i (+ neh 3))) |
1473 |
|
(while (< i (+ neh ehsize)) |
1474 |
|
(setq gname (concat gname (char-to-string (char-after i)))) |
1475 |
|
(setq i (1+ i))))) |
1476 |
|
((= etype 83) ;UNIX file user name |
1477 |
|
(let ((i (+ neh 3))) |
1478 |
|
(while (< i (+ neh ehsize)) |
1479 |
|
(setq uname (concat uname (char-to-string (char-after i)))) |
1480 |
|
(setq i (1+ i))))) |
1481 |
) |
) |
1482 |
(setq p3 (+ p3 hsize)) |
(setq neh (+ neh ehsize)) |
1483 |
(setq hsize (archive-l-e p3 2)) |
(setq ehsize (archive-l-e neh 2)) |
1484 |
(setq etype (char-after (+ p3 2))))))) |
(setq etype (char-after (+ neh 2)))) |
1485 |
(setq prname (if path (concat path ifnname) ifnname)) |
;;get total header size for level 1 and 2 headers |
1486 |
|
(setq thsize (- neh p)))) |
1487 |
|
(if (= hdrlvl 0) ;total header size |
1488 |
|
(setq thsize hsize)) |
1489 |
|
(setq fiddle (if efnname (string= efnname (upcase efnname)))) |
1490 |
|
(setq ifnname (if fiddle (downcase efnname) efnname)) |
1491 |
|
(setq prname (if dir (concat dir ifnname) ifnname)) |
1492 |
|
(setq width (if prname (string-width prname) 0)) |
1493 |
(setq modestr (if mode (archive-int-to-mode mode) "??????????")) |
(setq modestr (if mode (archive-int-to-mode mode) "??????????")) |
1494 |
|
(setq moddate (if (= hdrlvl 2) |
1495 |
|
(archive-unixdate time1 time2) ;level 2 header in UNIX format |
1496 |
|
(archive-dosdate time2))) ;level 0 and 1 header in DOS format |
1497 |
|
(setq modtime (if (= hdrlvl 2) |
1498 |
|
(archive-unixtime time1 time2) |
1499 |
|
(archive-dostime time1))) |
1500 |
(setq text (if archive-alternate-display |
(setq text (if archive-alternate-display |
1501 |
(format " %8d %5S %5S %s" |
(format " %8d %5S %5S %s" |
1502 |
ucsize |
ucsize |
1506 |
(format " %10s %8d %-11s %-8s %s" |
(format " %10s %8d %-11s %-8s %s" |
1507 |
modestr |
modestr |
1508 |
ucsize |
ucsize |
1509 |
(archive-dosdate moddate) |
moddate |
1510 |
(archive-dostime modtime) |
modtime |
1511 |
ifnname))) |
prname))) |
1512 |
(setq maxlen (max maxlen width) |
(setq maxlen (max maxlen width) |
1513 |
totalsize (+ totalsize ucsize) |
totalsize (+ totalsize ucsize) |
1514 |
visual (cons (vector text |
visual (cons (vector text |
1515 |
(- (length text) (length ifnname)) |
(- (length text) (length prname)) |
1516 |
(length text)) |
(length text)) |
1517 |
visual) |
visual) |
1518 |
files (cons (vector prname ifnname fiddle mode (1- p)) |
files (cons (vector prname ifnname fiddle mode (1- p)) |
1519 |
files) |
files) |
1520 |
p (+ p hsize 2 csize)))) |
p (+ p thsize 2 csize)))) |
1521 |
(goto-char (point-min)) |
(goto-char (point-min)) |
1522 |
(set-buffer-multibyte default-enable-multibyte-characters) |
(set-buffer-multibyte default-enable-multibyte-characters) |
1523 |
(let ((dash (concat (if archive-alternate-display |
(let ((dash (concat (if archive-alternate-display |
1618 |
(defun archive-zip-summarize () |
(defun archive-zip-summarize () |
1619 |
(goto-char (- (point-max) (- 22 18))) |
(goto-char (- (point-max) (- 22 18))) |
1620 |
(search-backward-regexp "[P]K\005\006") |
(search-backward-regexp "[P]K\005\006") |
1621 |
(let ((p (1+ (archive-l-e (+ (point) 16) 4))) |
(let ((p (+ (point-min) (archive-l-e (+ (point) 16) 4))) |
1622 |
(maxlen 8) |
(maxlen 8) |
1623 |
(totalsize 0) |
(totalsize 0) |
1624 |
files |
files |