/[emacs]/emacs/lisp/arc-mode.el
ViewVC logotype

Diff of /emacs/lisp/arc-mode.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.47 by rms, Sun May 19 16:02:26 2002 UTC revision 1.47.2.1 by miles, Fri Apr 4 06:20:00 2003 UTC
# Line 1  Line 1 
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
# Line 77  Line 77 
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-
# Line 318  Archive and member name will be added." Line 324  Archive and member name will be added."
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    
# Line 335  Archive and member name will be added." Line 341  Archive and member name will be added."
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    
# Line 463  the mode is invalid.  If ERROR is nil th Line 469  the mode is invalid.  If ERROR is nil th
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)
# Line 618  archive. Line 624  archive.
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)
# Line 751  when parsing the archive." Line 757  when parsing the archive."
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.
# Line 789  using `make-temp-file', and the generate Line 795  using `make-temp-file', and the generate
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))
# Line 1386  This doesn't recover lost files, it just Line 1392  This doesn't recover lost files, it just
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"
# Line 1408  This doesn't recover lost files, it just Line 1414  This doesn't recover lost files, it just
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
# Line 1465  This doesn't recover lost files, it just Line 1506  This doesn't recover lost files, it just
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
# Line 1577  This doesn't recover lost files, it just Line 1618  This doesn't recover lost files, it just
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

Legend:
Removed from v.1.47  
changed lines
  Added in v.1.47.2.1

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26