cpio-mode-0.17.0.20211211.193556/ 0000755 0001752 0001753 00000000000 14155344264 013557 5 ustar elpa elpa cpio-mode-0.17.0.20211211.193556/cpio-odc.el 0000644 0001752 0001753 00000063503 13754322553 015606 0 ustar elpa elpa ;;; cpio-odc.el --- handle old portable cpio entry header format. -*- coding: utf-8 -*-
;; COPYRIGHT
;;
;; Copyright © 2019-2020 Free Software Foundation, Inc.
;; All rights reserved.
;;
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see .
;;
;; Author: Douglas Lewan
;; Maintainer: Douglas Lewan
;; Created: 2015 Jan 03
;; Version: 0.17
;; Keywords: files
;;; Commentary:
;;; Documentation:
;;; Code:
;;
;; Dependencies
;;
;; (load-file (concat default-directory "cpio-generic.el"))
(eval-when-compile (require 'cpio-generic)) ;For `with-writable-buffer'!
;;;;;;;;;;;;;;;;
;; Things to make the byte compiler happy.
(defvar *cpio-catalog*)
(defvar *cpio-odc-dev-field-offset*)
(defvar *cpio-odc-filesize-field-offset*)
(defvar *cpio-odc-gid-field-offset*)
(defvar *cpio-odc-ino-field-offset*)
(defvar *cpio-odc-magic-field-offset*)
(defvar *cpio-odc-mode-field-offset*)
(defvar *cpio-odc-mtime-field-offset*)
(defvar *cpio-odc-name-field-offset*)
(defvar *cpio-odc-namesize-field-offset*)
(defvar *cpio-odc-nlink-field-offset*)
(defvar *cpio-odc-rdev-field-offset*)
(defvar *cpio-odc-uid-field-offset*)
(declare-function cpio-contents-start "cpio-mode.el")
(declare-function cpio-dev-maj "cpio-mode.el")
(declare-function cpio-entry-attrs-from-catalog-entry "cpio-mode.el")
(declare-function cpio-entry-name "cpio-mode.el")
(declare-function cpio-entry-size "cpio-mode.el")
(declare-function cpio-gid "cpio-mode.el")
(declare-function cpio-ino "cpio-mode.el")
(declare-function cpio-mode-value "cpio-mode.el")
(declare-function cpio-mtime "cpio-mode.el")
(declare-function cpio-nlink "cpio-mode.el")
(declare-function cpio-rdev-maj "cpio-mode.el")
(declare-function cpio-uid "cpio-mode.el")
(declare-function cpio-entry-attrs "cpio-mode.el")
;; EO things for the byte compiler.
;;;;;;;;;;;;;;;;
;;
;; Vars
;;
(defconst *cpio-odc-header-length* (length "0707070000000000000000000000000000000000010000000000000000000001300000000000")
"The length of an odc header.")
;; MAINTENANCE The following must remain in synch with *cpio-odc-header-re*.
;; magic 070707 \\(070707\\)
;; dev 176400 \\([0-7]\\{6\\}\\)
;; ino 005341 \\([0-7]\\{6\\}\\)
;; mode 100644 \\([0-7]\\{6\\}\\)
;; uid 001750 \\([0-7]\\{6\\}\\)
;; gid 001750 \\([0-7]\\{6\\}\\)
;; nlink 000001 \\([0-7]\\{6\\}\\)
;; rdev 000000 \\([0-7]\\{6\\}\\)
;; mtime 13300045411 \\([0-7]\\{11\\}\\)
;; namesz 000002 \\([0-7]\\{6\\}\\)
;; filesize 00000000004 \\([0-7]\\{11\\}\\)
;; name a\0 \\([[:print:]]+\\)\0
(defconst *cpio-odc-magic-re* "070707"
"RE to match the magic number of a odc archive.")
(setq *cpio-odc-magic-re* "070707")
(defconst *cpio-odc-field-width* 6
"The width of all of the fields in a odc header.")
(setq *cpio-odc-field-width* 6)
(defconst *cpio-odc-ino-re* (format "[0-7]\\{%d\\}" *cpio-odc-field-width*)
"RE to match the c_ino field in a odc header.")
(setq *cpio-odc-ino-re* (format "[0-7]\\{%d\\}" *cpio-odc-field-width*))
(defconst *cpio-odc-dev-re* (format "[0-7]\\{%d\\}" *cpio-odc-field-width*)
"RE to match the c_dev field in a odc header.")
(setq *cpio-odc-dev-re* (format "[0-7]\\{%d\\}" *cpio-odc-field-width*))
(defconst *cpio-odc-mode-re* (format "[0-7]\\{%d\\}" *cpio-odc-field-width*)
"RE to match the c_mode field in a odc header.")
(setq *cpio-odc-mode-re* (format "[0-7]\\{%d\\}" *cpio-odc-field-width*))
(defconst *cpio-odc-uid-re* (format "[0-7]\\{%d\\}" *cpio-odc-field-width*)
"RE to match the c_uid field in a odc header.")
(setq *cpio-odc-uid-re* (format "[0-7]\\{%d\\}" *cpio-odc-field-width*))
(defconst *cpio-odc-gid-re* (format "[0-7]\\{%d\\}" *cpio-odc-field-width*)
"RE to match the c_gid field in a odc header.")
(setq *cpio-odc-gid-re* (format "[0-7]\\{%d\\}" *cpio-odc-field-width*))
(defconst *cpio-odc-nlink-re* (format "[0-7]\\{%d\\}" *cpio-odc-field-width*)
"RE to match the c_nlink field in a odc header.")
(setq *cpio-odc-nlink-re* (format "[0-7]\\{%d\\}" *cpio-odc-field-width*))
(defconst *cpio-odc-rdev-re* (format "[0-7]\\{%d\\}" *cpio-odc-field-width*)
"RE to match the c_rdev field in a odc header.")
(setq *cpio-odc-rdev-re* (format "[0-7]\\{%d\\}" *cpio-odc-field-width*))
(defconst *cpio-odc-mtime-re* "[0-7]\\{11\\}"
"RE to match the c_mtime field in a odc header.")
(setq *cpio-odc-mtime-re* "[0-7]\\{11\\}")
(defconst *cpio-odc-namesize-re* (format "[0-7]\\{%d\\}" *cpio-odc-field-width*)
"RE to match the c_namesize field in a odc header.")
(setq *cpio-odc-namesize-re* (format "[0-7]\\{%d\\}" *cpio-odc-field-width*))
(defconst *cpio-odc-filesize-re* "[0-7]\\{11\\}"
"RE to match the c_filesize field in a odc header.")
(setq *cpio-odc-filesize-re* "[0-7]\\{11\\}")
(defconst *cpio-odc-filename-re* "[[:print:]]+"
"RE to match the c_filename field in a odc header.")
(setq *cpio-odc-filename-re* "[[:print:]]+")
(defconst *cpio-odc-header-re* ()
"RE to match odc header format cpio archives.")
(setq *cpio-odc-header-re* (concat "\\(" *cpio-odc-magic-re* "\\)"
"\\(" *cpio-odc-dev-re* "\\)"
"\\(" *cpio-odc-ino-re* "\\)"
"\\(" *cpio-odc-mode-re* "\\)"
"\\(" *cpio-odc-uid-re* "\\)"
"\\(" *cpio-odc-gid-re* "\\)"
"\\(" *cpio-odc-nlink-re* "\\)"
"\\(" *cpio-odc-rdev-re* "\\)"
"\\(" *cpio-odc-mtime-re* "\\)"
"\\(" *cpio-odc-namesize-re* "\\)"
"\\(" *cpio-odc-filesize-re* "\\)"
"\\(" *cpio-odc-filename-re* "\\)"
"\0"))
(let ((i 0))
(defconst *cpio-odc-magic-re-idx* 0
"RE to match the magic number in a odc header.")
(setq *cpio-odc-magic-re-idx* (setq i (1+ i)))
(defconst *cpio-odc-dev-re-idx* 0
"Index of the sub RE from *cpio-odc-header-re* to parse the dev.")
(setq *cpio-odc-dev-re-idx* (setq i (1+ i)))
(defconst *cpio-odc-ino-re-idx* 0
"Index of the sub RE from *cpio-odc-header-re* to parse the inode.")
(setq *cpio-odc-ino-re-idx* (setq i (1+ i)))
(defconst *cpio-odc-mode-re-idx* 0
"Index of the sub RE from *cpio-odc-header-re* to parse the mode.")
(setq *cpio-odc-mode-re-idx* (setq i (1+ i)))
(defconst *cpio-odc-uid-re-idx* 0
"Index of the sub RE from *cpio-odc-header-re* to parse the UID.")
(setq *cpio-odc-uid-re-idx* (setq i (1+ i)))
(defconst *cpio-odc-gid-re-idx* 0
"Index of the sub RE from *cpio-odc-header-re* to parse the GID.")
(setq *cpio-odc-gid-re-idx* (setq i (1+ i)))
(defconst *cpio-odc-nlink-re-idx* 0
"Index of the sub RE from *cpio-odc-header-re* to parse the nlink.")
(setq *cpio-odc-nlink-re-idx* (setq i (1+ i)))
(defconst *cpio-odc-rdev-re-idx* 0
"Index of the sub RE from *cpio-odc-header-re* to parse the rdev.")
(setq *cpio-odc-rdev-re-idx* (setq i (1+ i)))
(defconst *cpio-odc-mtime-re-idx* 0
"Index of the sub RE from *cpio-odc-header-re* to parse the mtime.")
(setq *cpio-odc-mtime-re-idx* (setq i (1+ i)))
(defconst *cpio-odc-namesize-re-idx* 0
"Index of the sub RE from *cpio-odc-header-re* to parse the namesize.")
(setq *cpio-odc-namesize-re-idx* (setq i (1+ i)))
(defconst *cpio-odc-filesize-re-idx* 0
"Index of the sub RE from *cpio-odc-header-re* to parse the filesize.")
(setq *cpio-odc-filesize-re-idx* (setq i (1+ i)))
(defconst *cpio-odc-filename-re-idx* 0
"Index of the sub RE from *cpio-odc-header-re* to parse the filename.")
(setq *cpio-odc-filename-re-idx* (setq i (1+ i))))
;;
;; EO odc header variables.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; *cpio-odc-magic-re*
(defconst *cpio-odc-magic* *cpio-odc-magic-re*
"The string that identifies an entry as a ODC style cpio(1) entry.")
(setq *cpio-odc-magic* *cpio-odc-magic-re*)
(defconst *cpio-odc-field-width* 6
"The width of all of the fields in a odc header.")
(setq *cpio-odc-field-width* 6)
(defconst *cpio-odc-padding-modulus* 2
"The modulus to which some things are padded in a ODC cpio archive.")
(setq *cpio-odc-padding-modulus* 2)
(defconst *cpio-odc-padding-char* ?\0
"A character to be used for padding headers and entry contents
in a odc cpio archive.")
(setq *cpio-odc-padding-char* ?\0)
(defconst *cpio-odc-padding-str* "\0"
"A single character string of the character
to be used for padding headers and entry contents
in a odc cpio archive.")
(setq *cpio-odc-padding-str* "\0")
(let ((offset-so-far 0))
(defconst *cpio-odc-magic-field-offset* offset-so-far)
(setq *cpio-odc-magic-field-offset* offset-so-far)
(defconst *cpio-odc-dev-field-offset* ())
(setq *cpio-odc-dev-field-offset* (setq offset-so-far (+ offset-so-far (length *cpio-odc-magic*))))
(defconst *cpio-odc-ino-field-offset* ())
(setq *cpio-odc-ino-field-offset* (setq offset-so-far (+ offset-so-far *cpio-odc-field-width*)))
(defconst *cpio-odc-mode-field-offset* ())
(setq *cpio-odc-mode-field-offset* (setq offset-so-far (+ offset-so-far *cpio-odc-field-width*)))
(defconst *cpio-odc-uid-field-offset* ())
(setq *cpio-odc-uid-field-offset* (setq offset-so-far (+ offset-so-far *cpio-odc-field-width*)))
(defconst *cpio-odc-gid-field-offset* ())
(setq *cpio-odc-gid-field-offset* (setq offset-so-far (+ offset-so-far *cpio-odc-field-width*)))
(defconst *cpio-odc-nlink-field-offset* ())
(setq *cpio-odc-nlink-field-offset* (setq offset-so-far (+ offset-so-far *cpio-odc-field-width*)))
(defconst *cpio-odc-rdev-field-offset* ())
(setq *cpio-odc-rdev-field-offset* (setq offset-so-far (+ offset-so-far *cpio-odc-field-width*)))
(defconst *cpio-odc-mtime-field-offset* ())
(setq *cpio-odc-mtime-field-offset* (setq offset-so-far (+ offset-so-far *cpio-odc-field-width*)))
(defconst *cpio-odc-namesize-field-offset* ())
(setq *cpio-odc-namesize-field-offset* (setq offset-so-far (+ offset-so-far 11)))
(defconst *cpio-odc-filesize-field-offset* ())
(setq *cpio-odc-filesize-field-offset* (setq offset-so-far (+ offset-so-far *cpio-odc-field-width*)))
(defconst *cpio-odc-name-field-offset* ())
(setq *cpio-odc-name-field-offset* (setq offset-so-far (+ offset-so-far 11))))
(defconst *cpio-odc-trailer* "0707070000000000000000000000000000000000010000000000000000000001300000000000TRAILER!!!\0"
"The TRAILER string for a odc archive.")
(setq *cpio-odc-trailer* "0707070000000000000000000000000000000000010000000000000000000001300000000000TRAILER!!!\0")
(defcustom *cpio-odc-blocksize* 512
"The default block size for this cpio archive.
Taken from cpio-2.12/src/global.c."
:type 'integer
:group 'cpio)
;;
;; Library
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Functions for working with a cpio odc header
;;
(defun cpio-odc-header-at-point (&optional where)
"Return the header string at or following point WHERE.
If WHERE is not given, then use point.
CAVEATS:
1. This searches for the magic number at the begining of the header;
if WHERE is inside the magic number, then the search will fail.
This works best if you are (looking-at) a header.
2. This returns the pure header;
it does not provide the filename itself."
(unless where (setq where (point)))
(let ((fname "cpio-odc-header-at-point")
(found nil))
(save-match-data
(cond ((looking-at *cpio-odc-header-re*)
(match-string-no-properties 0))
(t
(forward-char (length *cpio-odc-magic-re*))
(while (and (re-search-backward *cpio-odc-magic-re* (point-min) t)
(not (setq found (looking-at *cpio-odc-header-re*)))))
(if found
(match-string-no-properties 0)))))))
;;;;;;;;;;;;;;;;
;;
;; Parsing a header
;;
(defun cpio-odc-parse-header (header-string)
"Return the internal entry header structure encoded in HEADER-STR.
The optional argument WHERE should be a buffer location
at the beginning of a known cpio odc header.
If WHERE is not given, then take point and hope.
This function does NOT get the contents."
(let ((fname "cpio-odc-parse-header")
(namesize)
(filesize)
(result))
;; There's an arguable level of redundancy here,
;; but the caller likely grabbed HEADER-STR
;; from the buffer and we're using the string proper.
;; This call establishes the match-data
;; that the subsequent calls will use.
(save-match-data
(string-match *cpio-odc-header-re* header-string)
(setq result
(vector
(cpio-odc-parse-ino header-string)
(cpio-odc-parse-mode header-string)
(cpio-odc-parse-uid header-string)
(cpio-odc-parse-gid header-string)
(cpio-odc-parse-nlink header-string)
(cpio-odc-parse-mtime header-string)
(setq filesize (cpio-odc-parse-filesize header-string))
(cpio-odc-parse-dev header-string)
0 ;dev-min
(cpio-odc-parse-rdev header-string)
0 ;rdev-min
(setq namesize (cpio-odc-parse-namesize header-string))
0 ;checksum
(cpio-odc-parse-name header-string namesize))))
(if (cpio-entry-name result)
result
nil)))
(defun cpio-odc-header-size (header-string namesize)
"Determine the length of the header implied by the given HEADER-STRING."
(let ((fname "cpio-odc-header-size"))
(+ *cpio-odc-name-field-offset* namesize)))
(defun cpio-odc-parse-magic (header-string)
"Get the magic field from HEADER-STRING."
(let* ((fname "cpio-odc-parse-magic")
(this-offset *cpio-odc-magic-field-offset*)
(end-offset (+ this-offset (length *cpio-odc-magic-re*))))
(substring header-string this-offset end-offset)))
(defun cpio-odc-parse-ino (header-string)
"Get the ino field from HEADER-STRING."
(let* ((fname "cpio-odc-parse-ino")
(this-offset *cpio-odc-ino-field-offset*)
(end-offset (+ this-offset *cpio-odc-field-width*)))
(string-to-number (substring header-string this-offset end-offset) 8)))
(defun cpio-odc-parse-mode (header-string)
"Get the mode field from HEADER-STRING."
(let* ((fname "cpio-odc-parse-mode")
(this-offset *cpio-odc-mode-field-offset*)
(end-offset (+ this-offset *cpio-odc-field-width*)))
(string-to-number (substring header-string this-offset end-offset) 8)))
(defun cpio-odc-parse-uid (header-string)
"Get the uid field from HEADER-STRING."
(let* ((fname "cpio-odc-parse-uid")
(this-offset *cpio-odc-uid-field-offset*)
(end-offset (+ this-offset *cpio-odc-field-width*)))
(string-to-number (substring header-string this-offset end-offset) 8)))
(defun cpio-odc-parse-gid (header-string)
"Get the gid field from HEADER-STRING."
(let* ((fname "cpio-odc-parse-gid")
(this-offset *cpio-odc-gid-field-offset*)
(end-offset (+ this-offset *cpio-odc-field-width*)))
(string-to-number (substring header-string this-offset end-offset) 8)))
(defun cpio-odc-parse-nlink (header-string)
"Get the nlink field from HEADER-STRING."
(let* ((fname "cpio-odc-parse-nlink")
(this-offset *cpio-odc-nlink-field-offset*)
(end-offset (+ this-offset *cpio-odc-field-width*)))
(string-to-number (substring header-string this-offset end-offset) 8)))
(defun cpio-odc-parse-mtime (header-string)
"Get the mtime field from HEADER-STRING."
(let* ((fname "cpio-odc-parse-mtime")
(this-offset *cpio-odc-mtime-field-offset*)
(end-offset (+ this-offset 11))
(time-value ()))
(setq time-value (string-to-number (substring header-string this-offset end-offset) 8))
(setq time-value (list (lsh (logand #xFFFF0000 time-value) -16) (logand #xFFFF)))))
(defun cpio-odc-parse-filesize (header-string)
"Get the filesize from the HEADER-STRING."
(let* ((fname "cpio-odc-parse-filesize")
(this-offset *cpio-odc-filesize-field-offset*)
(end-offset (+ this-offset 11)))
(string-to-number (substring header-string this-offset end-offset) 8)))
(defun cpio-odc-parse-dev (header-string)
"Get the dev field from HEADER-STRING."
(let* ((fname "cpio-odc-parse-dev")
(this-offset *cpio-odc-dev-field-offset*)
(end-offset (+ this-offset *cpio-odc-field-width*)))
(string-to-number (substring header-string this-offset end-offset) 8)))
(defun cpio-odc-parse-rdev (header-string)
"Get the rdev field from HEADER-STRING."
(let* ((fname "cpio-odc-parse-rdev")
(this-offset *cpio-odc-rdev-field-offset*)
(end-offset (+ this-offset *cpio-odc-field-width*)))
(string-to-number (substring header-string this-offset end-offset) 8)))
(defun cpio-odc-parse-namesize (header-string)
"Get the namesize field from HEADER-STRING."
(let* ((fname "cpio-odc-parse-namesize")
(this-offset *cpio-odc-namesize-field-offset*)
(end-offset (+ this-offset *cpio-odc-field-width*)))
(string-to-number (substring header-string this-offset end-offset) 8)))
(defun cpio-odc-parse-name (header-string namesize)
"Get the name field from HEADER-STRING.
N.B. When called with the correct namesize, this includes the terminating \0."
(let* ((fname "cpio-odc-parse-name")
(this-offset *cpio-odc-name-field-offset*)
(tmp-string (substring header-string this-offset (+ this-offset namesize -1))))
(if (string-equal tmp-string "TRAILER!!!")
nil
tmp-string)))
;; Is this not M-x cpio-dired-find-entry?
(defun cpio-odc-parse-contents (header-string where namesize filesize)
"Return the contents implied by point and HEADER-STRING.
CAVEATS: See `cpio-odc-parse-magic'.
This requires the point to be at the start of HEADER-STRING in the buffer.
After all that's where the contents are, not in the header."
(let ((fname "cpio-odc-parse-contents"))
(buffer-substring-no-properties (+ where namesize)
(+ where namesize filesize))))
;;;;;;;;;;;;;;;;
;;
;; Header construction
;;
(defun cpio-odc-make-header-string (attrs &optional contents)
"Make a ODC style padded cpio header for the given ATTRibuteS.
This function does NOT include the contents."
(let ((fname "cpio-odc-make-header-string")
(name (cpio-entry-name attrs))
(header-string))
(setq header-string (concat (cpio-odc-make-magic attrs)
(cpio-odc-make-dev attrs)
(cpio-odc-make-ino attrs)
(cpio-odc-make-mode attrs)
(cpio-odc-make-uid attrs)
(cpio-odc-make-gid attrs)
(cpio-odc-make-nlink attrs)
(cpio-odc-make-rdev attrs)
(cpio-odc-make-mtime attrs)
(format "%06o" (1+ (length name)))
(cpio-odc-make-filesize attrs)
name
"\0"))
;; (setq header-string (cg-pad-right header-string (cg-round-up (length header-string) *cpio-odc-padding-modulus*) "\0"))
;; Check (at least during development).
(if (string-match-p *cpio-odc-header-re* header-string)
header-string
(error "%s(): I built a bad header: [[%s]]" fname header-string))))
(defun cpio-odc-make-magic (attrs)
"Return the ODC magic header string"
(let ((fname "cpio-odc-make-magic"))
*cpio-odc-magic*))
(defun cpio-odc-make-ino (attrs)
"Return a string value for the inode from the file attributes ATTRS."
(let ((fname "cpio-odc-make-ino")
(ino (cpio-ino attrs)))
(format "%06o" ino)))
(defun cpio-odc-make-mode (attrs)
"Return a string value for the mode from the file attributes ATTRS."
(let ((fname "cpio-odc-make-mode"))
(format "%06o" (cpio-mode-value attrs))))
(defun cpio-odc-make-uid (attrs)
"Return an integer string value for the UID from the file attributes ATTRS."
(let ((fname "cpio-odc-make-uid")
(uid (cpio-uid attrs)))
(format "%06o" uid)))
(defun cpio-odc-make-gid (attrs)
"Return an integer string value for the GID from the file attributes ATTRS."
(let ((fname "cpio-odc-make-gid")
(gid (cpio-gid attrs)))
(format "%06o" gid)))
(defun cpio-odc-make-nlink (attrs)
"Return an integer string value for the number of links from the file attributes ATTRS."
(let ((fname "cpio-odc-make-nlink"))
(format "%06o" (cpio-nlink attrs))))
(defun cpio-odc-make-mtime (attrs)
"Return a string value for the mod time from the file attributes ATTRS."
(let ((fname "cpio-odc-make-mtime")
(mod-time (cpio-mtime attrs)))
(substring (format "%011o" (float-time mod-time)) 0 11)))
(defun cpio-odc-make-filesize (attrs)
"Return an 8 digit hex string for the filesize attribute among the given ATTRs."
(let ((fname "cpio-odc-make-filesize"))
(format "%011o" (cpio-entry-size attrs))))
(defun cpio-odc-make-dev (attrs)
"Return a string value for the dev from the file attributes ATTRS."
(let ((fname "cpio-odc-make-dev")
(dev (cpio-dev-maj attrs)))
(format "%06o" dev)))
(defun cpio-odc-make-rdev (attrs)
"Return a string value for the rdev from the file attributes ATTRS."
(let ((fname "cpio-odc-make-rdev")
(rdev))
(format "%06o" (cpio-rdev-maj attrs))))
;; Filename is not one of ATTRS. ∴ It doesn't get a constructor here.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Functions for whole entries
;;
(defun cpio-odc-parse-header-at-point ()
"Parse the odc cpio header that begins at point.
If there is no header there, then signal an error."
(let ((fname "cpio-odc-parse-header-at-point"))
(unless (looking-at-p *cpio-odc-header-re*)
(error "%s(): point is not looking at a odc header." fname))
(cpio-odc-parse-header (match-string-no-properties 0))))
(defun cpio-odc-goto-next-header ()
"Move the point to the beginning of the next odc cpio header.
If point is looking-at such a header, then that is the next one
and there is no movement.
\(Thus, a caller may have to make sure that point has moved.\)
This returns the a marker for point where the header is found, if one is found.
It returns NIL otherwise.
This sets match-data for the entire header and each field."
(let ((fname "cpio-odc-goto-next-header")
(header-start)
(header-string))
(cond ((re-search-forward *cpio-odc-header-re* (point-max) t)
(setq header-start (goto-char (match-beginning 0)))
(setq header-string (match-string-no-properties 0))
(cons (point-marker) header-string))
(t nil))))
(defun cpio-odc-build-catalog ()
"Build an internal structure reflecting the contents of the odc cpio archive in the current buffer.
See the variable *cpio-catalog* for more information.
CAVEAT: This respects neither narrowing nor the point."
(let ((fname "cpio-odc-build-catalog")
(header-start) ;A marker.
(header-end)
(that-header-string)
(header-info ())
(parsed-header t)
(filesize) ;A marker.
(contents-start)
(contents-end) ;NOT NEEDED?
(those-contents) ;
(catalog ()))
(widen)
(goto-char (point-min))
(while (and (setq header-info (cpio-odc-goto-next-header))
(setq header-start (car header-info))
(setq that-header-string (cdr header-info))
parsed-header)
(cond ((setq parsed-header (cpio-odc-parse-header-at-point))
(setq filesize (cpio-entry-size parsed-header))
(forward-char (length that-header-string))
(setq header-end (point))
;; A little bit of arithmétic gymnastics here
;; because cpio, being written in C, starts counting at 0, but
;; emacs' points start at 1.
(goto-char header-end)
(setq contents-start (point-marker))
(set-marker-insertion-type contents-start *cg-insert-after*)
;; It feels like I really want a function for getting the contents.
;; But it's not obvious what is simpler or appropriately more general
;; than this one-liner.
;; Indeed. (setq those-contents (buffer-substring-no-properties contents-start contents-end))
(push (cons (cpio-entry-name parsed-header)
(vector
parsed-header
header-start
contents-start
'cpio-mode-entry-unmodified))
catalog)
(setq contents-end (+ contents-start filesize -1))
(goto-char contents-end))
(t t)))
(nreverse catalog)))
(defun cpio-odc-start-of-trailer ()
"Return the character position of the (ostensible) start of the trailer
for the current cpio archive."
(let ((fname "cpio-odc-start-of-trailer")
(end-of-contents 0))
(mapc (lambda (ce)
(let ((attrs (cpio-entry-attrs-from-catalog-entry ce)))
(setq end-of-contents (+ (cpio-entry-size attrs) (cpio-contents-start ce)))))
*cpio-catalog*)
end-of-contents))
(defun cpio-odc-end-of-archive ()
"Calculate the location of the end of the current archive
once the TRAILER is written and padded."
(let ((fname "cpio-odc-end-of-archive")
(end-of-contents (cpio-odc-start-of-trailer)))
(cg-round-up (+ end-of-contents (length *cpio-odc-trailer*)) *cpio-odc-blocksize*)))
(defun cpio-odc-adjust-trailer ()
"Replace thed current trailer in the current cpio odc archive."
(let ((fname "cpio-odc-adjust-trailer"))
(cpio-odc-delete-trailer)
(cpio-odc-insert-trailer)))
(defun cpio-odc-insert-trailer ()
"Insert a odc trailer into a cpio archive."
(let* ((fname "cpio-odc-insert-trailer")
(base-trailer *cpio-odc-trailer*)
(base-len (length base-trailer))
(len))
;; ...and insert the new trailer...
(with-writable-buffer
(insert base-trailer)
(goto-char (point-max))
;; ...with padding.
(setq len (cg-round-up (1- (point)) *cpio-odc-blocksize*))
(setq len (1+ (- len (point))))
(insert (make-string len ?\0)))))
(defun cpio-odc-delete-trailer ()
"Delete the trailer in the current cpio odc archive."
(let ((fname "cpio-odc-delete-trailer"))
(unless (eq major-mode 'cpio-mode)
(error "%s(): Called outside of a cpio archive buffer." fname))
;; First, get to the end of the last entry in the archive.
(goto-char (point-min))
(mapc (lambda (e)
(let* ((ename (car e)) ;Isn't there a generic function for this?
(attrs (cpio-entry-attrs ename))
;; Fencepost issue here.
(entry-end (+ (cpio-contents-start ename)
(cpio-entry-size attrs))))
(goto-char entry-end)
(skip-chars-forward "\0")))
*cpio-catalog*)
;; Next, delete what's left...
(with-writable-buffer
(delete-region (point) (point-max)))))
;;
;; Commands
;;
(provide 'cpio-odc)
;;; cpio-odc.el ends here.
cpio-mode-0.17.0.20211211.193556/cpio-entry-header.el 0000644 0001752 0001753 00000002203 13754322553 017416 0 ustar elpa elpa ;;; cpio-entry-header.el --- handle cpio entry headers. -*- coding: utf-8 -*-
;; COPYRIGHT
;;
;; Copyright © 2019 Free Software Foundation, Inc.
;; All rights reserved.
;;
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see .
;;
;; Author: Douglas Lewan
;; Maintainer: Douglas Lewan
;; Created: 2015 Jan 03
;; Version: 0.17
;; Keywords: files
;;; Commentary:
;;; Documentation:
;;; Code:
;;
;; Dependencies
;;
;;
;; Vars
;;
;;
;; Library
;;
;;
;; Commands
;;
;;; cpio-entry-header.el ends here.
cpio-mode-0.17.0.20211211.193556/cpio-generic.el 0000644 0001752 0001753 00000047064 13754322553 016461 0 ustar elpa elpa ;;; cpio-generic.el --- generically useful functions created in support of CPIO mode. -*- coding: utf-8 -*-
;; COPYRIGHT
;;
;; Copyright © 2019-2020 Free Software Foundation, Inc.
;; All rights reserved.
;;
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see .
;;
;; Author: Douglas Lewan
;; Maintainer: Douglas Lewan
;; Created: 2015 Apr 23
;; Version: 0.17
;; Keywords: files
;;; Commentary:
;;
;; This file contains useful generic functions,
;; and other temporarily useful hacks
;; to help with the development of cpio-mode.
;;
;; A quick glance through it suggests
;; that it has a lot of functional overlap with cpio-modes.el.
;;
;;; Documentation:
;;; Code:
;;
;; Dependencies
;;
(eval-and-compile
(require 'cl))
(declare-function signum "cl")
;;
;; Vars
;;
(defvar *cg-integer-hex-digits* nil)
(defvar *cg-insert-after* nil
"Value used to define that a marker has type 'insert after'.")
(defvar *cg-insert-before* t
"Value used to define that a marker has type 'insert before'.")
;;
;; Library
;;
(defun cg-integer-hex-digits ()
"Calculate the number of hex digits that are required to represent any integer."
(let ((fname "cg-integer-hex-digits")
(an-integer most-negative-fixnum)
(hex-digit-ct 0))
(unless *cg-integer-hex-digits*
(while (/= 0 an-integer)
(setq an-integer (lsh an-integer -4))
(setq hex-digit-ct (1+ hex-digit-ct)))
(setq *cg-integer-hex-digits* hex-digit-ct)))
*cg-integer-hex-digits*)
(defun OBS-cg-hex-format-pair (pair)
"Return a hex formatted representation of PAIR."
(let ((fname "cg-hex-format-pair")
(hex-digit-count (cg-integer-hex-digits))
(formatter))
(setq formatter (format "%%0%dx" hex-digit-count))
(setq formatter (concat formatter formatter))
(format formatter (car pair) (cdr pair))))
(defun OBS-cg-hex-format-triple (triple)
"Return a hex formatted representation of TRIPLE."
(let ((fname "cg-hex-format-triple")
(hex-digit-count (cg-integer-hex-digits))
(formatter))
(setq formatter (format "%%0%dx" hex-digit-count))
(setq formatter (concat formatter formatter formatter))
(format formatter (car triple) (cadr triple) (cddr triple))))
(defun cg-round-up (number modulus)
"Round NUMBER up to the next multiple of MODULUS.
If number ≡ 0 (modulus), then the NUMBER is already rounded up,
so NUMBER is returned.
CAVEAT: If NUMBER is negative, then the result may be surprising."
(let ((fname "cg-round-up"))
(unless (and (integerp number) (integerp modulus))
(error "%s() takes integer arguments." fname))
(cond ((= 0 (mod number modulus))
number)
((= (signum number) 1)
(* modulus (/ (+ number modulus -1) modulus)))
((= (signum number) -1)
(* modulus (/ number modulus)))
(t
(error "%s(): Impossible condition." fname)))))
(defun cg-pad-right (string width char)
"Pad STRING on the right with CHAR until it is at least WIDTH characters wide.
CHAR is typically a character or a single character string, but may be any string."
(let ((fname "cg-pad-right"))
(if (characterp char) (setq char (char-to-string char)))
(while (< (length string) width)
(setq string (concat string char)))
string))
(defun cg-strip-right (re string &optional multiples)
"Strip the given RE from the right end of STRING.
If the optional argument MULTIPLES is not NIL,
then match as many copies of RE as are there."
(let ((fname "cg-strip-right")
(inner-re (if multiples
(concat "\\(" re "\\)+\\'")
(concat re "\\'")))
(result string))
(save-match-data
(if (string-match inner-re string)
(setq result (substring string 0 (match-beginning 0)))))
result))
(defun cg-strip-left (re string &optional multiples)
"Strip the given RE from the left end of STRING.
If the optional argument MULTIPLES is not NIL,
then match as many copies of RE as are there."
(let ((fname "cg-strip-left")
(inner-re (if multiples
(concat "\\`\\(" re "\\)+")
(concat "\\`" re)))
(result string))
(save-match-data
(if (string-match inner-re string)
(setq result (substring string (match-end 0)))))
result))
(defun cg-strip (re string &optional multiples)
"Remove the given RE from both ends of STRING.
If the optional argument MULTIPLES is not NIL,
then match as many copies of RE as are there."
(let ((fname "strip")
(result))
(cg-strip-left re (cg-strip-right re string multiples) multiples)))
(defun cpio-pad (string modulus pad-char)
"Pad the given STRING with PAD-CHAR so that the resulting string has at least length MODULUS."
(let* ((fname "cpio-padded")
(string-length (length string))
(desired-length (cg-round-up string-length modulus)))
(cg-pad-right string desired-length pad-char)))
(defun cpio-uid-for-owner (owner)
"Return the uid (an integer) for the given OWNER (a string) if it exists.
If it doesn't exist, then return NIL.
If OWNER is a sequence of digits, then return OWNER as the GID.
CAVEAT: This deletes any buffer holding /etc/passwd."
(let ((fname "cpio-uid-for-owner")
(passwd-buffer (find-file-noselect "/etc/passwd"))
(uid nil))
(if (string-match-p "\\`[[:digit:]]+\\'" owner)
(setq uid owner)
(with-current-buffer passwd-buffer
(goto-char (point-min))
(save-match-data
(catch 'found-it
(while (< (point) (point-max))
(cond ((looking-at (concat owner ":[[:graph:]]+:\\([[:digit:]]+\\):[[:digit:]]+:"))
(setq uid (match-string-no-properties 1))
(throw 'found-it uid))
(t nil))
(forward-line))))))
(kill-buffer passwd-buffer)
(if uid
(string-to-number uid)
nil)))
(defun cpio-gid-for-group (group)
"Return the GID (an integer) for the given GROUP (a string) if it exists.
If it doesn't exist, then return NIL.
If GROUP is a sequence of digits, then return GROUP as the GID.
CAVEAT: This deletes any buffer holding /etc/group."
(let ((fname "cpio-gid-for-group")
(group-buffer (find-file-noselect "/etc/group"))
(gid nil))
(cond ((null group)
nil)
((stringp group)
(if (string-match-p "\\`[[:digit:]]+\\'" group)
(setq gid group)
(with-current-buffer group-buffer
(goto-char (point-min))
(save-match-data
(catch 'found-it
(while (< (point) (point-max))
(cond ((looking-at (concat group ":[[:graph:]]+:\\([[:digit:]]+\\):"))
(setq gid (match-string-no-properties 1))
(throw 'found-it gid))
(t nil))
(forward-line))))))
(kill-buffer group-buffer)
(if gid
(string-to-number gid)
nil))
(t nil))))
(defmacro with-writable-buffer (&rest body) ;FIXME: Namespace!
"Run body with the current buffer writable.
Reset the buffer's read-only (or not) status after execution."
`(let ((bro-before buffer-read-only))
(setq buffer-read-only nil)
,@body
(setq buffer-read-only bro-before)))
(defun encode-human-time (human-time) ;FIXME: Namespace!
"Return an emacs time from a HUMAN-TIME.
HUMAN-TIME may be any of many time formats typically used by humans.
If I've missed one, please let me know.
Star dates, really, star dates.
Besides that, with general relativity can we really be sure?
CAVEAT: This function attampts to handle multiple forms of dates in English.
Other languages are not yet implemented."
(let ((fname "encode-human-time")
(year nil) ;We'll use this to test for success.
(month 0)
(day 0)
(hour 0)
(minute 0)
(second 0)
(year-re (concat "\\("
"[[:digit:]]\\{4\\}"
"\\)"))
(mon-re (concat "\\("
"jan"
"\\|"
"feb"
"\\|"
"mar"
"\\|"
"apr"
"\\|"
"may"
"\\|"
"jun"
"\\|"
"jul"
"\\|"
"aug"
"\\|"
"sep"
"\\|"
"oct"
"\\|"
"nov"
"\\|"
"dec"
"\\)"))
(month-re (concat "\\("
"january"
"\\|"
"february"
"\\|"
"march"
"\\|"
"april"
"\\|"
"may"
"\\|"
"june"
"\\|"
"july"
"\\|"
"august"
"\\|"
"september"
"\\|"
"october"
"\\|"
"november"
"\\|"
"december"
"\\)"))
(mm-re "\\(0?[[:digit:]]\\|1[012]\\)")
(day-re "\\([012]?[[:digit:]]\\|3[01]\\)")
(time-re (concat "\\("
"\\([012]?[[:digit:]]\\)"
":"
"\\([012345][[:digit:]]\\)"
"\\("
":"
"\\([0123456][[:digit:]]\\)"
"\\)?"
"\\)")))
(save-match-data
(cond
((string-match (concat "\\`"
year-re
"[-/ ]+"
month-re
"[-/ ]+"
day-re
"[- ]*"
time-re
"?\\'")
human-time)
(setq year (string-to-number (match-string-no-properties 1 human-time)))
(setq month (month-to-number (match-string-no-properties 2 human-time)))
(setq day (string-to-number (match-string-no-properties 3 human-time)))
(setq hour (string-to-number (or (match-string-no-properties 5 human-time) "0")))
(setq minute (string-to-number (or (match-string-no-properties 6 human-time) "0")))
(setq second (string-to-number (or (match-string-no-properties 8 human-time) "0"))))
((string-match (concat "\\`"
year-re
"[-/ ]+"
mon-re
"[-/ ]+"
day-re
"[- ]*"
time-re
"?\\'")
human-time)
(setq year (string-to-number (match-string-no-properties 1 human-time)))
(setq month (month-to-number (match-string-no-properties 2 human-time)))
(setq day (string-to-number (match-string-no-properties 3 human-time)))
(setq hour (string-to-number (or (match-string-no-properties 5 human-time) "0")))
(setq minute (string-to-number (or (match-string-no-properties 6 human-time) "0")))
(setq second (string-to-number (or (match-string-no-properties 8 human-time) "0"))))
((string-match (concat "\\`"
month-re
"[-/ ]+"
day-re
"[,]?\\s-+"
year-re
"[-/ ]*"
time-re
"?\\'")
human-time)
(setq year (string-to-number (match-string-no-properties 3 human-time)))
(setq month (month-to-number (match-string-no-properties 1 human-time)))
(setq day (string-to-number (match-string-no-properties 2 human-time)))
(setq hour (string-to-number (or (match-string-no-properties 5 human-time) "0")))
(setq minute (string-to-number (or (match-string-no-properties 6 human-time) "0")))
(setq second (string-to-number (or (match-string-no-properties 8 human-time) "0"))))
((string-match (concat "\\`"
mon-re
"[-/ ]+"
day-re
"[,]?\\s-*"
year-re
"[-/ ]*"
time-re
"?\\'")
human-time)
(setq year (string-to-number (match-string-no-properties 3 human-time)))
(setq month (month-to-number (match-string-no-properties 1 human-time)))
(setq day (string-to-number (match-string-no-properties 2 human-time)))
(setq hour (string-to-number (or (match-string-no-properties 5 human-time) "0")))
(setq minute (string-to-number (or (match-string-no-properties 6 human-time) "0")))
(setq second (string-to-number (or (match-string-no-properties 8 human-time) "0")))
(message "Format: [[Month dd, YYYY hh:mm:ss]]")
"[[Month dd, YYYY hh:mm:ss]]")
;; Some date forms are ambiguous. Avoid them.
((or (and (string-match (concat "\\`"
year-re
"[-/ ]+"
mm-re
"[-/ ]+"
day-re
"[-/ ]*"
time-re
"?\\'")
human-time)
(string-match (concat "\\`"
year-re
"[-/ ]+"
day-re
"[-/ ]+"
mm-re
"[-/ ]*"
time-re
"?\\'")
human-time))
(and (string-match (concat "\\`"
mm-re
"[-/ ]+"
day-re
"[-/ ]+"
year-re
"[-/ ]*"
time-re
"?\\'")
human-time)
(string-match (concat "\\`"
day-re
"[-/ ]+"
mm-re
"[-/ ]+"
year-re
"[-/ ]*"
time-re
"?\\'")
human-time)))
nil)
((string-match (concat "\\`"
year-re
"[-/ ]+"
mm-re
"[-/ ]+"
day-re
"[-/ ]*"
time-re
"?\\'")
human-time)
(setq year (string-to-number (match-string-no-properties 1 human-time)))
(setq month (string-to-number (match-string-no-properties 2 human-time)))
(setq day (string-to-number (match-string-no-properties 3 human-time)))
(setq hour (string-to-number (or (match-string-no-properties 5 human-time) "0")))
(setq minute (string-to-number (or (match-string-no-properties 6 human-time) "0")))
(setq second (string-to-number (or (match-string-no-properties 8 human-time) "0"))))
((string-match (concat "\\`"
mm-re
"[-/ ]+"
day-re
"[-/ ]+"
year-re
"[-/ ]*"
time-re
"?\\'")
human-time)
(setq year (string-to-number (match-string-no-properties 3 human-time)))
(setq month (string-to-number (match-string-no-properties 1 human-time)))
(setq day (string-to-number (match-string-no-properties 2 human-time)))
(setq hour (string-to-number (or (match-string-no-properties 5 human-time) "0")))
(setq minute (string-to-number (or (match-string-no-properties 6 human-time) "0")))
(setq second (string-to-number (or (match-string-no-properties 8 human-time) "0"))))
((string-match (concat "\\`"
year-re
"[-/ ]+"
mm-re
"[-/ ]+"
day-re
"[-/ ]*"
time-re
"?\\'")
human-time)
(setq year (string-to-number (match-string-no-properties 1 human-time)))
(setq month (string-to-number (match-string-no-properties 2 human-time)))
(setq day (string-to-number (match-string-no-properties 3 human-time)))
(setq hour (string-to-number (or (match-string-no-properties 5 human-time) "0")))
(setq minute (string-to-number (or (match-string-no-properties 6 human-time) "0")))
(setq second (string-to-number (or (match-string-no-properties 8 human-time) "0"))))
(t (message "Unknown format.")
nil)))
(if year
(encode-time second minute hour day month year)
nil)))
(defun month-to-number (month-name) ;FIXME: Namespace!
"Convert The MONTH-NAME to a number (1..12)."
(let ((fname "month-to-number"))
(save-match-data
(cond ((string-match "jan" (substring month-name 0 3))
1)
((string-match "feb" (substring month-name 0 3))
2)
((string-match "mar" (substring month-name 0 3))
3)
((string-match "apr" (substring month-name 0 3))
4)
((string-match "may" (substring month-name 0 3))
5)
((string-match "jun" (substring month-name 0 3))
6)
((string-match "jul" (substring month-name 0 3))
7)
((string-match "aug" (substring month-name 0 3))
8)
((string-match "sep" (substring month-name 0 3))
9)
((string-match "oct" (substring month-name 0 3))
10)
((string-match "nov" (substring month-name 0 3))
11)
((string-match "dec" (substring month-name 0 3))
12)
(t (error "%s(): Unknown month [[%s]]." fname month-name))))))
;; HEREHERE Remove this before publishing or
;; figure out how to put it in test-generic.el.
(defun test-encode-human-time () ;FIXME: Namespace!
"Test (encode-human-time)."
(interactive)
(let ((fname "test-encode-human-time")
(results-buf (get-buffer-create "*Human time results*"))
(time-in)
(emacs-time)
(time-out)
(format "")
(test-dates (list
"2018 Nov 9"
"2018 Nov 9 9:53"
"2018 Nov 9 09:53"
"2018 Nov 9 9:53:23"
"2018 Nov 9 09:53:23"
"2018 Nov 09"
"2018 Nov 09 9:53"
"2018 Nov 09 09:53"
"2018 Nov 09 9:53:23"
"2018 Nov 09 09:53:23"
"2018 Nov 19"
"2018 Nov 19 9:53"
"2018 Nov 19 09:53"
"2018 Nov 19 9:53:23"
"2018 Nov 19 09:53:23"
"2018-Nov-29"
"2018-Nov-29 9:53"
"2018-Nov-29 09:53"
"2018-Nov-29 9:53:23"
"2018-Nov-29 09:53:23"
"2018/Nov/19"
"2018/Nov/19 9:53"
"2018/Nov/19 09:53"
"2018/Nov/19 9:53:23"
"2018/Nov/19 09:53:23"
"2018 November 9"
"2018 November 9 9:53"
"2018 November 9 09:53"
"2018 November 9 9:53:23"
"2018 November 9 09:53:23"
"2018 November 09"
"2018 November 09 9:53"
"2018 November 09 09:53"
"2018 November 09 9:53:23"
"2018 November 09 09:53:23"
"2018 November 19"
"2018 November 19 9:53"
"2018 November 19 09:53"
"2018 November 19 9:53:23"
"2018 November 19 09:53:23"
"2018-November-29"
"2018-November-29 9:53"
"2018-November-29 09:53"
"2018-November-29 9:53:23"
"2018-November-29 09:53:23"
"2018/November/19"
"2018/November/19 9:53"
"2018/November/19 09:53"
"2018/November/19 9:53:23"
"2018/November/19 09:53:23"
"11 09 2018"
"11 09 2018 9:53"
"11 09 2018 09:53"
"11 09 2018 9:53:23"
"11 09 2018 09:53:23"
"11 19 2018"
"11 19 2018 9:53"
"11 19 2018 09:53"
"11 19 2018 9:53:23"
"11 19 2018 09:53:23"
"11-29-2018"
"11-29-2018 9:53"
"11-29-2018 09:53"
"11-29-2018 9:53:23"
"11-29-2018 09:53:23"
"11/19/2018"
"11/19/2018 9:53"
"11/19/2018 09:53"
"11/19/2018 9:53:23"
"11/19/2018 09:53:23"
"2018 11 9"
"2018 11 9 9:53"
"2018 11 9 09:53"
"2018 11 9 9:53:23"
"2018 11 9 09:53:23"
"2018 11 09"
"2018 11 09 9:53"
"2018 11 09 09:53"
"2018 11 09 9:53:23"
"2018 11 09 09:53:23"
"2018 11 19"
"2018 11 19 9:53"
"2018 11 19 09:53"
"2018 11 19 9:53:23"
"2018 11 19 09:53:23"
"2018-11-29"
"2018-11-29 9:53"
"2018-11-29 09:53"
"2018-11-29 9:53:23"
"2018-11-29 09:53:23"
"2018/11/19"
"2018/11/19 9:53"
"2018/11/19 09:53"
"2018/11/19 9:53:23"
"2018/11/19 09:53:23"
"11 09 2018"
"11 09 2018 9:53"
"11 09 2018 09:53"
"11 09 2018 9:53:23"
"11 09 2018 09:53:23"
"11 19 2018"
"11 19 2018 9:53"
"11 19 2018 09:53"
"11 19 2018 9:53:23"
"11 19 2018 09:53:23"
"11-29-2018"
"11-29-2018 9:53"
"11-29-2018 09:53"
"11-29-2018 9:53:23"
"11-29-2018 09:53:23"
"11/19/2018"
"11/19/2018 9:53"
"11/19/2018 09:53"
"11/19/2018 9:53:23"
"11/19/2018 09:53:23")))
(with-current-buffer results-buf (erase-buffer))
(mapc (lambda (str)
(with-current-buffer results-buf
(setq time-in str)
(if (setq emacs-time (encode-human-time str))
(setq time-out (current-time-string emacs-time))
(setq time-out (format "(encode-human-time \"%s\") returned NIL." str)))
(goto-char (point-max))
(insert (format "%s\t-->\t%s\t-->\t%s\n" time-in emacs-time time-out))))
test-dates)
(pop-to-buffer results-buf)
(goto-char (point-min))))
;;
;; Commands
;;
(provide 'cpio-generic)
;;; cpio-generic.el ends here
cpio-mode-0.17.0.20211211.193556/cpio-mode-pkg.el 0000644 0001752 0001753 00000000577 14155344264 016545 0 ustar elpa elpa ;; Generated package description from cpio-mode.el -*- no-byte-compile: t -*-
(define-package "cpio-mode" "0.17.0.20211211.193556" "Handle cpio archives in the style of dired." '((emacs "24.5")) :url "https://elpa.gnu.org/packages/cpio-mode.html" :authors '(("Douglas Lewan" . "d.lewan2000@gmail.com")) :maintainer '("Douglas Lewan" . "d.lewan2000@gmail.com") :keywords '("files"))
cpio-mode-0.17.0.20211211.193556/THANKS 0000644 0001752 0001753 00000002370 13712322372 014466 0 ustar elpa elpa #
# Copyright © 2017, 2018, 2019 Douglas Lewan, d.lewan2000@gmail.com
# All rights reserved.
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program. If not, see .
#
Thanks to the following people for helping me
get cpio-mode up and running.
Michael Albinus , for pointing out similar functions now available in TRAMP.
Sergey Poznyakoff , for consultation about the structure of cpio archives.
Sebastrian Kremer et al., for providing the dired code that has guided me on occasion and performed fontification for me outright.
Stefan Monnier for help guiding me through the process of getting cpio-mode into ELPA.
cpio-mode-0.17.0.20211211.193556/cpio-dired.el 0000644 0001752 0001753 00000370454 13754322553 016136 0 ustar elpa elpa ;;; cpio-dired.el --- UI definition à la dired. -*- coding: utf-8 -*-
;; COPYRIGHT
;; Copyright © 2019-2020 Free Software Foundation, Inc.
;; All rights reserved.
;;
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see .
;; Author: Douglas Lewan
;; Maintainer: Douglas Lewan
;; Created: 2017 Dec 01
;; Version: 0.17
;; Keywords: files
;;; Commentary:
;;; Documentation:
;;; Some design principles:
;; • UI taken from dired.
;; • Modifications happen to the catalog
;; unless there is an element
;; that requires modifying the archive itself.
;; An example that includes both the archive and catalog
;; is adding a file to the archive.
;;; Code:
;;
;; Hacks
;;
(defun snarf-defuns () ;FIXME: Namespace!
"Return a list of the defuns in the visible porition of the buffer.
Keep any preceding comments."
(let ((fname "snarf-defuns")
(results ())
(start)
(end))
(save-excursion
(goto-char (point-min))
(while (re-search-forward "^(defun \\([[:graph:]]+\\) " (point-max) t)
(setq start (match-beginning 0))
(mark-defun)
(setq end (mark))
(forward-line -1)
(while (and (> (point) (point-min))
(looking-at ";"))
(setq start (point))
(forward-line -1))
(push (buffer-substring-no-properties start end) results)
(goto-char end)))
results))
(defun sort-defuns (defuns) ;FIXME: Namespace!
"Return a copy of the given list of DEFUNS sorted by name."
(let ((fname "sort-defuns")
(sortable-list)
(sorted-list))
(setq sortable-list
(mapcar (lambda (d)
(let ((defun-name (save-match-data
(and (string-match "(defun \\([[:graph:]]+\\) " d)
(match-string-no-properties 1 d)))))
(cons defun-name d)))
defuns))
(setq sorted-list (sort sortable-list (lambda (l r)
(string-lessp (car l) (car r)))))
(mapcar 'cdr sorted-list)))
(defun sort-defuns-in-buffer () ;FIXME: Namespace!
"Replace the visible portion of the current buffer with its defuns, but sorted."
(interactive)
(let ((fname "sort-defuns-in-buffer")
(defuns (sort-defuns (snarf-defuns))))
(delete-region (point-min) (point-max))
(mapc (lambda (d)
(insert d "\n"))
defuns)))
;;
;; Dependencies
;;
(eval-when-compile (require 'cpio-generic)) ;For `with-writable-buffer'!
(require 'dired)
(require 'dired-aux)
;;
;; Vars
;;
;;;;;;;;;;;;;;;;
;; Make the byte compiler happy.
(defvar *cpio-search-entries*)
(defvar *cpio-search-entry*)
(defvar *cpio-search-point*)
(defvar *cpio-search-re*)
(defvar cpio-dired-set-modified)
(defvar cpio-dired-hide-details-mode)
(defvar *cpio-catalog*)
(defvar *cpio-padding-modulus*)
(defvar *cpio-catalog-entry-length*)
(defvar *cpio-catalog-entry-attrs-idx*)
(defvar *cpio-catalog-entry-contents-start-idx*)
(defvar *cpio-catalog-entry-header-start-idx*)
(declare-function cpio-adjust-trailer "cpio-mode.el")
(declare-function cpio-catalog "cpio-mode.el")
(declare-function cpio-contents "cpio-mode.el")
(declare-function cpio-contents-start "cpio-mode.el")
(declare-function cpio-create-entry-attrs "cpio-mode.el")
(declare-function cpio-create-faux-directory-attrs "cpio-mode.el")
(declare-function cpio-delete-trailer "cpio-mode.el")
(declare-function cpio-dev-maj "cpio-mode.el")
(declare-function cpio-dev-maj-to-dev-maj-string "cpio-mode.el")
(declare-function cpio-dev-min "cpio-mode.el")
(declare-function cpio-dev-min-to-dev-min-string "cpio-mode.el")
(declare-function cpio-dired-modified-p "cpio-dired.el")
(declare-function cpio-dired-set-modified "cpio-dired.el")
(declare-function cpio-dired-set-unmodified "cpio-dired.el")
(declare-function cpio-entry "cpio-mode.el")
(declare-function cpio-entry-attrs "cpio-mode.el")
(declare-function cpio-entry-contents-start "cpio-mode.el")
(declare-function cpio-entry-exists-p "cpio-mode.el")
(declare-function cpio-entry-header-start "cpio-mode.el")
(declare-function cpio-entry-name "cpio-mode.el")
(declare-function cpio-entry-name-to-entry-name-string "cpio-mode.el")
(declare-function cpio-entry-size "cpio-mode.el")
(declare-function cpio-extract-all "cpio-mode.el")
(declare-function cpio-filesize-to-filesize-string "cpio-mode.el")
(declare-function cpio-find-entry "cpio-mode.el")
(declare-function cpio-gid "cpio-mode.el")
(declare-function cpio-gid-to-gid-string "cpio-mode.el")
(declare-function cpio-insert-padded-contents "cpio-mode.el")
(declare-function cpio-insert-trailer "cpio-mode.el")
(declare-function cpio-make-header-string "cpio-mode.el")
(declare-function cpio-mode "cpio-mode.el")
(declare-function cpio-mode-value "cpio-mode.el")
(declare-function cpio-move-to-entry "cpio-mode.el")
(declare-function cpio-mtime "cpio-mode.el")
(declare-function cpio-mtime-to-mtime-string "cpio-mode.el")
(declare-function cpio-nlink "cpio-mode.el")
(declare-function cpio-nlink-to-nlink-string "cpio-mode.el")
(declare-function cpio-numeric-entry-type "cpio-mode.el")
(declare-function cpio-set-contents-start "cpio-mode.el")
(declare-function cpio-set-entry-name "cpio-mode.el")
(declare-function cpio-set-entry-unmodified "cpio-mode.el")
(declare-function cpio-set-gid "cpio-mode.el")
(declare-function cpio-set-mode "cpio-mode.el")
(declare-function cpio-set-uid "cpio-mode.el")
(declare-function cpio-sort-catalog "cpio-mode.el")
(declare-function cpio-uid "cpio-mode.el")
(declare-function cpio-uid-to-uid-string "cpio-mode.el")
;; EO byte compiler code.
;;;;;;;;;;;;;;;;
(defvar *cpio-dired-permission-flags-regexp* dired-permission-flags-regexp
"Regular expression to match the permission flags in `ls -l'.")
;; (defvar dired-sort-by-date-regexp
;; (concat "\\(\\`\\| \\)-[^- ]*t"
;; ;; `dired-ls-sorting-switches' after -t overrides -t.
;; "[^ " dired-ls-sorting-switches "]*"
;; "\\(\\(\\`\\| +\\)\\(--[^ ]+\\|-[^- t"
;; dired-ls-sorting-switches "]+\\)\\)* *$")
;; "Regexp recognized by Dired to set `by date' mode.")
;; (defvar dired-sort-by-name-regexp
;; (concat "\\`\\(\\(\\`\\| +\\)\\(--[^ ]+\\|"
;; "-[^- t" dired-ls-sorting-switches "]+\\)\\)* *$")
;; "Regexp recognized by Dired to set `by name' mode.")
;; (defvar dired-sort-inhibit nil
;; "Non-nil means the Dired sort command is disabled.
;; The idea is to set this buffer-locally in special Dired buffers.")
(defvar *mon-re* (concat "jan\\|feb\\|mar\\|apr\\|may\\|jun\\|"
"jul\\|aug\\|sep\\|oct\\|nov\\|dec"))
(setq *mon-re* (concat "jan\\|feb\\|mar\\|apr\\|may\\|jun\\|"
"jul\\|aug\\|sep\\|oct\\|nov\\|dec"))
(defvar *cpio-dired-date-time-regexp* ()
"RE to match the date/time field in ls -l.")
(setq *cpio-dired-date-time-regexp* (concat "\\(?:"
*mon-re*
"\\)"
"\\s-+"
"[[:digit:]]\\{2\\}"
"\\s-+"
"\\(?:"
"[[:digit:]]\\{2\\}"
":"
"[[:digit:]]\\{2\\}"
"\\|"
"[[:digit:]]\\{4\\}"
"\\)"))
(defvar *cpio-dired-inner-entry-regexp* (concat "\\("
"[-dpstrwx]\\{10\\}"
"\\)"
"\\s-+"
"[[:digit:]]+" ;nlinks
"\\s-+"
"\\("
"[[:alnum:]]+" ;user
"\\)"
"\\s-+"
"\\("
"[[:alnum:]]+" ;group
"\\)"
"\\s-+"
"[[:digit:]]+" ;filesize
"\\s-+"
"\\("
*cpio-dired-date-time-regexp*
"\\)"
"\\s-+"
"\\("
"[[:graph:]]+"
"\\)")
"Regular expression to match the \"ls -l\" portion of an entry's line.")
(setq *cpio-dired-inner-entry-regexp* (concat "\\("
"[-dpstrwx]\\{10\\}"
"\\)"
"\\s-+"
"[[:digit:]]+" ;nlinks
"\\s-+"
"\\("
"[[:alnum:]]+" ;user
"\\)"
"\\s-+"
"\\("
"[[:alnum:]]+" ;group
"\\)"
"\\s-+"
"[[:digit:]]+" ;filesize
"\\s-+"
"\\("
*cpio-dired-date-time-regexp*
"\\)"
"\\s-+"
"\\("
"[[:graph:]]+"
"\\)"))
(defvar *cpio-dired-entry-regexp* (concat ".."
"\\("
*cpio-dired-permission-flags-regexp*
"\\)"
"\\s-+"
"[[:digit:]]+" ;nlinks
"\\s-+"
"\\("
"[[:alnum:]]+" ;user
"\\)"
"\\s-+"
"\\("
"[[:alnum:]]+" ;group
"\\)"
"\\s-+"
"[[:digit:]]+" ;filesize
"\\s-+"
"\\("
*cpio-dired-date-time-regexp*
"\\)"
"\\s-+"
"\\("
"[[:graph:]]+"
"\\)")
"Regular expression to match an entry's line in cpio-dired-mode")
(setq *cpio-dired-entry-regexp* (concat ".."
*cpio-dired-inner-entry-regexp*))
(defvar *cpio-dired-mode-idx* 1
"Index of the mode match in *cpio-dired-entry-regexp*.")
(setq *cpio-dired-mode-idx* 1)
(defvar *cpio-dired-user-idx* 2
"Index of the user match in *cpio-dired-entry-regexp*.")
(setq *cpio-dired-user-idx* 2)
(defvar *cpio-dired-group-idx* 3
"Index of the group match in *cpio-dired-entry-regexp*.")
(setq *cpio-dired-group-idx* 3)
(defvar *cpio-dired-date/time-idx* 4
"Index of the date/time match in *cpio-dired-entry-regexp*.")
(setq *cpio-dired-date/time-idx* 4)
(defvar *cpio-dired-name-idx* 5
"Index of the entry name match in *cpio-dired-entry-regexp*.")
(setq *cpio-dired-name-idx* 5)
(defconst cpio-dired-marker-char ?* ; the answer is 42
;; so that you can write things like
;; (let ((cpio-dired-marker-char ?X))
;; ;; great code using X markers ...
;; )
;; For example, commands operating on two sets of files, A and B.
;; Or marking files with digits 0-9. This could implicate
;; concentric sets or an order for the marked files.
;; The code depends on dynamic scoping on the marker char.
"In cpio-dired, the current mark character.
This is what the do-commands look for, and what the mark-commands store.")
(defconst cpio-dired-marker-str (char-to-string cpio-dired-marker-char)
"In cpio-dired, a string corresponding to cpio-dired-marker-char.")
(defvar cpio-dired-del-marker ?D
"Character used to flag entries for deletion.")
(setq cpio-dired-del-marker ?D)
(defvar cpio-dired-del-str (char-to-string cpio-dired-del-marker)
"In cpio-dired, a string corresponding to cpio-dired-del-marker.")
(setq cpio-dired-del-str (char-to-string cpio-dired-del-marker))
;; HEREHERE dired-keep-marker-copy is customizable.
;; Should it be here too?
(defvar cpio-dired-keep-marker-copy ?C
"Character used to flag entries for copying.")
(setq cpio-dired-keep-marker-copy ?C)
(defvar cpio-dired-keep-marker-copy-str ?C
"In cpio-dired, a string corresponding to cpio-dired-keep-marker-copy.")
(setq cpio-dired-keep-marker-copy-str ?C)
;; HEREHERE dired-keep-marker-rename is customizable.
;; Should it be here too?
(defvar cpio-dired-keep-marker-rename ?R
"Character used to flag entries for renaming.")
(setq cpio-dired-keep-marker-rename ?R)
(defvar cpio-dired-keep-marker-rename-str (char-to-string cpio-dired-keep-marker-rename)
"In cpio-dired, a string corresponding to cpio-dired-keep-marker-rename.")
(setq cpio-dired-keep-marker-rename-str (char-to-string cpio-dired-keep-marker-rename))
(defvar cpio-dired-re-inode-size "[0-9 \t]*"
"Regexp for optional initial inode and file size as made by `ls -i -s'.")
(setq cpio-dired-re-inode-size "[0-9 \t]*")
;; These regexps must be tested at beginning-of-line, but are also
;; used to search for next matches, so neither omitting "^" nor
;; replacing "^" by "\n" (to make it slightly faster) will work.
(defvar cpio-dired-re-mark "^[^ \n]"
"Regexp matching a marked line.
Important: the match ends just after the marker.")
(setq cpio-dired-re-mark "^[^ \n]")
(defvar cpio-dired-re-maybe-mark "^. ")
(setq cpio-dired-re-maybe-mark "^. ")
;; The [^:] part after "d" and "l" is to avoid confusion with the
;; DOS/Windows-style drive letters in directory names, like in "d:/foo".
(defvar cpio-dired-re-dir (concat cpio-dired-re-maybe-mark cpio-dired-re-inode-size "d[^:]"))
(setq cpio-dired-re-dir (concat cpio-dired-re-maybe-mark cpio-dired-re-inode-size "d[^:]"))
(defvar cpio-dired-re-sym (concat cpio-dired-re-maybe-mark cpio-dired-re-inode-size "l[^:]"))
(setq cpio-dired-re-sym (concat cpio-dired-re-maybe-mark cpio-dired-re-inode-size "l[^:]"))
(defvar cpio-dired-re-exe ;; match ls permission string of an executable file
(mapconcat (function
(lambda (x)
;; (concat cpio-dired-re-maybe-mark cpio-dired-re-inode-size x)))
(concat cpio-dired-re-maybe-mark " " x)))
'("-[-r][-w][xs][-r][-w].[-r][-w]."
"-[-r][-w].[-r][-w][xs][-r][-w]."
"-[-r][-w].[-r][-w].[-r][-w][xst]")
"\\|"))
(setq cpio-dired-re-exe ;; match ls permission string of an executable file
(mapconcat (function
(lambda (x)
;; (concat cpio-dired-re-maybe-mark cpio-dired-re-inode-size x)))
(concat cpio-dired-re-maybe-mark " " x)))
'("-[-r][-w][xs][-r][-w].[-r][-w]."
"-[-r][-w].[-r][-w][xs][-r][-w]."
"-[-r][-w].[-r][-w].[-r][-w][xst]")
"\\|"))
(defvar cpio-dired-re-perms "[-bcdlps][-r][-w].[-r][-w].[-r][-w].")
(setq cpio-dired-re-perms "[-bcdlps][-r][-w].[-r][-w].[-r][-w].")
(defvar cpio-dired-re-dot "^.* \\.\\.?/?$")
(setq cpio-dired-re-dot "^.* \\.\\.?/?$")
(defvar cpio-dired-font-lock-keywords
;; cpio-dired-font-lock-keywords is adapted from dired.
(list
;;
;; Dired marks.
(list cpio-dired-re-mark '(0 cpio-dired-mark-face))
;;
;; We make heavy use of MATCH-ANCHORED, since the regexps don't identify the
;; entry name itself. We search for Dired defined regexps, and then use the
;; cpio-dired defined function `cpio-dired-move-to-entry-name' before searching for the
;; simple regexp ".+". It is that regexp which matches the entry name.
;;
;; Marked entries.
(list (concat "^[" (char-to-string cpio-dired-marker-char) "]")
'(".+" (cpio-dired-move-to-entry-name) nil (0 cpio-dired-marked-face)))
;;
;; Flagged entries.
(list (concat "^[" (char-to-string cpio-dired-del-marker) "]")
'(".+" (cpio-dired-move-to-entry-name) nil (0 cpio-dired-flagged-face)))
;; People who are paranoid about security would consider this more
;; important than other things such as whether it is a directory.
;; But we don't want to encourage paranoia, so our default
;; should be what's most useful for non-paranoids. -- rms.
;;
;; However, we don't need to highlight the entry name, only the
;; permissions, to win generally. -- fx.
;; Fixme: we could also put text properties on the permission
;; fields with keymaps to frob the permissions, somewhat a la XEmacs.
;;DL (list (concat cpio-dired-re-maybe-mark cpio-dired-re-inode-size
;;DL "[-d]....\\(w\\)....") ; group writable
;;DL '(1 cpio-dired-perm-write-face))
;;DL (list (concat cpio-dired-re-maybe-mark cpio-dired-re-inode-size
;;DL "[-d].......\\(w\\).") ; world writable
;;DL '(1 cpio-dired-perm-write-face))
;;
;; Subdirectories.
(list cpio-dired-re-dir
'(".+" (cpio-dired-move-to-entry-name) nil (0 cpio-dired-directory-face)))
;;
;; Symbolic links.
(list cpio-dired-re-sym
'(".+" (cpio-dired-move-to-entry-name) nil (0 cpio-dired-symlink-face)))
;;
;; Entrys suffixed with `completion-ignored-extensions'.
'(eval .
;; It is quicker to first find just an extension, then go back to the
;; start of that entry name. So we do this complex MATCH-ANCHORED form.
(list (concat "\\(" (regexp-opt completion-ignored-extensions) "\\|#\\)$")
'(".+" (cpio-dired-move-to-entry-name) nil (0 cpio-dired-ignored-face))))
;;
;; Entrys suffixed with `completion-ignored-extensions'
;; plus a character put in by -F.
'(eval .
(list (concat "\\(" (regexp-opt completion-ignored-extensions)
"\\|#\\)[*=|]$")
'(".+" (progn
(end-of-line)
;; If the last character is not part of the entry-name,
;; move back to the start of the entry-name
;; so it can be fontified.
;; Otherwise, leave point at the end of the line;
;; that way, nothing is fontified.
(unless (get-text-property (1- (point)) 'mouse-face)
(cpio-dired-move-to-entry-name)))
nil (0 cpio-dired-ignored-face))))
;;
;; Explicitly put the default face on entry names ending in a colon to
;; avoid fontifying them as directory header.
(list (concat cpio-dired-re-maybe-mark " " cpio-dired-re-perms ".*:$")
'(".+" (cpio-dired-move-to-entry-name) nil (0 'default)))
;;
;; Directory headers.
;;;; (list cpio-dired-subdir-regexp '(1 cpio-dired-header-face))
)
"Additional expressions to highlight in cpio-dired mode.")
(setq cpio-dired-font-lock-keywords
;; cpio-dired-font-lock-keywords is adapted from dired.
(list
;;
;; Dired marks.
(list cpio-dired-re-mark '(0 cpio-dired-mark-face))
;;
;; We make heavy use of MATCH-ANCHORED, since the regexps don't identify the
;; entry name itself. We search for Dired defined regexps, and then use the
;; cpio-dired defined function `cpio-dired-move-to-entry-name' before searching for the
;; simple regexp ".+". It is that regexp which matches the entry name.
;;
;; Marked entries.
(list (concat "^[" (char-to-string cpio-dired-marker-char) "]")
'(".+" (cpio-dired-move-to-entry-name) nil (0 cpio-dired-marked-face)))
;;
;; Flagged entries.
(list (concat "^[" (char-to-string cpio-dired-del-marker) "]")
'(".+" (cpio-dired-move-to-entry-name) nil (0 cpio-dired-flagged-face)))
;; People who are paranoid about security would consider this more
;; important than other things such as whether it is a directory.
;; But we don't want to encourage paranoia, so our default
;; should be what's most useful for non-paranoids. -- rms.
;;
;; However, we don't need to highlight the entry name, only the
;; permissions, to win generally. -- fx.
;; Fixme: we could also put text properties on the permission
;; fields with keymaps to frob the permissions, somewhat a la XEmacs.
;;DL (list (concat cpio-dired-re-maybe-mark cpio-dired-re-inode-size
;;DL "[-d]....\\(w\\)....") ; group writable
;;DL '(1 cpio-dired-perm-write-face))
;;DL (list (concat cpio-dired-re-maybe-mark cpio-dired-re-inode-size
;;DL "[-d].......\\(w\\).") ; world writable
;;DL '(1 cpio-dired-perm-write-face))
;;
;; Subdirectories.
(list cpio-dired-re-dir
'(".+" (cpio-dired-move-to-entry-name) nil (0 cpio-dired-directory-face)))
;;
;; Symbolic links.
(list cpio-dired-re-sym
'(".+" (cpio-dired-move-to-entry-name) nil (0 cpio-dired-symlink-face)))
;;
;; Entrys suffixed with `completion-ignored-extensions'.
'(eval .
;; It is quicker to first find just an extension, then go back to the
;; start of that entry name. So we do this complex MATCH-ANCHORED form.
(list (concat "\\(" (regexp-opt completion-ignored-extensions) "\\|#\\)$")
'(".+" (cpio-dired-move-to-entry-name) nil (0 cpio-dired-ignored-face))))
;;
;; Entrys suffixed with `completion-ignored-extensions'
;; plus a character put in by -F.
'(eval .
(list (concat "\\(" (regexp-opt completion-ignored-extensions)
"\\|#\\)[*=|]$")
'(".+" (progn
(end-of-line)
;; If the last character is not part of the entry-name,
;; move back to the start of the entry-name
;; so it can be fontified.
;; Otherwise, leave point at the end of the line;
;; that way, nothing is fontified.
(unless (get-text-property (1- (point)) 'mouse-face)
(cpio-dired-move-to-entry-name)))
nil (0 cpio-dired-ignored-face))))
;;
;; Explicitly put the default face on entry names ending in a colon to
;; avoid fontifying them as directory header.
(list (concat cpio-dired-re-maybe-mark " " cpio-dired-re-perms ".*:$")
'(".+" (cpio-dired-move-to-entry-name) nil (0 'default)))
;;
;; Directory headers.
;;;; (list cpio-dired-subdir-regexp '(1 cpio-dired-header-face))
))
(defvar cpio-entry-name ()
"Name of the entry whose contents are being edited.")
(setq cpio-entry-name ())
(defconst *cpio-dirline-re* "^..d"
"Regular expression to match an entry for a directory.")
(setq *cpio-dirline-re* "^..d")
(defvar *cpio-dired-copy-history* ()
"History of copies made in cpio-dired-mode.")
(setq *cpio-dired-copy-history* ())
(defvar *cpio-dired-do-chgrp-history* ()
"History of M-x cpio-dired-do-chgrp.")
(setq *cpio-dired-do-chgrp-history* ())
(defvar *cpio-dired-do-chown-history* ()
"History of M-x cpio-dired-do-chown.")
(setq *cpio-dired-do-chown-history* ())
(defvar *cpio-dired-do-rename-history* ()
"History of M-x cpio-dired-do-rename.")
(setq *cpio-dired-do-rename-history* ())
(defvar *cpio-dired-head-offset* 2
"The number of lines in the cpio-dired buffer devoted to the dired-style header.")
(setq *cpio-dired-head-offset* 2)
(defvar *cpio-dired-buffer* ()
"The [subordinate] buffer used to present the curent catalog
à la dired.")
(setq *cpio-dired-buffer* ())
(make-variable-buffer-local '*cpio-dired-buffer*)
;;
;; Customizations
;;
(defgroup cpio-dired-faces nil
"Faces used by Dired."
:group 'dired
:group 'faces)
(defface cpio-dired-header
'((t (:inherit font-lock-type-face)))
"Face used for directory headers."
:group 'cpio-dired-faces
:version "22.1")
(defvar cpio-dired-header-face 'cpio-dired-header
"Face name used for directory headers.")
(setq cpio-dired-header-face 'cpio-dired-header)
(defface cpio-dired-mark
'((t (:inherit font-lock-constant-face)))
"Face used for Dired marks."
:group 'cpio-dired-faces
:version "22.1")
(defvar cpio-dired-mark-face 'cpio-dired-mark
"Face name used for Dired marks.")
(defface cpio-dired-marked
'((t (:inherit warning)))
"Face used for marked files."
:group 'cpio-dired-faces
:version "22.1")
(defvar cpio-dired-marked-face 'cpio-dired-marked
"Face name used for marked files.")
(defface cpio-dired-flagged
'((t (:inherit error)))
"Face used for files flagged for deletion."
:group 'cpio-dired-faces
:version "22.1")
(defvar cpio-dired-flagged-face 'cpio-dired-flagged
"Face name used for files flagged for deletion.")
(setq cpio-dired-flagged-face 'cpio-dired-flagged)
(defface cpio-dired-warning
;; Inherit from font-lock-warning-face since with min-colors 8
;; font-lock-comment-face is not colored any more.
'((t (:inherit font-lock-warning-face)))
"Face used to highlight a part of a buffer that needs user attention."
:group 'cpio-dired-faces
:version "22.1")
(defvar cpio-dired-warning-face 'cpio-dired-warning
"Face name used for a part of a buffer that needs user attention.")
(defface cpio-dired-perm-write
'((((type w32 pc)) :inherit default) ;; These default to rw-rw-rw.
;; Inherit from font-lock-comment-delimiter-face since with min-colors 8
;; font-lock-comment-face is not colored any more.
(t (:inherit font-lock-comment-delimiter-face)))
"Face used to highlight permissions of group- and world-writable files."
:group 'cpio-dired-faces
:version "22.2")
(defvar cpio-dired-perm-write-face 'cpio-dired-perm-write
"Face name used for permissions of group- and world-writable files.")
(setq cpio-dired-perm-write-face 'cpio-dired-perm-write)
(defface cpio-dired-directory
'((t (:inherit font-lock-function-name-face)))
"Face used for subdirectories."
:group 'cpio-dired-faces
:version "22.1")
(defvar cpio-dired-directory-face 'cpio-dired-directory
"Face name used for subdirectories.")
(setq cpio-dired-directory-face 'cpio-dired-directory)
(defface cpio-dired-symlink
'((t (:inherit font-lock-keyword-face)))
"Face used for symbolic links."
:group 'cpio-dired-faces
:version "22.1")
(defvar cpio-dired-symlink-face 'cpio-dired-symlink
"Face name used for symbolic links.")
(setq cpio-dired-symlink-face 'cpio-dired-symlink)
(defface cpio-dired-ignored
'((t (:inherit shadow)))
"Face used for files suffixed with `completion-ignored-extensions'."
:group 'cpio-dired-faces
:version "22.1")
(defvar cpio-dired-ignored-face 'cpio-dired-ignored
"Face name used for files suffixed with `completion-ignored-extensions'.")
(setq cpio-dired-ignored-face 'cpio-dired-ignored)
(defcustom cpio-dired-trivial-filenames dired-trivial-filenames
"Regexp of entries to skip when finding the first meaningful entry of a directory."
:group 'cpio-dired
:version "22.1")
(defcustom cpio-dired-hide-details-hide-information-lines nil
"Non-nil means 'cpio-dired-hide-information-lines' hides all but header and file lines."
:group 'cpio-dired
:type 'boolean)
(defcustom cpio-dired-hide-details-hide-symlink-targets nil
"Non-nil means `hides symbolic link targets."
:group 'cpio-dired
:type 'boolean)
(defcustom cpio-dired-hide-details-information nil
"Non-hil means `dired-hide-details-mode' hides all but header and file lines."
:group 'cpio-dired
:type 'boolean)
;; N.B. This is here because this file is where the cpio-dired lines are created.
(defcustom cpio-try-names t
"Non-nil means that GIDs and UIDs are displayed as integers."
:group 'cpio
:type 'boolean)
;;
;; Library
;;
(defun cpio-dired-get-entry-name ()
"Get the entry name on the current line."
(let ((fname "cpio-dired-get-filename"))
(save-excursion
(beginning-of-line)
(save-match-data
(if (looking-at *cpio-dired-entry-regexp*)
(match-string-no-properties *cpio-dired-name-idx*))))))
(defun cpio-dired-hide-details-update-invisibility-spec ()
"Toggle cpio-dired-hide-details-mode."
(let ((fname "cpio-dired-hide-details-update-invisibility-spec"))
(funcall (if cpio-dired-hide-details-mode
'add-to-invisibility-spec
'remove-from-invisibility-spec)
'cpio-dired-hide-details-detail)
(funcall (if (and cpio-dired-hide-details-mode
cpio-dired-hide-details-hide-information-lines)
'add-to-invisibility-spec
'remove-from-invisibility-spec)
'cpio-dired-hide-details-information)
(funcall (if (and cpio-dired-hide-details-mode
cpio-dired-hide-details-hide-symlink-targets
(not (derived-mode-p 'cpio-dired-mode)))
'add-to-invisibility-spec
'remove-from-invisibility-spec)
'cpio-dired-hide-details-link)))
(defun cpio-dired-find-entry-noselect (entry-name)
"Read the contents of the given ENTRY-NAME, but don't display it."
(let ((fname "cpio-dired-find-entry-noselect")
(target-buffer (get-buffer-create (cpio-contents-buffer-name entry-name))))
(cond ((and target-buffer (buffer-live-p target-buffer))
target-buffer)
(target-buffer
(kill-buffer target-buffer)
(setq target-buffer (get-buffer-create (cpio-contents-buffer-name entry-name)))
(with-current-buffer target-buffer
(insert (cpio-contents entry-name)))
target-buffer)
(t nil))))
(defun cpio-internal-do-deletions (l)
"Delete the entries in the list L."
(let ((fname "cpio-internal-do-deletions"))
(if *cab-parent*
(with-current-buffer *cab-parent*
(cpio-internal-do-deletions l))
(mapc 'cpio-internal-do-deletion l))))
(defun cpio-internal-do-deletion (entry-name)
"Remove the entry with name ENTRY-NAME from a cpio-archive.
CONTRACT: You're in that archive's buffer."
(let ((fname "cpio-internal-do-deletion")
(entry-info)
(start-marker)
(end-marker)
(entry-attrs))
(if *cab-parent*
(with-current-buffer *cab-parent*
(cpio-internal-do-deletion entry-name))
(if (null (setq entry-info (assoc entry-name *cpio-catalog*)))
(error "%s(): Could not get entry information for %s." fname entry-name))
(setq start-marker (aref (cdr entry-info) 1)) ;HEREHERE Shouldn't this have an abstraction?
(setq end-marker (1+ (cg-round-up (1- (+ (aref (cdr entry-info) 2)
(cpio-entry-size (cpio-entry-attrs entry-name))))
*cpio-padding-modulus*)))
(with-writable-buffer
(delete-region start-marker end-marker))
(setq *cpio-catalog* (delete (assoc entry-name *cpio-catalog*) *cpio-catalog*)))))
(defun cpio-dired-marked-entries (char arg)
"Return a list of entries marked with CHAR, or,
if none are so marked, then the next ARG entries."
(let ((fname "cpio-dired-marked-entries")
(files ())
(i 0))
(save-excursion
(goto-char (point-min))
(while (re-search-forward (format "^\\%c" char) (point-max) t)
(push (cpio-dired-get-entry-name) files)))
(unless files
(save-excursion
(while (< i arg)
(push (cpio-dired-get-entry-name) files)
(cpio-dired-next-line 1)
(setq i (1+ i)))))
files))
(defun cpio-dired-add-contents (attrs contents &optional cpio-dired-buffer mark)
"Add an entry to a cpio archive using the given ATTRS with the given CONTENTS.
CONTRACT: The archive buffer has no trailer.
The optional argument CPIO-DIRED-BUFFER is just there
to make the recursive call this function inside the archive buffer sensible.
If the optional argument MARK, a character, is not NIL,
then use that to mark the new entry."
;; CAUTION: There's lots of code duplicated with M-x cpio-dired-add-entry.
(unless cpio-dired-buffer (setq cpio-dired-buffer (current-buffer)))
(let ((fname "cpio-dired-add-contents")
(header-string)
(entry-name (cpio-entry-name attrs))
(new-catalog-entry)
(header-start-marker)
(contents-start-marker))
(if *cab-parent*
(with-current-buffer *cab-parent*
(cpio-dired-add-contents attrs contents cpio-dired-buffer mark))
(setq new-catalog-entry (make-vector *cpio-catalog-entry-length* nil))
(cpio-delete-trailer)
(setq header-string (cpio-make-header-string attrs contents))
(with-writable-buffer
(setq header-start-marker (point-max-marker))
(goto-char (point-max))
(insert header-string)
(setq contents-start-marker (point-max-marker))
(goto-char (point-max))
(cpio-insert-padded-contents contents))
(aset new-catalog-entry *cpio-catalog-entry-attrs-idx* attrs)
(aset new-catalog-entry *cpio-catalog-entry-header-start-idx* header-start-marker)
(aset new-catalog-entry *cpio-catalog-entry-contents-start-idx* contents-start-marker)
(cpio-set-entry-unmodified new-catalog-entry)
;; HEREHERE Is there an appropriate abstraction for the following?
;; Perhaps including the above?
(add-to-list '*cpio-catalog* (cons entry-name new-catalog-entry) 'append)
(with-current-buffer cpio-dired-buffer
(save-excursion
(goto-char (point-max))
(with-writable-buffer
(insert (cpio-dired-format-entry attrs mark) "\n")))))))
(defun cpio-dired-get-marked-entries (&optional arg) ;✓
"Return a list of the marked entries in the current cpio-dired buffer."
(let ((fname "cpio-dired-get-marked-entries")
(results ())
(regexp (cpio-dired-marker-regexp))
(i 0))
(unless (string-equal mode-name "cpio-dired")
(error "%s() only makes sense in a cpio-dired buffer." fname))
;; Marks win over ...
(save-excursion
(goto-char (point-min))
(while (re-search-forward regexp (point-max) t)
(push (cpio-dired-get-entry-name) results)))
;; ... arg,
(unless results
(save-excursion
(unless arg (setq arg 1))
(while (< i arg)
(push (cpio-dired-get-entry-name) results)
(dired-next-line 1)
(setq i (1+ i)))))
;; , but if none of that worked, then take the current entry.
(if results
results
(list (cpio-dired-get-entry-name)))))
(defun cpio-dired-internal-do-copy (entry target) ;✓
"Copy the ENTRY to the TARGET entry.
CONTRACT: TARGET is the actual TARGET name, not an implied directory entry."
(let ((fname "cpio-dired-internal-do-copy")
(attrs (copy-sequence (cpio-entry-attrs entry)))
(contents (cpio-contents entry)))
(cpio-set-entry-name attrs target)
(cpio-dired-add-contents attrs contents nil cpio-dired-keep-marker-copy)))
(defun cpio-dired-internal-do-rename (entry-name target)
"Rename ENTRY-NAME to the TARGET entry.
CONTRACT:
1. TARGET is the actual TARGET name, not an implied directory entry.
2. You're in a cpio-dired buffer"
;; HEREHERE This has some overlap with (cpio-dired-internal-do-copy).
(let ((fname "cpio-dired-internal-do-rename")
(entry (cpio-entry entry-name))
(attrs (cpio-entry-attrs entry-name))
(mark (cpio-dired-get-mark entry-name)))
(unless (eq major-mode 'cpio-dired-mode)
(error "%s(): You're not in a cpio-dired buffer." fname))
(save-excursion
(cpio-dired-goto-entry entry-name)
(with-writable-buffer
(delete-region (line-beginning-position) (line-end-position)))
;; (cpio-dired-goto-entry) needs entry-name in the catalog,
;; so don't update it until after.
(cpio-set-entry-name attrs target)
(with-current-buffer *cab-parent*
(setcar (assoc entry-name *cpio-catalog*) target))
(with-writable-buffer
(insert (cpio-dired-format-entry attrs mark))))
(cpio-dired-move-to-entry-name)))
(defun cpio-dired-mark-read-regexp (operation)
"Read a regular expression to match entries for the given OPERATION."
(let* ((fname "cpio-dired-mark-read-regexp")
(regexp (read-regexp
(format "%s on entries matching regexp: " operation)
nil
'dired-regexp-history))
(mark-char (cond ((string-equal operation "Copy")
cpio-dired-keep-marker-copy)
((string-equal operation "Rename")
cpio-dired-keep-marker-rename)
;; ((string-equal operation "HardLink") )
;; ((string-equal operation "Symlink") )
(t (error "%s() called with unknown operation [[%s]]." fname operation))))
(entry-name))
(save-excursion
(goto-char (point-min))
(while (re-search-forward *cpio-dired-entry-regexp* (point-max) t)
(setq entry-name (cpio-dired-get-entry-name))
(if (string-match-p regexp entry-name)
(cpio-dired-mark-this-entry mark-char))))))
(defun cpio-dired-replace-dired-line (entry-name)
"Replace the entry for the given ENTRY-NAME
with information from the current catalog.
CONTRACT: You're on the line to be replaced."
(let ((fname "cpio-dired-replace-dired-line")
(attrs (cpio-entry-attrs entry-name))
(mark))
(save-excursion
(cpio-move-to-entry entry-name)
(setq mark (cpio-dired-get-mark))
(cpio-dired-delete-dired-line entry-name)
(with-writable-buffer
(insert (cpio-dired-format-entry attrs mark))))))
(defun cpio-dired-delete-dired-line (entry-name)
"Delete the line of ENTRY-NAME not including the new line."
(let ((fname "cpio-dired-delete-dired-line"))
(unless (eq major-mode 'cpio-dired-mode)
(error "%s(): You're not in a cpio-dired-buffer." fname))
(cpio-move-to-entry entry-name)
(with-writable-buffer
(delete-region (line-beginning-position) (line-end-position)))))
(defun cpio-dired-buffer-name (archive-name)
"Return the name of the dired-style buffer for ARCHIVE-NAME."
(let ((fname "cpio-dired-buffer-name"))
(concat "CPIO archive: " (file-name-nondirectory archive-name))))
(defun cpio-present-ala-dired (archive-buffer)
"Create a buffer with a ls -l format reflecting the contents of the current cpio archive.
This returns the buffer created."
(let* ((fname "cpio-present-ala-dired")
(archive-name (with-current-buffer archive-buffer
(file-name-nondirectory (buffer-file-name))))
(buffer-name (cpio-dired-buffer-name archive-name))
(buffer (get-buffer-create buffer-name))
(entry-string)
(catalog (cpio-catalog)))
(with-current-buffer buffer
(setq *cpio-catalog* catalog)
(with-writable-buffer
(erase-buffer)
(insert "CPIO archive: " archive-name ":\n\n")
(mapc (lambda (e)
(let ((line (cpio-dired-format-entry (aref (cdr e) 0))))
(insert (concat line "\n"))))
(cpio-sort-catalog)))
(cpio-dired-mode))
(if cab-clear-cab-info-buffer
(with-current-buffer *cab-info-buffer*
(erase-buffer)))
;; No, I do not yet understand why this must be done
;; every time the presentation is updated.
;; (with-current-buffer "cpio-mode.el"
;; kill-buffer-hook)
(cab-register buffer archive-buffer)
;; (with-current-buffer "cpio-mode.el"
;; kill-buffer-hook)
buffer))
(defun cpio-dired-move-to-first-entry ()
"Move the point to the first entry in a cpio-dired style buffer."
(let ((fname "cpio-dired-move-to-first-entry"))
(unless (eq major-mode 'cpio-dired-mode)
(error "%s(): You're not in a cpio-dired buffer." fname))
(goto-char (point-min))
(cpio-dired-next-line *cpio-dired-head-offset*)))
(defun cpio-dired-format-entry (attrs &optional mark)
"Create a dired-style line for ATTRS.
If the optional MARK is given,
then it is a character and used as the mark on the generated line.
The line does not include a trailing ."
(let* ((fname "cpio-dired-format-entry")
(mode-string (cpio-int-mode-to-mode-string (cpio-mode-value attrs)))
(uid-string (cpio-uid-to-uid-string (cpio-uid attrs)))
(gid-string (cpio-gid-to-gid-string (cpio-gid attrs)))
(nlink-string (cpio-nlink-to-nlink-string (cpio-nlink attrs)))
(mtime-string (cpio-mtime-to-mtime-string (cpio-mtime attrs)))
(filesize-string (cpio-filesize-to-filesize-string (cpio-entry-size attrs)))
(dev-maj-string (cpio-dev-maj-to-dev-maj-string (cpio-dev-maj attrs)))
(dev-min-string (cpio-dev-min-to-dev-min-string (cpio-dev-min attrs)))
(entry-name-string (cpio-entry-name-to-entry-name-string (cpio-entry-name attrs)))
(fmt (if entry-name-string
(if cpio-try-names
(format "%%c %%s %%3s %%8s %%8s %%8s %%7s %%s")
(format "%%c %%s %%3s %%5s %%5s %%8s %%7s %%s"))
nil)))
(unless mark (setq mark ?\s))
(unless (characterp mark)
(signal 'wrong-type-error (list 'characterp mark)))
(if fmt
(format fmt mark
mode-string nlink-string uid-string gid-string
filesize-string mtime-string entry-name-string))))
(defun cpio-dired-get-mark (&optional entry-name)
"Get the mark, a character, on ENTRY-NAME."
(let ((fname "cpio-dired-get-mark"))
(unless (eq major-mode 'cpio-dired-mode)
(error "%s(): only makes sense in a cpio-dired buffer." fname))
(unless entry-name
(setq entry-name (cpio-dired-get-entry-name)))
(save-excursion
(cpio-dired-goto-entry entry-name)
(string-to-char (buffer-substring (line-beginning-position)
(1+ (line-beginning-position)))))))
;;
;; Commands
;;
;; h describe-mode
(defun cpio-dired-add-entry (filename &optional cpio-dired-buffer) ;✓
"Add the given FILENAME as an entry in a cpio archive.
The archive is the one affiliated with the current cpio-dired buffer.
If you want a different path, then rename the entry once it's there.
CAVEAT:
This function is not smart about its filename.
If you give a full path, then you get a fullpath.
If you want a different path, then rename the entry once it's there.
TECHNICAL INTERNAL INFORMATION:
The optional argument, CPIO-DIRED-BUFFER, is the cpio-dired style buffer
to be updated with the new entry.
It is here because, while this function may start
in the cpio-dired-style buffer,
It does its heavy lifting in the archive buffer.
CPIO-DIRED-BUFFER is just for bookkeeping;
if CPIO-DIRED-BUFFER is NIL (i.e. you're /in/ the cpio-dired buffer),
then use the current buffer."
;; CAUTION: There's lots of code duplicated with M-x cpio-dired-add-contents.
(interactive "fFile: ")
(let ((fname "cpio-dired-add-entry")
(entry-attrs)
(header-start-marker)
(contents-start-marker)
(header-string)
(cpio-dired-buffer (or cpio-dired-buffer (current-buffer))))
(if (string-match-p "^~/" filename)
(setq filename (expand-file-name filename)))
(cond (*cab-parent*
(unless (eq major-mode 'cpio-dired-mode)
(error "%s(): You're not in a cpio-dired buffer." fname))
(with-current-buffer *cab-parent*
(cpio-dired-add-entry filename cpio-dired-buffer))
(cpio-dired-set-modified))
(t
(setq entry-attrs (cpio-create-entry-attrs filename))
(cpio-delete-trailer)
(setq header-string (cpio-make-header-string entry-attrs))
(with-writable-buffer
(setq header-start-marker (point-max-marker))
(goto-char (point-max))
(insert header-string)
(setq contents-start-marker (point-max-marker))
(goto-char (point-max))
(insert-file-contents filename)
(goto-char (point-max))
(cpio-insert-trailer))
(with-current-buffer cpio-dired-buffer
(with-writable-buffer
(delete-region (line-beginning-position) (1+ (line-end-position)))))))))
;; * c dired-change-marks
(defun cpio-dired-change-marks (old new) ;✓✓
"Change all OLD marks to NEW marks.
OLD and NEW are both characters used to mark entries."
(interactive (let* ((cursor-in-echo-area t)
(old (progn (message "Change (old mark): ") (read-char)))
(new (progn (message "Change %c marks to (new mark): " old)
(read-char))))
(list (char-to-string old) (char-to-string new))))
(let ((fname "cpio-dired-change-marks"))
(unless (eq major-mode 'cpio-dired-mode)
(error "%s(): You're not in a cpio dired buffer." fname))
(save-excursion
(cpio-dired-move-to-first-entry)
(beginning-of-line)
(with-writable-buffer
(while (< (point) (point-max))
(when (looking-at-p old)
(delete-char 1)
(insert new))
(forward-line 1))))))
;; - negative-argument
;; . dired-clean-directory
(defun cpio-dired-clean-directory (keep) ;×
"Flag numerical backups for deletion.
Spares `cpio-dired-kept-versions' latest versions, and `cpio-kept-old-versions' oldest.
Positive prefix arg KEEP overrides `cpio-dired-kept-versions';
Negative prefix arg KEEP overrides `cpio-kept-old-versions' with KEEP made positive.
To clear the flags on these entries, you can use M-x cpio-dired-flag-backup-entries
with a prefix argument."
(interactive "p")
(let ((fname "cpio-dired-clean-directory"))
(error "%s() is not yet implemented" fname)))
;; w dired-copy-filename-as-kill
(defun cpio-dired-copy-entry-name-as-kill (arg) ;✓✓
"Copy names of marked (or next ARG) entries into the kill ring.
The names are separated by a space.
With a zero prefix arg, use the absolute entry name of each marked entry.
With C-u, use the entry name relative to the Dired buffer's
`default-directory'. (This still may contain slashes if in a subdirectory.)
If on a subdir headerline, use absolute subdirname instead;
prefix arg and marked entries are ignored in this case.
You can then feed the entry name(s) to other commands with C-y."
(interactive "p")
(let ((fname "cpio-dired-copy-entry-name-as-kill")
(names (reverse (cpio-dired-get-marked-entries arg))))
(unless (eq major-mode 'cpio-dired-mode)
(error "%s(): You're not in a cpio dired buffer." fname))
(if names
(mapc 'kill-new names)
(save-excursion
(while (and (> arg 0)
(< (point) (point-max)))
(kill-new (cpio-dired-get-entry-name))
(setq arg (1- arg))
(forward-line 1))))))
;; * Prefix Command
;; + dired-create-directory
(defun cpio-dired-create-directory (directory) ;✓✓
"Create a directory entry called DIRECTORY.
If DIRECTORY already exists, signal an error.
This respects umask(1) as available through (default-file-modes)."
(interactive (list (read-string "Create directory: " "" nil "")))
(let ((fname "cpio-dired-create-directory")
(new-catalog-entry)
(attrs)
(header-string)
(header-start)
(contents-start)
(cat-entry)
(namesize))
(cond (*cab-parent*
(unless (eq major-mode 'cpio-dired-mode)
(error "%s(): You're not in a cpio dired buffer." fname))
(with-current-buffer *cab-parent*
(cpio-dired-create-directory directory))
(save-excursion
(goto-char (point-max))
(with-writable-buffer
(insert (concat (cpio-dired-format-entry (cpio-entry-attrs directory)) "\n"))))
(cpio-dired-set-modified))
(t
(unless (eq major-mode 'cpio-mode)
(error "%s(): The parent buffer was not a cpio-mode buffer." fname))
(unless (stringp directory)
(signal 'wrong-type-error (list directory)))
(unless (< 0 (length directory))
(error "%s(): Cannot create an entry with a zero-length name." directory))
(if (cpio-entry-exists-p directory)
(error "%s(): Entry %s already exists." fname directory))
(setq namesize (1+ (length directory)))
(setq attrs (cpio-create-faux-directory-attrs directory))
(cpio-set-mode attrs (logior s-ifdir (default-file-modes)))
(with-writable-buffer
(cpio-delete-trailer)
(setq header-start (point-max-marker))
(setq header-string (cpio-make-header-string attrs))
(goto-char (point-max))
(insert header-string)
(setq buffer-read-only t))
(setq contents-start (point-max-marker))
(push (cons directory
(vector attrs
header-start
contents-start
'cpio-mode-entry-unmodified))
*cpio-catalog*)))))
;; = dired-diff
(defun cpio-dired-diff (entry &optional switches) ;✓
"Compare entry at point with entry ENTRY using `diff'.
If called interactively, prompt for ENTRY. If the entry at point
has a backup entry, use that as the default. If the entry at point
is a backup entry, use its original. If the mark is active
in Transient Mark mode, use the entry at the mark as the default.
\(That's the mark set by C-SPC, not by Dired's
M-x dired-mark command.)
ENTRY is the first entry given to `diff'. The entry at point
is the second entry given to `diff'.
With prefix arg, prompt for second argument SWITCHES, which is
the string of command switches for the third argument of `diff'."
;; HEREHERE This looks like plagiarized code to me. It's certainly not tested.
(interactive
(let* ((current (dired-get-filename t))
;; Get the latest existing backup file or its original.
(oldf (if (backup-file-name-p current)
(file-name-sans-versions current)
(diff-latest-backup-file current)))
;; Get the file at the mark.
(file-at-mark (if (and transient-mark-mode mark-active)
(save-excursion (goto-char (mark t))
(dired-get-filename t t))))
(default-file (or file-at-mark
(and oldf (file-name-nondirectory oldf))))
;; Use it as default if it's not the same as the current file,
;; and the target dir is current or there is a default file.
(default (if (and (not (equal default-file current))
(or (equal (dired-dwim-target-directory)
(dired-current-directory))
default-file))
default-file))
(target-dir (if default
(dired-current-directory)
(dired-dwim-target-directory)))
(defaults (dired-dwim-target-defaults (list current) target-dir)))
(list
(minibuffer-with-setup-hook
(lambda ()
(set (make-local-variable 'minibuffer-default-add-function) nil)
(setq minibuffer-default defaults))
(read-file-name
(format "Diff %s with%s: " current
(if default (format " (default %s)" default) ""))
target-dir default t))
(if current-prefix-arg (read-string "Options for diff: "
(if (stringp diff-switches)
diff-switches
(mapconcat 'identity diff-switches " ")))))))
(let ((fname "cpio-dired-diff"))
(error "%s() is not yet implemented" fname)))
;; C-o dired-display-file
(defun cpio-dired-display-entry () ;✓
"In a cpio UI buffer, display the entry on the current line in another window.
Return the buffer containing the entry's contents."
(interactive)
(let ((fname "cpio-dired-display-entry")
(target-buffer (cpio-dired-find-entry)))
(with-current-buffer target-buffer
(setq buffer-read-only t))
target-buffer))
;; % Prefix Command
;; & dired-do-async-shell-command
(defun cpio-dired-do-async-shell-command (command &optional arg entry-list) ;✓
;; I don't know if this makes sense.
"Run a shell command COMMAND on the marked entries asynchronously.
Like `dired-do-shell-command', but adds `&' at the end of COMMAND
to execute it asynchronously.
When operating on multiple entries, asynchronous commands
are executed in the background on each entry in parallel.
In shell syntax this means separating the individual commands
with `&'. However, when COMMAND ends in `;' or `;&' then commands
are executed in the background on each entry sequentially waiting
for each command to terminate before running the next command.
In shell syntax this means separating the individual commands with `;'.
The output appears in the buffer `*Async Shell Command*'."
;; HEREHERE This looks like plagiarized code. It certainly hasn't been tested.
(interactive
(let ((files (dired-get-marked-files t current-prefix-arg)))
(list
;; Want to give feedback whether this file or marked files are used:
(dired-read-shell-command "& on %s: " current-prefix-arg files)
current-prefix-arg
files)))
(let ((fname "cpio-dired-do-async-shell-command"))
(warn "%s() is not obvious." fname)))
;; B dired-do-byte-compile
(defun cpio-dired-do-byte-compile (arg) ;×
"Byte compile marked (or next ARG) Emacs Lisp entries."
(interactive "p")
(let ((fname "cpio-dired-do-byte-compile"))
(error "%s() is not yet implemented" fname)))
;; G dired-do-chgrp
(defun cpio-dired-do-chgrp (arg &optional entry-names group cpio-dired-buffer) ;✓
"Change the group of the marked (or next ARG) entries.
Type M-n to pull the entry attributes of the entry at point
into the minibuffer.
The optional arguements ENTRY-NAME, GROUP and CPIO-DIRED-BUFFER,
are just for bookkeeping, since this function may be called interactively
in one buffer, but actually performs the function
in the buffer containing the archive."
;; HEREHERE This shares a lot of code with (cpio-dired-do-chown).
(interactive "p")
(let ((fname "cpio-dired-do-chgrp")
(header-string)
(local-entry-names (if entry-names
entry-names
()))
(local-group (if group
group
;; HEREHERE This (read-string) doesn't play nicely
;; with make check.
(read-string "Group? "
nil
*cpio-dired-do-chgrp-history*)))
(local-cpio-dired-buffer (if cpio-dired-buffer
cpio-dired-buffer
(current-buffer)))
(i 0)
(entry)
(attrs)
(mark))
(unless (or (eq major-mode 'cpio-dired-mode)
(eq major-mode 'cpio-mode))
(error "%s(): major mode is [[%s]]." fname (symbol-name major-mode))
(error "%s(): You're in neither a cpio-dired buffer nor a buffer in cpio-mode ." fname))
(cond (*cab-parent*
(unless entry-names
(setq entry-names (cpio-dired-get-marked-entries arg)))
(setq local-group (cg-strip "\\s-+" local-group))
(with-current-buffer *cab-parent*
(cpio-dired-do-chgrp arg entry-names local-group local-cpio-dired-buffer))
(cpio-dired-set-modified))
(t
(unless entry-names
(signal 'void-variable entry-names))
(unless group
(signal 'void-variable group))
(unless cpio-dired-buffer
(signal 'void-variable cpio-dired-buffer))
(if (null (setq local-group (cpio-gid-for-group local-group)))
(error "%s(): Group [[%s]] does not exist." fname group))
(mapc (lambda (en)
(setq entry (cpio-entry en))
(setq attrs (cpio-entry-attrs en))
(cpio-set-gid attrs local-group)
(with-current-buffer local-cpio-dired-buffer
(save-excursion
(cpio-dired-goto-entry en)
(setq mark (cpio-dired-get-mark))
(with-writable-buffer
(delete-region (line-beginning-position)
(line-end-position))
(insert (cpio-dired-format-entry attrs mark))))))
entry-names)
(cpio-dired-set-modified)))))
;; M dired-do-chmod
(defun cpio-dired-do-chmod (&optional arg) ;✓✓✓
"Change the mode of the marked (or next ARG) entries.
Symbolic modes like `g+w' are allowed.
Type M-n to pull the entry attributes of the entry at point
into the minibuffer."
(interactive "p")
(let* ((fname "cpio-dired-do-chmod")
(entries (cpio-dired-get-marked-entries arg))
(default-entry (cpio-dired-get-entry-name))
(default-attrs (cpio-entry-attrs default-entry))
(cpio-mode-value (cpio-mode-value default-attrs))
(entry-type)
(default-mode-value (cpio-mode-value default-attrs))
(cpio-mode-value default-mode-value)
(attrs)
(mode-string (cpio-int-mode-to-mode-string cpio-mode-value))
(default
(and (stringp mode-string)
(string-match "^.\\(...\\)\\(...\\)\\(...\\)$" mode-string)
(replace-regexp-in-string
"-" ""
(format "u=%s,g=%s,o=%s"
(match-string-no-properties 1 mode-string)
(match-string-no-properties 2 mode-string)
(match-string-no-properties 3 mode-string)))))
(modes (dired-mark-read-string
"Change mode of %s to: "
nil 'chmod arg entries default)))
(cond ((or (equal mode-string "")
(equal mode-string default-mode-value))
(error "%s(): No entry mode specified." fname))
((string-match-p "^[0-7]+" modes)
(setq cpio-mode-value (string-to-number modes 8)))
(cpio-dired-set-modified))
(dolist (entry entries)
(setq entry-type (cpio-numeric-entry-type (cpio-mode-value (cpio-entry-attrs entry))))
(cpio-set-mode (cpio-entry-attrs entry) (logior entry-type cpio-mode-value))
(cpio-dired-replace-dired-line entry))))
;; O dired-do-chown
(defun cpio-dired-do-chown (arg &optional entry-names owner cpio-dired-buffer) ;✓
"Change the owner of the marked (or next ARG) entries.
Type M-n to pull the entry attributes of the entry at point
into the minibuffer."
;; HEREHERE This shares a lot of code with (cpio-dired-do-chgrp).
(interactive "p")
(let ((fname "cpio-dired-do-chown")
(header-string)
(cpio-dired-buffer (current-buffer))
(local-entry-names (if entry-names
entry-names
()))
(local-owner (if owner
owner
;; HERREHERE The following (read-string) doesn't play nicely
;; with make check*.
(read-string "Owner? "
nil
*cpio-dired-do-chown-history*)))
(local-group)
(local-cpio-dired-buffer (if cpio-dired-buffer
cpio-dired-buffer))
(i 0)
(entry)
(attrs)
(mark))
(unless (or (eq major-mode 'cpio-dired-mode)
(eq major-mode 'cpio-mode))
(error "%s(): You're in neither a cpio-dired buffer nor a buffer in cpio-mode ." fname))
(cond (*cab-parent*
(unless entry-names
(setq entry-names (cpio-dired-get-marked-entries arg)))
(unless entry-names
(save-excursion
(cpio-dired-move-to-entry-name)
(while (and (< i arg)
(< (point) (point-max)))
(push (cpio-dired-get-entry-name) entry-names)
(setq i (1+ i)))))
(setq local-owner (cg-strip "\\s-+" local-owner))
(with-current-buffer *cab-parent*
(cpio-dired-do-chown arg entry-names local-owner cpio-dired-buffer))
(cpio-dired-set-modified))
(t
(unless entry-names
(signal 'void-variable entry-names))
(unless owner
(signal 'void-variable owner))
(unless cpio-dired-buffer
(signal 'void-variable cpio-dired-buffer))
(cond ((string-match-p ":" owner)
(setq local-owner (nth 0 (split-string owner ":")))
(setq local-group (nth 1 (split-string owner ":"))))
(t t))
(if (null (setq local-owner (cpio-uid-for-owner local-owner)))
(error "%s(): Owner [[%s]] does not exist." fname owner))
(setq local-group (cpio-gid-for-group local-group))
(mapc (lambda (en)
(setq entry (cpio-entry en))
(setq attrs (cpio-entry-attrs en))
(cpio-set-uid attrs local-owner)
(if local-group
(cpio-set-gid attrs local-group))
(cpio-set-contents-start entry (+ (cpio-entry-header-start entry)
(length (cpio-pad (cpio-make-header-string attrs)
*cpio-padding-modulus* ?\0))))
(goto-char (cpio-entry-contents-start entry))
(with-current-buffer local-cpio-dired-buffer
(save-excursion
(cpio-dired-goto-entry en)
(setq mark (cpio-dired-get-mark))
(with-writable-buffer
(delete-region (line-beginning-position)
(line-end-position))
(insert (cpio-dired-format-entry attrs mark))))))
entry-names)
(cpio-dired-set-modified)))))
;; Z dired-do-compress
(defun cpio-dired-do-compress (arg) ;×
"Compress or uncompress marked (or next ARG) entries."
(interactive "p")
(let ((fname "cpio-dired-do-compress"))
(error "%s() is not yet implemented" fname)))
;; C dired-do-copy
(defun cpio-dired-do-copy (arg) ;✓
"Copy all marked (or next ARG) entries, or copy the current entry.
When operating on just the current entry, prompt for the new name.
When operating on multiple or marked entries,
the prompt for a target implies
that that target should be a directory."
;; HEREHERE This has lots of duplicated code with (cpio-dired-do-rename).
(interactive "p")
(let ((fname "cpio-dired-do-copy")
(entries (cpio-dired-marked-entries cpio-dired-marker-char arg))
(target)
(target-attrs))
(setq target (read-string "Target? "
nil
*cpio-dired-copy-history*))
(cpio-delete-trailer)
(cond ((> (length entries) 1)
(setq target (cg-strip-right "/" target 'multiples))
;; First handle the case where the entry exists and looks like a directory.
(cond ((cpio-entry-exists-p target)
(setq target-attrs (cpio-entry-attrs target))
(if (/= (logand s-ifdir (cpio-mode-value target-attrs)) s-ifdir)
(error "%s(): There's already a non-directory entry called %s." fname target)))
(t t))
;; Now check the existence of the implied targets.
(mapc (lambda (en)
(if (cpio-entry-exists-p (concat target "/" en))
(error "%s(): Target entry [[%s]] is already there." fname (concat target "/" en))))
entries)
;; Finally, add the implied targets.
(mapc (lambda (en)
(cpio-dired-internal-do-copy en (concat target "/" en)))
entries)
(cpio-dired-set-modified))
((cpio-entry-exists-p target)
(setq target-attrs (cpio-entry-attrs target))
(if (= (logand s-ifdir (cpio-mode-value target-attrs)) s-ifdir)
(mapc (lambda (en)
(cpio-dired-internal-do-copy en (concat target "/" en)))
entries)
(error "%s(): There's already an entry called %s." fname target)))
(t
(mapc (lambda (en)
(cpio-dired-internal-do-copy en target))
entries)))))
;; % C dired-do-copy-regexp
(defun cpio-dired-do-copy-regexp (regexp newname &optional arg whole-name) ;×
"Copy selected entries whose names match REGEXP to NEWNAME.
See function `cpio-dired-do-rename-regexp' for more info."
(interactive (cpio-dired-mark-read-regexp "Copy"))
(let ((fname "cpio-dired-do-copy-regexp"))
(error "%s() is not yet implemented" fname)))
;; D dired-do-delete
(defun cpio-dired-do-delete (arg) ;✓
"Delete all marked (or next ARG) entries.
Marks win over ARG."
(interactive "p")
(let ((fname "cpio-dired-do-delete")
(entries (cpio-dired-marked-entries cpio-dired-marker-char arg))
(i 0))
(unless (eq major-mode 'cpio-dired-mode)
(error "%s(): You're not in a cpio-dired buffer." fname))
(mapc (lambda (en)
(save-excursion
(cpio-dired-goto-entry en)
(with-writable-buffer
(delete-region (line-beginning-position) (1+ (line-end-position))))
(cpio-internal-do-deletion en)))
entries)
(cpio-dired-set-modified)
(cpio-dired-move-to-entry-name)))
;; x dired-do-flagged-delete
(defun cpio-dired-do-flagged-delete (&optional nomessage) ;✓
"In Dired, delete the entries flagged for deletion.
If NOMESSAGE is non-nil, we don't display any message
if there are no flagged entries.
`dired-recursive-deletes' controls whether deletion of
non-empty directories is allowed."
(interactive)
(let ((fname "cpio-dired-do-flagged-delete")
(entries (cpio-dired-marked-entries cpio-dired-del-marker 1)))
(unless (eq major-mode 'cpio-dired-mode)
(error "%s(): You're not in a cpio-dired buffer." fname))
(if (and (null entries)
(not nomessage))
(message "%s(): No entries marked for deletion." fname))
(mapc (lambda (en)
(save-excursion
(cond ((cpio-dired-goto-entry en)
(with-writable-buffer
(delete-region (line-beginning-position)
(1+ (line-end-position)))))
(t t)))
(cpio-internal-do-deletion en))
entries)
(cpio-dired-set-modified)))
;; H dired-do-hardlink
(defun cpio-dired-do-hardlink (arg) ;×
"Add names (hard links) current entry or all marked (or next ARG) entries.
When operating on just the current entry, you specify the new name.
When operating on multiple or marked entries, you specify a directory
and new hard links are made in that directory
with the same names that the entries currently have. The default
suggested for the target directory depends on the value of
`dired-dwim-target', which see."
(interactive "p")
(let ((fname "cpio-dired-do-hardlink"))
(error "%s() is not yet implemented" fname)))
;; % H dired-do-hardlink-regexp
(defun cpio-dired-do-hardlink-regexp (regexp newname &optional arg whole-name) ;×
"Hardlink selected entries whose names match REGEXP to NEWNAME.
See function `dired-do-rename-regexp' for more info."
(interactive (cpio-dired-mark-read-regexp "HardLink"))
(let ((fname "cpio-dired-do-hardlink-regexp"))
(error "%s() is not yet implemented" fname)))
;;
;; M-s a C-s dired-do-isearch
(defun cpio-dired-do-isearch () ;×
"Search for a string through all marked entries using Isearch."
(interactive)
(let ((fname "cpio-dired-do-isearch"))
(error "%s() is not yet implemented" fname)))
;;
;; M-s a C-M-s dired-do-isearch-regexp
(defun cpio-dired-do-isearch-regexp () ;×
"Search for a regexp through all marked entries using Isearch."
(interactive)
(let ((fname "cpio-dired-do-isearch-regexp"))
(error "%s() is not yet implemented" fname)))
;; k dired-do-kill-lines
(defun cpio-dired-do-kill-lines (arg) ;×
"Kill all marked lines (not the entries).
With a prefix argument, kill that many lines starting with the current line.
\(A negative argument kills backward.)
If you use this command with a prefix argument to kill the line
for a entry that is a directory, which you have inserted in the
Dired buffer as a subdirectory, then it deletes that subdirectory
from the buffer as well.
To kill an entire subdirectory (without killing its line in the
parent directory), go to its directory header line and use this
command with a prefix argument (the value does not matter)."
(interactive "p")
(let ((fname "cpio-dired-do-kill-lines"))
(error "%s() is not yet implemented" fname)))
;; L dired-do-load
(defun cpio-dired-do-load (arg) ;×
"Load the marked (or next ARG) Emacs Lisp entries."
(interactive "p")
(let ((fname "cpio-dired-do-load"))
(error "%s() is not yet implemented" fname)))
;; P dired-do-print
(defun cpio-dired-do-print (arg) ;×
"Print the marked (or next ARG) entries.
Uses the shell command coming from variables `lpr-command' and
`lpr-switches' as default."
(interactive "p")
(let ((fname "cpio-dired-do-print"))
(error "%s() is not yet implemented" fname)))
;; Q dired-do-qeuery-replace-regexp
(defun cpio-dired-do-query-replace-regexp (from to &optional delimited) ;✓
"Do `query-replace-regexp' of FROM with TO, on all marked entries.
Third arg DELIMITED (prefix arg) means replace only word-delimited matches.
If you exit (C-g, RET or q), you can resume the query replace
with the command M-,."
(interactive
(let ((common
(query-replace-read-args
"Query replace regexp in marked files" t t)))
(list (nth 0 common) (nth 1 common) (nth 2 common))))
(let ((fname "cpio-dired-do-query-replace-regexp"))
(error "%s() is not yet implemented" fname)))
;; l dired-do-redisplay
(defun cpio-dired-do-redisplay (arg) ;×
"Redisplay all marked (or next ARG) entries.
If on a subdir line, redisplay that subdirectory. In that case,
a prefix arg lets you edit the `ls' switches used for the new listing.
Dired remembers switches specified with a prefix arg, so that reverting
the buffer will not reset them. However, using `dired-undo' to re-insert
or delete subdirectories can bypass this machinery. Hence, you sometimes
may have to reset some subdirectory switches after a `dired-undo'.
You can reset all subdirectory switches to the default using
M-x dired-reset-subdir-switches.
See Info node `(emacs)Subdir switches' for more details."
(interactive "p")
(let ((fname "cpio-dired-do-redisplay"))
(error "%s() is not yet implemented" fname)))
;; R dired-do-rename
(defun cpio-dired-do-rename (arg) ;✓
"Rename current entry or all marked (or next ARG) entries.
When renaming just the current entry, you specify the new name.
When renaming multiple or marked entries, you specify a directory.
This command also renames any buffers that are visiting the entries.
The default suggested for the target directory depends on the value
of `dired-dwim-target', which see."
;; HEREHERE This has lots of code stolen from (cpio-dired-do-copy).
(interactive "p")
(let ((fname "cpio-dired-do-rename")
(entries (cpio-dired-marked-entries cpio-dired-marker-char arg))
(target)
(target-attrs))
(setq target (read-string "Target? "
nil
*cpio-dired-do-rename-history*))
(cond ((> (length entries) 1)
(setq target (cg-strip-right "/" target 'multiples))
;; First handle the case where the entry exists and looks like a directory.
(cond ((cpio-entry-exists-p target)
(setq target-attrs (cpio-entry-attrs target))
(if (/= (logand s-ifdir (cpio-mode-value target-attrs)) s-ifdir)
(error "%s(): There's already a non-directory entry called %s." fname target)))
;; HEREHERE Should I create the directory if it doesn't exist?
(t t))
;; Now check the existence of the implied targets.
(mapc (lambda (en)
(if (cpio-entry-exists-p (concat target "/" en))
(error "%s(): Target entry [[%s]] is already there." fname (concat target "/" en))))
entries)
;; Finally, add the implied targets.
(mapc (lambda (en)
(cpio-dired-internal-do-rename en (concat target "/" en)))
entries))
((cpio-entry-exists-p target)
(setq target-attrs (cpio-entry-attrs target))
(cond ((= (logand s-ifdir (cpio-mode-value target-attrs)) s-ifdir)
(mapc (lambda (en)
(cpio-dired-internal-do-rename en (concat target "/" en)))
entries)
(cpio-dired-set-modified))
(t
(error "%s(): There's already an entry called %s." fname target))))
(t
(mapc (lambda (en)
(cpio-dired-internal-do-rename en target))
entries))
(cpio-dired-set-modified))))
;; % R dired-do-rename-regexp
;; % r dired-do-rename-regexp
(defun cpio-dired-do-rename-regexp (regexp newname &optional arg whole-name) ;×
"Rename selected entries whose names match REGEXP to NEWNAME.
With non-zero prefix argument ARG, the command operates on the next ARG
entries. Otherwise, it operates on all the marked entries, or the current
entry if none are marked.
As each match is found, the user must type a character saying
what to do with it. For directions, type C-h at that time.
NEWNAME may contain \ or \& as in `query-replace-regexp'.
REGEXP defaults to the last regexp used.
With a zero prefix arg, renaming by regexp affects the absolute entry name.
Normally, only the non-directory part of the entry name is used and changed."
(interactive (cpio-dired-mark-read-regexp "Rename"))
(let ((fname "cpio-dired-do-rename-regexp"))
(error "%s() is not yet implemented" fname)
(cpio-dired-set-modified)))
;; A
(defun cpio-dired-do-search (regexp) ;✓
"Search through all marked entries for matches for REGEXP.
Present the results in *CPIO search results for REGEXP*.
NOTE: This behavior differs from the corresponding function in dired."
;; HEREHERE This is not yet functional.
(interactive "sSearch marked entries (regexp): ")
(let ((fname "cpio-dired-do-search")
(entry-names (cpio-dired-get-marked-entries))
(entry-name)
(entry-info)
(entry-attrs)
(entry-start)
(entry-end)
(cpio-dired-buffer (current-buffer))
(entry-buffer)
(results ())
(results-buffer-name (concat "CPIO search results for " regexp "*"))
(results-buffer))
(with-current-buffer *cab-parent*
(setq *cpio-search-re* regexp)
(setq *cpio-search-entries* entry-names)
(setq *cpio-search-entry* nil)
(setq *cpio-search-point* nil)
(setq entry-name (save-excursion
(mapc (lambda (en)
(setq entry-attrs (cpio-entry-attrs en))
(setq entry-start (cpio-contents-start en))
(setq entry-end (+ entry-start (cpio-entry-size entry-attrs)))
(goto-char entry-start)
(while (re-search-forward regexp entry-end t)
(setq *cpio-search-entry* en)
(setq *cpio-search-point* (- (point) entry-start))
;; Switch back to cpio-dired-buffer
;; since that's the only place
;; that (cpio-dired-find-entry) makes sense.
(with-current-buffer cpio-dired-buffer
(with-current-buffer (setq entry-buffer (cpio-dired-find-entry-noselect en))
(re-search-forward regexp (point-max) t)
(push (format "%s:%d: %s\n" en (count-lines (point-min) (match-beginning 0)) en)
results)))))
entry-names))))
(cond (results
(with-current-buffer (setq results-buffer (get-buffer-create results-buffer-name))
(erase-buffer)
(mapc 'insert (nreverse results)))
(pop-to-buffer results-buffer))
(t nil))))
;; ! dired-do-shell-command
;; X dired-do-shell-command
(defun cpio-dired-do-shell-command (command &optional arg entry-list) ;×
;; I'm not sure this one makes reasonable sense.
;; Certainly, you could run a filter on the entry's contents,
;; but I can't see a way to truly treat an entry like a file in that way.
"Run a shell command COMMAND on the marked entries.
If no entries are marked or a numeric prefix arg is given,
the next ARG entries are used. Just C-u means the current entry.
The prompt mentions the entry(s) or the marker, as appropriate.
If there is a `*' in COMMAND, surrounded by whitespace, this runs
COMMAND just once with the entire entry list substituted there.
If there is no `*', but there is a `?' in COMMAND, surrounded by
whitespace, this runs COMMAND on each entry individually with the
entry name substituted for `?'.
Otherwise, this runs COMMAND on each entry individually with the
entry name added at the end of COMMAND (separated by a space).
`*' and `?' when not surrounded by whitespace have no special
significance for `dired-do-shell-command', and are passed through
normally to the shell, but you must confirm first.
If you want to use `*' as a shell wildcard with whitespace around
it, write `*\"\"' in place of just `*'. This is equivalent to just
`*' in the shell, but avoids Dired's special handling.
If COMMAND ends in `&', `;', or `;&', it is executed in the
background asynchronously, and the output appears in the buffer
`*Async Shell Command*'. When operating on multiple entries and COMMAND
ends in `&', the shell command is executed on each entry in parallel.
However, when COMMAND ends in `;' or `;&' then commands are executed
in the background on each entry sequentially waiting for each command
to terminate before running the next command. You can also use
`dired-do-async-shell-command' that automatically adds `&'.
Otherwise, COMMAND is executed synchronously, and the output
appears in the buffer `*Shell Command Output*'.
This feature does not try to redisplay Dired buffers afterward, as
there's no telling what entries COMMAND may have changed.
Type M-x dired-do-redisplay to redisplay the marked entries.
When COMMAND runs, its working directory is the top-level directory
of the Dired buffer, so output entries usually are created there
instead of in a subdir.
In a noninteractive call (from Lisp code), you must specify
the list of entry names explicitly with the ENTRY-LIST argument, which
can be produced by `dired-get-marked-entries', for example."
(interactive
(let ((files (dired-get-marked-files t current-prefix-arg)))
(list
;; Want to give feedback whether this file or marked files are used:
(dired-read-shell-command "! on %s: " current-prefix-arg files)
current-prefix-arg
files)))
(let ((fname "cpio-dired-do-shell-command"))
(error "%s() is not yet implemented" fname)))
;; S dired-do-symlink
(defun cpio-dired-do-symlink (arg) ;×
"Make symbolic links to current entry or all marked (or next ARG) entries.
When operating on just the current entry, you specify the new name.
When operating on multiple or marked entries, you specify a directory
and new symbolic links are made in that directory
with the same names that the entries currently have. The default
suggested for the target directory depends on the value of
`dired-dwim-target', which see.
For relative symlinks, use M-x dired-do-relsymlink."
(interactive "p")
(let ((fname "cpio-dired-do-symlink"))
(error "%s() is not yet implemented" fname)))
;; % S dired-do-symlink-regexp
(defun cpio-dired-do-symlink-regexp (regexp newname &optional arg whole-name) ;×
"Symlink selected entries whose names match REGEXP to NEWNAME.
See function `dired-do-rename-regexp' for more info."
(interactive (cpio-dired-mark-read-regexp "SymLink"))
(let ((fname "cpio-dired-do-symlink-regexp"))
(error "%s() is not yet implemented" fname)))
;; T dired-do-touch
(defun cpio-dired-do-touch (arg) ;✓
"Change the timestamp of the marked (or next ARG) entries."
;; HEREHERE To be done:
;; Type M-n to pull the entry attributes of the entry at point
;; into the minibuffer."
(interactive "p")
(let ((fname "cpio-dired-do-touch")
(entries (cpio-dired-get-marked-entries arg))
(prompt)
(human-timestamp)
(timestamp (current-time))
(time-re)
(human-time)
(time)
(entry-name))
(cond ((= (length entries) 0)
(error "%s(): No cpio archive entries found." fname))
((or (> arg 1)
(> (length entries) 1))
(setq prompt (format "Change timestamp of %d files to when? [now]? " (length entries))))
((= arg 1)
(setq prompt (format "Change timestamp of %s to when? [now]? " (car entries))))
(t
(error "%s(): Impossible situation." fname)))
(setq human-timestamp (read-from-minibuffer prompt))
(while human-timestamp
(if (string-equal human-timestamp "")
(setq time (current-time))
(setq time (encode-human-time human-timestamp)))
(cond (time
(dolist (entry entries)
(cpio-set-mtime (cpio-entry-attrs entry) time)
(cpio-dired-replace-dired-line entry))
(setq human-timestamp nil))
((y-or-n-p (format "[[%s]] looks ambiguous. Try again?" time))
(setq human-timestamp (read-from-minibuffer prompt)))
(t (setq human-timestamp nil))))
(cpio-dired-set-modified)))
;; % l dired-downcase
(defun cpio-dired-downcase (arg) ;×
"Rename all marked (or next ARG) entries to lower case."
(interactive "p")
(let ((fname "cpio-dired-downcase"))
(error "%s() is not yet implemented" fname)))
(defun cpio-dired-extract-all () ;✓
"Extract all the entries in the current CPIO arhcive."
(interactive)
(let ((fname "cpio-dired-extract-all"))
(unless (or (eq major-mode 'cpio-dired-mode)
(eq major-mode 'cpio-mode))
(error "%s() only makes sense in a cpio-dired buffer." fname))
(cond (*cab-parent*
(with-current-buffer *cab-parent*
(cpio-dired-extract-all)))
(t
(cpio-extract-all)))))
(defun cpio-dired-extract-entries (arg) ;✓
"Extract the marked entries in the current CPIO dired buffer."
(interactive "p")
(let ((fname "cpio-dired-extract-entries")
(files (or (cpio-dired-get-marked-entries)
(list (cpio-dired-get-entry-name)))))
(unless (or (eq major-mode 'cpio-dired-mode)
(eq major-mode 'cpio-mode))
(error "%s() only makes sense in a cpio-dired buffer." fname))
(cond (*cab-parent*
(with-current-buffer *cab-parent*
(mapc 'cpio-extract-entry files)))
(t
(mapc 'cpio-extract-entry files)))))
;; a dired-find-alternate-file
(defun cpio-dired-find-alternate-entry () ;×
"In Dired, visit this entry or directory instead of the Dired buffer."
(interactive)
(let ((fname "cpio-dired-find-alternate-entry"))
(error "%s() is not yet implemented" fname)))
;; e .. f dired-find-file
;; RET dired-find-file
(defun cpio-dired-find-entry () ;✓
"In a cpio UI buffer, visit the contents of the entry named on this line.
Return the buffer containing those contents."
(interactive)
(let ((fname "cpio-dired-find-entry")
(find-file-run-dired t)
(local-entry-name (cpio-dired-get-entry-name))
(entry-buf))
(cond ((null local-entry-name)
(message "%s(): Could not get entry name." fname))
(t
(with-current-buffer (setq entry-buf (cpio-find-entry local-entry-name))
(cpio-entry-contents-mode))
(pop-to-buffer entry-buf)))))
;; n dired-next-line
;; o dired-find-file-other-window
(defun cpio-dired-find-entry-other-window () ;✓
"In Dired, visit this entry or directory in another window."
(interactive)
(let ((fname "cpio-dired-find-entry-other-window"))
(error "%s() is not yet implemented" fname)))
;; # dired-flag-auto-save-files
(defun cpio-dired-flag-auto-save-entries (&optional unflag-p) ;✓
"Flag for deletion entries whos names suggest they are auto save entries.
A prefix argument says to unmark or unflag those files instead."
(interactive)
(let ((fname "cpio-dired-flag-auto-save-entries"))
(unless (eq major-mode 'cpio-dired-mode)
(error "%s(): You're not in a cpio-dired style buffer." fname))
(save-excursion
(cpio-dired-move-to-first-entry)
(while (< (point) (point-max))
(if (string-match-p "\\`#" (cpio-dired-get-entry-name))
(if unflag-p
(cpio-dired-unmark 1)
(cpio-dired-mark-this-entry cpio-dired-del-marker))
(cpio-dired-next-line 1))))))
;; ~ dired-flag-backup-entries
(defun cpio-dired-flag-backup-entries (unflag-p) ;✓✓✓✓
;; Modeled very closely on the corresponding dired function
"Flag all backup entries (names ending with `~') for deletion.
With prefix argument, unmark or unflag these entries."
(interactive "P")
(let ((fname "cpio-dired-flag-backup-entries")
(dired-marker-char (if unflag-p ?\s dired-del-marker)))
(dired-mark-if
(and (save-excursion (end-of-line)
(eq (preceding-char) ?~))
(not (looking-at-p dired-re-dir))
(let ((entry-name (cpio-dired-get-entry-name))) ;The main modification for cpio-dired-mode.
(if entry-name (backup-file-name-p entry-name))))
"backup file")))
;; % d dired-flag-entries-regexp
(defun cpio-dired-flag-entries-regexp (regexp) ;×
"In Dired, flag all entries containing the specified REGEXP for deletion.
The match is against the non-directory part of the entry name. Use `^'
and `$' to anchor matches. Exclude subdirs by hiding them.
`.' and `..' are never flagged."
(interactive (cpio-dired-mark-read-regexp "SymLink"))
(let ((fname "cpio-dired-flag-entries-regexp"))
(error "%s() is not yet implemented" fname)))
;; d dired-flag-file-deletion
(defun cpio-dired-flag-entry-deletion (arg) ;✓
"In a cpio-dired style buffer,
flag the current line's entry for deletion.
If the region is active, flag all entries in the region.
Otherwise, with a prefix arg, flag entries on the next ARG lines.
If on a subdir headerline, flag all its entries except `.' and `..'.
If the region is active in Transient Mark mode, flag all entries
in the active region."
(interactive "p")
(let ((fname "cpio-dired-flag-entry-deletion")
(cpio-dired-marker-char cpio-dired-del-marker))
(cpio-dired-mark arg)))
;; M-s a Prefix Command
;; M-s f Prefix Command
;; % & dired-flag-garbage-entries
(defvar cpio-dired-garbage-entries-regexp dired-garbage-files-regexp
"Regular expression to match in cpio-dired-flag-garbage-entries.")
(setq cpio-dired-garbage-entries-regexp dired-garbage-files-regexp)
(defun cpio-dired-flag-garbage-entries () ;✓✓✓
"Flag for deletion all entries that match `cpio-dired-garbage-entries-regexp'."
(interactive)
(let ((fname "cpio-dired-flag-garbage-entries")
(entry-name))
(save-excursion
(cpio-dired-move-to-first-entry)
(save-match-data
(while (< (point) (point-max))
(setq entry-name (cpio-dired-get-entry-name))
(if (string-match-p cpio-dired-garbage-entries-regexp entry-name)
(cpio-dired-flag-entry-deletion 1)
(dired-next-line 1)))))))
;; j dired-goto-entry
(defun cpio-dired-goto-entry (entry) ;✓✓✓
"Go to line describing entry ENTRY in this Dired buffer."
(interactive "sGoto entry: ")
(let ((fname "cpio-dired-goto-entry")
(this-entry))
(unless (eq major-mode 'cpio-dired-mode)
(error "%s(): You're not in a cpio-dired buffer." fname))
(unless (cpio-entry-exists-p entry)
(error "%s(): There's no entry [[%s]]." fname entry))
(goto-char (point-min))
(re-search-forward (concat " " entry "$"))
(cpio-dired-move-to-entry-name)))
;; M-$ dired-hide-all
(defun cpio-dired-hide-all () ;×
"Hide all subdirectories, leaving only their header lines.
If there is already something hidden, make everything visible again.
Use M-x dired-hide-subdir to (un)hide a particular subdirectory."
(interactive)
(let ((fname "cpio-dired-hide-all"))
(error "%s() is not yet implemented" fname)))
;; $ dired-hide-subdir
(defun cpio-dired-hide-subdir (arg) ;×
;; Does this really make sense here?
"Hide or unhide the current subdirectory and move to next directory.
Optional prefix arg is a repeat factor.
Use M-x dired-hide-all to (un)hide all directories."
(interactive "p")
(let ((fname "cpio-dired-hide-subdir"))
(warn "%s() is not obvious." fname)))
;;
;; M-s f C-s dired-isearch-filenames
(defun cpio-dired-isearch-entry-names () ;×
"Search for a string using Isearch only in entry names in the Dired buffer."
(interactive)
(let ((fname "cpio-dired-isearch-entry-names"))
(error "%s() is not yet implemented" fname)))
;; M-s a ESC Prefix Command
;;
;; M-s f C-M-s dired-isearch-filenames-regexp
(defun cpio-dired-isearch-entry-names-regexp () ;×
"Search for a regexp using Isearch only in entry names in the cpio-dired buffer."
(interactive)
(let ((fname "cpio-dired-isearch-entry-names-regexp"))
(error "%s() is not yet implemented" fname)))
(defun cpio-dired-kill () ;✓
"Kill the current cpio dired-style buffer
along with it's corresponding archive buffer
and any affiliated buffers thereof."
(interactive)
(let ((fname "cpio-dired-kill"))
(unless (eq major-mode 'cpio-dired-mode)
(error "%s(): You're trying to kill a cpio buffer, but you're not in cpio-mode." fname))
(if *cab-parent*
(cond ((buffer-live-p *cab-parent*)
(if (and (called-interactively-p 'interactive)
(cpio-dired-modified-p))
(if (y-or-n-p "You've made changes to the archive. Save first? ")
(cpio-dired-save-archive)))
(with-current-buffer *cab-parent*
(kill-buffer))
;; This should be a noop.
(kill-buffer))
(t
(warn "%s(): Archive buffer [[%s]] is not there." fname (file-name-nondirectory (buffer-file-name *cab-parent*)))
(remove-hook 'kill-buffer-hook 'cab-kill-buffer-hook)
(kill-buffer)))
(kill-buffer))))
;; m dired-mark
(defun cpio-dired-mark (arg &optional interactive) ;✓
"If the region is active, mark all entries in the region.
Otherwise, with a prefix arg, mark entries on the next ARG lines."
(interactive "p")
(let ((fname "cpio-dired-mark")
(start (if (and interactive (use-region-p))
(min (point) (mark))
nil))
(end (if (and interactive (use-region-p))
(max (point) (mark))
nil))
(entry-name))
(cond ((and interactive (use-region-p))
(save-excursion
(let ((beg (region-beginning))
(end (region-end)))
(dired-mark-files-in-region
(progn (goto-char beg) (line-beginning-position))
(progn (goto-char end) (line-beginning-position))))))
(arg
(let ((inhibit-read-only t))
(dired-repeat-over-lines
(prefix-numeric-value arg)
(function (lambda () (delete-char 1) (insert cpio-dired-marker-char)))))))))
;; * / dired-mark-directories
(defun cpio-dired-mark-directories () ;✓
"Mark all directory entry lines except `.' and `..'.
With prefix argument, unmark or unflag all those entries."
(interactive)
(let ((fname "cpio-dired-mark-directories"))
(error "%s() is not yet implemented" fname)))
;; % g dired-mark-entries-containing-regexp
(defun cpio-dired-mark-entries-containing-regexp (regexp) ;×
;; dired-mark-entries-containing-regexp is an alias for `dired-mark-entries-containing-regexp',
;; which is not defined. Please make a bug report.
"Mark all entries with contents containing REGEXP for use in later commands.
A prefix argument means to unmark them instead.
`.' and `..' are never marked."
(interactive
(list (read-regexp (concat (if current-prefix-arg "Unmark" "Mark")
" files containing (regexp): ")
nil 'dired-regexp-history)
(if current-prefix-arg ?\040)))
(let ((fname "cpio-dired-mark-entries-containing-regexp"))
(error "%s() is not yet implemented" fname)))
;; % m dired-mark-entries-regexp
;; * % dired-mark-entries-regexp
(defun cpio-dired-mark-entries-regexp (regexp &optional marker-char) ;✓
"Mark all entries matching REGEXP for use in later commands.
A prefix argument means to unmark them instead.
`.' and `..' are never marked.
REGEXP is an Emacs regexp, not a shell wildcard. Thus, use `\.o$' for
object entries--just `.o' will mark more than you might think."
(interactive (list (read-regexp (concat (if current-prefix-arg "Unmark" "Mark")
" files (regexp): ")
nil 'dired-regexp-history)))
(unless marker-char (setq marker-char cpio-dired-marker-char))
(let ((fname "cpio-dired-mark-entries-regexp")
(cpio-dired-marker-char (or marker-char cpio-dired-marker-char))
(entry-name))
(unless (eq major-mode 'cpio-dired-mode)
(error "%s(): You're not in a cpio-dired buffer." fname))
(save-excursion
(cpio-dired-move-to-first-entry)
(while (< (point) (point-max))
(setq entry-name (cpio-dired-get-entry-name))
(if (string-match-p regexp entry-name)
(cpio-dired-mark 1 marker-char)
(cpio-dired-next-line 1))))))
;; * * dired-mark-executables
(defun cpio-dired-mark-executables (arg) ;✓✓✓
"Mark all executable entries.
With prefix argument, unmark or unflag all those entries."
(interactive "P")
(let ((fname "cpio-dired-mark-executables")
(this-mode))
(save-excursion
(cpio-dired-move-to-first-entry)
(while (< (point) (point-max))
(setq this-mode (cpio-mode-value (cpio-entry-attrs (cpio-dired-get-entry-name))))
(if (or (/= 0 (logand s-ixusr this-mode))
(/= 0 (logand s-ixgrp this-mode))
(/= 0 (logand s-ixoth this-mode)))
(cpio-dired-mark-this-entry)
(cpio-dired-next-line 1))))))
;; * m dired-mark
;; Defined above.
;; * s dired-mark-subdir-entries
(defun cpio-dired-mark-subdir-entries () ;✓✓✓
"Mark all entries except `.' and `..' in current subdirectory.
If the Dired buffer shows multiple directories, this command
marks the entries listed in the subdirectory that point is in."
(interactive)
(let ((fname "cpio-dired-mark-subdir-entries")
(this-mode))
(save-excursion
(cpio-dired-move-to-first-entry)
(while (< (point) (point-max))
(setq this-mode (cpio-mode-value (cpio-entry-attrs (cpio-dired-get-entry-name))))
(if (/= 0 (logand s-ifdir this-mode))
(cpio-dired-mark-this-entry)
(cpio-dired-next-line 1))))))
;; * @ dired-mark-symlinks
(defun cpio-dired-mark-symlinks (unflag-p) ;✓✓✓
"Mark all symbolic links.
With prefix argument, unmark or unflag all those entries."
(interactive "P")
(let ((fname "cpio-dired-mark-symlinks")
(this-mode))
(save-excursion
(cpio-dired-move-to-first-entry)
(while (< (point) (point-max))
(setq this-mode (cpio-mode-value (cpio-entry-attrs (cpio-dired-get-entry-name))))
(if (= s-iflnk (logand s-iflnk this-mode))
(cpio-dired-mark-this-entry)
(cpio-dired-next-line 1))))))
(defun cpio-dired-mark-this-entry (&optional char) ;✓
"Mark the entry on the current line with the given CHAR.
If CHAR is not given, then use cpio-dired-marker-char.
CONTRACT: You must be allowed to operate on that entry."
(unless char (setq char cpio-dired-marker-char))
(let ((fname "cpio-dired-mark-this-entry"))
(beginning-of-line)
(with-writable-buffer
(delete-char 1)
(insert (char-to-string char)))
(cpio-dired-next-line 1)))
(defun cpio-dired-marker-regexp ()
"Return a regular expression to match a marked entry."
(concat "^" (regexp-quote (char-to-string cpio-dired-marker-char))))
;; i dired-maybe-insert-subdir
(defun cpio-dired-maybe-insert-subdir () ;×
"Insert this subdirectory into the same dired buffer.
If it is already present, just move to it (type M-x dired-do-redisplay to refresh),
else inserts it at its natural place (as `ls -lR' would have done).
With a prefix arg, you may edit the ls switches used for this listing.
You can add `R' to the switches to expand the whole tree starting at
this subdirectory.
This function takes some pains to conform to `ls -lR' output.
Dired remembers switches specified with a prefix arg, so that reverting
the buffer will not reset them. However, using `dired-undo' to re-insert
or delete subdirectories can bypass this machinery. Hence, you sometimes
may have to reset some subdirectory switches after a `dired-undo'.
HEREHERE Archives don't hold subdirectories the same way a file system does.
You can reset all subdirectory switches to the default using
M-x dired-reset-subdir-switches.
See Info node `(emacs)Subdir switches' for more details."
(interactive)
(let ((fname "cpio-dired-maybe-insert-subdir"))
(error "%s() is not yet implemented" fname)))
;; mouse-face
;; dired-mouse-find-file-other-window
(defun cpio-dired-mouse-find-entry-other-window () ;×
"In a cpio UI window, visit the entry or directory name you click on."
(interactive)
(let ((fname "cpio-dired-mouse-find-entry-other-window"))
(error "%s() is not yet implemented" fname)))
(defun cpio-dired-move-to-entry-name ()
"Move the point to the beginning of the entry on the current line
if there is one."
(let ((fname "cpio-dired-move-to-entry-name"))
(beginning-of-line)
(save-match-data
(if (looking-at *cpio-dired-entry-regexp*)
(goto-char (match-beginning *cpio-dired-name-idx*))))))
;; > dired-next-dirline
(defun cpio-dired-next-dirline (arg &optional opoint) ;✓
"Goto ARGth next directory entry line."
(interactive "p")
(unless opoint (setq opoint (point)))
(let ((fname "cpio-dired-next-dirline"))
(while (and (< 0 arg)
(re-search-forward *cpio-dirline-re* (point-max) t))
(setq arg (1- arg)))
(cpio-dired-move-to-entry-name)))
;; C-t Prefix Command
;; ESC Prefix Command
;; SPC dired-next-line
;; dired-next-line
(defun cpio-dired-next-line (arg) ;✓
"In a cpio UI buffer, move down ARG lines then position at the entry's name.
Optional prefix ARG says how many lines to move; default is one line."
(interactive "p")
(let ((fname "cpio-dired-next-line"))
(forward-line arg)
(cpio-dired-move-to-entry-name)))
;; M-} dired-next-marked-file
;; * C-n dired-next-marked-file
(defun cpio-dired-next-marked-entry (wrap) ;×
"Move to the previous marked entry.
If WRAP is non-nil, wrap around to the end of the buffer if we
reach the beginning of the buffer."
(let ((fname "cpio-dired-next-marked-entry"))
(error "%s() is not yet implemented" fname)))
;; C-M-n dired-next-subdir
(defun cpio-dired-next-subdir () ;×
"Go to next subdirectory, regardless of level."
(interactive)
(let ((fname "cpio-dired-next-subdir"))
(error "%s() is not yet implemented" fname)))
;; 0 .. 9 digit-argument
;; : Prefix Command
;; < dired-prev-dirline
(defun cpio-dired-prev-dirline (arg) ;✓
"Goto ARGth previous directory entry line."
(interactive "p")
(let ((fname "cpio-dired-prev-dirline"))
(while (and (< 0 arg)
(prog2
(beginning-of-line)
(re-search-backward *cpio-dirline-re* (point-min) t)))
(setq arg (1- arg)))
(cpio-dired-move-to-entry-name)))
;; M-s Prefix Command
;; M-{ dired-prev-marked-file
;; * C-p dired-prev-marked-file
(defun cpio-dired-prev-marked-entry (arg wrap) ;×
"Move to the previous marked entry.
If WRAP is non-nil, wrap around to the end of the buffer if we
reach the beginning of the buffer."
(interactive "p\np")
(let ((fname "cpio-dired-prev-marked-entry"))
(error "%s() is not yet implemented" fname)))
;; C-M-p dired-prev-subdir
(defun cpio-dired-prev-subdir () ;×
"Go to previous subdirectory, regardless of level.
When called interactively and not on a subdir line, go to this subdir's line."
(interactive)
(let ((fname "cpio-dired-prev-subdir"))
(error "%s() is not yet implemented" fname)))
;; p dired-previous-line
;; dired-previous-line
(defun cpio-dired-previous-line (arg) ;✓
"Move up lines then position at entry name.
Optional prefix ARG says how many lines to move; default is one line."
(interactive "p")
(let ((fname "cpio-dired-previous-line"))
(forward-line (- arg))
(cpio-dired-move-to-entry-name)))
;; q quit-window
(defun cpio-dired-quit-window (&optional kill window) ;✓
"Quit WINDOW and bury its buffer.
WINDOW must be a live window and defaults to the selected one.
With prefix argument KILL non-nil, kill the buffer instead of
burying it.
According to information stored in WINDOW's `quit-restore' window
parameter either (1) delete WINDOW and its frame, (2) delete
WINDOW, (3) restore the buffer previously displayed in WINDOW,
or (4) make WINDOW display some other buffer than the present
one. If non-nil, reset `quit-restore' parameter to nil."
(interactive "P")
(let ((fname "cpio-dired-quit-window")
(buffer (window-buffer)))
(cond (kill
(kill-buffer buffer))
(t
(delete-window (selected-window))
(bury-buffer buffer)))))
(defun cpio-dired-save-archive () ;✓
"Save the archive associated with this cpio-dired buffer."
(interactive)
(let ((fname "cpio-dired-save-archive"))
(unless (or (eq major-mode 'cpio-dired-mode)
(eq major-mode 'cpio-mode))
(error "%s(): You can only save an archive from a cpio-dired buffer." fname))
(cond (*cab-parent*
(with-current-buffer *cab-parent*
(cpio-dired-save-archive))
(mapc (lambda (cen)
(cpio-dired-replace-dired-line (car cen)))
(cpio-catalog))
(cpio-dired-set-unmodified))
(t
(cpio-delete-trailer)
(with-writable-buffer
(mapc (lambda (cen) ;(cons name entry-contents)
(let* ((entry-info (cdr cen))
(attrs (aref entry-info *cpio-catalog-entry-attrs-idx*))
(header-start (marker-position
(aref entry-info 1)))
(header-end (marker-position
(aref entry-info 2)))
(header-string (cpio-make-header-string
attrs)))
(goto-char header-start)
(delete-region header-start header-end)
(set-marker (aref entry-info 1) (point)) ;Redundant?
(insert header-string)
(goto-char (+ (aref entry-info 1)
(length header-string)))
(set-marker (aref entry-info 2) (point))
(forward-char (cpio-entry-size attrs))
(while (looking-at-p "\0")
(delete-char 1))))
;; Do the adjustments backwards to ensure that the resulting markers are correct.
(reverse *cpio-catalog*))
;; Adjust all the entry padding.
(mapc (lambda (cen)
(let* ((entry (cdr cen))
(attrs (aref entry *cpio-catalog-entry-attrs-idx*))
(header-start (marker-position (aref entry *cpio-catalog-entry-header-start-idx*)))
(entry-start (marker-position (aref entry *cpio-catalog-entry-contents-start-idx*)))
(cpio-set-entry-unmodified entry)
(header-string (cpio-make-header-string attrs))
(local-where)
(padding-length))
(goto-char (+ entry-start (cpio-entry-size attrs)))
(setq local-where (mod (1- (point))
*cpio-padding-modulus*))
(cond ((= 0 local-where)
(setq padding-length 0))
(t
(setq padding-length (- *cpio-padding-modulus* local-where))))
(insert (make-string padding-length ?\0))))
*cpio-catalog*)
(cpio-adjust-trailer))
(basic-save-buffer)))))
;; y dired-show-file-type
(defun cpio-dired-show-entry-type (entry &optional deref-symlinks) ;×
"Print the type of ENTRY, according to the `entry' command.
If you give a prefix to this command, and ENTRY is a symbolic
link, then the type of the entry linked to by ENTRY is printed
instead."
(interactive (list (dired-get-filename t) current-prefix-arg))
(let ((fname "cpio-dired-show-entry-type"))
(error "%s() is not yet implemented" fname)))
;; s dired-sort-toggle-or-edit
(defun cpio-dired-sort-toggle-or-edit () ;×
"Toggle sorting by date, and refresh the Dired buffer.
With a prefix argument, edit the current listing switches instead."
(interactive)
(let ((fname "cpio-dired-sort-toggle-or-edit"))
(error "%s() is not yet implemented" fname)))
;; ? dired-summary
(defun cpio-dired-summary () ;✓
"Summarize basic cpio-dired commands."
(interactive)
(let ((fname "cpio-dired-summary"))
;>> this should check the key-bindings and use substitute-command-keys if non-standard
(message
"d-elete, u-ndelete, x-punge, f-ind, o-ther window, R-ename, C-opy, h-elp")))
;; * t dired-toggle-marks
;; t dired-toggle-marks
(defun cpio-dired-toggle-marks () ;×
"Toggle marks: marked entries become unmarked, and vice versa.
Entries marked with other flags (such as `D') are not affected.
`.' and `..' are never toggled.
As always, hidden subdirs are not affected."
(interactive)
(let ((fname "cpio-dired-toggle-marks"))
(error "%s() is not yet implemented" fname)))
;; dired-toggle-read-only
;; dired-toggle-read-only
(defun cpio-dired-toggle-read-only () ;×
;; HEREHERE Figure out very precisely what this means for M-x cpio-mode.
"Edit Dired buffer with Wdired, or make it read-only.
If the current buffer can be edited with Wdired, (i.e. the major
mode is `dired-mode'), call `wdired-change-to-wdired-mode'.
Otherwise, toggle `read-only-mode'."
(interactive)
(let ((fname "cpio-dired-toggle-read-only"))
(error "%s() is not yet implemented" fname)))
;; C-M-d dired-tree-down
(defun cpio-dired-tree-down () ;×
"Go down in the dired tree."
(interactive)
(let ((fname "cpio-dired-tree-down"))
(error "%s() is not yet implemented" fname)))
;; C-M-u dired-tree-up
(defun cpio-dired-tree-up (arg) ;×
"Go up ARG levels in the dired tree."
(interactive)
(let ((fname "cpio-dired-tree-up"))
(error "%s() is not yet implemented" fname)))
;; dired-undo
;; dired-undo
(defun cpio-dired-undo () ;×
"Search for a string using Isearch only in entry names in the Dired buffer.
You can use it to recover marks, killed lines or subdirs."
(interactive)
(let ((fname "cpio-dired-undo"))
(error "%s() is not yet implemented" fname)))
;; u dired-unmark
;; * u dired-unmark
(defun cpio-dired-unmark (arg) ;✓
"If the region is active, unmark all entries in the region.
Otherwise, with a prefix arg, unmark entries on the next ARG lines.
If looking at a subdir, unmark all its entries except `.' and `..'.
If the region is active in Transient Mark mode, unmark all entries
in the active region."
;; HEREHERE This shares a lot of structure sith M-x cpio-dired-mark.
(interactive "p")
(let ((fname "cpio-dired-unmark"))
(cond ((save-excursion (beginning-of-line) (looking-at-p *cpio-dired-entry-regexp*))
(let ((inhibit-read-only t))
(while (and (< 0 arg)
(< (point) (point-max)))
(cpio-dired-mark-this-entry ?\s)
;; (cpio-dired-next-line 1)
(setq arg (1- arg)))))
(t nil))
(cpio-dired-move-to-entry-name)))
;; * ? dired-unmark-all-entries
;; M-DEL dired-unmark-all-entries
(defun cpio-dired-unmark-all-entries (mark arg) ;✓
"Remove a specific mark (or any mark) from every entry.
After this command, type the mark character to remove,
or type RET to remove all marks.
With prefix arg, query for each marked file.
Type C-h at that time for help."
(interactive "sRemove marks (RET means all): \nP")
(let ((fname "cpio-dired-unmark-all-entries")
entry)
(unless (eq major-mode 'cpio-dired-mode)
(error "%s(): You're not in a cpio-dired buffer." fname))
(cond ((string-equal mark "")
(cpio-dired-unmark-all-marks))
(t
(save-excursion
(cpio-dired-move-to-first-entry)
(beginning-of-line)
(while (< (point) (point-max))
(setq entry (cpio-dired-get-entry-name))
(beginning-of-line)
(if (looking-at-p mark)
(with-writable-buffer
(cond ((and arg
(y-or-n-p (format "Unmark entry `%s'? " entry)))
(delete-char 1)
(insert " "))
(t
(delete-char 1)
(insert " "))))
(cpio-dired-next-line 1))))))))
;; * ! dired-unmark-all-marks
;; U dired-unmark-all-marks
(defun cpio-dired-unmark-all-marks () ;✓
"Remove all marks from all entries in the Dired buffer."
(interactive)
(let ((fname "cpio-dired-unmark-all-marks"))
(unless (eq major-mode 'cpio-dired-mode)
(error "%s(): You're not in a cpio-dired buffer." fname))
(save-excursion
(cpio-dired-move-to-first-entry)
(with-writable-buffer
(while (< (point) (point-max))
(beginning-of-line)
(delete-char 1)
(insert " ")
(cpio-dired-next-line 1))))))
;; DEL dired-unmark-backward
;; * DEL dired-unmark-backward
(defun cpio-dired-unmark-backward (&optional arg) ;×
"In a cpio UI buffer, move up lines and remove marks or deletion flags there.
Optional prefix ARG says how many lines to unmark/unflag; default
is one line.
If the region is active in Transient Mark mode, unmark all entries
in the active region."
(interactive "p")
(let ((fname "cpio-dired-unmark-backward"))
(error "%s() is not yet implemented" fname)))
;; ^ dired-up-directory
(defun cpio-dired-up-directory () ;×
"Run Dired on parent directory of current directory.
Find the parent directory either in this buffer or another buffer.
Creates a buffer if necessary.
If OTHER-WINDOW (the optional prefix arg), display the parent
directory in another window."
(interactive)
(let ((fname "cpio-dired-up-directory"))
(error "%s() is not yet implemented" fname)))
;; % u dired-upcase
(defun cpio-dired-upcase (arg) ;×
"Rename all marked (or next ARG) entries to upper case."
(interactive)
(let ((fname "cpio-dired-upcase"))
(error "%s() is not yet implemented" fname)))
(defun cpio-dired-view-archive () ;×
"Switch to the buffer holding the cpio archive for this cpio-dired style buffer."
(interactive)
(let ((fname "cpio-dired-view-archive"))
(switch-to-buffer *cab-parent*)))
;; v dired-view-file
(defun cpio-dired-view-entry () ;×
"In Dired, examine a entry in view mode, returning to Dired when done.
When entry is a directory, show it in this buffer if it is inserted.
Otherwise, display it in another buffer."
(interactive)
(let ((fname "cpio-dired-view-entry"))
(error "%s() is not yet implemented" fname)))
;;
;; : d epa-dired-do-decrypt
(defun cpio-epa-dired-do-decrypt () ;×
"Decrypt marked entries."
(interactive)
(let ((fname "epa-dired-do-decrypt"))
(error "%s() is not yet implemented" fname)))
;; : e epa-dired-do-encrypt
(defun cpio-epa-dired-do-encrypt () ;×
"Encrypt marked entries."
(interactive)
(let ((fname "epa-dired-do-encrypt"))
(error "%s() is not yet implemented" fname)))
;; : s epa-dired-do-sign
(defun cpio-epa-dired-do-sign () ;×
"Sign marked entries."
(interactive)
(let ((fname "epa-dired-do-sign"))
(error "%s() is not yet implemented" fname)))
;; : v epa-dired-do-verify
(defun cpio-epa-dired-do-verify () ;×
"Verify marked entries."
(interactive)
(let ((fname "epa-dired-do-verify"))
(error "%s() is not yet implemented" fname)))
;; C-t r image-dired-delete-tag
(defun cpio-image-dired-delete-tag (arg) ;×
"Remove tag for selected entry(s).
With prefix argument ARG, remove tag from entry at point."
(interactive "P")
(let ((fname "image-dired-delete-tag"))
(error "%s() is not yet implemented" fname)))
;; C-t c image-dired-dired-comment-entries
(defun cpio-image-dired-dired-comment-entries () ;×
"Add comment to current or marked entries in dired."
(interactive)
(let ((fname "image-dired-dired-comment-entries"))
(error "%s() is not yet implemented" fname)))
;; C-t x image-dired-dired-display-external
(defun cpio-image-dired-dired-display-external () ;×
"Display entry at point using an external viewer."
(interactive)
(let ((fname "image-dired-dired-display-external"))
(error "%s() is not yet implemented" fname)))
;; C-t i image-dired-dired-display-image
(defun cpio-image-dired-dired-display-image (&optional arg) ;×
"Display current image entry.
See documentation for `image-dired-display-image' for more information.
With prefix argument ARG, display image in its original size."
(interactive "p")
(let ((fname "image-dired-dired-display-image"))
(error "%s() is not yet implemented" fname)))
;; C-t e image-dired-dired-edit-comment-and-tags
(defun cpio-image-dired-dired-edit-comment-and-tags () ;×
"Edit comment and tags of current or marked image entries.
Edit comment and tags for all marked image entries in an
easy-to-use form."
(interactive)
(let ((fname "image-dired-dired-edit-comment-and-tags"))
(error "%s() is not yet implemented" fname)))
;; Prefix Command
;;
;; C-t C-t image-dired-dired-toggle-marked-thumbs
(defun cpio-image-dired-dired-toggle-marked-thumbs (arg) ;×
"Toggle thumbnails in front of entry names in the dired buffer.
If no marked entry could be found, insert or hide thumbnails on the
current line. ARG, if non-nil, specifies the entries to use instead
of the marked entries. If ARG is an integer, use the next ARG (or
previous -ARG, if ARG<0) entries."
(interactive "p")
(let ((fname "image-dired-dired-toggle-marked-thumbs"))
(error "%s() is not yet implemented" fname)))
;; C-t . image-dired-display-thumb
(defun cpio-image-dired-display-thumb (arg) ;×
"Shorthand for `image-dired-display-thumbs' with prefix argument."
(interactive "p")
(let ((fname "image-dired-display-thumb"))
(error "%s() is not yet implemented" fname)))
;; C-t d image-dired-display-thumbs ;×
(defun cpio-image-dired-display-thumbs (&optional arg append do-not-pop)
"Display thumbnails of all marked entries, in `image-dired-thumbnail-buffer'.
If a thumbnail image does not exist for a entry, it is created on the
fly. With prefix argument ARG, display only thumbnail for entry at
apoint (this is useful if you have marked some entries but want to show
another one).
Recommended usage is to split the current frame horizontally so that
you have the dired buffer in the left window and the
`image-dired-thumbnail-buffer' buffer in the right window.
With optional argument APPEND, append thumbnail to thumbnail buffer
instead of erasing it first.
Optional argument DO-NOT-POP controls if `pop-to-buffer' should be
used or not. If non-nil, use `display-buffer' instead of
`pop-to-buffer'. This is used from functions like
`image-dired-next-line-and-display' and
`image-dired-previous-line-and-display' where we do not want the
thumbnail buffer to be selected."
(interactive "P")
(let ((fname "image-dired-display-thumbs"))
(error "%s() is not yet implemented" fname)))
;; C-t a image-dired-display-thumbs-append
(defun cpio-image-dired-display-thumbs-append () ;×
"Append thumbnails to `image-dired-thumbnail-buffer'."
(interactive)
(let ((fname "image-dired-display-thumbs-append"))
(error "%s() is not yet implemented" fname)))
;; C-t j image-dired-jump-thumbnail-buffer
(defun cpio-image-dired-jump-thumbnail-buffer () ;×
"Jump to thumbnail buffer."
(interactive)
(let ((fname "image-dired-jump-thumbnail-buffer"))
(error "%s() is not yet implemented" fname))) ;×
;; C-t f image-dired-mark-tagged-entries
(defun cpio-image-dired-mark-tagged-entries () ;×
;; HREHERE What should I do with this?
"Use regexp to mark entries with matching tag.
A `tag' is a keyword, a piece of meta data, associated with an
image entry and stored in image-dired's database entry. This command
lets you input a regexp and this will be matched against all tags
on all image entries in the database entry. The entries that have a
matching tag will be marked in the dired buffer."
(interactive)
(let ((fname "image-dired-mark-tagged-entries"))
(error "%s() is not yet implemented" fname)))
;; C-t t image-dired-tag-entries
(defun cpio-image-dired-tag-entries (arg) ;×
"Tag marked entry(s) in dired. With prefix ARG, tag entry at point."
(interactive "P")
(let ((fname "image-dired-tag-entries"))
(error "%s() is not yet implemented" fname)))
;; g revert-buffer
(defun cpio-revert-buffer () ;✓
"Replace current buffer text with the dired-style view
of the corresponding CPIO archive.
This undoes all changes since the entry was visited or saved.
With a prefix argument, offer to revert from latest auto-save entry, if
that is more recent than the visited archive.
This command also implements an interface for special buffers
that contain text which doesn't come from a entry, but reflects
some other data instead (e.g. Dired buffers, `buffer-list'
buffers). This is done via the variable `revert-buffer-function'.
In these cases, it should reconstruct the buffer contents from the
appropriate data.
When called from Lisp, the first argument is IGNORE-AUTO; only offer
to revert from the auto-save entry when this is nil. Note that the
sense of this argument is the reverse of the prefix argument, for the
sake of backward compatibility. IGNORE-AUTO is optional, defaulting
to nil.
Optional second argument NOCONFIRM means don't ask for confirmation
at all. (The variable `revert-without-query' offers another way to
revert buffers without querying for confirmation.)
Optional third argument PRESERVE-MODES non-nil means don't alter
the entries modes. Normally we reinitialize them using `normal-mode'.
This function binds `revert-buffer-in-progress-p' non-nil while it operates.
This function calls the function that `revert-buffer-function' specifies
to do the work, with arguments IGNORE-AUTO and NOCONFIRM.
The default function runs the hooks `before-revert-hook' and
`after-revert-hook'."
(interactive)
(let ((fname "cpio-revert-buffer"))
(if *cab-parent*
(if (buffer-live-p *cab-parent*)
(with-current-buffer *cab-parent*
(cpio-revert-buffer))
(find-file (buffer-file-name *cab-parent*))
(cpio-mode))
(cpio-mode))))
;; S-SPC scroll-down-command
(defun cpio-scroll-down-command (arg) ;×
"Scroll text of selected window down ARG lines; or near full screen if no ARG.
If `scroll-error-top-bottom' is non-nil and `scroll-down' cannot
scroll window further, move cursor to the top line.
When point is already on that position, then signal an error.
A near full screen is `next-screen-context-lines' less than a full screen.
Negative ARG means scroll upward.
If ARG is the atom `-', scroll upward by nearly full screen."
(interactive "p")
(let ((fname "scroll-down-command"))
(error "%s() is not yet implemented" fname)))
(defun cpio-tags-loop-continue () ;✓
"Continue the search through marked entries in a cpio-dired buffer."
;; HERREHERE Do I want this? Is it used?
(interactive)
(let ((fname "cpio-tags-loop-continue")
(entry-buffer (get-buffer-create
(cpio-contents-buffer-name (with-current-buffer *cab-parent*
*cpio-search-entry*))))
(search-point (with-current-buffer *cab-parent*
*cpio-search-point*))
(regex (with-current-buffer *cab-parent*
*cpio-search-re*))
(entry-attrs)
(contents-size)
(contents-start))
(error "%s(): is not yet implemented." fname)
(switch-to-buffer entry-buffer)
(goto-char search-point)
(unless (re-search-forward regex (point-max) t)
(catch 'found-one
(with-current-buffer *cab-parent*
(while (setq *cpio-search-entry* (pop *cpio-search-entries*))
(setq entry-attrs (cpio-entry-attrs *cpio-search-entry*))
(goto-char (cpio-contents-start *cpio-search-entry*))
(cond ((re-search-forward *cpio-search-re* (+ contents-start (cpio-entry-size entry-attrs)))
(cpio-dired-find-entry)
(goto-char (point-min))
(re-search-forward *cpio-search-re* (point-max) t)
(throw 'found-one t))
(t nil)))))
(unless *cpio-search-entries*
(setq *cpio-search-entry* nil)
(setq *cpio-search-re* nil)
(setq *cpio-search-point* nil)))))
(defun cpio-dired-hide-details-mode ()
"Toggle visibility of detailed information in current Dired buffer.
When this minor mode is enabled, details such as file ownership and
permissions are hidden from view."
(let ((fname "cpio-dired-hide-details-mode"))
(error "%s() is not yet implemented" fname)))
;;
;; mode definition
;;
(defvar cpio-dired-mode-map
(let ((map (make-keymap)))
(define-key map "\C-c\C-c" 'cpio-dired-view-archive) ;✓
;; e .. f dired-find-file
;;
;; RET dired-find-file
(define-key map "e" 'cpio-dired-find-entry) ;✓
(define-key map "f" 'cpio-dired-find-entry) ;✓
(define-key map "\C-j" 'cpio-dired-find-entry) ;✓
;; C-o dired-display-file
(define-key map "\C-o" 'cpio-dired-display-entry) ;✓
;; C-t Prefix Command
;; ESC Prefix Command
;; SPC dired-next-line
;; n dired-next-line
;; dired-next-line
(define-key map "[remap next-line]" 'cpio-dired-next-line)
(define-key map "n" 'cpio-dired-next-line)
(define-key map "\C-n" 'cpio-dired-next-line)
(define-key map " " 'cpio-dired-next-line) ;✓
;; ! dired-do-shell-command
;; (define-key map "!" 'cpio-dired-do-shell-command) ;×
;; # dired-flag-auto-save-files
(define-key map "#" 'cpio-dired-flag-auto-save-entries) ;✓
;; $ dired-hide-subdir
(define-key map "$" 'cpio-dired-hide-subdir) ;?
;; % Prefix Command
(define-key map "%" nil)
;; & dired-do-async-shell-command
(define-key map "&" 'cpio-dired-do-async-shell-command) ;×
;; ( dired-hide-details-mode
(define-key map "(" 'cpio-dired-hide-details-mode) ;✓ Implemented by analogue to dired, but does nothing.
;; * Prefix Command
;; (define-key map "+" nil) ;×
;; + dired-create-directory
(define-key map "+" 'cpio-dired-create-directory) ;✓✓
;; - negative-argument
;; . dired-clean-directory
(define-key map "." 'cpio-dired-clean-directory)
;; 0 .. 9 digit-argument
;; : Prefix Command
(define-key map ":" nil)
;; < dired-prev-dirline
(define-key map "<" 'cpio-dired-prev-dirline) ;✓
;; = dired-diff
(define-key map "=" 'cpio-dired-diff) ;×
;; > dired-next-dirline
(define-key map ">" 'cpio-dired-next-dirline) ;✓
;; ? dired-summary
(define-key map "?" 'cpio-dired-summary) ;✓
;; A dired-do-search
(define-key map "A" 'cpio-dired-do-search) ;HEREHERE
;; (define-key map "\M-," 'cpio-tags-loop-continue)
;; B dired-do-byte-compile
;; (define-key map "B" 'cpio-dired-do-byte-compile) ;×
;; C dired-do-copy
(define-key map "C" 'cpio-dired-do-copy) ;✓
;; D dired-do-delete
(define-key map "D" 'cpio-dired-do-delete) ;✓
;; G dired-do-chgrp
(define-key map "G" 'cpio-dired-do-chgrp) ;✓
;; H dired-do-hardlink
(define-key map "H" 'cpio-dired-do-hardlink)
;; I -- Add an entry. New for cpio-dired.
(define-key map "I" 'cpio-dired-add-entry)
;; L dired-do-load
;; (define-key map "L" 'cpio-dired-do-load) ;×
;; M dired-do-chmod
(define-key map "M" 'cpio-dired-do-chmod)
;; O dired-do-chown
(define-key map "O" 'cpio-dired-do-chown) ;✓
;; P dired-do-print
(define-key map "P" 'cpio-dired-do-print)
;; Q dired-do-query-replace-regexp
(define-key map "Q" 'cpio-dired-do-query-replace-regexp)
;; R dired-do-rename
(define-key map "R" 'cpio-dired-do-rename)
;; S dired-do-symlink
(define-key map "S" 'cpio-dired-do-symlink)
;; T dired-do-touch
(define-key map "T" 'cpio-dired-do-touch)
;;;; ;; X dired-do-shell-command
;;;; (define-key map "X" 'cpio-dired-do-shell-command)
;; X prefix command
(define-key map "X" nil)
;; Xa
(define-key map "Xa" 'cpio-dired-extract-all)
;; Xm
(define-key map "Xm" 'cpio-dired-extract-entries)
;; Z dired-do-compress
(define-key map "Z" 'cpio-dired-do-compress)
;; ^ dired-up-directory
(define-key map "^" 'cpio-dired-up-directory)
;; a dired-find-alternate-file
(define-key map "a" 'cpio-dired-find-alternate-entry)
;; d dired-flag-file-deletion
(define-key map "d" 'cpio-dired-flag-entry-deletion) ;✓
;; g revert-buffer
;; HEREHERE This is not the way to do this.
(define-key map "g" 'revert-buffer)
;; h describe-mode
(define-key map "h" 'describe-mode)
;; i dired-maybe-insert-subdir
;; (define-key map "i" 'cpio-dired-maybe-insert-subdir) ;×
;; j dired-goto-file
(define-key map "j" 'cpio-dired-goto-entry)
;; k dired-do-kill-lines
(define-key map "k" 'cpio-dired-do-kill-lines)
;; l dired-do-redisplay
(define-key map "l" 'cpio-dired-do-redisplay)
;; m dired-mark
(define-key map "m" 'cpio-dired-mark) ;✓
;; o dired-find-file-other-window
(define-key map "o" 'cpio-dired-find-entry-other-window)
;; p dired-previous-line
;; dired-previous-line
(define-key map "[remap previous-line]" 'cpio-dired-previous-line)
(define-key map "p" 'cpio-dired-previous-line)
(define-key map "\C-p" 'cpio-dired-previous-line)
;; q quit-window
(define-key map "q" 'cpio-dired-quit-window)
;; s dired-sort-toggle-or-edit
(define-key map "s" 'cpio-dired-sort-toggle-or-edit)
;; t dired-toggle-marks
(define-key map "t" 'cpio-dired-toggle-marks)
;; u dired-unmark
;; * u
(define-key map "u" 'cpio-dired-unmark) ;✓
(define-key map "*u" 'cpio-dired-unmark) ;✓
;; v dired-view-file
(define-key map "v" 'cpio-dired-view-entry)
;; w dired-copy-filename-as-kill
(define-key map "w" 'cpio-dired-copy-entry-name-as-kill)
;; x dired-do-flagged-delete
(define-key map "x" 'cpio-dired-do-flagged-delete)
;; y dired-show-file-type
(define-key map "y" 'cpio-dired-show-entry-type)
;; ~ dired-flag-backup-files
(define-key map "~" 'cpio-dired-flag-backup-entries)
;; DEL dired-unmark-backward
(define-key map "\177" 'cpio-dired-unmark-backward)
;; S-SPC scroll-down-command
;; Not in dired.el (define-key map "\S-SPC" 'cpio-scroll-down-command)
;; mouse-face
(define-key map [follow-link] 'cpio-mouse-face)
;; dired-mouse-find-file-other-window
(define-key map "[mouse-2]" 'cpio-dired-mouse-find-entry-other-window)
;; Prefix Command
(define-key map "[remap]" nil)
;;
;; C-t C-t image-dired-dired-toggle-marked-thumbs
(define-key map "\C-t\C-t" 'cpio-image-dired-dired-toggle-marked-thumbs)
;;
;; C-t . image-dired-display-thumb
(define-key map "\C-t" 'cpio-image-dired-display-thumb)
;; C-t a image-dired-display-thumbs-append
(define-key map "\C-t" 'cpio-image-dired-display-thumbs-append)
;; C-t c image-dired-dired-comment-files
(define-key map "\C-t" 'cpio-image-dired-dired-comment-entries)
;; C-t d image-dired-display-thumbs
(define-key map "\C-t" 'cpio-image-dired-display-thumbs)
;; C-t e image-dired-dired-edit-comment-and-tags
(define-key map "\C-t" 'cpio-image-dired-dired-edit-comment-and-tags)
;; C-t f image-dired-mark-tagged-files
(define-key map "\C-t" 'cpio-image-dired-mark-tagged-entries)
;; C-t i image-dired-dired-display-image
(define-key map "\C-t" 'cpio-image-dired-dired-display-image)
;; C-t j image-dired-jump-thumbnail-buffer
(define-key map "\C-t" 'cpio-image-dired-jump-thumbnail-buffer)
;; C-t r image-dired-delete-tag
(define-key map "\C-t" 'cpio-image-dired-delete-tag)
;; C-t t image-dired-tag-files
(define-key map "\C-t" 'cpio-image-dired-tag-entries)
;; C-t x image-dired-dired-display-external
(define-key map "\C-t" 'cpio-image-dired-dired-display-external)
;;
;; C-M-d dired-tree-down
;; (define-key map "\C-M-d" 'cpio-dired-tree-down) ;×
;; C-M-n dired-next-subdir
(define-key map "\C-M-n" 'cpio-dired-next-subdir)
;; C-M-p dired-prev-subdir
(define-key map "\C-M-p" 'cpio-dired-prev-subdir)
;; C-M-u dired-tree-up
;; (define-key map "\C-M-u" 'cpio-dired-tree-up) ;×
;; M-$ dired-hide-all
(define-key map "\M-$" 'cpio-dired-hide-all)
;; M-s Prefix Command
(define-key map "\M-s" nil)
;; M-{ dired-prev-marked-file
(define-key map "\M-{" 'cpio-dired-prev-marked-entry)
;; M-} dired-next-marked-file
(define-key map "\M-}" 'cpio-dired-next-marked-entry)
;; M-DEL dired-unmark-all-files
(define-key map "\M-\177" 'cpio-dired-unmark-all-entries)
;;
;; M-s a Prefix Command
(define-key map "\M-sa" nil)
;; M-s f Prefix Command
(define-key map "\M-sf" nil)
;;
;; % & dired-flag-garbage-files
(define-key map "%&" 'cpio-dired-flag-garbage-entries)
;; % C dired-do-copy-regexp
(define-key map "%C" 'cpio-dired-do-copy-regexp)
;; % H dired-do-hardlink-regexp
(define-key map "%H" 'cpio-dired-do-hardlink-regexp)
;; % R dired-do-rename-regexp
(define-key map "%R" 'cpio-dired-do-rename-regexp)
;; % S dired-do-symlink-regexp
(define-key map "%S" 'cpio-dired-do-symlink-regexp)
;; % d dired-flag-files-regexp
(define-key map "%d" 'cpio-dired-flag-entries-regexp)
;; % g dired-mark-files-containing-regexp
(define-key map "%g" 'cpio-dired-mark-entries-containing-regexp)
;; % l dired-downcase
(define-key map "%l" 'cpio-dired-downcase)
;; % m dired-mark-files-regexp
;; * % dired-mark-files-regexp
(define-key map "%m" 'cpio-dired-mark-entries-regexp) ;✓
(define-key map "*%" 'cpio-dired-mark-entries-regexp) ;✓
;; % r dired-do-rename-regexp
(define-key map "%r" 'cpio-dired-do-rename-regexp)
;; % u dired-upcase
(define-key map "%u" 'cpio-dired-upcase)
;;
;; * C-n dired-next-marked-file
(define-key map "*\C-n" 'cpio-dired-next-marked-entry)
;; * C-p dired-prev-marked-file
(define-key map "*\C-p" 'cpio-dired-prev-marked-entry)
;; * ! dired-unmark-all-marks
;; U dired-unmark-all-marks
(define-key map "*!" 'cpio-dired-unmark-all-marks) ;✓
(define-key map "U" 'cpio-dired-unmark-all-marks) ;✓
;; * * dired-mark-executables
(define-key map "**" 'cpio-dired-mark-executables)
;; * / dired-mark-directories
(define-key map "*/" 'cpio-dired-mark-directories)
;; * ? dired-unmark-all-files
(define-key map "*?" 'cpio-dired-unmark-all-entries)
;; * @ dired-mark-symlinks
(define-key map "*@" 'cpio-dired-mark-symlinks)
;; * c dired-change-marks
(define-key map "*c" 'cpio-dired-change-marks)
;; * m dired-mark
(define-key map "*m" 'cpio-dired-mark) ;✓
;; * s dired-mark-subdir-files
(define-key map "*s" 'cpio-dired-mark-subdir-entries)
;; * t dired-toggle-marks
(define-key map "*t" 'cpio-dired-toggle-marks)
;; * DEL dired-unmark-backward
(define-key map "*\177" 'cpio-dired-unmark-backward)
;;
;; : d epa-dired-do-decrypt
(define-key map ":d" 'cpio-epa-dired-do-decrypt)
;; : e epa-dired-do-encrypt
(define-key map ":e" 'cpio-epa-dired-do-encrypt)
;; : s epa-dired-do-sign
(define-key map ":s" 'cpio-epa-dired-do-sign)
;; : v epa-dired-do-verify
(define-key map ":v" 'cpio-epa-dired-do-verify)
;;
;; dired-undo
(define-key map "[remap advertised-undo]" 'cpio-dired-undo)
;; dired-toggle-read-only
(define-key map "[remap read-only-mode]" 'cpio-dired-toggle-read-only)
;; dired-toggle-read-only
(define-key map "[remap toggle-read-only]" 'cpio-dired-toggle-read-only)
;; dired-undo
(define-key map "[remap undo]" 'cpio-dired-undo)
;;
;; M-s f C-s dired-isearch-filenames
(define-key map (kbd "M-s f C-s") 'cpio-dired-isearch-entry-names)
;; M-s f ESC Prefix Command
(define-key map "\M-sf" nil)
;;
;; M-s a C-s dired-do-isearch
(define-key map (kbd "M-s a C-s") 'cpio-dired-do-isearch)
;; M-s a ESC Prefix Command
;;
;; M-s f C-M-s dired-isearch-filenames-regexp
(define-key map (kbd "M-s f C-M-s") 'cpio-dired-isearch-entry-names-regexp)
;;
;; M-s a C-M-s dired-do-isearch-regexp
(define-key map (kbd "M-s a C-M-s") 'cpio-dired-do-isearch-regexp)
;; C-x k -- kill the cpio-related buffers from the cpio-dired buffer.
(define-key map (kbd "C-x k") 'cpio-dired-kill) ;✓
;; C-x C-s -- save the archive form the cpio-dired-buffer.
(define-key map (kbd "C-x C-s") 'cpio-dired-save-archive) ;✓
;; (setq *cpio-have-made-keymap)
map))
(define-derived-mode cpio-dired-mode fundamental-mode "cpio-dired"
"Mode for editing cpio archives in the style of dired."
:group 'cpio
;; (add-hook 'kill-buffer-hook (lambda () (kill-buffer *cab-parent*)) "append" "local"))
(goto-char (point-min))
(cond ((re-search-forward *cpio-dired-entry-regexp* (point-max) t)
(cpio-dired-move-to-entry-name)
(make-local-variable 'revert-buffer-function)
(setq revert-buffer-function 'cpio-revert-buffer)
(set-buffer-modified-p nil)
(setq-local font-lock-defaults
'(dired-font-lock-keywords t nil nil beginning-of-line)))
(t t)))
(provide 'cpio-dired)
;;; cpio-dired.el ends here
cpio-mode-0.17.0.20211211.193556/cpio-tar.el 0000644 0001752 0001753 00000001700 13754322553 015616 0 ustar elpa elpa ;; cpio-tar.el --- Let tar-mode handle tar archives. -*- coding: utf-8 -*-
;; COPYRIGHT
;;
;; Copyright © 2019 Free Software Foundation, Inc.
;; All rights reserved.
;;
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see .
;;
;;; Tar archives are already handled by tar-mode.
(error "Detection of tar archives should invoke tar-mode.")
;;; cpio-tar.el ends here.
cpio-mode-0.17.0.20211211.193556/cpio-entry-contents-mode.el 0000644 0001752 0001753 00000022161 13754322553 020752 0 ustar elpa elpa ;;; cpio-entry-contents-mode.el --- minor mode for editing a cpio-entry's contents. -*- coding: utf-8 -*-
;; COPYRIGHT
;;
;; Copyright © 2019 Free Software Foundation, Inc.
;; All rights reserved.
;;
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see .
;; Author: Douglas Lewan
;; Maintainer: Douglas Lewan
;; Created: 2017 Dec 06
;; yVersion: 0.17
;; Keywords: files
;;; Commentary:
;; This file contains code for editing and saving
;; the contents of entries in a cpio-archive.
;;; Documentation:
;;; Code:
;;
;; Hacks
;;
(defun entry-setup (arg &optional name depth)
"Set up buffers and windows for working on entry NAME.
If NAME is not given, then use 'aa'."
(interactive "P")
(if (and (called-interactively-p 'interactive)
arg)
(setq name (read-string "Name? ")))
(unless name (setq name "aa"))
(unless depth (setq depth 0))
(let* ((fname "entry-setup")
(short-archive-name "alphabet_small.crc.cpio")
(archive-name (if (string-match "alphabet/" default-directory)
(concat default-directory short-archive-name)
(concat default-directory "test_data/alphabet/" short-archive-name)))
(cpio-archive-buffer)
(cpio-dired-buffer)
(cpio-entry-contents-buffer)
(cpio-dired-contents-mode-buffer))
;; Make sure we have a clean copy of the archive.
(with-current-buffer (find-file-noselect archive-name)
(shell-command "make crc" nil nil)
(kill-buffer))
(with-current-buffer (setq cpio-archive-buffer (find-file-noselect archive-name))
(cpio-mode)
(setq cpio-dired-buffer (current-buffer)))
(unless (with-current-buffer cpio-archive-buffer (cpio-entry-exists-p name))
(if (> depth 1)
(error "%s(): Going too deep." fname)
(entry-setup nil name (1+ depth)))
(setq cpio-dired-buffer (current-buffer)))
;; Get the entry
(switch-to-buffer cpio-dired-buffer)
(cpio-dired-goto-entry name)
(cpio-dired-find-entry)
(setq cpio-entry-contents-buffer (current-buffer))
(switch-to-buffer cpio-dired-buffer)
;; Set up windows.
(delete-other-windows)
(split-window-right)
(split-window)
(other-window 1)
(switch-to-buffer cpio-archive-buffer)
(other-window 1)
(split-window)
(switch-to-buffer cpio-entry-contents-buffer)
(other-window 1)
(setq cpio-dired-contents-mode-buffer (switch-to-buffer "cpio-entry-contents-mode.el"))
(other-window 2)))
;;
;; Dependencies
;;
;;;;;;;;;;;;;;;;
;; Things to make the byte compiler happy.
(defvar cpio-entry-name)
(defvar *cpio-catalog-entry-contents-start-idx*)
(declare-function cpio-contents-start "cpio-mode.el")
(declare-function cpio-delete-archive-entry "cpio-mode.el")
(declare-function cpio-dired-find-entry "cpio-dired.el")
(declare-function cpio-dired-goto-entry "cpio-dired.el")
(declare-function cpio-entry "cpio-mode.el")
(declare-function cpio-entry-attrs "cpio-mode.el")
(declare-function cpio-entry-exists-p "cpio-mode.el")
(declare-function cpio-entry-header-start "cpio-mode.el")
(declare-function cpio-insert-padded-contents "cpio-mode.el")
(declare-function cpio-make-header-string "cpio-mode.el")
(declare-function cpio-mode "cpio-mode.el")
(declare-function cpio-present-ala-dired "cpio-dired.el")
(declare-function cpio-set-entry-modified "cpio-mode.el")
(declare-function cpio-set-entry-size "cpio-mode.el")
(declare-function cpio-entry-exists-p "cpio-mode.el")
(declare-function cpio-dired-goto-entry "cpio-dired.el")
(declare-function cpio-dired-find-entry "cpio-dired.el")
;; EO things for the byte compiler.
;;;;;;;;;;;;;;;;
;;
;; Vars
;;
;;
;; Library
;;
;;
;; Commands
;;
(defun cpio-entry-contents-save ()
"Save the contents of the current buffer in it's cpio archive."
(interactive)
(let ((fname "cpio-entry-contents-save")
(name cpio-entry-name)
(entry (cpio-entry cpio-entry-name))
(attrs (cpio-entry-attrs cpio-entry-name))
(header-string)
(size (buffer-size))
(new-contents (buffer-string))
(dired-buffer-name))
(unless (cpio-entry-contents-buffer-p)
(error "%s(): You're not in a cpio entry contents buffer." fname))
(with-current-buffer *cab-parent*
;; 1. Delete the entry's head and contents (plus padding) in the parent buffer.
(cpio-delete-archive-entry entry)
;; 2. Update the entry size in the entry.
(cpio-set-entry-size attrs size)
;; 3. Write the new contents in the archive buffer (plus padding).
(goto-char (cpio-contents-start name))
(cpio-insert-padded-contents new-contents)
;; 4. Build the entry header.
(setq header-string (cpio-make-header-string attrs))
;; 5. Write the header in the archive buffer (plus padding).
(goto-char (cpio-entry-header-start entry))
(with-writable-buffer
(insert header-string))
(aset entry *cpio-catalog-entry-contents-start-idx* (point-marker))
(setq dired-buffer-name (cpio-dired-buffer-name (buffer-file-name))))
;; 6. Mark the contents buffer as unmodified.
(set-buffer-modified-p nil)
;; 6a. But mark the entry in the archive modified.
(cpio-set-entry-modified entry)
;; 7. Update the dired-like interface.
(with-current-buffer dired-buffer-name
(save-excursion
(cpio-dired-goto-entry name)
(with-writable-buffer
(delete-region (line-beginning-position) (line-end-position))
(insert (cpio-dired-format-entry attrs)))))
(message "Saved into cpio archive buffer `%s'. Be sure to save that buffer!"
(file-name-nondirectory (buffer-file-name *cab-parent*)))))
(defun cpio-entry-contents-buffer-p ()
"Return non-NIL if the current buffer is an entry contents buffer."
(let ((fname "cpio-entry-contents-buffer-p"))
(member 'cpio-entry-contents-mode (current-minor-modes))))
(defun cpio-entry-contents-kill (&optional buffer-or-name)
"Kill the buffer specified by BUFFER-OR-NAME.
A name denotes the name of an entry in the cpio archive."
(interactive "P")
(unless buffer-or-name (setq buffer-or-name (current-buffer)))
(let ((fname "cpio-entry-contents-kill")
(buffer (if (bufferp buffer-or-name)
buffer-or-name
(get-buffer-create buffer-or-name))))
(if (and (buffer-modified-p buffer)
(yes-or-no-p "Buffer is modified. Really kill? "))
(kill-buffer buffer))))
(defun cpio-entry-contents-revert-buffer ()
"Discard any changes to the current CPIO archive entry and
reload the [current] entry contents."
(interactive)
(let ((fname "cpio-entry-contents-revert-buffer"))
(unless (cpio-entry-contents-buffer-p)
(error "%s(): You're not in an entry contetnts buffer." fname))
(with-writable-buffer
(erase-buffer)
(cpio-find-entry cpio-entry-name)
(set-auto-mode 'keep-mode-if-same))))
;;
;; Mode definition
;;
(defvar *cpio-entry-contents-mode-map* (make-sparse-keymap)
"Keymap for cpio-entry-contents-mode.")
(setq *cpio-entry-contents-mode-map* (make-sparse-keymap))
(defun cpio-entry-contents-make-keymap ()
"Define the keys that cpio-entry-contents-mode must override."
(let ((fname "cpio-entry-contents-make-keymap"))
(define-key *cpio-entry-contents-mode-map* "\C-x\C-s" 'cpio-entry-contents-save)
(define-key *cpio-entry-contents-mode-map* "\C-x\C-k" 'cpio-entry-contents-kill)
;; HEREHERE Does the following make sense any more?
(define-key *cpio-entry-contents-mode-map* "\M-," 'cpio-tags-loop-continue)))
(define-minor-mode cpio-entry-contents-mode
"Minor mode for working with an entry's contents from a cpio archive.
This mode is automatically invoked when the contents of a cpio entry are
prepared for editing."
nil
" entry contents"
:keymap *cpio-entry-contents-mode-map*
:global nil
:lighter "(cpio entry)"
;; Major modes kill local variables.
;; Keep the ones we need for cpio entry contents.
(let ((cab-parent *cab-parent*)
(entry-name cpio-entry-name)
(attrs (cpio-entry-attrs cpio-entry-name))
(local-buffer-file-name buffer-file-name))
;; For some reason (decode-coding-region) seems to need a writable buffer.
;; (with-writable-buffer
;; (decode-coding-region (cpio-entry-contents-start (cpio-entry entry-name))
;; (cpio-entry-contents-end (cpio-entry entry-name))
;; nil)))
;; (point-min) (point-max) nil)
;; (set-buffer-file-coding-system last-coding-system-used t)
;; (normal-mode)
(set-auto-mode 'keep-mode-if-same)
(setq *cab-parent* cab-parent)
(setq cpio-entry-name entry-name)
;; Why was I doing this?
;; (setq buffer-file-name local-buffer-file-name)
(setq cpio-entry-contents-mode t)))
(cpio-entry-contents-make-keymap)
(provide 'cpio-entry-contents-mode)
;;; cpio-entry-contents-mode.el ends here
cpio-mode-0.17.0.20211211.193556/README 0000644 0001752 0001753 00000016546 13712322372 014445 0 ustar elpa elpa # -*- mode: org; encoding: utf-8 -*-
# $Id: README,v 1.14 2019/01/07 07:44:34 doug Exp $
#
# Copyright © 2019 Free Software Foundation, Inc.
# All rights reserved.
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program. If not, see .
#
* Caveat
This is currenty beta code.
Please don't do anything critical with it.
That said, the current version /does/ create a backup
of every archive that it is applied to.
It is your responsibility to remove those archives.
They are marked with a date time stamp in the form YYYYmmddHHMMSS.mmm.
* Intent
The intents of cpio-mode are the following:
• It should be as much like dired as possible.¹
(The current keymap effectively duplicated dired's.)
• It should be easy to add new archive formats to it.
That is, in particular, it should admit, for any inode-like archive format,
an absract interface that leaves the the UI intact
and independent of the underlying format.
This should, for example, allow
for converting between and among archive formats nearly trivially.
It should also allow for dired-like functions.
Specifically, those things that dired within emacs allows.
That includes things like
• Adding/deleting entries
• Editing entries
• Changing an entry's attributes (chown, chgrp, chmod, etc.).
Note that, if you can write the archive,
then all those operations will succeed in the archive.
And they will be carried in the saved archive.
They may, however, not apply to files extracted from the archive
if you do not have sufficient permissions to perform those operations
on the corresponding files.
chown(1), for example, may require that you be root.
________________
¹Yes, this is a terrible requirement.
However, it does allow for incremental development relatively easily.
* Adding a new archive type
To add a new archive type a devloper should be able to do so
merely by being able to parse an entry and
write a parsed entry back to a file.
Right now (2018 Jun 09), the cpio-mode package supports the above
for the bin, crc, newc and odc formats of cpio archives.²
However, the internal structure of cpio-mode implements
all of the manipulation code in terms of parsed headers
(which look much like inodes), so adding new formats should be
relatively easy.
See the documentation in cpio-mode.el
for a slightly more detailed description of this structure.
You should be able to add a new format if
1. it has entry headers that have an inode-like format;
2. the end of a [padded] entry header is the start of the entry contents.
If you need to extend the inode-like format (for example the crc format),
then you can simply add the extensions to the attributes
of the entries in the catalog.
This will likely require updating the various build-catalog functions
and the make-header-string functions.
________________
² For archives without device entries, this means
that hpbin and hpodc are also supported.
* Other code
Some more generic code is delivered with cpio-mode.
** cpio-generic.el
This file contains truly generic lisp code.
For the most part, it employs the prefix cg-
to keep its names distinct.
Some names begin cpio-.
** cpio-modes.el
This file contains generic code pertaining to file modes,
both numeric and symbolic.
Constants corresponding to mode bits are named with lispish versions
of the names given in /usr/include/linux/stat.h.
The same goes for the predicates about a file's (entry's) type.
Otherwise, the prefix cpio- is used.
** cpio-affiliated-buffers.el
This file contains a package called Affiliated Buffers
that should be independent.
(And one day it will be published that way.)
The idea behind cpio-affiliated-buffers.el is
that there's a reference buffer and that reference buffer can have
buffers affiliated with it.
Killing the reference buffer should kill all the affiliated buffers.
An affiliated buffer can have buffers affiliated with it.
Affiliated buffers don't typically have anything to do with each other,
and cpio-affiliated-buffers.el includes no way to create such relationships.
cpio-mode uses the following sort of structure of buffer affiliation:
archive
├─ cpio-dired buffer
├─ entry
├─ entry
└─ ...
In theory it could be a full tree.
For example, if one of the entries were itself a cpio archive,
then its entries could also be included:
archive
├─ cpio-dired buffer
├─ entry
├─ an entry that is a cpio archive.
│ ├─ its cpio-dired-buffer
│ ├─ one of its entries
│ ├─ another such entry
│ └─ ...
├─ entry
└─ ...
* Testing
cpio-mode includes a few ERT tests.
All the testing is sunny day day testing.
Rarely are any error conditions tested.
** Dependencies
For any testing to succeed set your umask to 022,
otherwise all of the data in the tests are incorrect.
Since the automated tests explicitly invoke cpio-mode
as does the function (cdmt-reset),
you cannot use any automatic invocation of cpio-mode.
One way of doing this is to invoke »emacs -Q«.
(You'll also need »-eval "(setq load-path (add-to-list 'load-path \".\"))"«.
until I figure out the right way to handle loading.)
Thus, a good invocation is
»emacs -Q -eval "(setq load-path (add-to-list 'load-path \".\"))"«
Some recommendations for automatic invocation of cpio-mode can be found
in the comments near the top of cpio-mode.el.
And, of course, you must run ./configure
before trying to run automated tests.
** Internals
- cpio-generic-tests.el provides basic testing of some of the funciton
implemented in cpio-generic.el.
- cpio-modes-test.el provides basic testing of some of the function
implemented in cpio-modes.el.
- cab-test.el provides basic testing of cpio-affiliated-buffers.el.
(Yes, cpio-affiliated-buffers.el still has bugs.)
- cpio-newc-test.el provides basic testing of some of the function
implemented in cpio-newc.el.
The following files contain tests that exercise cpio function
through the dired-style interface.
* cpio-dired-bin-test.el
* cpio-dired-crc-test.el
* cpio-dired-odc-test.el
* cpio-dired-test.el -- tests of the newc format.
The general form of a check is the following:
1. Do something.
2. Compare the dired-style buffers.
3. Compare the archive buffers.
4. Compare the catalogs.
Occasionally, there are other things, like checking for modification,
or visibility of a window.
Some tests use a "large" cpio archive (one with 26·5 = 130 entries).
Those are not fast, so be patient if you're going to run them.
All dired tests are based on cpio-dired-test.el and,
yes, there's duplicated code.
Some of this should be cleaned up once development seems stable.
* Cruft
There's a fair amount of cruft in the code at the moment.
If I've done my job correctly, it is at least separate
from the main body of code (like on a different page).
Some is tools that have been built to help with development;
some is just hacks.
cpio-mode-0.17.0.20211211.193556/cpio-crc.el 0000644 0001752 0001753 00000044461 13754322553 015612 0 ustar elpa elpa ;;; cpio-crc.el --- handle crc cpio entry header formats -*- coding: utf-8 -*-
;; COPYRIGHT
;;
;; Copyright © 2019-2020 Free Software Foundation, Inc.
;; All rights reserved.
;;
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see .
;;
;; Author: Douglas Lewan
;; Maintainer: Douglas Lewan
;; Created: 2015 Jan 03
;; Version: 0.17
;; Keywords: files
;;; Commentary:
;;; Documentation:
;;; Code:
;;
;; Dependencies
;;
;; (eval-when-compile
;; (condition-case err
;; (require 'cpio-generic)
;; (error
;; (if (file-exists-p (concat default-directory "cpio-generic.elc"))
;; (load (concat default-directory "cpio-generic.elc"))
;; (load (concat default-directory "cpio-generic.el")))))
;; (condition-case err
;; (require 'cpio-newc)
;; (error
;; (if (file-exists-p (concat default-directory "cpio-newc.elc"))
;; (load (concat default-directory "cpio-newc.elc"))
;; (load (concat default-directory "cpio-newc.el"))))))
(require 'cpio-newc)
(eval-when-compile (require 'cpio-generic)) ;For `with-writable-buffer'!
;;;;;;;;;;;;;;;;
;; Things to make the byte compiler happy.
(declare-function cg-pad-right "cpio-generic.el")
(declare-function cg-round-up "cpio-generic.el")
(declare-function cpio-contents "cpio-mode.el" (entry-name &optional archive-buffer))
(declare-function cpio-entry-exists-p "cpio-mode.el" (entry-name))
(declare-function cpio-entry-name "cpio-mode.el" (attrs))
(declare-function cpio-entry-size "cpio-mode.el" (attrs))
(declare-function cpio-newc-parse-chksum "cpio-newc.el")
(declare-function cpio-newc-parse-dev-maj "cpio-newc.el")
(declare-function cpio-newc-parse-dev-min "cpio-newc.el")
(declare-function cpio-newc-parse-filesize "cpio-newc.el")
(declare-function cpio-newc-parse-gid "cpio-newc.el")
(declare-function cpio-newc-parse-ino "cpio-newc.el")
(declare-function cpio-newc-parse-mode "cpio-newc.el")
(declare-function cpio-newc-parse-mtime "cpio-newc.el")
(declare-function cpio-newc-parse-name "cpio-newc.el")
(declare-function cpio-newc-parse-namesize "cpio-newc.el")
(declare-function cpio-newc-parse-nlink "cpio-newc.el")
(declare-function cpio-newc-parse-rdev-maj "cpio-newc.el")
(declare-function cpio-newc-parse-rdev-min "cpio-newc.el")
(declare-function cpio-newc-parse-uid "cpio-newc.el")
(declare-function cpio-special-file "cpio-modes.el")
(declare-function cpio-validate-catalog-entry "cpio-mode.el" (catalog-entry))
;; EO things for the byte compiler.
;;;;;;;;;;;;;;;;
;;
;; Vars
;;
(defconst *cpio-crc-header-length* (length "07070100000000000000000000000000000000000000010000000000000000000000000000000000000000000000000000000B00000000")
"The length of a crc header.")
;; MAINTENANCE The following must remain in synch with *cpio-newc-header-re*.
(defconst *cpio-crc-magic-re* "070702"
"RE to match the magic number of a newc archive.")
(setq *cpio-crc-magic-re* "070702")
(defconst *cpio-crc-ino-re* *cpio-newc-ino-re*)
(defconst *cpio-crc-mode-re* *cpio-newc-mode-re*)
(defconst *cpio-crc-uid-re* *cpio-newc-uid-re*)
(defconst *cpio-crc-gid-re* *cpio-newc-gid-re*)
(defconst *cpio-crc-nlink-re* *cpio-newc-nlink-re*)
(defconst *cpio-crc-mtime-re* *cpio-newc-mtime-re*)
(defconst *cpio-crc-filesize-re* *cpio-newc-filesize-re*)
(defconst *cpio-crc-dev-maj-re* *cpio-newc-dev-maj-re*)
(defconst *cpio-crc-dev-min-re* *cpio-newc-dev-min-re*)
(defconst *cpio-crc-rdev-maj-re* *cpio-newc-rdev-maj-re*)
(defconst *cpio-crc-rdev-min-re* *cpio-newc-rdev-min-re*)
(defconst *cpio-crc-rdev-min-re* *cpio-newc-rdev-min-re*)
(defconst *cpio-crc-namesize-re* *cpio-newc-namesize-re*)
(defconst *cpio-crc-chksum-re* *cpio-newc-chksum-re*)
(defconst *cpio-crc-filename-re* *cpio-newc-filename-re*)
(defconst *cpio-crc-header-re* ()
"RE to match crc header format cpio archives.")
(setq *cpio-crc-header-re* (concat "\\(" *cpio-crc-magic-re* "\\)"
"\\(" *cpio-crc-ino-re* "\\)"
"\\(" *cpio-crc-mode-re* "\\)"
"\\(" *cpio-crc-uid-re* "\\)"
"\\(" *cpio-crc-gid-re* "\\)"
"\\(" *cpio-crc-nlink-re* "\\)"
"\\(" *cpio-crc-mtime-re* "\\)"
"\\(" *cpio-crc-filesize-re* "\\)"
"\\(" *cpio-crc-dev-maj-re* "\\)"
"\\(" *cpio-crc-dev-min-re* "\\)"
"\\(" *cpio-crc-rdev-maj-re* "\\)"
"\\(" *cpio-crc-rdev-min-re* "\\)"
"\\(" *cpio-crc-namesize-re* "\\)"
"\\(" *cpio-crc-chksum-re* "\\)"
"\\(" *cpio-crc-filename-re* "\\)"
"\0"))
(defconst *cpio-crc-magic-re-idx* *cpio-newc-magic-re-idx*)
(defconst *cpio-crc-ino-re-idx* *cpio-newc-ino-re-idx*)
(defconst *cpio-crc-mode-re-idx* *cpio-newc-mode-re-idx*)
(defconst *cpio-crc-uid-re-idx* *cpio-newc-uid-re-idx*)
(defconst *cpio-crc-gid-re-idx* *cpio-newc-gid-re-idx*)
(defconst *cpio-crc-nlink-re-idx* *cpio-newc-nlink-re-idx*)
(defconst *cpio-crc-mtime-re-idx* *cpio-newc-mtime-re-idx*)
(defconst *cpio-crc-filesize-re-idx* *cpio-newc-filesize-re-idx*)
(defconst *cpio-crc-dev-maj-re-idx* *cpio-newc-dev-maj-re-idx*)
(defconst *cpio-crc-dev-min-re-idx* *cpio-newc-dev-min-re-idx*)
(defconst *cpio-crc-rdev-maj-re-idx* *cpio-newc-rdev-maj-re-idx*)
(defconst *cpio-crc-rdev-min-re-idx* *cpio-newc-rdev-min-re-idx*)
(defconst *cpio-crc-namesize-re-idx* *cpio-newc-namesize-re-idx*)
(defconst *cpio-crc-chksum-re-idx* *cpio-newc-chksum-re-idx*)
(defconst *cpio-crc-filename-re-idx* *cpio-newc-filename-re-idx*)
;;
;; EO newc header variables.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defconst *cpio-crc-field-width* *cpio-newc-field-width*)
(defconst *cpio-crc-padding-modulus* *cpio-newc-padding-modulus*)
(defconst *cpio-crc-padding-char* *cpio-newc-padding-char*)
(defconst *cpio-crc-padding-str* *cpio-newc-padding-str*)
(defconst *cpio-crc-magic-field-offset* *cpio-newc-magic-field-offset*)
(defconst *cpio-crc-ino-field-offset* *cpio-newc-ino-field-offset*)
(defconst *cpio-crc-mode-field-offset* *cpio-newc-mode-field-offset*)
(defconst *cpio-crc-uid-field-offset* *cpio-newc-uid-field-offset*)
(defconst *cpio-crc-gid-field-offset* *cpio-newc-gid-field-offset*)
(defconst *cpio-crc-nlink-field-offset* *cpio-newc-nlink-field-offset*)
(defconst *cpio-crc-mtime-field-offset* *cpio-newc-mtime-field-offset*)
(defconst *cpio-crc-filesize-field-offset* *cpio-newc-filesize-field-offset*)
(defconst *cpio-crc-dev-maj-field-offset* *cpio-newc-dev-maj-field-offset*)
(defconst *cpio-crc-dev-min-field-offset* *cpio-newc-dev-min-field-offset*)
(defconst *cpio-crc-rdev-maj-field-offset* *cpio-newc-rdev-maj-field-offset*)
(defconst *cpio-crc-rdev-min-field-offset* *cpio-newc-rdev-min-field-offset*)
(defconst *cpio-crc-namesize-field-offset* *cpio-newc-namesize-field-offset*)
(defconst *cpio-crc-chksum-field-offset* *cpio-newc-chksum-field-offset*)
(defconst *cpio-crc-name-field-offset* *cpio-newc-name-field-offset*)
(defconst *cpio-crc-trailer* "07070200000000000000000000000000000000000000010000000000000000000000000000000000000000000000000000000B00000000TRAILER!!!\0\0\0\0"
"The TRAILER string for a newc archive.")
(defcustom *cpio-crc-blocksize* *cpio-newc-blocksize*
"The default block size for this cpio archive.
Taken from cpio-2.12/src/global.c."
:type 'integer
:group 'cpio)
;;
;; Library
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Functions for working with a cpio newc header
;;
(defun cpio-newc-header-at-point (&optional where)
"Return the header string at or following point WHERE.
If WHERE is not given, then use point.
CAVEATS:
1. This searches for the magic number at the begining of the header;
if WHERE is inside the magic number, then the search will fail.
This works best if you are (looking-at) a header.
2. This returns the pure header;
it does not provide the filename itself."
(unless where (setq where (point)))
(let ((fname "cpio-newc-header-at-point")
(found nil))
(save-match-data
(cond ((looking-at *cpio-newc-header-re*)
(match-string-no-properties 0))
(t
(forward-char (length *cpio-newc-magic-re*))
(while (and (re-search-backward *cpio-newc-magic-re* (point-min) t)
(not (setq found (looking-at *cpio-newc-header-re*)))))
(if found
(match-string-no-properties 0)))))))
;; OBSOLETE (setq cpio-header-at-point-func 'cpio-newc-header-at-point)
;;;;;;;;;;;;;;;;
;;
;; Parsing a header
;;
(defalias 'cpio-crc-header-size 'cpio-newc-header-size)
(defalias 'cpio-crc-parse-magic 'cpio-newc-parse-magic)
(defalias 'cpio-crc-parse-ino 'cpio-newc-parse-ino)
(defalias 'cpio-crc-parse-mode 'cpio-newc-parse-mode)
(defalias 'cpio-crc-parse-uid 'cpio-newc-parse-uid)
(defalias 'cpio-crc-parse-gid 'cpio-newc-parse-gid)
(defalias 'cpio-crc-parse-nlink 'cpio-newc-parse-nlink)
(defalias 'cpio-crc-parse-mtime 'cpio-newc-parse-mtime)
(defalias 'cpio-crc-parse-filesize 'cpio-newc-parse-filesize)
(defalias 'cpio-crc-parse-dev-maj 'cpio-newc-parse-dev-maj)
(defalias 'cpio-crc-parse-dev-min 'cpio-newc-parse-dev-min)
(defalias 'cpio-crc-parse-rdev-maj 'cpio-newc-parse-rdev-maj)
(defalias 'cpio-crc-parse-rdev-min 'cpio-newc-parse-rdev-min)
(defalias 'cpio-crc-parse-namesize 'cpio-newc-parse-namesize)
(defalias 'cpio-crc-parse-chksum 'cpio-newc-parse-chksum)
(defalias 'cpio-crc-parse-name 'cpio-newc-parse-name)
(defalias 'cpio-crc-parse-chksum 'cpio-newc-parse-chksum)
(defalias 'cpio-crc-parse-contents 'cpio-newc-parse-contents)
(defun cpio-crc-parse-header (header-string)
"Return the internal entry header structure encoded in HEADER-STR.
The optional argument WHERE should be a buffer location
at the beginning of a known cpio newc header.
If WHERE is not given, then take point and hope.
This function does NOT get the contents."
(let ((fname "cpio-newc-parse-header")
(namesize)
(filesize)
(result))
;; There's an arguable level of redundancy here,
;; but the caller likely grabbed HEADER-STR
;; from the buffer and we're using the string proper.
;; This call establishes the match-data
;; that the subsequent calls will use.
(save-match-data
(string-match *cpio-newc-header-re* header-string)
(setq result
(vector (cpio-newc-parse-ino header-string)
(cpio-newc-parse-mode header-string)
(cpio-newc-parse-uid header-string)
(cpio-newc-parse-gid header-string)
(cpio-newc-parse-nlink header-string)
(cpio-newc-parse-mtime header-string)
(setq filesize (cpio-newc-parse-filesize header-string))
(cpio-newc-parse-dev-maj header-string)
(cpio-newc-parse-dev-min header-string)
(cpio-newc-parse-rdev-maj header-string)
(cpio-newc-parse-rdev-min header-string)
(setq namesize (cpio-newc-parse-namesize header-string))
(cpio-newc-parse-chksum header-string)
(cpio-newc-parse-name header-string namesize))))
(if (cpio-entry-name result)
result
nil)))
(defun cpio-crc-make-header-string (attrs &optional contents)
"Make a header string for a CRC archive based on ATTRS.
This function does NOT include the contents."
(let ((fname "cpio-crc-make-header-string")
(name (cpio-entry-name attrs))
(header-string))
(setq header-string (concat (cpio-crc-make-magic attrs)
(cpio-crc-make-ino attrs)
(cpio-crc-make-mode attrs)
(cpio-crc-make-uid attrs)
(cpio-crc-make-gid attrs)
(cpio-crc-make-nlink attrs)
(cpio-crc-make-mtime attrs)
(cpio-crc-make-filesize attrs)
(cpio-crc-make-dev-maj attrs)
(cpio-crc-make-dev-min attrs)
(cpio-crc-make-rdev-maj attrs)
(cpio-crc-make-rdev-min attrs)
(format "%08X" (1+ (length name)))
(format "%08X"
(if (cpio-special-file attrs) ;See cpio-modes.el
0
(cpio-crc-make-chksum (if contents
contents
name))))
name
"\0"))
(setq header-string (cg-pad-right header-string (cg-round-up (length header-string) *cpio-crc-padding-modulus*) "\0"))
;; Check (at least during development).
(if (string-match-p *cpio-crc-header-re* header-string)
header-string
(error "%s(): I built a bad header: [[%s]]" fname header-string))))
(defun cpio-crc-make-magic (attrs)
"Return the magic string for a CRC archive."
*cpio-crc-magic-re*)
(defalias 'cpio-crc-make-ino 'cpio-newc-make-ino)
(defalias 'cpio-crc-make-mode 'cpio-newc-make-mode)
(defalias 'cpio-crc-make-uid 'cpio-newc-make-uid)
(defalias 'cpio-crc-make-gid 'cpio-newc-make-gid)
(defalias 'cpio-crc-make-nlink 'cpio-newc-make-nlink)
(defalias 'cpio-crc-make-mtime 'cpio-newc-make-mtime)
(defalias 'cpio-crc-make-filesize 'cpio-newc-make-filesize)
(defalias 'cpio-crc-make-dev-maj 'cpio-newc-make-dev-maj)
(defalias 'cpio-crc-make-dev-min 'cpio-newc-make-dev-min)
(defalias 'cpio-crc-make-rdev-maj 'cpio-newc-make-rdev-maj)
(defalias 'cpio-crc-make-rdev-min 'cpio-newc-make-rdev-min)
(defun cpio-crc-make-chksum (entry-name-or-contents)
"Return a string value for the newc cpio entry from the file attributes ATTRS."
(let ((fname "cpio-crc-make-chksum")
(result 0)
(contents (if (cpio-entry-exists-p entry-name-or-contents)
(cpio-contents entry-name-or-contents)
entry-name-or-contents)))
;; According to the info this is only populated for crc archives.
;; It has always been 00000000 for my concrete newc examples.
;; And, indeed, it's only set in crc archives.
;; See copyout.c->writeout-defered-file() and nowhere else.
(mapc (lambda (c)
(setq result (+ result c)))
contents)
result))
;; Filename is not one of ATTRS. ∴ It doesn't get a constructor here.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Functions for whole entries
;;
(defun cpio-crc-parse-header-at-point ()
"Parse the crc cpio header that begins at point.
If there is no header there, then signal an error."
(let ((fname "cpio-crc-parse-header-at-point"))
(unless (looking-at-p *cpio-crc-header-re*)
(error "%s(): point is not looking at a crc header." fname))
(cpio-crc-parse-header (match-string-no-properties 0))))
(defun cpio-crc-goto-next-header ()
"Move the point to the beginning of the next crc cpio header.
If point is looking-at such a header, then that is the next one
and there is no movement.
\(Thus, a caller may have to make sure that point has moved.\)
This returns the a marker for point where the header is found, if one is found.
It returns NIL otherwise.
This sets match-data for the entire header and each field."
(let ((fname "cpio-crc-goto-next-header")
(header-start)
(header-string))
(cond ((re-search-forward *cpio-crc-header-re* (point-max) t)
(setq header-start (goto-char (match-beginning 0)))
(setq header-string (match-string-no-properties 0))
(cons (point-marker) header-string))
(t nil))))
(defun cpio-crc-build-catalog ()
"Build an internal structure reflecting the contents of the crc cpio archive in the current buffer.
See the variable *cpio-catalog* for more information.
CAVEAT: This respects neither narrowing nor the point."
(let ((fname "cpio-crc-build-catalog")
(header-start) ;A marker.
(header-end)
(that-header-string)
(header-info ())
(parsed-header t)
(filesize) ;A marker.
(contents-start)
(contents-end) ;NOT NEEDED?
(those-contents) ;
(catalog ()))
(widen)
(goto-char (point-min))
(while (and (setq header-info (cpio-crc-goto-next-header))
(setq header-start (car header-info))
(setq that-header-string (cdr header-info))
parsed-header)
(cond ((setq parsed-header (cpio-crc-parse-header-at-point))
(setq filesize (cpio-entry-size parsed-header))
(forward-char (length that-header-string))
(setq header-end (point))
;; A little bit of arithmetic gymnastics here
;; because cpio, being written in C, starts counting at 0, but
;; emacs' points start at 1.
(goto-char (1+ (cg-round-up (1- header-end) *cpio-crc-padding-modulus*)))
(setq contents-start (point-marker))
(set-marker-insertion-type contents-start *cg-insert-after*)
;; It feels like I really want a function for getting the contents.
;; But it's not obvious what is simpler or appropriately more general
;; than this one-liner.
;; Indeed. (setq those-contents (buffer-substring-no-properties contents-start contents-end))
(push (cons (cpio-entry-name parsed-header)
(vector
parsed-header
header-start
contents-start
'cpio-mode-entry-unmodified))
catalog)
(setq contents-end (+ contents-start filesize -1))
(goto-char contents-end))
(t t)))
(mapc (lambda (ce)
(cpio-validate-catalog-entry (cdr ce)))
catalog)
(nreverse catalog)))
(defalias 'cpio-crc-start-of-trailer 'cpio-newc-start-of-trailer)
(defalias 'cpio-crc-end-of-archive 'cpio-newc-end-of-archive)
(defun cpio-crc-adjust-trailer ()
"Replace thed current trailer in the current cpio crc archive."
(let ((fname "cpio-crc-adjust-trailer"))
(cpio-crc-delete-trailer)
(cpio-crc-insert-trailer)))
(defun cpio-crc-insert-trailer ()
"Insert a crc trailer into a cpio archive."
(let* ((fname "cpio-crc-insert-trailer")
(base-trailer *cpio-crc-trailer*)
(base-len (length base-trailer))
(len))
;; ...and insert the new trailer...
(with-writable-buffer
(insert base-trailer)
(goto-char (point-max))
;; ...with padding.
(setq len (cg-round-up (1- (point)) *cpio-crc-blocksize*))
(setq len (1+ (- len (point))))
(insert (make-string len ?\0)))))
(defalias 'cpio-crc-delete-trailer 'cpio-newc-delete-trailer)
(defun cpio-crc-make-chksum-for-file (filename)
"Return the checksum for FILENAME."
(let ((fname "cpio-newc-make-chksum-for-file"))
(with-temp-buffer
(insert-file-contents filename)
(cpio-crc-make-chksum (buffer-substring-no-properties (point-min) (point-max))))))
;;
;; Commands
;;
(provide 'cpio-crc)
;;; cpio-crc.el ends here.
cpio-mode-0.17.0.20211211.193556/README.md 0000644 0001752 0001753 00000003104 13712322372 015026 0 ustar elpa elpa # -*- encoding: utf-8 -*-
# $Id: README,v 1.1.6.2 2018/03/08 06:10:11 doug Exp $
The intents of cpio-mode are the following:
• It should be as much like dired as possible.¹
(The current keymap effectively duplicated dired's.)
• It should be easy to add new archive formats to it.
That is, in particular, it should admit, for any inode-like archive format,
an absract interface that leaves the the UI intact
and independent of the underlying format.
This should, for example, allow
for converting between and among archive formats nearly trivially.
It should also allow for dired-like functions.
Specifically, those things that dired within emacs allows.
That includes things like
• Adding/deleting entries
• Editing entries
• Changing an entry's attributes (chown, chgrp, chmod, etc.).
To add a new archive type a devloper should be able to do so
merely by being able to parse an entry and
write a parsed entry back to a file.
Right now (2018 May 11), the cpio-mode package supports the above
for the "newc" format of cpio archives.
However, the internal structure of cpio-mode implements
all of the manipulation code in terms of parsed headers
(which look much like inodes), so adding new formats should be
relatively easy.
See the documentation in cpio.el
for a slightly more detailed description of this structure.
There's also a package of Affiliated Buffers included
that should be independent.
(And one day it will be published that way.)
________________
¹Yes, this is a terrible requirement.
However, it does allow for incremental development relatively easily.
cpio-mode-0.17.0.20211211.193556/cpio-ustar.el 0000644 0001752 0001753 00000001704 13754322553 016172 0 ustar elpa elpa ;; cpio-ustar.el --- Let tar-mode handle tar archives. -*- coding: utf-8 -*-
;; COPYRIGHT
;;
;; Copyright © 2019 Free Software Foundation, Inc.
;; All rights reserved.
;;
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see .
;;
;;; Tar archives are already handled by tar-mode.
(error "Detection of tar archives should invoke tar-mode.")
;;; cpio-ustar.el ends here.
cpio-mode-0.17.0.20211211.193556/cpio-hpodc.el 0000644 0001752 0001753 00000002230 13754322553 016124 0 ustar elpa elpa ;;; cpio-hpodc.el --- handle hpodc cpio entry header formats. -*- coding: utf-8 -*-
;; COPYRIGHT
;;
;; Copyright © 2019 Free Software Foundation, Inc.
;; All rights reserved.
;;
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see .
;;
;; Author: Douglas Lewan
;; Maintainer: Douglas Lewan
;; Created: 2015 Jan 03
;; Version: 0.17
;; Keywords: files
;;; Commentary:
;;; Documentation:
;;; Code:
;;
;; Dependencies
;;
;;
;; Vars
;;
;;
;; Library
;;
;;
;; Commands
;;
(provide 'cpio-hpodc)
;;; cpio-hpodc.el ends here.
cpio-mode-0.17.0.20211211.193556/COPYING 0000644 0001752 0001753 00000104513 13712322372 014610 0 ustar elpa elpa GNU GENERAL PUBLIC LICENSE
Version 3, 29 June 2007
Copyright (C) 2007 Free Software Foundation, Inc.
Everyone is permitted to copy and distribute verbatim copies
of this license document, but changing it is not allowed.
Preamble
The GNU General Public License is a free, copyleft license for
software and other kinds of works.
The licenses for most software and other practical works are designed
to take away your freedom to share and change the works. By contrast,
the GNU General Public License is intended to guarantee your freedom to
share and change all versions of a program--to make sure it remains free
software for all its users. We, the Free Software Foundation, use the
GNU General Public License for most of our software; it applies also to
any other work released this way by its authors. You can apply it to
your programs, too.
When we speak of free software, we are referring to freedom, not
price. Our General Public Licenses are designed to make sure that you
have the freedom to distribute copies of free software (and charge for
them if you wish), that you receive source code or can get it if you
want it, that you can change the software or use pieces of it in new
free programs, and that you know you can do these things.
To protect your rights, we need to prevent others from denying you
these rights or asking you to surrender the rights. Therefore, you have
certain responsibilities if you distribute copies of the software, or if
you modify it: responsibilities to respect the freedom of others.
For example, if you distribute copies of such a program, whether
gratis or for a fee, you must pass on to the recipients the same
freedoms that you received. You must make sure that they, too, receive
or can get the source code. And you must show them these terms so they
know their rights.
Developers that use the GNU GPL protect your rights with two steps:
(1) assert copyright on the software, and (2) offer you this License
giving you legal permission to copy, distribute and/or modify it.
For the developers' and authors' protection, the GPL clearly explains
that there is no warranty for this free software. For both users' and
authors' sake, the GPL requires that modified versions be marked as
changed, so that their problems will not be attributed erroneously to
authors of previous versions.
Some devices are designed to deny users access to install or run
modified versions of the software inside them, although the manufacturer
can do so. This is fundamentally incompatible with the aim of
protecting users' freedom to change the software. The systematic
pattern of such abuse occurs in the area of products for individuals to
use, which is precisely where it is most unacceptable. Therefore, we
have designed this version of the GPL to prohibit the practice for those
products. If such problems arise substantially in other domains, we
stand ready to extend this provision to those domains in future versions
of the GPL, as needed to protect the freedom of users.
Finally, every program is threatened constantly by software patents.
States should not allow patents to restrict development and use of
software on general-purpose computers, but in those that do, we wish to
avoid the special danger that patents applied to a free program could
make it effectively proprietary. To prevent this, the GPL assures that
patents cannot be used to render the program non-free.
The precise terms and conditions for copying, distribution and
modification follow.
TERMS AND CONDITIONS
0. Definitions.
"This License" refers to version 3 of the GNU General Public License.
"Copyright" also means copyright-like laws that apply to other kinds of
works, such as semiconductor masks.
"The Program" refers to any copyrightable work licensed under this
License. Each licensee is addressed as "you". "Licensees" and
"recipients" may be individuals or organizations.
To "modify" a work means to copy from or adapt all or part of the work
in a fashion requiring copyright permission, other than the making of an
exact copy. The resulting work is called a "modified version" of the
earlier work or a work "based on" the earlier work.
A "covered work" means either the unmodified Program or a work based
on the Program.
To "propagate" a work means to do anything with it that, without
permission, would make you directly or secondarily liable for
infringement under applicable copyright law, except executing it on a
computer or modifying a private copy. Propagation includes copying,
distribution (with or without modification), making available to the
public, and in some countries other activities as well.
To "convey" a work means any kind of propagation that enables other
parties to make or receive copies. Mere interaction with a user through
a computer network, with no transfer of a copy, is not conveying.
An interactive user interface displays "Appropriate Legal Notices"
to the extent that it includes a convenient and prominently visible
feature that (1) displays an appropriate copyright notice, and (2)
tells the user that there is no warranty for the work (except to the
extent that warranties are provided), that licensees may convey the
work under this License, and how to view a copy of this License. If
the interface presents a list of user commands or options, such as a
menu, a prominent item in the list meets this criterion.
1. Source Code.
The "source code" for a work means the preferred form of the work
for making modifications to it. "Object code" means any non-source
form of a work.
A "Standard Interface" means an interface that either is an official
standard defined by a recognized standards body, or, in the case of
interfaces specified for a particular programming language, one that
is widely used among developers working in that language.
The "System Libraries" of an executable work include anything, other
than the work as a whole, that (a) is included in the normal form of
packaging a Major Component, but which is not part of that Major
Component, and (b) serves only to enable use of the work with that
Major Component, or to implement a Standard Interface for which an
implementation is available to the public in source code form. A
"Major Component", in this context, means a major essential component
(kernel, window system, and so on) of the specific operating system
(if any) on which the executable work runs, or a compiler used to
produce the work, or an object code interpreter used to run it.
The "Corresponding Source" for a work in object code form means all
the source code needed to generate, install, and (for an executable
work) run the object code and to modify the work, including scripts to
control those activities. However, it does not include the work's
System Libraries, or general-purpose tools or generally available free
programs which are used unmodified in performing those activities but
which are not part of the work. For example, Corresponding Source
includes interface definition files associated with source files for
the work, and the source code for shared libraries and dynamically
linked subprograms that the work is specifically designed to require,
such as by intimate data communication or control flow between those
subprograms and other parts of the work.
The Corresponding Source need not include anything that users
can regenerate automatically from other parts of the Corresponding
Source.
The Corresponding Source for a work in source code form is that
same work.
2. Basic Permissions.
All rights granted under this License are granted for the term of
copyright on the Program, and are irrevocable provided the stated
conditions are met. This License explicitly affirms your unlimited
permission to run the unmodified Program. The output from running a
covered work is covered by this License only if the output, given its
content, constitutes a covered work. This License acknowledges your
rights of fair use or other equivalent, as provided by copyright law.
You may make, run and propagate covered works that you do not
convey, without conditions so long as your license otherwise remains
in force. You may convey covered works to others for the sole purpose
of having them make modifications exclusively for you, or provide you
with facilities for running those works, provided that you comply with
the terms of this License in conveying all material for which you do
not control copyright. Those thus making or running the covered works
for you must do so exclusively on your behalf, under your direction
and control, on terms that prohibit them from making any copies of
your copyrighted material outside their relationship with you.
Conveying under any other circumstances is permitted solely under
the conditions stated below. Sublicensing is not allowed; section 10
makes it unnecessary.
3. Protecting Users' Legal Rights From Anti-Circumvention Law.
No covered work shall be deemed part of an effective technological
measure under any applicable law fulfilling obligations under article
11 of the WIPO copyright treaty adopted on 20 December 1996, or
similar laws prohibiting or restricting circumvention of such
measures.
When you convey a covered work, you waive any legal power to forbid
circumvention of technological measures to the extent such circumvention
is effected by exercising rights under this License with respect to
the covered work, and you disclaim any intention to limit operation or
modification of the work as a means of enforcing, against the work's
users, your or third parties' legal rights to forbid circumvention of
technological measures.
4. Conveying Verbatim Copies.
You may convey verbatim copies of the Program's source code as you
receive it, in any medium, provided that you conspicuously and
appropriately publish on each copy an appropriate copyright notice;
keep intact all notices stating that this License and any
non-permissive terms added in accord with section 7 apply to the code;
keep intact all notices of the absence of any warranty; and give all
recipients a copy of this License along with the Program.
You may charge any price or no price for each copy that you convey,
and you may offer support or warranty protection for a fee.
5. Conveying Modified Source Versions.
You may convey a work based on the Program, or the modifications to
produce it from the Program, in the form of source code under the
terms of section 4, provided that you also meet all of these conditions:
a) The work must carry prominent notices stating that you modified
it, and giving a relevant date.
b) The work must carry prominent notices stating that it is
released under this License and any conditions added under section
7. This requirement modifies the requirement in section 4 to
"keep intact all notices".
c) You must license the entire work, as a whole, under this
License to anyone who comes into possession of a copy. This
License will therefore apply, along with any applicable section 7
additional terms, to the whole of the work, and all its parts,
regardless of how they are packaged. This License gives no
permission to license the work in any other way, but it does not
invalidate such permission if you have separately received it.
d) If the work has interactive user interfaces, each must display
Appropriate Legal Notices; however, if the Program has interactive
interfaces that do not display Appropriate Legal Notices, your
work need not make them do so.
A compilation of a covered work with other separate and independent
works, which are not by their nature extensions of the covered work,
and which are not combined with it such as to form a larger program,
in or on a volume of a storage or distribution medium, is called an
"aggregate" if the compilation and its resulting copyright are not
used to limit the access or legal rights of the compilation's users
beyond what the individual works permit. Inclusion of a covered work
in an aggregate does not cause this License to apply to the other
parts of the aggregate.
6. Conveying Non-Source Forms.
You may convey a covered work in object code form under the terms
of sections 4 and 5, provided that you also convey the
machine-readable Corresponding Source under the terms of this License,
in one of these ways:
a) Convey the object code in, or embodied in, a physical product
(including a physical distribution medium), accompanied by the
Corresponding Source fixed on a durable physical medium
customarily used for software interchange.
b) Convey the object code in, or embodied in, a physical product
(including a physical distribution medium), accompanied by a
written offer, valid for at least three years and valid for as
long as you offer spare parts or customer support for that product
model, to give anyone who possesses the object code either (1) a
copy of the Corresponding Source for all the software in the
product that is covered by this License, on a durable physical
medium customarily used for software interchange, for a price no
more than your reasonable cost of physically performing this
conveying of source, or (2) access to copy the
Corresponding Source from a network server at no charge.
c) Convey individual copies of the object code with a copy of the
written offer to provide the Corresponding Source. This
alternative is allowed only occasionally and noncommercially, and
only if you received the object code with such an offer, in accord
with subsection 6b.
d) Convey the object code by offering access from a designated
place (gratis or for a charge), and offer equivalent access to the
Corresponding Source in the same way through the same place at no
further charge. You need not require recipients to copy the
Corresponding Source along with the object code. If the place to
copy the object code is a network server, the Corresponding Source
may be on a different server (operated by you or a third party)
that supports equivalent copying facilities, provided you maintain
clear directions next to the object code saying where to find the
Corresponding Source. Regardless of what server hosts the
Corresponding Source, you remain obligated to ensure that it is
available for as long as needed to satisfy these requirements.
e) Convey the object code using peer-to-peer transmission, provided
you inform other peers where the object code and Corresponding
Source of the work are being offered to the general public at no
charge under subsection 6d.
A separable portion of the object code, whose source code is excluded
from the Corresponding Source as a System Library, need not be
included in conveying the object code work.
A "User Product" is either (1) a "consumer product", which means any
tangible personal property which is normally used for personal, family,
or household purposes, or (2) anything designed or sold for incorporation
into a dwelling. In determining whether a product is a consumer product,
doubtful cases shall be resolved in favor of coverage. For a particular
product received by a particular user, "normally used" refers to a
typical or common use of that class of product, regardless of the status
of the particular user or of the way in which the particular user
actually uses, or expects or is expected to use, the product. A product
is a consumer product regardless of whether the product has substantial
commercial, industrial or non-consumer uses, unless such uses represent
the only significant mode of use of the product.
"Installation Information" for a User Product means any methods,
procedures, authorization keys, or other information required to install
and execute modified versions of a covered work in that User Product from
a modified version of its Corresponding Source. The information must
suffice to ensure that the continued functioning of the modified object
code is in no case prevented or interfered with solely because
modification has been made.
If you convey an object code work under this section in, or with, or
specifically for use in, a User Product, and the conveying occurs as
part of a transaction in which the right of possession and use of the
User Product is transferred to the recipient in perpetuity or for a
fixed term (regardless of how the transaction is characterized), the
Corresponding Source conveyed under this section must be accompanied
by the Installation Information. But this requirement does not apply
if neither you nor any third party retains the ability to install
modified object code on the User Product (for example, the work has
been installed in ROM).
The requirement to provide Installation Information does not include a
requirement to continue to provide support service, warranty, or updates
for a work that has been modified or installed by the recipient, or for
the User Product in which it has been modified or installed. Access to a
network may be denied when the modification itself materially and
adversely affects the operation of the network or violates the rules and
protocols for communication across the network.
Corresponding Source conveyed, and Installation Information provided,
in accord with this section must be in a format that is publicly
documented (and with an implementation available to the public in
source code form), and must require no special password or key for
unpacking, reading or copying.
7. Additional Terms.
"Additional permissions" are terms that supplement the terms of this
License by making exceptions from one or more of its conditions.
Additional permissions that are applicable to the entire Program shall
be treated as though they were included in this License, to the extent
that they are valid under applicable law. If additional permissions
apply only to part of the Program, that part may be used separately
under those permissions, but the entire Program remains governed by
this License without regard to the additional permissions.
When you convey a copy of a covered work, you may at your option
remove any additional permissions from that copy, or from any part of
it. (Additional permissions may be written to require their own
removal in certain cases when you modify the work.) You may place
additional permissions on material, added by you to a covered work,
for which you have or can give appropriate copyright permission.
Notwithstanding any other provision of this License, for material you
add to a covered work, you may (if authorized by the copyright holders of
that material) supplement the terms of this License with terms:
a) Disclaiming warranty or limiting liability differently from the
terms of sections 15 and 16 of this License; or
b) Requiring preservation of specified reasonable legal notices or
author attributions in that material or in the Appropriate Legal
Notices displayed by works containing it; or
c) Prohibiting misrepresentation of the origin of that material, or
requiring that modified versions of such material be marked in
reasonable ways as different from the original version; or
d) Limiting the use for publicity purposes of names of licensors or
authors of the material; or
e) Declining to grant rights under trademark law for use of some
trade names, trademarks, or service marks; or
f) Requiring indemnification of licensors and authors of that
material by anyone who conveys the material (or modified versions of
it) with contractual assumptions of liability to the recipient, for
any liability that these contractual assumptions directly impose on
those licensors and authors.
All other non-permissive additional terms are considered "further
restrictions" within the meaning of section 10. If the Program as you
received it, or any part of it, contains a notice stating that it is
governed by this License along with a term that is a further
restriction, you may remove that term. If a license document contains
a further restriction but permits relicensing or conveying under this
License, you may add to a covered work material governed by the terms
of that license document, provided that the further restriction does
not survive such relicensing or conveying.
If you add terms to a covered work in accord with this section, you
must place, in the relevant source files, a statement of the
additional terms that apply to those files, or a notice indicating
where to find the applicable terms.
Additional terms, permissive or non-permissive, may be stated in the
form of a separately written license, or stated as exceptions;
the above requirements apply either way.
8. Termination.
You may not propagate or modify a covered work except as expressly
provided under this License. Any attempt otherwise to propagate or
modify it is void, and will automatically terminate your rights under
this License (including any patent licenses granted under the third
paragraph of section 11).
However, if you cease all violation of this License, then your
license from a particular copyright holder is reinstated (a)
provisionally, unless and until the copyright holder explicitly and
finally terminates your license, and (b) permanently, if the copyright
holder fails to notify you of the violation by some reasonable means
prior to 60 days after the cessation.
Moreover, your license from a particular copyright holder is
reinstated permanently if the copyright holder notifies you of the
violation by some reasonable means, this is the first time you have
received notice of violation of this License (for any work) from that
copyright holder, and you cure the violation prior to 30 days after
your receipt of the notice.
Termination of your rights under this section does not terminate the
licenses of parties who have received copies or rights from you under
this License. If your rights have been terminated and not permanently
reinstated, you do not qualify to receive new licenses for the same
material under section 10.
9. Acceptance Not Required for Having Copies.
You are not required to accept this License in order to receive or
run a copy of the Program. Ancillary propagation of a covered work
occurring solely as a consequence of using peer-to-peer transmission
to receive a copy likewise does not require acceptance. However,
nothing other than this License grants you permission to propagate or
modify any covered work. These actions infringe copyright if you do
not accept this License. Therefore, by modifying or propagating a
covered work, you indicate your acceptance of this License to do so.
10. Automatic Licensing of Downstream Recipients.
Each time you convey a covered work, the recipient automatically
receives a license from the original licensors, to run, modify and
propagate that work, subject to this License. You are not responsible
for enforcing compliance by third parties with this License.
An "entity transaction" is a transaction transferring control of an
organization, or substantially all assets of one, or subdividing an
organization, or merging organizations. If propagation of a covered
work results from an entity transaction, each party to that
transaction who receives a copy of the work also receives whatever
licenses to the work the party's predecessor in interest had or could
give under the previous paragraph, plus a right to possession of the
Corresponding Source of the work from the predecessor in interest, if
the predecessor has it or can get it with reasonable efforts.
You may not impose any further restrictions on the exercise of the
rights granted or affirmed under this License. For example, you may
not impose a license fee, royalty, or other charge for exercise of
rights granted under this License, and you may not initiate litigation
(including a cross-claim or counterclaim in a lawsuit) alleging that
any patent claim is infringed by making, using, selling, offering for
sale, or importing the Program or any portion of it.
11. Patents.
A "contributor" is a copyright holder who authorizes use under this
License of the Program or a work on which the Program is based. The
work thus licensed is called the contributor's "contributor version".
A contributor's "essential patent claims" are all patent claims
owned or controlled by the contributor, whether already acquired or
hereafter acquired, that would be infringed by some manner, permitted
by this License, of making, using, or selling its contributor version,
but do not include claims that would be infringed only as a
consequence of further modification of the contributor version. For
purposes of this definition, "control" includes the right to grant
patent sublicenses in a manner consistent with the requirements of
this License.
Each contributor grants you a non-exclusive, worldwide, royalty-free
patent license under the contributor's essential patent claims, to
make, use, sell, offer for sale, import and otherwise run, modify and
propagate the contents of its contributor version.
In the following three paragraphs, a "patent license" is any express
agreement or commitment, however denominated, not to enforce a patent
(such as an express permission to practice a patent or covenant not to
sue for patent infringement). To "grant" such a patent license to a
party means to make such an agreement or commitment not to enforce a
patent against the party.
If you convey a covered work, knowingly relying on a patent license,
and the Corresponding Source of the work is not available for anyone
to copy, free of charge and under the terms of this License, through a
publicly available network server or other readily accessible means,
then you must either (1) cause the Corresponding Source to be so
available, or (2) arrange to deprive yourself of the benefit of the
patent license for this particular work, or (3) arrange, in a manner
consistent with the requirements of this License, to extend the patent
license to downstream recipients. "Knowingly relying" means you have
actual knowledge that, but for the patent license, your conveying the
covered work in a country, or your recipient's use of the covered work
in a country, would infringe one or more identifiable patents in that
country that you have reason to believe are valid.
If, pursuant to or in connection with a single transaction or
arrangement, you convey, or propagate by procuring conveyance of, a
covered work, and grant a patent license to some of the parties
receiving the covered work authorizing them to use, propagate, modify
or convey a specific copy of the covered work, then the patent license
you grant is automatically extended to all recipients of the covered
work and works based on it.
A patent license is "discriminatory" if it does not include within
the scope of its coverage, prohibits the exercise of, or is
conditioned on the non-exercise of one or more of the rights that are
specifically granted under this License. You may not convey a covered
work if you are a party to an arrangement with a third party that is
in the business of distributing software, under which you make payment
to the third party based on the extent of your activity of conveying
the work, and under which the third party grants, to any of the
parties who would receive the covered work from you, a discriminatory
patent license (a) in connection with copies of the covered work
conveyed by you (or copies made from those copies), or (b) primarily
for and in connection with specific products or compilations that
contain the covered work, unless you entered into that arrangement,
or that patent license was granted, prior to 28 March 2007.
Nothing in this License shall be construed as excluding or limiting
any implied license or other defenses to infringement that may
otherwise be available to you under applicable patent law.
12. No Surrender of Others' Freedom.
If conditions are imposed on you (whether by court order, agreement or
otherwise) that contradict the conditions of this License, they do not
excuse you from the conditions of this License. If you cannot convey a
covered work so as to satisfy simultaneously your obligations under this
License and any other pertinent obligations, then as a consequence you may
not convey it at all. For example, if you agree to terms that obligate you
to collect a royalty for further conveying from those to whom you convey
the Program, the only way you could satisfy both those terms and this
License would be to refrain entirely from conveying the Program.
13. Use with the GNU Affero General Public License.
Notwithstanding any other provision of this License, you have
permission to link or combine any covered work with a work licensed
under version 3 of the GNU Affero General Public License into a single
combined work, and to convey the resulting work. The terms of this
License will continue to apply to the part which is the covered work,
but the special requirements of the GNU Affero General Public License,
section 13, concerning interaction through a network will apply to the
combination as such.
14. Revised Versions of this License.
The Free Software Foundation may publish revised and/or new versions of
the GNU General Public License from time to time. Such new versions will
be similar in spirit to the present version, but may differ in detail to
address new problems or concerns.
Each version is given a distinguishing version number. If the
Program specifies that a certain numbered version of the GNU General
Public License "or any later version" applies to it, you have the
option of following the terms and conditions either of that numbered
version or of any later version published by the Free Software
Foundation. If the Program does not specify a version number of the
GNU General Public License, you may choose any version ever published
by the Free Software Foundation.
If the Program specifies that a proxy can decide which future
versions of the GNU General Public License can be used, that proxy's
public statement of acceptance of a version permanently authorizes you
to choose that version for the Program.
Later license versions may give you additional or different
permissions. However, no additional obligations are imposed on any
author or copyright holder as a result of your choosing to follow a
later version.
15. Disclaimer of Warranty.
THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY
APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT
HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY
OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,
THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM
IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF
ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
16. Limitation of Liability.
IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS
THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY
GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE
USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF
DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD
PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),
EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
SUCH DAMAGES.
17. Interpretation of Sections 15 and 16.
If the disclaimer of warranty and limitation of liability provided
above cannot be given local legal effect according to their terms,
reviewing courts shall apply local law that most closely approximates
an absolute waiver of all civil liability in connection with the
Program, unless a warranty or assumption of liability accompanies a
copy of the Program in return for a fee.
END OF TERMS AND CONDITIONS
How to Apply These Terms to Your New Programs
If you develop a new program, and you want it to be of the greatest
possible use to the public, the best way to achieve this is to make it
free software which everyone can redistribute and change under these terms.
To do so, attach the following notices to the program. It is safest
to attach them to the start of each source file to most effectively
state the exclusion of warranty; and each file should have at least
the "copyright" line and a pointer to where the full notice is found.
Copyright (C)
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program. If not, see .
Also add information on how to contact you by electronic and paper mail.
If the program does terminal interaction, make it output a short
notice like this when it starts in an interactive mode:
Copyright (C)
This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
This is free software, and you are welcome to redistribute it
under certain conditions; type `show c' for details.
The hypothetical commands `show w' and `show c' should show the appropriate
parts of the General Public License. Of course, your program's commands
might be different; for a GUI interface, you would use an "about box".
You should also get your employer (if you work as a programmer) or school,
if any, to sign a "copyright disclaimer" for the program, if necessary.
For more information on this, and how to apply and follow the GNU GPL, see
.
The GNU General Public License does not permit incorporating your program
into proprietary programs. If your program is a subroutine library, you
may consider it more useful to permit linking proprietary applications with
the library. If this is what you want to do, use the GNU Lesser General
Public License instead of this License. But first, please read
.
cpio-mode-0.17.0.20211211.193556/cpio-newc.el 0000644 0001752 0001753 00000110123 13754322553 015764 0 ustar elpa elpa ;;; cpio-newc.el --- handle portable newc cpio archives. -*- coding: utf-8 -*-
;; COPYRIGHT
;;
;; Copyright © 2019-2020 Free Software Foundation, Inc.
;; All rights reserved.
;;
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see .
;;
;; Author: Douglas Lewan
;; Maintainer: Douglas Lewan
;; Created: 2015 Jan 03
;; Version: 0.17
;; Keywords: files
;;; Commentary:
;;; Documentation:
;; Naming conventions:
;;
;; All global variables pertaining to newc-formatted cpio-archives
;; begin '*cpio-newc-...'.
;; Every FIELD in a header have corrsponding regular expressions
;; to match them named '*cpio-newc-FIELD-re*'.
;; The variable *cpio-newc-header-re* uses those regular expressions
;; to parse a newc header.
;; Every FIELD's matching substring has an index named
;; *cpio-newc-FIELD-idx*'.
;;
;; HEREHERE The following are currently UNUSED:
;; Every FIELD has a function (cpio-newc-get-FIELD)
;; that operates on a parsed header to retrieve the value of that FIELD.
;; (It's not obvious that such functions need to be here.
;; After all, a parsed header has the same structure for each format.
;;; Code:
;;
;; Dependencies
;;
(eval-when-compile (require 'cpio-generic)) ;For `with-writable-buffer'!
(require 'cl-lib)
;; (condition-case err
;; (require 'cpio-generic)
;; (error
;; (if (file-exists-p (concat default-directory "cpio-generic.elc"))
;; (load-file (concat default-directory "cpio-generic.elc"))
;; (load-file (concat default-directory "cpio-generic.el")))))
;;;;;;;;;;;;;;;;
;; Things to make the byte compiler happy.
(defvar *cpio-catalog*)
(defvar *cpio-padding-modulus*)
(declare-function cpio-entry-name "cpio-mode.el")
(declare-function cpio-ino "cpio-mode.el")
(declare-function cpio-mode-value "cpio-mode.el")
(declare-function cpio-uid "cpio-mode.el")
(declare-function cpio-gid "cpio-mode.el")
(declare-function cpio-nlink "cpio-mode.el")
(declare-function cpio-mtime "cpio-mode.el")
(declare-function cpio-entry-size "cpio-mode.el")
(declare-function cpio-dev-maj "cpio-mode.el")
(declare-function cpio-dev-min "cpio-mode.el")
(declare-function cpio-entry-attrs-from-catalog-entry "cpio-mode.el")
(declare-function cpio-contents-start "cpio-mode.el")
(declare-function cpio-entry-attrs "cpio-mode.el")
;; EO things for the byte compiler.
;;;;;;;;;;;;;;;;
;;
;; Vars
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; newc header format vars
;;
(defconst *cpio-newc-header-length* (length "07070100000000000000000000000000000000000000010000000000000000000000000000000000000000000000000000000B00000000")
"The length of a newc header.")
;; MAINTENANCE The following must remain in synch with *cpio-newc-header-re*.
(defconst *cpio-newc-magic-re* "070701"
"RE to match the magic number of a newc archive.")
(setq *cpio-newc-magic-re* "070701")
(defconst *cpio-newc-ino-re* "[[:xdigit:]]\\{8\\}"
"RE to match the c_ino field in a newc header.")
(setq *cpio-newc-ino-re* "[[:xdigit:]]\\{8\\}")
(defconst *cpio-newc-mode-re* "[[:xdigit:]]\\{8\\}"
"RE to match the c_mode field in a newc header.")
(setq *cpio-newc-mode-re* "[[:xdigit:]]\\{8\\}")
(defconst *cpio-newc-uid-re* "[[:xdigit:]]\\{8\\}"
"RE to match the c_uid field in a newc header.")
(setq *cpio-newc-uid-re* "[[:xdigit:]]\\{8\\}")
(defconst *cpio-newc-gid-re* "[[:xdigit:]]\\{8\\}"
"RE to match the c_gid field in a newc header.")
(setq *cpio-newc-gid-re* "[[:xdigit:]]\\{8\\}")
(defconst *cpio-newc-nlink-re* "[[:xdigit:]]\\{8\\}"
"RE to match the c_nlink field in a newc header.")
(setq *cpio-newc-nlink-re* "[[:xdigit:]]\\{8\\}")
(defconst *cpio-newc-mtime-re* "[[:xdigit:]]\\{8\\}"
"RE to match the c_mtime field in a newc header.")
(setq *cpio-newc-mtime-re* "[[:xdigit:]]\\{8\\}")
(defconst *cpio-newc-filesize-re* "[[:xdigit:]]\\{8\\}"
"RE to match the c_filesize field in a newc header.")
(setq *cpio-newc-filesize-re* "[[:xdigit:]]\\{8\\}")
(defconst *cpio-newc-dev-maj-re* "[[:xdigit:]]\\{8\\}"
"RE to match the c_dev field in a newc header.")
(setq *cpio-newc-dev-maj-re* "[[:xdigit:]]\\{8\\}")
(defconst *cpio-newc-dev-min-re* "[[:xdigit:]]\\{8\\}"
"RE to match the c_dev field in a newc header.")
(setq *cpio-newc-dev-min-re* "[[:xdigit:]]\\{8\\}")
(defconst *cpio-newc-rdev-maj-re* "[[:xdigit:]]\\{8\\}"
"RE to match the c_rdev field in a newc header.")
(setq *cpio-newc-rdev-maj-re* "[[:xdigit:]]\\{8\\}")
(defconst *cpio-newc-rdev-min-re* "[[:xdigit:]]\\{8\\}"
"RE to match the c_rdev field in a newc header.")
(setq *cpio-newc-rdev-min-re* "[[:xdigit:]]\\{8\\}")
(defconst *cpio-newc-rdev-min-re* "[[:xdigit:]]\\{8\\}"
"RE to match the c_rdev field in a newc header.")
(setq *cpio-newc-rdev-min-re* "[[:xdigit:]]\\{8\\}")
(defconst *cpio-newc-namesize-re* "[[:xdigit:]]\\{8\\}"
"RE to match the c_namesize field in a newc header.")
(setq *cpio-newc-namesize-re* "[[:xdigit:]]\\{8\\}")
(defconst *cpio-newc-chksum-re* "[[:xdigit:]]\\{8\\}"
"RE to match the CRC checksum in a newc header.")
(setq *cpio-newc-chksum-re* "[[:xdigit:]]\\{8\\}")
(defconst *cpio-newc-filename-re* "[[:print:]]+"
"RE to match the c_filename field in a newc header.")
(setq *cpio-newc-filename-re* "[[:print:]]+")
(defconst *cpio-newc-header-re* ()
"RE to match newc header format cpio archives.")
(setq *cpio-newc-header-re* (concat "\\(" *cpio-newc-magic-re* "\\)"
"\\(" *cpio-newc-ino-re* "\\)"
"\\(" *cpio-newc-mode-re* "\\)"
"\\(" *cpio-newc-uid-re* "\\)"
"\\(" *cpio-newc-gid-re* "\\)"
"\\(" *cpio-newc-nlink-re* "\\)"
"\\(" *cpio-newc-mtime-re* "\\)"
"\\(" *cpio-newc-filesize-re* "\\)"
"\\(" *cpio-newc-dev-maj-re* "\\)"
"\\(" *cpio-newc-dev-min-re* "\\)"
"\\(" *cpio-newc-rdev-maj-re* "\\)"
"\\(" *cpio-newc-rdev-min-re* "\\)"
"\\(" *cpio-newc-namesize-re* "\\)"
"\\(" *cpio-newc-chksum-re* "\\)"
"\\(" *cpio-newc-filename-re* "\\)"
"\0"))
(let ((i 0))
(defconst *cpio-newc-magic-re-idx* 0 ; (setq i (1+ i))
"RE to match the magic number in a newc header.")
(setq *cpio-newc-magic-re-idx* (setq i (1+ i)))
(defconst *cpio-newc-ino-re-idx* 0 ; (setq i (1+ i))
"Index of the sub RE from *cpio-newc-header-re* to parse the inode.")
(setq *cpio-newc-ino-re-idx* (setq i (1+ i)))
(defconst *cpio-newc-mode-re-idx* 0 ; (setq i (1+ i))
"Index of the sub RE from *cpio-newc-header-re* to parse the mode.")
(setq *cpio-newc-mode-re-idx* (setq i (1+ i)))
(defconst *cpio-newc-uid-re-idx* 0 ; (setq i (1+ i))
"Index of the sub RE from *cpio-newc-header-re* to parse the UID.")
(setq *cpio-newc-uid-re-idx* (setq i (1+ i)))
(defconst *cpio-newc-gid-re-idx* 0 ; (setq i (1+ i))
"Index of the sub RE from *cpio-newc-header-re* to parse the GID.")
(setq *cpio-newc-gid-re-idx* (setq i (1+ i)))
(defconst *cpio-newc-nlink-re-idx* 0 ; (setq i (1+ i))
"Index of the sub RE from *cpio-newc-header-re* to parse the nlink.")
(setq *cpio-newc-nlink-re-idx* (setq i (1+ i)))
(defconst *cpio-newc-mtime-re-idx* 0 ; (setq i (1+ i))
"Index of the sub RE from *cpio-newc-header-re* to parse the mtime.")
(setq *cpio-newc-mtime-re-idx* (setq i (1+ i)))
(defconst *cpio-newc-filesize-re-idx* 0 ; (setq i (1+ i))
"Index of the sub RE from *cpio-newc-header-re* to parse the filesize.")
(setq *cpio-newc-filesize-re-idx* (setq i (1+ i)))
(defconst *cpio-newc-dev-maj-re-idx* 0 ; (setq i (1+ i))
"Index of the sub RE from *cpio-newc-header-re* to parse the dev.")
(setq *cpio-newc-dev-maj-re-idx* (setq i (1+ i)))
(defconst *cpio-newc-dev-min-re-idx* 0 ; (setq i (1+ i))
"Index of the sub RE from *cpio-newc-header-re* to parse the dev.")
(setq *cpio-newc-dev-min-re-idx* (setq i (1+ i)))
(defconst *cpio-newc-rdev-maj-re-idx* 0 ; (setq i (1+ i))
"Index of the sub RE from *cpio-newc-header-re* to parse the rdev.")
(setq *cpio-newc-rdev-maj-re-idx* (setq i (1+ i)))
(defconst *cpio-newc-rdev-min-re-idx* 0 ; (setq i (1+ i))
"Index of the sub RE from *cpio-newc-header-re* to parse the rdev.")
(setq *cpio-newc-rdev-min-re-idx* (setq i (1+ i)))
(defconst *cpio-newc-namesize-re-idx* 0 ; (setq i (1+ i))
"Index of the sub RE from *cpio-newc-header-re* to parse the namesize.")
(setq *cpio-newc-namesize-re-idx* (setq i (1+ i)))
(defconst *cpio-newc-chksum-re-idx* 0 ; (setq i (1+ i))
"Index of the sub RE from *cpio-newc-header-re* to parse the chksum.")
(setq *cpio-newc-chksum-re-idx* (setq i (1+ i)))
(defconst *cpio-newc-filename-re-idx* 0 ; (setq i (1+ i))
"Index of the sub RE from *cpio-newc-header-re* to parse the namesize.")
(setq *cpio-newc-filename-re-idx* (setq i (1+ i))))
;;
;; EO newc header variables.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; *cpio-newc-magic-re*
(defconst *cpio-newc-magic* *cpio-newc-magic-re*
"The string that identifies an entry as a NEWC style cpio(1) entry.")
(setq *cpio-newc-magic* *cpio-newc-magic-re*)
(defconst *cpio-newc-field-width* 8
"The width of all of the fields in a newc header.")
(setq *cpio-newc-field-width* 8)
(defconst *cpio-newc-padding-modulus* 4
"The modulus to which some things are padded in a NEWC cpio archive.")
(setq *cpio-newc-padding-modulus* 4)
(defconst *cpio-newc-padding-char* ?\0
"A character to be used for padding headers and entry contents
in a newc cpio archive.")
(setq *cpio-newc-padding-char* ?\0)
(defconst *cpio-newc-padding-str* "\0"
"A single character string of the character
to be used for padding headers and entry contents
in a newc cpio archive.")
(setq *cpio-newc-padding-str* "\0")
(let ((i 0)
(l (length *cpio-newc-magic-re*)))
(defconst *cpio-newc-magic-field-offset* i)
(setq *cpio-newc-magic-field-offset* i)
(setq i (1+ i))
(defconst *cpio-newc-ino-field-offset* (+ l (* *cpio-newc-field-width* i)))
(setq *cpio-newc-ino-field-offset* (+ l (* *cpio-newc-field-width* (1- i))))
(setq i (1+ i))
(defconst *cpio-newc-mode-field-offset* (+ l (* *cpio-newc-field-width* i)))
(setq *cpio-newc-mode-field-offset* (+ l (* *cpio-newc-field-width* (1- i))))
(setq i (1+ i))
(defconst *cpio-newc-uid-field-offset* (+ l (* *cpio-newc-field-width* i)))
(setq *cpio-newc-uid-field-offset* (+ l (* *cpio-newc-field-width* (1- i))))
(setq i (1+ i))
(defconst *cpio-newc-gid-field-offset* (+ l (* *cpio-newc-field-width* i)))
(setq *cpio-newc-gid-field-offset* (+ l (* *cpio-newc-field-width* (1- i))))
(setq i (1+ i))
(defconst *cpio-newc-nlink-field-offset* (+ l (* *cpio-newc-field-width* i)))
(setq *cpio-newc-nlink-field-offset* (+ l (* *cpio-newc-field-width* (1- i))))
(setq i (1+ i))
(defconst *cpio-newc-mtime-field-offset* (+ l (* *cpio-newc-field-width* i)))
(setq *cpio-newc-mtime-field-offset* (+ l (* *cpio-newc-field-width* (1- i))))
(setq i (1+ i))
(defconst *cpio-newc-filesize-field-offset* (+ l (* *cpio-newc-field-width* i)))
(setq *cpio-newc-filesize-field-offset* (+ l (* *cpio-newc-field-width* (1- i))))
(setq i (1+ i))
(defconst *cpio-newc-dev-maj-field-offset* (+ l (* *cpio-newc-field-width* i)))
(setq *cpio-newc-dev-maj-field-offset* (+ l (* *cpio-newc-field-width* (1- i))))
(setq i (1+ i))
(defconst *cpio-newc-dev-min-field-offset* (+ l (* *cpio-newc-field-width* i)))
(setq *cpio-newc-dev-min-field-offset* (+ l (* *cpio-newc-field-width* (1- i))))
(setq i (1+ i))
(defconst *cpio-newc-rdev-maj-field-offset* (+ l (* *cpio-newc-field-width* i)))
(setq *cpio-newc-rdev-maj-field-offset* (+ l (* *cpio-newc-field-width* (1- i))))
(setq i (1+ i))
(defconst *cpio-newc-rdev-min-field-offset* (+ l (* *cpio-newc-field-width* i)))
(setq *cpio-newc-rdev-min-field-offset* (+ l (* *cpio-newc-field-width* (1- i))))
(setq i (1+ i))
(defconst *cpio-newc-namesize-field-offset* (+ l (* *cpio-newc-field-width* i)))
(setq *cpio-newc-namesize-field-offset* (+ l (* *cpio-newc-field-width* (1- i))))
(setq i (1+ i))
(defconst *cpio-newc-chksum-field-offset* (+ l (* *cpio-newc-field-width* i)))
(setq *cpio-newc-chksum-field-offset* (+ l (* *cpio-newc-field-width* (1- i))))
(setq i (1+ i))
(defconst *cpio-newc-name-field-offset* (+ l (* *cpio-newc-field-width* i)))
(setq *cpio-newc-name-field-offset* (+ l (* *cpio-newc-field-width* (1- i)))))
(defconst *cpio-newc-trailer* "07070100000000000000000000000000000000000000010000000000000000000000000000000000000000000000000000000B00000000TRAILER!!!\0\0\0\0"
"The TRAILER string for a newc archive.")
(defcustom *cpio-newc-blocksize* 512
"The default block size for this cpio archive.
Taken from cpio-2.12/src/global.c."
:type 'integer
:group 'cpio)
;;
;; Library
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Functions for working with a cpio newc header
;;
(defun cpio-newc-header-at-point (&optional where)
"Return the header string at or following point WHERE.
If WHERE is not given, then use point.
CAVEATS:
1. This searches for the magic number at the begining of the header;
if WHERE is inside the magic number, then the search will fail.
This works best if you are (looking-at) a header.
2. This returns the pure header;
it does not provide the filename itself."
(unless where (setq where (point)))
(let ((fname "cpio-newc-header-at-point")
(found nil))
(save-match-data
(cond ((looking-at *cpio-newc-header-re*)
(match-string-no-properties 0))
(t
(forward-char (length *cpio-newc-magic-re*))
(while (and (re-search-backward *cpio-newc-magic-re* (point-min) t)
(not (setq found (looking-at *cpio-newc-header-re*)))))
(if found
(match-string-no-properties 0)))))))
;;;;;;;;;;;;;;;;
;;
;; Parsing a header
;;
(defun cpio-newc-parse-header (header-string)
"Return the internal entry header structure encoded in HEADER-STRING.
The optional argument WHERE should be a buffer location
at the beginning of a known cpio newc header.
If WHERE is not given, then take point and hope.
This function does NOT get the contents."
(let ((fname "cpio-newc-parse-header")
(namesize)
(filesize)
(result))
;; There's an arguable level of redundancy here,
;; but the caller likely grabbed HEADER-STR
;; from the buffer and we're using the string proper.
;; This call establishes the match-data
;; that the subsequent calls will use.
(save-match-data
(string-match *cpio-newc-header-re* header-string)
(setq result
(vector (cpio-newc-parse-ino header-string)
(cpio-newc-parse-mode header-string)
(cpio-newc-parse-uid header-string)
(cpio-newc-parse-gid header-string)
(cpio-newc-parse-nlink header-string)
(cpio-newc-parse-mtime header-string)
(setq filesize (cpio-newc-parse-filesize header-string))
(cpio-newc-parse-dev-maj header-string)
(cpio-newc-parse-dev-min header-string)
(cpio-newc-parse-rdev-maj header-string)
(cpio-newc-parse-rdev-min header-string)
(setq namesize (cpio-newc-parse-namesize header-string))
(cpio-newc-parse-chksum header-string)
(cpio-newc-parse-name header-string namesize))))
;; (cpio-newc-header-size header-string namesize))))
(if (cpio-entry-name result)
result
nil)))
(defun cpio-newc-header-size (header-string namesize)
"Determine the length of the header implied by the given HEADER-STRING."
(let ((fname "cpio-newc-header-size")
;; CAUTION: The following assumes that (string-to-number) doesn't care about leading zeroes.
;; The namesize in the header includes the terminating NULL at the end of the name.
(local-namesize (1- namesize))
(total -1))
(if (= 0 (mod (setq total (+ 1 *cpio-newc-name-field-offset* local-namesize))
*cpio-newc-padding-modulus*))
(setq total (1+ total)))
(cg-round-up total *cpio-newc-padding-modulus*)))
(defun cpio-newc-parse-magic (header-string)
"Get the magic field from HEADER-STRING."
(let* ((fname "cpio-newc-parse-magic")
(this-offset *cpio-newc-magic-field-offset*)
(end-offset (+ this-offset (length *cpio-newc-magic-re*))))
(substring header-string this-offset end-offset)))
(defun cpio-newc-parse-ino (header-string)
"Get the ino field from HEADER-STRING."
(let* ((fname "cpio-newc-parse-ino")
(this-offset *cpio-newc-ino-field-offset*)
(end-offset (+ this-offset *cpio-newc-field-width*)))
(string-to-number (substring header-string this-offset end-offset) 16)))
(defun cpio-newc-parse-mode (header-string)
"Get the mode field from HEADER-STRING."
(let* ((fname "cpio-newc-parse-mode")
(this-offset *cpio-newc-mode-field-offset*)
(end-offset (+ this-offset *cpio-newc-field-width*)))
(string-to-number (substring header-string this-offset end-offset)16)))
(defun cpio-newc-parse-uid (header-string)
"Get the uid field from HEADER-STRING."
(let* ((fname "cpio-newc-parse-uid")
(this-offset *cpio-newc-uid-field-offset*)
(end-offset (+ this-offset *cpio-newc-field-width*)))
(string-to-number (substring header-string this-offset end-offset) 16)))
(defun cpio-newc-parse-gid (header-string)
"Get the gid field from HEADER-STRING."
(let* ((fname "cpio-newc-parse-gid")
(this-offset *cpio-newc-gid-field-offset*)
(end-offset (+ this-offset *cpio-newc-field-width*)))
(string-to-number (substring header-string this-offset end-offset) 16)))
(defun cpio-newc-parse-nlink (header-string)
"Get the nlink field from HEADER-STRING."
(let* ((fname "cpio-newc-parse-nlink")
(this-offset *cpio-newc-nlink-field-offset*)
(end-offset (+ this-offset *cpio-newc-field-width*)))
(string-to-number (substring header-string this-offset end-offset) 16)))
(defun cpio-newc-parse-mtime (header-string)
"Get the mtime field from HEADER-STRING."
(let* ((fname "cpio-newc-parse-mtime")
(this-offset *cpio-newc-mtime-field-offset*)
(end-offset (+ this-offset *cpio-newc-field-width*))
(time-value ()))
(setq time-value (string-to-number (substring header-string this-offset end-offset) 16))
(setq time-value (list (lsh (logand #xFFFF0000 time-value) -16) (logand #xFFFF)))))
(defun cpio-newc-parse-filesize (header-string)
"Get the filesize from the HEADER-STRING."
(let* ((fname "cpio-newc-parse-filesize")
(this-offset *cpio-newc-filesize-field-offset*)
(end-offset (+ this-offset *cpio-newc-field-width*)))
(string-to-number (substring header-string this-offset end-offset) 16)))
(defun cpio-newc-parse-dev-maj (header-string)
"Get the dev-maj field from HEADER-STRING."
(let* ((fname "cpio-newc-parse-dev-maj")
(this-offset *cpio-newc-dev-maj-field-offset*)
(end-offset (+ this-offset *cpio-newc-field-width*)))
(string-to-number (substring header-string this-offset end-offset) 16)))
(defun cpio-newc-parse-dev-min (header-string)
"Get the dev-min field from HEADER-STRING."
(let* ((fname "cpio-newc-parse-dev-min")
(this-offset *cpio-newc-dev-min-field-offset*)
(end-offset (+ this-offset *cpio-newc-field-width*)))
(string-to-number (substring header-string this-offset end-offset) 16)))
(defun cpio-newc-parse-rdev-maj (header-string)
"Get the rdev-maj field from HEADER-STRING."
(let* ((fname "cpio-newc-parse-rdev-maj")
(this-offset *cpio-newc-rdev-maj-field-offset*)
(end-offset (+ this-offset *cpio-newc-field-width*)))
(string-to-number (substring header-string this-offset end-offset) 16)))
(defun cpio-newc-parse-rdev-min (header-string)
"Get the rdev-min field from HEADER-STRING."
(let* ((fname "cpio-newc-parse-rdev-min")
(this-offset *cpio-newc-rdev-min-field-offset*)
(end-offset (+ this-offset *cpio-newc-field-width*)))
(string-to-number (substring header-string this-offset end-offset) 16)))
(defun cpio-newc-parse-namesize (header-string)
"Get the namesize field from HEADER-STRING."
(let* ((fname "cpio-newc-parse-namesize")
(this-offset *cpio-newc-namesize-field-offset*)
(end-offset (+ this-offset *cpio-newc-field-width*)))
(string-to-number (substring header-string this-offset end-offset) 16)))
(defun cpio-newc-parse-chksum (header-string)
"Get the chksum field from HEADER-STRING."
(let* ((fname "cpio-newc-parse-chksum")
(this-offset *cpio-newc-chksum-field-offset*)
(end-offset (+ this-offset *cpio-newc-field-width*)))
(string-to-number (substring header-string this-offset end-offset) 16)))
(defun cpio-newc-parse-name (header-string namesize)
"Get the name field from HEADER-STRING.
N.B. When called with the correct namesize, this includes the terminating \0."
(let* ((fname "cpio-newc-parse-name")
(this-offset *cpio-newc-name-field-offset*)
(tmp-string (substring header-string this-offset (+ this-offset namesize -1))))
(if (string-equal tmp-string "TRAILER!!!")
nil
tmp-string)))
;; Is this not M-x cpio-dired-find-entry?
(defun cpio-newc-parse-contents (header-string where namesize filesize)
"Return the contents implied by point and HEADER-STRING.
CAVEATS: See `cpio-newc-parse-magic'.
This requires the point to be at the start of HEADER-STRING in the buffer.
After all that's where the contents are, not in the header."
(let ((fname "cpio-newc-parse-contents"))
(buffer-substring-no-properties (+ where namesize)
(+ where namesize filesize))))
;;;;;;;;;;;;;;;;
;;
;; Header construction
;;
(defun cpio-newc-make-header-string (attrs &optional contents)
"Make a NEWC style padded cpio header for the given ATTRibuteS.
This function does NOT include the contents."
(let ((fname "cpio-newc-make-header-string")
(name (cpio-entry-name attrs))
(header-string))
(setq header-string (concat (cpio-newc-make-magic attrs)
(cpio-newc-make-ino attrs)
(cpio-newc-make-mode attrs)
(cpio-newc-make-uid attrs)
(cpio-newc-make-gid attrs)
(cpio-newc-make-nlink attrs)
(cpio-newc-make-mtime attrs)
(cpio-newc-make-filesize attrs)
(cpio-newc-make-dev-maj attrs)
(cpio-newc-make-dev-min attrs)
(cpio-newc-make-rdev-maj attrs)
(cpio-newc-make-rdev-min attrs)
(format "%08X" (1+ (length name)))
(cpio-newc-make-chksum attrs)
name
"\0"))
(setq header-string (cg-pad-right header-string (cg-round-up (length header-string) *cpio-newc-padding-modulus*) "\0"))
;; Check (at least during development).
(if (string-match-p *cpio-newc-header-re* header-string)
header-string
(error "%s(): I built a bad header: [[%s]]" fname header-string))))
(defun cpio-newc-make-magic (attrs)
"Return the NEWC magic header string"
(let ((fname "cpio-newc-make-magic"))
*cpio-newc-magic*))
(defun cpio-newc-make-ino (attrs)
"Return a string value for the inode from the file attributes ATTRS."
(let ((fname "cpio-newc-make-ino")
(ino (cpio-ino attrs)))
(format "%08X" ino)))
(defun cpio-newc-make-mode (attrs)
"Return a string value for the mode from the file attributes ATTRS."
(let ((fname "cpio-newc-make-mode"))
(format "%08X" (cpio-mode-value attrs))))
(defun cpio-newc-make-uid (attrs)
"Return an integer string value for the UID from the file attributes ATTRS."
(let ((fname "cpio-newc-make-uid")
(uid (cpio-uid attrs)))
(format "%08X" uid)))
(defun cpio-newc-make-gid (attrs)
"Return an integer string value for the GID from the file attributes ATTRS."
(let ((fname "cpio-newc-make-gid")
(gid (cpio-gid attrs)))
(format "%08X" gid)))
(defun cpio-newc-make-nlink (attrs)
"Return an integer string value for the number of links from the file attributes ATTRS."
(let ((fname "cpio-newc-make-nlink"))
(format "%08X" (cpio-nlink attrs))))
(defun cpio-newc-make-mtime (attrs)
"Return a string value for the mod time from the file attributes ATTRS."
(let ((fname "cpio-newc-make-mtime")
(mod-time (cpio-mtime attrs)))
;; We're only about 1/2 way through using this up it seems.
;; Still, time will eventually overflow a 32 bit unsigned integer.
(format "%08X" (float-time mod-time))))
(defun cpio-newc-make-filesize (attrs)
"Return an 8 digit hex string for the filesize attribute among the given ATTRs."
(let ((fname "cpio-newc-make-filesize"))
(format "%08X" (cpio-entry-size attrs))))
(defun cpio-newc-make-dev-maj (attrs)
"Return a string value for the major device from the file attributes ATTRS."
(let ((fname "cpio-newc-make-dev-maj")
(dev (cpio-dev-maj attrs)))
(format "%08X" dev)))
(defun cpio-newc-make-dev-min (attrs)
"Return a string value for the minor device from the file attributes ATTRS."
(let ((fname "cpio-newc-make-dev-min")
(dev (cpio-dev-min attrs)))
(format "%08X" dev)))
(defun cpio-newc-make-rdev-maj (attrs)
"Return a string value for the major rdev from the file attributes ATTRS."
(let ((fname "cpio-newc-make-rdev-maj")
(rdev))
;; MAINTENANCE Every concrete example I look at has this value for rdev-maj.
;; That's apparently the case for all file types except char and block special.
;; And, yes, I have to figure out those calculations yet.
"00000000"))
(defun cpio-newc-make-rdev-min (attrs)
"Return a string value for the minor rdev from the file attributes ATTRS."
(let ((fname "cpio-newc-make-rdev-min"))
;; MAINTENANCE Every concrete example I look at has this value for rdev-maj.
;; See (cpio-newc-make-rdev-maj) for more information.
"00000000"))
(defun cpio-newc-make-chksum (attrs)
"Return a string value for the newc cpio entry from the file attributes ATTRS."
(let ((fname "cpio-newc-make-chksum"))
;; According to the info this is only populated for crc archives.
;; It has always been 00000000 for my concrete newc examples.
;; And, indeed, it's only set in crc archives.
;; See copyout.c->writeout-defered-file() and nowhere else.
"00000000"))
;; Filename is not one of ATTRS. ∴ It doesn't get a constructor here.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Functions for whole entries
;;
(defun cpio-newc-parse-header-at-point ()
"Parse the newc cpio header that begins at point.
If there is no header there, then signal an error."
(let ((fname "cpio-newc-parse-header-at-point"))
(unless (looking-at-p *cpio-newc-header-re*)
(error "%s(): point is not looking at a newc header." fname))
(cpio-newc-parse-header (match-string-no-properties 0))))
(defun cpio-newc-goto-next-header ()
"Move the point to the beginning of the next newc cpio header.
If point is looking-at such a header, then that is the next one
and there is no movement.
\(Thus, a caller may have to make sure that point has moved.\)
This returns the a marker for point where the header is found, if one is found.
It returns NIL otherwise.
This sets match-data for the entire header and each field."
(let ((fname "cpio-newc-goto-next-header")
(header-start)
(header-string))
(cond ((re-search-forward *cpio-newc-header-re* (point-max) t)
(setq header-start (goto-char (match-beginning 0)))
(setq header-string (match-string-no-properties 0))
(cons (point-marker) header-string))
(t nil))))
(defun cpio-newc-build-catalog ()
"Build an internal structure reflecting the contents of the newc cpio archive in the current buffer.
See the variable *cpio-catalog* for more information.
CAVEAT: This respects neither narrowing nor the point."
(let ((fname "cpio-newc-build-catalog")
(header-start) ;A marker.
(header-end)
(that-header-string)
(header-info ())
(parsed-header t)
(filesize) ;A marker.
(contents-start)
(contents-end) ;NOT NEEDED?
(those-contents) ;
(catalog ()))
(widen)
(goto-char (point-min))
(while (and (setq header-info (cpio-newc-goto-next-header))
(setq header-start (car header-info))
(setq that-header-string (cdr header-info))
parsed-header)
(cond ((setq parsed-header (cpio-newc-parse-header-at-point))
(setq filesize (cpio-entry-size parsed-header))
(forward-char (length that-header-string))
(setq header-end (point))
;; A little bit of arithmétic gymnastics here
;; because cpio, being written in C, starts counting at 0, but
;; emacs' points start at 1.
(goto-char (1+ (cg-round-up (1- header-end) *cpio-padding-modulus*)))
(setq contents-start (point-marker))
(set-marker-insertion-type contents-start *cg-insert-after*)
;; It feels like I really want a function for getting the contents.
;; But it's not obvious what is simpler or appropriately more general
;; than this one-liner.
;; Indeed. (setq those-contents (buffer-substring-no-properties contents-start contents-end))
(push (cons (cpio-entry-name parsed-header)
(vector
parsed-header
header-start
contents-start
'cpio-mode-entry-unmodified))
catalog)
(setq contents-end (+ contents-start filesize -1))
(goto-char contents-end))
(t t)))
(nreverse catalog)))
;; catalog))
(defun cpio-newc-start-of-trailer ()
"Return the character position of the (ostensible) start of the trailer
for the current cpio archive."
(let ((fname "cpio-newc-start-of-trailer")
(end-of-contents 0))
(mapc (lambda (ce)
(let ((attrs (cpio-entry-attrs-from-catalog-entry ce)))
(setq end-of-contents (+ (cpio-entry-size attrs) (cpio-contents-start ce)))))
*cpio-catalog*)
end-of-contents))
(defun cpio-newc-end-of-archive ()
"Calculate the location of the end of the current archive
once the TRAILER is written and padded."
(let ((fname "cpio-newc-end-of-archive")
(end-of-contents (cpio-newc-start-of-trailer)))
(cg-round-up (+ end-of-contents (length *cpio-newc-trailer*)) *cpio-newc-blocksize*)))
(defun cpio-newc-adjust-trailer ()
"Replace thed current trailer in the current cpio newc archive."
(let ((fname "cpio-newc-adjust-trailer"))
(cpio-newc-delete-trailer)
(cpio-newc-insert-trailer)))
(defun cpio-newc-insert-trailer ()
"Insert a newc trailer into a cpio archive."
(let* ((fname "cpio-newc-insert-trailer")
(base-len (length *cpio-newc-trailer*))
(len))
;; ...and insert the new trailer...
(with-writable-buffer
(insert *cpio-newc-trailer*)
(goto-char (point-max))
;; ...with padding.
(setq len (cg-round-up (1- (point)) *cpio-newc-blocksize*))
(setq len (1+ (- len (point))))
(insert (make-string len ?\0)))))
(defun cpio-newc-delete-trailer ()
"Delete the trailer in the current cpio newc archive."
(let ((fname "cpio-newc-delete-trailer"))
(unless (eq major-mode 'cpio-mode)
(error "%s(): Called outside of a cpio archive buffer." fname))
;; First, get to the end of the last entry in the archive.
(goto-char (point-min))
(mapc (lambda (e)
(let* ((ename (car e)) ;Isn't there a generic function for this?
(attrs (cpio-entry-attrs ename))
;; Fencepost issue here.
(entry-end (+ (cpio-contents-start ename)
(cpio-entry-size attrs))))
(goto-char entry-end)
(skip-chars-forward "\0")))
*cpio-catalog*)
;; Next, delete what's left...
(with-writable-buffer
(delete-region (point) (point-max)))))
(defun cpio-newc-make-chksum-for-file (filename)
"Return the checksum for FILENAME."
(let ((fname "cpio-newc-make-chksum-for-file")
)
;; (error "%s() is not yet implemented" fname)
0
))
;;
;; Test and other development assistance.
;;
(defun cpio-newc-present-header (header-string)
"Parse the HEADER-STRING and present its fields nicely.
That is show their names and octal and decimal values."
(let ((fname "cpio-newc-present-header")
(header-contents (cpio-newc-parse-header header-string))
(header-fields (list "magic"
"ino"
"mode"
"uid"
"gid"
"nlink"
"mtime"
"filesize"
"dev-maj"
"dev-min"
"rdev-maj"
"rdev-min"
"namesize"
"chksum"
"name")))
(apply #'concat (cl-mapcar (lambda (name value)
(setq name name)
;; (cg-pad-right name 12 " "))
(format "%s\t%s\t%o\t%d\n"
name
(cg-pad-right value 8 " ")
(string-to-number value 16)
(string-to-number value 16)))
header-fields header-contents))))
(defconst *locations-delay* 0.05 ;FIXME: Namespace!
"The number of seconds to wait at certain points in M-x locations.")
(defun locations () ;FIXME: Namespace!
"Put locations and location related data into the buffer *Locations*.
This is not done properly; it is somewhat brute force.
However, it is intended to help figure out
what the proper way to do it is."
(interactive)
(let ((fname "locations")
(lbuf (get-buffer-create "*Locations*"))
(name)
(namesize 0)
(soh)
(sofn)
(eoh)
(eon)
(hpad)
(filesize 0)
(soc)
(eoc)
(cpad)
(name "")
(ct 0)
(interval 0))
(unless (and lbuf
(buffer-live-p lbuf))
(error "Could not get buffer *Locations*."))
(with-current-buffer lbuf (erase-buffer))
(goto-char (point-min))
(while (re-search-forward *cpio-newc-header-re* (point-max) t)
(goto-char (match-beginning 0))
(sit-for *locations-delay*)
(setq soh (point))
(save-match-data
(looking-at *cpio-newc-magic*)
(goto-char (match-end 0)))
(forward-char (+ 8 ;inode
8 ;mode
8 ;uid
8 ;gid
8 ;nlink
8)) ;mtime
(sit-for *locations-delay*)
(setq filesize (string-to-number (buffer-substring-no-properties (point) (+ (point) 8))))
(forward-char (+ 8 ;filesize
8 ;dev-maj
8 ;dev-min
8 ;rdev-maj
8)) ;rdev-min
;namesize
(sit-for *locations-delay*)
;; HEREHERE
(setq namesize (string-to-number (buffer-substring-no-properties (point) (+ (point) 8))))
(forward-char (+ 8 ;namesize
8)) ;chksum
(sit-for *locations-delay*)
(setq sofn (point))
(sit-for *locations-delay*)
(setq name (buffer-substring-no-properties (point) (+ (point) namesize -1)))
(sit-for *locations-delay*)
(setq eoh (point))
(forward-char namesize)
(setq eon (point))
(setq hpad (skip-chars-forward "\0"))
(setq soc (point))
(re-search-forward "\0\\|070701" (point-max) t)
(goto-char (match-beginning 0))
(sit-for *locations-delay*)
(setq eoc (point))
(sit-for *locations-delay*)
(setq cpad (skip-chars-forward "\0"))
(with-current-buffer lbuf
(funcall 'insert-table-header-maybe ct)
(insert (format (concat "%5s\t" ;Name
" %5d\t" ;Name length
" %5d\t" ;SOH
" %5d\t" ;SOFN
" %5d\t" ;EOH
" %5d\t" ;EON
" %5d\t" ;hpad
" %5d\t" ;File size
" %5d\t" ;SOC
" %5d\t" ;EOC
" %5d\t" ;cpad
"\n")
name
namesize
soh
sofn
eoh
eon
hpad
filesize
soc
eoc
cpad)))
(setq ct (1+ ct)))
(with-current-buffer lbuf
(goto-char (point-max))
(insert (concat "Notes: 1. Name length includes the terminating NULL.\n"
" 2. SOH is calculated via a search for the magic number.\n"
" 3. EOH and SON are equal; each calculation is via the point.\n"
" 4. hpad and cpad are each calculated by motion.\n"))
(goto-char (point-min)))
(pop-to-buffer lbuf)))
(defun insert-table-header-maybe (ct) ;FIXME: Namespace!
"Insert a table header for a cpio entry."
(let ((fname "insert-table-header-maybe"))
(message "%s(): ct is [[%s]]" fname ct) (sit-for .2)
(cond ((= 0 (mod ct 40))
(insert "\n")
(insert (concat " Name\t"
" Name\t"
" SOH\t"
" SOFN\t"
" EOH\t"
" EON\t"
" hpad\t"
" File\t"
" SOC\t"
" EOC\t"
" cpad"
"\n"))
(insert "\tlength\t\t\t\t\t\t size\t\t\t\n")
(insert (concat
(make-string 8 ?=) ;name
(make-string 8 ?=) ;name length
(make-string 8 ?=) ;SOH
(make-string 8 ?=) ;SOFN
(make-string 8 ?=) ;EOH
(make-string 8 ?=) ;EON
(make-string 8 ?=) ;hpad
(make-string 8 ?=) ;File size
(make-string 8 ?=) ;SOC
(make-string 8 ?=) ;EOC
(make-string 8 ?=) ;cpad
(make-string 8 ?=) ;????
"\n")))
(t t))))
(provide 'cpio-newc)
;;; cpio-newc.el ends here.
cpio-mode-0.17.0.20211211.193556/NEWS 0000644 0001752 0001753 00000013002 13712322372 014244 0 ustar elpa elpa # -*- outline -*-
#
# Copyright © 2019 Free Software Foundation, Inc.
# All rights reserved.
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program. If not, see .
#
* Version 0.16β
** Copyright assignment to the FSF.
* Version 0.15β
** Killing the archive buffer now also kills all subordinates.
** More work on meeting ELPA conventions.
*** cpio.el is now cpio-mode.el
*** removed cpio-mode-pkg.el
* Version 0.14β
** Since this is beta code, the archive file is backed up.
The backup file has a timestamp.
Since this is really only for beta code,
the backup is not intelligent in any way.
* Version 0.13̱β
** Clean up for publication to elpa.
* Version 0.12β
** Initial beta release.
* Version 0.11
** Fixed a destructive-looking bug in cpio-affiliated-buffers.el.
** Post-development cleaning up.
* Version 0.10
** Finds an appropriate major mode for an entry's contents.
It does this with (set-auto-mode).
So only entries for which (set-auto-mode) finds a mode get
a non-trivial mode.
** New dired-like commands:
+ cpio-entry-contents-revert-buffer (no key mapping)
+ cpio-dired-do-touch ("T")
** You can now edit and save an entry's contents.
* Version 0.09
** There's now a find-file-hook
and documentation on how to use/invoke cpio-mode.
** Changing owner or group no longer removes marks
on the entries on which the change is being performed.
** cpio-affiliated-buffers.el has had some fixes.
There were lots of issues around the kill-buffer-hook.
It seems correct now.
(Of course, bug reports are welcome.)
Affiliated buffer tests have been fleshed out some.
** Byte compilation is cleaner.
Not entirely clean, but cleaner.
** Some tests have had minor fixes.
* Version 0.08
** Binary format support.
As with the ODC format, hpbin = bin if the archive contains no devices,
and cpio-mode doesn't handle devices yet.
* Version 0.07
** Fontification (from dired).
** Dired-like commands:
+ cpio-dired-flag-backup-entries ("~")
* Version 0.06
** Support for the ODC archive format.
Note that hpodc = odc if the archive contains no devices,
and cpio-mode doesn't handle devices yet.
(And it may never.)
* Version 0.05
** Support for the CRC archive format.
* Version 0.04
** Some post-development clean-up.
* Version 0.03
** More dired-like commands:
+ cpio-dired-flag-garbage-entries ("%&")
+ cpio-dired-goto-entry ("j")
+ cpio-dired-mark-executables ("**")
+ cpio-dired-mark-subdir-entries ("*s")
+ cpio-dired-mark-symlinks ("*@")
** Fixes to saving an archive.
** Fixes to cpio-dired-do-chgrp/own/mod.
** Automated test updates:
*** Automated tests now also check the catalog.
*** Automated tests that modify the catalog
now confirm that the archive can be unpacked by cpio(1)
after saving.
*** Automated tests all pass.
* Version 0.02
** You can now save an archive.
** More dired-like commands:
+ cpio-dired-add-entry ("I")
+ cpio-dired-display-entry ("f")
+ cpio-dired-do-chgrp ("G")
+ cpio-dired-do-chown ("O")
+ cpio-dired-do-copy ("C")
+ cpio-dired-do-delete ("D")
+ cpio-dired-do-flagged-delete ("x")
+ cpio-dired-do-query-replace-regexp ("Q")
+ cpio-dired-do-rename ("R")
+ cpio-dired-do-search ("A")
+ cpio-dired-find-entry-other-window ("o")
+ cpio-dired-flag-auto-save-entries ("#")
+ cpio-dired-flag-entry-deletion ("d")
+ cpio-dired-hide-details-mode ("(")
+ cpio-dired-kill ("C-x k")
+ cpio-dired-mark-entries-regexp ("%m", "*%")
+ cpio-dired-quit-window ("q")
+ cpio-dired-save-archive ("C-x C-s")
+ cpio-dired-summary ("?")
+ cpio-dired-unmark ("u", "*u")
+ cpio-dired-unmark-all-entries (M-xDEL "*?")
+ cpio-dired-unmark-all-marks ("*!", "U")
+ cpio-revert-buffer ("r")
** Other interactive commands:
+ cpio-dired-extract-all ("Xa")
+ cpio-dired-extract-entries ("Xm")
+ cpio-dired-view-archive ("C-cC-c")
+ cpio-view-dired-style-buffer ("C-cC-c" -- from archive buffer).
** You can now edit and save entry contents.
** Some automated testing of the dired-like interface.
* Version 0.01
** Basic function of cpio-mode, cpio-dired-mode, and
cpio-contents-entry-mode are in place.
** You can extract selected entries (M-x cpio-dired-extract-entries),
or extract all entries (M-x cpio-dired-extract-all).
** You can view an entry's contents and even edit the contents' buffer.
However, you cannot save it yet.
** cpio-dired-mode has the following implemented commands:
+ cpio-dired-display-entry ("C-o")
+ cpio-dired-extract-all ("X a")
+ cpio-dired-extract-entries ("X m")
+ cpio-dired-find-entry ("f", "e", "C-j")
+ cpio-dired-mark ("m", "* m")
+ cpio-dired-mark-entries-regexp ("* %", "% m")
+ cpio-dired-next-dirline (">")
+ cpio-dired-next-line (SPC, "n", "C-n")
+ cpio-dired-prev-dirline ("<")
+ cpio-dired-previous-line ("p", "C-p")
+ cpio-dired-summary ("?") -- Don't trust this yet.
+ cpio-dired-unmark ("u", "* u")
+ cpio-dired-unmark-all-marks ("U", "* !")
+ cpio-dired-view-archive ("C-cC-c")
cpio-mode-0.17.0.20211211.193556/cpio-affiliated-buffers.el 0000644 0001752 0001753 00000025351 13754322553 020562 0 ustar elpa elpa ;;; cpio-affiliated-buffers.el --- Establish and manage buffers affiliated with each other. -*- coding: utf-8 -*-
;; COPYRIGHT
;; Copyright © 2019 Free Software Foundation, Inc.
;; All rights reserved.
;;
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see .
;; Author: Douglas Lewan
;; Maintainer: Douglas Lewan
;; Created: 2017 Nov 22
;; Version: 0.17
;; Keywords: files
;;; Commentary:
;; To keep track of which buffers are connected to a specific archive,
;; cpio-mode uses the idea of affiliated buffers.
;;
;; The buffers affiliated with an archive's buffer are the following:
;; 1. The buffer holding the dired-like information.
;; 2. The buffers holding any entry's contents.
;; Killing [deregistering] the dired-like buffer also kills the archive's buffer,
;; and killing the archive's buffer kills
;; all remaining affiliated buffers.
;;
;;; Documentation:
;; Two variables hold the relationships among buffers:
;; • *cab-subordinates* -- a list of the buffers immediately subordinate
;; to the current buffer.
;; • *cab-parent* -- a buffer, the buffer to which the current buffer is affiliated.
;; Both variables are buffer local.
;;
;; The existence of a subordinate buffer depends
;; on the the existence of its parent.
;; One consequence is that a subordinate buffer can have only one parent.
;; Another is that killing the parent buffer kills all subordinates as well.
;; Should a subordinate buffer have further subordinates,
;; then they must also be killed.
;; API:
;; (cab-register (buffer parent))
;; Register BUFFER as a subordinate of PARENT.
;; (cab-registered-p (buffer parent)
;; Return non-NIL if BUFFER is a registered subordinate of PARENT.
;; (cab-kill-buffer-hook)
;; A hook for subordinate buffers that removes their registry entry
;; with PARENT.
;; (cab-deregister (&optional buffer))
;; Kill BUFFER and its subordinates.
;; Deregister BUFFER with its parent.
;; (cab-simple-deregister (buffer))
;; The internal function for (cab-deregister).
;; Don't use this directly.
;; (cab-clean)
;; A temporary function for development
;; that should more forcefully enforce the intent of (cab-deregister).
;; The following incantation should run the tests well.
;; emacs -batch -l ert -l cab-test.el -f ert-run-tests-batch-and-exit
;;; Code:
;;
;; Development
;;
(defun cab-setup-parenthood-check ()
"Set up a simple situation where the parenthood check should error out."
(let ((b0 (find-file-noselect "b0"))
(b1 (find-file-noselect "b1")))
(cab-register b1 b0)
(cab-register b0 b1)))
(defun cab-setup-parenthood-check-1 ()
"Set up a large situation where the parenthood check should error out."
(let* ((b0 (find-file-noselect "bb0"))
(b1 (find-file-noselect "bb1"))
(b2 (find-file-noselect "bb2"))
(b3 (find-file-noselect "bb3"))
(b4 (find-file-noselect "bb4"))
(b5 (find-file-noselect "bb5"))
(b6 (find-file-noselect "bb6"))
(b7 (find-file-noselect "bb7"))
(b8 (find-file-noselect "bb8"))
(b9 (find-file-noselect "bb9"))
(parent b0))
(mapc (lambda (b)
(cab-register b parent)
(setq parent b))
(list b1 b2 b3 b4 b5 b6 b7 b8 b9))
(cab-register b0 b9)))
;; HEREHERE Remove the following test code before publishing cpio-mode.
(defvar OBS-*cab-info-buffer* (get-buffer-create "*cab info*")
"A buffer for holding information about affiliated buffers.")
(setq OBS-*cab-info-buffer* (get-buffer-create "*cab info*"))
(defun OBS-cab-test-kill-buffer-hook ()
"Hook to run when killing a buffer.
The intent is to glean information about any buffers
that cpio-mode might be using
that are affiliated with each other."
(let ((fname "cab-test-kill-buffer-hook")
(buf (current-buffer)))
(unless (string-match "\\` " (buffer-name (current-buffer)))
(with-current-buffer *cab-info-buffer*
(goto-char (point-max))
(insert (format "\n\nKilling buffer [[%s]].
It has parent [[%s]].
"
(buffer-name buf)
(if *cab-parent*
(buffer-name *cab-parent*)
"nil")))
(cond ((with-current-buffer buf *cab-subordinates*)
(insert " It has subordinates:\n")
(mapc (lambda (b)
(insert (format " [[%s]]\n" b)))
(with-current-buffer buf
*cab-subordinates*)))
(t (insert " No subordinates.\n")))))))
(defun OBS-cab-test-register-buffer-hook (buffer parent)
"Record some information about the registration of a BUFFER
as an affiliated buffer.
It's not strictly a hook, but it pairs with the above kill-buffer-hook."
(let ((fname "cab-test-register-buffer-hook"))
(with-current-buffer *cab-info-buffer*
(goto-char (point-max))
(insert (format "Registering [[%s]] with [[%s]] as its parent.\n"
(buffer-name buffer) (buffer-name parent)))
(insert (format " [[%s]] currently has the following subordinates.\n"
(buffer-name parent)))
(mapc (lambda (b)
(insert (format " [[%s]]\n" (buffer-name b))))
(with-current-buffer parent
*cab-subordinates*)))))
(defcustom cab-clear-cab-info-buffer nil
"Clear the Affiliated Info Buffer if set."
:type 'boolean
:group 'cab)
;;
;; Generic functions
;;
;;
;; Dependencies
;;
(eval-when-compile
(require 'cl-lib))
;;
;; Vars
;;
(defvar *cab-subordinates* ()
"A list of subordinate buffers affiliated with the current buffer.")
(setq *cab-subordinates* ())
(make-variable-buffer-local '*cab-subordinates*)
(defvar *cab-parent* nil
"The parent buffer of an affiliated buffer.")
(setq *cab-parent* nil)
(make-variable-buffer-local '*cab-parent*)
;;
;; Library
;;
(defun cab-register (buffer parent)
"Register the given BUFFER as an affiliate of the PARENT buffer.
If BUFFER is already an affiliate of PARENT, then succeed quietly.
Return non-NIL on success.
Return NIL if buffer is already affiliated to another parent."
(let ((fname "cab-register"))
(if (not (bufferp buffer))
(error "%s(): proposed buffer [[%s]] is not a buffer." fname buffer))
(if (not (bufferp parent))
(error "%s(): proposed parent buffer [[%s]] is not a buffer." fname parent))
(if (equal buffer parent)
(error "%s(): You can't affiliate a buffer [[%s]] with itself [[%s]]." fname buffer parent))
(if (cab-detect-parenthood-cycle buffer parent)
(error "%s(): Registering [[%s]] as a subordinate of [[%s]] would create a cycle of parents." fname buffer parent))
(cond ((cab-registered-p buffer parent)
t)
((with-current-buffer buffer
(and (boundp '*cab-parent*)
(buffer-live-p *cab-parent*)))
nil)
(t
(with-current-buffer buffer
(setq *cab-parent* parent)
(local-set-key "\C-x\C-k" (lambda () (cab-deregister buffer))))
(with-current-buffer parent
(push buffer *cab-subordinates*)
(add-hook 'kill-buffer-hook 'cab-kill-buffer-hook nil 'local)
(local-set-key "\C-x\C-k" (lambda () (cab-deregister parent))))))))
(defun cab-detect-parenthood-cycle (buffer parent)
"Return non-NIL if affiliating BUFFER with PARENT would create a parenthood cycle."
(let ((fname "cab-detect-parenthood-cycle"))
(with-current-buffer parent
(catch 'detected
(while parent
(with-current-buffer parent
(cond ((eq (current-buffer) buffer)
(throw 'detected t))
((null *cab-parent*)
(setq parent *cab-parent*))
(t
(setq parent *cab-parent*)))))))))
(defun cab-registered-p (buffer parent)
"Return non-NIL if BUFFER is already registered to PARENT.
CONTRACT: BUFFER and PARENT are buffers."
(let ((fname "cab-registered-p"))
(cond ((or (null buffer)
(not (bufferp buffer))
(not (buffer-live-p buffer)))
nil)
((or (null parent)
(not (bufferp parent))
(not (buffer-live-p parent)))
nil)
((and (bufferp parent)
(buffer-live-p parent))
(with-current-buffer parent
(member buffer *cab-subordinates*))))))
(defun cab-kill-buffer-hook ()
"Kill the current buffer and remove any affiliation (parent or subordinate)."
(let ((fname "cab-kill-buffer-hook")
(buffer (current-buffer)))
(cond ((buffer-live-p (current-buffer))
(if (buffer-live-p *cab-parent*)
(with-current-buffer *cab-parent*
(delete buffer *cab-subordinates*))))
(t t))))
(defun cab-deregister (buffer)
"Deregister and kill BUFFER and all its subordinate buffers.
Note that that will include their subordinates too.
Remove its registry entry in its parent buffer.
NOTE: Use this function instead of (kill-buffer)
if you want to lose registry information."
(interactive)
(let ((fname "cab-deregister")
(parent)
(subordinates))
(cond ((buffer-live-p buffer)
(with-current-buffer buffer
(setq parent *cab-parent*)
(setq subordinates *cab-subordinates*))
(mapc 'cab-deregister subordinates)
(if (and parent
(bufferp parent)
(buffer-live-p parent)
(cab-registered-p buffer parent))
(with-current-buffer parent
(setq *cab-subordinates* (delete buffer *cab-subordinates*))))
(if (buffer-live-p buffer)
(kill-buffer buffer)))
(t nil))))
(defun cab-simple-deregister (buffer)
"Deregister BUFFER and all its subordinates, but don't kill it."
(let ((fname "cab-simple-deregister")
(parent)
(subordinates))
(with-current-buffer buffer
(setq parent *cab-parent*)
(setq subordinates *cab-subordinates*))
(mapc 'cab-simple-deregister subordinates)
(with-current-buffer parent
(setq *cab-subordinates* (delete buffer *cab-subordinates*)))))
(defun cab-clean ()
"Clean up affiliated buffers.
CAVEAT: This function should disappear as affiliated buffer code stabilizes."
(interactive)
(let ((fname "cab-clean"))
(mapc (lambda (b)
(with-current-buffer b
(if (boundp '*cab-subordinates*)
(setq *cab-subordinates* (delete-dups *cab-subordinates*)))))
(buffer-list))))
(defun cab-clean-ruthlessly ()
"Get rid of all buffers that are affiliated with other buffers."
(let ((fname "cab-clean-2"))
(mapc (lambda (b)
(if (buffer-live-p b)
(with-current-buffer b
(if (or (and (boundp '*cab-parent*)
*cab-parent*)
(and (boundp '*cab-subordinates*)
*cab-subordinates*))
(cab-deregister b)))))
(buffer-list))))
(provide 'cpio-affiliated-buffers)
;;; cpio-affiliated-buffers.el ends here
cpio-mode-0.17.0.20211211.193556/cpio-modes.el 0000644 0001752 0001753 00000034206 13754322553 016146 0 ustar elpa elpa ;;; cpio-modes.el --- handle file modes/permissions. -*- coding: utf-8 -*-
;; COPYRIGHT
;;
;; Copyright © 2019-2020 Free Software Foundation, Inc.
;; All rights reserved.
;;
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see .
;; Author: Douglas Lewan
;; Maintainer: Douglas Lewan
;; Created: 2017 Nov 28
;; Version: 0.17
;; Keywords: files
;;; Commentary:
;; This file contains code for dealing with mode bits in cpio-mode.
;;; Documentation:
;;; Code:
;;
;; Dependencies
;;
(eval-when-compile
(require 'cl-lib)
(require 'cl-extra))
;;;;;;;;;;;;;;;;
;; Things to make the byte compiler happy.
(declare-function cpio-mode-value "cpio-mode.el")
;; EO things for the byte compiler.
;;;;;;;;;;;;;;;;
;;
;; Vars
;;
;;
;; Mode-related bits (adapted from /usr/include/linux/stat.h).
;;
(defconst s-ifunk #o1000000)
(defconst s-ifmt #o0170000)
(defconst s-ifsock #o0140000)
(defconst s-iflnk #o0120000)
(defconst s-ifreg #o0100000)
(defconst s-ifblk #o0060000)
(defconst s-ifdir #o0040000)
(defconst s-ifchr #o0020000)
(defconst s-ififo #o0010000)
(defconst s-isuid #o0004000)
(defconst s-isgid #o0002000)
(defconst s-isvtx #o0001000)
(defconst s-irwxu #o00700)
(defconst s-irusr #o00400)
(defconst s-iwusr #o00200)
(defconst s-ixusr #o00100)
(defconst s-irwxg #o00070)
(defconst s-irgrp #o00040)
(defconst s-iwgrp #o00020)
(defconst s-ixgrp #o00010)
(defconst s-irwxo #o00007)
(defconst s-iroth #o00004)
(defconst s-iwoth #o00002)
(defconst s-ixoth #o00001)
(defconst UNUSED-*cpio-low-mode-bits* (logior s-irwxu s-irwxg s-irwxo s-isuid s-isgid s-isvtx)
"A bit mask of the modes that can be set by chmod(1).")
;;
;; Library
;;
(defun s-islnk (m)
(= (logand m s-ifmt) s-iflnk))
(defun s-isreg (m)
(= (logand m s-ifmt) s-ifreg))
(defun s-isdir (m)
(= (logand m s-ifmt) s-ifdir))
(defun s-ischr (m)
(= (logand m s-ifmt) s-ifchr))
(defun s-isblk (m)
(= (logand m s-ifmt) s-ifblk))
(defun s-isfifo (m)
(= (logand m s-ifmt) s-ififo))
(defun s-issock (m)
(= (logand m s-ifmt) s-ifsock))
(defun cpio-special-file (attrs)
"Return non-NIL if the mode in ATTRS is as special file:
fmt, sock, link, block, character, fifo."
(let ((fname "cpio-special-file")
(mode (cpio-mode-value attrs)))
(or (= s-ifmt (logand s-ifmt mode))
(= s-ifsock (logand s-ifsock mode))
(= s-iflnk (logand s-iflnk mode)) ;Does this really belong here? I'm writing this to support (cpio-crc-make-chksum). Do links' checksums get calculated?
(= s-ifblk (logand s-ifblk mode))
(= s-ifdir (logand s-ifdir mode)) ;Is a directory a special file? Again, this has to do with calculating a checksum.
(= s-ifchr (logand s-ifchr mode))
(= s-ififo (logand s-ififo mode)))))
(defun cpio-int-mode-to-mode-string (int-mode)
"Convert an integer mode value to the corresponding ls -l version."
(let ((fname "cpio-int-mode-to-mode-string")
(file-type (cpio-int-mode-to-file-type int-mode))
(user-mode (cpio-int-mode-to-user-permissions int-mode))
(group-mode (cpio-int-mode-to-group-permissions int-mode))
(other-mode (cpio-int-mode-to-other-permissions int-mode)))
(concat file-type user-mode group-mode other-mode)))
(defvar *cpio-modes-link* "l")
(setq *cpio-modes-link* "l")
(defvar *cpio-modes-reg* "-")
(setq *cpio-modes-reg* "-")
(defvar *cpio-modes-dir* "d")
(setq *cpio-modes-dir* "d")
(defvar *cpio-modes-char* "c")
(setq *cpio-modes-char* "c")
(defvar *cpio-modes-block* "b")
(setq *cpio-modes-block* "b")
(defvar *cpio-modes-fifo* "p")
(setq *cpio-modes-fifo* "p")
(defvar *cpio-modes-sock* "s")
(setq *cpio-modes-sock* "s")
(defvar *cpio-modes-unknown* "?")
(setq *cpio-modes-unknown* "?")
(defun cpio-int-mode-to-file-type (int-mode)
"Extract the one character string that expresses the file type from INT-MODE.
CAUTION: Some file types are not present here:
D -- Solaris door
M -- Cray DMF migrated file
n -- HP-UX network special file
P -- Solaris port.
If you have access to any of those operating systems,
please let me know."
(let ((fname "cpio-int-mode-to-file-type"))
(cond ((s-islnk int-mode)
*cpio-modes-link*)
((s-isreg int-mode)
*cpio-modes-reg*)
((s-isdir int-mode)
*cpio-modes-dir*)
((s-ischr int-mode)
*cpio-modes-char*)
((s-isblk int-mode)
*cpio-modes-block*)
((s-isfifo int-mode)
*cpio-modes-fifo*)
((s-issock int-mode)
*cpio-modes-sock*)
(t
*cpio-modes-unknown*))))
(defun cpio-int-mode-to-user-permissions (int-mode)
"Extract the 3-character string expressing the user permissions from INT-MODE."
(let ((fname "cpio-int-mode-to-user-permissions")
(read-string (cpio-int-mode-to-user-read-string int-mode))
(write-string (cpio-int-mode-to-user-write-string int-mode))
(execute-string (cpio-int-mode-to-user-execute-string int-mode)))
(concat read-string write-string execute-string)))
(defun cpio-int-mode-to-user-read-string (int-mode)
"Extract the 1-character string expressing the user read permissions from INT-MODE."
(let ((fname "cpio-int-mode-to-user-read-string"))
(cond ((/= (logand int-mode s-irusr) 0)
"r")
(t "-"))))
(defun cpio-int-mode-to-user-write-string (int-mode)
"Extract the 1-character string expressing the user write permissions from INT-MODE."
(let ((fname "cpio-int-mode-to-user-write-string"))
(cond ((/= (logand int-mode s-iwusr) 0)
"w")
(t "-"))))
(defun cpio-int-mode-to-user-execute-string (int-mode)
"Extract the 1-character string expressing the user execute permissions from INT-MODE."
(let ((fname "cpio-int-mode-to-user-execute-string"))
(cond ((/= (logand int-mode s-ixusr) 0)
(if (/= (logand int-mode s-isuid) 0)
"s"
"x"))
(t
(if (/= (logand int-mode s-isuid) 0)
"S"
"-")))))
(defun cpio-int-mode-to-group-permissions (int-mode)
"Extract the 3-character string expressing the group permissions from INT-MODE."
(let ((fname "cpio-int-mode-to-group-permissions")
(read-string (cpio-int-mode-to-group-read-string int-mode))
(write-string (cpio-int-mode-to-group-write-string int-mode))
(execute-string (cpio-int-mode-to-group-execute-string int-mode)))
(concat read-string write-string execute-string)))
(defun cpio-int-mode-to-group-read-string (int-mode)
"Extract the 1-character string expressing the group read permissions from INT-MODE."
(let ((fname "cpio-int-mode-to-group-read-string"))
(cond ((/= (logand s-irgrp int-mode) 0)
"r")
(t "-"))))
(defun cpio-int-mode-to-group-write-string (int-mode)
"Extract the 1-character string expressing the group write permissions from INT-MODE."
(let ((fname "cpio-int-mode-to-group-write-string"))
(cond ((/= (logand s-iwgrp int-mode) 0)
"w")
(t "-"))))
(defun cpio-int-mode-to-group-execute-string (int-mode)
"Extract the 1-character string expressing the group execute permissions from INT-MODE."
(let ((fname "cpio-int-mode-to-group-execute-string"))
(cond ((/= (logand int-mode s-ixgrp) 0)
(if (/= (logand int-mode s-isgid) 0)
"s"
"x"))
(t
(if (/= (logand int-mode s-isgid) 0)
"S"
"-")))))
(defun cpio-int-mode-to-other-permissions (int-mode)
"Extract the 3-character string expressing the other permissions from INT-MODE."
(let ((fname "cpio-int-mode-to-other-permissions")
(read-string (cpio-int-mode-to-other-read-string int-mode))
(write-string (cpio-int-mode-to-other-write-string int-mode))
(execute-string (cpio-int-mode-to-other-execute-string int-mode)))
(concat read-string write-string execute-string)))
(defun cpio-int-mode-to-other-read-string (int-mode)
"Extract the 1-character string expressing the other read permissions from INT-MODE."
(let ((fname "cpio-int-mode-to-other-read-string"))
(cond ((/= (logand s-iroth int-mode) 0)
"r")
(t "-"))))
(defun cpio-int-mode-to-other-write-string (int-mode)
"Extract the 1-character string expressing the other write permissions from INT-MODE."
(let ((fname "cpio-int-mode-to-other-write-string"))
(cond ((/= (logand s-iwoth int-mode) 0)
"w")
(t "-"))))
(defun cpio-int-mode-to-other-execute-string (int-mode)
"Extract the 1-character string expressing the other execute permissions from INT-MODE."
(let ((fname "cpio-int-mode-to-other-execute-string"))
(cond ((/= (logand s-ixoth int-mode) 0)
(if (/= (logand s-isvtx int-mode) 0)
"t"
"x"))
(t
(if (/= (logand s-isvtx int-mode) 0)
"T"
"-")))))
(defun cpio-mode-string-to-int-mode (mode-string)
;; HEREHERE This should do some error checking.
;; It will currently flag an error if MODE-STRING is not long enough.
"Convert an ls -l style mode string to its corresponding integer."
(let* ((fname "cpio-mode-string-to-int-mode")
(bits 0)
(chars (mapcar 'string-to-char (split-string mode-string "" t)))
(type-char (car (cl-subseq chars 0 1)))
(owner-chars (cl-subseq chars 1 4))
(group-chars (cl-subseq chars 4 7))
(other-chars (cl-subseq chars 7 10)))
(setq bits (logior bits
(cpio-type-char-to-bits type-char)
(cpio-owner-chars-to-bits owner-chars)
(cpio-group-chars-to-bits group-chars)
(cpio-other-chars-to-bits other-chars)))
bits))
(defun cpio-type-char-to-bits (char)
"Return the mode bits implied by the given type CHAR."
(let ((fname "cpio-type-char-to-bits"))
(unless (and (characterp char)
(or (= char (string-to-char *cpio-modes-link*))
(= char (string-to-char *cpio-modes-reg*))
(= char (string-to-char *cpio-modes-dir*))
(= char (string-to-char *cpio-modes-char*))
(= char (string-to-char *cpio-modes-block*))
(= char (string-to-char *cpio-modes-fifo*))
(= char (string-to-char *cpio-modes-sock*))
(= char (string-to-char *cpio-modes-unknown*))))
(signal 'wrong-type-argument char))
(cond ((= char (string-to-char *cpio-modes-link*))
s-iflnk)
((= char (string-to-char *cpio-modes-reg*))
s-ifreg)
((= char (string-to-char *cpio-modes-dir*))
s-ifdir)
((= char (string-to-char *cpio-modes-char*))
s-ifchr)
((= char (string-to-char *cpio-modes-block*))
s-ifblk)
((= char (string-to-char *cpio-modes-fifo*))
s-ififo)
((= char (string-to-char *cpio-modes-sock*))
s-ifsock)
(t
(error "%s(): Uknown file type is not yet supported." fname)))))
(defun cpio-owner-chars-to-bits (chars)
"Interpret the given CHARS as bits relevant to the owner of a file."
(let ((fname "cpio-owner-chars-to-bits")
(read-char)
(write-char)
(exec-char)
(bits 0))
(unless (and (listp chars)
(= (length chars) 3)
(member (setq read-char (nth 0 chars)) '(?- ?r))
(member (setq write-char (nth 1 chars)) '(?- ?w))
(member (setq exec-char (nth 2 chars)) '(?- ?x ?s ?S)))
(signal 'wrong-type-argument chars))
(cond ((= read-char ?-))
((= read-char ?r)
(setq bits (logior bits s-irusr))))
(cond ((= write-char ?-))
((= write-char ?w)
(setq bits (logior bits s-iwusr))))
(cond ((= exec-char ?-))
((= exec-char ?x)
(setq bits (logior bits s-ixusr)))
((= exec-char ?s)
(setq bits (logior bits s-ixusr s-isuid)))
((= exec-char ?S)
(setq bits (logior bits s-isuid))))
bits))
(defun cpio-group-chars-to-bits (chars)
"Interpret CHARS as group mode bits."
(let ((fname "cpio-group-chars-to-bits")
(read-char)
(write-char)
(exec-char)
(bits 0))
(unless (and (listp chars)
(= (length chars) 3)
(member (setq read-char (nth 0 chars)) '(?- ?r))
(member (setq write-char (nth 1 chars)) '(?- ?w))
(member (setq exec-char (nth 2 chars)) '(?- ?x ?s ?S)))
(signal 'wrong-type-argument chars))
(cond ((= read-char ?-))
((= read-char ?r)
(setq bits (logior bits s-irgrp))))
(cond ((= write-char ?-))
((= write-char ?w)
(setq bits (logior bits s-iwgrp))))
(cond ((= exec-char ?-))
((= exec-char ?x)
(setq bits (logior bits s-ixgrp)))
((= exec-char ?s)
(setq bits (logior bits s-ixgrp s-isgid)))
((= exec-char ?S)
(setq bits (logior bits s-isgid))))
bits))
(defun cpio-other-chars-to-bits (chars)
"Interpret CHARS as other mode bits."
(let ((fname "cpio-other-chars-to-bits")
(read-char)
(write-char)
(exec-char)
(bits 0))
(unless (and (listp chars)
(= (length chars) 3)
(member (setq read-char (nth 0 chars)) '(?- ?r))
(member (setq write-char (nth 1 chars)) '(?- ?w))
(member (setq exec-char (nth 2 chars)) '(?- ?x ?t ?T)))
(signal 'wrong-type-argument chars))
(cond ((= read-char ?-))
((= read-char ?r)
(setq bits (logior bits s-iroth))))
(cond ((= write-char ?-))
((= write-char ?w)
(setq bits (logior bits s-iwoth))))
(cond ((= exec-char ?-))
((= exec-char ?x)
(setq bits (logior bits s-ixoth)))
((= exec-char ?t)
(setq bits (logior bits s-ixoth s-isvtx)))
((= exec-char ?T)
(setq bits (logior bits s-isvtx))))
bits))
(defun cpio-mode-extractable-p (mode)
"Return non-NIL if MODE represents an entry that can be extracted by cpio-mode.
That is, a regular file, symbolic link or directory. "
(let ((fname "cpio-mode-not-extractable-p"))
(or (s-islnk mode)
(s-isreg mode)
(s-isdir mode))))
(defun cpio-valid-numeric-mode (proposed-mode-num)
"Return non-NIL if the PROPOSED-MODE-NUM is a valid numeric file mode."
(let ((fname "cpio-valid-numeric-mode"))
(/= 0 (logxor proposed-mode-num
;; This list could be pared down a little,
;; but this is more readable.
(logand s-ifmt
s-ifsock
s-iflnk
s-ifreg
s-ifblk
s-ifdir
s-ifchr
s-ififo
s-isuid
s-isgid
s-isvtx
s-irwxu
s-irwxg
s-irwxo)))))
(provide 'cpio-modes)
;;; cpio-modes ends here
cpio-mode-0.17.0.20211211.193556/cpio-bin.el 0000644 0001752 0001753 00000043600 13754322553 015605 0 ustar elpa elpa ;;; cpio-bin.el --- handle bin cpio entry header formats -*- coding: utf-8 -*-
;; COPYRIGHT
;;
;; Copyright © 2019-2020 Free Software Foundation, Inc.
;; All rights reserved.
;;
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see .
;;
;; Author: Douglas Lewan
;; Maintainer: Douglas Lewan
;; Created: 2015 Jan 03
;; Version: 0.17
;; Keywords: files
;;; Commentary:
;;; Documentation:
;;; Code:
;;
;; Dependencies
;;
(require 'bindat)
(eval-when-compile (require 'cpio-generic)) ;For `with-writable-buffer'!
;;;;;;;;;;;;;;;;
;; Things to make the byte compiler happy.
(declare-function cpio-entry-name "cpio-mode.el" (attrs))
(declare-function cpio-ino "cpio-mode.el" (attrs))
(declare-function cpio-mode-value "cpio-mode.el" (attrs))
(declare-function cpio-uid "cpio-mode.el" (attrs))
(declare-function cpio-gid "cpio-mode.el" (attrs))
(declare-function cpio-nlink "cpio-mode.el" (attrs))
(declare-function cpio-mtime "cpio-mode.el" (attrs))
(declare-function cpio-entry-size "cpio-mode.el" (attrs))
(declare-function cpio-dev-maj "cpio-mode.el" (attrs))
(declare-function cpio-rdev-maj "cpio-mode.el" (attrs))
(declare-function cpio-entry-attrs-from-catalog-entry "cpio-mode.el" (entry))
(declare-function cpio-contents-start "cpio-mode.el" (entry-name))
(declare-function cpio-entry-attrs "cpio-mode.el" (entry-name))
(defvar *cpio-catalog*)
;; EO things for the byte compiler.
;;;;;;;;;;;;;;;;
;;
;; Vars
;;
(defconst *cpio-bin-header-length* (length (string-as-unibyte "\307q\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0"))
"The length of a bin header.")
;; \307q\0\375c\9\244\201\350\3\350\3\1\0\0\0\377Z\320q\2\0\0\0\4\0a\0
;; \307q \0\375 c\9 \244\201 \350\3 \350\3 \1\0 \0\0 \377Z\320q \2\0 \0\0\4\0 a\0
(defconst *cpio-bin-magic-re* "\307q" ; 070707 \307q
"RE to match the magic number of a bin archive.")
(setq *cpio-bin-magic-re* "\307q")
(defconst *cpio-bin-dev-re* "\\w\\w"
"RE to match the c_dev field in a bin header.")
(setq *cpio-bin-dev-re* "\\w\\w")
(defconst *cpio-bin-ino-re* "\\w\\w"
"RE to match the c_ino field in a bin header.")
(setq *cpio-bin-ino-re* "\\w\\w")
(defconst *cpio-bin-mode-re* "\\w\\w"
"RE to match the c_mode field in a bin header.")
(setq *cpio-bin-mode-re* "\\w\\w")
(defconst *cpio-bin-uid-re* "\\w\\w"
"RE to match the c_uid field in a bin header.")
(setq *cpio-bin-uid-re* "\\w\\w")
(defconst *cpio-bin-gid-re* "\\w\\w"
"RE to match the c_gid field in a bin header.")
(setq *cpio-bin-gid-re* "\\w\\w")
(defconst *cpio-bin-nlink-re* "\\w\\w"
"RE to match the c_nlink field in a bin header.")
(setq *cpio-bin-nlink-re* "\\w\\w")
(defconst *cpio-bin-rdev-re* "\\w\\w"
"RE to match the c_rdev field in a bin header.")
(setq *cpio-bin-rdev-re* "\\w\\w")
(defconst *cpio-bin-mtime-re* "\\w\\w\\w\\w"
"RE to match the c_mtime field in a bin header.")
(setq *cpio-bin-mtime-re* "\\w\\w\\w\\w")
(defconst *cpio-bin-namesize-re* "\\w\\w"
"RE to match the c_rdev field in a bin header.")
(setq *cpio-bin-rdev-re* "\\w\\w")
(defconst *cpio-bin-filesize-re* "\\w\\w\\w\\w"
"RE to match the c_filesize field in a bin header.")
(setq *cpio-bin-filesize-re* "\\w\\w\\w\\w")
(defconst *cpio-bin-filename-re* ()
"RE to match a filename in a bin header.")
(setq *cpio-bin-filename-re* "[[:print:]]+")
(defconst *cpio-bin-header-re* ()
"RE to match bin header format cpio archives.")
(setq *cpio-bin-header-re* (concat "\\(" *cpio-bin-magic-re* "\\)"
"\\(" *cpio-bin-dev-re* "\\)"
"\\(" *cpio-bin-ino-re* "\\)"
"\\(" *cpio-bin-mode-re* "\\)"
"\\(" *cpio-bin-uid-re* "\\)"
"\\(" *cpio-bin-gid-re* "\\)"
"\\(" *cpio-bin-nlink-re* "\\)"
"\\(" *cpio-bin-rdev-re* "\\)"
"\\(" *cpio-bin-mtime-re* "\\)"
"\\(" *cpio-bin-namesize-re* "\\)"
"\\(" *cpio-bin-filesize-re* "\\)"
"\\(" *cpio-bin-filename-re* "\\)"
"\0"))
(defvar *cpio-bin-name-field-offset* (length "\307q\0\375z\r\244\201\350\350\0\0\0[\211\255\0\0\0\0")
"The offset of the name field in a cpio binary header.")
(defconst cpio-bin-index-spec
'(;; (:magic u16)
(:dev u16)
(:ino u16)
(:mode u16)
(:uid u16)
(:gid u16)
(:nlink u16)
(:rdev u16)
(:mtime u32)
(:namesize u16)
(:filesize u32)
(:filename strz (:namesize))))
(setq cpio-bin-index-spec
'((:magic u16r)
(:dev u16r)
(:ino u16r)
(:mode u16r)
(:uid u16r)
(:gid u16r)
(:nlink u16r)
(:rdev u16r)
(:mtime0 u16r)
(:mtime1 u16r)
(:namesize u16r)
(:filesize0 u16r)
(:filesize1 u16r)
(:filename strz (:namesize))))
(defconst *cpio-bin-magic* *cpio-bin-magic-re*
"The string that identifies an entry as a BIN style cpio(1) entry.")
(setq *cpio-bin-magic* *cpio-bin-magic-re*)
(defconst *cpio-bin-magic-int* #o070707
"An integer value of the cpio bin magic number.")
(defconst *cpio-bin-padding-modulus* 2
"The modulus to which some things are padded in a BIN cpio archive.")
(setq *cpio-bin-padding-modulus* 2)
(defconst *cpio-bin-padding-char* ?\0
"A character to be used for padding headers and entry contents
in a bin cpio archive.")
(setq *cpio-bin-padding-char* ?\0)
(defconst *cpio-bin-padding-str* "\0"
"A single character string of the character
to be used for padding headers and entry contents
in a bin cpio archive.")
(setq *cpio-bin-padding-str* "\0")
(defconst *cpio-bin-trailer* (string-as-unibyte "\307q\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0TRAILER!!!\0\0")
"The TRAILER string of a cpio binary archive.")
(defcustom *cpio-bin-blocksize* 512
"The default blocksize for a cpio binary archive."
:type 'integer
:group 'cpio)
;;
;; Library
;;
(defun cpio-bin-header-at-point (&optional where)
"Return the header string at or following point WHERE.
If WHERE is not given, then use point.
CAVEATS:
1. This searches for the magic number at the begining of the header;
if WHERE is inside the magic number, then the search will fail.
This works best if you are (looking-at) a header.
2. This returns the pure header;
it does not provide the filename itself."
(unless where (setq where (point)))
(let ((fname "cpio-bin-header-at-point")
(found nil))
(save-match-data
(cond ((looking-at *cpio-bin-header-re*)
(string-as-unibyte (match-string-no-properties 0)))
(t
(forward-char (length *cpio-bin-magic-re*))
(while (and (re-search-backward *cpio-bin-magic-re* (point-min) t)
(not (setq found (looking-at *cpio-bin-header-re*)))))
(if found
(string-as-unibyte (match-string-no-properties 0))))))))
(defun cpio-bin-parse-header (header-string)
"Return the internal entry header structure encoded in HEADER-STRING.
HEADER-STRING is a unibyte string.
The function does NOT get the contents of that entry."
(let ((fname "cpio-bin-parse-header")
(header-info)
(mtime)
(filesize)
(result)
(entry-name))
(setq header-info (bindat-unpack cpio-bin-index-spec
header-string))
(setq mtime (list (bindat-get-field header-info :mtime0)
(bindat-get-field header-info :mtime1)))
(setq filesize (+ (* 256 256 (bindat-get-field header-info :filesize0))
(bindat-get-field header-info :filesize1)))
(cond ((string-equal (setq entry-name (bindat-get-field header-info :filename))
"TRAILER!!!")
nil)
(t
(setq result
(vector (bindat-get-field header-info :ino)
(bindat-get-field header-info :mode)
(bindat-get-field header-info :uid)
(bindat-get-field header-info :gid)
(bindat-get-field header-info :nlink)
mtime
filesize
(bindat-get-field header-info :dev)
0 ;dev min
(bindat-get-field header-info :rdev)
0 ;rdev min
(bindat-get-field header-info :namesize)
0 ;checksum
entry-name))
(if (cpio-entry-name result)
result
nil)))))
(defun cpio-bin-header-size (header-string namesize)
"Determine the length of the header implied by the given HEADER-STRING."
(let ((fname "cpio-bin-header-size")
;; CAUTION: The following assumes that (string-to-number) doesn't care about leading zeroes.
;; The namesize in the header includes the terminating NULL at the end of the name.
(local-namesize (1- namesize))
(total -1))
(if (= 0 (mod (setq total (+ 1 *cpio-bin-name-field-offset* local-namesize))
*cpio-bin-padding-modulus*))
(setq total (1+ total)))
(cg-round-up total *cpio-bin-padding-modulus*)))
;;;;;;;;;;;;;;;;
;;
;; Header construction
;;
(defun cpio-bin-make-header-string (attrs &optional contents)
"Make a BIN style padded cpio header for the given ATTRibuteS.
This function does NOT include the contents."
(let ((fname "cpio-bin-make-header-string")
(name (cpio-entry-name attrs))
(header-string)
(padding)
(mtime (cpio-bin-make-mtime attrs))
(filesize (cpio-bin-make-filesize attrs)))
(setq header-string
(bindat-pack cpio-bin-index-spec
(list
(cons :magic (cpio-bin-make-magic attrs))
(cons :dev (cpio-bin-make-dev-maj attrs))
(cons :ino (cpio-bin-make-ino attrs))
(cons :mode (cpio-bin-make-mode attrs))
(cons :uid (cpio-bin-make-uid attrs))
(cons :gid (cpio-bin-make-gid attrs))
(cons :nlink (cpio-bin-make-nlink attrs))
(cons :rdev (cpio-bin-make-rdev-maj attrs))
(cons :mtime0 (car mtime))
(cons :mtime1 (cdr mtime))
(cons :namesize (1+ (length name)))
(cons :filesize0 (car filesize))
(cons :filesize1 (cdr filesize))
(cons :filename (concat name "\0")))))
(setq header-string (cg-pad-right header-string (cg-round-up (length header-string)
*cpio-bin-padding-modulus*)
"\0"))))
(defun cpio-bin-make-magic (attrs)
"Return the BIN magic header string"
(let ((fname "cpio-bin-make-magic"))
*cpio-bin-magic-int*))
(defun cpio-bin-make-ino (attrs)
"Return a string value for the inode from the file attributes ATTRS."
(let ((fname "cpio-bin-make-ino"))
(cpio-ino attrs)))
(defun cpio-bin-make-mode (attrs)
"Return a string value for the mode from the file attributes ATTRS."
(let ((fname "cpio-bin-make-mode"))
(cpio-mode-value attrs)))
(defun cpio-bin-make-uid (attrs)
"Return an integer string value for the UID from the file attributes ATTRS."
(let ((fname "cpio-bin-make-uid"))
(cpio-uid attrs)))
(defun cpio-bin-make-gid (attrs)
"Return an integer string value for the GID from the file attributes ATTRS."
(let ((fname "cpio-bin-make-gid"))
(cpio-gid attrs)))
(defun cpio-bin-make-nlink (attrs)
"Return an integer string value for the number of links from the file attributes ATTRS."
(let ((fname "cpio-bin-make-nlink"))
(cpio-nlink attrs)))
(defun cpio-bin-make-mtime (attrs)
"Return a string value for the mod time from the file attributes ATTRS."
(let* ((fname "cpio-bin-make-mtime")
(mod-time (cpio-mtime attrs))
(high-time (car mod-time))
(low-time (cadr mod-time)))
(cons high-time low-time)))
(defun cpio-bin-make-filesize (attrs)
"Return an 8 digit hex string for the filesize attribute among the given ATTRs."
(let ((fname "cpio-bin-make-filesize")
(filesize (cpio-entry-size attrs)))
(cons (lsh (logand #xFFFF0000 filesize) 8)
(logand #xFFFF filesize))))
(defun cpio-bin-make-dev-maj (attrs)
"Return a string value for the major device from the file attributes ATTRS."
(let ((fname "cpio-bin-make-dev-maj"))
(cpio-dev-maj attrs)))
(defun cpio-bin-make-dev-min (attrs)
"Return a string value for the minor device from the file attributes ATTRS."
(let ((fname "cpio-bin-make-dev-min"))
0))
(defun cpio-bin-make-rdev-maj (attrs)
"Return a string value for the major rdev from the file attributes ATTRS."
(let ((fname "cpio-bin-make-rdev-maj"))
(cpio-rdev-maj attrs)))
(defun cpio-bin-make-rdev-min (attrs)
"Return a string value for the minor rdev from the file attributes ATTRS."
(let ((fname "cpio-bin-make-rdev-min"))
0))
(defun cpio-bin-make-chksum (attrs)
"Return a string value for the bin cpio entry from the file attributes ATTRS."
(let ((fname "cpio-bin-make-chksum"))
0))
;; Filename is not one of ATTRS. ∴ It doesn't get a constructor here.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Functions for whole entries
;;
(defun cpio-bin-parse-header-at-point ()
"Parse the bin cpio header that begins at point.
If there is no header there, then signal an error."
(let ((fname "cpio-bin-parse-header-at-point"))
(unless (looking-at-p *cpio-bin-header-re*)
(error "%s(): point is not looking at a bin header." fname))
(cpio-bin-parse-header (string-as-unibyte (match-string-no-properties 0)))))
(defun cpio-bin-goto-next-header ()
"Move the point to the beginning of the next bin cpio header.
If point is looking-at such a header, then that is the next one
and there is no movement.
\(Thus, a caller may have to make sure that point has moved.\)
This returns the a marker for point where the header is found, if one is found.
It returns NIL otherwise.
This sets match-data for the entire header and each field."
(let ((fname "cpio-bin-goto-next-header")
(header-start)
(header-string))
(cond ((re-search-forward *cpio-bin-header-re* (point-max) t)
(setq header-start (goto-char (match-beginning 0)))
(setq header-string (match-string-no-properties 0))
(cons (point-marker) header-string))
(t nil))))
(defun cpio-bin-build-catalog ()
"Build an internal structure reflecting the contents of the bin cpio archive in the current buffer.
See the variable *cpio-catalog* for more information.
CAVEAT: This respects neither narrowing nor the point."
(let ((fname "cpio-bin-build-catalog")
(header-start) ;A marker.
(header-end)
(that-header-string)
(header-info ())
(parsed-header t)
(filesize) ;A marker.
(contents-start)
(contents-end) ;NOT NEEDED?
(those-contents) ;
(catalog ()))
(widen)
(goto-char (point-min))
(while (and (setq header-info (cpio-bin-goto-next-header))
(setq header-start (car header-info))
(setq that-header-string (cdr header-info))
parsed-header)
(cond ((setq parsed-header (cpio-bin-parse-header-at-point))
(setq filesize (cpio-entry-size parsed-header))
(forward-char (length that-header-string))
(setq header-end (point))
;; A little bit of arithmétic gymnastics here
;; because cpio, being written in C, starts counting at 0, but
;; emacs' points start at 1.
(goto-char (1+ (cg-round-up (1- header-end) *cpio-bin-padding-modulus*)))
(setq contents-start (point-marker))
(set-marker-insertion-type contents-start *cg-insert-after*)
;; It feels like I really want a function for getting the contents.
;; But it's not obvious what is simpler or appropriately more general
;; than this one-liner.
;; Indeed. (setq those-contents (buffer-substring-no-properties contents-start contents-end))
(push (cons (cpio-entry-name parsed-header)
(vector
parsed-header
header-start
contents-start
'cpio-mode-entry-unmodified))
catalog)
(setq contents-end (+ contents-start filesize -1))
(goto-char contents-end))
(t t)))
(nreverse catalog)))
(defun cpio-bin-start-of-trailer ()
"Return the character position of the (ostensible) start of the trailer
for the current cpio archive."
(let ((fname "cpio-bin-start-of-trailer")
(end-of-contents 0))
(mapc (lambda (ce)
(let ((attrs (cpio-entry-attrs-from-catalog-entry ce)))
(setq end-of-contents (+ (cpio-entry-size attrs) (cpio-contents-start ce)))))
*cpio-catalog*)
end-of-contents))
(defun cpio-bin-end-of-archive ()
"Calculate the location of the end of the current archive
once the TRAILER is written and padded."
(let ((fname "cpio-bin-end-of-archive")
(end-of-contents (cpio-bin-start-of-trailer)))
(cg-round-up (+ end-of-contents (length *cpio-bin-trailer*)) 512)))
(defun cpio-bin-adjust-trailer ()
"Replace thed current trailer in the current cpio bin archive."
(let* ((fname "cpio-bin-adjust-trailer"))
(cpio-bin-delete-trailer)
(cpio-bin-insert-trailer)))
(defun cpio-bin-insert-trailer ()
"Insert a bin trailer into a cpio archive."
(let* ((fname "cpio-bin-insert-trailer")
(base-trailer *cpio-bin-trailer*)
(base-len (length base-trailer))
(len))
;; ...and insert the new trailer...
(with-writable-buffer
(insert base-trailer)
(goto-char (point-max))
;; ...with padding.
(setq len (cg-round-up (1- (point)) *cpio-bin-blocksize*))
(setq len (1+ (- len (point))))
(insert (make-string len ?\0)))))
(defun cpio-bin-delete-trailer ()
"Delete the trailer in the current cpio bin archive."
(let ((fname "cpio-bin-delete-trailer"))
(unless (eq major-mode 'cpio-mode)
(error "%s(): Called outside of a cpio archive buffer." fname))
;; First, get to the end of the last entry in the archive.
(goto-char (point-min))
(mapc (lambda (e)
(let* ((ename (car e)) ;Isn't there a generic function for this?
(attrs (cpio-entry-attrs ename))
;; Fencepost issue here.
(entry-end (+ (cpio-contents-start ename)
(cpio-entry-size attrs))))
(goto-char entry-end)
(skip-chars-forward "\0")))
*cpio-catalog*)
;; Next, delete what's left...
(with-writable-buffer
(delete-region (point) (point-max)))))
(defun cpio-bin-make-chcksum-for-file (filename)
"Return the checksum for FILENAME."
(let ((fname "cpio-newc-make-chcksum-for-file"))
0))
;;
;; Commands
;;
(provide 'cpio-bin)
;;; cpio-bin.el ends here.
cpio-mode-0.17.0.20211211.193556/cpio-mode.el 0000644 0001752 0001753 00000213477 14155344264 015773 0 ustar elpa elpa ;;; cpio-mode.el --- Handle cpio archives in the style of dired. -*- coding: utf-8 -*-
;; Author: Douglas Lewan
;; Maintainer: Douglas Lewan
;; Version: 0.17
;; Long description: cpio-mode provides a dired-like interface for working with cpio archives. You can view, edit and save entries. You can also change permissions, UID, etc.
;; Package-Requires: ((emacs "24.5"))
;; Created: 2015 Jan 03
;; Package-Type: multi
;; Keywords: files
;; Copyright © 2019-2020 Free Software Foundation, Inc.
;; All rights reserved.
;;
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see .
;;; Commentary:
;; This package implements cpio-mode,
;; a mode for working with cpio archives
;; through a dired-like interface.
;;; Documentation:
;;
;; NAME: cpio-mode
;;
;; USAGE:
;; There are several ways to invoke cpio-mode:
;;
;; • M-x cpio-mode
;;
;; • If you want to put a cpio-archive into cpio-mode automatically,
;; then add the following to your .emacs:
;; (add-hook 'find-file-hook #'cpio-mode-find-file-hook)
;;
;; • Another way to do this would be to modify magic-mode-alist
;; (add-to-list 'magic-mode-alist
;; (cons #'cpio-discern-archive-type #'cpio-mode))
;;
;; • If you only care about archives that end .cpio,
;; then the following would also work:
;; (add-to-list 'auto-mode-alist (cons "\\.cpio\\'" #'cpio-mode))
;;
;; DESCRIPTION:
;; cpio-mode presents a cpio archive as if it were a directory
;; in a manner like dired-mode.
;; tar-mode already does such a thing for tar archives,
;; and some ideas (and likely code) have been adapted from tar-mode.
;;
;; To automatically invoke cpio-mode when finding a file
;; add the following to your find-file-hook.
;;
;; You can use toggle-cpio-mode to switch between cpio-mode
;; and fundamental mode.
;;
;; KEYMAP:
;; This should be conceptually as close to dired as I can make it.
;;
;; OPTIONS:
;;
;; ENVIRONMENT:
;; Early development was done under emacs 24.2
;; on the Fedora 18 distribution of 64 bit GNU/Linux.
;;
;; Later development happened under emacs 24.5
;; on GNU/Linux Mint, Linux kernel 4.4.0.
;;
;; Current development is happening on emacs 24.5
;; on GNU/Linux Trisquel, Linux Kernel 4.4.0.
;;
;; RETURN CODE:
;;
;; NOTES:
;; Binary formats are not yet implemented.
;;
;; CAVEATS:
;; Only regular files can be edited.
;; I'm not sure what to do with symbolic links yet.
;;
;; SECURITY ISSUES:
;; There are no ownership/group-ship tests on anything.
;; You could create an archive with bad behavior
;; (for example, a set-uid executable)
;; when unpacked by root.
;;
;;
;; cpio-mode.el is the entry point to all of cpio-mode code.
;; It defines the archive management variables and functions
;; that define cpio-mode.
;; That said, there are other components.
;; 1. There's some generically useful code
;; defined in
;; • cpio-generic.el, truly generic code,
;; • cpio-modes.el, file-mode related information,
;; 2. Every archive format has its own file:
;; cpio-bin for the cpio binary format,
;; cpio-crc for the cpio CRC format,
;; etc.
;; 3. cpio-mode.el, this file, defining the cpio logic
;; reflected in the catalog,
;; a list of the information of all the headers
;; in the current archive.
;; 4. The package cpio-dired, defining the user interface.
;;
;; The following figure shows the relationships
;; among those components.
;;
;; +----------------------+ +-------------+ +-------------+
;; | Format specific code | | | | |
;; | +---------------+ | | | | |
;; | | cpio-bin | | | | | |
;; | | +--------------+ | | CPIO | | dired-like |
;; | +-|cpio-crc | |<->| Logic |<->| UI |
;; | | +-------------+ | | | | |
;; | +-| hpbin | | | | | |
;; | | +------------+ | | | | |
;; | +-| ··· | | | | | |
;; | +------------+ | | | | |
;; +----------------------+ +-------------+ +-------------+
;; Λ Λ Λ
;; | | |
;; V V V
;; +----------------------------------------------------------+
;; | generic code |
;; | +------------+ +--------------+ +-----+ |
;; | | cpio-modes | | cpio-generic | | ··· | |
;; | +------------+ +--------------+ +-----+ |
;; +----------------------------------------------------------+
;;
;; The basic idea is that the format-spedific code parses and makes headers
;; while all the cpio logic uses those parsed headers to edit
;; and calls format-specific parsing and making functions.
;;
;; The main data structures are the following.
;;
;; 0. Parsed headers, an inode-like array structure.
;;
;; 1. Entries, an array containing a parsed header,
;; the header start and the contents start.
;;
;; 2. The catalog, a list of the entries in the cpio archive,
;; including the trailer.
;;
;; 3. The buffer holding the archive.
;; This buffer is put into cpio-mode.
;; It holds all the "global" data,
;; like the catalog described above.
;;
;; 4. The buffer holding the dired-like UI.
;; cpio-mode creates this buffer and
;; puts this buffer into cpio-dired-mode.
;;
;; 5. Buffers visiting entries.
;; cpio-dired-mode uses the archive buffer
;; to get entry contents and them in the visiting buffer.
;; cpio-dired-mode puts that buffer in cpio-entry-contents-mode,
;; a minor mode that handles editing and saving
;; an entry's contents.
;;; Naming conventions.
;;
;; All files that define cpio-mode begin with "cpio."
;;
;; Global variables all begin '*cpio-...'.
;; Functions are named 'cpio-...'.
;;
;; The corresponding archive format specific names for format FMT
;; begin '*cpio-FMT-...' and 'cpio-FMT-...'.
;; The format-specific variables names are calculated
;; in (cpio-set-local-vars).
;; That function drops directly into corresponding format-specific functions
;;
;; The format-specific function names are calculated
;; in (cpio-set-local-funcs).
;; Here is the process:
;; cpio-do-good-stuff-func
;; --> "cpio-do-good-stuff-func"
;; --> "cpio" "do" "good" "stuff"
;; --> "cpio-fmt-do-good-stuff"
;; --> cpio-fmt-do-good-stuff
;;
;; The index of FIELD within a parsed header is named 'cpio-FIELD-parsed-idx'.
;;
;; Each archive format FMT has a regular expression
;; that identifies that format unambiguously called '*cpio-FMT-header-re*'.
;;
;; The functions (cpio-get-FIELD) operate directly on the header
;; to extract FIELD.
;; It's not clear that these need to be defined here.
;;
;; The functions (cpio-FIELD) operate on a parsed header
;; to extract FIELD.
;;
;; Depending on the context the expression "entry attributes",
;; often abbreviated "attrs", and the phrase "parsed header"
;; are used to reference the structure
;; that stores inode-like information (mode, size, user, etc.).
;; Truly, the expressions are semantically equivalent.
;; However, "parsed header" is used where the topic at hand is
;; the archive, and
;; "entry attributes" is used where the topic at hand is
;; the internal processing within cpio-mode.
;;
;; An "entry" is, somewhat ambiguously, either an entry in the archive
;; or a member of the catalog.
;; The context should make it clear which is intended.
;; Yes, in principle they're isomorphic.
;; (And, yes, I hate specifications that depend on context.)
;;
;;; Code:
;;
;; Dependencies
;;
(require 'dired)
(require 'cpio-generic)
(require 'cpio-modes)
(require 'cpio-affiliated-buffers)
(require 'cpio-bin)
;; While I like things to be alphabetical, newc /must/ precede crc.
(require 'cpio-newc)
(require 'cpio-crc)
(require 'cpio-hpbin)
(require 'cpio-hpodc)
(require 'cpio-odc)
(require 'cpio-dired)
;; (require 'cpio-entry-contents-mode) ;;FIXME: missing file?
;; Formats not supported:
;; (require 'cpio-tar)
;; (require 'cpio-ustar)
;;;;;;;;;;;;;;;;
;; Things to make the byte compiler happy.
(defvar *cpio-catalog-entry-attrs-idx*)
(defvar *cpio-catalog-entry-contents-start-idx*)
(defvar *cpio-catalog-entry-header-start-idx*)
(defvar *cpio-catalog-entry-length*)
(defvar *cpio-catalog-entry-modified-flag-idx*)
(defvar *cpio-chksum-parsed-idx*)
(defvar *cpio-crc-header-re*)
(defvar *cpio-crc-padding-char*)
(defvar *cpio-crc-padding-modulus*)
(defvar *cpio-crc-padding-str*)
(defvar *cpio-dev-maj-parsed-idx*)
(defvar *cpio-dev-min-parsed-idx*)
(defvar *cpio-entry-size-parsed-idx*)
(defvar *cpio-gid-parsed-idx*)
(defvar *cpio-ino-parsed-idx*)
(defvar *cpio-mode-parsed-idx*)
(defvar *cpio-mtime-parsed-idx*)
(defvar *cpio-name-parsed-idx*)
(defvar *cpio-namesize-parsed-idx*)
(defvar *cpio-newc-header-re*)
(defvar *cpio-newc-padding-char*)
(defvar *cpio-newc-padding-modulus*)
(defvar *cpio-newc-padding-str*)
(defvar *cpio-nlink-parsed-idx*)
(defvar *cpio-odc-header-re*)
(defvar *cpio-odc-padding-char*)
(defvar *cpio-odc-padding-modulus*)
(defvar *cpio-odc-padding-str*)
(defvar *cpio-parsed-header-length*)
(defvar *cpio-rdev-maj-parsed-idx*)
(defvar *cpio-rdev-min-parsed-idx*)
(defvar *cpio-uid-parsed-idx*)
(defvar cpio-entry-name)
(defvar cpio-try-names)
;;;; (declare-function cpio-contents-buffer-name "cpio-dired.el")
(declare-function cpio-dired-buffer-name "cpio-dired.el")
(declare-function cpio-dired-move-to-first-entry "cpio-dired.el")
(declare-function cpio-dired-next-line "cpio-dired.el")
(declare-function cpio-entry-contents-mode "cpio-entry-contents-mode.el") ;FIXME: Unused!
(declare-function cpio-present-ala-dired "cpio-dired.el")
;; EO things for the byte compiler.
;;;;;;;;;;;;;;;;
;;
;; Vars
;;
(defvar *cpio-format* ()
"The format of the cpio archive in the current-buffer.
Takes the values 'bin, 'newc, 'odc etc.")
(setq *cpio-format* ())
(make-variable-buffer-local '*cpio-format*)
;; N.B. The format REs go here since they are what we use
;; to discern the type of the archive.
(defvar *cpio-tar-header-re* "not yet set"
"RE to match tar format cpio archives.")
(setq *cpio-tar-header-re* "not yet set")
(defvar *cpio-ustar-header-re* "not yet set"
"RE to match ustar format cpio archives.")
(setq *cpio-ustar-header-re* "not yet set")
(defvar *cpio-hpbin-header-re* "not yet set"
"RE to match hpbin format cpio archives.")
(setq *cpio-hpbin-header-re* "not yet set")
(defvar *cpio-hpodc-header-re* "not yet set"
"RE to match hpodc format cpio archives.")
(setq *cpio-hpodc-header-re* "not yet set")
;; MAINTENTANCE Order matters; hpodc must precede odc.
(defvar *cpio-re-type-alist* (list
(cons *cpio-bin-header-re* 'bin)
(cons *cpio-crc-header-re* 'crc)
(cons *cpio-hpbin-header-re* 'hpbin)
(cons *cpio-hpodc-header-re* 'hpodc)
(cons *cpio-newc-header-re* 'newc)
(cons *cpio-odc-header-re* 'odc)
(cons *cpio-tar-header-re* 'tar)
(cons *cpio-ustar-header-re* 'ustar))
"Association list matching REs defining cpio entry header types
with their corresponding archive types.
The archive types are symbols: 'bin, 'newc, 'odc, etc.
See `cpio-discern-archive-type' for the full list.")
(setq *cpio-re-type-alist* (list
(cons *cpio-bin-header-re* 'bin)
(cons *cpio-crc-header-re* 'crc)
(cons *cpio-hpbin-header-re* 'hpbin)
(cons *cpio-hpodc-header-re* 'hpodc)
(cons *cpio-newc-header-re* 'newc)
(cons *cpio-odc-header-re* 'odc)
(cons *cpio-tar-header-re* 'tar)
(cons *cpio-ustar-header-re* 'ustar)))
(defvar cpio-build-catalog-func ()
"The function for building the catalog of a specific archive format.")
(setq cpio-build-catalog-func ())
(defvar cpio-parse-header-func ()
"")
(setq cpio-parse-header-func ())
(defvar cpio-header-at-point-func ()
"")
(setq cpio-header-at-point-func ())
(defvar OBS-cpio-get-magic-func ()
"")
(setq OBS-cpio-get-magic-func ())
(defvar OBS-cpio-get-ino-func ()
"")
(setq OBS-cpio-get-ino-func ())
(defvar OBS-cpio-get-mode-func ()
"")
(setq OBS-cpio-get-mode-func ())
(defvar OBS-cpio-get-uid-func ()
"")
(setq OBS-cpio-get-uid-func ())
(defvar OBS-cpio-get-gid-func ()
"")
(setq OBS-cpio-get-gid-func ())
(defvar OBS-cpio-get-nlink-func ()
"")
(setq OBS-cpio-get-nlink-func ())
(defvar OBS-cpio-get-mtime-min-func ()
"")
(setq OBS-cpio-get-mtime-min-func ())
(defvar OBS-cpio-get-filesize-func ()
"")
(setq OBS-cpio-get-filesize-func ())
(defvar OBS-cpio-get-dev-maj-func ()
"")
(setq OBS-cpio-get-dev-maj-func ())
(defvar OBS-cpio-get-dev-min-func ()
"")
(setq OBS-cpio-get-dev-min-func ())
(defvar OBS-cpio-get-rdev-maj-func ()
"")
(setq OBS-cpio-get-rdev-maj-func ())
(defvar OBS-cpio-get-rdev-min-func ()
"")
(setq OBS-cpio-get-rdev-min-func ())
(defvar OBS-cpio-get-namesize-func ()
"")
(setq OBS-cpio-get-namesize-func ())
(defvar OBS-cpio-get-chksum-func ()
"")
(setq OBS-cpio-get-chksum-func ())
(defvar OBS-cpio-get-name-func ()
"")
(setq OBS-cpio-get-name-func ())
(defvar OBS-cpio-get-contents-func ()
"")
(setq OBS-cpio-get-contents-func ())
(defvar cpio-make-header-string-func ()
"")
(setq cpio-make-header-string-func ())
(defvar cpio-adjust-trailer-func ()
"")
(defvar cpio-insert-trailer-func ()
"")
(defvar cpio-delete-trailer-func ()
"")
(defvar cpio-make-chksum-for-file-func ()
"")
(defvar *cpio-local-funcs* ()
"A list of variables peculiar to the different headers and their fields.
The design here is that package-wide variables have the prefix `cpio-'
and the corresponding functions for a specific format FMT have the form `cpio-FMT-'.
All of this can then be calculated via (symbol-name), etc.")
(setq *cpio-local-funcs* (list
;; Catalog management
'cpio-build-catalog-func
'cpio-make-chksum-for-file-func
;; Header parsing functions
'cpio-end-of-archive-func
'cpio-start-of-trailer-func
;; Header making functions
'cpio-make-chksum-func
'cpio-make-header-string-func
;; Archive manipulation functions
'cpio-adjust-trailer-func
'cpio-insert-trailer-func
'cpio-delete-trailer-func))
;; (make-variable-buffer-local '*cpio-local-funcs*)
(defvar *cpio-catalog* ()
"The variable that holds the catalog of entries in cpio-mode.
Each entry has the following form:
name
[parsed-header
header-start
content-start
modified-flag].
• name is the name of the entry
• parsed-header has the description below.
• header-start and content-start are markers,
so they should be automatically updated
with modifications to the buffer.
• Don't use (aref) to get at these; use an accessor function.
The last entry should is always be the TRAILER entry.
A parsed header is a vector of the following form:
[inode
mode
uid
gid
nlink
mtime
filesize
dev-maj
dev-min
rdev-maj
rdev-min
name-size
chksum
name].")
(make-variable-buffer-local '*cpio-catalog*)
(setq *cpio-catalog* ())
(let ((i 0))
;; (defvar *cpio-catalog-entry-name-idx* i)
;; (setq i (1+ i))
(defvar *cpio-catalog-entry-attrs-idx* i)
(setq *cpio-catalog-entry-attrs-idx* i)
(setq i (1+ i))
(defvar *cpio-catalog-entry-header-start-idx* i)
(setq *cpio-catalog-entry-header-start-idx* i)
(setq i (1+ i))
(defvar *cpio-catalog-entry-contents-start-idx* i)
(setq *cpio-catalog-entry-contents-start-idx* i)
(setq i (1+ i))
(defvar *cpio-catalog-entry-modified-flag-idx* i)
(setq *cpio-catalog-entry-modified-flag-idx* i)
(setq i (1+ i))
(defvar *cpio-catalog-entry-length* i)
(setq *cpio-catalog-entry-length* i))
(defvar *cpio-archive-name* ()
"The name of the cpio archive being processed.")
(setq *cpio-archive-name* ())
(make-variable-buffer-local '*cpio-archive-names*)
;; Indexes for the fields in a parsed header.
(let ((i 0))
(defvar *cpio-ino-parsed-idx* i)
(setq *cpio-ino-parsed-idx* i)
(setq i (1+ i))
(defvar *cpio-mode-parsed-idx* i)
(setq *cpio-mode-parsed-idx* i)
(setq i (1+ i))
(defvar *cpio-uid-parsed-idx* i)
(setq *cpio-uid-parsed-idx* i)
(setq i (1+ i))
(defvar *cpio-gid-parsed-idx* i)
(setq *cpio-gid-parsed-idx* i)
(setq i (1+ i))
(defvar *cpio-nlink-parsed-idx* i)
(setq *cpio-nlink-parsed-idx* i)
(setq i (1+ i))
(defvar *cpio-mtime-parsed-idx* i)
(setq *cpio-mtime-parsed-idx* i)
(setq i (1+ i))
(defvar *cpio-entry-size-parsed-idx* i)
(setq *cpio-entry-size-parsed-idx* i)
(setq i (1+ i))
(defvar *cpio-dev-maj-parsed-idx* i)
(setq *cpio-dev-maj-parsed-idx* i)
(setq i (1+ i))
(defvar *cpio-dev-min-parsed-idx* i)
(setq *cpio-dev-min-parsed-idx* i)
(setq i (1+ i))
(defvar *cpio-rdev-maj-parsed-idx* i)
(setq *cpio-rdev-maj-parsed-idx* i)
(setq i (1+ i))
(defvar *cpio-rdev-min-parsed-idx* i)
(setq *cpio-rdev-min-parsed-idx* i)
(setq i (1+ i))
(defvar *cpio-namesize-parsed-idx* i)
(setq *cpio-namesize-parsed-idx* i)
(setq i (1+ i))
(defvar *cpio-chksum-parsed-idx* i)
(setq *cpio-chksum-parsed-idx* i)
(setq i (1+ i))
(defvar *cpio-name-parsed-idx* i)
(setq *cpio-name-parsed-idx* i)
(setq i (1+ i))
(defvar *cpio-parsed-header-length* i
"The length of a parsed header (attribute vector).")
(setq *cpio-parsed-header-length* i))
(defvar *cpio-padding-modulus* ()
"The modulus to be used for building padded strings.")
(setq *cpio-padding-modulus* ())
(defvar *cpio-padding-char* ()
"The character to be used for building padded strings.")
(setq *cpio-padding-char* ())
(defvar *cpio-padding-str* ()
"A single character string of the character to be used for building padded strings.")
(setq *cpio-padding-str* ())
(defvar *cpio-archive-syntax-table* ()
"Every character in a cpio archive has word syntax.")
(setq *cpio-archive-syntax-table* ())
(defvar *cpio-header-length* ()
"A buffer-local variable to hold the length of the header
for a cpio archive of the current format.")
(setq *cpio-header-length* ())
;;
;; Customizations
;;
(defgroup cpio ()
"Customizations for cpio-mode."
:group 'data)
(defcustom cpio-default-format "newc"
"The default cpio format to use for a new or empty archive."
:type 'string
:group 'cpio)
;;
;; Library
;;
;;;###autoload
(defun cpio-mode-find-file-hook ()
"find-file hook to detect if a file is likely a cpio archive.
If it is, then put it under cpio-mode."
(let ((fname "cpio-mode-find-file-hook"))
(if (cpio-discern-archive-type)
(cpio-mode))))
;;;###autoload
(defun cpio-discern-archive-type ()
"Return a symbol reflecting the type of the cpio archive in the current buffer.
Values are `bin', `newc', `odc', `crc', `tar', `ustar', `hpbin', `hpodc',
or nil if the current buffer does not begin with a cpio entry header."
;; Using a RE may not be the right way to go.
;; Maybe each format needs a function.
(let ((fname "cpio-discern-archive-type")
(this-archive-type ()))
(unless *cpio-archive-syntax-table*
(setq *cpio-archive-syntax-table* (make-syntax-table))
(let ((i 0))
(while (< i #x100)
(modify-syntax-entry i "w" *cpio-archive-syntax-table*)
(setq i (1+ i)))))
(with-syntax-table *cpio-archive-syntax-table*
(save-excursion
(widen)
(goto-char (point-min))
(catch 'found-it
(mapc (lambda (archive-spec)
(cond ((looking-at-p (car archive-spec))
(setq this-archive-type (cdr archive-spec))
(throw 'found-it t))
(t t)))
*cpio-re-type-alist*))))
this-archive-type))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Header handling
;; HEREHERE I think all these (funcall)s need to be wrapped with *s.
(defun cpio-parse-header (header-str)
"Return the internal entry header structure encoded in HEADER-STR."
(let ((fname "cpio-parse-header"))
(funcall cpio-parse-header-func header-str)))
(defun OBS-cpio-header-at-point (&optional where)
"Return the header string at or following point WHERE.
If WHERE is not given, then use point.
CAVEAT: This searches for the magic number at the begining of the header;
if WHERE is inside the magic number, then the search will fail."
(unless where (setq where (point)))
(let ((fname "cpio-header-at-point"))
(funcall cpio-header-at-point-func where)))
(defun cpio-ino (parsed-header)
"Return the inode in PARSED-HEADER.
CAVEAT: See `cpio-magic'."
(let ((fname "cpio-ino"))
(aref parsed-header *cpio-ino-parsed-idx*)))
(defun cpio-mode-value (parsed-header)
"Return the mode (as an integer) in PARSED-HEADER.
CAVEAT: See `cpio-magic'."
(let ((fname "cpio-mode"))
(aref parsed-header *cpio-mode-parsed-idx*)))
(defun cpio-uid (parsed-header)
"Return the UID (as an integer) in PARSED-HEADER.
CAVEAT: See `cpio-magic'."
(let ((fname "cpio-uid"))
(aref parsed-header *cpio-uid-parsed-idx*)))
(defun cpio-gid (parsed-header)
"Return the GID (as an integer) in PARSED-HEADER.
CAVEAT: See `cpio-magic'."
(let ((fname "cpio-gid"))
(aref parsed-header *cpio-gid-parsed-idx*)))
(defun cpio-nlink (parsed-header)
"Return the number of links in PARSED-HEADER.
CAVEAT: See `cpio-magic'."
(let ((fname "cpio-nlink"))
(aref parsed-header *cpio-nlink-parsed-idx*)))
(defun cpio-mtime (parsed-header)
"Return the mod time (emacs time structure) in PARSED-HEADER.
CAVEAT: See `cpio-magic'."
(let ((fname "cpio-mtime"))
(aref parsed-header *cpio-mtime-parsed-idx*)))
(defun cpio-entry-size (parsed-header)
"Return the size of the contents in PARSED-HEADER.
CAVEAT: See `cpio-magic'."
(let ((fname "cpio-entry-size"))
(aref parsed-header *cpio-entry-size-parsed-idx*)))
(defun cpio-dev-maj (parsed-header)
"Return the dev maj in PARSED-HEADER.
CAVEAT: See `cpio-magic'."
(let ((fname "cpio-dev"))
(aref parsed-header *cpio-dev-maj-parsed-idx*)))
(defun cpio-dev-min (parsed-header)
"Return the dev in PARSED-HEADER.
CAVEAT: See `cpio-magic'."
(let ((fname "cpio-dev-min"))
(aref parsed-header *cpio-dev-min-parsed-idx*)))
(defun cpio-rdev-maj (parsed-header)
"Return the rdev maj in PARSED-HEADER.
CAVEAT: See `cpio-magic'."
(let ((fname "cpio-rdev-maj"))
(aref parsed-header *cpio-rdev-maj-parsed-idx*)))
(defun cpio-rdev-min (parsed-header)
"Return the rdev in PARSED-HEADER.
CAVEAT: See `cpio-magic'."
(let ((fname "cpio-rdev-min"))
(aref parsed-header *cpio-rdev-min-parsed-idx*)))
(defun cpio-namesize (parsed-header)
"Return the size of the name in PARSED-HEADER.
CAVEAT: See `cpio-magic'."
(let ((fname "cpio-namesize"))
(aref parsed-header *cpio-namesize-parsed-idx*)))
(defun cpio-entry-name (parsed-header)
"Return the name in PARSED-HEADER.
CAVEAT: See `cpio-magic'."
(let ((fname "cpio-name"))
(aref parsed-header *cpio-name-parsed-idx*)))
(defun cpio-chksum (parsed-header)
"Return the checksum in PARSE-HEADER."
(let ((fname "cpio-chksum"))
(aref *cpio-chksum-parsed-idx* parsed-header)))
(defun cpio-contents-start (entry-name)
"Return the contents start for ENTRY-NAME."
(let ((fname "cpio-contents-start")
(catalog-entry (cpio-entry entry-name)))
(aref catalog-entry *cpio-catalog-entry-contents-start-idx*)))
(defun cpio-entry-attrs (entry-name)
"Retrieve the entry attributes for ENTRY-NAME."
(let ((fname "cpio-entry-attrs"))
(if *cab-parent*
(with-current-buffer *cab-parent*
(cpio-entry-attrs entry-name))
(aref (cpio-entry entry-name) *cpio-catalog-entry-attrs-idx*))))
(defun cpio-entry-header-start (entry)
"Return the start of the entry specified in ENTRY."
(let ((fname "cpio-entry-header-start"))
(aref entry *cpio-catalog-entry-header-start-idx*)))
;; HEREHERE This isn't right yet.
;; It's being introduced to fix the acrobatics in (cpio-internal-do-deletion).
(defun cpio-entry-header-end (entry)
"Return the end of the unpadded header specified in ENTRY."
(let ((fname "cpio-entry-header-end")
(attrs (aref entry *cpio-catalog-entry-attrs-idx*)))
(+ (cpio-entry-header-start entry) *cpio-header-length* (cpio-namesize attrs))
))
(defun cpio-entry-contents-start (entry)
"Return the start of the contents of the entry specified in ENTRY."
(let ((fname "cpio-entry-contents-start"))
(aref entry *cpio-catalog-entry-contents-start-idx*)))
(defun cpio-entry-contents-end (entry)
"Return the end of the contents of the entry specified in ENTRY."
(let* ((fname "cpio-entry-contents-end")
(attrs (aref entry *cpio-catalog-entry-attrs-idx*))
(entry-name (cpio-entry-name attrs)))
(+ (cpio-entry-contents-start entry)
(cpio-entry-size attrs))))
(defun cpio-set-header-start (entry where)
"Set the header start marker in ENTRY to the location WHERE."
(let ((fname "cpio-set-header-start")
(where-marker (cond ((integerp where)
(set-marker (make-marker) where))
((markerp where)
where)
(t
(signal 'wrong-type-error (list where))))))
(aset entry *cpio-catalog-entry-header-start-idx* where-marker)))
(defun cpio-set-contents-start (entry where)
"Set the contents start marker in ENTRY to the location WHERE.
WHERE can be an integer or marker."
(let ((fname "cpio-set-contents-start")
(where-marker (cond ((integerp where)
(set-marker (make-marker) where))
((markerp where)
where)
(t
(signal 'wrong-type-error (list where))))))
(aset entry *cpio-catalog-entry-contents-start-idx* where-marker)))
(defun cpio-contents (entry-name &optional archive-buffer)
"Return a string that is the contents of the named entry."
(let ((fname "cpio-contents"))
(cond (archive-buffer
(with-current-buffer archive-buffer
(cpio-contents entry-name)))
(*cab-parent*
(with-current-buffer *cab-parent*
(cpio-contents entry-name)))
((eq major-mode 'cpio-mode)
(let* ((entry-attrs (cpio-entry-attrs entry-name))
(contents-start (cpio-contents-start entry-name))
(contents-size (cpio-entry-size entry-attrs))
(contents-end (+ contents-start contents-size))
(result))
(if (null entry-attrs)
(error "%s(): Could not get entry attributes for [[%s]]." fname entry-name))
(goto-char contents-start)
(forward-char contents-size)
(setq result (buffer-substring-no-properties contents-start contents-end))))
(t
(error "%s(): Could not find the archive buffer." fname)))))
(defun cpio-catalog ()
"Return the catalog relevant to the current buffer."
(let ((fname "cpio-catalog"))
(unless (or (eq major-mode 'cpio-dired-mode)
(eq major-mode 'cpio-mode))
(error "%s(): only makes sense in a cpio buffer." fname))
(if *cab-parent*
(with-current-buffer *cab-parent*
*cpio-catalog*)
*cpio-catalog*)))
(defun cpio-make-header-string (parsed-header &optional contents)
"Build a padded cpio header string based on the given PARSED-HEADER."
(let ((fname "cpio-make-header-string"))
(funcall cpio-make-header-string-func parsed-header contents)))
(defun cpio-set-entry-size (parsed-header size)
"Set the entry-size element of PARSED-HEADER to SIZE."
(let ((fname "cpio-set-entry-size"))
(aset parsed-header *cpio-entry-size-parsed-idx* size)))
(defun cpio-set-entry-name (parsed-header entry-name)
"Set the entry-name element of the PARSED-HEADER to ENTRY-NAME.
To be consistent, this also sets the name's size element."
(let ((fname "cpio-set-entry-name"))
(aset parsed-header *cpio-name-parsed-idx* entry-name)
;; The namesize in the header includes the terminating NULL at the end of the name.
;; See, for example, (cpio-newc-header-size).
(aset parsed-header *cpio-namesize-parsed-idx* (1+ (length entry-name)))))
(defun cpio-set-uid (parsed-header uid)
"Set the uid field in the PARSED-HEADER to UID.
UID can be either a string (representing a number)
or an integer."
(let ((fname "cpio-set-uid"))
(unless (integerp uid)
(setq uid (string-to-number uid)))
(aset parsed-header *cpio-uid-parsed-idx* uid)))
(defun cpio-set-gid (parsed-header gid)
"Set the gid field in the PARSED-HEADER to GID.
GID can be either a string (representing a number)
or an integer."
(let ((fname "cpio-set-gid"))
(unless (integerp gid)
(setq gid (string-to-number gid)))
(aset parsed-header *cpio-gid-parsed-idx* gid)))
(defun cpio-set-mode (parsed-header mode)
"Set the mode field in the PARSED-HEADER to MODE.
MODE is either an integer or a string representing an integer."
(let ((fname "cpio-set-mode")
(integer-mode (cond ((integerp mode)
mode)
((stringp mode)
(string-to-number mode))
(t
(signal 'wrong-type-error (list mode))))))
(unless (cpio-valid-numeric-mode integer-mode)
(error "%s(): Invalid mode [[%s]]." fname mode))
(aset parsed-header *cpio-mode-parsed-idx* integer-mode)))
(defun cpio-set-mtime (parsed-header mtime)
"Set the modification time in the PARSED-HEADER to MTIME.
MTIME is an emacs time."
(let ((fname "cpio-set-mtime"))
(if (fboundp 'time-convert)
(setq mtime (time-convert mtime 'list)))
(aset parsed-header *cpio-mtime-parsed-idx* mtime)))
(defun cpio-extract-all ()
"Extract all entries from the cpio archive related to the current buffer."
(let ((fname "cpio-extract-all"))
(if *cab-parent*
(with-current-buffer *cab-parent*
(cpio-extract-all))
(mapc (lambda (e)
(let ((entry-name (car e)))
(cpio-extract-entry entry-name)))
*cpio-catalog*))))
(defun cpio-ask-user-about-supersession-threat (entry-name)
"Ask a user who is trying to save ENTRY-NAME what to do
if a file named ENTRY-NAME already exists
or if there is a modified buffer containing that entry's contents."
(let* ((fname "cpio-ask-user-about-supersession-threat")
(intermediate-buffer-name (cpio-contents-buffer-name entry-name))
(intermediate-buffer (get-buffer intermediate-buffer-name))
(archive-mod-time (cpio-get-archive-mod-time)) ;HEREHERE Do I want this?
(entry-mod-time (cpio-mtime (cpio-entry-attrs entry-name))))
(cond ((and (buffer-live-p intermediate-buffer)
(buffer-modified-p intermediate-buffer)
(yes-or-no-p (format "A buffer for entry %s exists and is modified. Save? " entry-name)))
t)
((and (file-exists-p entry-name)
(yes-or-no-p (format "File %s already exists. Overwrite? " entry-name)))
t)
(t t))))
(defun cpio-get-archive-mod-time ()
"Return the modification time of the cpio archive affiliated with the current buffer."
(let ((fname "cpio-get-archive-mod-time")
(archive-buffer (if *cab-parent*
*cab-parent*
(current-buffer))))
(with-current-buffer archive-buffer
(message "%s(): is not implemented." fname))))
(defun cpio-extract-entry (entry-name &optional force)
"Extract the archive entry ENTRY-NAME.
If that file already exists (and this is called interactively),
then prompt the user about overwriting it.
If a buffer is already visiting that entry,
then leave that buffer in place;
otherwise kill the intermediate buffer.
The optional argument FORCE indicates
if this was called from a lisp program.
If it is, then the extraction occurs no matter what.
CAVEAT: Extracting the same ENTRY-NAME from different archives
will create a conflict.
CONTRACT: This can only be invoked in a cpio archive under cpio-mode
or a buffer affiliated with such a buffer.
NOTE: FORCE is not currently used anywhere in cpio-mode.
It is present so that any applications that are built on cpio-mode
can have predictable results."
(interactive "sName: \nP")
(let ((fname "cpio-extract-entry")
(attrs (cpio-entry-attrs entry-name))
;; HEREHERE Would this be noticably more efficient
;; with (cpio-numeric-entry-type)?
(entry-type (cpio-entry-type entry-name)))
(cond ((string-equal entry-type *cpio-modes-link*)
(warn "%s(): Symlink extraction is not yet implemented." fname))
((string-equal entry-type *cpio-modes-reg*)
(cpio-extract-regular-file entry-name))
((string-equal entry-type *cpio-modes-dir*)
(cpio-extract-directory entry-name))
((string-equal entry-type *cpio-modes-char*)
(warn "%s(): Character special files cannot be extracted with cpio-mode." fname))
((string-equal entry-type *cpio-modes-block*)
(warn "%s(): Block special files cannot be extracted with cpio-mode." fname))
((string-equal entry-type *cpio-modes-fifo*)
(warn "%s(): FIFOs (pipes) cannot be extracted with cpio-mode." fname))
((string-equal entry-type *cpio-modes-sock*)
(warn "%s(): Sockets cannot be extracted with cpio-mode." fname))
((string-equal entry-type *cpio-modes-unknown*)
(warn "%s(): Unknown entry type -- not extracting." fname))
(t (error "%s(): Impossible condition." fname)))))
(defun cpio-extract-regular-file (entry-name &optional from-lisp)
"Extract the regular file entry ENTRY-NAME.
CONTRACT: ENTRY-NAME is in fact an entry of a regular file."
(let* ((fname "cpio-extract-regular-file")
(do-it (if from-lisp
t
(cpio-ask-user-about-supersession-threat entry-name)))
(buffer-name (cpio-contents-buffer-name entry-name))
(temp-buffer (get-buffer buffer-name))
(restore (buffer-live-p temp-buffer))
(contents)
(archive-buffer (if *cab-parent*
*cab-parent*
(current-buffer))))
(if do-it
(cond (temp-buffer
(setq contents (cpio-contents entry-name archive-buffer))
(cab-register temp-buffer archive-buffer)
(with-current-buffer temp-buffer
(insert contents)
(write-file entry-name))
(unless restore (kill-buffer temp-buffer)))
(t
(with-temp-buffer
(insert (cpio-contents entry-name archive-buffer))
(write-file entry-name)
(unless restore (kill-buffer temp-buffer)))
(cpio-set-file-attrs entry-name))))))
(defun cpio-extract-directory (entry-name)
"Extract the directory entry ENTRY-NAME.
CONTRACT: ENTRY-NAME really is a directory entry."
(let ((fname "cpio-extract-directory")
(attrs (cpio-entry-attrs entry-name)))
(make-directory entry-name t)
(cpio-set-file-attrs entry-name)))
(defun cpio-entry-type (entry-name)
"Return the type of the entry with the given ENTRY-NAME.
The type is the single character that would be displayed
in the initial mode slot of 'ls -l'.
That is, 'l' is a link, '-' is a regular file, etc.
See (cpio-int-mode-to-file-type) in cpio-modes.el for more detail.
If ENTRY-NAME is not in the current archive, then return NIL."
(let ((fname "cpio-entry-type")
(entry-attrs)
(entry-mode))
(cond ((and entry-name
(setq entry-attrs (cpio-entry-attrs entry-name))
(setq entry-mode (cpio-mode-value entry-attrs)))
(cpio-int-mode-to-file-type entry-mode))
(t nil))))
(defun cpio-numeric-entry-type (numeric-mode)
"Return the numeric entry type of the given NUMERIC MODE."
(let ((fname "cpio-numeric-entry-type"))
(cond ((= #o170000 (logand s-ifmt numeric-mode))
s-ifmt)
((= #o140000 (logand s-ifsock numeric-mode))
s-ifsock)
((= #o120000 (logand s-iflnk numeric-mode))
s-iflnk)
((/= 0 (logand s-ifreg numeric-mode))
s-ifreg)
((/= 0 (logand s-ifdir numeric-mode))
s-ifdir)
((/= s-ifblk (logand s-ifblk numeric-mode))
s-ifblk)
((/= 0 (logand s-ifchr numeric-mode))
s-ifchr)
((/= 0 (logand s-ififo numeric-mode))
s-ififo)
(t
s-ifunk))))
(defun cpio-set-file-attrs (file-name)
"Set the attributes on FILE-NAME
based on its attributes in the catalog."
(let* ((fname "cpio-set-file-attrs")
(attrs (cpio-entry-attrs file-name))
(mode-value (cpio-mode-value attrs))
(modtime (cpio-mtime attrs))
(uid (cpio-uid attrs))
(gid (cpio-gid-to-gid-string (cpio-gid attrs))))
(cpio-set-file-owner file-name uid)
(cpio-set-file-group file-name gid)
(cpio-set-file-mode file-name mode-value)
(cpio-set-file-modtime file-name modtime)))
(defun cpio-set-file-owner (file-name user) ;HEREHERE Generic?
"Change the owner of [the file] FILE-NAME to USER.
USER is an either a numeric uid or a user's name.
If USER is a string, but that user doesn't exist,
then fail and return NIL.
Otherwise return non-NIL."
(let ((fname "cpio-set-file-owner")
(uid (cond ((integerp user)
user)
((stringp user)
(cpio-uid-string-to-uid user))
(t
nil))))
(unless (file-exists-p file-name)
(error "%s(): requires the name of an existing file." fname))
(call-process "chown"
nil
nil
nil
uid
file-name)))
(defun cpio-set-file-group (file-name group) ;HEREHERE Generic?
"Change the group of [the file] FILE-NAME to group
USER is an either a numeric gid or a group's name.
If USER is a string, but that user doesn't exist,
then fail and return NIL.
Otherwise return non-NIL."
(let ((fname "cpio-set-file-group")
(gid (cond ((integerp group)
group)
((stringp group)
(cpio-gid-string-to-gid group))
(t
nil))))
(unless (file-exists-p file-name)
(error "%s(): requires the name of an existing file." fname))
(call-process "chgrp"
nil
nil
nil
gid
file-name)))
(defun cpio-set-file-mode (file-name mode) ;HEREHERE Generic?
"Set the mode of the [the file] FILE-NAME to MODE.
MODE may be a complete symbolic mode or an appropriate integer.
If FILE-NAME doesn't exist, then fail and return NIL.
If MODE is not a valid mode value (either symbolic or numeric),
then fail and return NIL."
(let ((fname "cpio-set-file-mode")
(mode-num (cond ((stringp mode)
(cpio-mode-string-to-int-mode mode))
((integerp mode)
mode)
(t
nil))))
(unless (cpio-valid-numeric-mode mode-num)
(if (integerp mode)
(error "%s(): [[%d]] is not a valid mode." fname mode-num)
(error "%s(): [[%s]] is not a valid mode." fname mode-num)))
(chmod file-name mode)))
(defun cpio-set-file-modtime (file-name mod-time) ;HEREHERE Generic?
"Set the modtime of [the file] FILE-NAME to MOD-TIME.
MOD-TIME is an emacs time."
(let ((fname "cpio-set-file-modtime")
(modtime-string (cpio-mtime-to-touch-string mod-time)))
(call-process "touch"
nil
nil
nil
"-t"
modtime-string
file-name)))
(defun cpio-mtime-to-touch-string (mtime) ;HEREHERE Generic?
"Convert the given MTIME to a time that touch(1) understands.
MTIME is an emacs time.
Touch understands times of the form YYYYMMDDhhmm.ss."
(let ((fname "cpio-mtime-to-touch-string"))
(format-time-string "%Y%m%d%M%H.%S" mtime)))
(defun cpio-adjust-trailer ()
"Replace the trailer in the current buffer
with one with the correct size fot its contents."
(let ((fname "cpio-adjust-trailer"))
(if *cab-parent*
(with-current-buffer *cab-parent*
(funcall cpio-adjust-trailer-func))
(funcall cpio-adjust-trailer-func))))
(defun cpio-insert-trailer ()
"Insert a trailer in a cpio archive."
(let ((fname "cpio-insert-trailer"))
(if *cab-parent*
(with-current-buffer *cab-parent*
(funcall cpio-insert-trailer-func))
(funcall cpio-insert-trailer-func))))
(defun cpio-delete-trailer ()
"Delete the trailer in the cpio archive buffer affiliated with the current buffer."
(let ((fname "cpio-delete-trailer"))
(if *cab-parent*
(with-current-buffer *cab-parent*
(funcall cpio-delete-trailer-func))
(funcall cpio-delete-trailer-func))))
(defun cpio-delete-archive-entry (entry)
"Delete the entry in the cpio archive specified by ENTRY.
ENTRY is a catalog entry."
(let ((fname "cpio-delete-archive-entry"))
(if *cab-parent*
(with-current-buffer *cab-parent*
(cpio-delete-archive-entry entry))
(let* ((attrs (aref entry 0))
(size (cpio-entry-size attrs))
(entry-start (cpio-entry-header-start entry))
(contents-start (cpio-contents-start (cpio-entry-name attrs)))
(entry-end (1+ (cg-round-up (+ (1- contents-start)
(cpio-entry-size attrs))
*cpio-padding-modulus*))))
(with-writable-buffer
(delete-region entry-start entry-end))))))
(defun cpio-insert-padded-header (header-string)
"Insert an appropriately padded version of HEADER-STRING.
CONTRACT: You're at the point of insertion."
(let ((fname "cpio-insert-padded-header")
(padding))
(if *cab-parent*
(with-current-buffer *cab-parent*
(cpio-insert-padded-header header-string))
(with-writable-buffer
(insert (cpio-pad header-string *cpio-padding-modulus* *cpio-padding-char*))))))
(defun cpio-insert-padded-contents (contents) ;HEREHERE Generic
"Insert an appropriately padded version of CONTENTS into the archive buffer.
CONTRACT: Point is at the point of insertion."
(let ((fname "cpio-insert-padded-contents"))
(if *cab-parent*
(with-current-buffer *cab-parent*
(cpio-insert-padded-contents contents))
(with-writable-buffer
;; (cpio-set-contents-start (point))
(insert (cpio-pad contents *cpio-padding-modulus* *cpio-padding-char*))))))
(defun cpio-sort-catalog ()
"Return a copy of the catalog sorted by entry name (car cpio-catalog-entry)."
(let ((fname "cpio-sort-catalog"))
(sort *cpio-catalog* 'cpio-entry-less-p)))
(defun cpio-entry-less-p (l r)
"Return non-nil if [the car of] entry L precedes [the car of] entry L.
CONTRACT: L and R should be entries:
(entry-name [inode mode uid ...] entry-start entry-end)."
(let ((fname "cpio-entry-less-p"))
(string-lessp (car l) (car r))))
(defun cpio-uid-to-uid-string (uid) ;; HEREHERE Generic?
"Convert the given UID, an integer, to a string,
either a user name or a string representing UID."
(let ((fname "cpio-uid-to-uid-string"))
(if cpio-try-names
(or (user-login-name uid)
(number-to-string uid))
(number-to-string uid))))
(defun cpio-uid-string-to-uid (user) ;; HEREHERE Generic?
"Return the system UID, an integer, for the string USER."
(let ((fname "cpio-uid-string-to-uid")
)
;; (error "%s() is not yet implemented" fname)
(unless (stringp user)
(signal 'wrong-type-error (list user)))
(with-temp-buffer
;; HEREHERE This clearly doesn't work on Windows.
;; Also note that it won't work on very old versions of UNIX.
;; What about MacOS?
;; What would be the right thing on other operating systems?
(insert-file-contents "/etc/passwd")
(if (re-search-forward (concat "^" user ":[^:]*:\\([0-9]+\\):" (point-max) t))
(string-to-number (match-string 1))
nil))))
(defun cpio-gid-to-gid-string (gid) ;; HEREHERE Generic?
"Convert the given GID, an integer, to a string."
(let ((fname "cpio-gid-to-gid-string"))
(if cpio-try-names
(or (user-login-name gid)
(number-to-string gid))
(number-to-string gid))))
(defun cpio-gid-string-to-gid (group) ;; HEREHERE Generic?
"Return the system gid, an integer, for the given GROUP."
(let ((fname "cpio-gid-string-to-gid"))
(unless (stringp group)
(signal 'wrong-type-error (list group)))
(with-temp-buffer
;; HEREHERE This clearly doesn't work on Windows.
;; See (cpio-uid-string-to-uid).
(insert-file-contents "/etc/group")
(if (re-search-forward (concat "^" group ":[^:]*:\\([0-9]+\\):" (point-max) t))
(string-to-number (match-string 1))
nil))))
(defun cpio-nlink-to-nlink-string (nlink)
"Convert the given NLINK, an integer, to a string."
(let ((fname "cpio-nlink-to-nlink-string"))
(number-to-string nlink)))
(defun cpio-mtime-to-mtime-string (mtime &optional long)
"Convert the given MTIME, an emacs internal time, to a string.
CAUTION: This depends on your emacs being able to handle
a UNIX/GNU/Linux time as an integer."
(let ((fname "cpio-mtime-to-mtime-string")
(six-months (* 6 30 24 60 60))
(now (time-to-seconds (current-time)))
(tmp-time (time-to-seconds mtime)))
(cond (long
(format-time-string "%F %T" mtime))
((< (- now tmp-time) six-months)
(format-time-string "%b %d %H:%M" mtime))
(t
(format-time-string "%b %d %Y " mtime)))))
(defun cpio-filesize-to-filesize-string (filesize)
"Convert the given FILESIZE, an integer, to a string."
(let ((fname "cpio-filesize-to-filesize-string"))
(number-to-string filesize)))
(defun cpio-dev-maj-to-dev-maj-string (dev-maj)
"Do Convert the given DEV-MAJ, an integer, to a string."
(let ((fname "cpio-dev-maj-to-dev-maj-string"))
(number-to-string dev-maj)))
(defun cpio-dev-min-to-dev-min-string (dev-min)
"Do Convert the given DEV-MIN, an integer, to a string."
(let ((fname "cpio-dev-min-to-dev-min-string"))
(number-to-string dev-min)))
(defun cpio-entry-name-to-entry-name-string (name)
"DConvert the given NAME, an integer, to a string."
(let ((fname "cpio-entry-name-to-entry-name-string"))
name))
(defun cpio-find-entry (entry-name)
"Find the given ENTRY-NAME and return the buffer holding its contents."
(let ((fname "cpio-find-entry")
(target-buffer (get-file-buffer entry-name))
(just-created nil)
(local-parent *cab-parent*))
(unless target-buffer
(setq just-created t)
(with-current-buffer (setq target-buffer (get-buffer-create entry-name))
(cab-register target-buffer local-parent)
(setq buffer-file-name entry-name)
(setq buffer-file-truename (abbreviate-file-name
(concat (cpio-archive-name) "/"
buffer-file-name)))
(set (make-local-variable 'cpio-entry-name) entry-name)))
(with-current-buffer target-buffer
(cond ((and just-created
(= 0 (buffer-size)))
;; I can't seem to get coding right.
;; (cpio-set-auto-coding (setq contents (cpio-contents entry-name)))
(with-writable-buffer
(insert (cpio-contents entry-name)))
(goto-char (point-min)))
(t t))
(set-buffer-modified-p nil))
target-buffer))
(defun cpio-archive-name ()
"Return [the full path to] the cpio archive associated with the current buffer."
(let ((fname "cpio-archive-name"))
(unless (or *cab-parent*
(eq major-mode 'cpio-mode))
(error "%s(): You're not in a cpio-archive affiliated buffer." fname))
(if *cab-parent*
(buffer-file-name *cab-parent*)
(buffer-file-name))))
(defun cpio-contents-buffer-name (name)
"Return the name of the buffer that would/does hold the contents of entry NAME.
CAVEAT: Yes, there's a possibility of a collision here.
However, that would mean that you're editing
more than one archive, each containing entries of the same name
more than one of whose contents you are currently editing.
Run more than one instance of emacs to avoid such collisions."
(let ((fname "cpio-contents-buffer-name"))
;; (format "%s (in cpio archive %s)" name (file-name-nondirectory (buffer-file-name *cab-parent*)))))
name))
;; (expand-file-name
;; (concat name "!"))))
(defun cpio-create-entry-attrs (filename)
"Create an entry attribute structure based on the given FILENAME."
(let* ((fname "cpio-create-entry-attrs")
(attrs (file-attributes filename))
(ino (nth 10 attrs))
(mode (cpio-mode-string-to-int-mode (nth 8 attrs)))
(uid (nth 2 attrs))
(gid (nth 3 attrs))
(nlink 1)
(mtime (time-to-seconds (nth 5 attrs)))
(entry-size (nth 7 attrs))
(dev-maj (nth 11 attrs))
(dev-min 1)
(rdev-maj 0)
(rdev-min 0)
(namesize (length filename))
(chksum (cpio-make-chksum-for-file filename))
(result (make-vector 14 nil)))
(aset result *cpio-ino-parsed-idx* ino)
(aset result *cpio-mode-parsed-idx* mode)
(aset result *cpio-uid-parsed-idx* uid)
(aset result *cpio-gid-parsed-idx* gid)
(aset result *cpio-nlink-parsed-idx* nlink)
(cpio-set-mtime result mtime)
(aset result *cpio-entry-size-parsed-idx* entry-size)
(aset result *cpio-dev-maj-parsed-idx* dev-maj)
(aset result *cpio-dev-min-parsed-idx* dev-min)
(aset result *cpio-rdev-maj-parsed-idx* rdev-maj)
(aset result *cpio-rdev-min-parsed-idx* rdev-min)
(aset result *cpio-namesize-parsed-idx* namesize)
(aset result *cpio-chksum-parsed-idx* chksum)
(aset result *cpio-name-parsed-idx* filename)
result))
(defun cpio-make-chksum-for-file (filename)
"Return the checksum for FILENAME."
(let ((fname "cpio-make-chksum-for-file"))
(funcall cpio-make-chksum-for-file-func filename)))
(defun cpio-create-faux-directory-attrs (name)
"Create attributes appropriate for adding a directory entry to a cpio-archive.
CAVEAT: While many attributes are derived from a best guess of reality,
many are simply invented."
(let* ((fname "cpio-create-faux-directory-attrs")
(local-attrs (file-attributes "."))
(ino 1)
;; HEREHERE think about basing the mode on umask or local-attrs.
(mode (logior s-ifdir
s-irwxu
s-irusr
s-ixusr))
(uid (user-uid))
(gid (group-gid))
(nlink 1)
(now (current-time))
(entry-size 0)
(dev-maj 1)
(dev-min 1)
(rdev-maj 0)
(rdev-min 0)
(namesize (1+ (length name)))
(chksum 0) ;Checksum for a direcory is always 0.
(result (make-vector 14 nil)))
(aset result *cpio-ino-parsed-idx* ino)
(aset result *cpio-mode-parsed-idx* mode)
(aset result *cpio-uid-parsed-idx* uid)
(aset result *cpio-gid-parsed-idx* gid)
(aset result *cpio-nlink-parsed-idx* nlink)
(cpio-set-mtime result now)
(aset result *cpio-mtime-parsed-idx* mtime)
(aset result *cpio-entry-size-parsed-idx* entry-size)
(aset result *cpio-dev-maj-parsed-idx* dev-maj)
(aset result *cpio-dev-min-parsed-idx* dev-min)
(aset result *cpio-rdev-maj-parsed-idx* rdev-maj)
(aset result *cpio-rdev-min-parsed-idx* rdev-min)
(aset result *cpio-namesize-parsed-idx* namesize)
(aset result *cpio-chksum-parsed-idx* chksum)
(aset result *cpio-name-parsed-idx* name)
result))
(defun cpio-entry-exists-p (name)
"Return non-nil if there's already an entry called NAME
in the current archive."
(let ((fname "cpio-entry-exists-p"))
(unless (or (eq major-mode 'cpio-mode)
(eq major-mode 'cpio-dired-mode))
(error "%s(): You're not in a cpio-dired buffer." fname))
(if *cab-parent*
(with-current-buffer *cab-parent*
(cpio-entry-exists-p name))
(assoc name (cpio-catalog)))))
(defun cpio-move-to-entry (entry-name)
"Move the point to ENTRY-NAME."
(let ((fname "cpio-move-to-entry")
(where nil))
(unless (eq major-mode 'cpio-dired-mode)
(error "%s(): You're not in a cpio-dired buffer." fname))
(save-excursion
(cpio-dired-move-to-first-entry)
(while (not (looking-at-p (concat entry-name "$")))
(cpio-dired-next-line 1))
(if (looking-at-p (concat entry-name "$"))
(setq where (point))))
(if where
(goto-char where))))
;;
;; Functions about the modified state of a catalog entry.
;;
(defun cpio-set-entry-unmodified (catalog-entry)
"Mark the given CATALOG-ENTRY as not modified."
(let ((fname "cpio-set-entry-unmodified"))
(cpio-validate-catalog-entry catalog-entry)
(aset catalog-entry *cpio-catalog-entry-modified-flag-idx* 'cpio-mode-entry-unmodified)))
(defun cpio-set-entry-modified (catalog-entry)
"Mark the given CATALOG-ENTRY as modified."
(let ((fname "cpio-set-entry-modified"))
(cpio-validate-catalog-entry catalog-entry)
(aset catalog-entry *cpio-catalog-entry-modified-flag-idx* 'cpio-mode-entry-modified)))
(defun cpio-entry-modified-p (catalog-entry)
"Return non-NIL if CATALOG-ENTRY is marked as modified."
(let ((fname "cpio-entry-modified-p")
(modified-flag))
(cpio-validate-catalog-entry catalog-entry)
(cond ((eq 'cpio-mode-modified
(setq modified-flag (aref catalog-entry *cpio-catalog-entry-modified-flag-idx*)))
t)
((eq 'cpio-mode-unmodified catalog-entry)
nil)
(t
(error "%s(): Invalid modified flag value [[%s]]." fname modified-flag)))))
(defun cpio-validate-catalog-entry (catalog-entry)
"Verify that the given CATALOG-ENTRY is (could be) a valid catalog entry.
Signal an error if it isn't."
(let ((fname "validate-catalog-entry")
(modified-flag))
(unless (vectorp catalog-entry)
(signal 'wrong-type-error (list catalog-entry)))
(unless (= *cpio-catalog-entry-length* (length catalog-entry))
(error "%(): The catalog entry [[%d]] is not the right length." fname *cpio-catalog-entry-length*))
(unless (vectorp (aref catalog-entry *cpio-catalog-entry-attrs-idx*))
(signal 'wrong-type-error (list catalog-entry)))
(unless (= *cpio-parsed-header-length* (length (aref catalog-entry *cpio-catalog-entry-attrs-idx*)))
(error "%s(): The parsed header in [[%s]] is not the right length." fname (aref catalog-entry *cpio-catalog-entry-attrs-idx*))
(sit-for 1)
(error "%s(): Found [[%d]], expected [[%d]]." fname (length (aref catalog-entry *cpio-catalog-entry-attrs-idx*)) *cpio-parsed-header-length*))
(unless (and (markerp (aref catalog-entry *cpio-catalog-entry-header-start-idx*))
(markerp (aref catalog-entry *cpio-catalog-entry-contents-start-idx*)))
(error "%s(): The marker fields in [[%s]] are not markers." fname catalog-entry))
;; The modified flag may not be set yet, so ignore it.
))
;; A few functions for a failed attempt at supporting different encodings.
;; Modified from (set-auto-coding) ∈ mule.el.
(defun cpio-set-auto-coding (contents)
"Return coding system for the current buffer.
See `cpio-find-auto-coding' for how the coding system is found.
Return nil if an invalid coding system is found.
The variable `set-auto-coding-function' (which see) is set to this
function by default."
(let ((found (cpio-find-auto-coding cpio-entry-name contents)))
(if (and found (coding-system-p (car found)))
(car found))))
;; Modified from (find-auto-coding) ∈ mule.el.
(defun cpio-find-auto-coding (entry-name contents)
"Find a coding system for an archive entry ENTRY-NAME.
The function checks ENTRY-NAME against the variable `auto-coding-alist'.
If ENTRY-NAME doesn't match any entries in the variable, it checks the
contents of the current buffer following point against
`auto-coding-regexp-alist'. If no match is found, it checks for a
`coding:' tag in the first one or two lines following point. If no
`coding:' tag is found, it checks any local variables list in the last
3K bytes out of the SIZE bytes. Finally, if none of these methods
succeed, it checks to see if any function in `auto-coding-functions'
gives a match.
If a coding system is specified, the return value is a cons
\(CODING . SOURCE), where CODING is the specified coding system and
SOURCE is a symbol `auto-coding-alist', `auto-coding-regexp-alist',
`:coding', or `auto-coding-functions' indicating by what CODING is
specified. Note that the validity of CODING is not checked;
it's the caller's responsibility to check it.
If nothing is specified, the return value is nil."
(error "%s() is not yet implemented" "cpio-find-auto-coding")
(or (let ((coding-system (auto-coding-alist-lookup entry-name)))
(if coding-system
(cons coding-system 'auto-coding-alist)))
;; Try using `auto-coding-regexp-alist'.
(let ((coding-system (cpio-auto-coding-regexp-alist-lookup contents)))
(if coding-system
(cons coding-system 'auto-coding-regexp-alist)))
(let* ((case-fold-search t)
(size (length contents))
(head-start 0)
(head-end (+ head-start (min size 1024)))
(head (substring contents head-start head-end))
coding-system head-found tail-found char-trans)
;; Try a short cut by searching for the string "coding:"
;; and for "unibyte:".
(setq head-found (or (string-match "coding:" contents)
(string-match "unibyte:" contents)
(string-match "enable-character-translation:" contents)))
;; At first check the head.
(when head-found
;; (goto-char head-start)
;; (setq head-end (set-auto-mode-1))
;; (setq head-start (point))
(when (and head-end (< head-found head-end))
(goto-char head-start)
(when (and set-auto-coding-for-load
(string-match
"\\(.*;\\)?[ \t]*unibyte:[ \t]*\\([^ ;]+\\)"
contents))
(display-warning 'mule
(format "\"unibyte: t\" (in %s) is obsolete; \
use \"coding: 'raw-text\" instead."
(file-relative-name entry-name))
:warning)
(setq coding-system 'raw-text))
(when (and (not coding-system)
(string-match
"\\(.*;\\)?[ \t]*coding:[ \t]*\\([^ ;]+\\)"
contents)
(setq coding-system (intern (match-string 2 contents))))
(when (string-match
"\\(.*;\\)?[ \t]*enable-character-translation:[ \t]*\\([^ ;]+\\)"
contents)
(setq char-trans (match-string 2 contents)))))
(if coding-system
;; If the coding-system name ends with "!", remove it and
;; set char-trans to "nil".
(let ((name (symbol-name coding-system)))
(if (= (aref name (1- (length name))) ?!)
(setq coding-system (intern (substring name 0 -1))
char-trans "nil"))))
(when (and char-trans
(not (setq char-trans (intern char-trans))))
(make-local-variable 'enable-character-translation)
(setq enable-character-translation nil))
(if coding-system
(cons coding-system :coding)))
;; Finally, try all the `auto-coding-functions'.
(let ((funcs auto-coding-functions)
(coding-system nil))
(while (and funcs (not coding-system))
(setq coding-system (ignore-errors
(save-excursion
(goto-char (point-min))
(funcall (pop funcs) size))))))
(if coding-system
(cons coding-system 'auto-coding-functions)))))
(defun cpio-auto-coding-regexp-alist-lookup (contents)
"Lookup `auto-coding-regexp-alist' for CONTENTS.
The value is a coding system is specified for the CONTENTS
or nil."
(let ((fname "cpio-auto-coding-regexp-alist-lookup")
(alist auto-coding-regexp-alist)
(coding-system))
(error "%s() is not yet implemented" fname)
(while (and alist (not coding-system))
(let ((regexp (car (car alist))))
(if enable-multibyte-characters
(setq regexp (string-to-multibyte regexp)))
(if (string-match regexp contents)
(setq coding-system (cdr (car alist)))
(setq alist (cdr alist)))))
coding-system))
(defun cpio-set-coding-system (entry-name)
"Set the coding system for the current buffer based on the contents of the entry-ENTRY-NAME."
(let ((fname "cpio-set-coding-system"))
(error "%s() is not yet implemented" fname)
(if *cab-parent*
(with-current-buffer *cab-parent*
(cpio-set-coding-system entry-name))
;; (setq last-coding-system-used
;; (car (find-coding-systems-region (cpio-contents-start entry-name)
;; (cpio-contents-end entry-name))))
(set-buffer-file-coding-system last-coding-system-used 'force 'nomodify))))
(defun cpio-not-modified ()
"Mark the current cpio-dired-style and archive buffersfas unmodified."
(let ((fname "cpio-not-modified"))
(cond (*cab-parent*
(not-modified)
(with-current-buffer *cab-parent* (not-modified)))
(t
(not-modified)
(mapc (lambda (b)
(if (buffer-live-p b)
(with-current-buffer b
(not-modified))))
*cab-subordinates*)))))
;;
;; Commands
;;
(defun cpio-view-dired-style-buffer ()
"Switch to the dired style buffer corresponding to this archive buffer."
;; (cpio-dired-buffer-name) is in cpio-mode.el because
;; it is invoked in the archive's directory.
(interactive)
(let ((fname "cpio-view-dired-style-buffer")
(archive-file-name (buffer-file-name)))
(unless (eq major-mode 'cpio-mode)
(error "%s(): You're not in a cpio archive buffer under cpio-mode." fname))
(bury-buffer)
(switch-to-buffer (cpio-dired-buffer-name archive-file-name))))
;;
;; Mode definition
;;
;; HEREHERE I'm hoping dired-mode gives me decent stuff for free.
;; dired-mode -- Nope the hooks for dired-mode want a nicer environment.
;; I'll have to see how tar-mode does it.
;;;###autoload
(define-derived-mode cpio-mode fundamental-mode "cpio-mode"
"Treat cpio archives like file systems with a dired UI."
(if (null (setq *cpio-format* (cpio-discern-archive-type)))
(error "You're not in a supported CPIO buffer. It begins [[%s]]." (buffer-substring-no-properties 1 8)))
;;
;; HEREHERE Get rid of this once things look clean.
;;
(cpio-backup-during-development)
;;
;; EO temporary code for development
;;
(let ((archive-buffer (current-buffer))
(cpio-dired-buffer))
;; You really only need this for the binary archive formats,
;; but, hey it's cheap to set it.
(set-syntax-table *cpio-archive-syntax-table*)
(setq buffer-read-only t)
(cpio-set-locals *cpio-format*)
(setq *cpio-archive-name* (buffer-file-name))
(cpio-build-catalog)
(with-current-buffer (setq cpio-dired-buffer
(cpio-present-ala-dired (current-buffer)))
(make-local-variable '*cpio-archive-name*)
(cpio-dired-set-unmodified))
(cpio-create-keymap)
(bury-buffer)
;; cpio-mode is the top level function here,
;; so this should control what we see at this point.
(switch-to-buffer cpio-dired-buffer)))
;;
;; HEREHERE Get rid of this once things look clean.
;;
(defun cpio-backup-during-development ()
"Create a time-stamped backup of the file in the current-buffer.
There's an implied CONTRACT there:
The buffer must contain a file."
(let* ((fname "cpio-backup-during-development")
(filename (buffer-file-name))
(backup-file (format "%s-%s"
filename
(format-time-string "%Y%m%d%H%H%M%S.%3N"))))
(copy-file filename backup-file nil 'keep-time 'preserve-uid-gid 'preserve-permissions)))
;;
;; EO temporary code for development
;;
(defvar *cpio-dired-modified* nil
"A flag to record if any archive-modifying events have occured
since either the beginning or the last save.")
(setq *cpio-dired-modified* nil)
(make-variable-buffer-local '*cpio-dired-modified*)
(defun cpio-dired-modified-p ()
"Return non-NIL if the catalog has been modified
and, thus, the archive can be saved."
(let ((fname "cpio-dired-modified-p"))
(unless (or (eq major-mode 'cpio-dired-mode)
(eq major-mode 'cpio-mode))
(error "%s(): only makes sense in a cpio-dired buffer." fname))
(if *cab-parent*
(with-current-buffer *cab-parent*
(cpio-dired-modified-p))
*cpio-dired-modified*)))
(defun cpio-dired-set-modified ()
"Flag the catalog as modified."
(let ((fname "cpio-dired-set-modified"))
(unless (or (eq major-mode 'cpio-dired-mode)
(eq major-mode 'cpio-mode))
(error "%s(): only makes sense in a cpio-dired buffer." fname))
(if *cab-parent*
(with-current-buffer *cab-parent*
(cpio-dired-set-modified))
(setq *cpio-dired-modified* t))))
(defun cpio-dired-set-unmodified ()
"Flag the catalog as not modified."
(let ((fname "cpio-dired-set-unmodified"))
;; HEREHERE There's probably more to this than just the following.
;; For example, should it look for entry-contents buffers and
;; offer to save them if they're modified?
;; What about upon killing the archive buffer?
(unless (or (eq major-mode 'cpio-dired-mode)
(eq major-mode 'cpio-mode))
(error "%s(): only makes sense in a cpio-dired buffer." fname))
(cond (*cab-parent*
(with-current-buffer *cab-parent*
(cpio-dired-set-unmodified)))
(t
(setq *cpio-dired-modified* nil)
(set-buffer-modified-p nil)
(with-current-buffer (cpio-dired-buffer-name (buffer-name))
(set-buffer-modified-p nil))))))
(defvar *cpio-have-made-keymap* nil
"Flag to indicate that the cpio-mode-map has already been built.")
(setq *cpio-have-made-keymap* nil)
(defun cpio-create-keymap ()
(let ((fname "cpio-create-keymap")
(keymap (make-keymap)))
(setq cpio-mode-map keymap)
(unless *cpio-have-made-keymap*
(define-key cpio-mode-map "\C-c\C-c" 'cpio-view-dired-style-buffer)
(define-key cpio-mode-map "q" 'cpio-quit))))
(defun cpio-quit ()
"Quit cpio mode and kill all the affiliated buffers."
(interactive)
(let ((fname "cpio-quit"))
(if *cab-parent*
(with-current-buffer *cab-parent*
(cpio-quit)
(unless (kill-buffer)
(warn "%s(): Could not kill [[%s]]." fname (current-buffer)))))))
(defun cpio-entry (entry-name)
"Return the entry in the catalog for the entry with ENTRY-NAME."
(let ((fname "cpio-entry"))
(if *cab-parent*
(cdr (assoc entry-name (with-current-buffer *cab-parent*
*cpio-catalog*)))
(cdr (assoc entry-name *cpio-catalog*)))))
(defun cpio-entry-attrs-from-catalog-entry (catalog-entry)
"Do that."
(let ((fname "cpio-entry c-attrs-from-catalog"))
(aref catalog-entry *cpio-catalog-entry-attrs-idx*)))
(defun cpio-build-catalog ()
"Build the catalog that tracks the entries in this cpio-mode buffer.
cpio-mode maintains the catalog in the *cpio-catalog* variable."
(let ((fname "cpio-build-catalog"))
(goto-char (point-min))
(setq *cpio-catalog* (funcall cpio-build-catalog-func))))
(defun cpio-set-locals (archive-type)
"Establish certain variables as local to the current buffer and give them good values.
ARCHIVE-TYPE is a symbol."
(let ((fname "cpio-set-locals"))
(if *cab-parent*
(with-current-buffer *cab-parent*
(cpio-set-local-vars archive-type))
(cpio-set-local-vars archive-type)
(cpio-set-local-funcs archive-type))))
(defun cpio-set-local-funcs (archive-type)
"Establish the functions for the given archive type.
The functions are assigned to the elements of *cpio-local-funcs*,
a string of symbols.
Thus, to use them as functions
you need to (funcall) them or to (apply) them.
CAVEAT: No checking is done.
This function doesn't care /why/ you are asking for functions
that are appropriate for ARCHIVE-TYPE.
That's the caller's business.
See *cpio-local-funcs* for more information."
(let ((fname "cpio-set-local-funcs")
(archive-type-name (symbol-name archive-type)))
(mapc 'make-local-variable
*cpio-local-funcs*)
;; Here is the process:
;; cpio-do-good-stuff-func
;; --> "cpio-do-good-stuff-func"
;; --> "cpio" "do" "good" "stuff"
;; --> "cpio-fmt-do-good-stuff"
;; --> cpio-fmt-do-good-stuff
;; (setq cpio-do-good-stuff-func cpio-hdr-do-good-stuff)
;; Here's an example of the desired result for newc headers.
;; (setq cpio-parse-header-func 'cpio-newc-parse-header)
(mapc (lambda (local-func-var)
(let* ((name-parts (split-string (symbol-name local-func-var) "-"))
(target-name (concat (car name-parts) "-" ;HEREHERE Should this be (pop)?
(symbol-name archive-type))))
(setq name-parts (cdr (remove "func" name-parts)))
(mapc (lambda (part)
(setq target-name (concat target-name "-" part)))
name-parts)
;; 1. (set) not (setq) because
;; 2. local-func-var holds a symbol)
(set local-func-var (read target-name))
target-name))
*cpio-local-funcs*)))
(defun cpio-set-local-vars (archive-type)
"Set all the necessary local variables for the CPIO archive type given."
(let ((fname "cpio-set-local-vars"))
;; Some variables are not format-specific.
(make-local-variable '*cpio-catalog*)
(setq *cpio-catalog* ())
(setq *cpio-archive-name* (buffer-file-name))
;; Now for the format-specific variables.
(cond ((eq archive-type 'bin)
(cpio-set-local-bin-vars))
((eq archive-type 'newc)
(cpio-set-local-newc-vars))
((eq archive-type 'odc)
(cpio-set-local-odc-vars))
((eq archive-type 'crc)
(cpio-set-local-crc-vars))
((eq archive-type 'tar)
(cpio-set-local-tar-vars))
((eq archive-type 'ustar)
(cpio-set-local-ustar-vars))
((eq archive-type 'hpbin)
(cpio-set-local-hpbin-vars))
((eq archive-type 'hpodc)
(cpio-set-local-hpodc-vars))
(t (error "%s(): Unknown archive type [[%s]]" fname archive-type)))))
(defun cpio-set-local-bin-vars ()
"Set buffer local variables appropriate for a BIN format CPIO archive."
(let ((fname "cpio-set-local-bin-vars"))
(make-local-variable '*cpio-padding-modulus*)
(setq *cpio-padding-modulus* *cpio-bin-padding-modulus*)
(make-local-variable '*cpio-padding-char*)
(setq *cpio-padding-char* *cpio-bin-padding-char*)
(make-local-variable '*cpio-padding-str*)
(setq *cpio-padding-str* *cpio-bin-padding-str*)
(make-local-variable '*cpio-header-length*)
(setq *cpio-header-length* *cpio-bin-header-length*)))
(defun cpio-set-local-newc-vars ()
"Set buffer local variables appropriate for a NEWC format CPIO archive."
(let ((fname "cpio-set-local-newc-vars"))
(make-local-variable '*cpio-padding-modulus*)
(setq *cpio-padding-modulus* *cpio-newc-padding-modulus*)
(make-local-variable '*cpio-padding-char*)
(setq *cpio-padding-char* *cpio-newc-padding-char*)
(make-local-variable '*cpio-padding-str*)
(setq *cpio-padding-str* *cpio-newc-padding-str*)
(make-local-variable '*cpio-header-length*)
(setq *cpio-header-length* *cpio-newc-header-length*)))
(defun cpio-set-local-odc-vars ()
"Set buffer local variables appropriate for a ODC format CPIO archive."
(let ((fname "cpio-set-local-odc-vars"))
(make-local-variable '*cpio-padding-modulus*)
(setq *cpio-padding-modulus* *cpio-odc-padding-modulus*)
(make-local-variable '*cpio-padding-char*)
(setq *cpio-padding-char* *cpio-odc-padding-char*)
(make-local-variable '*cpio-padding-str*)
(setq *cpio-padding-str* *cpio-odc-padding-str*)
(make-local-variable '*cpio-header-length*)
(setq *cpio-header-length* *cpio-odc-header-length*)))
(defun cpio-set-local-crc-vars ()
"Set buffer local variables appropriate for a CRC format CPIO archive."
(let ((fname "cpio-set-local-crc-vars"))
(make-local-variable '*cpio-padding-modulus*)
(setq *cpio-padding-modulus* *cpio-crc-padding-modulus*)
(make-local-variable '*cpio-padding-char*)
(setq *cpio-padding-char* *cpio-crc-padding-char*)
(make-local-variable '*cpio-padding-str*)
(setq *cpio-padding-str* *cpio-crc-padding-str*)
(make-local-variable '*cpio-header-length*)
(setq *cpio-header-length* *cpio-crc-header-length*)))
(defun cpio-set-local-tar-vars ()
"Set buffer local variables appropriate for a TAR format CPIO archive."
(let ((fname "cpio-set-local-tar-vars"))
(error "%s() is not yet implemented" fname)))
(defun cpio-set-local-ustar-vars ()
"Set buffer local variables appropriate for a USTAR format CPIO archive."
(let ((fname "cpio-set-local-ustar-vars"))
x (error "%s() is not yet implemented" fname)))
(defun cpio-set-local-hpbin-vars ()
"Set buffer local variables appropriate for a HPBIN format CPIO archive."
(let ((fname "cpio-set-local-hpbin-vars"))
(error "%s() is not yet implemented" fname)))
(defun cpio-set-local-hpodc-vars ()
"Set buffer local variables appropriate for a HPODC format CPIO archive."
(let ((fname "cpio-set-local-hpodc-vars"))
(error "%s() is not yet implemented" fname)))
(provide 'cpio-mode)
;;; cpio-mode.el ends here
cpio-mode-0.17.0.20211211.193556/cpio-hpbin.el 0000644 0001752 0001753 00000002231 13754322553 016130 0 ustar elpa elpa ;;; cpio-hpbin.el --- handle hpbin cpio entry header formats. -*- coding: utf-8 -*-
;; COPYRIGHT
;;
;; Copyright © 2019 Free Software Foundation, Inc.
;; All rights reserved.
;;
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see .
;;
;; Author: Douglas Lewan
;; Maintainer: Douglas Lewan
;; Created: 2015 Jan 03
;; Version: 0.17
;; Keywords: files
;;; Commentary:
;;; Documentation:
;;; Code:
;;
;; Dependencies
;;
;;
;; Vars
;;
;;
;; Library
;;
;;
;; Commands
;;
(provide 'cpio-hpbin)
;;; cpio-hpbin.el ends here.