# HG changeset patch # User steve # Date 884760185 0 # Wed Jan 14 06:43:05 1998 +0000 # Node ID a5ccea260cd505ca43d0090fbcc986d41ae7772b # Parent 0000000000000000000000000000000000000000 Created diff --git a/ChangeLog b/ChangeLog new file mode 100644 --- /dev/null +++ b/ChangeLog @@ -0,0 +1,17 @@ +1998-01-11 SL Baur <steve@altair.xemacs.org> + + * Makefile: Update to newer package interface. + +1998-01-05 SL Baur <steve@altair.xemacs.org> + + * Makefile: Update to newer packages interface. + +1997-12-27 Jens-Ulrik Holger Petersen <petersen@kurims.kyoto-u.ac.jp> + + * tar-mode.el: Minimal synchage with Emacs 20. Moved `tar-' to the + front of all identifiers. Some docstring improvements too. + (tar-mode-map): Added keybindings for [up], [down] and [return]. + +1997-12-24 SL Baur <steve@altair.xemacs.org> + + * Makefile: Created. diff --git a/Makefile b/Makefile new file mode 100644 --- /dev/null +++ b/Makefile @@ -0,0 +1,38 @@ +# Makefile for miscellaneous O/S Utilities lisp code + +# This file is part of XEmacs. + +# XEmacs 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 2, or (at your option) any +# later version. + +# XEmacs 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 XEmacs; see the file COPYING. If not, write to +# the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +# Boston, MA 02111-1307, USA. + +# This XEmacs package contains independent single file lisp packages + +VERSION = 1.03 +PACKAGE = os-utils +PKG_TYPE = single-file +REQUIRES = xemacs-base +CATEGORY = os + +ELCS = arc-mode.elc background.elc crypt.elc inf-lisp.elc jka-compr.elc \ + kermit.elc ledit.elc lpr.elc ps-print.elc rlogin.elc spell.elc \ + ssh.elc tar-mode.elc telnet.elc terminal.elc uncompress.elc + +include ../../XEmacs.rules + +all:: $(ELCS) auto-autoloads.elc custom-load.elc + +srckit: srckit-std + +binkit: binkit-sourceonly diff --git a/arc-mode.el b/arc-mode.el new file mode 100644 --- /dev/null +++ b/arc-mode.el @@ -0,0 +1,1594 @@ +;;; arc-mode.el --- simple editing of archives + +;; Copyright (C) 1995 Free Software Foundation, Inc. + +;; Author: Morten Welinder (terra@diku.dk) +;; Keywords: data, unix +;; Favourite-brand-of-beer: None, I hate beer. + +;; This file is part of XEmacs. + +;; XEmacs 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 2, or (at your option) +;; any later version. + +;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the Free +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. + +;;; Synched up with: FSF 19.34. + +;;; Commentary: + +;; NAMING: "arc" is short for "archive" and does not refer specifically +;; to files whose name end in ".arc" +;; +;; This code does not decode any files internally, although it does +;; understand the directory level of the archives. For this reason, +;; you should expect this code to need more fiddling than tar-mode.el +;; (although it at present has fewer bugs :-) In particular, I have +;; not tested this under Ms-Dog myself. +;; ------------------------------------- +;; INTERACTION: arc-mode.el should play together with +;; +;; * ange-ftp.el: Remote archives (i.e., ones that ange-ftp has brought +;; to you) are handled by doing all updates on a local +;; copy. When you make changes to a remote file the +;; changes will first take effect when the archive buffer +;; is saved. You will be warned about this. +;; +;; * dos-fns.el: (Part of Emacs 19). You get automatic ^M^J <--> ^J +;; conversion. +;; +;; arc-mode.el does not work well with crypt++.el; for the archives as +;; such this could be fixed (but wouldn't be useful) by declaring such +;; archives to be "remote". For the members this is a general Emacs +;; problem that 19.29's file formats may fix. +;; ------------------------------------- +;; ARCHIVE TYPES: Currently only the archives below are handled, but the +;; structure for handling just about anything is in place. +;; +;; Arc Lzh Zip Zoo +;; -------------------------------- +;; View listing Intern Intern Intern Intern +;; Extract member Y Y Y Y +;; Save changed member Y Y Y Y +;; Add new member N N N N +;; Delete member Y Y Y Y +;; Rename member Y Y N N +;; Chmod - Y Y - +;; Chown - Y - - +;; Chgrp - Y - - +;; +;; Special thanks to Bill Brodie <wbrodie@panix.com> for very useful tips +;; on the first released version of this package. +;; +;; This code is partly based on tar-mode.el from Emacs. +;; ------------------------------------- +;; ARCHIVE STRUCTURES: +;; (This is mostly for myself.) +;; +;; ARC A series of (header,file). No interactions among members. +;; +;; LZH A series of (header,file). Headers are checksummed. No +;; interaction among members. +;; +;; ZIP A series of (lheader,fil) followed by a "central directory" +;; which is a series of (cheader) followed by an end-of- +;; central-dir record possibly followed by junk. The e-o-c-d +;; links to c-d. cheaders link to lheaders which are basically +;; cut-down versions of the cheaders. +;; +;; ZOO An archive header followed by a series of (header,file). +;; Each member header points to the next. The archive is +;; terminated by a bogus header with a zero next link. +;; ------------------------------------- +;; HOOKS: `foo' means one of the supported archive types. +;; +;; archive-mode-hook +;; archive-foo-mode-hook +;; archive-extract-hooks + +;;; Code: + +;; ------------------------------------------------------------------------- +;; Section: Configuration. + +(defgroup archive nil + "Simple editing of archives." + :group 'data) + +(defgroup archive-arc nil + "ARC-specific options to archive." + :group 'archive) + +(defgroup archive-lzh nil + "LZH-specific options to archive." + :group 'archive) + +(defgroup archive-zip nil + "ZIP-specific options to archive." + :group 'archive) + +(defgroup archive-zoo nil + "ZOO-specific options to archive." + :group 'archive) + + +(defcustom archive-dos-members t + "*If non-nil then recognize member files using ^M^J as line terminator." + :type 'boolean + :group 'archive) + +(defcustom archive-tmpdir + (expand-file-name + (make-temp-name (if (eq system-type 'ms-dos) "ar" "archive.tmp")) + (or (getenv "TMPDIR") (getenv "TMP") "/tmp")) + "*Directory for temporary files made by arc-mode.el" + :type 'directory + :group 'archive) + +(defcustom archive-remote-regexp "^/[^/:]*[^/:.]:" + "*Regexp recognizing archive files names that are not local. +A non-local file is one whose file name is not proper outside Emacs. +A local copy of the archive will be used when updating." + :type 'regexp + :group 'archive) + +(defcustom archive-extract-hooks nil + "*Hooks to run when an archive member has been extracted." + :type 'hook + :group 'archive) +;; ------------------------------ +;; Arc archive configuration + +;; We always go via a local file since there seems to be no reliable way +;; to extract to stdout without junk getting added. +(defcustom archive-arc-extract + '("arc" "x") + "*Program and its options to run in order to extract an arc file member. +Extraction should happen to the current directory. Archive and member +name will be added." + :type '(list (string :tag "Program") + (repeat :tag "Options" + :inline t + (string :format "%v"))) + :group 'archive-arc) + +(defcustom archive-arc-expunge + '("arc" "d") + "*Program and its options to run in order to delete arc file members. +Archive and member names will be added." + :type '(list (string :tag "Program") + (repeat :tag "Options" + :inline t + (string :format "%v"))) + :group 'archive-arc) + +(defcustom archive-arc-write-file-member + '("arc" "u") + "*Program and its options to run in order to update an arc file member. +Archive and member name will be added." + :type '(list (string :tag "Program") + (repeat :tag "Options" + :inline t + (string :format "%v"))) + :group 'archive-arc) +;; ------------------------------ +;; Lzh archive configuration + +(defcustom archive-lzh-extract + '("lha" "pq") + "*Program and its options to run in order to extract an lzh file member. +Extraction should happen to standard output. Archive and member name will +be added." + :type '(list (string :tag "Program") + (repeat :tag "Options" + :inline t + (string :format "%v"))) + :group 'archive-lzh) + +(defcustom archive-lzh-expunge + '("lha" "d") + "*Program and its options to run in order to delete lzh file members. +Archive and member names will be added." + :type '(list (string :tag "Program") + (repeat :tag "Options" + :inline t + (string :format "%v"))) + :group 'archive-lzh) + +(defcustom archive-lzh-write-file-member + '("lha" "a") + "*Program and its options to run in order to update an lzh file member. +Archive and member name will be added." + :type '(list (string :tag "Program") + (repeat :tag "Options" + :inline t + (string :format "%v"))) + :group 'archive-lzh) +;; ------------------------------ +;; Zip archive configuration + +(defcustom archive-zip-use-pkzip (memq system-type '(ms-dos windows-nt)) + "*If non-nil then pkzip option are used instead of zip options. +Only set to true for msdog systems!" + :type 'boolean + :group 'archive-zip) + +(defcustom archive-zip-extract + (if archive-zip-use-pkzip '("pkunzip" "-e") '("unzip" "-qq" "-c")) + "*Program and its options to run in order to extract a zip file member. +Extraction should happen to standard output. Archive and member name will +be added. If `archive-zip-use-pkzip' is non-nil then this program is +expected to extract to a file junking the directory part of the name." + :type '(list (string :tag "Program") + (repeat :tag "Options" + :inline t + (string :format "%v"))) + :group 'archive-zip) + +;; For several reasons the latter behaviour is not desirable in general. +;; (1) It uses more disk space. (2) Error checking is worse or non- +;; existent. (3) It tends to do funny things with other systems' file +;; names. + +(defcustom archive-zip-expunge + (if archive-zip-use-pkzip '("pkzip" "-d") '("zip" "-d" "-q")) + "*Program and its options to run in order to delete zip file members. +Archive and member names will be added." + :type '(list (string :tag "Program") + (repeat :tag "Options" + :inline t + (string :format "%v"))) + :group 'archive-zip) + +(defcustom archive-zip-update + (if archive-zip-use-pkzip '("pkzip" "-u") '("zip" "-q")) + "*Program and its options to run in order to update a zip file member. +Options should ensure that specified directory will be put into the zip +file. Archive and member name will be added." + :type '(list (string :tag "Program") + (repeat :tag "Options" + :inline t + (string :format "%v"))) + :group 'archive-zip) + +(defcustom archive-zip-update-case + (if archive-zip-use-pkzip archive-zip-update '("zip" "-q" "-k")) + "*Program and its options to run in order to update a case fiddled zip member. +Options should ensure that specified directory will be put into the zip file. +Archive and member name will be added." + :type '(list (string :tag "Program") + (repeat :tag "Options" + :inline t + (string :format "%v"))) + :group 'archive-zip) + +(defcustom archive-zip-case-fiddle t + "*If non-nil then zip file members are case fiddled. +Case fiddling will only happen for members created by a system that +uses caseless file names." + :type 'boolean + :group 'archive-zip) +;; ------------------------------ +;; Zoo archive configuration + +(defcustom archive-zoo-extract + '("zoo" "xpq") + "*Program and its options to run in order to extract a zoo file member. +Extraction should happen to standard output. Archive and member name will +be added." + :type '(list (string :tag "Program") + (repeat :tag "Options" + :inline t + (string :format "%v"))) + :group 'archive-zoo) + +(defcustom archive-zoo-expunge + '("zoo" "DqPP") + "*Program and its options to run in order to delete zoo file members. +Archive and member names will be added." + :type '(list (string :tag "Program") + (repeat :tag "Options" + :inline t + (string :format "%v"))) + :group 'archive-zoo) + +(defcustom archive-zoo-write-file-member + '("zoo" "a") + "*Program and its options to run in order to update a zoo file member. +Archive and member name will be added." + :type '(list (string :tag "Program") + (repeat :tag "Options" + :inline t + (string :format "%v"))) + :group 'archive-zoo) +;; ------------------------------------------------------------------------- +;; Section: Variables + +(defvar archive-subtype nil "*Symbol describing archive type.") +(defvar archive-file-list-start nil "*Position of first contents line.") +(defvar archive-file-list-end nil "*Position just after last contents line.") +(defvar archive-proper-file-start nil "*Position of real archive's start.") +(defvar archive-read-only nil "*Non-nil if the archive is read-only on disk.") +(defvar archive-remote nil "*Non-nil if the archive is outside file system.") +(defvar archive-local-name nil "*Name of local copy of remote archive.") +(defvar archive-mode-map nil "*Local keymap for archive mode listings.") +(defvar archive-file-name-indent nil "*Column where file names start.") + +(defvar archive-alternate-display nil + "*Non-nil when alternate information is shown.") +(make-variable-buffer-local 'archive-alternate-display) +(put 'archive-alternate-display 'permanent-local t) + +(defvar archive-superior-buffer nil "*In archive members, points to archive.") +(put 'archive-superior-buffer 'permanent-local t) + +(defvar archive-subfile-mode nil "*Non-nil in archive member buffers.") +(make-variable-buffer-local 'archive-subfile-mode) +(put 'archive-subfile-mode 'permanent-local t) + +;; buffer-file-type is a per-buffer variable in the msdog configuration +(if (boundp 'buffer-file-type) nil + (defvar buffer-file-type nil + "*Nil for dos-style text file, non-nil otherwise.") + (make-variable-buffer-local 'buffer-file-type) + (put 'buffer-file-type 'permanent-local t) + (setq-default buffer-file-type nil)) + +(defvar archive-subfile-dos nil + "Negation of `buffer-file-type' which see.") +(make-variable-buffer-local 'archive-subfile-dos) +(put 'archive-subfile-dos 'permanent-local t) + +(defvar archive-files nil "Vector of file descriptors. Each descriptor is +a vector of [ext-file-name int-file-name case-fiddled mode ...]") +(make-variable-buffer-local 'archive-files) + +;; XEmacs change +(defvar archive-xemacs + (string-match "\\(Lucid\\|XEmacs\\)" emacs-version) + "*Non-nil when running under Lucid Emacs or XEmacs.") +;; ------------------------------------------------------------------------- +;; Section: Support functions. + +(defsubst archive-name (suffix) + (intern (concat "archive-" (symbol-name archive-subtype) "-" suffix))) + +(defun archive-l-e (str &optional len) + "Convert little endian string/vector to integer. +Alternatively, first argument may be a buffer position in the current buffer +in which case a second argument, length, should be supplied." + (if (stringp str) + (setq len (length str)) + (setq str (buffer-substring str (+ str len)))) + (let ((result 0) + (i 0)) + (while (< i len) + (setq i (1+ i) + result (+ (ash result 8) (aref str (- len i))))) + result)) + +(defun archive-int-to-mode (mode) + "Turn an integer like 0700 (i.e., 448) into a mode string like -rwx------" + (let ((str (make-string 10 ?-))) + (or (zerop (logand 16384 mode)) (aset str 0 ?d)) + (or (zerop (logand 8192 mode)) (aset str 0 ?c)) ; completeness + (or (zerop (logand 256 mode)) (aset str 1 ?r)) + (or (zerop (logand 128 mode)) (aset str 2 ?w)) + (or (zerop (logand 64 mode)) (aset str 3 ?x)) + (or (zerop (logand 32 mode)) (aset str 4 ?r)) + (or (zerop (logand 16 mode)) (aset str 5 ?w)) + (or (zerop (logand 8 mode)) (aset str 6 ?x)) + (or (zerop (logand 4 mode)) (aset str 7 ?r)) + (or (zerop (logand 2 mode)) (aset str 8 ?w)) + (or (zerop (logand 1 mode)) (aset str 9 ?x)) + (or (zerop (logand 1024 mode)) (aset str 3 (if (zerop (logand 64 mode)) + ?S ?s))) + (or (zerop (logand 2048 mode)) (aset str 6 (if (zerop (logand 8 mode)) + ?S ?s))) + str)) + +(defun archive-calc-mode (oldmode newmode &optional error) + "From the integer OLDMODE and the string NEWMODE calculate a new file mode. +NEWMODE may be an octal number including a leading zero in which case it +will become the new mode.\n +NEWMODE may also be a relative specification like \"og-rwx\" in which case +OLDMODE will be modified accordingly just like chmod(2) would have done.\n +If optional third argument ERROR is non-nil an error will be signaled if +the mode is invalid. If ERROR is nil then nil will be returned." + (cond ((string-match "^0[0-7]*$" newmode) + (let ((result 0) + (len (length newmode)) + (i 1)) + (while (< i len) + (setq result (+ (lsh result 3) (aref newmode i) (- ?0)) + i (1+ i))) + (logior (logand oldmode 65024) result))) + ((string-match "^\\([agou]+\\)\\([---+=]\\)\\([rwxst]+\\)$" newmode) + (let ((who 0) + (result oldmode) + (op (aref newmode (match-beginning 2))) + (bits 0) + (i (match-beginning 3))) + (while (< i (match-end 3)) + (let ((rwx (aref newmode i))) + (setq bits (logior bits (cond ((= rwx ?r) 292) + ((= rwx ?w) 146) + ((= rwx ?x) 73) + ((= rwx ?s) 3072) + ((= rwx ?t) 512))) + i (1+ i)))) + (while (< who (match-end 1)) + (let* ((whoc (aref newmode who)) + (whomask (cond ((= whoc ?a) 4095) + ((= whoc ?u) 1472) + ((= whoc ?g) 2104) + ((= whoc ?o) 7)))) + (if (= op ?=) + (setq result (logand result (lognot whomask)))) + (if (= op ?-) + (setq result (logand result (lognot (logand whomask bits)))) + (setq result (logior result (logand whomask bits))))) + (setq who (1+ who))) + result)) + (t + (if error + (error "Invalid mode specification: %s" newmode))))) + +(defun archive-dosdate (date) + "Stringify dos packed DATE record." + (let ((year (+ 1980 (logand (ash date -9) 127))) + (month (logand (ash date -5) 15)) + (day (logand date 31))) + (if (or (> month 12) (< month 1)) + "" + (format "%2d-%s-%d" + day + (aref ["Jan" "Feb" "Mar" "Apr" "May" "Jun" + "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"] (1- month)) + year)))) + +(defun archive-dostime (time) + "Stringify dos packed TIME record." + (let ((hour (logand (ash time -11) 31)) + (minute (logand (ash time -5) 53)) + (second (* 2 (logand time 31)))) ; 2 seconds resolution + (format "%02d:%02d:%02d" hour minute second))) + +;;(defun archive-unixdate (low high) +;; "Stringify unix (LOW HIGH) date." +;; (let ((str (current-time-string (cons high low)))) +;; (format "%s-%s-%s" +;; (substring str 8 9) +;; (substring str 4 7) +;; (substring str 20 24)))) + +;;(defun archive-unixtime (low high) +;; "Stringify unix (LOW HIGH) time." +;; (let ((str (current-time-string (cons high low)))) +;; (substring str 11 19))) + +(defun archive-get-lineno () + (if (>= (point) archive-file-list-start) + (count-lines archive-file-list-start + (save-excursion (beginning-of-line) (point))) + 0)) + +(defun archive-get-descr (&optional noerror) + "Return the descriptor vector for file at point. +Does not signal an error if optional second argument NOERROR is non-nil." + (let ((no (archive-get-lineno))) + (if (and (>= (point) archive-file-list-start) + (< no (length archive-files))) + (let ((item (aref archive-files no))) + (if (vectorp item) + item + (if (not noerror) + (error "Entry is not a regular member of the archive")))) + (if (not noerror) + (error "Line does not describe a member of the archive"))))) +;; ------------------------------------------------------------------------- +;; Section: the mode definition + +;;;###autoload +(defun archive-mode (&optional force) + "Major mode for viewing an archive file in a dired-like way. +You can move around using the usual cursor motion commands. +Letters no longer insert themselves. +Type `e' to pull a file out of the archive and into its own buffer; +or click mouse-2 on the file's line in the archive mode buffer. + +If you edit a sub-file of this archive (as with the `e' command) and +save it, the contents of that buffer will be saved back into the +archive. + +\\{archive-mode-map}" + ;; This is not interactive because you shouldn't be turning this + ;; mode on and off. You can corrupt things that way. + (if (zerop (buffer-size)) + ;; At present we cannot create archives from scratch + (funcall default-major-mode) + (if (and (not force) archive-files) nil + (let* ((type (archive-find-type)) + (typename (copy-sequence (symbol-name type)))) + (aset typename 0 (upcase (aref typename 0))) + (kill-all-local-variables) + (make-local-variable 'archive-subtype) + (setq archive-subtype type) + + ;; Buffer contains treated image of file before the file contents + (make-local-variable 'revert-buffer-function) + (setq revert-buffer-function 'archive-mode-revert) + (auto-save-mode 0) + (make-local-variable 'local-write-file-hooks) + (add-hook 'local-write-file-hooks 'archive-write-file) + + ;; Real file contents is binary + (make-local-variable 'require-final-newline) + (setq require-final-newline nil) + (make-local-variable 'enable-local-variables) + (setq enable-local-variables nil) + (setq buffer-file-type t) + + (make-local-variable 'archive-read-only) + (setq archive-read-only (not (file-writable-p (buffer-file-name)))) + + ;; Should we use a local copy when accessing from outside Emacs? + (make-local-variable 'archive-local-name) + (make-local-variable 'archive-remote) + (setq archive-remote (string-match archive-remote-regexp + (buffer-file-name))) + + (setq major-mode 'archive-mode) + (setq mode-name (concat typename "-Archive")) + ;; Run archive-foo-mode-hook and archive-mode-hook + (run-hooks (archive-name "mode-hook") 'archive-mode-hook) + (use-local-map archive-mode-map)) + + (make-local-variable 'archive-proper-file-start) + (make-local-variable 'archive-file-list-start) + (make-local-variable 'archive-file-list-end) + (make-local-variable 'archive-file-name-indent) + (archive-summarize) + (setq buffer-read-only t)))) + +;; Archive mode is suitable only for specially formatted data. +(put 'archive-mode 'mode-class 'special) + +(defun archive-quit () + "Bury the current archive buffer." + (interactive) + (bury-buffer)) + +;; ------------------------------------------------------------------------- +;; Section: Key maps + +(if archive-mode-map nil + (setq archive-mode-map (make-keymap)) + (suppress-keymap archive-mode-map) + (define-key archive-mode-map " " 'archive-next-line) + (define-key archive-mode-map "a" 'archive-alternate-display) + ;;(define-key archive-mode-map "c" 'archive-copy) + (define-key archive-mode-map "d" 'archive-flag-deleted) + (define-key archive-mode-map "\C-d" 'archive-flag-deleted) + (define-key archive-mode-map "e" 'archive-extract) + (define-key archive-mode-map "f" 'archive-extract) + (define-key archive-mode-map "\C-m" 'archive-extract) + (define-key archive-mode-map "g" 'revert-buffer) + (define-key archive-mode-map "h" 'describe-mode) + (define-key archive-mode-map "m" 'archive-mark) + (define-key archive-mode-map "n" 'archive-next-line) + (define-key archive-mode-map "\C-n" 'archive-next-line) + (define-key archive-mode-map [down] 'archive-next-line) + (define-key archive-mode-map "o" 'archive-extract-other-window) + (define-key archive-mode-map "p" 'archive-previous-line) + (define-key archive-mode-map "\C-p" 'archive-previous-line) + (define-key archive-mode-map [up] 'archive-previous-line) + (define-key archive-mode-map "r" 'archive-rename-entry) + (define-key archive-mode-map "u" 'archive-unflag) + (define-key archive-mode-map "\M-\C-?" 'archive-unmark-all-files) + (define-key archive-mode-map "v" 'archive-view) + (define-key archive-mode-map "x" 'archive-expunge) + (define-key archive-mode-map 'backspace 'archive-unflag-backwards) + (define-key archive-mode-map 'delete 'archive-unflag-backwards) + (define-key archive-mode-map "E" 'archive-extract-other-window) + (define-key archive-mode-map "M" 'archive-chmod-entry) + (define-key archive-mode-map "G" 'archive-chgrp-entry) + (define-key archive-mode-map "O" 'archive-chown-entry) + + (if archive-xemacs + (progn + ;; Not a nice "solution" but it'll have to do + (define-key archive-mode-map "q" 'archive-quit) + (define-key archive-mode-map "\C-xu" 'archive-undo) + (define-key archive-mode-map "\C-_" 'archive-undo)) + (substitute-key-definition 'undo 'archive-undo + archive-mode-map global-map)) + + (define-key archive-mode-map + (if archive-xemacs 'button2 [mouse-2]) 'archive-mouse-extract) + + (if archive-xemacs + () ; out of luck + ;; Get rid of the Edit menu bar item to save space. + (define-key archive-mode-map [menu-bar edit] 'undefined) + + (define-key archive-mode-map [menu-bar immediate] + (cons "Immediate" (make-sparse-keymap "Immediate"))) + (define-key archive-mode-map [menu-bar immediate alternate] + '("Alternate Display" . archive-alternate-display)) + (put 'archive-alternate-display 'menu-enable + '(boundp (archive-name "alternate-display"))) + (define-key archive-mode-map [menu-bar immediate view] + '("View This File" . archive-view)) + (define-key archive-mode-map [menu-bar immediate display] + '("Display in Other Window" . archive-display-other-window)) + (define-key archive-mode-map [menu-bar immediate find-file-other-window] + '("Find in Other Window" . archive-extract-other-window)) + (define-key archive-mode-map [menu-bar immediate find-file] + '("Find This File" . archive-extract)) + + (define-key archive-mode-map [menu-bar mark] + (cons "Mark" (make-sparse-keymap "Mark"))) + (define-key archive-mode-map [menu-bar mark unmark-all] + '("Unmark All" . archive-unmark-all-files)) + (define-key archive-mode-map [menu-bar mark deletion] + '("Flag" . archive-flag-deleted)) + (define-key archive-mode-map [menu-bar mark unmark] + '("Unflag" . archive-unflag)) + (define-key archive-mode-map [menu-bar mark mark] + '("Mark" . archive-mark)) + + (define-key archive-mode-map [menu-bar operate] + (cons "Operate" (make-sparse-keymap "Operate"))) + (define-key archive-mode-map [menu-bar operate chown] + '("Change Owner..." . archive-chown-entry)) + (put 'archive-chown-entry 'menu-enable + '(fboundp (archive-name "chown-entry"))) + (define-key archive-mode-map [menu-bar operate chgrp] + '("Change Group..." . archive-chgrp-entry)) + (put 'archive-chgrp-entry 'menu-enable + '(fboundp (archive-name "chgrp-entry"))) + (define-key archive-mode-map [menu-bar operate chmod] + '("Change Mode..." . archive-chmod-entry)) + (put 'archive-chmod-entry 'menu-enable + '(fboundp (archive-name "chmod-entry"))) + (define-key archive-mode-map [menu-bar operate rename] + '("Rename to..." . archive-rename-entry)) + (put 'archive-rename-entry 'menu-enable + '(fboundp (archive-name "rename-entry"))) + ;;(define-key archive-mode-map [menu-bar operate copy] + ;; '("Copy to..." . archive-copy)) + (define-key archive-mode-map [menu-bar operate expunge] + '("Expunge Marked Files" . archive-expunge)) + )) + +(let* ((item1 '(archive-subfile-mode " Archive")) + (item2 '(archive-subfile-dos " Dos")) + (items (if (memq system-type '(ms-dos windows-nt)) + (list item1) ; msdog has its own indicator + (list item1 item2)))) + (or (member item1 minor-mode-alist) + (setq minor-mode-alist (append items minor-mode-alist)))) +;; ------------------------------------------------------------------------- +(defun archive-find-type () + (widen) + (goto-char (point-min)) + ;; The funny [] here make it unlikely that the .elc file will be treated + ;; as an archive by other software. + (let (case-fold-search) + (cond ((looking-at "[P]K\003\004") 'zip) + ((looking-at "..-l[hz][0-9]-") 'lzh) + ((looking-at "....................[\334]\247\304\375") 'zoo) + ((and (looking-at "\C-z") ; signature too simple, IMHO + (string-match "\\.[aA][rR][cC]$" + (or buffer-file-name (buffer-name)))) + 'arc) + (t (error "Buffer format not recognized."))))) +;; ------------------------------------------------------------------------- +(defun archive-summarize () + "Parse the contents of the archive file in the current buffer. +Place a dired-like listing on the front; +then narrow to it, so that only that listing +is visible (and the real data of the buffer is hidden)." + (widen) + (let (buffer-read-only) + (message "Parsing archive file...") + (buffer-disable-undo (current-buffer)) + (setq archive-files (funcall (archive-name "summarize"))) + (message "Parsing archive file...done.") + (setq archive-proper-file-start (point-marker)) + (narrow-to-region (point-min) (point)) + (set-buffer-modified-p nil) + (buffer-enable-undo)) + (goto-char archive-file-list-start) + (archive-next-line 0)) + +(defun archive-resummarize () + "Recreate the contents listing of an archive." + (let ((modified (buffer-modified-p)) + (no (archive-get-lineno)) + buffer-read-only) + (widen) + (delete-region (point-min) archive-proper-file-start) + (archive-summarize) + (set-buffer-modified-p modified) + (goto-char archive-file-list-start) + (archive-next-line no))) + +(defun archive-summarize-files (files) + "Insert a description of a list of files annotated with proper mouse face" + (setq archive-file-list-start (point-marker)) + (setq archive-file-name-indent (if files (aref (car files) 1) 0)) + ;; We don't want to do an insert for each element since that takes too + ;; long when the archive -- which has to be moved in memory -- is large. + (insert + (apply + (function concat) + (mapcar + (function + (lambda (fil) + ;; Using `concat' here copies the text also, so we can add + ;; properties without problems. + (let ((text (concat (aref fil 0) "\n"))) + (if archive-xemacs + () ; out of luck + (put-text-property (aref fil 1) (aref fil 2) + 'mouse-face 'highlight + text)) + text))) + files))) + (setq archive-file-list-end (point-marker))) + +(defun archive-alternate-display () + "Toggle alternative display. +To avoid very long lines some archive mode don't show all information. +This function changes the set of information shown for each files." + (interactive) + (setq archive-alternate-display (not archive-alternate-display)) + (archive-resummarize)) +;; ------------------------------------------------------------------------- +;; Section: Local archive copy handling + +(defun archive-maybe-copy (archive) + (if archive-remote + (let ((start (point-max))) + (setq archive-local-name (expand-file-name + (file-name-nondirectory archive) + archive-tmpdir)) + (make-directory archive-tmpdir t) + (save-restriction + (widen) + (write-region start (point-max) archive-local-name nil 'nomessage)) + archive-local-name) + (if (buffer-modified-p) (save-buffer)) + archive)) + +(defun archive-maybe-update (unchanged) + (if archive-remote + (let ((name archive-local-name) + (modified (buffer-modified-p)) + buffer-read-only) + (if unchanged nil + (erase-buffer) + (insert-file-contents name) + (archive-mode t)) + (archive-delete-local name) + (if (not unchanged) + (message "Archive file must be saved for changes to take effect")) + (set-buffer-modified-p (or modified (not unchanged)))))) + +(defun archive-delete-local (name) + "Delete file NAME and its parents up to and including `archive-tmpdir'." + (let ((again t) + (top (directory-file-name (file-name-as-directory archive-tmpdir)))) + (condition-case nil + (delete-file name) + (error nil)) + (while again + (setq name (directory-file-name (file-name-directory name))) + (condition-case nil + (delete-directory name) + (error nil)) + (if (string= name top) (setq again nil))))) +;; ------------------------------------------------------------------------- +;; Section: Member extraction + +(defun archive-mouse-extract (event) + "Extract a file whose name you click on." + (interactive "e") + (mouse-set-point event) + (switch-to-buffer + (save-excursion + (archive-extract) + (current-buffer)))) + +(defun archive-extract (&optional other-window-p) + "In archive mode, extract this entry of the archive into its own buffer." + (interactive) + (let* ((view-p (eq other-window-p 'view)) + (descr (archive-get-descr)) + (ename (aref descr 0)) + (iname (aref descr 1)) + (archive-buffer (current-buffer)) + (arcdir default-directory) + (archive (buffer-file-name)) + (arcname (file-name-nondirectory archive)) + (bufname (concat (file-name-nondirectory iname) " (" arcname ")")) + (extractor (archive-name "extract")) + (read-only-p (or archive-read-only view-p)) + (buffer (get-buffer bufname)) + (just-created nil)) + (if buffer + nil + (setq archive (archive-maybe-copy archive)) + (setq buffer (get-buffer-create bufname)) + (setq just-created t) + (save-excursion + (set-buffer buffer) + (setq buffer-file-name + (expand-file-name (concat arcname ":" iname))) + (setq buffer-file-truename + (abbreviate-file-name buffer-file-name)) + ;; Set the default-directory to the dir of the superior buffer. + (setq default-directory arcdir) + (make-local-variable 'archive-superior-buffer) + (setq archive-superior-buffer archive-buffer) + (make-local-variable 'local-write-file-hooks) + (add-hook 'local-write-file-hooks 'archive-write-file-member) + (setq archive-subfile-mode descr) + (setq archive-subfile-dos nil + buffer-file-type t) + (if (fboundp extractor) + (funcall extractor archive ename) + (archive-*-extract archive ename (symbol-value extractor))) + (if archive-dos-members (archive-check-dos)) + (goto-char (point-min)) + (rename-buffer bufname) + (setq buffer-read-only read-only-p) + (setq buffer-undo-list nil) + (set-buffer-modified-p nil) + (setq buffer-saved-size (buffer-size)) + (normal-mode) + ;; Just in case an archive occurs inside another archive. + (if (eq major-mode 'archive-mode) + (setq archive-remote t)) + (run-hooks 'archive-extract-hooks)) + (archive-maybe-update t)) + (if view-p + (progn + (view-buffer buffer) + (and just-created (setq view-exit-action 'kill-buffer))) + (if (eq other-window-p 'display) + (display-buffer buffer) + (if other-window-p + (switch-to-buffer-other-window buffer) + (switch-to-buffer buffer)))))) + +(defun archive-*-extract (archive name command) + (let* ((default-directory (file-name-as-directory archive-tmpdir)) + (tmpfile (expand-file-name (file-name-nondirectory name) + default-directory))) + (make-directory (directory-file-name default-directory) t) + (apply 'call-process + (car command) + nil + nil + nil + (append (cdr command) (list archive name))) + (insert-file-contents tmpfile) + (archive-delete-local tmpfile))) + +(defun archive-extract-by-stdout (archive name command) + (let ((binary-process-output t)) ; for Ms-Dos + (apply 'call-process + (car command) + nil + t + nil + (append (cdr command) (list archive name))))) + +(defun archive-extract-other-window () + "In archive mode, find this member in another window." + (interactive) + (archive-extract t)) + +(defun archive-display-other-window () + "In archive mode, display this member in another window." + (interactive) + (archive-extract 'display)) + +(defun archive-view () + "In archive mode, view the member on this line." + (interactive) + (archive-extract 'view)) + +(defun archive-add-new-member (arcbuf name) + "Add current buffer to the archive in ARCBUF naming it NAME." + (interactive + (list (get-buffer + (read-buffer "Buffer containing archive: " + ;; Find first archive buffer and suggest that + (let ((bufs (buffer-list))) + (while (and bufs (not (eq (save-excursion + (set-buffer (car bufs)) + major-mode) + 'archive-mode))) + (setq bufs (cdr bufs))) + (if bufs + (car bufs) + (error "There are no archive buffers"))) + t)) + (read-string "File name in archive: " + (if buffer-file-name + (file-name-nondirectory buffer-file-name) + "")))) + (save-excursion + (set-buffer arcbuf) + (or (eq major-mode 'archive-mode) + (error "Buffer is not an archive buffer")) + (if archive-read-only + (error "Archive is read-only"))) + (if (eq arcbuf (current-buffer)) + (error "An archive buffer cannot be added to itself")) + (if (string= name "") + (error "Archive members may not be given empty names")) + (let ((func (save-excursion (set-buffer arcbuf) + (archive-name "add-new-member"))) + (membuf (current-buffer))) + (if (fboundp func) + (save-excursion + (set-buffer arcbuf) + (funcall func buffer-file-name membuf name)) + (error "Adding a new member is not supported for this archive type")))) +;; ------------------------------------------------------------------------- +;; Section: IO stuff + +(defun archive-check-dos (&optional force) + "*Possibly handle a buffer with ^M^J terminated lines." + (save-restriction + (widen) + (save-excursion + (goto-char (point-min)) + (setq archive-subfile-dos + (or force (not (search-forward-regexp "[^\r]\n" nil t)))) + (setq buffer-file-type (not archive-subfile-dos)) + (if archive-subfile-dos + (let ((modified (buffer-modified-p))) + (buffer-disable-undo (current-buffer)) + (goto-char (point-min)) + (while (search-forward "\r\n" nil t) + (replace-match "\n")) + (buffer-enable-undo) + (set-buffer-modified-p modified)))))) + +(defun archive-write-file-member () + (if archive-subfile-dos + (save-restriction + (widen) + (save-excursion + (goto-char (point-min)) + ;; We don't want our ^M^J <--> ^J changes to show in the undo list + (let ((undo-list buffer-undo-list)) + (unwind-protect + (progn + (setq buffer-undo-list t) + (while (search-forward "\n" nil t) + (replace-match "\r\n")) + (setq archive-subfile-dos nil) + (setq buffer-file-type t) + ;; OK, we're now have explicit ^M^Js -- save and re-unixfy + (archive-write-file-member)) + (progn + (archive-check-dos t) + (setq buffer-undo-list undo-list)))) + t)) + (save-excursion + (save-restriction + (message "Updating archive...") + (widen) + (let ((writer (save-excursion (set-buffer archive-superior-buffer) + (archive-name "write-file-member"))) + (archive (save-excursion (set-buffer archive-superior-buffer) + (buffer-file-name)))) + (if (fboundp writer) + (funcall writer archive archive-subfile-mode) + (archive-*-write-file-member archive + archive-subfile-mode + (symbol-value writer)))) + (set-buffer-modified-p nil) + (message "Updating archive...done") + (set-buffer archive-superior-buffer) + (revert-buffer) + t)))) + +(defun archive-*-write-file-member (archive descr command) + (let* ((ename (aref descr 0)) + (tmpfile (expand-file-name ename archive-tmpdir)) + (top (directory-file-name (file-name-as-directory archive-tmpdir))) + (default-directory (file-name-as-directory top))) + (unwind-protect + (progn + (make-directory (file-name-directory tmpfile) t) + (write-region (point-min) (point-max) tmpfile nil 'nomessage) + (if (aref descr 3) + ;; Set the file modes, but make sure we can read it. + (set-file-modes tmpfile (logior ?\400 (aref descr 3)))) + (let ((exitcode (apply 'call-process + (car command) + nil + nil + nil + (append (cdr command) (list archive ename))))) + (if (equal exitcode 0) + nil + (error "Updating was unsuccessful (%S)" exitcode)))) + (archive-delete-local tmpfile)))) + +(defun archive-write-file () + (save-excursion + (write-region archive-proper-file-start (point-max) buffer-file-name nil t) + (set-buffer-modified-p nil) + t)) +;; ------------------------------------------------------------------------- +;; Section: Marking and unmarking. + +(defun archive-flag-deleted (p &optional type) + "In archive mode, mark this member to be deleted from the archive. +With a prefix argument, mark that many files." + (interactive "p") + (or type (setq type ?D)) + (beginning-of-line) + (let ((sign (if (>= p 0) +1 -1)) + (modified (buffer-modified-p)) + buffer-read-only) + (while (not (zerop p)) + (if (archive-get-descr t) + (progn + (delete-char 1) + (insert type))) + (forward-line sign) + (setq p (- p sign))) + (set-buffer-modified-p modified)) + (archive-next-line 0)) + +(defun archive-unflag (p) + "In archive mode, un-mark this member if it is marked to be deleted. +With a prefix argument, un-mark that many files forward." + (interactive "p") + (archive-flag-deleted p ? )) + +(defun archive-unflag-backwards (p) + "In archive mode, un-mark this member if it is marked to be deleted. +With a prefix argument, un-mark that many members backward." + (interactive "p") + (archive-flag-deleted (- p) ? )) + +(defun archive-unmark-all-files () + "Remove all marks." + (interactive) + (let ((modified (buffer-modified-p)) + buffer-read-only) + (save-excursion + (goto-char archive-file-list-start) + (while (< (point) archive-file-list-end) + (or (= (following-char) ? ) + (progn (delete-char 1) (insert ? ))) + (forward-line 1))) + (set-buffer-modified-p modified))) + +(defun archive-mark (p) + "In archive mode, mark this member for group operations. +With a prefix argument, mark that many members. +Use \\[archive-unmark-all-files] to remove all marks." + (interactive "p") + (archive-flag-deleted p ?*)) + +(defun archive-get-marked (mark &optional default) + (let (files) + (save-excursion + (goto-char archive-file-list-start) + (while (< (point) archive-file-list-end) + (if (= (following-char) mark) + (setq files (cons (archive-get-descr) files))) + (forward-line 1))) + (or (nreverse files) + (and default + (list (archive-get-descr)))))) +;; ------------------------------------------------------------------------- +;; Section: Operate + +(defun archive-next-line (p) + (interactive "p") + (forward-line p) + (or (eobp) + (forward-char archive-file-name-indent))) + +(defun archive-previous-line (p) + (interactive "p") + (archive-next-line (- p))) + +(defun archive-chmod-entry (new-mode) + "Change the protection bits associated with all marked or this member. +The new protection bits can either be specified as an octal number or +as a relative change like \"g+rw\" as for chmod(2)" + (interactive "sNew mode (octal or relative): ") + (if archive-read-only (error "Archive is read-only")) + (let ((func (archive-name "chmod-entry"))) + (if (fboundp func) + (progn + (funcall func new-mode (archive-get-marked ?* t)) + (archive-resummarize)) + (error "Setting mode bits is not supported for this archive type")))) + +(defun archive-chown-entry (new-uid) + "Change the owner of all marked or this member." + (interactive "nNew uid: ") + (if archive-read-only (error "Archive is read-only")) + (let ((func (archive-name "chown-entry"))) + (if (fboundp func) + (progn + (funcall func new-uid (archive-get-marked ?* t)) + (archive-resummarize)) + (error "Setting owner is not supported for this archive type")))) + +(defun archive-chgrp-entry (new-gid) + "Change the group of all marked or this member." + (interactive "nNew gid: ") + (if archive-read-only (error "Archive is read-only")) + (let ((func (archive-name "chgrp-entry"))) + (if (fboundp func) + (progn + (funcall func new-gid (archive-get-marked ?* t)) + (archive-resummarize)) + (error "Setting group is not supported for this archive type")))) + +(defun archive-expunge () + "Do the flagged deletions." + (interactive) + (let (files) + (save-excursion + (goto-char archive-file-list-start) + (while (< (point) archive-file-list-end) + (if (= (following-char) ?D) + (setq files (cons (aref (archive-get-descr) 0) files))) + (forward-line 1))) + (setq files (nreverse files)) + (and files + (or (not archive-read-only) + (error "Archive is read-only")) + (or (yes-or-no-p (format "Really delete %d member%s? " + (length files) + (if (null (cdr files)) "" "s"))) + (error "Operation aborted")) + (let ((archive (archive-maybe-copy (buffer-file-name))) + (expunger (archive-name "expunge"))) + (if (fboundp expunger) + (funcall expunger archive files) + (archive-*-expunge archive files (symbol-value expunger))) + (archive-maybe-update nil) + (if archive-remote + (archive-resummarize) + (revert-buffer)))))) + +(defun archive-*-expunge (archive files command) + (apply 'call-process + (car command) + nil + nil + nil + (append (cdr command) (cons archive files)))) + +(defun archive-rename-entry (newname) + "Change the name associated with this entry in the tar file." + (interactive "sNew name: ") + (if archive-read-only (error "Archive is read-only")) + (if (string= newname "") + (error "Archive members may not be given empty names")) + (let ((func (archive-name "rename-entry")) + (descr (archive-get-descr))) + (if (fboundp func) + (progn + (funcall func (buffer-file-name) newname descr) + (archive-resummarize)) + (error "Renaming is not supported for this archive type")))) + +;; Revert the buffer and recompute the dired-like listing. +(defun archive-mode-revert (&optional no-autosave no-confirm) + (let ((no (archive-get-lineno))) + (setq archive-files nil) + (let ((revert-buffer-function nil)) + (revert-buffer t t)) + (archive-mode) + (goto-char archive-file-list-start) + (archive-next-line no))) + +(defun archive-undo () + "Undo in an archive buffer. +This doesn't recover lost files, it just undoes changes in the buffer itself." + (interactive) + (let (buffer-read-only) + (undo))) +;; ------------------------------------------------------------------------- +;; Section: Arc Archives + +(defun archive-arc-summarize () + (let ((p 1) + (totalsize 0) + (maxlen 8) + files + visual) + (while (and (< (+ p 29) (point-max)) + (eq (char-after p) ?\C-z) + (> (char-after (1+ p)) 0)) + (let* ((namefld (buffer-substring (+ p 2) (+ p 2 13))) + (fnlen (or (string-match "\0" namefld) 13)) + (efnname (substring namefld 0 fnlen)) + (csize (archive-l-e (+ p 15) 4)) + (moddate (archive-l-e (+ p 19) 2)) + (modtime (archive-l-e (+ p 21) 2)) + (ucsize (archive-l-e (+ p 25) 4)) + (fiddle (string= efnname (upcase efnname))) + (ifnname (if fiddle (downcase efnname) efnname)) + (text (format " %8d %-11s %-8s %s" + ucsize + (archive-dosdate moddate) + (archive-dostime modtime) + ifnname))) + (setq maxlen (max maxlen fnlen) + totalsize (+ totalsize ucsize) + visual (cons (vector text + (- (length text) (length ifnname)) + (length text)) + visual) + files (cons (vector efnname ifnname fiddle nil (1- p)) + files) + p (+ p 29 csize)))) + (goto-char (point-min)) + (let ((dash (concat "- -------- ----------- -------- " + (make-string maxlen ?-) + "\n"))) + (insert "M Length Date Time File\n" + dash) + (archive-summarize-files (nreverse visual)) + (insert dash + (format " %8d %d file%s" + totalsize + (length files) + (if (= 1 (length files)) "" "s")) + "\n")) + (apply 'vector (nreverse files)))) + +(defun archive-arc-rename-entry (archive newname descr) + (if (string-match "[:\\\\/]" newname) + (error "File names in arc files may not contain a path")) + (if (> (length newname) 12) + (error "File names in arc files are limited to 12 characters")) + (let ((name (concat newname (substring "\0\0\0\0\0\0\0\0\0\0\0\0\0" + (length newname)))) + buffer-read-only) + (save-restriction + (save-excursion + (widen) + (goto-char (+ archive-proper-file-start (aref descr 4) 2)) + (delete-char 13) + (insert name))))) +;; ------------------------------------------------------------------------- +;; Section: Lzh Archives + +(defun archive-lzh-summarize () + (let ((p 1) + (totalsize 0) + (maxlen 8) + files + visual) + (while (progn (goto-char p) (looking-at "..-l[hz][0-9]-")) + (let* ((hsize (char-after p)) + (csize (archive-l-e (+ p 7) 4)) + (ucsize (archive-l-e (+ p 11) 4)) + (modtime (archive-l-e (+ p 15) 2)) + (moddate (archive-l-e (+ p 17) 2)) + (fnlen (char-after (+ p 21))) + (efnname (buffer-substring (+ p 22) (+ p 22 fnlen))) + (fiddle (string= efnname (upcase efnname))) + (ifnname (if fiddle (downcase efnname) efnname)) + (p2 (+ p 22 fnlen)) + (creator (if (>= (- hsize fnlen) 24) (char-after (+ p2 2)) 0)) + (mode (if (eq creator ?U) (archive-l-e (+ p2 8) 2) ?\666)) + (modestr (if mode (archive-int-to-mode mode) "??????????")) + (uid (if (eq creator ?U) (archive-l-e (+ p2 10) 2))) + (gid (if (eq creator ?U) (archive-l-e (+ p2 12) 2))) + (text (if archive-alternate-display + (format " %8d %5S %5S %s" + ucsize + (or uid "?") + (or gid "?") + ifnname) + (format " %10s %8d %-11s %-8s %s" + modestr + ucsize + (archive-dosdate moddate) + (archive-dostime modtime) + ifnname)))) + (setq maxlen (max maxlen fnlen) + totalsize (+ totalsize ucsize) + visual (cons (vector text + (- (length text) (length ifnname)) + (length text)) + visual) + files (cons (vector efnname ifnname fiddle mode (1- p)) + files) + p (+ p hsize 2 csize)))) + (goto-char (point-min)) + (let ((dash (concat (if archive-alternate-display + "- -------- ----- ----- " + "- ---------- -------- ----------- -------- ") + (make-string maxlen ?-) + "\n")) + (header (if archive-alternate-display + "M Length Uid Gid File\n" + "M Filemode Length Date Time File\n")) + (sumline (if archive-alternate-display + " %8d %d file%s" + " %8d %d file%s"))) + (insert header dash) + (archive-summarize-files (nreverse visual)) + (insert dash + (format sumline + totalsize + (length files) + (if (= 1 (length files)) "" "s")) + "\n")) + (apply 'vector (nreverse files)))) + +(defconst archive-lzh-alternate-display t) + +(defun archive-lzh-extract (archive name) + (archive-extract-by-stdout archive name archive-lzh-extract)) + +(defun archive-lzh-resum (p count) + (let ((sum 0)) + (while (> count 0) + (setq count (1- count) + sum (+ sum (char-after p)) + p (1+ p))) + (logand sum 255))) + +(defun archive-lzh-rename-entry (archive newname descr) + (save-restriction + (save-excursion + (widen) + (let* ((p (+ archive-proper-file-start (aref descr 4))) + (oldhsize (char-after p)) + (oldfnlen (char-after (+ p 21))) + (newfnlen (length newname)) + (newhsize (+ oldhsize newfnlen (- oldfnlen))) + buffer-read-only) + (if (> newhsize 255) + (error "The file name is too long")) + (goto-char (+ p 21)) + (delete-char (1+ oldfnlen)) + (insert newfnlen newname) + (goto-char p) + (delete-char 2) + (insert newhsize (archive-lzh-resum p newhsize)))))) + +(defun archive-lzh-ogm (newval files errtxt ofs) + (save-restriction + (save-excursion + (widen) + (while files + (let* ((fil (car files)) + (p (+ archive-proper-file-start (aref fil 4))) + (hsize (char-after p)) + (fnlen (char-after (+ p 21))) + (p2 (+ p 22 fnlen)) + (creator (if (>= (- hsize fnlen) 24) (char-after (+ p2 2)) 0)) + buffer-read-only) + (if (= creator ?U) + (progn + (or (numberp newval) + (setq newval (funcall newval (archive-l-e (+ p2 ofs) 2)))) + (goto-char (+ p2 ofs)) + (delete-char 2) + (insert (logand newval 255) (lsh newval -8)) + (goto-char (1+ p)) + (delete-char 1) + (insert (archive-lzh-resum (1+ p) hsize))) + (message "Member %s does not have %s field" + (aref fil 1) errtxt))) + (setq files (cdr files)))))) + +(defun archive-lzh-chown-entry (newuid files) + (archive-lzh-ogm newuid files "an uid" 10)) + +(defun archive-lzh-chgrp-entry (newgid files) + (archive-lzh-ogm newgid files "a gid" 12)) + +(defun archive-lzh-chmod-entry (newmode files) + (archive-lzh-ogm + ;; This should work even though newmode will be dynamically accessed. + (function (lambda (old) (archive-calc-mode old newmode t))) + files "a unix-style mode" 8)) +;; ------------------------------------------------------------------------- +;; Section: Zip Archives + +(defun archive-zip-summarize () + (goto-char (- (point-max) (- 22 18))) + (search-backward-regexp "[P]K\005\006") + (let ((p (1+ (archive-l-e (+ (point) 16) 4))) + (maxlen 8) + (totalsize 0) + files + visual) + (while (string= "PK\001\002" (buffer-substring p (+ p 4))) + (let* ((creator (char-after (+ p 5))) + (method (archive-l-e (+ p 10) 2)) + (modtime (archive-l-e (+ p 12) 2)) + (moddate (archive-l-e (+ p 14) 2)) + (ucsize (archive-l-e (+ p 24) 4)) + (fnlen (archive-l-e (+ p 28) 2)) + (exlen (archive-l-e (+ p 30) 2)) + (fclen (archive-l-e (+ p 32) 2)) + (lheader (archive-l-e (+ p 42) 4)) + (efnname (buffer-substring (+ p 46) (+ p 46 fnlen))) + (isdir (and (= ucsize 0) + (string= (file-name-nondirectory efnname) ""))) + (mode (cond ((memq (char-int creator) '(2 3)) ; Unix + VMS + (archive-l-e (+ p 40) 2)) + ((memq (char-int creator) + '(0 5 6 7 10 11)) ; Dos etc. + (logior ?\444 + (if isdir (logior 16384 ?\111) 0) + (if (zerop + (logand 1 (char-after (+ p 38)))) + ?\222 0))) + (t nil))) + (modestr (if mode (archive-int-to-mode mode) "??????????")) + (fiddle (and archive-zip-case-fiddle + (not (not (memq (char-int creator) '(0 2 4 5 9)))))) + (ifnname (if fiddle (downcase efnname) efnname)) + (text (format " %10s %8d %-11s %-8s %s" + modestr + ucsize + (archive-dosdate moddate) + (archive-dostime modtime) + ifnname))) + (setq maxlen (max maxlen fnlen) + totalsize (+ totalsize ucsize) + visual (cons (vector text + (- (length text) (length ifnname)) + (length text)) + visual) + files (cons (if isdir + nil + (vector efnname ifnname fiddle mode + (list (1- p) lheader))) + files) + p (+ p 46 fnlen exlen fclen)))) + (goto-char (point-min)) + (let ((dash (concat "- ---------- -------- ----------- -------- " + (make-string maxlen ?-) + "\n"))) + (insert "M Filemode Length Date Time File\n" + dash) + (archive-summarize-files (nreverse visual)) + (insert dash + (format " %8d %d file%s" + totalsize + (length files) + (if (= 1 (length files)) "" "s")) + "\n")) + (apply 'vector (nreverse files)))) + +(defun archive-zip-extract (archive name) + (if archive-zip-use-pkzip + (archive-*-extract archive name archive-zip-extract) + (archive-extract-by-stdout archive name archive-zip-extract))) + +(defun archive-zip-write-file-member (archive descr) + (archive-*-write-file-member + archive + descr + (if (aref descr 2) archive-zip-update-case archive-zip-update))) + +(defun archive-zip-chmod-entry (newmode files) + (save-restriction + (save-excursion + (widen) + (while files + (let* ((fil (car files)) + (p (+ archive-proper-file-start (car (aref fil 4)))) + (creator (char-after (+ p 5))) + (oldmode (aref fil 3)) + (newval (archive-calc-mode oldmode newmode t)) + buffer-read-only) + (cond ((memq (char-int creator) '(2 3)) ; Unix + VMS + (goto-char (+ p 40)) + (delete-char 2) + (insert (logand newval 255) (lsh newval -8))) + ((memq (char-int creator) '(0 5 6 7 10 11)) ; Dos etc. + (goto-char (+ p 38)) + (insert (logior (logand (char-after (point)) 254) + (logand (logxor 1 (lsh newval -7)) 1))) + (delete-char 1)) + (t (message "Don't know how to change mode for this member")))) + (setq files (cdr files)))))) +;; ------------------------------------------------------------------------- +;; Section: Zoo Archives + +(defun archive-zoo-summarize () + (let ((p (1+ (archive-l-e 25 4))) + (maxlen 8) + (totalsize 0) + files + visual) + (while (and (string= "\334\247\304\375" (buffer-substring p (+ p 4))) + (> (archive-l-e (+ p 6) 4) 0)) + (let* ((next (1+ (archive-l-e (+ p 6) 4))) + (moddate (archive-l-e (+ p 14) 2)) + (modtime (archive-l-e (+ p 16) 2)) + (ucsize (archive-l-e (+ p 20) 4)) + (namefld (buffer-substring (+ p 38) (+ p 38 13))) + (dirtype (char-after (+ p 4))) + (lfnlen (if (= dirtype 2) (char-after (+ p 56)) 0)) + (ldirlen (if (= dirtype 2) (char-after (+ p 57)) 0)) + (fnlen (+ ldirlen + (if (> lfnlen 0) + (1- lfnlen) + (or (string-match "\0" namefld) 13)))) + (efnname (concat + (if (> ldirlen 0) + (concat (buffer-substring + (+ p 58 lfnlen) (+ p 58 lfnlen ldirlen -1)) + "/") + "") + (if (> lfnlen 0) + (buffer-substring (+ p 58) (+ p 58 lfnlen -1)) + (substring namefld 0 fnlen)))) + (fiddle (and (= lfnlen 0) (string= efnname (upcase efnname)))) + (ifnname (if fiddle (downcase efnname) efnname)) + (text (format " %8d %-11s %-8s %s" + ucsize + (archive-dosdate moddate) + (archive-dostime modtime) + ifnname))) + (setq maxlen (max maxlen fnlen) + totalsize (+ totalsize ucsize) + visual (cons (vector text + (- (length text) (length ifnname)) + (length text)) + visual) + files (cons (vector efnname ifnname fiddle nil (1- p)) + files) + p next))) + (goto-char (point-min)) + (let ((dash (concat "- -------- ----------- -------- " + (make-string maxlen ?-) + "\n"))) + (insert "M Length Date Time File\n" + dash) + (archive-summarize-files (nreverse visual)) + (insert dash + (format " %8d %d file%s" + totalsize + (length files) + (if (= 1 (length files)) "" "s")) + "\n")) + (apply 'vector (nreverse files)))) + +(defun archive-zoo-extract (archive name) + (archive-extract-by-stdout archive name archive-zoo-extract)) +;; ------------------------------------------------------------------------- +(provide 'archive-mode) + +;;; arc-mode.el ends here. diff --git a/background.el b/background.el new file mode 100644 --- /dev/null +++ b/background.el @@ -0,0 +1,137 @@ +;;; background.el --- fun with background jobs + +;; Copyright (C) 1988 Joe Keane <jk3k+@andrew.cmu.edu> +;; Keywords: processes + +;; This file is part of XEmacs. + +;; XEmacs 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 2 of the License, or +;; (at your option) any later version. + +;; XEmacs 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 XEmacs; if not, write to the Free Software +;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. + +;;; Synched up with: Not in FSF + +;;; Commentary: + +;; - Adapted to use comint and cleaned up somewhat. Olin Shivers 5/90 +;; - Background failed to set the process buffer's working directory +;; in some cases. Fixed. Olin 6/14/90 +;; - Background failed to strip leading cd's off the command string +;; after performing them. This screwed up relative pathnames. +;; Furthermore, the proc buffer's default dir wasn't initialised +;; to the user's buffer's default dir before doing the leading cd. +;; This also screwed up relative pathnames if the proc buffer already +;; existed and was set to a different default dir. Hopefully we've +;; finally got it right. The pwd is now reported in the buffer +;; just to let the user know. Bug reported by Piet Van Oostrum. +;; Olin 10/19/90 +;; - Fixed up the sentinel to protect match-data around invocations. +;; Also slightly rearranged the cd match code for similar reasons. +;; Olin 7/16/91 +;; - Dec 29 1995: changed for new stuff (shell-command-switch, second +;; arg to shell-command --> BUFFER-NAME arg to background) from +;; FSF 19.30. Ben Wing + +;;; Code: + +(provide 'background) +(require 'comint) + +(defgroup background nil + "Fun with background jobs" + :group 'processes) + + +;; user variables +(defcustom background-show t + "*If non-nil, background jobs' buffers are shown when they're started." + :type 'boolean + :group 'background) +(defcustom background-select nil + "*If non-nil, background jobs' buffers are selected when they're started." + :type 'boolean + :group 'background) + +;;;###autoload +(defun background (command &optional buffer-name) + "Run COMMAND in the background like csh. +A message is displayed when the job starts and finishes. The buffer is in +comint mode, so you can send input and signals to the job. The process object +is returned if anyone cares. See also comint-mode and the variables +background-show and background-select. + +Optional second argument BUFFER-NAME is a buffer to insert the output into. +If omitted, a buffer name is constructed from the command run." + (interactive "s%% ") + (let ((job-number 1) + job-name + (dir default-directory)) + (while (get-process (setq job-name (format "background-%d" job-number))) + (setq job-number (1+ job-number))) + (or buffer-name + (setq buffer-name (format "*%s*" job-name))) + (if background-select (pop-to-buffer buffer-name) + (if background-show (with-output-to-temp-buffer buffer-name)) ; cute + (set-buffer (get-buffer-create buffer-name))) + (erase-buffer) + + (setq default-directory dir) ; Do this first, in case cd is relative path. + (if (string-match "^cd[\t ]+\\([^\t ;]+\\)[\t ]*;[\t ]*" command) + (let ((dir (substring command (match-beginning 1) (match-end 1)))) + (setq command (substring command (match-end 0))) + (setq default-directory + (file-name-as-directory (expand-file-name dir))))) + + (insert "--- working directory: " default-directory + "\n% " command ?\n) + + (let ((proc (get-buffer-process + (comint-exec buffer-name job-name shell-file-name + nil (list shell-command-switch command))))) + (comint-mode) + ;; COND because the proc may have died before the G-B-P is called. + (cond (proc (set-process-sentinel proc 'background-sentinel) + (message "[%d] %d" job-number (process-id proc)))) + (setq mode-name "Background") + proc))) + + +(defun background-sentinel (process msg) + "Called when a background job changes state." + (let ((ms (match-data))) ; barf + (unwind-protect + (let ((msg (cond ((string= msg "finished\n") "Done") + ((string-match "^exited" msg) + (concat "Exit " (substring msg 28 -1))) + ((zerop (length msg)) "Continuing") + (t (concat (upcase (substring msg 0 1)) + (substring msg 1 -1)))))) + (message "[%s] %s %s" (process-name process) + msg + (nth 2 (process-command process))) + (if (null (buffer-name (process-buffer process))) + (set-process-buffer process nil) ; WHY? Olin. + (if (memq (process-status process) '(signal exit)) + (save-excursion + (set-buffer (process-buffer process)) + (let ((at-end (eobp))) + (save-excursion + (goto-char (point-max)) + (insert ?\n msg ? + (substring (current-time-string) 11 19) ?\n)) + (if at-end (goto-char (point-max)))) + (set-buffer-modified-p nil))))) + (store-match-data ms)))) + +;;; background.el ends here diff --git a/crypt.el b/crypt.el new file mode 100644 --- /dev/null +++ b/crypt.el @@ -0,0 +1,2649 @@ +;;; crypt.el --- code for handling all sorts of compressed and encrypted files + +;; Author: Lawrence R. Dodd <dodd@roebling.poly.edu> +;; Rod Whitby <rwhitby@research.canon.oz.au> +;; Kyle E. Jones <kyle@uunet.uu.net> +;; Maintainer: Lawrence R. Dodd <dodd@roebling.poly.edu> +;; Created: crypt.el in 1988, crypt++.el on 18 Jan 1993 +;; Version: 2.83 +;; Date: 1994/03/31 12:30:17 +;; Keywords: extensions + +;;; Copyright (C) 1994 Lawrence R. Dodd +;;; Copyright (C) 1993 Lawrence R. Dodd and Rod Whitby +;;; Copyright (C) 1988, 1989, 1990 Kyle E. Jones +;;; +;;; 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 2 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, write to the Free Software +;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +;;; Synched up with: Not in FSF. + +;;; Commentary: + +;;; NOTE: Apparently not being maintained by the author, who now +;;; uses jka-compr.el. --ben (1/26/96) +;;; Included patch (1/26/96) + +;;; Please see notes on INSTALLATION and USAGE on the pages below. + +;;; LCD Archive Entry: +;;; crypt++|Rod Whitby and Lawrence R. Dodd|dodd@roebling.poly.edu| +;;; Code for handling all sorts of compressed and encrypted files.| +;;; 1994/03/31 12:30:17|2.83|~/misc/crypt++.el.Z| + +;;; AVAILABLE: +;;; +;;; via anonymous ftp to roebling.poly.edu [128.238.5.31] in +;;; /pub/lisp/crypt++.el.gz +;;; +;;; via anonymous ftp to archive.cis.ohio-state.edu [128.146.8.52] in +;;; /pub/gnu/emacs/elisp-archive/misc/crypt++.el.Z + +;;; BUG REPORTS +;;; +;;; Type M-x crypt-submit-report to generate a bug report template or put your +;;; cursor at the end of this line and type C-x C-e: (crypt-submit-report) +;;; +;;; Please note that this bug-report facility (crypt-submit-report) uses Barry +;;; Warsaw's reporter.el which is part of GNU Emacs v19 and bundled with many +;;; other packages. If needed, you can obtain a copy of reporter.el at +;;; /roebling.poly.edu:/pub/reporter.el or the elisp-archive. In fact, +;;; crypt-submit-report will attempt to ange-ftp a copy for you from roebling +;;; if you do not have one accessible. + +;;; Lawrence R. Dodd <dodd@roebling.poly.edu> +;;; Polytechnic University +;;; Brooklyn, New York USA + +;;; VERSION: +;;; +;;; Version: 2.83 +;;; Ident: crypt++.el,v 2.82 1994/03/31 12:30:17 dodd Exp +;;; Date: 1994/03/31 12:30:17 + + +;;; INSTALLATION: +;;; +;;; To use this package, simply put it in a file called "crypt.el" in a Lisp +;;; directory known to Emacs (see `load-path'), byte-compile it (you may get a +;;; warning saying that the function reporter-submit-bug-report is not known +;;; to be defined -- ignore it), and put the line: +;;; +;;; (require 'crypt) +;;; +;;; in your ~/.emacs file or in the file default.el in the ../lisp directory +;;; of the Emacs distribution. Do not bother trying to autoload this file; +;;; this package uses find-file and write-file hooks and thus should be loaded +;;; the first time you visit any sort of file. Any package loaded after this +;;; one that appends something to `write-file-hooks' will not be executed +;;; because this package writes out the file. Other packages that append to +;;; `write-file-hooks' should either be modified to prepend to that hook or be +;;; loaded before this one (preferably the former). + +;;; NOTE: encryption users should set `crypt-encryption-type' to one of the +;;; values in `crypt-encryption-alist' (see USAGE below). + +;;; SEE ALSO: /roebling.poly.edu:/pub/crypt++-fnf.el for file-not-found +;;; support for GNU Emacs. + +;;; SPECIAL NOTES: +;;; +;;; If crypt is dumped with the emacs executable, or if it has already been +;;; loaded in an emacs session, then modifying the variables used in building +;;; the encryption and encoding tables will have no effect until these tables +;;; are rebuilt. This may be done with `M-x crypt-rebuild-tables'. See USAGE +;;; below to determine variables for which this is needed. For example, +;;; post-load changes to `crypt-encryption-file-extension' or +;;; `crypt-freeze-vs-fortran' can be incorporated into the encryption table +;;; via `M-x crypt-rebuild-tables'. Similarly, post-load changes to +;;; `crypt-bind-insert-file' are handled with `M-x crypt-bind-insert-file'. + + +;;; USAGE: +;;; +;;; By default, intended to be transparent. User-defined variables +;;; +;;; controlling ENCRYPTION are +;;; +;;; crypt-encryption-type +;;; crypt-encryption-file-extension +;;; crypt-never-ever-decrypt +;;; crypt-auto-write-buffer-encrypted +;;; crypt-confirm-password +;;; crypt-encrypted-disable-auto-save +;;; crypt-encryption-alist +;;; +;;; controlling ENCODING are +;;; +;;; crypt-auto-decode-buffer +;;; crypt-auto-write-buffer +;;; crypt-query-if-interactive +;;; crypt-no-extension-implies-plain +;;; crypt-freeze-vs-fortran +;;; crypt-compact-vs-C++ +;;; crypt-ignored-filenames +;;; crypt-default-encoding +;;; crypt-encoded-disable-auto-save +;;; crypt-encoding-alist +;;; +;;; controlling file insertion are +;;; +;;; crypt-bind-insert-file +;;; crypt-auto-decode-insert +;;; +;;; To find out more about these variables, load this file, put your cursor at +;;; the end of any of the variable names, and hit C-h v [RET]. +;;; +;;; NOTE: encryption users should set `crypt-encryption-type' to one of the +;;; values in `crypt-encryption-alist' +;;; +;;; Although rarely needed, the following functions may be called interactively +;;; +;;; (crypt-encoded-mode) +;;; (crypt-encode-region) +;;; (crypt-encrypted-mode) +;;; (crypt-encrypt-region) +;;; (crypt-set-encryption-key) +;;; (crypt-rebuild-tables) +;;; (crypt-insert-file) +;;; (crypt-bind-insert-file) +;;; (crypt-submit-report) +;;; +;;; To find out more about these functions, load this file, put your cursor +;;; inside any of the `()' of the above lines, and hit C-h f [RET]. + + +;;; NOTES ON INTERFACES WITH OTHER PROGRAMS AND PACKAGES: +;;; +;;; GZIP: the environment variable GZIP of gzip can cause an error if it +;;; contains `--verbose' because standard output messages will be appended to +;;; gzip'ed files. This corrupts the files. The cleanest solution is to pass +;;; the `--quiet' switch in `crypt-encoding-alist' to override this. use gzip +;;; version 1.0.4 or higher from prep.ai.mit.edu:/pub/gnu +;;; +;;; TAR-MODE: works properly with version 1.28 (or higher) with v19 emacs. + + +;;; DESCRIPTION: +;;; +;;; The basic purpose of this package of Lisp functions is to recognize +;;; automatically encrypted and encoded (i.e., compressed) files when they are +;;; first visited or written. The BUFFER corresponding to the file is decoded +;;; and/or decrypted before it is presented to the user. The file itself is +;;; unchanged on the disk. When the buffer is subsequently saved to disk, a +;;; hook function re-encodes the buffer before the actual disk write takes +;;; place. +;;; +;;; This package recognizes all sorts of compressed files by a magic number at +;;; the beginning of these files but uses a heuristic to detect encrypted +;;; files. If you are asked for an encryption key for a file that is in fact +;;; not encrypted, just hit RET and the file will be accepted as is, and the +;;; crypt minor mode will not be entered. +;;; +;;; Other types of encoding programs may be added to this package by using the +;;; variable `crypt-encoding-alist' which contains a table of encoding +;;; programs such as compress, gzip (GNU zip), freeze, and compact. +;;; +;;; This new extended version of crypt now monitors the filename extensions of +;;; buffers that are written out using write-file (C-x C-w). If the filename +;;; extension matches one of the extensions listed in `crypt-encoding-alist,' +;;; then this package will write the file out using the corresponding encoding +;;; (compression) method. This is done whether or not the buffer originated +;;; from a previously encoded (compressed) file. +;;; +;;; Thus, if the user is editing a file that may or may not have been encoded +;;; originally (e.g., foobar.Z or foobar) and decides to write it to a +;;; different file (e.g., barfoo or barfoo.z or barfoo.C). This package will +;;; examine the filename extension and write the buffer in plain format or an +;;; alternate encoding (compression) format by searching through the entries +;;; in the table of encoding methods `crypt-encoding-alist.' This change in +;;; encoding state is done automatically if the variable +;;; `crypt-auto-write-buffer' is t otherwise the user is asked. + + +;;; TO DO/KNOWN BUGS/HELP WANTED/APPLY WITHIN: +;;; +;;; All Users/hackers out there are strongly encouraged to pursue any of these +;;; matters further (especially those that concern encryption and decryption!). +;;; It is important to future programmers and modifiers of crypt++.el to know +;;; about its perceived limitations. Since necessity drives invention, users +;;; who find any of the following features of crypt++.el annoying are asked to +;;; make suggestions and send patches (again, especially those that concern +;;; encryption and decryption!). +;;; +;;; * currently crypt++ assumes that if a file is both encrypted and encoded +;;; (i.e., compressed) that the order in which it was done was encryption +;;; first _then_ compression. As has been pointed by many people compression +;;; following encryption is useless since the encrypted file is basically +;;; random. On the other hand, many agree that doing encryption _following_ +;;; compression is better since it makes it harder to crack the encryption. +;;; We would like to make the ordering of these two user-configurable or if +;;; nothing else change the order. +;;; +;;; Having read the above however, Francois Pinard <pinard@iro.umontreal.ca> +;;; writes that encryption following compression may not be harder to crack +;;; since "the fact that the first few uncrypted bytes are expected (the +;;; compress signature) facilitates a serious attempt at uncrypting." +;;; jwz agrees with Francois. +;;; +;;; * get write-region and append-to-file to handle encoded and encrypted +;;; files. There is an interesting low-level encoding package by Jay Adams +;;; <jka@ece.cmu.edu> called jka-compr.el that might address some of these +;;; issues. We encourage hackers out there to come up with crypt++ versions +;;; of write-region and append-to-file. The difficulty is creating versions +;;; that mimic the originals as closely as possible. +;;; +;;; * instead of using call-process-region (which can fail badly if the region +;;; is large and there's not much room in /tmp), write the region to a temp +;;; file (with a customisable location) and use call-process directly. +;;; +;;; * users have mentioned trouble using crypt++ and hilit simultaneously since +;;; the functions in write-file-hook for both write the file to disk and +;;; return t. A possible solution is to have one of them write to a +;;; scratch buffer instead of to disk and return nil and then allow the +;;; other to do its work on the scratch buffer and write it to disk. Thanks +;;; to Wayne Folta <folta@cs.UMD.EDU> and Amir J Katz <amir@matis.ingr.com>. +;;; It would be nice to have another way in emacs to have an +;;; after-write-file-hook and a before-write-file-hook of some sort. +;;; Lucid Emacs has an after-write-file-hook. Recent versions of hilit19.el +;;; do not automatically attach to `write-file-hooks' and return t. +;;; However, the general problem of multiple packages returning t still +;;; remains. dos-mode.el and crypt.el also conflict. +;;; +;;; * another possible source of trouble is with encryption (and encoding) +;;; programs sticking verbose output into buffers prior to being written to +;;; disk. This was definitely occurring with gzip because of --verbose in +;;; the GZIP environment variable and is solved/hidden with the --quiet +;;; switch. However, I suspect that some encryption problems out there are +;;; capable of similar things so the user should be careful. +;;; +;;; * integrating crypt++ with a backgrounding package such as Olin Shivers' +;;; `background.el' might be useful too. thanks to Mark Borges +;;; <mdb@noaacrd.Colorado.EDU> for suggesting this. +;;; +;;; * Performing M-x crypt-encode-buffer or M-x crypt-encrypt-buffer and then +;;; saving the file would possibly cause errors. It is better to toggle +;;; `crypt-encoded-mode' (or `crypt-encrypted-mode') and simply save the +;;; file. It is for this reason that `crypt-encode-buffer' and +;;; `crypt-encrypt-buffer' are not interactive. +;;; +;;; * use plists instead of alists replacing calls to `nth' with `get' +;;; +;;; * merge encryption code completely into encoding code making encryption +;;; just a special case of encoding. + + +;;; Change log: +;;; +;;; 1.1 - original version of crypt.el +;;; 1.2 - +;;; jwz: works with tar-mode.el +;;; jwz: applied patch from piet, merged with Lawrence Dodd's gzip version +;;; 1.3 - +;;; lrd: fixed compress-magic-regexp +;;; 1.4, 1.5, 1.6 - +;;; lrd: write-file compresses or gzips based on file extension +;;; 2.1 - +;;; lrd: merged with Rod Whitby's table-driven version (major upgrade) +;;; 2.2 - +;;; rjw: Changed file name to crypt++.el, so archie and lispdir can find it. +;;; 2.3 - +;;; rjw: Separated the hook additions and minor mode alist additions. +;;; 2.4 - +;;; rjw: Fixed the interactive form for crypt-buffer. +;;; 2.5 - +;;; lrd: doc mods, changed GNU free software notice (was out of date), added +;;; anonymous ftp information +;;; 2.6 - +;;; lrd: added back in definition of `buffer' in defun crypt-buffer caused +;;; an error when trying to read encrypted file; modified check for minor +;;; mode alist addition; added gzip magic number warning +;;; 2.7 - [posted to gnu.emacs.sources] +;;; lrd: added `TO DO' and `KNOW BUGS' section to header +;;; 2.8 - +;;; lrd: added note about updating to v 1.24 of tar-mode.el +;;; Thanks to Mark Borges <mdb@noaacrd.Colorado.EDU> +;;; 2.9 - +;;; lrd: moved query about `crypt-freeze-vs-fortran' out of defvar for +;;; `crypt-encoding-alist,' an erroneous value of nil was being stuck into +;;; alist when user set `crypt-freeze-vs-fortran' was nil, doc mod. +;;; Thanks to Mark Borges <mdb@noaacrd.Colorado.EDU> +;;; 2.10 - +;;; rjw: moved query about `crypt-freeze-vs-fortran' back into defvar for +;;; `crypt-encoding-alist,' - used append to ignore the erroneous nil. +;;; 2.11 - +;;; rjw: fixed a bug in my fix :-( +;;; 2.12 - +;;; rjw: Defvar crypt-magic-regexp and crypt-magic-regexp-inverse and +;;; allow either a regexp or an elisp expression. +;;; Suggested by Franc,ois Pinard <pinard@iro.umontreal.ca>. +;;; 2.13 - +;;; lrd: added in info on lispdir.el, doc mods and some puttering while +;;; looking over rjw's v 2.12 mods. +;;; 2.14 - +;;; lrd: doc mod - trivial huh? switched `compact' and `gzip' in +;;; `crypt-encoding-alist' - want gzip near top +;;; 2.15 - +;;; lrd: added in LCD Archive Entry and modified comments on tar-mode.el +;;; since the version at the elisp-archive now works with crypt++.el +;;; 2.16 - +;;; lrd: provide `crypt' as well as `crypt++' allowing something like `ln -s +;;; crypt++.el crypt.el' to be meaningful +;;; Suggested (by|as) Per Abrahamsen <amanda@iesd.auc.dk> +;;; 2.17 - +;;; lrd: clarified bug report procedure, added fancy pseudo-graphics, added +;;; to the `TO DO' list, put RCS tags in LCD Archive entry +;;; 2.18 - [posted to gnu.emacs.sources] +;;; lrd: included pointer to elisp archive in crypt-version description, +;;; changed "Decode buffer %s? " to "Decode %s? " in crypt-find-file-hook +;;; to be more general (mainly for crypt-insert-file) +;;; 2.19 - +;;; rjw: Added the crypt-compact-vs-C++ switch to distinguish compacted and +;;; C++ files. +;;; 2.20 - +;;; lrd: (1) modified interactive form of crypt-buffer. (2) made search +;;; case-insensitive in crypt-submit-report. (3) modified encoded-mode and +;;; crypt-mode so that buffer-modified is not unconditionally set to nil +;;; when the mode is not changed. Thanks to Gerd Hillebrand +;;; <ggh@cs.brown.edu> for suggesting (2) and (3). +;;; 2.21 - +;;; rjw: Added an entry to the TODO list about the hazards of using +;;; call-process-region on a large region and not much room in /tmp +;;; (David Carlisle <carlisle@computer-science.manchester.ac.uk>). +;;; 2.22 - +;;; lrd: allow write-file-hooks to contain functions as well as lists. +;;; Contributed by Ken Laprade <laprade@trantor.harris-atd.com>. +;;; 2.23 - +;;; lrd: made crypt-submit-report list values of more user-defined variables +;;; 2.24 - +;;; lrd: pass the -q switch to gzip to thwart the possibility of a --verbose +;;; in the GZIP environment variable +;;; 2.25 - +;;; lrd: added some more to the TO DO list, clarified some things, also +;;; untabified the entire file (I got tired of the control I's) +;;; 2.26 - +;;; lrd: use the long-named options for GNU zip (self-documenting) +;;; 2.27 - +;;; lrd: included observation by Francois Pinard <pinard@iro.umontreal.ca> +;;; and worked on text in TO DO/KNOWN BUGS list +;;; 2.28 - +;;; lrd: added two new variables in (crypt-submit-report) to the list stuck +;;; at the bottom of the mail message; changed the comments regarding the +;;; user-defined variables. added in default values in user defined +;;; variables. added to and removed stuff to the `TO DO' list. +;;; +;;; (encoded-mode): +;;; added in code to remove any auto-save-files that may have been formed +;;; before becoming an encoded buffer (for example a plain file saved to +;;; disk encoded had orphan auto-save-files left behind). turning off +;;; auto-save-mode disables the creation of auto-save-files, but it also +;;; disables the possibility of these being removed when the buffer is +;;; saved. +;;; +;;; (crypt-region): +;;; now call the encryption and decryption program directly instead of +;;; through the shell. this is more secure since the shell will expose the +;;; password (key). thanks to Jon Cargille <jcargill@cs.wisc.edu>. defined +;;; two new variables `crypt-decryption-args' and `crypt-encryption-args' to +;;; take the arguments separately. removed (let ((opoint)...)) construct +;;; this was a throw back to some old dead code and was not being used. +;;; 2.29 - +;;; lrd: added three new variables in (crypt-submit-report); added to the +;;; `TO DO' list. +;;; +;;; (encode-region,encode-buffer,encoded-mode): fixed interactive forms - +;;; the conversion to table version had eliminated some of the interactive +;;; features of these. thanks to Kimball Collins <kpc@ptolemy.arc.nasa.gov> +;;; for point this out. new interactive form uses functions +;;; `crypt-get-encoding-type' and `crypt-symbol-alist-to-table' and variable +;;; `crypt-default-encoding' to generate completion list of encoding types. +;;; +;;; (crypt-write-file-hook): two new user-defined variables +;;; `crypt-query-if-interactive' and `crypt-no-extension-implies-plain' and +;;; the buffer-local variable `buffer-interactive-mode' are used to help +;;; determined whether or not plain output is really desired for files +;;; without a compression file-name extension. the default behavior is the +;;; same as before. +;;; 2.30 - +;;; lrd: added test for user-defined variable `crypt-never-ever-decrypt' +;;; when finding a file. some users may never wish to decrypt files +;;; and like to edit binary files. thanks to Nelson Minar +;;; <nelson@reed.edu>. added to doc-strings of +;;; `crypt-magic-regexp[-inverse]' -- these can be set to nil[t] and +;;; accomplish the same thing as setting `crypt-never-ever-decrypt' to t +;;; 2.31 - +;;; rjw: Updated the comments in the encryption check section. +;;; 2.32 - [posted to gnu.emacs.sources] +;;; lrd: added warning about `crypt-(de|en)cryption-program'; doc mod. +;;; 2.33 - +;;; lrd: if `crypt-(de|en)cryption-args' are nil then don't pass any +;;; arguments to (de|en)cryption program, nil is the default instead of +;;; "". Thanks to Joe Ilacqua <spike@world.std.com>, David J. Schur +;;; <djs@idm.com>, Peter Nuth <nuth@ai.mit.edu>, and Greg Larson +;;; <glarson@bnr.ca>. `-q' exists in gzip 1.0.3 but not `--quiet' changed +;;; GZIP NOTE. Thanks to Chris Moore <moore@src.bae.co.uk>. +;;; 2.34 - +;;; lrd: allow `crypt-(de|en)cryption-args' to be a list of strings -- more +;;; robust. query for password (key), if none is set, when writing out file +;;; for which `buffer-save-encrypted' is t. Thanks to John Interrante +;;; <interran@uluru.Stanford.EDU>. (crypt-write-file-hook): check filename +;;; extension against regexp `crypt-encryption-file-extension' and query for +;;; encryption, unless `crypt-auto-write-buffer-encrypted' is t (don't +;;; bother doing reverse check, encrypted to plain, not a common request). +;;; (crypt-mode): delete auto-save files (cf., encoded-mode), may exist now. +;;; (read-string-no-echo): applied patch from Piet van Oostrum +;;; <piet@cs.ruu.nl> -- set `cursor-in-echo-area' _after_ setting buffer +;;; (this was screwing up gnews). +;;; 2.35 - +;;; lrd: doc mod +;;; 2.36 - +;;; lrd: fixed typo, added RMAIL note. +;;; 2.37 - [posted to gnu.emacs.sources] +;;; lrd: +;;; (crypt-write-file-hook): search user-defined list +;;; `crypt-ignored-filenames' for possible match with `buffer-filename' +;;; before attempting conversion from compressed to plain format; useful for +;;; compressed incoming mail files (e.g., RMAIL, INBOX). +;;; +;;; (crypt-mode): query for key if not set already; need to switch order of +;;; recovering key and toggling crypt-mode in crypt-find-file-hook (thanks +;;; to Piet van Oostrum <piet@cs.ruu.nl>). +;;; +;;; (crypt-buffer) and (encode-buffer): remove interactive form; use +;;; (crypt-mode) and (encoded-mode) instead so encryption and compression +;;; are done at the very end; leave interactive form in (crypt-region) and +;;; (encode-region) may still be used. +;;; +;;; (set-encryption-key): remove from `command-history' if called +;;; interactively - thanks to George M. Georgiou +;;; <georgiou@silicon.csci.csusb.edu>. +;;; 2.38 - +;;; lrd: added `crypt-' prefix to `(read-string-no-echo)' and `(save-point)' +;;; changed file extension for gzip files to `.z' _or_ `.gz' (future release +;;; of gzip with use later extension by default and so this should be +;;; changed to just `.gz' someday). +;;; 2.39 - +;;; lrd: doc mod. added in patch from jwz - `(crypt-read-string-no-echo)' is +;;; more secure, put property 'permanent-local on buffer-locals works for +;;; Lucid Emacs and doesn't harm v18 emacs, change `buffer-interactive-mode' +;;; to `buffer-interactive-encoded-mode.' +;;; 2.40 - +;;; lrd: put property 'preserved in case kill-fix.el is being used. +;;; 2.41 - +;;; lrd: all functions and variables now start with `crypt-', moved REVISION +;;; HISTORY to bottom of header, interactive version of +;;; `(crypt-encrypt-region)' clearer, `(crypt-read-string-no-echo)' now +;;; echos `.' +;;; 2.42 - +;;; lrd: (crypt-check-extension-for-encoding): broke out of +;;; `(crypt-write-file-hook)'. setting user variables +;;; `crypt-compact-vs-C++' and `crypt-freeze-vs-fortran' to nil no longer +;;; completely disables the reading compact'ed and frozen files but just +;;; disables the use of the file-extension tricks of +;;; `(crypt-check-extension-for-encoding).' (crypt-encode-region): allow +;;; for a single line message from encoding program at top of region; if it +;;; is there, then remove it; kludge for `compact' program. +;;; 2.43 - +;;; lrd: (crypt-encode-region): generalize the clean up procedure; add +;;; element to `crypt-encoding-alist' and introduce new function +;;; `(crypt-encoding-cleanup-regexp)' to extract a compression specific +;;; regexp for erroneous message or lisp expression for cleanup. +;;; 2.44 - +;;; lrd: new element for `crypt-encoding-alist' handles whether or not +;;; file-name extension tricks may be play with encoding method; compact and +;;; freeze values default to `crypt-compact-vs-C++' and +;;; `crypt-freeze-vs-fortran' (thanks to rjw); +;;; (crypt-encoding-extension-tricks): new defun to handle this; +;;; (crypt-check-extension-for-encoding): monitors "tricks" entry of +;;; `crypt-encoding-alist' and adjust the bag of tricks it can apply. +;;; 2.45 - +;;; lrd: (crypt-encode-region): delete entire match of cleanup regexp by +;;; requiring newlines in GARBAGE-REGEXP-OR-LISPEXP. (crypt-submit-report): +;;; use Warsaw's reporter.el. +;;; 2.46 - +;;; lrd: (crypt-find-file-hook, crypt-write-file-hook): cleaned, documented, +;;; and replaced occurrences of `(cond (C BODY))' with `(if C BODY)'; +;;; changed `crypt-magic-regexp' to `crypt-encryption-magic-regexp' and +;;; `crypt-magic-regexp-inverse' to `crypt-encryption-magic-regexp-inverse' +;;; for consistency with other variable names. new user-defined variable +;;; `crypt-encryption-minor-mode-name' instead of always "Crypt". grouped +;;; all encryption variables together. +;;; 2.47 - +;;; lrd: somewhat major change - put program-specific encryption variables +;;; into a single table `crypt-encryption-alist' and let the variable +;;; `crypt-encryption-type' define the appropriate entry to use; new +;;; user-defined variable `crypt-confirm-password,' thanks to Jeff Clark +;;; <jclark@src.honeywell.com>. (crypt-submit-report): improved error +;;; handling, thanks to baw. (crypt-write-file-hook): fixed bug with +;;; `crypt-encoding-extension-tricks' +;;; 2.48 - +;;; lrd: added dummy argument to `crypt-encoding-alist' and +;;; `crypt-encryption-alist' and merged all defuns that work on their +;;; elements into defuns that all start with `crypt-get-' and look through +;;; both lists. simplifies some of code and closer to treating encryption +;;; as a special case of encoding; crypt-minor-mode-alist: replaced (nth *) +;;; with `(crypt-get-minor-mode)' call; (crypt-encode-region): allow +;;; arguments to be list of strings; renamed (crypt-get-encoding-type) to +;;; (crypt-read-encoding-type) for clarity. +;;; 2.49 - [posted to gnu.emacs.sources] +;;; lrd: (crypt-encode-region): ignore `args' if set to t +;;; 2.50 - +;;; lrd: (crypt-write-file-hook): in v19 we need to call `backup-buffer' +;;; ourselves -- we write out the file and return t so `basic-save-buffer' +;;; does not do it; also call `set-file-modes' +;;; 2.51 - +;;; lrd: some `defvar's are now `defconst's and tar-mode note was changed. +;;; 2.52 - +;;; lrd: make doc strings conform to GNU standards. +;;; 2.53 - +;;; lrd: made header conform to GNU Conventional Headers standard. +;;; 2.54 - +;;; lrd: `crypt-encryption-file-extension', `crypt-freeze-vs-fortran', +;;; `crypt-compact-vs-C++', `crypt-encryption-magic-regexp', and +;;; `crypt-encryption-magic-regexp-inverse' are used in defining the tables +;;; `crypt-encoding-alist' and `crypt-encryption-alist' and so need to be set +;;; _before_ loading crypt++. use `add-hook' if it is available. +;;; 2.55 - +;;; lrd: new interactive function `crypt-insert-file' mimics `insert-file' +;;; but attempts to decode or decrypt before insertion; bound `C-x i' if +;;; `crypt-bind-insert-file' is non-nil. comment out doc-strings from +;;; internal subroutines, saves space. +;;; 2.56 - +;;; tfb: change the definitions of crypt-{encoding,encryption}-alist, to +;;; call the functions crypt-make-{encoding,encryption}-alist resp. +;;; Added crypt-reinit which regenerates these variables from their +;;; functions, thus allowing this stuff to be preloaded even if people +;;; set things in their init files. +;;; Tim Bradshaw <tim.bradshaw@mid-heidelberg.de> +;;; 2.57 - +;;; lrd: untabify; remove duplicate entry in `crypt-make-encoding-alist'; +;;; change name of `crypt-make-*-alist' to `crypt-build-*-alist' and +;;; `crypt-reinit' to `crypt-rebuild-tables'; (crypt-read-string-no-echo): +;;; change local variable `form' to `help-form' so it is defined; +;;; `crypt-encryption-alist' and `crypt-encoding-alist' must be defined with +;;; `defconst' since we wish crypt++ to initialize these variables +;;; unconditionally; modify INSTALLATION section to reflect these changes. +;;; 2.58 - +;;; lrd: doc mod. +;;; 2.59 - [posted to gnu.emacs.sources] +;;; lrd: (crypt-bind-insert-file): new function for changing "C-x i" in +;;; initialization file or interactively. +;;; 2.60 - +;;; lrd: add `crypt-rebuild-tables' and `crypt-bind-insert-file' to +;;; `after-init-hook' in GNU emacs v19 and to `term-setup-hook' in Lucid +;;; emacs. Change INSTALLATION notes. +;;; 2.61 - [posted to gnu.emacs.sources] +;;; lrd: Doc mod. Clean up the installation of minor mode indicators. +;;; 2.62 - [posted to gnu.emacs.sources] +;;; lrd: installed patch from stig@hackvan.com to simplify crypt-get-* defuns +;;; (now defmacros). Don't add to `term-setup-hook' unless no +;;; `after-init-hook' _and_ definitely running v19, otherwise Rod gets an +;;; error at home :-<. Don't assume C-x i had `insert-file' bound to it: +;;; store old binding in `crypt-old-binding' before overwriting and use in +;;; function `crypt-bind-insert-file.' +;;; 2.63 - +;;; lrd: (crypt-encode-buffer, crypt-encode-region, crypt-encrypt-buffer, +;;; crypt-encrypt-region): changed argument list putting optional buffer +;;; last and making default action to encode or encrypt. (crypt-encoded-p, +;;; crypt-encrypted-p): new functions that do the actual testing of file +;;; contents. (crypt-find-file): uses these new functions. +;;; (crypt-rebuild-minor-modes-alist): new function to rebuild +;;; `minor-mode-alist' called by function crypt-rebuild-tables. +;;; (crypt-build-minor-mode-alist): new function called by +;;; `crypt-minor-mode-alist' to create itself. `crypt-minor-mode-encrypted' +;;; removed because defined in function crypt-build-minor-mode-alist. +;;; 2.64 - +;;; lrd: (crypt-find-file-hook): temporarily remove the encrytion file +;;; extension to help determine the major mode, just like is done with the +;;; encoding file extension. In order for this to work properly the file +;;; extension in `crypt-encryption-file-extension' and +;;; `crypt-encryption-alist' needs to be inside a pair of \\( \\). +;;; 2.65 - +;;; lrd: (crypt-find-file-hook): move determination of key, password, into +;;; (crypt-encrypted-p). +;;; 2.66 - +;;; lrd: (crypt-set-encryption-key): improve prompt string for encryption +;;; key. +;;; 2.67 - +;;; lrd: (crypt-write-file-hook): make check for encryption file-name +;;; extension case-sensitive. +;;; 2.68 - +;;; lrd: fixed check for previous addition to `minor-mode-alist' -- was not +;;; working. Check for an `add-hook' function; if one does not exist then +;;; use a copy of one from GNU Emacs 19. When using `add-hook' to append to +;;; the `write-file-hooks' make sure that the version accepts the optional +;;; APPEND argument -- v19's does but the one in the elisp archive by Dan +;;; LaLiberte <liberte@cs.uiuc.edu> does not append. This causes problems. +;;; Thanks to Francesco Potorti` <pot@fly.CNUCE.CNR.IT> for pointing this +;;; out. +;;; 2.69 - [posted to gnu.emacs.sources] +;;; lrd: doc mod with regards `after-init-hook' and Lucid Emacs. Add +;;; pointer to crypt++-fnf.el for people who might be interested. +;;; 2.70 - +;;; lrd: narrow conditions under which crypt-encryption-magic-regexp +;;; matches. Thanks to Philippe Michel <michel@thomson-lcr.fr> and Francois +;;; Pinard <pinard@iro.umontreal.ca> for helping explain this with regards +;;; to ISO/Latin-1. +;;; 2.71 - +;;; lrd: applied patches from Darrin Jewell <jewell@bdi.com> for DOS to UNIX +;;; support. DOS entry added to crypt-build-encoding-alist. +;;; (crypt-dos-to-unix-region, crypt-unix-to-dos-region): New +;;; functions. (crypt-dos-has-ctrl-z): New buffer-local variable. +;;; (crypt-encode-region): allow for encoding and decoding programs to be +;;; elisp expressions. If they are then apply them directly to region. +;;; Point out that crypt++.el conflicts with dos-mode.el. +;;; 2.72 - +;;; lrd: The limit for the regular expression search done by +;;; `crypt-encrypted-p' is extended to 100 by default. The enlargement of +;;; search field is needed because of previous reduction in size of regexp +;;; being searched for. (crypt-magic-search-limit): New variable defining +;;; this new limit. (crypt-encrypted-p): Uses it and cleaned up. Doc mod. +;;; Thanks to Philippe Michel <michel@thomson-lcr.fr>, Francois Pinard +;;; <pinard@iro.umontreal.ca>, and Dave Goldberg <dsg@blackbird.mitre.org>. +;;; 2.73 - [posted to gnu.emacs.sources] +;;; lrd: Apply patch from Kevin Rodgers <kevin@traffic.den.mmc.com> that +;;; uses more verbose messages and capitals. Doc mod. +;;; 2.74 - +;;; lrd: Untabify. (crypt-encrypted-p): Check value of +;;; `crypt-never-ever-decrypt' before anything else. +;;; 2.75 - +;;; lrd: (crypt-version): Remove call to `substring'. +;;; 2.76 - +;;; lrd: (crypt-encryption-magic-regexp-inverse): Add in regexp that will +;;; match ksh `.sh_history' files so that they are not interpreted as +;;; encrypted files. Thanks to Francesco Potorti` <pot@fly.CNUCE.CNR.IT>. +;;; 2.77 - [posted to gnu.emacs.sources] +;;; lrd: (crypt-bind-insert-file): Use substitute-key-definition to bind +;;; crypt-insert-file to whatever key insert-file is bound to (not +;;; necessarily C-x i). Call crypt-bind-insert-file directly in +;;; file. Variable crypt-bind-insert-file: Doc mod. Remove +;;; crypt-old-binding. Replace `M-x foobar' in doc strings with +;;; `\\[foobar]'. +;;; 2.78 - +;;; lrd: (crypt-auto-write-answer-local): New internal variable. Holds +;;; answer to query about file-extension tricks question per buffer. Thanks +;;; to George Forman <forman@cs.washington.edu>. Remove Rod from list of +;;; maintainers...he's busy enough. Merge multiple setq forms into single +;;; setq forms. +;;; 2.79 - +;;; lrd: (crypt-y-or-n-p): New internal function for querying. Tests the +;;; internal variable crypt-auto-write-answer-local to ensure single query. +;;; (crypt-check-extension-for-encoding): Replace all occurrences of queries +;;; involving y-or-no-p constructs with crypt-y-or-n-p. +;;; 2.80 - [posted to gnu.emacs.sources] +;;; lrd: (crypt-set-encryption-key): Shorten interactive prompt. Change +;;; documentation. +;;; 2.81 - +;;; lrd: (crypt-variable-list): Add shell and path variables. +;;; (crypt-confirm-password): Fix spelling error in doc. +;;; 2.82 - +;;; lrd: Applied patch from Noah Friedman <friedman@prep.ai.mit.edu>. +;;; (crypt-encoded-disable-auto-save, crypt-encrypted-disable-auto-save): +;;; New user-defined variables. (crypt-encoded-mode, crypt-encrypted-mode): +;;; Use them. +;;; 2.83 - +;;; hniksic: Added custom. + + +;;; Code: + +;;;; User definable variables. + +(progn + (defgroup crypt nil + "Handling compressed and encrypted files." + :group 'compression) + ) + +(defcustom crypt-encryption-type 'crypt + "*Method of encryption. Must be an element of `crypt-encryption-alist.' +If you change this after crypt++ is loaded then do \\[crypt-rebuild-tables]." + :type 'symbol + :group 'crypt) + +(defcustom crypt-encryption-file-extension nil + "*Regexp for extension of files encrypted with `crypt-encryption-type.' +Should be of the form \"\\\\(\\\\.foo\\\\)$\". nil says use default values in +`crypt-encryption-alist.' If you change this after crypt++ is loaded then do +\\[crypt-rebuild-tables]." + :type 'regexp + :group 'crypt) + +(defcustom crypt-never-ever-decrypt nil + "*t says never attempt to decrypt a buffer." + :type 'boolean + :group 'crypt) + +(defcustom crypt-auto-write-buffer-encrypted nil + "*t says files with `crypt-encryption-alist' file extension auto-encrypted. +nil says query. See `crypt-auto-write-buffer.'" + :type 'boolean + :group 'crypt) + +(defcustom crypt-confirm-password nil + "*t says confirm new passwords and when writing a newly encrypted buffer." + :type 'boolean + :group 'crypt) + +(defcustom crypt-encoded-disable-auto-save t + "*If t, turn off auto-save-mode for buffers which are encoded. +If non-nil but not t, then no message is displayed. + +The default is t is because there isn't any way to tell emacs to encode the +autosave file, so the autosave would be in a different format from the +original. The disadvantage of turning off autosaves is that any work you +do in that buffer will be completely lost if the changes are not explicitly +saved. + +It is probably best to set this variable to nil and use buffer-local +variables in files for which you don't actually care about autosaves. +Unencoded recovery data is better than none at all." + :type '(choice (const :tag "on" t) + (const :tag "off" nil) + (const :tag "no message" other)) + :group 'crypt) + +(defcustom crypt-encrypted-disable-auto-save t + "*If t, turn off auto-save-mode for buffers which are encrypted. +If non-nil but not t, then no message is displayed. + +The default is t is because there isn't any way to tell emacs to encrypt +the autosave file, so the autosave would be in cleartext form. The +disadvantage of turning off autosaves is that any work you do in that +buffer will be completely lost if the changes are not explicitly saved. + +You might consider setting this variable to nil and use buffer-local +variables in files for which security is more important than data +recovery." + :type '(choice (const :tag "on" t) + (const :tag "off" nil) + (const :tag "no message" other)) + :group 'crypt) + +;;; ENCRYPTION + +;;; Encrypted files have no magic number, so we have to hack a way of +;;; determining when a buffer should be decrypted. we do this only buffers +;;; that match a MAGIC-REGEXP very close to beginning of buffer and that do +;;; _NOT_ match a MAGIC-REGEXP-INVERSE. +;;; +;;; Currently MAGIC-REGEXP matches non-ASCII characters and +;;; MAGIC-REGEXP-INVERSE will match Sun OS, 4.x BSD, and Ultrix executable +;;; magic numbers, so binaries can still be edited (heh) without headaches. + +(defconst crypt-encryption-magic-regexp "[\000\200-\237]" + "Regexp that must be found very close to beginning of encrypted buffer. +This is intended to be an internal variable \(not user-visible\). If you +change this after crypt++ is loaded then do \\[crypt-rebuild-tables].") + +(defconst crypt-encryption-magic-regexp-inverse + "\\`\201\001\\|^\\(..\\)?\\([\007\010\013]\001\\|\001[\007\010\013]\\)" + "Regexp that must *not* be found very close to beginning of encrypted buffer. +This is intended to be an internal variable \(not user-visible\). If you +change this after crypt++ is loaded then do \\[crypt-rebuild-tables].") + +(defconst crypt-magic-search-limit 100 + "Limit of regular expression search used to recognize encrypted files. +Maximum position in file for presence of `crypt-encryption-magic-regexp' and +absence of `crypt-encryption-magic-regexp-inverse'.") + +(defun crypt-build-encryption-alist () + ;; Returns the encryption alist + (list + ;; crypt + (list 'crypt + crypt-encryption-magic-regexp crypt-encryption-magic-regexp-inverse + (or crypt-encryption-file-extension "\\(\\.e\\)$") + "crypt" "crypt" + nil + nil + "Crypt" + nil + t + ) + ;; DES (Cipher Block Chaining - CBC) [DES' default] + (list 'des + crypt-encryption-magic-regexp crypt-encryption-magic-regexp-inverse + (or crypt-encryption-file-extension "\\(\\.des\\)$") + "des" "des" + '("-e" "-k") + '("-d" "-k") + "DES-CBC" + nil + t + ) + ;; DES (Electronic Code Book - ECB) + (list 'des-ecb + crypt-encryption-magic-regexp crypt-encryption-magic-regexp-inverse + (or crypt-encryption-file-extension "\\(\\.des\\)$") + "des" "des" + '("-e" "-b" "-k") + '("-d" "-b" "-k") + "DES-ECB" + nil + t + ) + ;; PGP + (list 'pgp + crypt-encryption-magic-regexp crypt-encryption-magic-regexp-inverse + (or crypt-encryption-file-extension "\\(\\.pgp\\)$") + "pgp" "pgp" + '("+batchmode" "+verbose=0" "-c" "-f" "-z") + '("+batchmode" "+verbose=0" "-f" "-z") + "PGP" + nil + t + ) + ;; Add new elements here ... + )) + +(defconst crypt-encryption-alist (crypt-build-encryption-alist) + "List of elements describing the encryption methods available. +each element looks like + + \(ENCRYPTION-TYPE + MAGIC-REGEXP MAGIC-REGEXP-INVERSE + FILE-EXTENSION + ENCRYPT-PROGRAM DECRYPT-PROGRAM + ENCRYPT-ARGS + DECRYPT-ARGS + MINOR-MODE + GARBAGE-REGEXP-OR-LISPEXP + FILE-EXTENSION-TRICKS + \) + +ENCRYPTION-TYPE is a symbol denoting the encryption type. + +MAGIC-REGEXP regexp that must match very close to the beginning of an +encrypted buffer. This may also be some elisp expression to be evaluated at +\(point-min\) that will return t for an encrypted buffer. If this is set to +nil then crypt++ will never try to decrypt a buffer. Currently set to the +internal variable `crypt-encryption-magic-regexp' which will match non-ASCII +characters. + +MAGIC-REGEXP-INVERSE regexp that must _NOT_ match very close to the beginning +of an encrypted buffer. This may also be some elisp expression to be +evaluated at \(point-min\) that will return t for a NON-encrypted buffer. +If this is set to t then crypt++ will never try to decrypt a buffer. +Currently set to the internal variable `crypt-encryption-magic-regexp-inverse' +which will match Sun OS, 4.x BSD, and Ultrix executable magic numbers, so +binaries can still be edited (heh) without headaches. + +FILE-EXTENSION regexp denoting the file extension usually appended the +filename of files encrypted with ENCRYPT-PROGRAM. The variable +`crypt-encryption-file-extension' will over ride the default. + +ENCRYPT-PROGRAM name of executable file to be used for encryption. + +DECRYPT-PROGRAM name of executable file to be used for decryption. + +ENCRYPT-ARGS arguments to be passed to ENCRYPT-PROGRAM may be a string or a +list of strings or nil. + +DECRYPT-ARGS arguments to be passed to DECRYPT-PROGRAM may be a string or a +list of strings or nil. + +MINOR-MODE string denoting the name for the encrypted minor mode as it will +appear in the mode line. + +GARBAGE-REGEXP-OR-LISPEXP dummy variable for compatibility with encoding. + +FILE-EXTENSION-TRICKS is t or nil depending on whether or not tricks +converting between different encryption types can be done based on +FILE-EXTENSION; typically t. +") + + +;;; ENCODING + +(defcustom crypt-auto-decode-buffer t + "*t says buffers visiting encoded files will be decoded automatically. +nil means to ask before doing the decoding." + :type 'boolean + :group 'crypt) + +(defcustom crypt-auto-write-buffer nil + "*t says save files with `crypt-encoding-alist' file extensions as encoded. +nil says to ask before doing this encoding. Similarly, buffers originating +from encoded files to be written to files not ending in `crypt-encoding-alist' +file extensions will be written in plain format automatically. nil says to +ask before doing this decoding." + :type 'boolean + :group 'crypt) + +;; This is an internal variable documented here and not in a DOCSTRING in +;; order to save memory. If this variable's value has been changed from its +;; default, then it contains the answer to the question "Write out buffer +;; foobar using `compression-type'?". This question is asked only if *plain* +;; buffer foobar is being written to disk *and* it has a provocative +;; `compression-type' file-name extension (see DOCSTRING for variable +;; crypt-auto-write-buffer). The variable is local to all buffers with a +;; default value of 'ask so if the situation described above arises, then the +;; question is asked at least once, unless the user-defined variable +;; crypt-auto-write-buffer is non-nil. +(defvar crypt-auto-write-answer-local 'ask) +(make-variable-buffer-local 'crypt-auto-write-answer-local) +(setq-default crypt-auto-write-answer-local 'ask) +(put 'crypt-auto-write-answer-local 'permanent-local t) ; for v19 Emacs +(put 'crypt-auto-write-answer-local 'preserved t) ; for kill-fix.el + +(defcustom crypt-query-if-interactive t + "*t says ask when saving buffers where `crypt-encoded-mode' was toggled. +nil says that even if filename extension is plain (i.e., not listed in +`crypt-encoding-alist') buffer will be written in an encoded format without +asking. + +This variable is designed for users that edit a plain file (with plain +extension) and then toggle `(crypt-encoded-mode)' and do not wish to be +queried every time that they save the buffer. + +NOTE: if `(crypt-encoded-mode)' was not called interactively (the usual +scenario) then the value of this variable has no effect on how the buffer is +written to disk. In such a case `crypt-no-extension-implies-plain' is then +the relevant variable." + :type 'boolean + :group 'crypt) + +(defcustom crypt-no-extension-implies-plain t + "*t says file extensions not in `crypt-encoding-alist' may be written plain. +if `crypt-auto-write-buffer' is also t then any file ending in a plain +extension is written in plain format automatically, otherwise query user. + +nil says user works with encoded (compressed) files without file extensions +and will not be queried each time they save these files. + +NOTE: (1) this does not effect find-file (C-x C-f) since that works with a +magic regexp. (2) there is no way to distinguish between write-file and +save-buffer so nil will mean that neither will query." + :type 'boolean + :group 'crypt) + +(defcustom crypt-freeze-vs-fortran t + "*t says `.F' file extension denotes a frozen file not a Fortran file. +If you change this variable after crypt++ has been loaded then do +\\[crypt-rebuild-tables]." + :type 'boolean + :group 'crypt) + +(defcustom crypt-compact-vs-C++ nil + "*t says `.C' file extension denotes a compacted file not a C++ file. +If you change this variable after crypt++ has been loaded then do +\\[crypt-rebuild-tables]." + :type 'boolean + :group 'crypt) + +(defcustom crypt-ignored-filenames nil + "*List of regexp filenames for which encoded to plain conversion is not done. +A filename with a plain extension, in encoded format, that is matched by one of +these elements will be saved in encoded format without a query for conversion to +plain format. + +This variable is provided for users that want to compress their incoming mail +for RMAIL and VM which look for files `RMAIL' and `INBOX,' respectively, to +store incoming mail. For example, the gzip extensions on `RMAIL.gz' and +`INBOX.gz' can be removed, this variable set to '\(\"INBOX$\" \"RMAIL$\"\) and +no query about conversion to plain format will be made." + :type '(repeat regexp) + :group 'crypt) + +(defcustom crypt-default-encoding "gzip" + "*Default encoding type as string used when `crypt-encoded-mode' is toggled. +Must match one of the elements of `crypt-encoding-alist'." + :type 'string + :group 'crypt) + +(defcustom crypt-dos-has-ctrl-z nil + "t if this buffer had a ctrl-z stripped from end, otherwise, nil. +Buffer local and set by `crypt-dos-to-unix-region'" + :type 'boolean + :group 'crypt) +(make-variable-buffer-local 'crypt-dos-has-ctrl-z) +(setq-default crypt-dos-has-ctrl-z nil) +(put 'crypt-dos-has-ctrl-z 'permanent-local t) ; for v19 Emacs +(put 'crypt-dos-has-ctrl-z 'preserved t) ; for kill-fix.el + +(defun crypt-build-encoding-alist () + ;; Returns the encoding alist + (list + ;; compress + (list 'compress + "\037\235" nil + "\\(\\.Z\\)$" + "compress" "uncompress" + nil nil + "Compress" + nil + t) + ;; gzip (GNU zip) + (list 'gzip + "\037\213" nil + "\\(\\.g?z\\)$" + "gzip" "gzip" + "--quiet" "--decompress --quiet" + "Zip" + nil + t) + ;; freeze + (list 'freeze + "\037\236\\|\037\237" nil + "\\(\\.F\\)$" + "freeze" "freeze" + "" "-d" + "Freeze" + nil + crypt-freeze-vs-fortran) + ;; compact + (list 'compact + "\377\037" nil + "\\(\\.C\\)$" + "compact" "uncompact" + nil nil + "Compact" + "^Compression *:.*\n" + crypt-compact-vs-C++) + ;; DOS + (list 'dos + "[^\n\r]*\r$" nil + "\\(\\.DOS\\)$" + 'crypt-unix-to-dos-region 'crypt-dos-to-unix-region + nil nil + "Dos" + nil + nil) + ;; Add new elements here ... + )) + +(defconst crypt-encoding-alist (crypt-build-encoding-alist) + "List of elements describing the encoding methods available. +each element looks like + + \(ENCODING-TYPE + MAGIC-REGEXP MAGIC-REGEXP-INVERSE + FILE-EXTENSION + ENCODE-PROGRAM DECODE-PROGRAM + ENCODE-ARGS DECODE-ARGS + MINOR-MODE + GARBAGE-REGEXP-OR-LISPEXP + FILE-EXTENSION-TRICKS + \) + +ENCODING-TYPE is a symbol denoting the encoding type. Currently known +encodings are (compress compact freeze gzip). + +MAGIC-REGEXP is a regexp that matches the magic number at the +beginning of files encoded with ENCODING-TYPE. + +MAGIC-REGEXP-INVERSE dummy variable for compatibility with encryption. + +FILE-EXTENSION is a string denoting the file extension usually +appended the filename of files encoded with ENCODING-TYPE. + +ENCODE-PROGRAM is a string denoting the name of the executable used to +encode files. + +DECODE-PROGRAM is a string denoting the name of the executable used to +decode files. + +ENCODE-ARGS arguments to be passed to ENCODE-PROGRAM may be a string or a +list of strings or nil. + +DECODE-ARGS arguments to be passed to DECODE-PROGRAM may be a string or a +list of strings or nil. + +MINOR-MODE is a string denoting the name for the encoded minor mode as +it will appear in the mode line. + +GARBAGE-REGEXP-OR-LISPEXP is (1) a regexp that matches any extraneous text +that is produced by the ENCODE-COMMAND including any newlines and will be +removed from the buffer before saving to disk; (2) a lisp expression that will +clean up extraneous material in the buffer or nil. This is normally not +needed but can be derived for any ENCODE-COMMAND by checking the standard +error that results from `sh -c \"cat foo | ENCODE-COMMAND > bar\"'. + +FILE-EXTENSION-TRICKS is t or nil depending on whether or not tricks +converting between different encoding types can be done based on +FILE-EXTENSION; typically t. +") + +(defvar crypt-inhibit-formats (when (featurep 'mule) '(dos)) + "*A list of crypt abilities to turn off. In particular, setting this +variable to be '(dos) will stop the dos-mode CRLF <-> LF damage.") + + +;;; This allows the user to alter contents of the encoding and encryption +;;; table variables without having to reload all of crypt++. +(defun crypt-rebuild-tables () + "Rebuilds the encryption and encoding tables and `minor-mode-alist'. +Allows user to alter variables used in building these tables. May be called +interactively or in an initialization file. Part of `after-init-hook'." + (interactive) + (setq crypt-encryption-alist (crypt-build-encryption-alist) + crypt-encoding-alist (crypt-build-encoding-alist)) + (crypt-rebuild-minor-modes-alist)) + + +;;; Buffer locals. + +(defvar crypt-buffer-save-encrypted nil + "*non-nil says save buffer encrypted with `crypt-encryption-type.' +local to all buffers.") +(make-variable-buffer-local 'crypt-buffer-save-encrypted) +(put 'crypt-buffer-save-encrypted 'permanent-local t) ; for v19 Emacs +(put 'crypt-buffer-save-encrypted 'preserved t) ; for kill-fix.el + +(defvar crypt-buffer-encryption-key nil + "*Key used for encryption of current buffer. Local to all buffers.") +(make-variable-buffer-local 'crypt-buffer-encryption-key) +(put 'crypt-buffer-encryption-key 'permanent-local t) ; for v19 Emacs +(put 'crypt-buffer-encryption-key 'preserved t) ; for kill-fix.el + +(defvar crypt-buffer-save-encoded nil + "*non-nil says buffer will be saved encoded. Local to all buffers.") +(make-variable-buffer-local 'crypt-buffer-save-encoded) +(put 'crypt-buffer-save-encoded 'permanent-local t) ; for v19 Emacs +(put 'crypt-buffer-save-encoded 'preserved t) ; for kill-fix.el + +(defvar crypt-buffer-encoding-type nil + "*non-nil says buffer is encoded with ENCODING-TYPE. Local to all buffers.") +(make-variable-buffer-local 'crypt-buffer-encoding-type) +(put 'crypt-buffer-encoding-type 'permanent-local t) ; for v19 Emacs +(put 'crypt-buffer-encoding-type 'preserved t) ; for kill-fix.el + +(defvar crypt-buffer-interactive-encoded-mode nil + "t says `crypt-encoded-mode' was toggled interactively, almost always nil. +Local to all buffers.") +(make-variable-buffer-local 'crypt-buffer-interactive-encoded-mode) +(put 'crypt-buffer-interactive-encoded-mode 'permanent-local t) ; v19 Emacs +(put 'crypt-buffer-interactive-encoded-mode 'preserved t) ; kill-fix.el + + +;;; Functions and macros that search `crypt-encryption-alist' and +;;; `crypt-encoding-alist'. + +(defun crypt-get-alist-member (type n) + ;; Returns TYPE's Nth element + (nth n (or (assoc type crypt-encryption-alist) + (assoc type crypt-encoding-alist)))) + +(defmacro crypt-get-magic-regexp (type) + ;; Returns regexp found at top of files encoded/encrypted with TYPE. + (list 'crypt-get-alist-member type 1)) + +(defmacro crypt-get-magic-regexp-inverse (type) + ;; Returns regexp *not* found at top of files encoded/encrypted with TYPE. + (list 'crypt-get-alist-member type 2)) + +(defmacro crypt-get-file-extension (type) + ;; Returns regexp matching extension of files encoded/encrypted with TYPE. + (list 'crypt-get-alist-member type 3)) + +(defmacro crypt-get-encoding-program (type) + ;; Returns name of program, as string, used to encode/encrypt with TYPE. + (list 'crypt-get-alist-member type 4)) + +(defmacro crypt-get-decoding-program (type) + ;; Returns name of program, as string, used to decode/decrypt with TYPE. + (list 'crypt-get-alist-member type 5)) + +(defmacro crypt-get-encoding-args (type) + ;; Returns arguments passed to program used to encode/encrypt with TYPE. + (list 'crypt-get-alist-member type 6)) + +(defmacro crypt-get-decoding-args (type) + ;; Returns arguments passed to program used to decode/decrypt with TYPE. + (list 'crypt-get-alist-member type 7)) + +(defmacro crypt-get-minor-mode-name (type) + ;; Returns minor mode name, as string, for encoding/encrypting with TYPE. + (list 'crypt-get-alist-member type 8)) + +(defmacro crypt-get-cleanup-regexp (type) + ;; Returns regexp or lisp-exp for cleaning up encoding/encrypting with TYPE. + (list 'crypt-get-alist-member type 9)) + +(defmacro crypt-get-extension-tricks (type) + ;; Returns t if file extension tricks doable for encoding/encrypting with + ;; TYPE. + (list 'crypt-get-alist-member type 10)) + +(defun crypt-buffer-save-name (type) + ;; Returns variable `crypt-buffer-save-TYPE', set to t if encoding with TYPE. + ;; local to all buffers. + (intern (concat "crypt-buffer-save-" (symbol-name type)))) + + +;;; Create a buffer-local variable for each type of encoding. +;;; These variables are used to trigger the minor mode names. + +(defun crypt-build-minor-mode-alist () + ;; Returns minor mode alist entries for encoded and encrypted buffers. + (append + ;; First the encrypted minor mode -- only one. + (list (list 'crypt-buffer-save-encrypted + (concat " " (crypt-get-minor-mode-name crypt-encryption-type)))) + ;; Now the encoding minor modes. + (mapcar + (function + (lambda (element) + (let ((variable (crypt-buffer-save-name (car element)))) + (make-variable-buffer-local variable) + (put variable 'permanent-local t) ; for v19 Emacs + (put variable 'preserved t) ; for kill-fix.el + (list variable + (concat " " (crypt-get-minor-mode-name (car element))))))) + crypt-encoding-alist))) + +(defconst crypt-minor-mode-alist (crypt-build-minor-mode-alist) + "Alist containing encoded and encrypted minor modes. +Derived from variable `crypt-encoding-alist' and function +`crypt-build-minor-mode-encrypted'") + +(defun crypt-rebuild-minor-modes-alist () + ;; Rebuilds the encryption and encoding minor modes and `minor-mode-alist.' + ;; Allows user to alter variables used in building this alist. Called by + ;; `crypt-rebuild-tables' and so part of `after-init-hook'." + + ;; First remove old crypt minor mode entries from `minor-mode-alist'. + (if (memq (car crypt-minor-mode-alist) minor-mode-alist) + (let ((alist crypt-minor-mode-alist) elt) + (while (and alist (setq elt (car alist))) + (setq minor-mode-alist (delq elt minor-mode-alist) + alist (cdr alist))))) + + ;; Get new crypt minor mode entries and add to minor-mode-alist. + (setq crypt-minor-mode-alist (crypt-build-minor-mode-alist) + minor-mode-alist (append crypt-minor-mode-alist minor-mode-alist))) + + +(defmacro crypt-save-point (&rest body) + ;; Save value of point, evaluate FORMS, and restore value of point. If the + ;; saved value of point is no longer valid go to (point-max). This macro + ;; exists because, save-excursion loses track of point during some types of + ;; deletions. + (let ((var (make-symbol "saved-point"))) + (list 'let (list (list var '(point))) + (list 'unwind-protect + (cons 'progn body) + (list 'goto-char var))))) + + +(defun crypt-find-file-hook () + + ;; Hook run for decoding and/or decrypting the contents of a buffer. Meant + ;; to be called as part of `find-file-hooks' + + (let ((buffer-file-name buffer-file-name) + (old-buffer-file-name buffer-file-name) + (old-buffer-modified-p (buffer-modified-p)) + (case-fold-search nil) ; case-sensitive + encrypted encoded buffer-read-only) + + ;; DECODE AND/OR DECRYPT + (crypt-save-point + + ;; Do we have to DECODE? If not, then move on. + (if (and (crypt-encoded-p) + (or crypt-auto-decode-buffer + (y-or-n-p (format "Decode %s? " (buffer-name))))) + + ;; Decode, uncompress, the buffer. + (progn + + (if (and (not (null buffer-file-name)) + (string-match "\\.Z$" buffer-file-name)) + (set-visited-file-name + (substring buffer-file-name 0 (match-beginning 0))) + (if (and (not (null buffer-file-name)) + (string-match "\\.gz$" buffer-file-name)) + (set-visited-file-name + (substring buffer-file-name 0 (match-beginning 0))))) + (message "Decoding %s..." (buffer-name)) + (crypt-encode-buffer t) + + ;; Store the encoding mode. + + ;; We can not yet go into the minor modes because the major mode + ;; may change later on and blow away all local variables (and thus + ;; the minor modes). Only needed for vanilla v18. Our + ;; buffer-locals defined 'permanent-local for v19 Emacs and + ;; 'preserved for kill-fix.el. + + (setq encoded crypt-buffer-encoding-type) + + ;; Strip encoded file's extension so later we can set buffer's + ;; major mode based on its file-name sans encoding extension. + (if (string-match (crypt-get-file-extension + crypt-buffer-encoding-type) buffer-file-name) + (setq buffer-file-name + (substring buffer-file-name 0 (match-beginning 1)))) + + ;; Decoding ends. + (if (not (input-pending-p)) + (message "Decoding %s... done" (buffer-name))))) + + ;; Do we have to DECRYPT? If not, then move on. + (if (crypt-encrypted-p) + + ;; Decrypt buffer. + (progn + + (message "Decrypting %s..." (buffer-name)) + (crypt-encrypt-buffer crypt-buffer-encryption-key t) + + ;; Save key in case major mode blows all buffer-locals. + + ;; Only needed for vanilla v18. Our buffer-locals defined + ;; 'permanent-local for v19 Emacs and 'preserved for + ;; kill-fix.el. + + (setq encrypted crypt-buffer-encryption-key) + + ;; Strip encrypted file's extension so later we can set buffer's + ;; major mode based on its file-name sans encrypting extension. + (if (and (crypt-get-extension-tricks crypt-encryption-type) + (string-match (crypt-get-file-extension + crypt-encryption-type) buffer-file-name)) + (setq buffer-file-name + (substring buffer-file-name 0 (match-beginning 1)))) + + (if (not (input-pending-p)) + (message "Decrypting %s... done" (buffer-name)))))) + + ;; MAJOR AND MINOR MODES + + ;; OK, if any changes have been made to the buffer we need to rerun the + ;; code the does automatic selection of major mode. + + (if (or encoded encrypted) + + (progn + + ;; Set the major mode. + (set-auto-mode) + (hack-local-variables) + + ;; Now set our own minor mode(s). + (if encoded + ;; Recover encoding type, may have been smashed by major mode, + ;; and toggle encoded mode. + (progn (setq crypt-buffer-encoding-type encoded) + (crypt-encoded-mode 1))) + + (if encrypted + ;; Recover encryption key, may have been smashed by major mode, + ;; and toggle encrypted mode. + (progn (setq crypt-buffer-encryption-key encrypted) + (crypt-encrypted-mode 1))) + + ;; Restore buffer file name now, so that lock file entry is removed + ;; properly. + (setq buffer-file-name old-buffer-file-name) + + ;; Restore buffer modified flag to its previous value. Will also + ;; remove lock file entry for buffer if previous value was nil. + ;; This is why buffer-file-name had to be restored manually above. + (set-buffer-modified-p old-buffer-modified-p))))) + +(defun crypt-encoded-p (&optional buffer) + ;; Returns t if current buffer, or optionally BUFFER, is encoded. + ;; Sets `crypt-buffer-encoding-type' to encoding method. + (save-excursion + (and buffer (set-buffer buffer)) + (save-restriction + (widen) + (goto-char (point-min)) + (let ((alist crypt-encoding-alist) elt found) + (while (and alist (setq elt (car alist)) (not found)) + (if (and (looking-at (nth 1 elt)) + (not (memq (nth 0 elt) crypt-inhibit-formats))) + (setq crypt-buffer-encoding-type (nth 0 elt) + found t) + ;; Decrement + (setq alist (cdr alist)))) + found)))) + +(defun crypt-encrypted-p (&optional buffer) + ;; Returns t if current buffer, or optionally BUFFER, is encrypted. + ;; Look for MAGIC-REGEXP and absence of MAGIC-REGEXP-INVERSE. If so, then + ;; assume it is an encrypted buffer. + ;; Sets `crypt-buffer-encryption-key' to password if not set already. + + ;; Do not try to decrypt buffer if not wanted. + (if (not crypt-never-ever-decrypt) + + (save-excursion + (and buffer (set-buffer buffer)) + + (save-restriction + (widen) + (goto-char (point-min)) + + (let ((magic-regexp (crypt-get-magic-regexp crypt-encryption-type)) + (magic-regexp-inverse (crypt-get-magic-regexp-inverse + crypt-encryption-type)) + (limit (min (point-max) crypt-magic-search-limit))) + + ;; Check all encryption conditions. If any fail, then return nil + ;; value of this if-form, else check for password. + (if (and + + ;; Check for existence of MAGIC-REGEXP. + (if (stringp magic-regexp) + ;; regular expression + (re-search-forward magic-regexp limit t) + ;; lisp expression + (eval magic-regexp)) + + (goto-char (point-min)) + + ;; Check for absence of MAGIC-REGEXP-INVERSE. + (not (if (stringp magic-regexp-inverse) + ;; regular expression + (re-search-forward magic-regexp-inverse limit t) + ;; lisp expression + (eval magic-regexp-inverse)))) + + (progn + + ;; Get key, i.e., the password? + (or crypt-buffer-encryption-key + ;; Do not confirm on reading an encrypted file. + (let ((crypt-confirm-password nil)) + (call-interactively 'crypt-set-encryption-key))) + + ;; Do not turn on encryption mode if no key: may be a binary + ;; file. Thanks to Paul Dworkin (paul@media-lab.media.mit.edu). + (if (equal crypt-buffer-encryption-key "") + ;; Return nil. + (progn + (message "No key given. Assumed normal.") + nil) + ;; Return t. + t)))))))) + + +;;; + +(defun crypt-check-extension-for-encoding () + + ;; Checks file extensions for possible toggling of encoding modes. Used for + ;; buffers to be written to disk and called by `crypt-write-file-hook' + + ;; We try to flag a buffer to be written out in encoded form if the file + ;; ends in one of the file-extensions in `crypt-encoding-alist' even if + ;; `crypt-buffer-save-encoded' is nil. Conversely, we try to write out a + ;; buffer as a plain file if it does _not_ end in one of these + ;; file-extensions even if `crypt-buffer-save-encoded' is non-nil. + + (let ((alist crypt-encoding-alist) + (case-fold-search nil) + found elt) + + ;; Search through the file name extensions for a match. + (while (and alist (setq elt (car alist)) (not found)) + (if (string-match (nth 3 elt) buffer-file-name) + (setq found t) + ;; Decrement. + (setq alist (cdr alist)))) + + ;; Did we find a match? + (if found + + ;; File name ends in a very provocative extension. + + ;; Check to see if already an encoded file. + (if crypt-buffer-save-encoded + + ;; Already encoded - do the methods of encoding match? + (if (not (eq (nth 0 elt) crypt-buffer-encoding-type)) + + ;; A new encoding method is desired. + + ;; Can we play some filename extension tricks with the + ;; destination extension? + (if (crypt-get-extension-tricks (nth 0 elt)) + + ;; Can play tricks. + ;; Change the method of encoding? + (if (crypt-y-or-n-p (format "Write %s using %s? " + (buffer-name) (nth 4 elt))) + + ;; Case one. + ;; Turn off original encoding and turn on new encoding. + (progn (crypt-encoded-mode -1) + (setq crypt-buffer-encoding-type (nth 0 elt)) + (crypt-encoded-mode 1))) + + ;; Can not play tricks - maybe wants a plain file? + (if (crypt-y-or-n-p (format "Write %s a plain file? " + (buffer-name))) + + ;; Case three. + ;; Turn off the minor mode and _then_ the flags. + (progn + (crypt-encoded-mode -1) + (setq crypt-buffer-save-encoded nil + crypt-buffer-encoding-type nil))))) + + ;; Was a plain file. + (if (and + ;; Can we play some filename extension tricks? + ;; If not then we must abort. + (crypt-get-extension-tricks (nth 0 elt)) + + (crypt-y-or-n-p (format "Write %s using %s? " + (buffer-name) (nth 4 elt)))) + + ;; Case two. + ;; Turn on encoding flags and _then_ the minor mode. + (progn + (setq crypt-buffer-save-encoded t + crypt-buffer-encoding-type (nth 0 elt)) + (crypt-encoded-mode 1)))) + + ;; No match - a plain-jane file extension - but if the encoded flag is + ;; non-nil then the user may really want it written out in plain + ;; format so we must override this flag. + (if (and crypt-buffer-save-encoded + + ;; Search the list of files to be ignored. + ;; If `crypt-ignored-filenames' is nil then this let form + ;; will return t. If a match is found this form will return + ;; nil. Otherwise it will return t. + (let ((tlist crypt-ignored-filenames) + case-fold-search found elt) + + ;; Search through the list of filenames for a match. + (while (and tlist (setq elt (car tlist)) (not found)) + (if (string-match elt buffer-file-name) + (setq found t) + ;; Decrement. + (setq tlist (cdr tlist)))) + + ;; Return t if we can _not_ find a match. + (not found)) + + ;; If `(crypt-encoded-mode)' was called interactively, then + ;; there is a high probability that no matter what the file + ;; name extension the user wishes to write the file out in some + ;; encoded format. Thanks to Kimball Collins + ;; <kpc@ptolemy.arc.nasa.gov> for pointing out the need for + ;; this. Unfortunately, still can not distinguish between + ;; write-file and save-buffer. In the former the user may want + ;; to write in plain format (or indeed some other format). + + (if crypt-buffer-interactive-encoded-mode + ;; Interactive + crypt-query-if-interactive + ;; Non-interactive but still may want encoded format. + crypt-no-extension-implies-plain) + + (crypt-y-or-n-p (format "Write %s as a plain file? " + (buffer-name)))) + + ;; Case three. + ;; Turn off the minor mode and _then_ the flags. + (progn + (crypt-encoded-mode -1) + (setq crypt-buffer-save-encoded nil + crypt-buffer-encoding-type nil)))))) + + +(defun crypt-y-or-n-p (prompt) + ;; Queries user based on `crypt-auto-write-buffer' and internal buffer-local + ;; variable `crypt-auto-write-answer-local'. Returns value of + ;; `crypt-auto-write-answer-local', which is t or nil. + + ;; Check if we need to ask user. Should be 'ask, nil, or t. + (if (eq crypt-auto-write-answer-local 'ask) ; Default value. + ;; We may need to ask. + (or crypt-auto-write-buffer + ;; Ask and store the answer. + ;; Note: we only store if we asked. + (setq crypt-auto-write-answer-local (y-or-n-p prompt))) + ;; Use previous answer. + crypt-auto-write-answer-local)) ; Will be nil or t. + + +;;; This function should be called ONLY as a write-file hook. +;;; Odd things will happen if it is called elsewhere. + +(defun crypt-write-file-hook () + + ;; Hook for possibly writing out file, and backup file, in a non-plain + ;; format. Terminates calls in `write-file-hooks' and should be at end of + ;; list. + + ;; Check file-extension for possible toggling of encoding modes. + (crypt-check-extension-for-encoding) + + ;; Check extension for encryption. + (if (and + + ;; Maybe file ends with provocative extension w.r.t. encryption? + (stringp (crypt-get-file-extension crypt-encryption-type)) + (let ((case-fold-search nil)) ; Make case-sensitive. + (string-match (crypt-get-file-extension crypt-encryption-type) + buffer-file-name)) + + ;; Can we play tricks? + (crypt-get-extension-tricks crypt-encryption-type) + + ;; Match of filename extension - is file in plain format? + (not crypt-buffer-save-encrypted) + + ;; Query? + (or crypt-auto-write-buffer-encrypted + (y-or-n-p + (format "Write %s as an encrypted file? " (buffer-name))))) + + (progn + ;; Set password and toggle `crypt-encrypted-mode' + (call-interactively 'crypt-set-encryption-key) + (crypt-encrypted-mode 1))) + + ;; Now decide whether or not we need to continue with this defun. Does the + ;; buffer need to be saved in a non-plain form? If not then writing is not + ;; done here but later in the write-file-hooks - probably at the end. + + (if (or crypt-buffer-save-encoded crypt-buffer-save-encrypted) + + (save-excursion + (save-restriction + + (let + + ;; BINDINGS + ((copy-buffer (get-buffer-create " *crypt copy buffer*")) + (selective-display selective-display) + (buffer-read-only)) + + ;; FORMS + (copy-to-buffer copy-buffer 1 (1+ (buffer-size))) + (narrow-to-region (point) (point)) + + (unwind-protect + + ;; BODYFORM + (let (setmodes) + + ;; As of v19, if one of functions of the `write-file-hooks' + ;; returns a non-nil value, then `basic-save-buffer' no + ;; longer creates a backup file. We must do it ourselves. + ;; this should be a no-op in v18. + (or buffer-backed-up + (setq setmodes (backup-buffer))) + + (insert-buffer-substring copy-buffer) + (kill-buffer copy-buffer) + + ;; "Who would cross the Bridge of Death + ;; Must answer me + ;; These questions three + ;; Ere the other side he see." + ;; + ;; Bridgekeeper from Monty Python and the Holy Grail + + ;; [1] selective-display non-nil means we must convert + ;; carriage returns to newlines now, and set the variable + ;; selective-display temporarily to nil. + (if selective-display + (progn + (goto-char (point-min)) + (subst-char-in-region (point-min) (point-max) ?\r ?\n) + (setq selective-display nil))) + + ;; [2] encryption + (if crypt-buffer-save-encrypted + (progn + ;; check for password + (if (not crypt-buffer-encryption-key) + (call-interactively 'crypt-set-encryption-key)) + (if (null crypt-buffer-encryption-key) + (error "No encryption key set for buffer %s" + (buffer-name))) + (if (not (stringp crypt-buffer-encryption-key)) + (error "Encryption key is not a string")) + (message "Encrypting %s..." (buffer-name)) + (crypt-encrypt-buffer crypt-buffer-encryption-key))) + + ;; [3] encoding + (if crypt-buffer-save-encoded + (progn + (message "Encoding %s..." (buffer-name)) + (crypt-encode-buffer))) + + ;; Now write buffer/region to disk. + (write-region (point-min) (point-max) buffer-file-name nil t) + (delete-region (point-min) (point-max)) + (set-buffer-modified-p nil) + + ;; Now that the file is written, set its modes. + (if setmodes + (condition-case () + (set-file-modes buffer-file-name setmodes) + (error nil))) + + ;; Return t so that `basic-save-buffer' will know that the + ;; save has already been done. + + ;; NOTE: this TERMINATES write-file-hooks so any hooks + ;; following this one will not be executed. + + t ) + + ;; UNWINDFORMS + ;; unwind...sit back...take a load off...have a beer + + ;; If the encoded and encrypted stuff has already been removed + ;; then this is a no-op. This form is executed if BODYFORM + ;; completes normally but the value of BODYFORM is returned - + ;; i.e., t is returned. + + (delete-region (point-min) (point-max)))))))) + + +;;;; ENCRYPTION + +(defun crypt-encrypt-region (start end key &optional decrypt) + "Encrypt region START to END using KEY and `crypt-encryption-type'. When +called interactively START and END default to point and mark \(START being the +lesser of the two\), and KEY is prompted for. With optional DECRYPT non-nil, +decryption is done." + + (interactive + (let (decrypt) + (barf-if-buffer-read-only) + (list (region-beginning) + (region-end) + (crypt-read-string-no-echo + (concat (if (setq decrypt (y-or-n-p "Decrypt region? ")) "De" "En") + "crypt buffer using key: ") + ;; Do not confirm on decrypting region. + (if (not decrypt) crypt-confirm-password)) + decrypt))) + + (crypt-save-point + + ;; We define the PROGRAM as the encryption program or decryption program + ;; listed for `crypt-encryption-type' of `crypt-encryption-alist.' These + ;; should be just the name of the executable and should _not_ contain any + ;; arguments. `(call-process-region)' would be confused if we tried to + ;; pass the arguments as part of the PROGRAM. The arguments are passed + ;; through the encryption args or decryption args listed for + ;; `crypt-encryption-type' of `crypt-encryption-alist.' + + ;; Thanks to Joe Ilacqua <spike@world.std.com> and others for pointing out + ;; an error that occurs with some encryption programs (e.g., the crypt from + ;; Sun Microsystems, HPUX-8, and BSD) if `args' is `"".' This will allow + ;; nil values and lists of strings for argument. + + (let (prog args) + + ;; Get the proper program and arguments. + (if decrypt + (setq prog (crypt-get-decoding-program crypt-encryption-type) + args (crypt-get-decoding-args crypt-encryption-type)) + (setq prog (crypt-get-encoding-program crypt-encryption-type) + args (crypt-get-encoding-args crypt-encryption-type))) + + ;; Check arguments. + (cond + + ;; nil or "" args - don't pass. + ((or (not args) (equal "" args)) + (call-process-region start end prog t t nil key)) + + ;; Check if the args are in the form of a list - must use apply. + ((listp args) + (apply 'call-process-region + (append (list start end prog t t nil) args (list key)))) + + ;; Default - just a non-null string. + (t + (call-process-region start end prog t t nil args key)))))) + + +(defun crypt-encrypt-buffer (key &optional decrypt buffer) + + ;; Use KEY to encrypt current buffer and with optional DECRYPT decrypt. + ;; With optional BUFFER, encrypt or decrypt that buffer. Not meant to be + ;; called interactively, toggle `crypt-encrypted-mode' to encrypt an entire + ;; buffer. + + (or buffer (setq buffer (current-buffer))) + (save-excursion (set-buffer buffer) + (crypt-encrypt-region (point-min) (point-max) key decrypt))) + + +;;;; ENCODING + +(defun crypt-encode-region (start end &optional decode) + + "Encode region START to END. When called interactively START and END +default to point and mark \(START being the lesser of the two\). With +optional DECODE non-nil, decoding is done. + +If encoding is attempted, then checks for correct magic number at start of +newly-encoded region. If not found, then searches and deletes a user-defined +regexp, or executes a user-defined lisp expression, as defined in +`crypt-encoding-alist,' and checks again for magic number." + + (interactive "*r\nP") + + ;; If called interactively then we may need to determine the encoding type. + (if (and (interactive-p) (not crypt-buffer-encoding-type)) + (crypt-read-encoding-type)) + + (crypt-save-point + + ;; We define the PROGRAM as `shell-file-name' and have it call the encoding + ;; or decoding program with the arguments. + + (let (prog args) + + ;; Get the proper program and arguments. + (if decode + (setq prog (crypt-get-decoding-program crypt-buffer-encoding-type) + args (crypt-get-decoding-args crypt-buffer-encoding-type)) + (setq prog (crypt-get-encoding-program crypt-buffer-encoding-type) + args (crypt-get-encoding-args crypt-buffer-encoding-type))) + + (cond + + ;; prog is a string? + ((stringp prog) + + ;; Check arguments. + (cond + + ;; Check if the args are in the form of a list, will catch 'nil. + ((listp args) + + ;; Cat all the strings together. + (while args + (setq prog (concat prog " " (car args)) + args (cdr args)))) + + ;; Check if a non-null string. + ((and (not (string= "" args)) + (not (eq args t))) ; just in case... + (setq prog (concat prog " " args)))) + + (call-process-region start end shell-file-name t t nil "-c" prog)) + + ;; Otherwise try and eval it. + (t + (eval (if args + (list prog start end args) + (list prog start end)))))) + + ;; Encoding or decoding region? + (if (not decode) + + ;; Check if encoded region starts with magic number. + (let ((magic (crypt-get-magic-regexp crypt-buffer-encoding-type)) + (clean (crypt-get-cleanup-regexp crypt-buffer-encoding-type)) + (case-fold-search nil)) + + ;; Top of region. + (goto-char start) + + ;; Check for magic number. + (if (not (looking-at magic)) + + ;; Magic number not there. + + ;; Some compression programs produce an (inane) standard error + ;; message that gets piped into the buffer. For example, some + ;; versions of compact output "Compression : 35.50%." There may + ;; be some way to clean up buffer and check again. + + (cond + + ;; No mechanism to clean up - failed. + ((eq clean nil) + (error "Encoding failed!")) + + ;; Cleanup a regexp string? + ((stringp clean) + + ;; Is regexp there? + (if (looking-at clean) + + (progn + ;; Delete the match. + (delete-region (match-beginning 0) (match-end 0)) + + ;; Check for magic again. + (if (not (looking-at magic)) + (error "Encoding failed!"))))) + + ;; Default: evaluate a lisp expression and check again. + (t (eval clean) + (if (not (looking-at magic)) + (error "Encoding failed!"))))))))) + +(defun crypt-encode-buffer (&optional decode buffer) + + ;; Encode current buffer. With optional DECODE non-nil decode and optional + ;; BUFFER, encode or decode that buffer. Not meant to be called + ;; interactively, toggle `crypt-encoded-mode' to encode an entire buffer. + + (or buffer (setq buffer (current-buffer))) + (save-excursion (set-buffer buffer) + (crypt-encode-region (point-min) (point-max) decode))) + + +;;;; DOS <--> UNIX +(defun crypt-dos-to-unix-region (start end) + "Converts region from START to END, from dos to unix format. +Replaces \"\\r\\n\" with \"\\n\" and, if exists, removes ^Z at end of file. +Sets `crypt-dos-has-ctrl-z'." + (save-excursion + (save-restriction + (let ((remove-ctrl-z (equal end (point-max)))) + (narrow-to-region start end) + (goto-char (point-min)) + (while (search-forward "\r\n" nil t) + (replace-match "\n" nil t)) + (if remove-ctrl-z + (progn + (goto-char (1- (point-max))) + (setq crypt-dos-has-ctrl-z (looking-at "\C-z")) + (if crypt-dos-has-ctrl-z (replace-match "")))))))) + +(defun crypt-unix-to-dos-region (start end) + "Converts region from START to END, from unix to dos format. +Replaces \"\\n\" with \"\\r\\n\" and adds a ^Z at end of file if +`crypt-dos-has-ctrl-z' is non-nil." + (save-excursion + (save-restriction + (let ((add-ctrl-z (and crypt-dos-has-ctrl-z + (equal end (point-max))))) + (narrow-to-region start end) + (goto-char (point-min)) + (while (search-forward "\n" nil t) + (replace-match "\r\n" nil t)) + (if add-ctrl-z + (progn + (goto-char (point-max)) + (insert "\C-z"))))))) + + +;;;; MODES + +(defun crypt-encrypted-mode (&optional arg) + + "Toggle encrypted mode. With ARG, turn on iff positive, otherwise turn off. +minor mode in which buffers are automatically encrypted before being written. +if toggled and a key has been set for the current buffer, then the current +buffer is marked modified, since it needs to be rewritten with or without +encryption. + +Entering encrypted mode causes auto-saving to be turned off in the current +buffer, as there is no way in Emacs Lisp to force auto save files to be +encrypted." + + (interactive "P") + (let ((oldval crypt-buffer-save-encrypted)) + (setq crypt-buffer-save-encrypted + (if arg (> arg 0) (not crypt-buffer-save-encrypted))) + + (if crypt-buffer-save-encrypted + ;; We are going to save as encrypted, we will turn off auto-saving. + (progn +;; NEVER do this. Turning off auto-saving is one thing. But if there's +;; already an autosave for some other reason, what business does this +;; package have tampering with it? +; ;; If an auto-save file already exists, then delete it. +; (if (and (stringp buffer-auto-save-file-name) +; (file-exists-p buffer-auto-save-file-name)) +; (delete-file buffer-auto-save-file-name)) + ;; If the key is not set then ask for it. + (if (not crypt-buffer-encryption-key) + (call-interactively 'crypt-set-encryption-key)) + ;; Turn-off auto-saving if crypt-encrypted-disable-auto-save non-nil. + (and crypt-encrypted-disable-auto-save + auto-save-default + (progn + (auto-save-mode 0) + (if (eq crypt-encrypted-disable-auto-save t) + (message "Auto-save off (in this buffer)"))))) + + ;; We are not going to save as encrypted, we will turn on auto-saving + ;; but only if we are editing a file and the default says we should. + (auto-save-mode (if (and auto-save-default buffer-file-name) 1 0))) + + (if crypt-buffer-encryption-key + ;; Set buffer-modified flag to t only if the mode has been changed, + ;; old code set unconditionally to nil if mode was not changed . + ;; Modification suggested by: Gerd Hillebrand <ggh@cs.brown.edu> + (if (not (eq oldval crypt-buffer-save-encrypted)) + (set-buffer-modified-p t))))) + + +;;; Forgetting encryption keys (by jwz) +;;; This is really kind of bogus. Good behavior would be: +;;; - If a crypted buffer has not been "accessed" (edited? selected? +;;; viewed?) in N minutes, kill the buffer (since the plaintext is valuable.) +;;; - If a crypted buffer is modified, but "idle", just forget the password +;;; instead of killing the buffer (though the plaintext is valuable, it's +;;; also unsaved...) +;;; - The "idleness" of a modified buffer should be reset with every mod, so +;;; that an unsaved buffer that you have been constantly typing at for an +;;; hour doesn't lose its password. +;;; - But, if a password for a buffer has been discarded, and then an attempt +;;; is made to save that buffer, then we should confirm that the newly- +;;; typed password is the same as the password used in the file on disk. +;;; with PGP, we could check that by attempting to decrypt the file on +;;; disk into a scratch buffer and seeing if it contains the PGP error +;;; message. +;;; - BUG: if a password has been forgotten, and you save, and are prompted, +;;; the old file has already been renamed to a backup!! so if you ^G, the +;;; real file name no longer exists on disk - only as a ~ file. + +(defun crypt-forget-encryption-key () + (cond (crypt-buffer-encryption-key + (let ((inhibit-quit t)) + (fillarray crypt-buffer-encryption-key 0) + (setq crypt-buffer-encryption-key nil)) + t) + (t nil))) + +(add-hook 'kill-buffer-hook 'crypt-forget-encryption-key) + +(defcustom crypt-forget-passwd-timeout (* 60 60) + "*Do not retain passwords for encrypted buffers more than this many seconds. +If nil, keep them indefinitely." + :type '(choice integer (const :tag "indefinite" nil)) + :group 'crypt) + +(defun crypt-reset-passwd-timer () + (if (fboundp 'get-itimer) ; XEmacs, or anything with itimer.el loaded. + (let ((name "crypt-forget-passwds")) + (if (get-itimer name) + (delete-itimer name)) + (if crypt-forget-passwd-timeout + (start-itimer name + 'crypt-reset-passwds-timeout + crypt-forget-passwd-timeout))))) + +(defun crypt-reset-passwds-timeout () + ;; run by the timer code to forget all passwords + (let ((buffers (buffer-list)) + (inhibit-quit t) + (keep-going nil)) + (while buffers + (save-excursion + (set-buffer (car buffers)) + (cond ((and crypt-buffer-encryption-key + (buffer-modified-p)) + ;; don't forget the password in modified buffers, but + ;; do check again later (maybe it will be unmodified.) + (setq keep-going t)) + (crypt-buffer-encryption-key + ;; forget the password in unmodified buffers. + (crypt-forget-encryption-key) + ;; Mark the buffer read only so that it's not accidentally + ;; edited; the smart thing to do is revert it, type the + ;; encryption key (to make sure they same key is used) + ;; and then edit it. + (setq buffer-read-only t) + (message "Password discarded in buffer %s" + (buffer-name (car buffers)))) + )) + (setq buffers (cdr buffers))) + (if keep-going + (crypt-reset-passwd-timer)) + nil)) + + +;;; Originally `tek-symbol-alist-to-table' from tek-highlight.el. +(defun crypt-symbol-alist-to-table (list) + ;; Converts an alist of symbols to a table suitable for `completing-read.' + ;; Called by `crypt-read-encoding-type' + (mapcar (function (lambda (x) (list (symbol-name (car x))))) + list)) + +(defun crypt-read-encoding-type () + + ;; Function called to query user for `crypt-buffer-encoding-type' uses + ;; contents of `crypt-encoding-alist' and `crypt-default-encoding.' + + ;; Use poor man's gmhist (i.e., we could have used gmhist's + ;; `completing-read-with-history-in' instead). + (let ( + ;; Find the encoding type desired by user. + (type + (completing-read + (concat "encoding type (? for list): [" crypt-default-encoding "] ") + (crypt-symbol-alist-to-table crypt-encoding-alist)))) + + ;; Test length of object returned by `completing-read'. + (if (zerop (length type)) + + ;; Nothing there, i.e., user hit return -- use default. + (setq crypt-buffer-encoding-type (intern crypt-default-encoding)) + + ;; Use the value from mini-buffer and update the default value. + (setq crypt-buffer-encoding-type (intern type) + crypt-default-encoding type)))) + +(defun crypt-encoded-mode (&optional arg) + + "Toggle encoded mode. With ARG, turn on iff positive, otherwise turn off. +minor mode in which buffers are automatically encoded before being written. if +toggled then current buffer is marked modified, since it needs to be written +with or without encoding. + +Entering encoded mode causes auto-saving to be turned off in the current +buffer, as there is no way in Emacs Lisp to force auto save files to be +encoded." + + (interactive "P") + + ;; Set flag indicating whether or not `(crypt-encoded-mode)' was called + ;; interactively. + (setq crypt-buffer-interactive-encoded-mode (interactive-p)) + + ;; If called interactively then need to determine encoding type. + (if (and crypt-buffer-interactive-encoded-mode + (not crypt-buffer-encoding-type)) + (crypt-read-encoding-type)) + + ;; Save old value of `crypt-buffer-save-encoded'. + (let ((oldval crypt-buffer-save-encoded)) + + ;; Set the variable `crypt-buffer-save-encoded' to t if the argument is + ;; positive, otherwise toggle its current value. + (setq crypt-buffer-save-encoded + (if arg (> arg 0) (not crypt-buffer-save-encoded))) + + ;; Set the variable generated by `(crypt-buffer-save-name)' to the value + ;; stored in `crypt-buffer-save-encoded.' + (set-variable (crypt-buffer-save-name crypt-buffer-encoding-type) + crypt-buffer-save-encoded) + + (if crypt-buffer-save-encoded + ;; We are going to save as encoded, we might turn off auto-saving. + (progn +;; NEVER do this. Turning off auto-saving is one thing. But if there's +;; already an autosave for some other reason, what business does this +;; package have tampering with it? +; ;; If an auto-save file already exists, then delete it. +; (if (and (stringp buffer-auto-save-file-name) +; (file-exists-p buffer-auto-save-file-name)) +; (delete-file buffer-auto-save-file-name)) + ;; Turn-off auto-saving if crypt-encoded-disable-auto-save non-nil. + (and crypt-encoded-disable-auto-save + auto-save-default + (progn + (auto-save-mode 0) + (if (eq crypt-encoded-disable-auto-save t) + (message "Auto-save off (in this buffer)"))))) + + ;; We are not going to save as encoded, we will turn on auto-saving but + ;; only if we are editing a file and the default says we should. + (auto-save-mode (if (and auto-save-default buffer-file-name) 1 0))) + + ;; Have we toggled the mode? + + ;; If yes, then mark buffer as modified. If not, then leave + ;; buffer-modified flag alone. + + ;; The old code previously set the variable `set-buffer-modified-p' to a + ;; value of t if there was a mode change and (unconditionally) to nil + ;; if there was not a mode change. + + ;; Modification suggested by: Gerd Hillebrand <ggh@cs.brown.edu>. + + (if (not (eq oldval crypt-buffer-save-encoded)) + (set-buffer-modified-p t)))) + + +;;;; Additional encryption functions + +;; For Emacs V18 compatibility +(and (not (fboundp 'buffer-disable-undo)) + (fboundp 'buffer-flush-undo) + (fset 'buffer-disable-undo 'buffer-flush-undo)) + +(fset 'crypt-read-string-no-echo 'read-passwd) + +;(defun crypt-read-string-no-echo (prompt &optional confirm) +; +; ;; Read a string from minibuffer, prompting with PROMPT, echoing periods. +; ;; Optional second argument CONFIRM non-nil means that the user will be +; ;; asked to type the string a second time for confirmation and if there is a +; ;; mismatch, the whole process is repeated. +; ;; +; ;; Line editing keys are -- +; ;; C-h, DEL rubout +; ;; C-u, C-x line kill +; ;; C-q, C-v literal next +; +; (catch 'return-value +; (save-excursion +; +; (let ((input-buffer (get-buffer-create (make-temp-name " *password*"))) +; char hold-password help-form kill-ring) +; +; (set-buffer input-buffer) +; ;; Don't add to undo ring. +; (buffer-disable-undo input-buffer) +; +; (let ((cursor-in-echo-area t) +; (echo-keystrokes 0)) +; +; (unwind-protect +; +; ;; BODYFORM +; ;; Repeat until we get a `throw'. +; (while t +; (erase-buffer) +; (message prompt) +; +; ;; Read string. +; (while (not (memq (setq char (read-char)) '(?\C-m ?\C-j))) +; (if (setq help-form +; (cdr +; (assq char +; '((?\C-h . (delete-char -1)) +; (?\C-? . (delete-char -1)) +; (?\C-u . (delete-region 1 (point))) +; (?\C-x . (delete-region 1 (point))) +; (?\C-q . (quoted-insert 1)) +; (?\C-v . (quoted-insert 1)))))) +; (condition-case error-data +; (eval help-form) +; (error t)) +; ;; Just a plain character - insert into password buffer. +; (insert char)) +; +; ;; I think crypt-read-string-no-echo should echo asterisks. +; ;; -- Jamie. How about periods like in ange-ftp? -- lrd +; ;; +; (message "%s%s" prompt (make-string (buffer-size) ?.))) +; +; ;; Do we have to confirm password? +; (cond +; +; ;; No confirmation requested - terminate. +; ((not confirm) +; (throw 'return-value (buffer-string))) +; +; ;; Can we compare (confirm) password values yet? +; (hold-password +; (if (string= hold-password (buffer-string)) +; ;; The two passwords match - terminate. +; (throw 'return-value hold-password) +; +; ;; Mismatch - start over. +; (progn +; (message (concat prompt "[Mismatch. Start over]")) +; (beep) +; (sit-for 2) +; (fillarray hold-password 0) ; destroy extra copy now +; (setq hold-password nil)))) +; +; ;; Store password and read again. +; (t +; (setq hold-password (buffer-string)) +; (message (concat prompt "[Retype to confirm]")) +; (sit-for 2)))) +; +; ;; UNWINDFORMS +; ;; Clean up. +; (set-buffer input-buffer) +; (set-buffer-modified-p nil) +; (buffer-disable-undo input-buffer) ; redundant, but why not be safe. +; (widen) +; (goto-char (point-min)) +; (while (not (eobp)) (delete-char 1) (insert "*")) ; destroy now +; (kill-buffer input-buffer))))))) + +(defun crypt-set-encryption-key (key &optional buffer) + + "Set the encryption KEY, a string, for current buffer or optionally BUFFER. +If buffer is in encrypted mode, then it is also marked as modified, since it +needs to be saved with the new key." + + (interactive + (progn + (barf-if-buffer-read-only) + (list (crypt-read-string-no-echo + (format "Encryption key for %s? [RET to ignore]: " (buffer-name)) + crypt-confirm-password)))) + + ;; For security reasons we remove `(crypt-set-encryption-key "password")' + ;; from the `command-history' list if called interactively. + (if (interactive-p) + (setq command-history (cdr command-history))) + + (or buffer (setq buffer (current-buffer))) + + (save-excursion + (set-buffer buffer) + (if (equal key crypt-buffer-encryption-key) + (message "Key is identical to original, no change.") + + (progn + ;; jwz: destroy old string + (if (and crypt-buffer-encryption-key + (not (eq crypt-buffer-encryption-key key))) + (fillarray crypt-buffer-encryption-key 0)) + (setq crypt-buffer-encryption-key key) + + ;; Don't touch the modify flag unless we're in `(crypt-encrypted-mode)'. + (if crypt-buffer-save-encrypted + (set-buffer-modified-p t)) + + (crypt-reset-passwd-timer) + )))) + + +;;;; Install hooks and mode indicators. + +;;; Check if mode indicators are not already installed and then prepend them. +(and (not (assq 'crypt-buffer-save-encrypted minor-mode-alist)) + (setq minor-mode-alist (append crypt-minor-mode-alist minor-mode-alist))) + +;;; Install the hooks. + +;;; If add-hook isn't already defined overwrite it with our own. +;;; Note the `add-hook' function must take the optional APPEND argument. +(if (not (fboundp 'add-hook)) + ;; No add-hook found. + ;; Use `add-hook' from GNU Emacs v19. + (defun add-hook (hook function &optional append) + "Add to the value of HOOK the function FUNCTION. +FUNCTION is not added if already present. +FUNCTION is added (if necessary) at the beginning of the hook list +unless the optional argument APPEND is non-nil, in which case +FUNCTION is added at the end. + +HOOK should be a symbol, and FUNCTION may be any valid function. If +HOOK is void, it is first set to nil. If HOOK's value is a single +function, it is changed to a list of functions." + (or (boundp hook) (set hook nil)) + ;; If the hook value is a single function, turn it into a list. + (let ((old (symbol-value hook))) + (if (or (not (listp old)) (eq (car old) 'lambda)) + (set hook (list old)))) + (or (if (consp function) + ;; Clever way to tell whether a given lambda-expression + ;; is equal to anything in the hook. + (let ((tail (assoc (cdr function) (symbol-value hook)))) + (equal function tail)) + (memq function (symbol-value hook))) + (set hook + (if append + (nconc (symbol-value hook) (list function)) + (cons function (symbol-value hook))))))) + +;;; Attach ourselves to the find-file-hooks and find-file-not-found-hooks. +(add-hook 'find-file-hooks 'crypt-find-file-hook) +(add-hook 'find-file-not-found-hooks 'crypt-find-file-hook) + +;; Take care when appending to write-file-hook. User's version of add-hook +;; may not have APPEND option. If it fails then do it by hand. I wish +;; everyone would upgrade - lrd 8/31/93. +(condition-case err + (add-hook 'write-file-hooks 'crypt-write-file-hook t) ; *must* append this + (error + ;; Do it by hand. Not as robust as `add-hook'. + + ;; Contributed by Ken Laprade <laprade@trantor.harris-atd.com> + ;; Really should use some sort of add-hook - 16 Feb 93 - KCL + (or (and (listp write-file-hooks) (not (eq (car write-file-hooks) 'lambda))) + (setq write-file-hooks (list write-file-hooks))) + + (cond + ((not (memq 'crypt-write-file-hook write-file-hooks)) + ;; make this hook last on purpose + (setq write-file-hooks (append write-file-hooks + (list 'crypt-write-file-hook))))))) + +;; In order that the tables and key-binding correctly reflect user's +;; preferences we add ourselves to the `after-init-hook' GNU Emacs v19 and +;; Lucid Emacs v 19.8 (or later) or `term-setup-hook' in Lucid Emacs v 19.7 +;; (or earlier). These are run *after* ~/.emacs and ../lisp/default.el are +;; loaded. Unfortunately, v18 does not have `after-init-hook' and +;; `term-setup-hook' is just a single function. It is a bit of a pain trying +;; to work our functions in properly without overwriting the user's value. +;; Therefore, we do nothing and hope they upgrade to v19 soon. + +(cond ((boundp 'after-init-hook) + ;; Must be running GNU Emacs v19 :-> + (add-hook 'after-init-hook 'crypt-rebuild-tables) + (add-hook 'after-init-hook 'crypt-rebuild-minor-modes-alist) + (add-hook 'after-init-hook 'crypt-bind-insert-file)) + + ((and (string-match "^19" emacs-version) t) + ;; Probably running Lucid Emacs v19.7 (or earlier) since it, + ;; unfortunately, does not have `after-init-hook'. Use + ;; `term-setup-hook' instead and hope they upgrade to Lucid 19.8 or GNU + ;; Emacs 19. + (add-hook 'term-setup-hook 'crypt-rebuild-tables) + (add-hook 'term-setup-hook 'crypt-rebuild-minor-modes-alist) + (add-hook 'term-setup-hook 'crypt-bind-insert-file))) + + +;;; Code for conditionally decoding/decrypting an inserted file + +(defcustom crypt-bind-insert-file t + "*t value means bind `crypt-insert-file' over `insert-file'. +If you wish to change this variable after crypt++ has been loaded then do +\\[crypt-bind-insert-file]." + :type 'boolean + :group 'crypt) + +(defcustom crypt-auto-decode-insert nil + "*t says decode/decrypt files that are inserted with `crypt-insert-file'. +nil says to ask before doing this." + :type 'boolean + :group 'crypt) + +;;; Bind `crypt-insert-file' over wherever `insert-file' is bound? +(defun crypt-bind-insert-file () + + "Bind `crypt-insert-file' in place of `insert-file' or reverse based on +`crypt-bind-insert-file'. Part of `after-init-hook'." + + (interactive) + + (if (interactive-p) + (setq crypt-bind-insert-file + (y-or-n-p "Bind crypt-insert-file over insert-file? "))) + + (if crypt-bind-insert-file + (substitute-key-definition + 'insert-file 'crypt-insert-file (current-global-map)) + (substitute-key-definition + 'crypt-insert-file 'insert-file (current-global-map)))) + +;;; Now call it. +(crypt-bind-insert-file) + +;;; crypt++ replacement for `insert-file' +(defun crypt-insert-file (filename &optional codesys) + "Insert decoded/decrypted contents of file FILENAME into buffer after point. +Set mark after the inserted text. + +Under XEmacs/Mule, optional second argument specifies the +coding system to use when decoding the file. Interactively, +with a prefix argument, you will be prompted for the coding system. + +This function is meant for the user to run interactively. +Don't call it from programs! Use `insert-file-contents' instead. +\(Its calling sequence is different; see its documentation\). + +This version will attempt to decrypt and/or decode file before inserting. +see variable `crypt-auto-decode-insert'." + (interactive "*fInsert file: \nZCoding system: ") + (if (file-directory-p filename) + (signal 'file-error (list "Opening input file" "file is a directory" + filename))) + (let* (format-alist ; format.el only confuses people in this context + (tem + (if codesys + (let ((coding-system-for-read + (get-coding-system codesys))) + (crypt-insert-file-contents filename)) + (crypt-insert-file-contents filename)))) + (push-mark (+ (point) (car (cdr tem)))))) + +(defun crypt-insert-file-contents (file) + + ;; Similar to `insert-file-contents' except decoding/decrypting of FILE + ;; attempted. See `crypt-insert-file' and `crypt-auto-decode-insert' + + (let (temp-buffer + temp-list + (crypt-auto-decode-buffer crypt-auto-decode-insert) + (orig-buffer (current-buffer))) + + ;; Create a temporary buffer and decode and decrypt it. + (save-excursion + + ;; Temporary buffer, use the same name as the file to be inserted. + (setq temp-buffer (generate-new-buffer (file-name-nondirectory file))) + (set-buffer temp-buffer) + + ;; Original insert-file-contents - save list. + (setq temp-list (insert-file-contents file nil)) + + ;; Make temp-buffer unmodified. + (set-buffer-modified-p nil) + + ;; Need to set buffer name to file name for crypt++. + (setq buffer-file-name file) + + ;; Decode and decrypt, if necessary. + (crypt-find-file-hook) + + ;; Find the length of the file to be inserted. `insert-file-contents' + ;; returns it for the original encoded/encrypted file. + (setcdr temp-list (cons (buffer-size) ())) + + ;; Now insert temp-buffer into original buffer. + (set-buffer orig-buffer) + (insert-buffer temp-buffer) + + ;; Kill the temporary buffer. + (kill-buffer temp-buffer)) + + ;; Return modified list from `insert-file-contents'. + temp-list)) + + +;;;; BUG REPORTS + +;;; This section is provided for reports. +;;; Using Barry A. Warsaw's reporter.el + +(defconst crypt-version "2.82" + "Revision number of crypt++.el -- handles compressed and encrypted files. +Type \\[crypt-submit-report] to send a bug report. Available via anonymous +ftp in + + /roebling.poly.edu:/pub/lisp/crypt++.el.gz + /archive.cis.ohio-state.edu:/pub/gnu/emacs/elisp-archive/misc/crypt++.el.Z") + +(defconst crypt-help-address + "dodd@roebling.poly.edu" + "Address(es) accepting submission of reports on crypt++.el.") + +(defconst crypt-maintainer "Larry" + "First name(s) of people accepting submission of reports on crypt++.el.") + +(defconst crypt-file "crypt++.el" + "Name of file containing emacs lisp code.") + +(defconst crypt-variable-list + (list 'shell-file-name ; These + 'load-path ; are + 'exec-path ; useful. + 'crypt-encryption-type + 'crypt-encryption-file-extension + 'crypt-never-ever-decrypt + 'crypt-auto-write-buffer-encrypted + 'crypt-confirm-password + 'crypt-encrypted-disable-auto-save + 'crypt-auto-decode-buffer + 'crypt-auto-write-buffer + 'crypt-query-if-interactive + 'crypt-no-extension-implies-plain + 'crypt-freeze-vs-fortran + 'crypt-compact-vs-C++ + 'crypt-ignored-filenames + 'crypt-default-encoding + 'crypt-encoded-disable-auto-save + 'crypt-bind-insert-file + 'crypt-auto-decode-insert + 'crypt-encoding-alist + 'crypt-encryption-alist + ) + "List of variables to be appended to reports sent by `crypt-submit-report.'") + +(defun crypt-submit-report () + "Submit via reporter.el a bug report on program. Send report on `crypt-file' +version `crypt-version,' to `crypt-maintainer' at address `crypt-help-address' +listing variables `crypt-variable-list' in the message." + (interactive) + + ;; In case we can't find reporter... + (condition-case err + (progn + ;; Get it if we can. + (require 'reporter) + + (reporter-submit-bug-report + crypt-help-address ; address + (concat crypt-file " " crypt-version) ; pkgname + crypt-variable-list ; varlist + nil nil ; pre-hooks and post-hooks + (concat "Yo! " crypt-maintainer ","))) ; salutation + + ;; ...fail gracefully. + (error + (beep) + + ;; Do they have ange-ftp? + (if (and (featurep 'ange-ftp) + (y-or-n-p (concat "Sorry, reporter.el not found. " + "Can I ange-ftp it for you? "))) + + ;; Yes. Then Ange-ftp a copy from roebling. + (let ((ange-ftp-generate-anonymous-password t)) + ;; Might want to use the elisp archive official site? But + ;; then it would have to be uncompressed, etc. Ick! + (find-file-other-window + "/anonymous@roebling.poly.edu:/pub/reporter.el") + (eval-current-buffer) + (message (concat "Save reporter.el somewhere in `load-path' " + "and try again."))) + + ;; No ange-ftp. + (message "Sorry, reporter.el not found.") + (sit-for 3) + (message (concat "Get it from archive.cis.ohio-state.edu " + "or roebling.poly.edu")))))) + +;;; Provide this package as crypt++ as well as crypt. +(provide 'crypt++) +(provide 'crypt) + +;;; crypt++.el ends here. diff --git a/inf-lisp.el b/inf-lisp.el new file mode 100644 --- /dev/null +++ b/inf-lisp.el @@ -0,0 +1,636 @@ +;;; inf-lisp.el --- an inferior-lisp mode +;;; Copyright (C) 1988, 1993, 1994 Free Software Foundation, Inc. + +;; Author: Olin Shivers <shivers@cs.cmu.edu> +;; Keywords: processes, lisp + +;; This file is part of XEmacs. + +;; XEmacs 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 2, or (at your option) +;; any later version. + +;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Synched up with: FSF 19.30. + +;;; Commentary: + +;;; Hacked from tea.el by Olin Shivers (shivers@cs.cmu.edu). 8/88 + +;;; This file defines a a lisp-in-a-buffer package (inferior-lisp +;;; mode) built on top of comint mode. This version is more +;;; featureful, robust, and uniform than the Emacs 18 version. The +;;; key bindings are also more compatible with the bindings of Hemlock +;;; and Zwei (the Lisp Machine emacs). + +;;; Since this mode is built on top of the general command-interpreter-in- +;;; a-buffer mode (comint mode), it shares a common base functionality, +;;; and a common set of bindings, with all modes derived from comint mode. +;;; This makes these modes easier to use. + +;;; For documentation on the functionality provided by comint mode, and +;;; the hooks available for customizing it, see the file comint.el. +;;; For further information on inferior-lisp mode, see the comments below. + +;;; Needs fixin: +;;; The load-file/compile-file default mechanism could be smarter -- it +;;; doesn't know about the relationship between filename extensions and +;;; whether the file is source or executable. If you compile foo.lisp +;;; with compile-file, then the next load-file should use foo.bin for +;;; the default, not foo.lisp. This is tricky to do right, particularly +;;; because the extension for executable files varies so much (.o, .bin, +;;; .lbin, .mo, .vo, .ao, ...). +;;; +;;; It would be nice if inferior-lisp (and inferior scheme, T, ...) modes +;;; had a verbose minor mode wherein sending or compiling defuns, etc. +;;; would be reflected in the transcript with suitable comments, e.g. +;;; ";;; redefining fact". Several ways to do this. Which is right? +;;; +;;; When sending text from a source file to a subprocess, the process-mark can +;;; move off the window, so you can lose sight of the process interactions. +;;; Maybe I should ensure the process mark is in the window when I send +;;; text to the process? Switch selectable? + +;;; Code: + +(require 'comint) +(require 'lisp-mode) + + +;;;jwz: ilisp is better, don't ###autoload +(defvar inferior-lisp-filter-regexp "\\`\\s *\\(:\\(\\w\\|\\s_\\)\\)?\\s *\\'" + "*What not to save on inferior Lisp's input history. +Input matching this regexp is not saved on the input history in Inferior Lisp +mode. Default is whitespace followed by 0 or 1 single-letter colon-keyword +\(as in :a, :c, etc.)") + +(defvar inferior-lisp-mode-map nil) +(cond ((not inferior-lisp-mode-map) + (setq inferior-lisp-mode-map (make-sparse-keymap)) + (set-keymap-name inferior-lisp-mode-map 'inferior-lisp-mode-map) + (set-keymap-parents inferior-lisp-mode-map + (list comint-mode-map shared-lisp-mode-map)) + (define-key inferior-lisp-mode-map "\C-x\C-e" 'lisp-eval-last-sexp) + (define-key inferior-lisp-mode-map "\C-c\C-l" 'lisp-load-file) + (define-key inferior-lisp-mode-map "\C-c\C-k" 'lisp-compile-file) + (define-key inferior-lisp-mode-map "\C-c\C-a" 'lisp-show-arglist) + (define-key inferior-lisp-mode-map "\C-c\C-d" 'lisp-describe-sym) + (define-key inferior-lisp-mode-map "\C-c\C-f" + 'lisp-show-function-documentation) + (define-key inferior-lisp-mode-map "\C-c\C-v" + 'lisp-show-variable-documentation))) + +;;; These commands augment Lisp mode, so you can process Lisp code in +;;; the source files. +(define-key lisp-mode-map "\M-\C-x" 'lisp-eval-defun) ; Gnu convention +(define-key lisp-mode-map "\C-x\C-e" 'lisp-eval-last-sexp) ; Gnu convention +(define-key lisp-mode-map "\C-c\C-e" 'lisp-eval-defun) +(define-key lisp-mode-map "\C-c\C-r" 'lisp-eval-region) +(define-key lisp-mode-map "\C-c\C-c" 'lisp-compile-defun) +(define-key lisp-mode-map "\C-c\C-z" 'switch-to-lisp) +(define-key lisp-mode-map "\C-c\C-l" 'lisp-load-file) +(define-key lisp-mode-map "\C-c\C-k" 'lisp-compile-file) ; "kompile" file +(define-key lisp-mode-map "\C-c\C-a" 'lisp-show-arglist) +(define-key lisp-mode-map "\C-c\C-d" 'lisp-describe-sym) +(define-key lisp-mode-map "\C-c\C-f" 'lisp-show-function-documentation) +(define-key lisp-mode-map "\C-c\C-v" 'lisp-show-variable-documentation) + +;;; This function exists for backwards compatibility. +;;; Previous versions of this package bound commands to C-c <letter> +;;; bindings, which is not allowed by the gnumacs standard. + +;;; "This function binds many inferior-lisp commands to C-c <letter> bindings, +;;;where they are more accessible. C-c <letter> bindings are reserved for the +;;;user, so these bindings are non-standard. If you want them, you should +;;;have this function called by the inferior-lisp-load-hook: +;;; (setq inferior-lisp-load-hook '(inferior-lisp-install-letter-bindings)) +;;;You can modify this function to install just the bindings you want." +(defun inferior-lisp-install-letter-bindings () + (define-key lisp-mode-map "\C-ce" 'lisp-eval-defun-and-go) + (define-key lisp-mode-map "\C-cr" 'lisp-eval-region-and-go) + (define-key lisp-mode-map "\C-cc" 'lisp-compile-defun-and-go) + (define-key lisp-mode-map "\C-cz" 'switch-to-lisp) + (define-key lisp-mode-map "\C-cl" 'lisp-load-file) + (define-key lisp-mode-map "\C-ck" 'lisp-compile-file) + (define-key lisp-mode-map "\C-ca" 'lisp-show-arglist) + (define-key lisp-mode-map "\C-cd" 'lisp-describe-sym) + (define-key lisp-mode-map "\C-cf" 'lisp-show-function-documentation) + (define-key lisp-mode-map "\C-cv" 'lisp-show-variable-documentation) + + (define-key inferior-lisp-mode-map "\C-cl" 'lisp-load-file) + (define-key inferior-lisp-mode-map "\C-ck" 'lisp-compile-file) + (define-key inferior-lisp-mode-map "\C-ca" 'lisp-show-arglist) + (define-key inferior-lisp-mode-map "\C-cd" 'lisp-describe-sym) + (define-key inferior-lisp-mode-map "\C-cf" 'lisp-show-function-documentation) + (define-key inferior-lisp-mode-map "\C-cv" + 'lisp-show-variable-documentation)) + + +;;;jwz: ilisp is better, don't ###autoload +(defvar inferior-lisp-program "lisp" + "*Program name for invoking an inferior Lisp with for Inferior Lisp mode.") + +;;;jwz: ilisp is better, don't ###autoload +(defvar inferior-lisp-load-command "(load \"%s\")\n" + "*Format-string for building a Lisp expression to load a file. +This format string should use `%s' to substitute a file name +and should result in a Lisp expression that will command the inferior Lisp +to load that file. The default works acceptably on most Lisps. +The string \"(progn (load \\\"%s\\\" :verbose nil :print t) (values))\\n\" +produces cosmetically superior output for this application, +but it works only in Common Lisp.") + +;;;jwz: ilisp is better, don't ###autoload +(defvar inferior-lisp-prompt "^[^> \n]*>+:? *" + "Regexp to recognise prompts in the Inferior Lisp mode. +Defaults to \"^[^> \\n]*>+:? *\", which works pretty good for Lucid, kcl, +and franz. This variable is used to initialize `comint-prompt-regexp' in the +Inferior Lisp buffer. + +More precise choices: +Lucid Common Lisp: \"^\\\\(>\\\\|\\\\(->\\\\)+\\\\) *\" +franz: \"^\\\\(->\\\\|<[0-9]*>:\\\\) *\" +kcl: \"^>+ *\" + +This is a fine thing to set in your .emacs file.") + +(defvar inferior-lisp-buffer nil "*The current inferior-lisp process buffer. + +MULTIPLE PROCESS SUPPORT +=========================================================================== +To run multiple Lisp processes, you start the first up +with \\[inferior-lisp]. It will be in a buffer named `*inferior-lisp*'. +Rename this buffer with \\[rename-buffer]. You may now start up a new +process with another \\[inferior-lisp]. It will be in a new buffer, +named `*inferior-lisp*'. You can switch between the different process +buffers with \\[switch-to-buffer]. + +Commands that send text from source buffers to Lisp processes -- +like `lisp-eval-defun' or `lisp-show-arglist' -- have to choose a process +to send to, when you have more than one Lisp process around. This +is determined by the global variable `inferior-lisp-buffer'. Suppose you +have three inferior Lisps running: + Buffer Process + foo inferior-lisp + bar inferior-lisp<2> + *inferior-lisp* inferior-lisp<3> +If you do a \\[lisp-eval-defun] command on some Lisp source code, +what process do you send it to? + +- If you're in a process buffer (foo, bar, or *inferior-lisp*), + you send it to that process. +- If you're in some other buffer (e.g., a source file), you + send it to the process attached to buffer `inferior-lisp-buffer'. +This process selection is performed by function `inferior-lisp-proc'. + +Whenever \\[inferior-lisp] fires up a new process, it resets +`inferior-lisp-buffer' to be the new process's buffer. If you only run +one process, this does the right thing. If you run multiple +processes, you can change `inferior-lisp-buffer' to another process +buffer with \\[set-variable].") + +;;;jwz: ilisp is better, don't ###autoload +(defvar inferior-lisp-mode-hook '() + "*Hook for customizing Inferior Lisp mode.") + +(defun inferior-lisp-mode () + "Major mode for interacting with an inferior Lisp process. +Runs a Lisp interpreter as a subprocess of Emacs, with Lisp I/O through an +Emacs buffer. Variable `inferior-lisp-program' controls which Lisp interpreter +is run. Variables `inferior-lisp-prompt', `inferior-lisp-filter-regexp' and +`inferior-lisp-load-command' can customize this mode for different Lisp +interpreters. + +For information on running multiple processes in multiple buffers, see +documentation for variable `inferior-lisp-buffer'. + +\\{inferior-lisp-mode-map} + +Customization: Entry to this mode runs the hooks on `comint-mode-hook' and +`inferior-lisp-mode-hook' (in that order). + +You can send text to the inferior Lisp process from other buffers containing +Lisp source. + switch-to-lisp switches the current buffer to the Lisp process buffer. + lisp-eval-defun sends the current defun to the Lisp process. + lisp-compile-defun compiles the current defun. + lisp-eval-region sends the current region to the Lisp process. + lisp-compile-region compiles the current region. + + Prefixing the lisp-eval/compile-defun/region commands with + a \\[universal-argument] causes a switch to the Lisp process buffer after sending + the text. + +Commands: +Return after the end of the process' output sends the text from the + end of process to point. +Return before the end of the process' output copies the sexp ending at point + to the end of the process' output, and sends it. +Delete converts tabs to spaces as it moves back. +Tab indents for Lisp; with argument, shifts rest + of expression rigidly with the current line. +C-M-q does Tab on each line starting within following expression. +Paragraphs are separated only by blank lines. Semicolons start comments. +If you accidentally suspend your process, use \\[comint-continue-subjob] +to continue it." + (interactive) + (comint-mode) + (setq comint-prompt-regexp inferior-lisp-prompt) + (setq major-mode 'inferior-lisp-mode) + (setq mode-name "Inferior Lisp") + (setq mode-line-process '(":%s")) + (lisp-mode-variables t) + (use-local-map inferior-lisp-mode-map) ;c-c c-k for "kompile" file + (setq comint-get-old-input (function lisp-get-old-input)) + (setq comint-input-filter (function lisp-input-filter)) + (setq comint-input-sentinel 'ignore) + (run-hooks 'inferior-lisp-mode-hook)) + +(defun lisp-get-old-input () + "Return a string containing the sexp ending at point." + (save-excursion + (let ((end (point))) + (backward-sexp) + (buffer-substring (point) end)))) + +(defun lisp-input-filter (str) + "t if STR does not match `inferior-lisp-filter-regexp'." + (not (string-match inferior-lisp-filter-regexp str))) + +;;;jwz: ilisp is better, don't ###autoload +(defun inferior-lisp (cmd) + "Run an inferior Lisp process, input and output via buffer `*inferior-lisp*'. +If there is a process already running in `*inferior-lisp*', just switch +to that buffer. +With argument, allows you to edit the command line (default is value +of `inferior-lisp-program'). Runs the hooks from +`inferior-lisp-mode-hook' (after the `comint-mode-hook' is run). +\(Type \\[describe-mode] in the process buffer for a list of commands.)" + (interactive (list (if current-prefix-arg + (read-string "Run lisp: " inferior-lisp-program) + inferior-lisp-program))) + (if (not (comint-check-proc "*inferior-lisp*")) + (let ((cmdlist (inferior-lisp-args-to-list cmd))) + (set-buffer (apply (function make-comint) + "inferior-lisp" (car cmdlist) nil (cdr cmdlist))) + (inferior-lisp-mode))) + (setq inferior-lisp-buffer "*inferior-lisp*") + (pop-to-buffer "*inferior-lisp*")) +;;;###autoload (add-hook 'same-window-buffer-names "*inferior-lisp*") + +;;;jwz: ilisp is better, don't ###autoload +(define-function 'run-lisp 'inferior-lisp) + +;;; Break a string up into a list of arguments. +;;; This will break if you have an argument with whitespace, as in +;;; string = "-ab +c -x 'you lose'". +(defun inferior-lisp-args-to-list (string) + (let ((where (string-match "[ \t]" string))) + (cond ((null where) (list string)) + ((not (= where 0)) + (cons (substring string 0 where) + (inferior-lisp-args-to-list (substring string (+ 1 where) + (length string))))) + (t (let ((pos (string-match "[^ \t]" string))) + (if (null pos) + nil + (inferior-lisp-args-to-list (substring string pos + (length string))))))))) + +(defun lisp-eval-region (start end &optional and-go) + "Send the current region to the inferior Lisp process. +Prefix argument means switch to the Lisp buffer afterwards." + (interactive "r\nP") + (comint-send-region (inferior-lisp-proc) start end) + (comint-send-string (inferior-lisp-proc) "\n") + (if and-go (switch-to-lisp t))) + +(defun lisp-eval-defun (&optional and-go) + "Send the current defun to the inferior Lisp process. +Prefix argument means switch to the Lisp buffer afterwards." + (interactive "P") + (save-excursion + (end-of-defun) + (skip-chars-backward " \t\n\r\f") ; Makes allegro happy + (let ((end (point))) + (beginning-of-defun) + (lisp-eval-region (point) end))) + (if and-go (switch-to-lisp t))) + +(defun lisp-eval-last-sexp (&optional and-go) + "Send the previous sexp to the inferior Lisp process. +Prefix argument means switch to the Lisp buffer afterwards." + (interactive "P") + (lisp-eval-region (save-excursion (backward-sexp) (point)) (point) and-go)) + +;;; Common Lisp COMPILE sux. +(defun lisp-compile-region (start end &optional and-go) + "Compile the current region in the inferior Lisp process. +Prefix argument means switch to the Lisp buffer afterwards." + (interactive "r\nP") + (comint-send-string + (inferior-lisp-proc) + (format "(funcall (compile nil `(lambda () (progn 'compile %s))))\n" + (buffer-substring start end))) + (if and-go (switch-to-lisp t))) + +(defun lisp-compile-defun (&optional and-go) + "Compile the current defun in the inferior Lisp process. +Prefix argument means switch to the Lisp buffer afterwards." + (interactive "P") + (save-excursion + (end-of-defun) + (skip-chars-backward " \t\n\r\f") ; Makes allegro happy + (let ((e (point))) + (beginning-of-defun) + (lisp-compile-region (point) e))) + (if and-go (switch-to-lisp t))) + +(defun switch-to-lisp (eob-p) + "Switch to the inferior Lisp process buffer. +With argument, positions cursor at end of buffer." + (interactive "P") + (if (get-buffer inferior-lisp-buffer) + (pop-to-buffer inferior-lisp-buffer) + (error "No current inferior Lisp buffer")) + (cond (eob-p + (push-mark) + (goto-char (point-max))))) + + +;;; Now that lisp-compile/eval-defun/region takes an optional prefix arg, +;;; these commands are redundant. But they are kept around for the user +;;; to bind if he wishes, for backwards functionality, and because it's +;;; easier to type C-c e than C-u C-c C-e. + +(defun lisp-eval-region-and-go (start end) + "Send the current region to the inferior Lisp, and switch to its buffer." + (interactive "r") + (lisp-eval-region start end t)) + +(defun lisp-eval-defun-and-go () + "Send the current defun to the inferior Lisp, and switch to its buffer." + (interactive) + (lisp-eval-defun t)) + +(defun lisp-compile-region-and-go (start end) + "Compile the current region in the inferior Lisp, and switch to its buffer." + (interactive "r") + (lisp-compile-region start end t)) + +(defun lisp-compile-defun-and-go () + "Compile the current defun in the inferior Lisp, and switch to its buffer." + (interactive) + (lisp-compile-defun t)) + +;;; A version of the form in H. Shevis' soar-mode.el package. Less robust. +;;; (defun lisp-compile-sexp (start end) +;;; "Compile the s-expression bounded by START and END in the inferior lisp. +;;; If the sexp isn't a DEFUN form, it is evaluated instead." +;;; (cond ((looking-at "(defun\\s +") +;;; (goto-char (match-end 0)) +;;; (let ((name-start (point))) +;;; (forward-sexp 1) +;;; (process-send-string "inferior-lisp" +;;; (format "(compile '%s #'(lambda " +;;; (buffer-substring name-start +;;; (point))))) +;;; (let ((body-start (point))) +;;; (goto-char start) (forward-sexp 1) ; Can't use end-of-defun. +;;; (process-send-region "inferior-lisp" +;;; (buffer-substring body-start (point)))) +;;; (process-send-string "inferior-lisp" ")\n")) +;;; (t (lisp-eval-region start end))))) +;;; +;;; (defun lisp-compile-region (start end) +;;; "Each s-expression in the current region is compiled (if a DEFUN) +;;; or evaluated (if not) in the inferior lisp." +;;; (interactive "r") +;;; (save-excursion +;;; (goto-char start) (end-of-defun) (beginning-of-defun) ; error check +;;; (if (< (point) start) (error "region begins in middle of defun")) +;;; (goto-char start) +;;; (let ((s start)) +;;; (end-of-defun) +;;; (while (<= (point) end) ; Zip through +;;; (lisp-compile-sexp s (point)) ; compiling up defun-sized chunks. +;;; (setq s (point)) +;;; (end-of-defun)) +;;; (if (< s end) (lisp-compile-sexp s end))))) +;;; +;;; End of HS-style code + + +(defvar lisp-prev-l/c-dir/file nil + "Record last directory and file used in loading or compiling. +This holds a cons cell of the form `(DIRECTORY . FILE)' +describing the last `lisp-load-file' or `lisp-compile-file' command.") + +(defvar lisp-source-modes '(lisp-mode) + "*Used to determine if a buffer contains Lisp source code. +If it's loaded into a buffer that is in one of these major modes, it's +considered a Lisp source file by `lisp-load-file' and `lisp-compile-file'. +Used by these commands to determine defaults.") + +(defun lisp-load-file (file-name) + "Load a Lisp file into the inferior Lisp process." + (interactive (comint-get-source "Load Lisp file: " lisp-prev-l/c-dir/file + lisp-source-modes nil)) ; NIL because LOAD + ; doesn't need an exact name + (comint-check-source file-name) ; Check to see if buffer needs saved. + (setq lisp-prev-l/c-dir/file (cons (file-name-directory file-name) + (file-name-nondirectory file-name))) + (comint-send-string (inferior-lisp-proc) + (format inferior-lisp-load-command file-name)) + (switch-to-lisp t)) + +(defun lisp-compile-file (file-name) + "Compile a Lisp file in the inferior Lisp process." + (interactive (comint-get-source "Compile Lisp file: " lisp-prev-l/c-dir/file + lisp-source-modes nil)) ; NIL = don't need + ; suffix .lisp + (comint-check-source file-name) ; Check to see if buffer needs saved. + (setq lisp-prev-l/c-dir/file (cons (file-name-directory file-name) + (file-name-nondirectory file-name))) + (comint-send-string (inferior-lisp-proc) (concat "(compile-file \"" + file-name + "\"\)\n")) + (switch-to-lisp t)) + + + +;;; Documentation functions: function doc, var doc, arglist, and +;;; describe symbol. +;;; =========================================================================== + +;;; Command strings +;;; =============== + +(defvar lisp-function-doc-command + "(let ((fn '%s)) + (format t \"Documentation for ~a:~&~a\" + fn (documentation fn 'function)) + (values))\n" + "Command to query inferior Lisp for a function's documentation.") + +(defvar lisp-var-doc-command + "(let ((v '%s)) + (format t \"Documentation for ~a:~&~a\" + v (documentation v 'variable)) + (values))\n" + "Command to query inferior Lisp for a variable's documentation.") + +(defvar lisp-arglist-command + "(let ((fn '%s)) + (format t \"Arglist for ~a: ~a\" fn (arglist fn)) + (values))\n" + "Command to query inferior Lisp for a function's arglist.") + +(defvar lisp-describe-sym-command + "(describe '%s)\n" + "Command to query inferior Lisp for a variable's documentation.") + + +;;; Ancillary functions +;;; =================== + +;;; Reads a string from the user. +(defun lisp-symprompt (prompt default) + (list (let* ((prompt (if default + (format "%s (default %s): " prompt default) + (concat prompt ": "))) + (ans (read-string prompt))) + (if (zerop (length ans)) default ans)))) + + +;;; Adapted from function-called-at-point in help.el. +(defun lisp-fn-called-at-pt () + "Returns the name of the function called in the current call. +The value is nil if it can't find one." + (condition-case nil + (save-excursion + (save-restriction + (narrow-to-region (max (point-min) (- (point) 1000)) (point-max)) + (backward-up-list 1) + (forward-char 1) + (let ((obj (read (current-buffer)))) + (and (symbolp obj) obj)))) + (error nil))) + + +;;; Adapted from variable-at-point in help.el. +(defun lisp-var-at-pt () + (condition-case () + (save-excursion + (forward-sexp -1) + (skip-chars-forward "'") + (let ((obj (read (current-buffer)))) + (and (symbolp obj) obj))) + (error nil))) + + +;;; Documentation functions: fn and var doc, arglist, and symbol describe. +;;; ====================================================================== + +(defun lisp-show-function-documentation (fn) + "Send a command to the inferior Lisp to give documentation for function FN. +See variable `lisp-function-doc-command'." + (interactive (lisp-symprompt "Function doc" (lisp-fn-called-at-pt))) + (comint-proc-query (inferior-lisp-proc) + (format lisp-function-doc-command fn))) + +(defun lisp-show-variable-documentation (var) + "Send a command to the inferior Lisp to give documentation for function FN. +See variable `lisp-var-doc-command'." + (interactive (lisp-symprompt "Variable doc" (lisp-var-at-pt))) + (comint-proc-query (inferior-lisp-proc) (format lisp-var-doc-command var))) + +(defun lisp-show-arglist (fn) + "Send a query to the inferior Lisp for the arglist for function FN. +See variable `lisp-arglist-command'." + (interactive (lisp-symprompt "Arglist" (lisp-fn-called-at-pt))) + (comint-proc-query (inferior-lisp-proc) (format lisp-arglist-command fn))) + +(defun lisp-describe-sym (sym) + "Send a command to the inferior Lisp to describe symbol SYM. +See variable `lisp-describe-sym-command'." + (interactive (lisp-symprompt "Describe" (lisp-var-at-pt))) + (comint-proc-query (inferior-lisp-proc) + (format lisp-describe-sym-command sym))) + + +;; "Returns the current inferior Lisp process. +;; See variable `inferior-lisp-buffer'." +(defun inferior-lisp-proc () + (let ((proc (get-buffer-process (if (eq major-mode 'inferior-lisp-mode) + (current-buffer) + inferior-lisp-buffer)))) + (or proc + (error "No Lisp subprocess; see variable `inferior-lisp-buffer'")))) + + +;;; Do the user's customization... +;;;=============================== +(defvar inferior-lisp-load-hook nil + "This hook is run when the library `inf-lisp' is loaded. +This is a good place to put keybindings.") + +(run-hooks 'inferior-lisp-load-hook) + +;;; CHANGE LOG +;;; =========================================================================== +;;; 7/21/92 Jim Blandy +;;; - Changed all uses of the cmulisp name or prefix to inferior-lisp; +;;; this is now the official inferior lisp package. Use the global +;;; ChangeLog from now on. +;;; 5/24/90 Olin +;;; - Split cmulisp and cmushell modes into separate files. +;;; Not only is this a good idea, it's apparently the way it'll be rel 19. +;;; - Upgraded process sends to use comint-send-string instead of +;;; process-send-string. +;;; - Explicit references to process "cmulisp" have been replaced with +;;; (cmulisp-proc). This allows better handling of multiple process bufs. +;;; - Added process query and var/function/symbol documentation +;;; commands. Based on code written by Douglas Roberts. +;;; - Added lisp-eval-last-sexp, bound to C-x C-e. +;;; +;;; 9/20/90 Olin +;;; Added a save-restriction to lisp-fn-called-at-pt. This bug and fix +;;; reported by Lennart Staflin. +;;; +;;; 3/12/90 Olin +;;; - lisp-load-file and lisp-compile-file no longer switch-to-lisp. +;;; Tale suggested this. +;;; - Reversed this decision 7/15/91. You need the visual feedback. +;;; +;;; 7/25/91 Olin +;;; Changed all keybindings of the form C-c <letter>. These are +;;; supposed to be reserved for the user to bind. This affected +;;; mainly the compile/eval-defun/region[-and-go] commands. +;;; This was painful, but necessary to adhere to the gnumacs standard. +;;; For some backwards compatibility, see the +;;; cmulisp-install-letter-bindings +;;; function. +;;; +;;; 8/2/91 Olin +;;; - The lisp-compile/eval-defun/region commands now take a prefix arg, +;;; which means switch-to-lisp after sending the text to the Lisp process. +;;; This obsoletes all the -and-go commands. The -and-go commands are +;;; kept around for historical reasons, and because the user can bind +;;; them to key sequences shorter than C-u C-c C-<letter>. +;;; - If M-x cmulisp is invoked with a prefix arg, it allows you to +;;; edit the command line. + +(provide 'inf-lisp) + +;;; inf-lisp.el ends here diff --git a/jka-compr.el b/jka-compr.el new file mode 100644 --- /dev/null +++ b/jka-compr.el @@ -0,0 +1,874 @@ +;;; jka-compr.el --- reading/writing/loading compressed files + +;; Copyright (C) 1993, 1994 Free Software Foundation, Inc. + +;; Author: jka@ece.cmu.edu (Jay K. Adams) +;; Keywords: data + +;; This file is part of XEmacs. + +;; XEmacs 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 2, or (at your option) +;; any later version. + +;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the Free +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. + +;; Synched up with: FSF 19.34 + +;;; Commentary: + +;; This package implements low-level support for reading, writing, +;; and loading compressed files. It hooks into the low-level file +;; I/O functions (including write-region and insert-file-contents) so +;; that they automatically compress or uncompress a file if the file +;; appears to need it (based on the extension of the file name). +;; Packages like Rmail, VM, GNUS, and Info should be able to work +;; with compressed files without modification. + + +;; INSTRUCTIONS: +;; +;; To use jka-compr, simply load this package, and edit as usual. +;; Its operation should be transparent to the user (except for +;; messages appearing when a file is being compressed or +;; uncompressed). +;; +;; The variable, jka-compr-compression-info-list can be used to +;; customize jka-compr to work with other compression programs. +;; The default value of this variable allows jka-compr to work with +;; Unix compress and gzip. +;; +;; If you are concerned about the stderr output of gzip and other +;; compression/decompression programs showing up in your buffers, you +;; should set the discard-error flag in the compression-info-list. +;; This will cause the stderr of all programs to be discarded. +;; However, it also causes emacs to call compression/uncompression +;; programs through a shell (which is specified by jka-compr-shell). +;; This may be a drag if, on your system, starting up a shell is +;; slow. +;; +;; If you don't want messages about compressing and decompressing +;; to show up in the echo area, you can set the compress-name and +;; decompress-name fields of the jka-compr-compression-info-list to +;; nil. + + +;; APPLICATION NOTES: +;; +;; crypt++ +;; jka-compr can coexist with crypt++ if you take all the decompression +;; entries out of the crypt-encoding-list. Clearly problems will arise if +;; you have two programs trying to compress/decompress files. jka-compr +;; will not "work with" crypt++ in the following sense: you won't be able to +;; decode encrypted compressed files--that is, files that have been +;; compressed then encrypted (in that order). Theoretically, crypt++ and +;; jka-compr could properly handle a file that has been encrypted then +;; compressed, but there is little point in trying to compress an encrypted +;; file. +;; + + +;; ACKNOWLEDGMENTS +;; +;; jka-compr is a V19 adaptation of jka-compr for V18 of Emacs. Many people +;; have made helpful suggestions, reported bugs, and even fixed bugs in +;; jka-compr. I recall the following people as being particularly helpful. +;; +;; Jean-loup Gailly +;; David Hughes +;; Richard Pieri +;; Daniel Quinlan +;; Chris P. Ross +;; Rick Sladkey +;; +;; Andy Norman's ange-ftp was the inspiration for the original jka-compr for +;; Version 18 of Emacs. +;; +;; After I had made progress on the original jka-compr for V18, I learned of a +;; package written by Kazushi Jam Marukawa, called jam-zcat, that did exactly +;; what I was trying to do. I looked over the jam-zcat source code and +;; probably got some ideas from it. +;; + +;;; Code: + +(defgroup compression nil + "Data compression utilities" + :group 'data) + +(defgroup jka-compr nil + "jka-compr customization" + :group 'compression) + + +(defcustom jka-compr-shell "sh" + "*Shell to be used for calling compression programs. +The value of this variable only matters if you want to discard the +stderr of a compression/decompression program (see the documentation +for `jka-compr-compression-info-list')." + :type 'string + :group 'jka-compr) + +(defvar jka-compr-use-shell t) + + +;;; I have this defined so that .Z files are assumed to be in unix +;;; compress format; and .gz files, in gzip format. +(defcustom jka-compr-compression-info-list + ;;[regexp + ;; compr-message compr-prog compr-args + ;; uncomp-message uncomp-prog uncomp-args + ;; can-append auto-mode-flag] + '(["\\.Z\\(~\\|\\.~[0-9]+~\\)?\\'" + "compressing" "compress" ("-c") + "uncompressing" "uncompress" ("-c") + nil t] + ["\\.tgz\\'" + "zipping" "gzip" ("-c" "-q") + "unzipping" "gzip" ("-c" "-q" "-d") + t nil] + ["\\.gz\\(~\\|\\.~[0-9]+~\\)?\\'" + "zipping" "gzip" ("-c" "-q") + "unzipping" "gzip" ("-c" "-q" "-d") + t t] + ["\\.bz2\\(~\\|\\.~[0-9]+~\\)?\\'" + "bzipping" "bzip2" ("-f") + "unbzipping" "bzip2" ("-d") + nil t]) + + "List of vectors that describe available compression techniques. +Each element, which describes a compression technique, is a vector of +the form [REGEXP COMPRESS-MSG COMPRESS-PROGRAM COMPRESS-ARGS +UNCOMPRESS-MSG UNCOMPRESS-PROGRAM UNCOMPRESS-ARGS +APPEND-FLAG EXTENSION], where: + + regexp is a regexp that matches filenames that are + compressed with this format + + compress-msg is the message to issue to the user when doing this + type of compression (nil means no message) + + compress-program is a program that performs this compression + + compress-args is a list of args to pass to the compress program + + uncompress-msg is the message to issue to the user when doing this + type of uncompression (nil means no message) + + uncompress-program is a program that performs this compression + + uncompress-args is a list of args to pass to the uncompress program + + append-flag is non-nil if files compressed with this technique can + be appended to without decompressing them first. + + auto-mode flag non-nil means strip the regexp from file names + before attempting to set the mode. + +Because of the way `call-process' is defined, discarding the stderr output of +a program adds the overhead of starting a shell each time the program is +invoked." + :type '(repeat (vector :tag "Compression Technique" + regexp + (choice :tag "Compress Message" + (string :format "%v") + (const :tag "No Message" nil)) + (string :tag "Compress Program") + (repeat :tag "Compress Arguments" string) + (choice :tag "Uncompress Message" + (string :format "%v") + (const :tag "No Message" nil)) + (string :tag "Uncompress Program") + (repeat :tag "Uncompress Arguments" string) + (boolean :tag "Append") + (boolean :tag "Auto Mode"))) + :group 'jka-compr) + +(defvar jka-compr-mode-alist-additions + (list (cons "\\.tgz\\'" 'tar-mode)) + "A list of pairs to add to auto-mode-alist when jka-compr is installed.") + +(defvar jka-compr-file-name-handler-entry + nil + "The entry in `file-name-handler-alist' used by the jka-compr I/O functions.") + +;;; Functions for accessing the return value of jka-compr-get-compression-info +(defun jka-compr-info-regexp (info) (aref info 0)) +(defun jka-compr-info-compress-message (info) (aref info 1)) +(defun jka-compr-info-compress-program (info) (aref info 2)) +(defun jka-compr-info-compress-args (info) (aref info 3)) +(defun jka-compr-info-uncompress-message (info) (aref info 4)) +(defun jka-compr-info-uncompress-program (info) (aref info 5)) +(defun jka-compr-info-uncompress-args (info) (aref info 6)) +(defun jka-compr-info-can-append (info) (aref info 7)) +(defun jka-compr-info-strip-extension (info) (aref info 8)) + + +(defun jka-compr-get-compression-info (filename) + "Return information about the compression scheme of FILENAME. +The determination as to which compression scheme, if any, to use is +based on the filename itself and `jka-compr-compression-info-list'." + (catch 'compression-info + (let ((case-fold-search nil)) + (mapcar + (function (lambda (x) + (and (string-match (jka-compr-info-regexp x) filename) + (throw 'compression-info x)))) + jka-compr-compression-info-list) + nil))) + + +;; XEmacs change +(define-error 'compression-error "Compression error" 'file-error) + +(defvar jka-compr-acceptable-retval-list '(0 2 141)) + + +(defun jka-compr-error (prog args infile message &optional errfile) + (let ((errbuf (get-buffer-create " *jka-compr-error*")) + (curbuf (current-buffer))) + (set-buffer errbuf) + (widen) (erase-buffer) + (insert (format "Error while executing \"%s %s < %s\"\n\n" + prog + (mapconcat 'identity args " ") + infile)) + + (and errfile + (insert-file-contents errfile)) + + (set-buffer curbuf) + (display-buffer errbuf)) + (signal 'compression-error (list "Opening input file" + (format "error %s" message) + infile))) + + +(defvar jka-compr-dd-program + "/bin/dd") + + +(defvar jka-compr-dd-blocksize 256) + + +(defun jka-compr-partial-uncompress (prog message args infile beg len) + "Call program PROG with ARGS args taking input from INFILE. +Fourth and fifth args, BEG and LEN, specify which part of the output +to keep: LEN chars starting BEG chars from the beginning." + (let* ((skip (/ beg jka-compr-dd-blocksize)) + (prefix (- beg (* skip jka-compr-dd-blocksize))) + (count (and len (1+ (/ (+ len prefix) jka-compr-dd-blocksize)))) + (start (point)) + (err-file (jka-compr-make-temp-name)) + (run-string (format "%s %s 2> %s | %s bs=%d skip=%d %s 2> /dev/null" + prog + (mapconcat 'identity args " ") + err-file + jka-compr-dd-program + jka-compr-dd-blocksize + skip + ;; dd seems to be unreliable about + ;; providing the last block. So, always + ;; read one more than you think you need. + (if count (concat "count=" (1+ count)) "")))) + + (unwind-protect + (or (memq (call-process jka-compr-shell + infile t nil "-c" + run-string) + jka-compr-acceptable-retval-list) + + (jka-compr-error prog args infile message err-file)) + + (jka-compr-delete-temp-file err-file)) + + ;; Delete the stuff after what we want, if there is any. + (and + len + (< (+ start prefix len) (point)) + (delete-region (+ start prefix len) (point))) + + ;; Delete the stuff before what we want. + (delete-region start (+ start prefix)))) + + +(defun jka-compr-call-process (prog message infile output temp args) + (if jka-compr-use-shell + + (let ((err-file (jka-compr-make-temp-name))) + + (unwind-protect + + (or (memq + (call-process jka-compr-shell infile + (if (stringp output) nil output) + nil + "-c" + (format "%s %s 2> %s %s" + prog + (mapconcat 'identity args " ") + err-file + (if (stringp output) + (concat "> " output) + ""))) + jka-compr-acceptable-retval-list) + + (jka-compr-error prog args infile message err-file)) + + (jka-compr-delete-temp-file err-file))) + + (or (zerop + (apply 'call-process + prog + infile + (if (stringp output) temp output) + nil + args)) + (jka-compr-error prog args infile message)) + + (and (stringp output) + (let ((cbuf (current-buffer))) + (set-buffer temp) + (write-region (point-min) (point-max) output) + (erase-buffer) + (set-buffer cbuf))))) + + +;;; Support for temp files. Much of this was inspired if not lifted +;;; from ange-ftp. + +(defcustom jka-compr-temp-name-template + "/tmp/jka-com" + "Prefix added to all temp files created by jka-compr. +There should be no more than seven characters after the final `/'" + :type 'string + :group 'jka-compr) + +(defvar jka-compr-temp-name-table (make-vector 31 nil)) + +(defun jka-compr-make-temp-name (&optional local-copy) + "This routine will return the name of a new file." + (let* ((lastchar ?a) + (prevchar ?a) + (template (concat jka-compr-temp-name-template "aa")) + (lastpos (1- (length template))) + (not-done t) + file + entry) + + (while not-done + (aset template lastpos lastchar) + (setq file (concat (make-temp-name template) "#")) + (setq entry (intern file jka-compr-temp-name-table)) + (if (or (get entry 'active) + (file-exists-p file)) + + (progn + (setq lastchar (1+ lastchar)) + (if (> lastchar ?z) + (progn + (setq prevchar (1+ prevchar)) + (setq lastchar ?a) + (if (> prevchar ?z) + (error "Can't allocate temp file.") + (aset template (1- lastpos) prevchar))))) + + (put entry 'active (not local-copy)) + (setq not-done nil))) + + file)) + + +(defun jka-compr-delete-temp-file (temp) + + (put (intern temp jka-compr-temp-name-table) + 'active nil) + + (condition-case () + (delete-file temp) + (error nil))) + +;;; 20.0-b92 change +;;; Now receives both `lockname' and `codesys' from Fwrite_region_internal +;;; what makes it compatible with write-region +(defun jka-compr-write-region (start end file &optional append visit lockname coding-system) + (let* ((filename (expand-file-name file)) + (visit-file (if (stringp visit) (expand-file-name visit) filename)) + (info (jka-compr-get-compression-info visit-file))) + + (if info + + (let ((can-append (jka-compr-info-can-append info)) + (compress-program (jka-compr-info-compress-program info)) + (compress-message (jka-compr-info-compress-message info)) + (uncompress-program (jka-compr-info-uncompress-program info)) + (uncompress-message (jka-compr-info-uncompress-message info)) + (compress-args (jka-compr-info-compress-args info)) + (uncompress-args (jka-compr-info-uncompress-args info)) + (base-name (file-name-nondirectory visit-file)) + temp-file cbuf temp-buffer) + + (setq cbuf (current-buffer) + temp-buffer (get-buffer-create " *jka-compr-wr-temp*")) + (set-buffer temp-buffer) + (widen) (erase-buffer) + (set-buffer cbuf) + + (if (and append + (not can-append) + (file-exists-p filename)) + + (let* ((local-copy (file-local-copy filename)) + (local-file (or local-copy filename))) + + (setq temp-file local-file)) + + (setq temp-file (jka-compr-make-temp-name))) + + (and + compress-message + (message "%s %s..." compress-message base-name)) + + (jka-compr-run-real-handler 'write-region + (list start end temp-file t 'dont lockname coding-system)) + + (jka-compr-call-process compress-program + (concat compress-message + " " base-name) + temp-file + temp-buffer + nil + compress-args) + + (set-buffer temp-buffer) + (jka-compr-run-real-handler 'write-region + (list (point-min) (point-max) + filename + (and append can-append) + 'dont lockname 'binary)) + (erase-buffer) + (set-buffer cbuf) + + (jka-compr-delete-temp-file temp-file) + + (and + compress-message + (message "%s %s...done" compress-message base-name)) + + (cond + ((eq visit t) + (setq buffer-file-name filename) + (set-visited-file-modtime)) + ((stringp visit) + (setq buffer-file-name visit) + (let ((buffer-file-name filename)) + (set-visited-file-modtime)))) + + (and (or (eq visit t) + (eq visit nil) + (stringp visit)) + (message "Wrote %s" visit-file)) + + nil) + + (jka-compr-run-real-handler 'write-region + (list start end filename append visit lockname coding-system))))) + + +(defun jka-compr-insert-file-contents (file &optional visit beg end replace) + (barf-if-buffer-read-only) + + (and (or beg end) + visit + (error "Attempt to visit less than an entire file")) + + (let* ((filename (expand-file-name file)) + (info (jka-compr-get-compression-info filename))) + + (if info + + (let ((uncompress-message (jka-compr-info-uncompress-message info)) + (uncompress-program (jka-compr-info-uncompress-program info)) + (uncompress-args (jka-compr-info-uncompress-args info)) + (base-name (file-name-nondirectory filename)) + (notfound nil) + (local-copy + (jka-compr-run-real-handler 'file-local-copy (list filename))) + local-file + size start) + + (setq local-file (or local-copy filename)) + + (and + visit + (setq buffer-file-name filename)) + + (unwind-protect ; to make sure local-copy gets deleted + + (progn + + (and + uncompress-message + (message "%s %s..." uncompress-message base-name)) + + (condition-case error-code + + (progn + (if replace + (goto-char (point-min))) + (setq start (point)) + (if (or beg end) + (jka-compr-partial-uncompress uncompress-program + (concat uncompress-message + " " base-name) + uncompress-args + local-file + (or beg 0) + (if (and beg end) + (- end beg) + end)) + ;; If visiting, bind off buffer-file-name so that + ;; file-locking will not ask whether we should + ;; really edit the buffer. + (let ((buffer-file-name + (if visit nil buffer-file-name))) + (jka-compr-call-process uncompress-program + (concat uncompress-message + " " base-name) + local-file + t + nil + uncompress-args))) + (setq size (- (point) start)) + (if replace + (let* ((del-beg (point)) + (del-end (+ del-beg size))) + (delete-region del-beg + (min del-end (point-max))))) + (goto-char start)) + (error + (if (and (eq (car error-code) 'file-error) + (eq (nth 3 error-code) local-file)) + (if visit + (setq notfound error-code) + (signal 'file-error + (cons "Opening input file" + (nthcdr 2 error-code)))) + (signal (car error-code) (cdr error-code)))))) + + (and + local-copy + (file-exists-p local-copy) + (delete-file local-copy))) + + (and + visit + (progn + (unlock-buffer) + (setq buffer-file-name filename) + (set-visited-file-modtime))) + + (and + uncompress-message + (message "%s %s...done" uncompress-message base-name)) + + (and + visit + notfound + (signal 'file-error + (cons "Opening input file" (nth 2 notfound)))) + + ;; Run the functions that insert-file-contents would. + (let ((p after-insert-file-functions) + (insval size)) + (while p + (setq insval (funcall (car p) size)) + (if insval + (progn + (or (integerp insval) + (signal 'wrong-type-argument + (list 'integerp insval))) + (setq size insval))) + (setq p (cdr p)))) + + (list filename size)) + + (jka-compr-run-real-handler 'insert-file-contents + (list file visit beg end replace))))) + + +(defun jka-compr-file-local-copy (file) + (let* ((filename (expand-file-name file)) + (info (jka-compr-get-compression-info filename))) + + (if info + + (let ((uncompress-message (jka-compr-info-uncompress-message info)) + (uncompress-program (jka-compr-info-uncompress-program info)) + (uncompress-args (jka-compr-info-uncompress-args info)) + (base-name (file-name-nondirectory filename)) + (local-copy + (jka-compr-run-real-handler 'file-local-copy (list filename))) + (temp-file (jka-compr-make-temp-name t)) + (temp-buffer (get-buffer-create " *jka-compr-flc-temp*")) + (notfound nil) + (cbuf (current-buffer)) + local-file) + + (setq local-file (or local-copy filename)) + + (unwind-protect + + (progn + + (and + uncompress-message + (message "%s %s..." uncompress-message base-name)) + + (set-buffer temp-buffer) + + (jka-compr-call-process uncompress-program + (concat uncompress-message + " " base-name) + local-file + t + nil + uncompress-args) + + (and + uncompress-message + (message "%s %s...done" uncompress-message base-name)) + + (write-region + (point-min) (point-max) temp-file nil 'dont)) + + (and + local-copy + (file-exists-p local-copy) + (delete-file local-copy)) + + (set-buffer cbuf) + (kill-buffer temp-buffer)) + + temp-file) + + (jka-compr-run-real-handler 'file-local-copy (list filename))))) + + +;;; Support for loading compressed files. +;;; XEmacs: autoload this function +;;;###autoload +(defun jka-compr-load (file &optional noerror nomessage nosuffix) + "Documented as original." + + (let* ((local-copy (jka-compr-file-local-copy file)) + (load-file (or local-copy file))) + + (unwind-protect + + (let (inhibit-file-name-operation + inhibit-file-name-handlers) + (or nomessage + (message "Loading %s..." file)) + + (let ((load-force-doc-strings t)) + (load load-file noerror t t)) + + (or nomessage + (message "Loading %s...done." file))) + + (jka-compr-delete-temp-file local-copy)) + + t)) + +(defun jka-compr-byte-compiler-base-file-name (file) + (let ((info (jka-compr-get-compression-info file))) + (if (and info (jka-compr-info-strip-extension info)) + (save-match-data + (substring file 0 (string-match (jka-compr-info-regexp info) file))) + file))) + +(put 'write-region 'jka-compr 'jka-compr-write-region) +(put 'insert-file-contents 'jka-compr 'jka-compr-insert-file-contents) +(put 'file-local-copy 'jka-compr 'jka-compr-file-local-copy) +(put 'load 'jka-compr 'jka-compr-load) +(put 'byte-compiler-base-file-name 'jka-compr + 'jka-compr-byte-compiler-base-file-name) + +(defun jka-compr-handler (operation &rest args) + (save-match-data + (let ((jka-op (get operation 'jka-compr))) + (if jka-op + (apply jka-op args) + (jka-compr-run-real-handler operation args))))) + +;; If we are given an operation that we don't handle, +;; call the Emacs primitive for that operation, +;; and manipulate the inhibit variables +;; to prevent the primitive from calling our handler again. +(defun jka-compr-run-real-handler (operation args) + (let ((inhibit-file-name-handlers + (cons 'jka-compr-handler + (and (eq inhibit-file-name-operation operation) + inhibit-file-name-handlers))) + (inhibit-file-name-operation operation)) + (apply operation args))) + +;; XEmacs change: I don't have a clue what this is trying do. -sb +;; ;;;###autoload(defun auto-compression-mode (&optional arg) +;; ;;;###autoload "\ +;; ;;;###autoloadToggle automatic file compression and uncompression. +;; ;;;###autoloadWith prefix argument ARG, turn auto compression on if positive, else off. +;; ;;;###autoloadReturns the new status of auto compression (non-nil means on)." +;; ;;;###autoload (interactive "P") +;; ;;;###autoload (if (not (fboundp 'jka-compr-installed-p)) +;; ;;;###autoload (progn +;; ;;;###autoload (require 'jka-compr) +;; ;;;###autoload ;; That turned the mode on, so make it initially off. +;; ;;;###autoload (toggle-auto-compression))) +;; ;;;###autoload (toggle-auto-compression arg t)) + +;; XEmacs: autoload this function +;;;###autoload +(defun toggle-auto-compression (&optional arg message) + "Toggle automatic file compression and uncompression. +With prefix argument ARG, turn auto compression on if positive, else off. +Returns the new status of auto compression (non-nil means on). +If the argument MESSAGE is non-nil, it means to print a message +saying whether the mode is now on or off." + (interactive "P\np") + (let* ((installed (jka-compr-installed-p)) + (flag (if (null arg) + (not installed) + (or (eq arg t) (listp arg) (and (integerp arg) (> arg 0)))))) + + (cond + ((and flag installed) t) ; already installed + + ((and (not flag) (not installed)) nil) ; already not installed + + (flag + (jka-compr-install)) + + (t + (jka-compr-uninstall))) + + + (and message + (if flag + (message "Automatic file (de)compression is now ON.") + (message "Automatic file (de)compression is now OFF."))) + + flag)) + + +(defun jka-compr-build-file-regexp () + (concat + "\\(" + (mapconcat + 'jka-compr-info-regexp + jka-compr-compression-info-list + "\\)\\|\\(") + "\\)")) + +;;;###autoload +(defun jka-compr-install () + "Install jka-compr. +This adds entries to `file-name-handler-alist' and `auto-mode-alist' +and `inhibit-first-line-modes-suffixes'." + + (setq jka-compr-file-name-handler-entry + (cons (jka-compr-build-file-regexp) 'jka-compr-handler)) + + (setq file-name-handler-alist (cons jka-compr-file-name-handler-entry + file-name-handler-alist)) + + (mapcar + (function (lambda (x) + (and (jka-compr-info-strip-extension x) + ;; Make entries in auto-mode-alist so that modes + ;; are chosen right according to the file names + ;; sans `.gz'. + (setq auto-mode-alist + (cons (list (jka-compr-info-regexp x) + nil 'jka-compr) + auto-mode-alist)) + ;; Also add these regexps to + ;; inhibit-first-line-modes-suffixes, so that a + ;; -*- line in the first file of a compressed tar + ;; file doesn't override tar-mode. + ;; XEmacs: the (now)superfluous conditional doesn't hurt + (and (boundp 'inhibit-first-line-modes-suffixes) + (setq inhibit-first-line-modes-suffixes + (cons (jka-compr-info-regexp x) + inhibit-first-line-modes-suffixes)))))) + jka-compr-compression-info-list) + (setq auto-mode-alist + (append auto-mode-alist jka-compr-mode-alist-additions))) + + +(defun jka-compr-uninstall () + "Uninstall jka-compr. +This removes the entries in `file-name-handler-alist' and `auto-mode-alist' +and `inhibit-first-line-modes-suffixes' that were added +by `jka-compr-installed'." + ;; Delete from inhibit-first-line-modes-suffixes + ;; what jka-compr-install added. + (mapcar + (function (lambda (x) + (and (jka-compr-info-strip-extension x) + ;; XEmacs: the (now)superfluous conditional doesn't hurt + (and (boundp 'inhibit-first-line-modes-suffixes) + (setq inhibit-first-line-modes-suffixes + (delete (jka-compr-info-regexp x) + inhibit-first-line-modes-suffixes))))) + ) + jka-compr-compression-info-list) + + (let* ((fnha (cons nil file-name-handler-alist)) + (last fnha)) + + (while (cdr last) + (if (eq (cdr (car (cdr last))) 'jka-compr-handler) + (setcdr last (cdr (cdr last))) + (setq last (cdr last)))) + + (setq file-name-handler-alist (cdr fnha))) + + (let* ((ama (cons nil auto-mode-alist)) + (last ama) + entry) + + (while (cdr last) + (setq entry (car (cdr last))) + (if (or (member entry jka-compr-mode-alist-additions) + (and (consp (cdr entry)) + (eq (nth 2 entry) 'jka-compr))) + (setcdr last (cdr (cdr last))) + (setq last (cdr last)))) + + (setq auto-mode-alist (cdr ama)))) + + +(defun jka-compr-installed-p () + "Return non-nil if jka-compr is installed. +The return value is the entry in `file-name-handler-alist' for jka-compr." + (rassq 'jka-compr-handler file-name-handler-alist)) + + +;; No no no no! +;(jka-compr-install) + + +(provide 'jka-compr) + +;; jka-compr.el ends here. diff --git a/kermit.el b/kermit.el new file mode 100644 --- /dev/null +++ b/kermit.el @@ -0,0 +1,151 @@ +;;; kermit.el --- additions to shell mode for use with kermit, etc. + +;; Copyright (C) 1988 Free Software Foundation, Inc. + +;; Author: Jeff Norden <jeff@colgate.csnet> +;; Created: 15 Feb 1988 +;; Keywords: comm + +;; This file is part of XEmacs. + +;; XEmacs 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 2, or (at your option) +;; any later version. + +;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Synched up with: FSF 19.30. + +;;; Commentary: + +;; I'm not sure, but I think somebody asked about running kermit under shell +;; mode a while ago. Anyway, here is some code that I find useful. The result +;; is that I can log onto machines with primitive operating systems (VMS and +;; ATT system V :-), and still have the features of shell-mode available for +;; command history, etc. It's also handy to be able to run a file transfer in +;; an emacs window. The transfer is in the "background", but you can also +;; monitor or stop it easily. + +;; The ^\ key is bound to a function for sending escape sequences to kermit, +;; and ^C^Q can be used to send any control characters needed thru to the +;; system you connect to. A more serious problem is that some brain-dead +;; systems will not recognize a ^J as an end-of-line character. So LFD is +;; bound to a new function which acts just like CR usually does in shell-mode, +;; but a ^M is sent as an end-of-line. Functions are also provided to swap the +;; bindings of CR and LFD. I've also included a filter which will clean out +;; any ^M's or ^@'s that get typed at you, but I don't really recommend it. +;; There doesn't seem to be an acceptably fast way to do this via emacs-lisp. +;; Invoking kermit by the command " kermit | tr -d '\015' " seems to work +;; better (on my system anyway). + +;; Here's how I've been using this setup. We have several machines connected +;; thru a fairly stupid terminal switch. If I want to connect to unix system, +;; then I use the LFD key to talk to the switch, and ignore any ^M's in the +;; buffer, and do a " stty -echo nl " after I log in. Then the only real +;; difference from being in local shell-mode is that you need to type +;; ^C^Q^C to send an interrupt, and ^C^Q^Z for a stop signal, etc. (since ^C^C +;; just generates a local stop signal, which kermit ignores). +;; To connect to a VMS system, I use a shell script to invoke kermit thru the +;; tr filter, do "M-X kermit-send-cr", and then tell VMS that I'm on a +;; half-duplex terminal. + +;; Some caveats: +;; 1) Kermit under shell mode is a real pain if you don't have pty's. I +;; recently discovered this on our 3b2/400. When kermit can't find a tty, it +;; assumes it is supposed to be in remote mode. So the simple command "kermit" +;; won't work in shell mode on such a system. You can get around this by using +;; the -c (connect) command line option, which means you also have to specify a +;; line and baud on the command line, as in "kermit -l /dev/tty53 -b 9600 -c". +;; However, this will cause kermit to exit when the connection is closed. So +;; in order to do a file transfer, you have to think ahead and add -r +;; (receive) to the command line. This means that you can't use the server +;; feature. The only fix I can see is to muck around with the source code for +;; kermit, although this probably wouldn't be too hard. What is needed is an +;; option to force kermit to be local, to use stdin and stdout for interactive +;; speech, and to forget about cbreak mode. + +;; Please let me know if any bugs turn up. +;; Feb 1988, Jeff Norden - jeff@colgate.csnet + +;;; Code: + +(require 'shell) + +(defvar kermit-esc-char "\C-\\" "*Kermit's escape char") + +(defun kermit-esc () + "For sending escape sequences to a kermit running in shell mode." + (interactive) + (process-send-string + (get-buffer-process (current-buffer)) + (concat kermit-esc-char (char-to-string (read-char))))) + +(defun kermit-send-char () + "Send an arbitrary character to a program in shell mode." + (interactive) + (process-send-string + (get-buffer-process (current-buffer)) + (char-to-string (read-char)))) + +(define-key shell-mode-map "\C-\\" 'kermit-esc) +(define-key shell-mode-map "\C-c\C-q" 'kermit-send-char) +;; extra bindings for folks suffering form ^S/^Q braindamage: +(define-key shell-mode-map "\C-c\\" 'kermit-esc) + +(defun kermit-send-input-cr () + "Like \\[comint-send-input] but end the line with carriage-return." + (interactive) + (comint-send-input) + (comint-send-string (get-buffer-process (current-buffer)) "\r")) + +;; This is backwards of what makes sense, but ... +(define-key shell-mode-map "\n" 'kermit-send-input-cr) + +(defun kermit-default-cr () + "Make RETURN end the line with carriage-return and LFD end it with a newline. +This is useful for talking to other systems on which carriage-return +is the normal way to end a line." + (interactive) + (define-key shell-mode-map "\r" 'kermit-send-input-cr) + (define-key shell-mode-map "\n" 'comint-send-input)) + +(defun kermit-default-nl () + "Make RETURN end the line with a newline char. This is the default state. +In this state, use LFD to send a line and end it with a carriage-return." + (interactive) + (define-key shell-mode-map "\n" 'kermit-send-input-cr) + (define-key shell-mode-map "\r" 'comint-send-input)) + +(defun kermit-clean-filter (proc str) + "Strip ^M and ^@ characters from process output." + (save-excursion + (let ((beg (process-mark proc))) + (set-buffer (process-buffer proc)) + (goto-char beg) + (insert-before-markers str) + (while (re-search-backward "[\r\C-a]+" beg t) + (replace-match ""))))) + +(defun kermit-clean-on () + "Delete all null characters and ^M's from the kermit output. +Note that another (perhaps better) way to do this is to use the +command `kermit | tr -d '\\015''." + (interactive) + (set-process-filter (get-buffer-process (current-buffer)) + 'kermit-clean-filter)) + +(defun kermit-clean-off () + "Cancel a previous kermit-clean-shell-on command." + (interactive) + (set-process-filter (get-buffer-process (current-buffer)) nil)) + +;;; kermit.el ends here diff --git a/ledit.el b/ledit.el new file mode 100644 --- /dev/null +++ b/ledit.el @@ -0,0 +1,157 @@ +;;; ledit.el --- Emacs side of ledit interface + +;; Copyright (C) 1985 Free Software Foundation, Inc. + +;; Maintainer: FSF +;; Keyword: languages + +;; This file is part of XEmacs. + +;; XEmacs 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 2, or (at your option) +;; any later version. + +;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the Free +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. + +;;; Synched up with: FSF 19.34. + +;;; Commentary: + +;; This is a major mode for editing Liszt. See etc/LEDIT for details. + +;;; Code: + +;;; To do: +;;; o lisp -> emacs side of things (grind-definition and find-definition) + +(defvar ledit-mode-map nil) + +(defconst ledit-zap-file (concat "/tmp/" (user-login-name) ".l1") + "File name for data sent to Lisp by Ledit.") +(defconst ledit-read-file (concat "/tmp/" (user-login-name) ".l2") + "File name for data sent to Ledit by Lisp.") +(defconst ledit-compile-file + (concat "/tmp/" (user-login-name) ".l4") + "File name for data sent to Lisp compiler by Ledit.") +(defconst ledit-buffer "*LEDIT*" + "Name of buffer in which Ledit accumulates data to send to Lisp.") + +;;;###autoload +(defconst ledit-save-files t "\ +*Non-nil means Ledit should save files before transferring to Lisp.") +;;;###autoload +(defconst ledit-go-to-lisp-string "%?lisp" "\ +*Shell commands to execute to resume Lisp job.") +;;;###autoload +(defconst ledit-go-to-liszt-string "%?liszt" "\ +*Shell commands to execute to resume Lisp compiler job.") + +(defun ledit-save-defun () + "Save the current defun in the ledit buffer" + (interactive) + (save-excursion + (end-of-defun) + (let ((end (point))) + (beginning-of-defun) + (append-to-buffer ledit-buffer (point) end)) + (message "Current defun saved for Lisp"))) + +(defun ledit-save-region (beg end) + "Save the current region in the ledit buffer" + (interactive "r") + (append-to-buffer ledit-buffer beg end) + (message "Region saved for Lisp")) + +(defun ledit-zap-defun-to-lisp () + "Carry the current defun to Lisp." + (interactive) + (ledit-save-defun) + (ledit-go-to-lisp)) + +(defun ledit-zap-defun-to-liszt () + "Carry the current defun to liszt." + (interactive) + (ledit-save-defun) + (ledit-go-to-liszt)) + +(defun ledit-zap-region-to-lisp (beg end) + "Carry the current region to Lisp." + (interactive "r") + (ledit-save-region beg end) + (ledit-go-to-lisp)) + +(defun ledit-go-to-lisp () + "Suspend Emacs and restart a waiting Lisp job." + (interactive) + (if ledit-save-files + (save-some-buffers)) + (if (get-buffer ledit-buffer) + (save-excursion + (set-buffer ledit-buffer) + (goto-char (point-min)) + (write-region (point-min) (point-max) ledit-zap-file) + (erase-buffer))) + (suspend-emacs ledit-go-to-lisp-string) + (load ledit-read-file t t)) + +(defun ledit-go-to-liszt () + "Suspend Emacs and restart a waiting Liszt job." + (interactive) + (if ledit-save-files + (save-some-buffers)) + (if (get-buffer ledit-buffer) + (save-excursion + (set-buffer ledit-buffer) + (goto-char (point-min)) + (insert "(declare (macros t))\n") + (write-region (point-min) (point-max) ledit-compile-file) + (erase-buffer))) + (suspend-emacs ledit-go-to-liszt-string) + (load ledit-read-file t t)) + +(defun ledit-setup () + "Set up key bindings for the Lisp/Emacs interface." + (if (not ledit-mode-map) + (progn (setq ledit-mode-map (nconc (make-sparse-keymap) + shared-lisp-mode-map)))) + (define-key ledit-mode-map "\e\^d" 'ledit-save-defun) + (define-key ledit-mode-map "\e\^r" 'ledit-save-region) + (define-key ledit-mode-map "\^xz" 'ledit-go-to-lisp) + (define-key ledit-mode-map "\e\^c" 'ledit-go-to-liszt)) + +(ledit-setup) + +;;;###autoload +(defun ledit-mode () + "\\<ledit-mode-map>Major mode for editing text and stuffing it to a Lisp job. +Like Lisp mode, plus these special commands: + \\[ledit-save-defun] -- record defun at or after point + for later transmission to Lisp job. + \\[ledit-save-region] -- record region for later transmission to Lisp job. + \\[ledit-go-to-lisp] -- transfer to Lisp job and transmit saved text. + \\[ledit-go-to-liszt] -- transfer to Liszt (Lisp compiler) job + and transmit saved text. +\\{ledit-mode-map} +To make Lisp mode automatically change to Ledit mode, +do (setq lisp-mode-hook 'ledit-from-lisp-mode)" + (interactive) + (lisp-mode) + (ledit-from-lisp-mode)) + +;;;###autoload +(defun ledit-from-lisp-mode () + (use-local-map ledit-mode-map) + (setq mode-name "Ledit") + (setq major-mode 'ledit-mode) + (run-hooks 'ledit-mode-hook)) + +;;; ledit.el ends here diff --git a/lpr.el b/lpr.el new file mode 100644 --- /dev/null +++ b/lpr.el @@ -0,0 +1,241 @@ +;;; lpr.el --- print Emacs buffer on line printer. + +;; Copyright (C) 1985, 1988, 1992, 1994 Free Software Foundation, Inc. + +;; Maintainer: FSF +;; Keywords: unix + +;; This file is part of XEmacs. + +;; XEmacs 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 2, or (at your option) +;; any later version. + +;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the Free +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. + +;;; Synched up with: FSF 19.34. + +;;; Commentary: + +;; Commands to send the region or a buffer your printer. Entry points +;; are `lpr-buffer', `print-buffer', lpr-region', or `print-region'; option +;; variables include `lpr-switches' and `lpr-command'. + +;;; Code: + +(defgroup lpr nil + "Print Emacs buffer on line printer" + :group 'wp) + + +;;;###autoload +(defcustom lpr-switches nil + "*List of strings to pass as extra options for the printer program. +See `lpr-command'." + :type '(repeat (string :tag "Argument")) + :group 'lpr) + +(defcustom lpr-add-switches (eq system-type 'berkeley-unix) + "*Non-nil means construct -T and -J options for the printer program. +These are made assuming that the program is `lpr'; +if you are using some other incompatible printer program, +this variable should be nil." + :type 'boolean + :group 'lpr) + +;;;###autoload +(defcustom lpr-command + (if (memq system-type '(usg-unix-v dgux hpux irix)) + "lp" "lpr") + "*Name of program for printing a file." + :type 'string + :group 'lpr) + +;; Default is nil, because that enables us to use pr -f +;; which is more reliable than pr with no args, which is what lpr -p does. +(defcustom lpr-headers-switches nil + "*List of strings of options to request page headings in the printer program. +If nil, we run `lpr-page-header-program' to make page headings +and print the result." + :type '(repeat (string :tag "Argument")) + :group 'lpr) + +(defcustom print-region-function nil + "Function to call to print the region on a printer. +See definition of `print-region-1' for calling conventions." + :type 'function + :group 'lpr) + +(defcustom lpr-page-header-program "pr" + "*Name of program for adding page headers to a file." + :type 'string + :group 'lpr) + +(defcustom lpr-page-header-switches '("-f") + "*List of strings to use as options for the page-header-generating program. +The variable `lpr-page-header-program' specifies the program to use." + :type '(repeat string) + :group 'lpr) + +;;;###autoload +(defun lpr-buffer () + "Print buffer contents as with Unix command `lpr'. +`lpr-switches' is a list of extra switches (strings) to pass to lpr." + (interactive) + (print-region-1 (point-min) (point-max) lpr-switches nil)) + +;;;###autoload +(defun print-buffer () + "Print buffer contents as with Unix command `lpr -p'. +`lpr-switches' is a list of extra switches (strings) to pass to lpr." + (interactive) + (print-region-1 (point-min) (point-max) lpr-switches t)) + +;;;###autoload +(defun lpr-region (start end) + "Print region contents as with Unix command `lpr'. +`lpr-switches' is a list of extra switches (strings) to pass to lpr." + (interactive "r") + (print-region-1 start end lpr-switches nil)) + +;;;###autoload +(defun print-region (start end) + "Print region contents as with Unix command `lpr -p'. +`lpr-switches' is a list of extra switches (strings) to pass to lpr." + (interactive "r") + (print-region-1 start end lpr-switches t)) + +;; XEmacs change +;; (require 'message) ; Until We can get some sensible autoloads, or + ; message-flatten-list gets put somewhere decent. +;; Sigh ... +;; `ps-flatten-list' is defined here (copied from "message.el" and +;; enhanced to handle dotted pairs as well) until we can get some +;; sensible autoloads, or `flatten-list' gets put somewhere decent. + +;; (ps-flatten-list '((a . b) c (d . e) (f g h) i . j)) +;; => (a b c d e f g h i j) + +(defun lpr-flatten-list (&rest list) + (lpr-flatten-list-1 list)) + +(defun lpr-flatten-list-1 (list) + (cond + ((null list) (list)) + ((consp list) + (append (lpr-flatten-list-1 (car list)) + (lpr-flatten-list-1 (cdr list)))) + (t (list list)))) + +(defun print-region-1 (start end switches page-headers) + ;; On some MIPS system, having a space in the job name + ;; crashes the printer demon. But using dashes looks ugly + ;; and it seems to annoying to do for that MIPS system. + (let ((name (concat (buffer-name) " Emacs buffer")) + (title (concat (buffer-name) " Emacs buffer")) + ;; On MS-DOS systems, make pipes use binary mode if the + ;; original file is binary. + (binary-process-input buffer-file-type) + (binary-process-output buffer-file-type) + (width tab-width) + nswitches + switch-string) + (save-excursion + (if page-headers + (if lpr-headers-switches + ;; It is possible to use an lpr option + ;; to get page headers. + (setq switches (append (if (stringp lpr-headers-switches) + (list lpr-headers-switches) + lpr-headers-switches) + switches)))) + (setq nswitches (lpr-flatten-list ; XEmacs + (mapcar '(lambda (arg) ; Dynamic evaluation + (cond ((stringp arg) arg) + ((functionp arg) (apply arg nil)) + ((symbolp arg) (eval arg)) + ((consp arg) (apply (car arg) + (cdr arg))) + (t nil))) + switches))) + (setq switch-string + (if nswitches (concat " with options " + (mapconcat 'identity nswitches " ")) + "")) + (message "Spooling%s..." switch-string) + (if (/= tab-width 8) + (let ((new-coords (print-region-new-buffer start end))) + (setq start (car new-coords) end (cdr new-coords)) + (setq tab-width width) + (save-excursion + (goto-char end) + (setq end (point-marker))) + (untabify (point-min) (point-max)))) + (if page-headers + (if lpr-headers-switches + ;; We handled this above by modifying SWITCHES. + nil + ;; Run a separate program to get page headers. + (let ((new-coords (print-region-new-buffer start end))) + (setq start (car new-coords) end (cdr new-coords))) + (apply 'call-process-region start end lpr-page-header-program + t t nil + (nconc (and lpr-add-switches + (list "-h" title)) + lpr-page-header-switches)) + (setq start (point-min) end (point-max)))) + (apply (or print-region-function 'call-process-region) + (nconc (list start end lpr-command + nil nil nil) + (nconc (and lpr-add-switches + (list "-J" name)) + ;; These belong in pr if we are using that. + (and lpr-add-switches lpr-headers-switches + (list "-T" title)) + nswitches))) + (if (markerp end) + (set-marker end nil)) + (message "Spooling%s...done" switch-string)))) + +;; This function copies the text between start and end +;; into a new buffer, makes that buffer current. +;; It returns the new range to print from the new current buffer +;; as (START . END). + +(defun print-region-new-buffer (ostart oend) + (if (string= (buffer-name) " *spool temp*") + (cons ostart oend) + (let ((oldbuf (current-buffer))) + (set-buffer (get-buffer-create " *spool temp*")) + (widen) (erase-buffer) + (insert-buffer-substring oldbuf ostart oend) + (cons (point-min) (point-max))))) + +(defun printify-region (begin end) + "Turn nonprinting characters (other than TAB, LF, SPC, RET, and FF) +in the current buffer into printable representations as control or +hexadecimal escapes." + (interactive "r") + (save-excursion + (goto-char begin) + (let (c) + (while (re-search-forward "[\^@-\^h\^k\^n-\^_\177-\377]" end t) + (setq c (preceding-char)) + (delete-backward-char 1) + (insert + (if (< c ?\ ) + (format "\\^%c" (+ c ?@)) + (format "\\%02x" c))))))) + +(provide 'lpr) + +;;; lpr.el ends here diff --git a/package-info.in b/package-info.in new file mode 100644 --- /dev/null +++ b/package-info.in @@ -0,0 +1,10 @@ +(os-utils + (version VERSION + description "Miscellaneous O/S utilities." + filename FILENAME + md5sum MD5SUM + size SIZE + provides (archive-mode background crypt crypt++ inf-lisp jka-compr lpr ps-print tar-mode telnet terminal uncompress) + requires (REQUIRES) + type single +)) diff --git a/ps-print.el b/ps-print.el new file mode 100644 --- /dev/null +++ b/ps-print.el @@ -0,0 +1,3194 @@ +;;; ps-print.el --- Jim's Pretty-Good PostScript Generator for Emacs 19. + +;; Copyright (C) 1993, 1994, 1995, 1996 Free Software Foundation, Inc. + +;; Author: Jim Thompson (was <thompson@wg2.waii.com>) +;; Maintainer: Jacques Duthen <duthen@club-internet.fr> +;; Keywords: print, PostScript +;; Time-stamp: <97/01/29 23:21:25 tjchol01> +;; Version: 3.05 + +(defconst ps-print-version "3.05" + "ps-print.el, v 3.05 <97/01/17 duthen> + +Jack's last change version -- this file may have been edited as part of +Emacs without changes to the version number. When reporting bugs, +please also report the version of Emacs, if any, that ps-print was +distributed with. + +Please send all bug fixes and enhancements to + Jacques Duthen <duthen@cegelec-red.fr>. +") + +;; This file is part of GNU Emacs. + +;; GNU Emacs 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 2, or (at your option) +;; any later version. + +;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;; LCD Archive Entry: +;; ps-print|James C. Thompson|thompson@wg2.waii.com| +;; Jim's Pretty-Good PostScript Generator for Emacs 19 (ps-print)| +;; 26-Feb-1994|2.8|~/packages/ps-print.el| + +;; 3.05 [jack] <97/01/16 duthen> +;; Ben Wing <ben@666.com> took ps-print.el from the official 19.34 +;; GNU distribution: +;; -rw-rw-r-- 1 duthen 69315 Jul 22 1996 ps-print.el +;; He patched it for XEmacs. +;; Steven L Baur <steve@miranova.com> sent me this version which has +;; 26 diffs with 19.34. +;; I merge these 26 diffs into my 3.04 version. + +;; `ps-paper-type': ###autoload. +;; `ps-print-color-p' `ps-color-values': Replace pixel-components by +;; color-instance-rgb-components for XEmacs. +;; `ps-color-device': New function to dynamically test the device +;; color capability, added where ps-print-color-p is tested. +;; `ps-xemacs-face-kind-p': Fixed. +;; `ps-do-despool': Permit dynamic evaluation at print time of +;; ps-lpr-switches. +;; `ps-eval-switch' `ps-flatten-list' `ps-flatten-list-1': New for +;; the previous feature. +;; `ps-gnus-print-article-from-summary': Updated for Gnus 5. + + +;; 3.04 [jack] after [simon] Oct 8, 1996 Simon Marshall <simon@gnu.ai.mit.edu> +;; `ps-print-version': +;; Fix value. +;; `cl' `lisp-float-type': +;; Require them. +;; `ps-number-of-columns' `ps-*-font-size': +;; Try to select defaults better suited when `ps-landscape-mode' is non-nil. +;; `ps-*-faces': +;; Change default for Font Lock mode faces when `ps-print-color-p' is nil. +;; `ps-right-header': +;; Replace `time-stamp-yy/mm/dd' by `time-stamp-mon-dd-yyyy'. +;; `ps-end-file' `ps-begin-page': +;; Fix bug in page count for Ghostview. +;; `ps-generate-postscript-with-faces': +;; Replace `ps-sorter' by `car-less-than-car'. +;; `ps-plot' `ps-generate': +;; Replace `%d' by `%3d'. + +;; 3.03 [jack] Sept 27, 1996 Jacques Duthen <duthen@cegelec-red.fr> +;; Merge 31 diffs between 19.29 and 19.34 + +;; 3.02 [jack] June 26, 1996 Jacques Duthen <duthen@cegelec-red.fr> +;; Add new page dimensions to `ps-page-dimensions-database' for `paper-type' +;; Improve landscape mode `ps-landscape-mode' and multiple columns +;; printing `ps-number-of-columns': +;; The text and the margins are no more scaled. +;; Simplify the semantics of `ps-inter-column' (space between columns). +;; Add error checking for negative `ps-print-width' and `ps-print-height'. +;; Change the semantics of `ps-top-margin' which is now the TOP MARGIN, +;; and add `ps-header-offset' instead of having `ps-top-margin' split in 2. +;; Add `ps-header-font-family', `ps-header-font-size' and +;; `ps-header-title-font-size' to control the header. +;; Add `ps-header-line-pad'. +;; Change the semantics of `ps-font-info-database' to have symbolic +;; font families. +;; Add new fonts to `ps-font-info-database': `Courier' `Helvetica' +;; `Times' `Palatino' `Helvetica-Narrow' `NewCenturySchlbk' +;; Make public `ps-font-family' and `ps-font-size' so that the user +;; can directly control the text font and size without loading ps-print. +;; Add error checking for unknown font families and a message giving +;; the exhaustive list of available font families. +;; Document how to install a new font family. +;; Add `/ReportAllFontInfo' to get all the font families of the printer. +;; Add the possibility to make `mixed' font families. +;; Add `ps-setup' to get the current setup. +;; Add tools `ps-line-lengths' `ps-nb-pages-buffer' `ps-nb-pages-region' +;; to help choose the font size. +;; Split `ps-print-prologue' in two to insert info from header fonts +;; Replace indexes by macro `ps-page-dimensions-get-width' +;; to get access to the dimensions list. +;; Add `ps-select-font' inside `ps-get-page-dimensions'. +;; Fix the "clumsy" `ps-page-height' management. +;; Move `ps-get-page-dimensions' to the beginning of `ps-begin-file' +;; to get early error checking. +;; Add sample setup `ps-jack-setup'. +;; +;; Rewrite a lot of postscript code and add comments inside it +;; (maybe they should not (or optionally) be included in the generated +;; Postscript). +;; Translate the origin to (lm, bm) to simplify the other moves. +;; Fix bug in `/HeaderOffset' with `/PrintStartY'. +;; Fix bug in `/SetHeaderLines'. +;; Change `/ReportFontInfo' for use by `/ReportAllFontInfo'. + +;; 3.01 [jack] June 4, 1996 Jacques Duthen <duthen@cegelec-red.fr> +;; Manage float value for every variable representing a size. +;; Add `ps-font-info-database' `ps-inter-column' + +;; 3.00 [jack] May 17, 1996 Jacques Duthen <duthen@cegelec-red.fr> +;; based on 2.8 Jim's Pretty-Good version: +;; Add `ps-landscape-mode' and `ps-number-of-columns' +;; for dumb multi-column landscape mode. + +;; Baseline-version: 2.8. (Jim's last change version -- this +;; file may have been edited as part of Emacs without changes to the +;; version number. When reporting bugs, please also report the +;; version of Emacs, if any, that ps-print was distributed with.) + +;;; Commentary: + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; About ps-print +;; -------------- +;; +;; This package provides printing of Emacs buffers on PostScript +;; printers; the buffer's bold and italic text attributes are +;; preserved in the printer output. Ps-print is intended for use with +;; Emacs 19 or Lucid Emacs, together with a fontifying package such as +;; font-lock or hilit. +;; +;; +;; Using ps-print +;; -------------- +;; +;; The Commands +;; +;; Ps-print provides eight commands for generating PostScript images +;; of Emacs buffers: +;; +;; ps-print-buffer +;; ps-print-buffer-with-faces +;; ps-print-region +;; ps-print-region-with-faces +;; ps-spool-buffer +;; ps-spool-buffer-with-faces +;; ps-spool-region +;; ps-spool-region-with-faces +;; +;; These commands all perform essentially the same function: they +;; generate PostScript images suitable for printing on a PostScript +;; printer or displaying with GhostScript. These commands are +;; collectively referred to as "ps-print- commands". +;; +;; The word "print" or "spool" in the command name determines when the +;; PostScript image is sent to the printer: +;; +;; print - The PostScript image is immediately sent to the +;; printer; +;; +;; spool - The PostScript image is saved temporarily in an +;; Emacs buffer. Many images may be spooled locally +;; before printing them. To send the spooled images +;; to the printer, use the command `ps-despool'. +;; +;; The spooling mechanism was designed for printing lots of small +;; files (mail messages or netnews articles) to save paper that would +;; otherwise be wasted on banner pages, and to make it easier to find +;; your output at the printer (it's easier to pick up one 50-page +;; printout than to find 50 single-page printouts). +;; +;; Ps-print has a hook in the `kill-emacs-hooks' so that you won't +;; accidentally quit from Emacs while you have unprinted PostScript +;; waiting in the spool buffer. If you do attempt to exit with +;; spooled PostScript, you'll be asked if you want to print it, and if +;; you decline, you'll be asked to confirm the exit; this is modeled +;; on the confirmation that Emacs uses for modified buffers. +;; +;; The word "buffer" or "region" in the command name determines how +;; much of the buffer is printed: +;; +;; buffer - Print the entire buffer. +;; +;; region - Print just the current region. +;; +;; The -with-faces suffix on the command name means that the command +;; will include font, color, and underline information in the +;; PostScript image, so the printed image can look as pretty as the +;; buffer. The ps-print- commands without the -with-faces suffix +;; don't include font, color, or underline information; images printed +;; with these commands aren't as pretty, but are faster to generate. +;; +;; Two ps-print- command examples: +;; +;; ps-print-buffer - print the entire buffer, +;; without font, color, or +;; underline information, and +;; send it immediately to the +;; printer. +;; +;; ps-spool-region-with-faces - print just the current region; +;; include font, color, and +;; underline information, and +;; spool the image in Emacs to +;; send to the printer later. +;; +;; +;; Invoking Ps-Print +;; ----------------- +;; +;; To print your buffer, type +;; +;; M-x ps-print-buffer +;; +;; or substitute one of the other seven ps-print- commands. The +;; command will generate the PostScript image and print or spool it as +;; specified. By giving the command a prefix argument +;; +;; C-u M-x ps-print-buffer +;; +;; it will save the PostScript image to a file instead of sending it +;; to the printer; you will be prompted for the name of the file to +;; save the image to. The prefix argument is ignored by the commands +;; that spool their images, but you may save the spooled images to a +;; file by giving a prefix argument to `ps-despool': +;; +;; C-u M-x ps-despool +;; +;; When invoked this way, `ps-despool' will prompt you for the name of +;; the file to save to. +;; +;; Any of the `ps-print-' commands can be bound to keys; I recommend +;; binding `ps-spool-buffer-with-faces', `ps-spool-region-with-faces', +;; and `ps-despool'. Here are the bindings I use on my Sun 4 keyboard: +;; +;; (global-set-key 'f22 'ps-spool-buffer-with-faces) ;f22 is prsc +;; (global-set-key '(shift f22) 'ps-spool-region-with-faces) +;; (global-set-key '(control f22) 'ps-despool) +;; +;; +;; The Printer Interface +;; --------------------- +;; +;; The variables `ps-lpr-command' and `ps-lpr-switches' determine what +;; command is used to send the PostScript images to the printer, and +;; what arguments to give the command. These are analogous to +;; `lpr-command' and `lpr-switches'. +;; +;; Make sure that they contain appropriate values for your system; +;; see the usage notes below and the documentation of these variables. +;; +;; NOTE: `ps-lpr-command' and `ps-lpr-switches' take their initial values +;; from the variables `lpr-command' and `lpr-switches'. If you have +;; `lpr-command' set to invoke a pretty-printer such as `enscript', +;; then ps-print won't work properly. `ps-lpr-command' must name +;; a program that does not format the files it prints. +;; +;; +;; The Page Layout +;; --------------- +;; +;; All dimensions are floats in PostScript points. +;; 1 inch == 2.54 cm == 72 points +;; 1 cm == (/ 1 2.54) inch == (/ 72 2.54) points +;; +;; The variable `ps-paper-type' determines the size of paper ps-print +;; formats for; it should contain one of the symbols: +;; `a4' `a3' `letter' `legal' `letter-small' `tabloid' +;; `ledger' `statement' `executive' `a4small' `b4' `b5' +;; +;; The variable `ps-landscape-mode' determines the orientation +;; of the printing on the page: +;; nil means `portrait' mode, non-nil means `landscape' mode. +;; There is no oblique mode yet, though this is easy to do in ps. + +;; In landscape mode, the text is NOT scaled: you may print 70 lines +;; in portrait mode and only 50 lignes in landscape mode. +;; The margins represent margins in the printed paper: +;; the top margin is the margin between the top of the page +;; and the printed header, whatever the orientation is. +;; +;; The variable `ps-number-of-columns' determines the number of columns +;; both in landscape and portrait mode. +;; You can use: +;; - (the standard) one column portrait mode +;; - (my favorite) two columns landscape mode (which spares trees) +;; but also +;; - one column landscape mode for files with very long lines. +;; - multi-column portrait or landscape mode +;; +;; +;; Horizontal layout +;; ----------------- +;; +;; The horizontal layout is determined by the variables +;; `ps-left-margin' `ps-inter-column' `ps-right-margin' +;; as follows: +;; +;; ------------------------------------------ +;; | | | | | | | | +;; | lm | text | ic | text | ic | text | rm | +;; | | | | | | | | +;; ------------------------------------------ +;; +;; If `ps-number-of-columns' is 1, `ps-inter-column' is not relevant. +;; Usually, lm = rm > 0 and ic = lm +;; If (ic < 0), the text of adjacent columns can overlap. +;; +;; +;; Vertical layout +;; --------------- +;; +;; The vertical layout is determined by the variables +;; `ps-bottom-margin' `ps-top-margin' `ps-header-offset' +;; as follows: +;; +;; |--------| |--------| +;; | tm | | tm | +;; |--------| |--------| +;; | header | | | +;; |--------| | | +;; | ho | | | +;; |--------| or | text | +;; | | | | +;; | text | | | +;; | | | | +;; |--------| |--------| +;; | bm | | bm | +;; |--------| |--------| +;; +;; If `ps-print-header' is nil, `ps-header-offset' is not relevant. +;; The margins represent margins in the printed paper: +;; the top margin is the margin between the top of the page +;; and the printed header, whatever the orientation is. +;; +;; +;; Headers +;; ------- +;; +;; Ps-print can print headers at the top of each column; the default +;; headers contain the following four items: on the left, the name of +;; the buffer and, if the buffer is visiting a file, the file's +;; directory; on the right, the page number and date of printing. +;; The default headers look something like this: +;; +;; ps-print.el 1/21 +;; /home/jct/emacs-lisp/ps/new 94/12/31 +;; +;; When printing on duplex printers, left and right are reversed so +;; that the page numbers are toward the outside (cf. `ps-spool-duplex'). +;; +;; Headers are configurable: +;; To turn them off completely, set `ps-print-header' to nil. +;; To turn off the header's gaudy framing box, +;; set `ps-print-header-frame' to nil. +;; +;; The font family and size of text in the header are determined +;; by the variables `ps-header-font-family', `ps-header-font-size' and +;; `ps-header-title-font-size' (see below). +;; +;; The variable `ps-header-line-pad' determines the portion of a header +;; title line height to insert between the header frame and the text +;; it contains, both in the vertical and horizontal directions: +;; .5 means half a line. + +;; Page numbers are printed in `n/m' format, indicating page n of m pages; +;; to omit the total page count and just print the page number, +;; set `ps-show-n-of-n' to nil. +;; +;; The amount of information in the header can be changed by changing +;; the number of lines. To show less, set `ps-header-lines' to 1, and +;; the header will show only the buffer name and page number. To show +;; more, set `ps-header-lines' to 3, and the header will show the time of +;; printing below the date. +;; +;; To change the content of the headers, change the variables +;; `ps-left-header' and `ps-right-header'. +;; These variables are lists, specifying top-to-bottom the text +;; to display on the left or right side of the header. +;; Each element of the list should be a string or a symbol. +;; Strings are inserted directly into the PostScript arrays, +;; and should contain the PostScript string delimiters '(' and ')'. +;; +;; Symbols in the header format lists can either represent functions +;; or variables. Functions are called, and should return a string to +;; show in the header. Variables should contain strings to display in +;; the header. In either case, function or variable, the PostScript +;; string delimiters are added by ps-print, and should not be part of +;; the returned value. +;; +;; Here's an example: say we want the left header to display the text +;; +;; Moe +;; Larry +;; Curly +;; +;; where we have a function to return "Moe" +;; +;; (defun moe-func () +;; "Moe") +;; +;; a variable specifying "Larry" +;; +;; (setq larry-var "Larry") +;; +;; and a literal for "Curly". Here's how `ps-left-header' should be +;; set: +;; +;; (setq ps-left-header (list 'moe-func 'larry-var "(Curly)")) +;; +;; Note that Curly has the PostScript string delimiters inside his +;; quotes -- those aren't misplaced lisp delimiters! +;; +;; Without them, PostScript would attempt to call the undefined +;; function Curly, which would result in a PostScript error. +;; +;; Since most printers don't report PostScript errors except by +;; aborting the print job, this kind of error can be hard to track down. +;; +;; Consider yourself warned! +;; +;; +;; Duplex Printers +;; --------------- +;; +;; If you have a duplex-capable printer (one that prints both sides of +;; the paper), set `ps-spool-duplex' to t. +;; Ps-print will insert blank pages to make sure each buffer starts +;; on the correct side of the paper. +;; Don't forget to set `ps-lpr-switches' to select duplex printing +;; for your printer. +;; +;; +;; Font managing +;; ------------- +;; +;; Ps-print now knows rather precisely some fonts: +;; the variable `ps-font-info-database' contains information +;; for a list of font families (currently mainly `Courier' `Helvetica' +;; `Times' `Palatino' `Helvetica-Narrow' `NewCenturySchlbk'). +;; Each font family contains the font names for standard, bold, italic +;; and bold-italic characters, a reference size (usually 10) and the +;; corresponding line height, width of a space and average character width. +;; +;; The variable `ps-font-family' determines which font family +;; is to be used for ordinary text. +;; If its value does not correspond to a known font family, +;; an error message is printed into the `*Messages*' buffer, +;; which lists the currently available font families. +;; +;; The variable `ps-font-size' determines the size (in points) +;; of the font for ordinary text, when generating Postscript. +;; Its value is a float. +;; +;; Similarly, the variable `ps-header-font-family' determines +;; which font family is to be used for text in the header. +;; The variable `ps-header-font-size' determines the font size, +;; in points, for text in the header. +;; The variable `ps-header-title-font-size' determines the font size, +;; in points, for the top line of text in the header. +;; +;; +;; Adding a new font family +;; ------------------------ +;; +;; To use a new font family, you MUST first teach ps-print +;; this font, i.e., add its information to `ps-font-info-database', +;; otherwise ps-print cannot correctly place line and page breaks. +;; +;; For example, assuming `Helvetica' is unknown, +;; you first need to do the following ONLY ONCE: +;; +;; - create a new buffer +;; - generate the PostScript image to a file (C-u M-x ps-print-buffer) +;; - open this file and find the line: +;; `% 3 cm 20 cm moveto 10 /Courier ReportFontInfo showpage' +;; - delete the leading `%' (which is the Postscript comment character) +;; - replace in this line `Courier' by the new font (say `Helvetica') +;; to get the line: +;; `3 cm 20 cm moveto 10 /Helvetica ReportFontInfo showpage' +;; - send this file to the printer (or to ghostscript). +;; You should read the following on the output page: +;; +;; For Helvetica 10 point, the line height is 11.56, the space width is 2.78 +;; and a crude estimate of average character width is 5.09243 +;; +;; - Add these values to the `ps-font-info-database': +;; (setq ps-font-info-database +;; (append +;; '((Helvetica ; the family name +;; "Helvetica" "Helvetica-Bold" "Helvetica-Oblique" "Helvetica-BoldOblique" +;; 10.0 11.56 2.78 5.09243)) +;; ps-font-info-database)) +;; - Now you can use this font family with any size: +;; (setq ps-font-family 'Helvetica) +;; - if you want to use this family in another emacs session, you must +;; put into your `~/.emacs': +;; (require 'ps-print) +;; (setq ps-font-info-database (append ...))) +;; if you don't want to load ps-print, you have to copy the whole value: +;; (setq ps-font-info-database '(<your stuff> <the standard stuff>)) +;; or, if you can wait until the `ps-print-hook' is implemented, do: +;; (add-hook 'ps-print-hook '(setq ps-font-info-database (append ...))) +;; This does not work yet, since there is no `ps-print-hook' yet. +;; +;; You can create new `mixed' font families like: +;; (my-mixed-family +;; "Courier-Bold" "Helvetica" +;; "Zapf-Chancery-MediumItalic" "NewCenturySchlbk-BoldItalic" +;; 10.0 10.55 6.0 6.0) +;; Now you can use your new font family with any size: +;; (setq ps-font-family 'my-mixed-family) +;; +;; You can get information on all the fonts resident in YOUR printer +;; by uncommenting the line: +;; % 3 cm 20 cm moveto ReportAllFontInfo showpage +;; +;; The postscript file should be sent to YOUR postscript printer. +;; If you send it to ghostscript or to another postscript printer, +;; you may get slightly different results. +;; Anyway, as ghostscript fonts are autoload, you won't get +;; much font info. +;; +;; +;; How Ps-Print Deals With Faces +;; ----------------------------- +;; +;; The ps-print-*-with-faces commands attempt to determine which faces +;; should be printed in bold or italic, but their guesses aren't +;; always right. For example, you might want to map colors into faces +;; so that blue faces print in bold, and red faces in italic. +;; +;; It is possible to force ps-print to consider specific faces bold or +;; italic, no matter what font they are displayed in, by setting the +;; variables `ps-bold-faces' and `ps-italic-faces'. These variables +;; contain lists of faces that ps-print should consider bold or +;; italic; to set them, put code like the following into your .emacs +;; file: +;; +;; (setq ps-bold-faces '(my-blue-face)) +;; (setq ps-italic-faces '(my-red-face)) +;; +;; Faces like bold-italic that are both bold and italic should go in +;; *both* lists. +;; +;; Ps-print keeps internal lists of which fonts are bold and which are +;; italic; these lists are built the first time you invoke ps-print. +;; For the sake of efficiency, the lists are built only once; the same +;; lists are referred in later invocations of ps-print. +;; +;; Because these lists are built only once, it's possible for them to +;; get out of sync, if a face changes, or if new faces are added. To +;; get the lists back in sync, you can set the variable +;; `ps-build-face-reference' to t, and the lists will be rebuilt the +;; next time ps-print is invoked. +;; +;; +;; How Ps-Print Deals With Color +;; ----------------------------- +;; +;; Ps-print detects faces with foreground and background colors +;; defined and embeds color information in the PostScript image. +;; The default foreground and background colors are defined by the +;; variables `ps-default-fg' and `ps-default-bg'. +;; On black-and-white printers, colors are displayed in grayscale. +;; To turn off color output, set `ps-print-color-p' to nil. +;; +;; +;; Utilities +;; --------- +;; +;; Some tools are provided to help you customize your font setup. +;; +;; `ps-setup' returns (some part of) the current setup. +;; +;; To avoid wrapping too many lines, you may want to adjust the +;; left and right margins and the font size. On UN*X systems, do: +;; pr -t file | awk '{printf "%3d %s\n", length($0), $0}' | sort -r | head +;; to determine the longest lines of your file. +;; Then, the command `ps-line-lengths' will give you the correspondence +;; between a line length (number of characters) and the maximum font +;; size which doesn't wrap such a line with the current ps-print setup. +;; +;; The commands `ps-nb-pages-buffer' and `ps-nb-pages-region' display +;; the correspondence between a number of pages and the maximum font +;; size which allow the number of lines of the current buffer or of +;; its current region to fit in this number of pages. +;; Note: line folding is not taken into account in this process +;; and could change the results. +;; +;; +;; New since version 1.5 +;; --------------------- +;; +;; Color output capability. +;; Automatic detection of font attributes (bold, italic). +;; Configurable headers with page numbers. +;; Slightly faster. +;; Support for different paper sizes. +;; Better conformance to PostScript Document Structure Conventions. +;; +;; +;; New since version 2.8 +;; --------------------- +;; +;; [jack] 960517 Jacques Duthen <duthen@cegelec-red.fr> +;; +;; Font familiy and float size for text and header. +;; Landscape mode. +;; Multiple columns. +;; Tools for page setup. +;; +;; +;; Known bugs and limitations of ps-print: +;; -------------------------------------- +;; +;; Although color printing will work in XEmacs 19.12, it doesn't work +;; well; in particular, bold or italic fonts don't print in the right +;; background color. +;; +;; Invisible properties aren't correctly ignored in XEmacs 19.12. +;; +;; Automatic font-attribute detection doesn't work well, especially +;; with hilit19 and older versions of get-create-face. Users having +;; problems with auto-font detection should use the lists +;; `ps-italic-faces' and `ps-bold-faces' and/or turn off automatic +;; detection by setting `ps-auto-font-detect' to nil. +;; +;; Automatic font-attribute detection doesn't work with XEmacs 19.12 +;; in tty mode; use the lists `ps-italic-faces' and `ps-bold-faces' +;; instead. +;; +;; Still too slow; could use some hand-optimization. +;; +;; ASCII Control characters other than tab, linefeed and pagefeed are +;; not handled. +;; +;; Default background color isn't working. +;; +;; Faces are always treated as opaque. +;; +;; Epoch and Emacs 18 not supported. At all. +;; +;; Fixed-pitch fonts work better for line folding, but are not required. +;; +;; `ps-nb-pages-buffer' and `ps-nb-pages-region' don't take care +;; of folding lines. +;; +;; +;; Things to change: +;; ---------------- +;; +;; Add `ps-print-hook' (I don't know how to do that (yet!)). +;; Add 4-up capability (really needed?). +;; Add line numbers (should not be too hard). +;; Add `ps-non-bold-faces' and `ps-non-italic-faces' (should be easy). +;; Put one header per page over the columns (easy but needed?). +;; Improve the memory management for big files (hard?). +;; `ps-nb-pages-buffer' and `ps-nb-pages-region' should take care +;; of folding lines. +;; +;; +;; Acknowledgements +;; ---------------- +;; Thanks to Jim Thompson <?@?> for the 2.8 version I started from. +;; [jack] +;; +;; Thanks to Kevin Rodgers <kevinr@ihs.com> for adding support for +;; color and the invisible property. +;; +;; Thanks to Avishai Yacobi, avishaiy@mcil.comm.mot.com, for writing +;; the initial port to Emacs 19. His code is no longer part of +;; ps-print, but his work is still appreciated. +;; +;; Thanks to Remi Houdaille and Michel Train, michel@metasoft.fdn.org, +;; for adding underline support. Their code also is no longer part of +;; ps-print, but their efforts are not forgotten. +;; +;; Thanks also to all of you who mailed code to add features to +;; ps-print; although I didn't use your code, I still appreciate your +;; sharing it with me. +;; +;; Thanks to all who mailed comments, encouragement, and criticism. +;; Thanks also to all who responded to my survey; I had too many +;; responses to reply to them all, but I greatly appreciate your +;; interest. +;; +;; Jim +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Code: + +(eval-when-compile + (require 'cl)) + +(unless (featurep 'lisp-float-type) + (error "`ps-print' requires floating point support")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; User Variables: + +;;; Interface to the command system + +(defgroup ps-print nil + "Postscript generator for Emacs 19" + :prefix "ps-" + :group 'wp) + +(defgroup ps-print-horizontal nil + "Horizontal page layout" + :prefix "ps-" + :tag "Horizontal" + :group 'ps-print) + +(defgroup ps-print-vertical nil + "Vertical page layout" + :prefix "ps-" + :tag "Vertical" + :group 'ps-print) + +(defgroup ps-print-header nil + "Headers layout" + :prefix "ps-" + :tag "Header" + :group 'ps-print) + +(defgroup ps-print-font nil + "Fonts customization" + :prefix "ps-" + :tag "Font" + :group 'ps-print) + +(defgroup ps-print-color nil + "Color customization" + :prefix "ps-" + :tag "Color" + :group 'ps-print) + +(defgroup ps-print-face nil + "Faces customization" + :prefix "ps-" + :tag "PS Faces" + :group 'ps-print + :group 'faces) + + +(defcustom ps-lpr-command lpr-command + "*The shell command for printing a PostScript file." + :type 'string + :group 'ps-print) + +(defcustom ps-lpr-switches lpr-switches + "*A list of extra switches to pass to `ps-lpr-command'." + :type '(repeat string) + :group 'ps-print) + +;;; Page layout + +;; All page dimensions are in PostScript points. +;; 1 inch == 2.54 cm == 72 points +;; 1 cm == (/ 1 2.54) inch == (/ 72 2.54) points + +;; Letter 8.5 inch x 11.0 inch +;; Legal 8.5 inch x 14.0 inch +;; A4 8.26 inch x 11.69 inch = 21.0 cm x 29.7 cm + +;; LetterSmall 7.68 inch x 10.16 inch +;; Tabloid 11.0 inch x 17.0 inch +;; Ledger 17.0 inch x 11.0 inch +;; Statement 5.5 inch x 8.5 inch +;; Executive 7.5 inch x 10.0 inch +;; A3 11.69 inch x 16.5 inch = 29.7 cm x 42.0 cm +;; A4Small 7.47 inch x 10.85 inch +;; B4 10.125 inch x 14.33 inch +;; B5 7.16 inch x 10.125 inch + +(defcustom ps-page-dimensions-database + (list (list 'a4 (/ (* 72 21.0) 2.54) (/ (* 72 29.7) 2.54)) + (list 'a3 (/ (* 72 29.7) 2.54) (/ (* 72 42.0) 2.54)) + (list 'letter (* 72 8.5) (* 72 11.0)) + (list 'legal (* 72 8.5) (* 72 14.0)) + (list 'letter-small (* 72 7.68) (* 72 10.16)) + (list 'tabloid (* 72 11.0) (* 72 17.0)) + (list 'ledger (* 72 17.0) (* 72 11.0)) + (list 'statement (* 72 5.5) (* 72 8.5)) + (list 'executive (* 72 7.5) (* 72 10.0)) + (list 'a4small (* 72 7.47) (* 72 10.85)) + (list 'b4 (* 72 10.125) (* 72 14.33)) + (list 'b5 (* 72 7.16) (* 72 10.125))) + "*List associating a symbolic paper type to its width and height. +see `ps-paper-type'." + :type '(repeat (list :tag "Paper Type" + (symbol :tag "Name") + (number :tag "Width") + (number :tag "Height"))) + :group 'ps-print) + +;;;###autoload +(defcustom ps-paper-type 'letter + "*Specifies the size of paper to format for. +Should be one of the paper types defined in `ps-page-dimensions-database', for +example `letter', `legal' or `a4'." + :type '(symbol :validate (lambda (wid) + (if (assq (widget-value wid) ps-page-dimensions-database) + nil + (widget-put wid :error "Unknown paper size") + wid))) + :group 'ps-print) + +(defcustom ps-landscape-mode 'nil + "*Non-nil means print in landscape mode." + :type 'boolean + :group 'ps-print) + +(defcustom ps-number-of-columns (if ps-landscape-mode 2 1) + "*Specifies the number of columns" + :type 'integer + :group 'ps-print) + +;;; Horizontal layout + +;; ------------------------------------------ +;; | | | | | | | | +;; | lm | text | ic | text | ic | text | rm | +;; | | | | | | | | +;; ------------------------------------------ + +(defcustom ps-left-margin (/ (* 72 2.0) 2.54) ; 2 cm + "*Left margin in points (1/72 inch)." + :type 'number + :group 'ps-print-horizontal) + +(defcustom ps-right-margin (/ (* 72 2.0) 2.54) ; 2 cm + "*Right margin in points (1/72 inch)." + :type 'number + :group 'ps-print-horizontal) + +(defcustom ps-inter-column (/ (* 72 2.0) 2.54) ; 2 cm + "*Horizontal space between columns in points (1/72 inch)." + :type 'number + :group 'ps-print-horizontal) + +;;; Vertical layout + +;; |--------| +;; | tm | +;; |--------| +;; | header | +;; |--------| +;; | ho | +;; |--------| +;; | text | +;; |--------| +;; | bm | +;; |--------| + +(defcustom ps-bottom-margin (/ (* 72 1.5) 2.54) ; 1.5 cm + "*Bottom margin in points (1/72 inch)." + :type 'number + :group 'ps-print-vertical) + +(defcustom ps-top-margin (/ (* 72 1.5) 2.54) ; 1.5 cm + "*Top margin in points (1/72 inch)." + :type 'number + :group 'ps-print-vertical) + +(defcustom ps-header-offset (/ (* 72 1.0) 2.54) ; 1.0 cm + "*Vertical space in points (1/72 inch) between the main text and the header." + :type 'number + :group 'ps-print-vertical) + +(defcustom ps-header-line-pad 0.15 + "*Portion of a header title line height to insert between the header frame +and the text it contains, both in the vertical and horizontal directions." + :type 'number + :group 'ps-print-vertical) + +;;; Header setup + +(defcustom ps-print-header t + "*Non-nil means print a header at the top of each page. +By default, the header displays the buffer name, page number, and, if +the buffer is visiting a file, the file's directory. Headers are +customizable by changing variables `ps-header-left' and +`ps-header-right'." + :type 'boolean + :group 'ps-print-header) + +(defcustom ps-print-header-frame t + "*Non-nil means draw a gaudy frame around the header." + :type 'boolean + :group 'ps-print-header) + +(defcustom ps-header-lines 2 + "*Number of lines to display in page header, when generating Postscript." + :type 'integer + :group 'ps-print-header) +(make-variable-buffer-local 'ps-header-lines) + +(defcustom ps-show-n-of-n t + "*Non-nil means show page numbers as N/M, meaning page N of M. +Note: page numbers are displayed as part of headers, see variable +`ps-print-headers'." + :type 'boolean + :group 'ps-print-header) + +(defcustom ps-spool-duplex nil ; Not many people have duplex + ; printers, so default to nil. + "*Non-nil indicates spooling is for a two-sided printer. +For a duplex printer, the `ps-spool-*' commands will insert blank pages +as needed between print jobs so that the next buffer printed will +start on the right page. Also, if headers are turned on, the headers +will be reversed on duplex printers so that the page numbers fall to +the left on even-numbered pages." + :type 'boolean + :group 'ps-print-header) + +;;; Fonts + +(defcustom ps-font-info-database + '((Courier ; the family key + "Courier" "Courier-Bold" "Courier-Oblique" "Courier-BoldOblique" + 10.0 10.55 6.0 6.0) + (Helvetica ; the family key + "Helvetica" "Helvetica-Bold" "Helvetica-Oblique" "Helvetica-BoldOblique" + 10.0 11.56 2.78 5.09243) + (Times + "Times-Roman" "Times-Bold" "Times-Italic" "Times-BoldItalic" + 10.0 11.0 2.5 4.71432) + (Palatino + "Palatino-Roman" "Palatino-Bold" "Palatino-Italic" "Palatino-BoldItalic" + 10.0 12.1 2.5 5.08676) + (Helvetica-Narrow + "Helvetica-Narrow" "Helvetica-Narrow-Bold" + "Helvetica-Narrow-Oblique" "Helvetica-Narrow-BoldOblique" + 10.0 11.56 2.2796 4.17579) + (NewCenturySchlbk + "NewCenturySchlbk-Roman" "NewCenturySchlbk-Bold" + "NewCenturySchlbk-Italic" "NewCenturySchlbk-BoldItalic" + 10.0 12.15 2.78 5.31162) + ;; got no bold for the next ones + (AvantGarde-Book + "AvantGarde-Book" "AvantGarde-Book" + "AvantGarde-BookOblique" "AvantGarde-BookOblique" + 10.0 11.77 2.77 5.45189) + (AvantGarde-Demi + "AvantGarde-Demi" "AvantGarde-Demi" + "AvantGarde-DemiOblique" "AvantGarde-DemiOblique" + 10.0 12.72 2.8 5.51351) + (Bookman-Demi + "Bookman-Demi" "Bookman-Demi" + "Bookman-DemiItalic" "Bookman-DemiItalic" + 10.0 11.77 3.4 6.05946) + (Bookman-Light + "Bookman-Light" "Bookman-Light" + "Bookman-LightItalic" "Bookman-LightItalic" + 10.0 11.79 3.2 5.67027) + ;; got no bold and no italic for the next ones + (Symbol + "Symbol" "Symbol" "Symbol" "Symbol" + 10.0 13.03 2.5 3.24324) + (Zapf-Dingbats + "Zapf-Dingbats" "Zapf-Dingbats" "Zapf-Dingbats" "Zapf-Dingbats" + 10.0 9.63 2.78 2.78) + (Zapf-Chancery-MediumItalic + "Zapf-Chancery-MediumItalic" "Zapf-Chancery-MediumItalic" + "Zapf-Chancery-MediumItalic" "Zapf-Chancery-MediumItalic" + 10.0 11.45 2.2 4.10811) +) + "*Font info database: font family (the key), name, bold, italic, bold-italic, +reference size, line height, space width, average character width. +To get the info for another specific font (say Helvetica), do the following: +- create a new buffer +- generate the PostScript image to a file (C-u M-x ps-print-buffer) +- open this file and delete the leading `%' (which is the Postscript + comment character) from the line + `% 3 cm 20 cm moveto 10 /Courier ReportFontInfo showpage' + to get the line + `3 cm 20 cm moveto 10 /Helvetica ReportFontInfo showpage' +- add the values to `ps-font-info-database'. +You can get all the fonts of YOUR printer using `ReportAllFontInfo'." + :type '(repeat (list :tag "Font Definition" + (symbol :tag "Font") + (string :tag "Name") + (string :tag "Bold") + (string :tag "Italic") + (string :tag "Bold-Italic") + (number :tag "Reference Size") + (number :tag "Line Height") + (number :tag "Space Width") + (number :tag "Average Character Width"))) + :group 'ps-print-font) + +(defcustom ps-font-family 'Courier + "Font family name for ordinary text, when generating Postscript." + :type 'symbol + :group 'ps-print-font) + +(defcustom ps-font-size (if ps-landscape-mode 7 8.5) + "Font size, in points, for ordinary text, when generating Postscript." + :type 'number + :group 'ps-print-font) + +(defcustom ps-header-font-family 'Helvetica + "Font family name for text in the header, when generating Postscript." + :type 'symbol + :group 'ps-print-font) + +(defcustom ps-header-font-size (if ps-landscape-mode 10 12) + "Font size, in points, for text in the header, when generating Postscript." + :type 'number + :group 'ps-print-font) + +(defcustom ps-header-title-font-size (if ps-landscape-mode 12 14) + "Font size, in points, for the top line of text in the header, +when generating Postscript." + :type 'number + :group 'ps-print-font) + +;;; Colors + +;;;###autoload +;;; The 19.33 fsf version includes a test on pixel components instead +;;; of color-instance-rgb-components +(defcustom ps-print-color-p (or (fboundp 'x-color-values) ; fsf + (fboundp 'color-instance-rgb-components)) + ; xemacs +; Printing color requires x-color-values. + "*If non-nil, print the buffer's text in color." + :type 'boolean + :group 'ps-print-color) + +(defcustom ps-default-fg '(0.0 0.0 0.0) + "*RGB values of the default foreground color. Defaults to black." + :type '(list (number :tag "Red") (number :tag "Green") (number :tag "Blue")) + :group 'ps-print-color) + +(defcustom ps-default-bg '(1.0 1.0 1.0) + "*RGB values of the default background color. Defaults to white." + :type '(list (number :tag "Red") (number :tag "Green") (number :tag "Blue")) + :group 'ps-print-color) + +(defcustom ps-auto-font-detect t + "*Non-nil means automatically detect bold/italic face attributes. +nil means rely solely on the lists `ps-bold-faces', `ps-italic-faces', +and `ps-underlined-faces'." + :type 'boolean + :group 'ps-print-font) + +(defcustom ps-bold-faces + (unless ps-print-color-p + '(font-lock-function-name-face + font-lock-builtin-face + font-lock-variable-name-face + font-lock-keyword-face + font-lock-warning-face)) + "*A list of the \(non-bold\) faces that should be printed in bold font. +This applies to generating Postscript." + :type '(repeat face) + :group 'ps-print-face) + +(defcustom ps-italic-faces + (unless ps-print-color-p + '(font-lock-variable-name-face + font-lock-string-face + font-lock-comment-face + font-lock-warning-face)) + "*A list of the \(non-italic\) faces that should be printed in italic font. +This applies to generating Postscript." + :type '(repeat face) + :group 'ps-print-face) + +(defcustom ps-underlined-faces + (unless ps-print-color-p + '(font-lock-function-name-face + font-lock-type-face + font-lock-reference-face + font-lock-warning-face)) + "*A list of the \(non-underlined\) faces that should be printed underlined. +This applies to generating Postscript." + :type '(repeat face) + :group 'ps-print-face) + +(defcustom ps-left-header + (list 'ps-get-buffer-name 'ps-header-dirpart) + "*The items to display (each on a line) on the left part of the page header. +This applies to generating Postscript. + +The value should be a list of strings and symbols, each representing an +entry in the PostScript array HeaderLinesLeft. + +Strings are inserted unchanged into the array; those representing +PostScript string literals should be delimited with PostScript string +delimiters '(' and ')'. + +For symbols with bound functions, the function is called and should +return a string to be inserted into the array. For symbols with bound +values, the value should be a string to be inserted into the array. +In either case, function or variable, the string value has PostScript +string delimiters added to it." + :type '(repeat (choice string symbol)) + :group 'ps-print-header) +(make-variable-buffer-local 'ps-left-header) + +(defcustom ps-right-header + (list "/pagenumberstring load" 'time-stamp-mon-dd-yyyy 'time-stamp-hh:mm:ss) + "*The items to display (each on a line) on the right part of the page header. +This applies to generating Postscript. + +See the variable `ps-left-header' for a description of the format of +this variable." + :type '(repeat (choice string symbol)) + :group 'ps-print-header) +(make-variable-buffer-local 'ps-right-header) + +(defcustom ps-razzle-dazzle t + "*Non-nil means report progress while formatting buffer." + :type 'boolean + :group 'ps-print) + +(defvar ps-adobe-tag "%!PS-Adobe-3.0\n" + "*Contains the header line identifying the output as PostScript. +By default, `ps-adobe-tag' contains the standard identifier. Some +printers require slightly different versions of this line.") + +(defcustom ps-build-face-reference t + "*Non-nil means build the reference face lists. + +Ps-print sets this value to nil after it builds its internal reference +lists of bold and italic faces. By settings its value back to t, you +can force ps-print to rebuild the lists the next time you invoke one +of the ...-with-faces commands. + +You should set this value back to t after you change the attributes of +any face, or create new faces. Most users shouldn't have to worry +about its setting, though." + :type 'boolean + :group 'ps-print-face) + +(defcustom ps-always-build-face-reference nil + "*Non-nil means always rebuild the reference face lists. + +If this variable is non-nil, ps-print will rebuild its internal +reference lists of bold and italic faces *every* time one of the +-with-faces commands is called. Most users shouldn't need to set this +variable." + :type 'boolean + :group 'ps-print-face) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; User commands + +;;;###autoload +(defun ps-print-buffer (&optional filename) + "Generate and print a PostScript image of the buffer. + +When called with a numeric prefix argument (C-u), prompts the user for +the name of a file to save the PostScript image in, instead of sending +it to the printer. + +More specifically, the FILENAME argument is treated as follows: if it +is nil, send the image to the printer. If FILENAME is a string, save +the PostScript image in a file with that name. If FILENAME is a +number, prompt the user for the name of the file to save in." + + (interactive (list (ps-print-preprint current-prefix-arg))) + (ps-generate (current-buffer) (point-min) (point-max) + 'ps-generate-postscript) + (ps-do-despool filename)) + + +;;;###autoload +(defun ps-print-buffer-with-faces (&optional filename) + "Generate and print a PostScript image of the buffer. +Like `ps-print-buffer', but includes font, color, and underline +information in the generated image. This command works only if you +are using a window system, so it has a way to determine color values." + (interactive (list (ps-print-preprint current-prefix-arg))) + (ps-generate (current-buffer) (point-min) (point-max) + 'ps-generate-postscript-with-faces) + (ps-do-despool filename)) + + +;;;###autoload +(defun ps-print-region (from to &optional filename) + "Generate and print a PostScript image of the region. +Like `ps-print-buffer', but prints just the current region." + + (interactive (list (point) (mark) (ps-print-preprint current-prefix-arg))) + (ps-generate (current-buffer) from to + 'ps-generate-postscript) + (ps-do-despool filename)) + + +;;;###autoload +(defun ps-print-region-with-faces (from to &optional filename) + "Generate and print a PostScript image of the region. +Like `ps-print-region', but includes font, color, and underline +information in the generated image. This command works only if you +are using a window system, so it has a way to determine color values." + + (interactive (list (point) (mark) (ps-print-preprint current-prefix-arg))) + (ps-generate (current-buffer) from to + 'ps-generate-postscript-with-faces) + (ps-do-despool filename)) + + +;;;###autoload +(defun ps-spool-buffer () + "Generate and spool a PostScript image of the buffer. +Like `ps-print-buffer' except that the PostScript image is saved in a +local buffer to be sent to the printer later. + +Use the command `ps-despool' to send the spooled images to the printer." + (interactive) + (ps-generate (current-buffer) (point-min) (point-max) + 'ps-generate-postscript)) + + +;;;###autoload +(defun ps-spool-buffer-with-faces () + "Generate and spool a PostScript image of the buffer. +Like `ps-spool-buffer', but includes font, color, and underline +information in the generated image. This command works only if you +are using a window system, so it has a way to determine color values. + +Use the command `ps-despool' to send the spooled images to the printer." + + (interactive) + (ps-generate (current-buffer) (point-min) (point-max) + 'ps-generate-postscript-with-faces)) + + +;;;###autoload +(defun ps-spool-region (from to) + "Generate a PostScript image of the region and spool locally. +Like `ps-spool-buffer', but spools just the current region. + +Use the command `ps-despool' to send the spooled images to the printer." + (interactive "r") + (ps-generate (current-buffer) from to + 'ps-generate-postscript)) + + +;;;###autoload +(defun ps-spool-region-with-faces (from to) + "Generate a PostScript image of the region and spool locally. +Like `ps-spool-region', but includes font, color, and underline +information in the generated image. This command works only if you +are using a window system, so it has a way to determine color values. + +Use the command `ps-despool' to send the spooled images to the printer." + (interactive "r") + (ps-generate (current-buffer) from to + 'ps-generate-postscript-with-faces)) + +;;;###autoload +(defun ps-despool (&optional filename) + "Send the spooled PostScript to the printer. + +When called with a numeric prefix argument (C-u), prompt the user for +the name of a file to save the spooled PostScript in, instead of sending +it to the printer. + +More specifically, the FILENAME argument is treated as follows: if it +is nil, send the image to the printer. If FILENAME is a string, save +the PostScript image in a file with that name. If FILENAME is a +number, prompt the user for the name of the file to save in." + (interactive (list (ps-print-preprint current-prefix-arg))) + (ps-do-despool filename)) + +;;;###autoload +(defun ps-line-lengths () + "*Display the correspondence between a line length and a font size, +using the current ps-print setup. +Try: pr -t file | awk '{printf \"%3d %s\n\", length($0), $0}' | sort -r | head" + (interactive) + (ps-line-lengths-internal)) + +;;;###autoload +(defun ps-nb-pages-buffer (nb-lines) + "*Display an approximate correspondence between a font size and the number +of pages the current buffer would require to print +using the current ps-print setup." + (interactive (list (count-lines (point-min) (point-max)))) + (ps-nb-pages nb-lines)) + +;;;###autoload +(defun ps-nb-pages-region (nb-lines) + "*Display an approximate correspondence between a font size and the number +of pages the current region would require to print +using the current ps-print setup." + (interactive (list (count-lines (mark) (point)))) + (ps-nb-pages nb-lines)) + +;;;###autoload +(defun ps-setup () + "*Return the current setup" + (format " + (setq ps-print-color-p %s + ps-lpr-command \"%s\" + ps-lpr-switches %s + + ps-paper-type '%s + ps-landscape-mode %s + ps-number-of-columns %s + + ps-left-margin %s + ps-right-margin %s + ps-inter-column %s + ps-bottom-margin %s + ps-top-margin %s + ps-header-offset %s + ps-header-line-pad %s + ps-print-header %s + ps-print-header-frame %s + ps-header-lines %s + ps-show-n-of-n %s + ps-spool-duplex %s + + ps-font-family '%s + ps-font-size %s + ps-header-font-family '%s + ps-header-font-size %s + ps-header-title-font-size %s) +" + ps-print-color-p + ps-lpr-command + ps-lpr-switches + ps-paper-type + ps-landscape-mode + ps-number-of-columns + ps-left-margin + ps-right-margin + ps-inter-column + ps-bottom-margin + ps-top-margin + ps-header-offset + ps-header-line-pad + ps-print-header + ps-print-header-frame + ps-header-lines + ps-show-n-of-n + ps-spool-duplex + ps-font-family + ps-font-size + ps-header-font-family + ps-header-font-size + ps-header-title-font-size)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Utility functions and variables: + +(defvar ps-print-emacs-type + (cond ((string-match "XEmacs" emacs-version) 'xemacs) + ((string-match "Lucid" emacs-version) 'lucid) + ((string-match "Epoch" emacs-version) 'epoch) + (t 'emacs))) + +(if (or (eq ps-print-emacs-type 'lucid) + (eq ps-print-emacs-type 'xemacs)) + (if (< emacs-minor-version 12) + (setq ps-print-color-p nil)) + (require 'faces)) ; face-font, face-underline-p, + ; x-font-regexp + +;; Return t if the device (which can be changed during an emacs +;; session) can handle colors. +;; This is function is not yet implemented for GNU emacs. +(defun ps-color-device () + (if (and (eq ps-print-emacs-type 'xemacs) + (>= emacs-minor-version 12)) + (eq (device-class) 'color) + t)) + +(require 'time-stamp) + +(defvar ps-font nil + "Font family name for ordinary text, when generating Postscript.") + +(defvar ps-font-bold nil + "Font family name for bold text, when generating Postscript.") + +(defvar ps-font-italic nil + "Font family name for italic text, when generating Postscript.") + +(defvar ps-font-bold-italic nil + "Font family name for bold italic text, when generating Postscript.") + +(defvar ps-avg-char-width nil + "The average width, in points, of a character, for generating Postscript. +This is the value that ps-print uses to determine the length, +x-dimension, of the text it has printed, and thus affects the point at +which long lines wrap around.") + +(defvar ps-space-width nil + "The width of a space character, for generating Postscript. +This value is used in expanding tab characters.") + +(defvar ps-line-height nil + "The height of a line, for generating Postscript. +This is the value that ps-print uses to determine the height, +y-dimension, of the lines of text it has printed, and thus affects the +point at which page-breaks are placed. +The line-height is *not* the same as the point size of the font.") + +(defvar ps-print-prologue-1 + "% ISOLatin1Encoding stolen from ps_init.ps in GhostScript 2.6.1.4: +/ISOLatin1Encoding where { pop } { +% -- The ISO Latin-1 encoding vector isn't known, so define it. +% -- The first half is the same as the standard encoding, +% -- except for minus instead of hyphen at code 055. +/ISOLatin1Encoding +StandardEncoding 0 45 getinterval aload pop + /minus +StandardEncoding 46 82 getinterval aload pop +%*** NOTE: the following are missing in the Adobe documentation, +%*** but appear in the displayed table: +%*** macron at 0225, dieresis at 0230, cedilla at 0233, space at 0240. +% 0200 (128) + /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef + /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef + /dotlessi /grave /acute /circumflex /tilde /macron /breve /dotaccent + /dieresis /.notdef /ring /cedilla /.notdef /hungarumlaut /ogonek /caron +% 0240 (160) + /space /exclamdown /cent /sterling + /currency /yen /brokenbar /section + /dieresis /copyright /ordfeminine /guillemotleft + /logicalnot /hyphen /registered /macron + /degree /plusminus /twosuperior /threesuperior + /acute /mu /paragraph /periodcentered + /cedilla /onesuperior /ordmasculine /guillemotright + /onequarter /onehalf /threequarters /questiondown +% 0300 (192) + /Agrave /Aacute /Acircumflex /Atilde + /Adieresis /Aring /AE /Ccedilla + /Egrave /Eacute /Ecircumflex /Edieresis + /Igrave /Iacute /Icircumflex /Idieresis + /Eth /Ntilde /Ograve /Oacute + /Ocircumflex /Otilde /Odieresis /multiply + /Oslash /Ugrave /Uacute /Ucircumflex + /Udieresis /Yacute /Thorn /germandbls +% 0340 (224) + /agrave /aacute /acircumflex /atilde + /adieresis /aring /ae /ccedilla + /egrave /eacute /ecircumflex /edieresis + /igrave /iacute /icircumflex /idieresis + /eth /ntilde /ograve /oacute + /ocircumflex /otilde /odieresis /divide + /oslash /ugrave /uacute /ucircumflex + /udieresis /yacute /thorn /ydieresis +256 packedarray def +} ifelse + +/reencodeFontISO { %def + dup + length 5 add dict % Make a new font (a new dict the same size + % as the old one) with room for our new symbols. + + begin % Make the new font the current dictionary. + + + { 1 index /FID ne + { def } { pop pop } ifelse + } forall % Copy each of the symbols from the old dictionary + % to the new one except for the font ID. + + /Encoding ISOLatin1Encoding def % Override the encoding with + % the ISOLatin1 encoding. + + % Use the font's bounding box to determine the ascent, descent, + % and overall height; don't forget that these values have to be + % transformed using the font's matrix. + +% ^ (x2 y2) +% | | +% | v +% | +----+ - - +% | | | ^ +% | | | | Ascent (usually > 0) +% | | | | +% (0 0) -> +--+----+--------> +% | | | +% | | v Descent (usually < 0) +% (x1 y1) --> +----+ - - + + FontBBox % -- x1 y1 x2 y2 + FontMatrix transform /Ascent exch def pop + FontMatrix transform /Descent exch def pop + /FontHeight Ascent Descent sub def % use `sub' because descent < 0 + + % Define these in case they're not in the FontInfo + % (also, here they're easier to get to. + /UnderlinePosition 1 def + /UnderlineThickness 1 def + + % Get the underline position and thickness if they're defined. + currentdict /FontInfo known { + FontInfo + + dup /UnderlinePosition known { + dup /UnderlinePosition get + 0 exch FontMatrix transform exch pop + /UnderlinePosition exch def + } if + + dup /UnderlineThickness known { + /UnderlineThickness get + 0 exch FontMatrix transform exch pop + /UnderlineThickness exch def + } if + + } if + + currentdict % Leave the new font on the stack + end % Stop using the font as the current dictionary. + definefont % Put the font into the font dictionary + pop % Discard the returned font. +} bind def + +/DefFont { % Font definition + findfont exch scalefont reencodeFontISO +} def + +/F { % Font selection + findfont + dup /Ascent get /Ascent exch def + dup /Descent get /Descent exch def + dup /FontHeight get /FontHeight exch def + dup /UnderlinePosition get /UnderlinePosition exch def + dup /UnderlineThickness get /UnderlineThickness exch def + setfont +} def + +/FG /setrgbcolor load def + +/bg false def +/BG { + dup /bg exch def + { mark 4 1 roll ] /bgcolor exch def } if +} def + +% B width C +% +-----------+ +% | Ascent (usually > 0) +% A + + +% | Descent (usually < 0) +% +-----------+ +% E width D + +/dobackground { % width -- + currentpoint % -- width x y + gsave + newpath + moveto % A (x y) + 0 Ascent rmoveto % B + dup 0 rlineto % C + 0 Descent Ascent sub rlineto % D + neg 0 rlineto % E + closepath + bgcolor aload pop setrgbcolor + fill + grestore +} def + +/dobackgroundstring { % string -- + stringwidth pop + dobackground +} def + +/dounderline { % fromx fromy -- + currentpoint + gsave + UnderlineThickness setlinewidth + 4 2 roll + UnderlinePosition add moveto + UnderlinePosition add lineto + stroke + grestore +} def + +/eolbg { % dobackground until right margin + PrintWidth % -- x-eol + currentpoint pop % -- cur-x + sub % -- width until eol + dobackground +} def + +/eolul { % idem for underline + PrintWidth % -- x-eol + currentpoint exch pop % -- x-eol cur-y + dounderline +} def + +/SL { % Soft Linefeed + bg { eolbg } if + ul { eolul } if + 0 currentpoint exch pop LineHeight sub moveto +} def + +/HL /SL load def % Hard Linefeed + +/sp1 { currentpoint 3 -1 roll } def + +% Some debug +/dcp { currentpoint exch 40 string cvs print (, ) print = } def +/dp { print 2 copy + exch 40 string cvs print (, ) print = } def + +/S { + bg { dup dobackgroundstring } if + ul { sp1 } if + show + ul { dounderline } if +} def + +/W { + ul { sp1 } if + ( ) stringwidth % Get the width of a space in the current font. + pop % Discard the Y component. + mul % Multiply the width of a space + % by the number of spaces to plot + bg { dup dobackground } if + 0 rmoveto + ul { dounderline } if +} def + +/BeginDoc { + % ---- save the state of the document (useful for ghostscript!) + /docState save def + % ---- [jack] Kludge: my ghostscript window is 21x27.7 instead of 21x29.7 + /JackGhostscript where { + pop 1 27.7 29.7 div scale + } if + LandscapeMode { + % ---- translate to bottom-right corner of Portrait page + LandscapePageHeight 0 translate + 90 rotate + } if + /ColumnWidth PrintWidth InterColumn add def + % ---- translate to lower left corner of TEXT + LeftMargin BottomMargin translate + % ---- define where printing will start + /f0 F % this installs Ascent + /PrintStartY PrintHeight Ascent sub def + /ColumnIndex 1 def +} def + +/EndDoc { + % ---- on last page but not last column, spit out the page + ColumnIndex 1 eq not { showpage } if + % ---- restore the state of the document (useful for ghostscript!) + docState restore +} def + +/BeginDSCPage { + % ---- when 1st column, save the state of the page + ColumnIndex 1 eq { /pageState save def } if + % ---- save the state of the column + /columnState save def +} def + +/BeginPage { + PrintHeader { + PrintHeaderFrame { HeaderFrame } if + HeaderText + } if + 0 PrintStartY moveto % move to where printing will start +} def + +/EndPage { + bg { eolbg } if + ul { eolul } if +} def + +/EndDSCPage { + ColumnIndex NumberOfColumns eq { + % ---- on last column, spit out the page + showpage + % ---- restore the state of the page + pageState restore + /ColumnIndex 1 def + } { % else + % ---- restore the state of the current column + columnState restore + % ---- and translate to the next column + ColumnWidth 0 translate + /ColumnIndex ColumnIndex 1 add def + } ifelse +} def + +/ul false def + +/UL { /ul exch def } def + +/SetHeaderLines { % nb-lines -- + /HeaderLines exch def + % ---- bottom up + HeaderPad + HeaderLines 1 sub HeaderLineHeight mul add + HeaderTitleLineHeight add + HeaderPad add + /HeaderHeight exch def +} def + +% |---------| +% | tm | +% |---------| +% | header | +% |-+-------| <-- (x y) +% | ho | +% |---------| +% | text | +% |-+-------| <-- (0 0) +% | bm | +% |---------| + +/HeaderFrameStart { % -- x y + 0 PrintHeight HeaderOffset add +} def + +/HeaderFramePath { + PrintWidth 0 rlineto + 0 HeaderHeight rlineto + PrintWidth neg 0 rlineto + 0 HeaderHeight neg rlineto +} def + +/HeaderFrame { + gsave + 0.4 setlinewidth + % ---- fill a black rectangle (the shadow of the next one) + HeaderFrameStart moveto + 1 -1 rmoveto + HeaderFramePath + 0 setgray fill + % ---- do the next rectangle ... + HeaderFrameStart moveto + HeaderFramePath + gsave 0.9 setgray fill grestore % filled with grey + gsave 0 setgray stroke grestore % drawn with black + grestore +} def + +/HeaderStart { + HeaderFrameStart + exch HeaderPad add exch % horizontal pad + % ---- bottom up + HeaderPad add % vertical pad + HeaderDescent sub + HeaderLineHeight HeaderLines 1 sub mul add +} def + +/strcat { + dup length 3 -1 roll dup length dup 4 -1 roll add string dup + 0 5 -1 roll putinterval + dup 4 2 roll exch putinterval +} def + +/pagenumberstring { + PageNumber 32 string cvs + ShowNofN { + (/) strcat + PageCount 32 string cvs strcat + } if +} def + +/HeaderText { + HeaderStart moveto + + HeaderLinesRight HeaderLinesLeft % -- rightLines leftLines + + % ---- hack: `PN 1 and' == `PN 2 modulo' + + % ---- if duplex and even page number, then exchange left and right + Duplex PageNumber 1 and 0 eq and { exch } if + + { % ---- process the left lines + aload pop + exch F + gsave + dup xcheck { exec } if + show + grestore + 0 HeaderLineHeight neg rmoveto + } forall + + HeaderStart moveto + + { % ---- process the right lines + aload pop + exch F + gsave + dup xcheck { exec } if + dup stringwidth pop + PrintWidth exch sub HeaderPad 2 mul sub 0 rmoveto + show + grestore + 0 HeaderLineHeight neg rmoveto + } forall +} def + +/ReportFontInfo { + 2 copy + /t0 3 1 roll DefFont + /t0 F + /lh FontHeight def + /sw ( ) stringwidth pop def + /aw (01234567890abcdefghijklmnopqrstuvwxyz) dup length exch + stringwidth pop exch div def + /t1 12 /Helvetica-Oblique DefFont + /t1 F + gsave + (For ) show + 128 string cvs show + ( ) show + 32 string cvs show + ( point, the line height is ) show + lh 32 string cvs show + (, the space width is ) show + sw 32 string cvs show + (,) show + grestore + 0 FontHeight neg rmoveto + gsave + (and a crude estimate of average character width is ) show + aw 32 string cvs show + (.) show + grestore + 0 FontHeight neg rmoveto +} def + +/cm { % cm to point + 72 mul 2.54 div +} def + +/ReportAllFontInfo { + FontDirectory + { % key = font name value = font dictionary + pop 10 exch ReportFontInfo + } forall +} def + +% 3 cm 20 cm moveto 10 /Courier ReportFontInfo showpage +% 3 cm 20 cm moveto ReportAllFontInfo showpage + +") + +(defvar ps-print-prologue-2 + " +% ---- These lines must be kept together because... + +/h0 F +/HeaderTitleLineHeight FontHeight def + +/h1 F +/HeaderLineHeight FontHeight def +/HeaderDescent Descent def + +% ---- ...because `F' has a side-effect on `FontHeight' and `Descent' + +") + +;; Start Editing Here: + +(defvar ps-source-buffer nil) +(defvar ps-spool-buffer-name "*PostScript*") +(defvar ps-spool-buffer nil) + +(defvar ps-output-head nil) +(defvar ps-output-tail nil) + +(defvar ps-page-count 0) +(defvar ps-showpage-count 0) + +(defvar ps-current-font 0) +(defvar ps-current-underline-p nil) +(defvar ps-default-color (if ps-print-color-p ps-default-fg)) ; black +(defvar ps-current-color ps-default-color) +(defvar ps-current-bg nil) + +(defvar ps-razchunk 0) + +(defvar ps-color-format + (if (eq ps-print-emacs-type 'emacs) + + ;;Emacs understands the %f format; we'll + ;;use it to limit color RGB values to + ;;three decimals to cut down some on the + ;;size of the PostScript output. + "%0.3f %0.3f %0.3f" + + ;; Lucid emacsen will have to make do with + ;; %s (princ) for floats. + "%s %s %s")) + +;; These values determine how much print-height to deduct when headers +;; are turned on. This is a pretty clumsy way of handling it, but +;; it'll do for now. + +(defvar ps-header-font) +(defvar ps-header-title-font) + +(defvar ps-header-line-height) +(defvar ps-header-title-line-height) +(defvar ps-header-pad 0 + "Vertical and horizontal space in points (1/72 inch) between the header frame +and the text it contains.") + +;; Define accessors to the dimensions list. + +(defmacro ps-page-dimensions-get-width (dims) `(nth 0 ,dims)) +(defmacro ps-page-dimensions-get-height (dims) `(nth 1 ,dims)) + +(defvar ps-landscape-page-height) + +(defvar ps-print-width nil) +(defvar ps-print-height nil) + +(defvar ps-height-remaining) +(defvar ps-width-remaining) + +(defvar ps-ref-bold-faces nil) +(defvar ps-ref-italic-faces nil) +(defvar ps-ref-underlined-faces nil) + +(defvar ps-print-color-scale nil) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Internal functions + +(defun ps-line-lengths-internal () + "Display the correspondence between a line length and a font size, +using the current ps-print setup. +Try: pr -t file | awk '{printf \"%3d %s\n\", length($0), $0}' | sort -r | head" + (let ((buf (get-buffer-create "*Line-lengths*")) + (ifs ps-font-size) ; initial font size + (icw ps-avg-char-width) ; initial character width + (print-width (progn (ps-get-page-dimensions) + ps-print-width)) + (ps-setup (ps-setup)) ; setup for the current buffer + (fs-min 5) ; minimum font size + cw-min ; minimum character width + nb-cpl-max ; maximum nb of characters per line + (fs-max 14) ; maximum font size + cw-max ; maximum character width + nb-cpl-min ; minimum nb of characters per line + fs ; current font size + cw ; current character width + nb-cpl ; current nb of characters per line + ) + (setq cw-min (/ (* icw fs-min) ifs) + nb-cpl-max (floor (/ print-width cw-min)) + cw-max (/ (* icw fs-max) ifs) + nb-cpl-min (floor (/ print-width cw-max))) + (setq nb-cpl nb-cpl-min) + (set-buffer buf) + (goto-char (point-max)) + (if (not (bolp)) (insert "\n")) + (insert ps-setup) + (insert "nb char per line / font size\n") + (while (<= nb-cpl nb-cpl-max) + (setq cw (/ print-width (float nb-cpl)) + fs (/ (* ifs cw) icw)) + (insert (format "%3s %s\n" nb-cpl fs)) + (setq nb-cpl (1+ nb-cpl))) + (insert "\n") + (display-buffer buf 'not-this-window))) + +(defun ps-nb-pages (nb-lines) + "Display an approximate correspondence between a font size and the number +of pages the number of lines would require to print +using the current ps-print setup." + (let ((buf (get-buffer-create "*Nb-Pages*")) + (ifs ps-font-size) ; initial font size + (ilh ps-line-height) ; initial line height + (page-height (progn (ps-get-page-dimensions) + ps-print-height)) + (ps-setup (ps-setup)) ; setup for the current buffer + (fs-min 4) ; minimum font size + lh-min ; minimum line height + nb-lpp-max ; maximum nb of lines per page + nb-page-min ; minimum nb of pages + (fs-max 14) ; maximum font size + lh-max ; maximum line height + nb-lpp-min ; minimum nb of lines per page + nb-page-max ; maximum nb of pages + fs ; current font size + lh ; current line height + nb-lpp ; current nb of lines per page + nb-page ; current nb of pages + ) + (setq lh-min (/ (* ilh fs-min) ifs) + nb-lpp-max (floor (/ page-height lh-min)) + nb-page-min (ceiling (/ (float nb-lines) nb-lpp-max)) + lh-max (/ (* ilh fs-max) ifs) + nb-lpp-min (floor (/ page-height lh-max)) + nb-page-max (ceiling (/ (float nb-lines) nb-lpp-min))) + (setq nb-page nb-page-min) + (set-buffer buf) + (goto-char (point-max)) + (if (not (bolp)) (insert "\n")) + (insert ps-setup) + (insert (format "%d lines\n" nb-lines)) + (insert "nb page / font size\n") + (while (<= nb-page nb-page-max) + (setq nb-lpp (ceiling (/ nb-lines (float nb-page))) + lh (/ page-height nb-lpp) + fs (/ (* ifs lh) ilh)) + (insert (format "%s %s\n" nb-page fs)) + (setq nb-page (1+ nb-page))) + (insert "\n") + (display-buffer buf 'not-this-window))) + +(defun ps-select-font () + "Choose the font name and size (scaling data)." + (let ((assoc (assq ps-font-family ps-font-info-database)) + l fn fb fi bi sz lh sw aw) + (if (null assoc) + (error "Don't have data to scale font %s. Known fonts families are %s" + ps-font-family + (mapcar 'car ps-font-info-database))) + (setq l (cdr assoc) + fn (prog1 (car l) (setq l (cdr l))) ; need `pop' + fb (prog1 (car l) (setq l (cdr l))) + fi (prog1 (car l) (setq l (cdr l))) + bi (prog1 (car l) (setq l (cdr l))) + sz (prog1 (car l) (setq l (cdr l))) + lh (prog1 (car l) (setq l (cdr l))) + sw (prog1 (car l) (setq l (cdr l))) + aw (prog1 (car l) (setq l (cdr l)))) + + (setq ps-font fn) + (setq ps-font-bold fb) + (setq ps-font-italic fi) + (setq ps-font-bold-italic bi) + ;; These data just need to be rescaled: + (setq ps-line-height (/ (* lh ps-font-size) sz)) + (setq ps-space-width (/ (* sw ps-font-size) sz)) + (setq ps-avg-char-width (/ (* aw ps-font-size) sz)) + ps-font-family)) + +(defun ps-select-header-font () + "Choose the font name and size (scaling data) for the header." + (let ((assoc (assq ps-header-font-family ps-font-info-database)) + l fn fb fi bi sz lh sw aw) + (if (null assoc) + (error "Don't have data to scale font %s. Known fonts families are %s" + ps-font-family + (mapcar 'car ps-font-info-database))) + (setq l (cdr assoc) + fn (prog1 (car l) (setq l (cdr l))) ; need `pop' + fb (prog1 (car l) (setq l (cdr l))) + fi (prog1 (car l) (setq l (cdr l))) + bi (prog1 (car l) (setq l (cdr l))) + sz (prog1 (car l) (setq l (cdr l))) + lh (prog1 (car l) (setq l (cdr l))) + sw (prog1 (car l) (setq l (cdr l))) + aw (prog1 (car l) (setq l (cdr l)))) + + ;; Font name + (setq ps-header-font fn) + (setq ps-header-title-font fb) + ;; Line height: These data just need to be rescaled: + (setq ps-header-title-line-height (/ (* lh ps-header-title-font-size) sz)) + (setq ps-header-line-height (/ (* lh ps-header-font-size) sz)) + ps-header-font-family)) + +(defun ps-get-page-dimensions () + (let ((page-dimensions (cdr (assq ps-paper-type ps-page-dimensions-database))) + page-width page-height) + (cond + ((null page-dimensions) + (error "`ps-paper-type' must be one of:\n%s" + (mapcar 'car ps-page-dimensions-database))) + ((< ps-number-of-columns 1) + (error "The number of columns %d should not be negative"))) + + (ps-select-font) + (ps-select-header-font) + + (setq page-width (ps-page-dimensions-get-width page-dimensions) + page-height (ps-page-dimensions-get-height page-dimensions)) + + ;; Landscape mode + (if ps-landscape-mode + ;; exchange width and height + (setq page-width (prog1 page-height (setq page-height page-width)))) + + ;; It is used to get the lower right corner (only in landscape mode) + (setq ps-landscape-page-height page-height) + + ;; | lm | text | ic | text | ic | text | rm | + ;; page-width == lm + n * pw + (n - 1) * ic + rm + ;; => pw == (page-width - lm -rm - (n - 1) * ic) / n + (setq ps-print-width + (/ (- page-width + ps-left-margin ps-right-margin + (* (1- ps-number-of-columns) ps-inter-column)) + ps-number-of-columns)) + (if (<= ps-print-width 0) + (error "Bad horizontal layout: +page-width == %s +ps-left-margin == %s +ps-right-margin == %s +ps-inter-column == %s +ps-number-of-columns == %s +| lm | text | ic | text | ic | text | rm | +page-width == lm + n * print-width + (n - 1) * ic + rm +=> print-width == %d !" + page-width + ps-left-margin + ps-right-margin + ps-inter-column + ps-number-of-columns + ps-print-width)) + + (setq ps-print-height + (- page-height ps-bottom-margin ps-top-margin)) + (if (<= ps-print-height 0) + (error "Bad vertical layout: +ps-top-margin == %s +ps-bottom-margin == %s +page-height == bm + print-height + tm +=> print-height == %d !" + ps-top-margin + ps-bottom-margin + ps-print-height)) + ;; If headers are turned on, deduct the height of the header from + ;; the print height. + (cond + (ps-print-header + (setq ps-header-pad + (* ps-header-line-pad ps-header-title-line-height)) + (setq ps-print-height + (- ps-print-height + ps-header-offset + ps-header-pad + ps-header-title-line-height + (* ps-header-line-height (- ps-header-lines 1)) + ps-header-pad)))) + (if (<= ps-print-height 0) + (error "Bad vertical layout: +ps-top-margin == %s +ps-bottom-margin == %s +ps-header-offset == %s +ps-header-pad == %s +header-height == %s +page-height == bm + print-height + tm - ho - hh +=> print-height == %d !" + ps-top-margin + ps-bottom-margin + ps-header-offset + ps-header-pad + (+ ps-header-pad + ps-header-title-line-height + (* ps-header-line-height (- ps-header-lines 1)) + ps-header-pad) + ps-print-height)))) + +(defun ps-print-preprint (&optional filename) + (if (and filename + (or (numberp filename) + (listp filename))) + (let* ((name (concat (buffer-name) ".ps")) + (prompt (format "Save PostScript to file: (default %s) " + name)) + (res (read-file-name prompt default-directory name nil))) + (if (file-directory-p res) + (expand-file-name name (file-name-as-directory res)) + res)))) + +;; The following functions implement a simple list-buffering scheme so +;; that ps-print doesn't have to repeatedly switch between buffers +;; while spooling. The functions ps-output and ps-output-string build +;; up the lists; the function ps-flush-output takes the lists and +;; insert its contents into the spool buffer (*PostScript*). + +(defun ps-output-string-prim (string) + (insert "(") ;insert start-string delimiter + (save-excursion ;insert string + (insert string)) + + ;; Find and quote special characters as necessary for PS + (while (re-search-forward "[()\\]" nil t) + (save-excursion + (forward-char -1) + (insert "\\"))) + + (goto-char (point-max)) + (insert ")")) ;insert end-string delimiter + +(defun ps-init-output-queue () + (setq ps-output-head (list "")) + (setq ps-output-tail ps-output-head)) + +(defun ps-output (&rest args) + (setcdr ps-output-tail args) + (while (cdr ps-output-tail) + (setq ps-output-tail (cdr ps-output-tail)))) + +(defun ps-output-string (string) + (ps-output t string)) + +(defun ps-flush-output () + (save-excursion + (set-buffer ps-spool-buffer) + (goto-char (point-max)) + (while ps-output-head + (let ((it (car ps-output-head))) + (if (not (eq t it)) + (insert it) + (setq ps-output-head (cdr ps-output-head)) + (ps-output-string-prim (car ps-output-head)))) + (setq ps-output-head (cdr ps-output-head)))) + (ps-init-output-queue)) + +(defun ps-insert-file (fname) + (ps-flush-output) + + ;; Check to see that the file exists and is readable; if not, throw + ;; an error. + (if (not (file-readable-p fname)) + (error "Could not read file `%s'" fname)) + + (save-excursion + (set-buffer ps-spool-buffer) + (goto-char (point-max)) + (insert-file fname))) + +;; These functions insert the arrays that define the contents of the +;; headers. + +(defun ps-generate-header-line (fonttag &optional content) + (ps-output " [ " fonttag " ") + (cond + ;; Literal strings should be output as is -- the string must + ;; contain its own PS string delimiters, '(' and ')', if necessary. + ((stringp content) + (ps-output content)) + + ;; Functions are called -- they should return strings; they will be + ;; inserted as strings and the PS string delimiters added. + ((and (symbolp content) (fboundp content)) + (ps-output-string (funcall content))) + + ;; Variables will have their contents inserted. They should + ;; contain strings, and will be inserted as strings. + ((and (symbolp content) (boundp content)) + (ps-output-string (symbol-value content))) + + ;; Anything else will get turned into an empty string. + (t + (ps-output-string ""))) + (ps-output " ]\n")) + +(defun ps-generate-header (name contents) + (ps-output "/" name " [\n") + (if (> ps-header-lines 0) + (let ((count 1)) + (ps-generate-header-line "/h0" (car contents)) + (while (and (< count ps-header-lines) + (setq contents (cdr contents))) + (ps-generate-header-line "/h1" (car contents)) + (setq count (+ count 1))) + (ps-output "] def\n")))) + +(defun ps-output-boolean (name bool) + (ps-output (format "/%s %s def\n" name (if bool "true" "false")))) + +(defun ps-begin-file () + (ps-get-page-dimensions) + (setq ps-showpage-count 0) + + (ps-output ps-adobe-tag) + (ps-output "%%Title: " (buffer-name) "\n") ;Take job name from name of + ;first buffer printed + (ps-output "%%Creator: " (user-full-name) "\n") + (ps-output "%%CreationDate: " + (time-stamp-hh:mm:ss) " " (time-stamp-mon-dd-yyyy) "\n") + (ps-output "%%Pages: (atend)\n") + (ps-output "%%EndComments\n\n") + + (ps-output "%%BeginProlog\n") + (ps-output-boolean "LandscapeMode" ps-landscape-mode) + (ps-output (format "/NumberOfColumns %d def\n" ps-number-of-columns)) + + (ps-output (format "/LandscapePageHeight %s def\n" ps-landscape-page-height)) + (ps-output (format "/PrintWidth %s def\n" ps-print-width)) + (ps-output (format "/PrintHeight %s def\n" ps-print-height)) + + (ps-output (format "/LeftMargin %s def\n" ps-left-margin)) + (ps-output (format "/RightMargin %s def\n" ps-right-margin)) ; not used + (ps-output (format "/InterColumn %s def\n" ps-inter-column)) + + (ps-output (format "/BottomMargin %s def\n" ps-bottom-margin)) + (ps-output (format "/TopMargin %s def\n" ps-top-margin)) ; not used + (ps-output (format "/HeaderOffset %s def\n" ps-header-offset)) + (ps-output (format "/HeaderPad %s def\n" ps-header-pad)) + + (ps-output-boolean "PrintHeader" ps-print-header) + (ps-output-boolean "PrintHeaderFrame" ps-print-header-frame) + (ps-output-boolean "ShowNofN" ps-show-n-of-n) + (ps-output-boolean "Duplex" ps-spool-duplex) + + (ps-output (format "/LineHeight %s def\n" ps-line-height)) + + (ps-output ps-print-prologue-1) + (ps-output "%%EndProlog\n\n") + + + (ps-output "%%BeginSetup\n") + + ;; Header fonts + (ps-output ; /h0 14 /Helvetica-Bold Font + (format "/h0 %s /%s DefFont\n" ps-header-title-font-size ps-header-title-font)) + (ps-output ; /h1 12 /Helvetica Font + (format "/h1 %s /%s DefFont\n" ps-header-font-size ps-header-font)) + + (ps-output ps-print-prologue-2) + + ;; Text fonts + (ps-output (format "/f0 %s /%s DefFont\n" ps-font-size ps-font)) + (ps-output (format "/f1 %s /%s DefFont\n" ps-font-size ps-font-bold)) + (ps-output (format "/f2 %s /%s DefFont\n" ps-font-size ps-font-italic)) + (ps-output (format "/f3 %s /%s DefFont\n" ps-font-size ps-font-bold-italic)) + + (ps-output "\nBeginDoc\n\n") + (ps-output "%%EndSetup\n") +) + +(defun ps-header-dirpart () + (let ((fname (buffer-file-name))) + (if fname + (if (string-equal (buffer-name) (file-name-nondirectory fname)) + (file-name-directory fname) + fname) + ""))) + +(defun ps-get-buffer-name () + (cond + ;; Indulge Jim this little easter egg: + ((string= (buffer-name) "ps-print.el") + "Hey, Cool! It's ps-print.el!!!") + ;; Indulge Jack this other little easter egg: + ((string= (buffer-name) "sokoban.el") + "Super! C'est sokoban.el!") + (t (buffer-name)))) + +(defun ps-begin-job () + (setq ps-page-count 0)) + +(defun ps-end-file () + (ps-output "\n\n%%Trailer\n") + (ps-output (format "%%%%Pages: %d\n" (1+ (/ (1- ps-page-count) + ps-number-of-columns)))) + (ps-output "EndDoc\n") + (ps-output "%%EOF\n")) + +(defun ps-next-page () + (ps-end-page) + (ps-flush-output) + (ps-begin-page)) + +(defun ps-begin-page (&optional dummypage) + (ps-get-page-dimensions) + (setq ps-width-remaining ps-print-width) + (setq ps-height-remaining ps-print-height) + + ;; Print only when a new real page begins. + (when (zerop (mod ps-page-count ps-number-of-columns)) + (ps-output (format "\n%%%%Page: %d %d\n" + (1+ (/ ps-page-count ps-number-of-columns)) + (1+ (/ ps-page-count ps-number-of-columns))))) + + (ps-output "BeginDSCPage\n") + (ps-output (format "/PageNumber %d def\n" (incf ps-page-count))) + (ps-output "/PageCount 0 def\n") + + (when ps-print-header + (ps-generate-header "HeaderLinesLeft" ps-left-header) + (ps-generate-header "HeaderLinesRight" ps-right-header) + (ps-output (format "%d SetHeaderLines\n" ps-header-lines))) + + (ps-output "BeginPage\n") + (ps-set-font ps-current-font) + (ps-set-bg ps-current-bg) + (ps-set-color ps-current-color) + (ps-set-underline ps-current-underline-p)) + +(defun ps-end-page () + (setq ps-showpage-count (+ 1 ps-showpage-count)) + (ps-output "EndPage\n") + (ps-output "EndDSCPage\n")) + +(defun ps-dummy-page () + (setq ps-showpage-count (+ 1 ps-showpage-count)) + (ps-output "%%Page: " (format "- %d\n" ps-showpage-count) + "BeginDSCPage +/PrintHeader false def +BeginPage +EndPage +EndDSCPage\n")) + +(defun ps-next-line () + (if (< ps-height-remaining ps-line-height) + (ps-next-page) + (setq ps-width-remaining ps-print-width) + (setq ps-height-remaining (- ps-height-remaining ps-line-height)) + (ps-hard-lf))) + +(defun ps-continue-line () + (if (< ps-height-remaining ps-line-height) + (ps-next-page) + (setq ps-width-remaining ps-print-width) + (setq ps-height-remaining (- ps-height-remaining ps-line-height)) + (ps-soft-lf))) + +;; [jack] Why hard and soft ? + +(defun ps-hard-lf () + (ps-output "HL\n")) + +(defun ps-soft-lf () + (ps-output "SL\n")) + +(defun ps-find-wrappoint (from to char-width) + (let ((avail (truncate (/ ps-width-remaining char-width))) + (todo (- to from))) + (if (< todo avail) + (cons to (* todo char-width)) + (cons (+ from avail) ps-width-remaining)))) + +(defun ps-basic-plot-string (from to &optional bg-color) + (let* ((wrappoint (ps-find-wrappoint from to ps-avg-char-width)) + (to (car wrappoint)) + (string (buffer-substring from to))) + (ps-output-string string) + (ps-output " S\n") + wrappoint)) + +(defun ps-basic-plot-whitespace (from to &optional bg-color) + (let* ((wrappoint (ps-find-wrappoint from to ps-space-width)) + (to (car wrappoint))) + + (ps-output (format "%d W\n" (- to from))) + wrappoint)) + +(defun ps-plot (plotfunc from to &optional bg-color) + (while (< from to) + (let* ((wrappoint (funcall plotfunc from to bg-color)) + (plotted-to (car wrappoint)) + (plotted-width (cdr wrappoint))) + (setq from plotted-to) + (setq ps-width-remaining (- ps-width-remaining plotted-width)) + (if (< from to) + (ps-continue-line)))) + (if ps-razzle-dazzle + (let* ((q-todo (- (point-max) (point-min))) + (q-done (- (point) (point-min))) + (chunkfrac (/ q-todo 8)) + (chunksize (if (> chunkfrac 1000) 1000 chunkfrac))) + (if (> (- q-done ps-razchunk) chunksize) + (let (foo) + (setq ps-razchunk q-done) + (setq foo + (if (< q-todo 100) + (/ (* 100 q-done) q-todo) + (/ q-done (/ q-todo 100)))) + (message "Formatting...%3d%%" foo)))))) + +(defun ps-set-font (font) + (setq ps-current-font font) + (ps-output (format "/f%d F\n" ps-current-font))) + +(defun ps-set-bg (color) + (if (setq ps-current-bg color) + (ps-output (format ps-color-format (nth 0 color) (nth 1 color) + (nth 2 color)) + " true BG\n") + (ps-output "false BG\n"))) + +(defun ps-set-color (color) + (if (setq ps-current-color color) + nil + (setq ps-current-color ps-default-fg)) + (ps-output (format ps-color-format (nth 0 ps-current-color) + (nth 1 ps-current-color) (nth 2 ps-current-color)) + " FG\n")) + +(defun ps-set-underline (underline-p) + (ps-output (if underline-p "true" "false") " UL\n") + (setq ps-current-underline-p underline-p)) + +(defun ps-plot-region (from to font fg-color &optional bg-color underline-p) + + (if (not (equal font ps-current-font)) + (ps-set-font font)) + + ;; Specify a foreground color only if one's specified and it's + ;; different than the current. + (if (not (equal fg-color ps-current-color)) + (ps-set-color fg-color)) + + (if (not (equal bg-color ps-current-bg)) + (ps-set-bg bg-color)) + + ;; Toggle underlining if different. + (if (not (equal underline-p ps-current-underline-p)) + (ps-set-underline underline-p)) + + ;; Starting at the beginning of the specified region... + (save-excursion + (goto-char from) + + ;; ...break the region up into chunks separated by tabs, linefeeds, + ;; and pagefeeds, and plot each chunk. + (while (< from to) + (if (re-search-forward "[\t\n\f]" to t) + (let ((match (char-after (match-beginning 0)))) + (cond + ((= match ?\t) + (let ((linestart + (save-excursion (beginning-of-line) (point)))) + (ps-plot 'ps-basic-plot-string from (- (point) 1) + bg-color) + (forward-char -1) + (setq from (+ linestart (current-column))) + (if (re-search-forward "[ \t]+" to t) + (ps-plot 'ps-basic-plot-whitespace + from (+ linestart (current-column)) + bg-color)))) + + ((= match ?\n) + (ps-plot 'ps-basic-plot-string from (- (point) 1) + bg-color) + (ps-next-line) + ) + + ((= match ?\f) + (ps-plot 'ps-basic-plot-string from (- (point) 1) + bg-color) + (ps-next-page))) + (setq from (point))) + (ps-plot 'ps-basic-plot-string from to bg-color) + (setq from to))))) + +(defun ps-color-value (x-color-value) + ;; Scale 16-bit X-COLOR-VALUE to PostScript color value in [0, 1] interval. + (/ x-color-value ps-print-color-scale)) + +(defun ps-color-values (x-color) + (cond ((fboundp 'color-instance-rgb-components) + (if (ps-color-device) + (color-instance-rgb-components + (if (color-instance-p x-color) x-color + (if (color-specifier-p x-color) + (make-color-instance (color-name x-color)) + (make-color-instance x-color)))) + (error "No available function to determine X color values."))) + ((fboundp 'x-color-values) + (x-color-values x-color)) + (t (error "No available function to determine X color values.")))) + +(defun ps-face-attributes (face) + (let ((differs (face-differs-from-default-p face))) + (list (memq face ps-ref-bold-faces) + (memq face ps-ref-italic-faces) + (memq face ps-ref-underlined-faces) + (and differs (face-foreground face)) + (and differs (face-background face))))) + +(defun ps-face-attribute-list (face-or-list) + (if (listp face-or-list) + (let (bold-p italic-p underline-p foreground background face-attr face) + (while face-or-list + (setq face (car face-or-list)) + (setq face-attr (ps-face-attributes face)) + (setq bold-p (or bold-p (nth 0 face-attr))) + (setq italic-p (or italic-p (nth 1 face-attr))) + (setq underline-p (or underline-p (nth 2 face-attr))) + (if foreground + nil + (setq foreground (nth 3 face-attr))) + (if background + nil + (setq background (nth 4 face-attr))) + (setq face-or-list (cdr face-or-list))) + (list bold-p italic-p underline-p foreground background)) + + (ps-face-attributes face-or-list))) + +(defun ps-plot-with-face (from to face) + (if face + (let* ((face-attr (ps-face-attribute-list face)) + (bold-p (nth 0 face-attr)) + (italic-p (nth 1 face-attr)) + (underline-p (nth 2 face-attr)) + (foreground (nth 3 face-attr)) + (background (nth 4 face-attr)) + (fg-color (if (and ps-print-color-p + (ps-color-device) + foreground) + (mapcar 'ps-color-value + (ps-color-values foreground)) + ps-default-color)) + (bg-color (if (and ps-print-color-p + (ps-color-device) + background) + (mapcar 'ps-color-value + (ps-color-values background))))) + (ps-plot-region from to + (cond ((and bold-p italic-p) 3) + (italic-p 2) + (bold-p 1) + (t 0)) +; (or fg-color '(0.0 0.0 0.0)) + fg-color + bg-color underline-p)) + (goto-char to))) + + +(defun ps-emacs-face-kind-p (face kind kind-regex kind-list) + (let ((frame-font (face-font face)) + (face-defaults (face-font face t))) + (or + ;; Check FACE defaults: + (and (listp face-defaults) + (memq kind face-defaults)) + + ;; Check the user's preferences + (memq face kind-list)))) + +(defun ps-xemacs-face-kind-p (face kind kind-regex kind-list) + (let* ((frame-font + (or (face-font-instance face) (face-font-instance 'default))) + (kind-cons (and frame-font + (assq kind (font-instance-properties frame-font)))) + (kind-spec (cdr-safe kind-cons)) + (case-fold-search t)) + + (or (and kind-spec (string-match kind-regex kind-spec)) + ;; Kludge-compatible: + (memq face kind-list)))) + +(defun ps-face-bold-p (face) + (if (eq ps-print-emacs-type 'emacs) + (ps-emacs-face-kind-p face 'bold "-\\(bold\\|demibold\\)-" + ps-bold-faces) + (ps-xemacs-face-kind-p face 'WEIGHT_NAME "bold\\|demibold" + ps-bold-faces))) + +(defun ps-face-italic-p (face) + (if (eq ps-print-emacs-type 'emacs) + (ps-emacs-face-kind-p face 'italic "-[io]-" ps-italic-faces) + (or + (ps-xemacs-face-kind-p face 'ANGLE_NAME "i\\|o" ps-italic-faces) + (ps-xemacs-face-kind-p face 'SLANT "i\\|o" ps-italic-faces)))) + +(defun ps-face-underlined-p (face) + (or (face-underline-p face) + (memq face ps-underlined-faces))) + +;; Ensure that face-list is fbound. +(or (fboundp 'face-list) (defalias 'face-list 'list-faces)) + +(defun ps-build-reference-face-lists () + (if ps-auto-font-detect + (let ((faces (if (eq ps-print-emacs-type 'xemacs) + (face-list 5) + (face-list))) + the-face) + (setq ps-ref-bold-faces nil + ps-ref-italic-faces nil + ps-ref-underlined-faces nil) + (while faces + (setq the-face (car faces)) + (if (ps-face-italic-p the-face) + (setq ps-ref-italic-faces + (cons the-face ps-ref-italic-faces))) + (if (ps-face-bold-p the-face) + (setq ps-ref-bold-faces + (cons the-face ps-ref-bold-faces))) + (if (ps-face-underlined-p the-face) + (setq ps-ref-underlined-faces + (cons the-face ps-ref-underlined-faces))) + (setq faces (cdr faces)))) + (setq ps-ref-bold-faces ps-bold-faces) + (setq ps-ref-italic-faces ps-italic-faces) + (setq ps-ref-underlined-faces ps-underlined-faces)) + (setq ps-build-face-reference nil)) + +(defun ps-mapper (extent list) + (nconc list (list (list (extent-start-position extent) 'push extent) + (list (extent-end-position extent) 'pull extent))) + nil) + +(defun ps-extent-sorter (a b) + (< (extent-priority a) (extent-priority b))) + +(defun ps-print-ensure-fontified (start end) + (if (and (boundp 'lazy-lock-mode) lazy-lock-mode) + (if (fboundp 'lazy-lock-fontify-region) + (lazy-lock-fontify-region start end) ; the new + (lazy-lock-fontify-buffer))) ; the old + (if (and (boundp 'lazy-shot-mode) lazy-shot-mode) ;; temporary untill + (lazy-shot-fontify-region start end))) ;; lazy-shot is renamed + + +(defun ps-generate-postscript-with-faces (from to) + ;; Build the reference lists of faces if necessary. + (if (or ps-always-build-face-reference + ps-build-face-reference) + (progn + (message "Collecting face information...") + (ps-build-reference-face-lists))) + ;; Set the color scale. We do it here instead of in the defvar so + ;; that ps-print can be dumped into emacs. This expression can't be + ;; evaluated at dump-time because X isn't initialized. + (setq ps-print-color-scale + (if (and ps-print-color-p (ps-color-device)) + (float (car (ps-color-values "white"))) + 1.0)) + ;; Generate some PostScript. + (save-restriction + (narrow-to-region from to) + (let ((face 'default) + (position to)) + (ps-print-ensure-fontified from to) + (cond ((or (eq ps-print-emacs-type 'lucid) + (eq ps-print-emacs-type 'xemacs)) + ;; Build the list of extents... + (let ((a (cons 'dummy nil)) + record type extent extent-list) + (map-extents 'ps-mapper nil from to a) + (setq a (sort (cdr a) 'car-less-than-car)) + + (setq extent-list nil) + + ;; Loop through the extents... + (while a + (setq record (car a)) + + (setq position (car record)) + (setq record (cdr record)) + + (setq type (car record)) + (setq record (cdr record)) + + (setq extent (car record)) + + ;; Plot up to this record. + ;; XEmacs 19.12: for some reason, we're getting into a + ;; situation in which some of the records have + ;; positions less than 'from'. Since we've narrowed + ;; the buffer, this'll generate errors. This is a + ;; hack, but don't call ps-plot-with-face unless from > + ;; point-min. + (if (and (>= from (point-min)) + (<= position (point-max))) + (ps-plot-with-face from position face)) + + (cond + ((eq type 'push) + (if (extent-face extent) + (setq extent-list (sort (cons extent extent-list) + 'ps-extent-sorter)))) + + ((eq type 'pull) + (setq extent-list (sort (delq extent extent-list) + 'ps-extent-sorter)))) + + (setq face + (if extent-list + (extent-face (car extent-list)) + 'default)) + + (setq from position) + (setq a (cdr a))))) + + ((eq ps-print-emacs-type 'emacs) + (let ((property-change from) + (overlay-change from)) + (while (< from to) + (if (< property-change to) ; Don't search for property change + ; unless previous search succeeded. + (setq property-change + (next-property-change from nil to))) + (if (< overlay-change to) ; Don't search for overlay change + ; unless previous search succeeded. + (setq overlay-change + (min (next-overlay-change from) to))) + (setq position + (min property-change overlay-change)) + ;; The code below is not quite correct, + ;; because a non-nil overlay invisible property + ;; which is inactive according to the current value + ;; of buffer-invisibility-spec nonetheless overrides + ;; a face text property. + (setq face + (cond ((let ((prop (get-text-property from 'invisible))) + ;; Decide whether this invisible property + ;; really makes the text invisible. + (if (eq buffer-invisibility-spec t) + (not (null prop)) + (or (memq prop buffer-invisibility-spec) + (assq prop buffer-invisibility-spec)))) + nil) + ((get-text-property from 'face)) + (t 'default))) + (let ((overlays (overlays-at from)) + (face-priority -1)) ; text-property + (while overlays + (let* ((overlay (car overlays)) + (overlay-face (overlay-get overlay 'face)) + (overlay-invisible (overlay-get overlay 'invisible)) + (overlay-priority (or (overlay-get overlay + 'priority) + 0))) + (if (and (or overlay-invisible overlay-face) + (> overlay-priority face-priority)) + (setq face (cond ((if (eq buffer-invisibility-spec t) + (not (null overlay-invisible)) + (or (memq overlay-invisible buffer-invisibility-spec) + (assq overlay-invisible buffer-invisibility-spec))) + nil) + ((and face overlay-face))) + face-priority overlay-priority))) + (setq overlays (cdr overlays)))) + ;; Plot up to this record. + (ps-plot-with-face from position face) + (setq from position))))) + (ps-plot-with-face from to face)))) + +(defun ps-generate-postscript (from to) + (ps-plot-region from to 0 nil)) + +(defun ps-generate (buffer from to genfunc) + (let ((from (min to from)) + (to (max to from)) + ;; This avoids trouble if chars with read-only properties + ;; are copied into ps-spool-buffer. + (inhibit-read-only t)) + (save-restriction + (narrow-to-region from to) + (if ps-razzle-dazzle + (message "Formatting...%3d%%" (setq ps-razchunk 0))) + (set-buffer buffer) + (setq ps-source-buffer buffer) + (setq ps-spool-buffer (get-buffer-create ps-spool-buffer-name)) + (ps-init-output-queue) + (let (safe-marker completed-safely needs-begin-file) + (unwind-protect + (progn + (set-buffer ps-spool-buffer) + + ;; Get a marker and make it point to the current end of the + ;; buffer, If an error occurs, we'll delete everything from + ;; the end of this marker onwards. + (setq safe-marker (make-marker)) + (set-marker safe-marker (point-max)) + + (goto-char (point-min)) + (if (looking-at (regexp-quote ps-adobe-tag)) + nil + (setq needs-begin-file t)) + (save-excursion + (set-buffer ps-source-buffer) + (if needs-begin-file (ps-begin-file)) + (ps-begin-job) + (ps-begin-page)) + (set-buffer ps-source-buffer) + (funcall genfunc from to) + (ps-end-page) + + (if (and ps-spool-duplex + (= (mod ps-page-count 2) 1)) + (ps-dummy-page)) + (ps-flush-output) + + ;; Back to the PS output buffer to set the page count + (set-buffer ps-spool-buffer) + (goto-char (point-max)) + (while (re-search-backward "^/PageCount 0 def$" nil t) + (replace-match (format "/PageCount %d def" ps-page-count) t)) + + ;; Setting this variable tells the unwind form that + ;; the postscript was generated without error. + (setq completed-safely t)) + + ;; Unwind form: If some bad mojo occurred while generating + ;; postscript, delete all the postscript that was generated. + ;; This protects the previously spooled files from getting + ;; corrupted. + (if (and (markerp safe-marker) (not completed-safely)) + (progn + (set-buffer ps-spool-buffer) + (delete-region (marker-position safe-marker) (point-max)))))) + + (if ps-razzle-dazzle + (message "Formatting...done"))))) + +;; Permit dynamic evaluation at print time of ps-lpr-switches +(defun ps-do-despool (filename) + (if (or (not (boundp 'ps-spool-buffer)) + (not (symbol-value 'ps-spool-buffer))) + (message "No spooled PostScript to print") + (ps-end-file) + (ps-flush-output) + (if filename + (save-excursion + (if ps-razzle-dazzle + (message "Saving...")) + (set-buffer ps-spool-buffer) + (setq filename (expand-file-name filename)) + (write-region (point-min) (point-max) filename) + (if ps-razzle-dazzle + (message "Wrote %s" filename))) + ;; Else, spool to the printer + (if ps-razzle-dazzle + (message "Printing...")) + (save-excursion + (set-buffer ps-spool-buffer) + (if (and (eq system-type 'ms-dos) (stringp dos-ps-printer)) + (write-region (point-min) (point-max) dos-ps-printer t 0) + (let ((binary-process-input t) ; for MS-DOS + (ps-lpr-sw ; Dynamic evaluation + (ps-flatten-list (mapcar 'ps-eval-switch ps-lpr-switches)))) + (apply 'call-process-region + (point-min) (point-max) ps-lpr-command nil + (if (fboundp 'start-process) 0 nil) + nil + ps-lpr-sw)))) + (if ps-razzle-dazzle + (message "Printing...done"))) + (kill-buffer ps-spool-buffer))) + +;; Dynamic evaluation +(defun ps-eval-switch (arg) + (cond ((stringp arg) arg) + ((functionp arg) (apply arg nil)) + ((symbolp arg) (symbol-value arg)) + ((consp arg) (apply (car arg) (cdr arg))) + (t nil))) + +;; `ps-flatten-list' is defined here (copied from "message.el" and +;; enhanced to handle dotted pairs as well) until we can get some +;; sensible autoloads, or `flatten-list' gets put somewhere decent. + +;; (ps-flatten-list '((a . b) c (d . e) (f g h) i . j)) +;; => (a b c d e f g h i j) + +(defun ps-flatten-list (&rest list) + (ps-flatten-list-1 list)) + +(defun ps-flatten-list-1 (list) + (cond + ((null list) (list)) + ((consp list) + (append (ps-flatten-list-1 (car list)) + (ps-flatten-list-1 (cdr list)))) + (t (list list)))) + +(defun ps-kill-emacs-check () + (let (ps-buffer) + (if (and (setq ps-buffer (get-buffer ps-spool-buffer-name)) + (buffer-modified-p ps-buffer)) + (if (y-or-n-p "Unprinted PostScript waiting; print now? ") + (ps-despool))) + (if (and (setq ps-buffer (get-buffer ps-spool-buffer-name)) + (buffer-modified-p ps-buffer)) + (if (yes-or-no-p "Unprinted PostScript waiting; exit anyway? ") + nil + (error "Unprinted PostScript"))))) + +(if (fboundp 'add-hook) + (add-hook 'kill-emacs-hook 'ps-kill-emacs-check) + (if kill-emacs-hook + (message "Won't override existing kill-emacs-hook") + (setq kill-emacs-hook 'ps-kill-emacs-check))) + +;;; Sample Setup Code: + +;; This stuff is for anybody that's brave enough to look this far, +;; and able to figure out how to use it. It isn't really part of ps- +;; print, but I'll leave it here in hopes it might be useful: + +;; WARNING!!! The following code is *sample* code only. Don't use it +;; unless you understand what it does! + +(defmacro ps-prsc () (list 'if (list 'eq 'ps-print-emacs-type ''emacs) + [f22] ''f22)) +(defmacro ps-c-prsc () (list 'if (list 'eq 'ps-print-emacs-type ''emacs) + [C-f22] + ''(control f22))) +(defmacro ps-s-prsc () (list 'if (list 'eq 'ps-print-emacs-type ''emacs) + [S-f22] + ''(shift f22))) + +;; Look in an article or mail message for the Subject: line. To be +;; placed in ps-left-headers. +(defun ps-article-subject () + (save-excursion + (goto-char (point-min)) + (if (re-search-forward "^Subject:[ \t]+\\(.*\\)$" nil t) + (buffer-substring (match-beginning 1) (match-end 1)) + "Subject ???"))) + +;; Look in an article or mail message for the From: line. Sorta-kinda +;; understands RFC-822 addresses and can pull the real name out where +;; it's provided. To be placed in ps-left-headers. +(defun ps-article-author () + (save-excursion + (goto-char (point-min)) + (if (re-search-forward "^From:[ \t]+\\(.*\\)$" nil t) + (let ((fromstring (buffer-substring (match-beginning 1) (match-end 1)))) + (cond + + ;; Try first to match addresses that look like + ;; thompson@wg2.waii.com (Jim Thompson) + ((string-match ".*[ \t]+(\\(.*\\))" fromstring) + (substring fromstring (match-beginning 1) (match-end 1))) + + ;; Next try to match addresses that look like + ;; Jim Thompson <thompson@wg2.waii.com> + ((string-match "\\(.*\\)[ \t]+<.*>" fromstring) + (substring fromstring (match-beginning 1) (match-end 1))) + + ;; Couldn't find a real name -- show the address instead. + (t fromstring))) + "From ???"))) + +;; A hook to bind to gnus-Article-prepare-hook. This will set the ps- +;; left-headers specially for gnus articles. Unfortunately, gnus- +;; article-mode-hook is called only once, the first time the *Article* +;; buffer enters that mode, so it would only work for the first time +;; we ran gnus. The second time, this hook wouldn't get set up. The +;; only alternative is gnus-article-prepare-hook. +(defun ps-gnus-article-prepare-hook () + (setq ps-header-lines 3) + (setq ps-left-header + ;; The left headers will display the article's subject, its + ;; author, and the newsgroup it was in. + (list 'ps-article-subject 'ps-article-author 'gnus-newsgroup-name))) + +;; A hook to bind to vm-mode-hook to locally bind prsc and set the ps- +;; left-headers specially for mail messages. This header setup would +;; also work, I think, for RMAIL. +(defun ps-vm-mode-hook () + (local-set-key (ps-prsc) 'ps-vm-print-message-from-summary) + (setq ps-header-lines 3) + (setq ps-left-header + ;; The left headers will display the message's subject, its + ;; author, and the name of the folder it was in. + (list 'ps-article-subject 'ps-article-author 'buffer-name))) + +;; Every now and then I forget to switch from the *Summary* buffer to +;; the *Article* before hitting prsc, and a nicely formatted list of +;; article subjects shows up at the printer. This function, bound to +;; prsc for the gnus *Summary* buffer means I don't have to switch +;; buffers first. +;; sb: Updated for Gnus 5. +(defun ps-gnus-print-article-from-summary () + (interactive) + (let ((ps-buf (if (boundp 'gnus-article-buffer) + gnus-article-buffer + "*Article*"))) + (if (get-buffer ps-buf) + (save-excursion + (set-buffer ps-buf) + (ps-spool-buffer-with-faces))))) + +;; See ps-gnus-print-article-from-summary. This function does the +;; same thing for vm. +(defun ps-vm-print-message-from-summary () + (interactive) + (if (and (boundp 'vm-mail-buffer) (symbol-value 'vm-mail-buffer)) + (save-excursion + (set-buffer (symbol-value 'vm-mail-buffer)) + (ps-spool-buffer-with-faces)))) + +;; A hook to bind to bind to gnus-summary-setup-buffer to locally bind +;; prsc. +(defun ps-gnus-summary-setup () + (local-set-key (ps-prsc) 'ps-gnus-print-article-from-summary)) + +;; Look in an article or mail message for the Subject: line. To be +;; placed in ps-left-headers. +(defun ps-info-file () + (save-excursion + (goto-char (point-min)) + (if (re-search-forward "File:[ \t]+\\([^, \t\n]*\\)" nil t) + (buffer-substring (match-beginning 1) (match-end 1)) + "File ???"))) + +;; Look in an article or mail message for the Subject: line. To be +;; placed in ps-left-headers. +(defun ps-info-node () + (save-excursion + (goto-char (point-min)) + (if (re-search-forward "Node:[ \t]+\\([^,\t\n]*\\)" nil t) + (buffer-substring (match-beginning 1) (match-end 1)) + "Node ???"))) + +(defun ps-info-mode-hook () + (setq ps-left-header + ;; The left headers will display the node name and file name. + (list 'ps-info-node 'ps-info-file))) + +;; WARNING! The following function is a *sample* only, and is *not* +;; meant to be used as a whole unless you understand what the effects +;; will be! (In fact, this is a copy of Jim's setup for ps-print -- +;; I'd be very surprised if it was useful to *anybody*, without +;; modification.) + +(defun ps-jts-ps-setup () + (global-set-key (ps-prsc) 'ps-spool-buffer-with-faces) ;f22 is prsc + (global-set-key (ps-s-prsc) 'ps-spool-region-with-faces) + (global-set-key (ps-c-prsc) 'ps-despool) + (add-hook 'gnus-article-prepare-hook 'ps-gnus-article-prepare-hook) + (add-hook 'gnus-summary-mode-hook 'ps-gnus-summary-setup) + (add-hook 'vm-mode-hook 'ps-vm-mode-hook) + (add-hook 'vm-mode-hooks 'ps-vm-mode-hook) + (add-hook 'Info-mode-hook 'ps-info-mode-hook) + (setq ps-spool-duplex t) + (setq ps-print-color-p nil) + (setq ps-lpr-command "lpr") + (setq ps-lpr-switches '("-Jjct,duplex_long")) + 'ps-jts-ps-setup) + +;; WARNING! The following function is a *sample* only, and is *not* +;; meant to be used as a whole unless it corresponds to your needs. +;; (In fact, this is a copy of Jack's setup for ps-print -- +;; I would not be that surprised if it was useful to *anybody*, +;; without modification.) + +(defun ps-jack-setup () + (setq ps-print-color-p 'nil + ps-lpr-command "lpr" + ps-lpr-switches (list) + + ps-paper-type 'a4 + ps-landscape-mode 't + ps-number-of-columns 2 + + ps-left-margin (/ (* 72 1.0) 2.54) ; 1.0 cm + ps-right-margin (/ (* 72 1.0) 2.54) ; 1.0 cm + ps-inter-column (/ (* 72 1.0) 2.54) ; 1.0 cm + ps-bottom-margin (/ (* 72 1.5) 2.54) ; 1.5 cm + ps-top-margin (/ (* 72 1.5) 2.54) ; 1.5 cm + ps-header-offset (/ (* 72 1.0) 2.54) ; 1.0 cm + ps-header-line-pad .15 + ps-print-header t + ps-print-header-frame t + ps-header-lines 2 + ps-show-n-of-n t + ps-spool-duplex nil + + ps-font-family 'Courier + ps-font-size 5.5 + ps-header-font-family 'Helvetica + ps-header-font-size 6 + ps-header-title-font-size 8) + 'ps-jack-setup) + +(provide 'ps-print) + +;;; ps-print.el ends here diff --git a/rlogin.el b/rlogin.el new file mode 100644 --- /dev/null +++ b/rlogin.el @@ -0,0 +1,341 @@ +;;; rlogin.el --- remote login interface + +;; Author: Noah Friedman +;; Maintainer: Noah Friedman <friedman@prep.ai.mit.edu> +;; Keywords: unix, comm + +;; Copyright (C) 1992, 1993, 1994, 1995 Free Software Foundation, Inc. +;; +;; 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 2, 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, write to: The Free Software Foundation, +;; Inc.; 675 Massachusetts Avenue.; Cambridge, MA 02139, USA. + +;; $Id$ + +;;; Commentary: + +;; Support for remote logins using `rlogin'. +;; This program is layered on top of shell.el; the code here only accounts +;; for the variations needed to handle a remote process, e.g. directory +;; tracking and the sending of some special characters. + +;; If you wish for rlogin mode to prompt you in the minibuffer for +;; passwords when a password prompt appears, just enter m-x send-invisible +;; and type in your line, or add `comint-watch-for-password-prompt' to +;; `comint-output-filter-functions'. + +;;; Code: + +(require 'comint) +(require 'shell) + +(defgroup rlogin nil + "Remote login interface" + :group 'processes + :group 'unix) + + +(defcustom rlogin-program "rlogin" + "*Name of program to invoke rlogin" + :type 'string + :group 'rlogin) + +(defcustom rlogin-explicit-args nil + "*List of arguments to pass to rlogin on the command line." + :type '(repeat (string :tag "Argument")) + :group 'rlogin) + +(defcustom rlogin-mode-hook nil + "*Hooks to run after setting current buffer to rlogin-mode." + :type 'hook + :group 'rlogin) + +(defcustom rlogin-process-connection-type nil + "*If non-`nil', use a pty for the local rlogin process. +If `nil', use a pipe (if pipes are supported on the local system). + +Generally it is better not to waste ptys on systems which have a static +number of them. On the other hand, some implementations of `rlogin' assume +a pty is being used, and errors will result from using a pipe instead." + :type '(choice (const :tag "ptys" t) + (const :tag "pipes" nil)) + :group 'rlogin) + +(defcustom rlogin-directory-tracking-mode 'local + "*Control whether and how to do directory tracking in an rlogin buffer. + +nil means don't do directory tracking. + +t means do so using an ftp remote file name. + +Any other value means do directory tracking using local file names. +This works only if the remote machine and the local one +share the same directories (through NFS). This is the default. + +This variable becomes local to a buffer when set in any fashion for it. + +It is better to use the function of the same name to change the behavior of +directory tracking in an rlogin session once it has begun, rather than +simply setting this variable, since the function does the necessary +re-synching of directories." + :type '(choice (const :tag "off" nil) + (const :tag "ftp" t) + (const :tag "local" local)) + :group 'rlogin) + +(make-variable-buffer-local 'rlogin-directory-tracking-mode) + +(defcustom rlogin-host nil + "*The name of the remote host. This variable is buffer-local." + :type '(choice (const nil) string) + :group 'rlogin) + +(defcustom rlogin-remote-user nil + "*The username used on the remote host. +This variable is buffer-local and defaults to your local user name. +If rlogin is invoked with the `-l' option to specify the remote username, +this variable is set from that." + :type '(choice (const nil) string) + :group 'rlogin) + +;; Initialize rlogin mode map. +(defvar rlogin-mode-map '()) +(cond + ((null rlogin-mode-map) + (setq rlogin-mode-map (if (consp shell-mode-map) + (cons 'keymap shell-mode-map) + (copy-keymap shell-mode-map))) + (define-key rlogin-mode-map "\C-c\C-c" 'rlogin-send-Ctrl-C) + (define-key rlogin-mode-map "\C-c\C-d" 'rlogin-send-Ctrl-D) + (define-key rlogin-mode-map "\C-c\C-z" 'rlogin-send-Ctrl-Z) + (define-key rlogin-mode-map "\C-c\C-\\" 'rlogin-send-Ctrl-backslash) + (define-key rlogin-mode-map "\C-d" 'rlogin-delchar-or-send-Ctrl-D) + (define-key rlogin-mode-map "\C-i" 'rlogin-tab-or-complete))) + + +;;;###autoload (add-hook 'same-window-regexps "^\\*rlogin-.*\\*\\(\\|<[0-9]+>\\)") + +(defvar rlogin-history nil) + +;;;###autoload +(defun rlogin (input-args &optional buffer) + "Open a network login connection to HOST via the `rlogin' program. +Input is sent line-at-a-time to the remote connection. + +Communication with the remote host is recorded in a buffer `*rlogin-HOST*' +\(or `*rlogin-USER@HOST*' if the remote username differs\). +If a prefix argument is given and the buffer `*rlogin-HOST*' already exists, +a new buffer with a different connection will be made. + +When called from a program, if the optional second argument is a string or +buffer, it names the buffer to use. + +The variable `rlogin-program' contains the name of the actual program to +run. It can be a relative or absolute path. + +The variable `rlogin-explicit-args' is a list of arguments to give to +the rlogin when starting. They are added after any arguments given in +INPUT-ARGS. + +If the default value of `rlogin-directory-tracking-mode' is t, then the +default directory in that buffer is set to a remote (FTP) file name to +access your home directory on the remote machine. Occasionally this causes +an error, if you cannot access the home directory on that machine. This +error is harmless as long as you don't try to use that default directory. + +If `rlogin-directory-tracking-mode' is neither t nor nil, then the default +directory is initially set up to your (local) home directory. +This is useful if the remote machine and your local machine +share the same files via NFS. This is the default. + +If you wish to change directory tracking styles during a session, use the +function `rlogin-directory-tracking-mode' rather than simply setting the +variable." + (interactive (list + (read-from-minibuffer "rlogin arguments (hostname first): " + nil nil nil 'rlogin-history) + current-prefix-arg)) + + (let* ((process-connection-type rlogin-process-connection-type) + (args (if rlogin-explicit-args + (append (rlogin-parse-words input-args) + rlogin-explicit-args) + (rlogin-parse-words input-args))) + (host (car args)) + (user (or (car (cdr (member "-l" args))) + (user-login-name))) + (buffer-name (if (string= user (user-login-name)) + (format "*rlogin-%s*" host) + (format "*rlogin-%s@%s*" user host))) + proc) + + (cond ((null buffer)) + ((or (stringp buffer) (bufferp buffer)) + (setq buffer-name buffer)) + ((numberp buffer) + (setq buffer-name (format "%s<%d>" buffer-name buffer))) + (t + (setq buffer-name (generate-new-buffer-name buffer-name)))) + + (pop-to-buffer buffer-name) + (cond + ((comint-check-proc buffer-name)) + (t + (comint-exec (current-buffer) buffer-name rlogin-program nil args) + (setq proc (get-process buffer-name)) + ;; Set process-mark to point-max in case there is text in the + ;; buffer from a previous exited process. + (set-marker (process-mark proc) (point-max)) + (rlogin-mode) + + ;; comint-output-filter-functions is just like a hook, except that the + ;; functions in that list are passed arguments. add-hook serves well + ;; enough for modifying it. + (add-hook 'comint-output-filter-functions 'rlogin-carriage-filter) + + (make-local-variable 'rlogin-host) + (setq rlogin-host host) + (make-local-variable 'rlogin-remote-user) + (setq rlogin-remote-user user) + + (cond + ((eq rlogin-directory-tracking-mode t) + ;; Do this here, rather than calling the tracking mode function, to + ;; avoid a gratuitous resync check; the default should be the + ;; user's home directory, be it local or remote. + (setq comint-file-name-prefix + (concat "/" rlogin-remote-user "@" rlogin-host ":")) + (cd-absolute comint-file-name-prefix)) + ((null rlogin-directory-tracking-mode)) + (t + (cd-absolute (concat comint-file-name-prefix "~/")))))))) + +(defun rlogin-mode () + "Set major-mode for rlogin sessions. +If `rlogin-mode-hook' is set, run it." + (interactive) + (kill-all-local-variables) + (shell-mode) + (setq major-mode 'rlogin-mode) + (setq mode-name "rlogin") + (use-local-map rlogin-mode-map) + (setq shell-dirtrackp rlogin-directory-tracking-mode) + (make-local-variable 'comint-file-name-prefix) + (run-hooks 'rlogin-mode-hook)) + +(defun rlogin-directory-tracking-mode (&optional prefix) + "Do remote or local directory tracking, or disable entirely. + +If called with no prefix argument or a unspecified prefix argument (just +``\\[universal-argument]'' with no number) do remote directory tracking via +ange-ftp. If called as a function, give it no argument. + +If called with a negative prefix argument, disable directory tracking +entirely. + +If called with a positive, numeric prefix argument, e.g. +``\\[universal-argument] 1 M-x rlogin-directory-tracking-mode\'', +then do directory tracking but assume the remote filesystem is the same as +the local system. This only works in general if the remote machine and the +local one share the same directories (through NFS)." + (interactive "P") + (cond + ((or (null prefix) + (consp prefix)) + (setq rlogin-directory-tracking-mode t) + (setq shell-dirtrackp t) + (setq comint-file-name-prefix + (concat "/" rlogin-remote-user "@" rlogin-host ":"))) + ((< prefix 0) + (setq rlogin-directory-tracking-mode nil) + (setq shell-dirtrackp nil)) + (t + (setq rlogin-directory-tracking-mode 'local) + (setq comint-file-name-prefix "") + (setq shell-dirtrackp t))) + (cond + (shell-dirtrackp + (let* ((proc (get-buffer-process (current-buffer))) + (proc-mark (process-mark proc)) + (current-input (buffer-substring proc-mark (point-max))) + (orig-point (point)) + (offset (and (>= orig-point proc-mark) + (- (point-max) orig-point)))) + (unwind-protect + (progn + (delete-region proc-mark (point-max)) + (goto-char (point-max)) + (shell-resync-dirs)) + (goto-char proc-mark) + (insert current-input) + (if offset + (goto-char (- (point-max) offset)) + (goto-char orig-point))))))) + + +;; Parse a line into its constituent parts (words separated by +;; whitespace). Return a list of the words. +(defun rlogin-parse-words (line) + (let ((list nil) + (posn 0) + (match-data (match-data))) + (while (string-match "[^ \t\n]+" line posn) + (setq list (cons (substring line (match-beginning 0) (match-end 0)) + list)) + (setq posn (match-end 0))) + (store-match-data (match-data)) + (nreverse list))) + +(defun rlogin-carriage-filter (string) + (let* ((point-marker (point-marker)) + (end (process-mark (get-buffer-process (current-buffer)))) + (beg (or (and (boundp 'comint-last-output-start) + comint-last-output-start) + (- end (length string))))) + (goto-char beg) + (while (search-forward "\C-m" end t) + (delete-char -1)) + (goto-char point-marker))) + +(defun rlogin-send-Ctrl-C () + (interactive) + (send-string nil "\C-c")) + +(defun rlogin-send-Ctrl-D () + (interactive) + (send-string nil "\C-d")) + +(defun rlogin-send-Ctrl-Z () + (interactive) + (send-string nil "\C-z")) + +(defun rlogin-send-Ctrl-backslash () + (interactive) + (send-string nil "\C-\\")) + +(defun rlogin-delchar-or-send-Ctrl-D (arg) + "\ +Delete ARG characters forward, or send a C-d to process if at end of buffer." + (interactive "p") + (if (eobp) + (rlogin-send-Ctrl-D) + (delete-char arg))) + +(defun rlogin-tab-or-complete () + "Complete file name if doing directory tracking, or just insert TAB." + (interactive) + (if rlogin-directory-tracking-mode + (comint-dynamic-complete) + (insert "\C-i"))) + +;;; rlogin.el ends here diff --git a/spell.el b/spell.el new file mode 100644 --- /dev/null +++ b/spell.el @@ -0,0 +1,156 @@ +;;; spell.el --- spelling correction interface for Emacs. + +;; Copyright (C) 1985 Free Software Foundation, Inc. + +;; Maintainer: FSF +;; Keywords: wp, unix + +;; This file is part of XEmacs. + +;; XEmacs 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 2, or (at your option) +;; any later version. + +;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the Free +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. + +;;; Synched up with: FSF 19.34. + +;;; Commentary: + +;; This mode provides an Emacs interface to the UNIX spell(1) program. +;; Entry points are `spell-buffer', `spell-word', `spell-region' and +;; `spell-string'. These facilities are documented in the Emacs user's +;; manual. + +;;; Code: + +(defvar spell-command "spell" + "*Command to run the spell program.") + +(defvar spell-filter nil + "*Filter function to process text before passing it to spell program. +This function might remove text-processor commands. +nil means don't alter the text before checking it.") + +;;;###autoload +(put 'spell-filter 'risky-local-variable t) + +;;;###autoload +(defun spell-buffer () + "Check spelling of every word in the buffer. +For each incorrect word, you are asked for the correct spelling +and then put into a query-replace to fix some or all occurrences. +If you do not want to change a word, just give the same word +as its \"correct\" spelling; then the query replace is skipped." + (interactive) + (spell-region (point-min) (point-max) "buffer")) + +;;;###autoload +(defun spell-word () + "Check spelling of word at or before point. +If it is not correct, ask user for the correct spelling +and `query-replace' the entire buffer to substitute it." + (interactive) + (let (beg end spell-filter) + (save-excursion + (if (not (looking-at "\\<")) + (forward-word -1)) + (setq beg (point)) + (forward-word 1) + (setq end (point))) + (spell-region beg end (buffer-substring beg end)))) + +;;;###autoload +(defun spell-region (start end &optional description) + "Like `spell-buffer' but applies only to region. +Used in a program, applies from START to END. +DESCRIPTION is an optional string naming the unit being checked: +for example, \"word\"." + (interactive "r") + (let ((filter spell-filter) + (buf (get-buffer-create " *temp*"))) + (save-excursion + (set-buffer buf) + (widen) + (erase-buffer)) + (message "Checking spelling of %s..." (or description "region")) + (if (and (null filter) (= ?\n (char-after (1- end)))) + (if (string= "spell" spell-command) + (call-process-region start end "spell" nil buf) + (call-process-region start end shell-file-name + nil buf nil "-c" spell-command)) + (let ((oldbuf (current-buffer))) + (save-excursion + (set-buffer buf) + (insert-buffer-substring oldbuf start end) + (or (bolp) (insert ?\n)) + (if filter (funcall filter)) + (if (string= "spell" spell-command) + (call-process-region (point-min) (point-max) "spell" t buf) + (call-process-region (point-min) (point-max) shell-file-name + t buf nil "-c" spell-command))))) + (message "Checking spelling of %s...%s" + (or description "region") + (if (save-excursion + (set-buffer buf) + (> (buffer-size) 0)) + "not correct" + "correct")) + (let (word newword + (case-fold-search t) + (case-replace t)) + (while (save-excursion + (set-buffer buf) + (> (buffer-size) 0)) + (save-excursion + (set-buffer buf) + (goto-char (point-min)) + (setq word (downcase + (buffer-substring (point) + (progn (end-of-line) (point))))) + (forward-char 1) + (delete-region (point-min) (point)) + (setq newword + (read-input (concat "`" word + "' not recognized; edit a replacement: ") + word)) + (flush-lines (concat "^" (regexp-quote word) "$"))) + (if (not (equal word newword)) + (progn + (goto-char (point-min)) + (query-replace-regexp (concat "\\b" (regexp-quote word) "\\b") + newword))))))) + + +;;;###autoload +(defun spell-string (string) + "Check spelling of string supplied as argument." + (interactive "sSpell string: ") + (let ((buf (get-buffer-create " *temp*"))) + (save-excursion + (set-buffer buf) + (widen) + (erase-buffer) + (insert string "\n") + (if (string= "spell" spell-command) + (call-process-region (point-min) (point-max) "spell" + t t) + (call-process-region (point-min) (point-max) shell-file-name + t t nil "-c" spell-command)) + (if (= 0 (buffer-size)) + (message "%s is correct" string) + (goto-char (point-min)) + (while (search-forward "\n" nil t) + (replace-match " ")) + (message "%sincorrect" (buffer-substring 1 (point-max))))))) + +;;; spell.el ends here diff --git a/ssh.el b/ssh.el new file mode 100644 --- /dev/null +++ b/ssh.el @@ -0,0 +1,358 @@ +;;; ssh.el --- remote login interface + +;; Copyright (C) 1996, 1997 Noah S. Friedman + +;; Author: Noah Friedman <friedman@prep.ai.mit.edu> +;; Maintainer: friedman@prep.ai.mit.edu +;; Keywords: unix, comm +;; Created: 1996-07-03 + +;; $Id$ + +;; 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 2, 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, you can either send email to this +;; program's maintainer or write to: The Free Software Foundation, +;; Inc.; 59 Temple Place, Suite 330; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; Support for remote logins using `ssh'. +;; This program is layered on top of shell.el; the code here only accounts +;; for the variations needed to handle a remote process, e.g. directory +;; tracking and the sending of some special characters. + +;; If you wish for ssh mode to prompt you in the minibuffer for +;; passwords when a password prompt appears, just enter m-x send-invisible +;; and type in your line, or add `comint-watch-for-password-prompt' to +;; `comint-output-filter-functions'. + +;;; Code: + +(require 'comint) +(require 'shell) + +(defgroup ssh nil + "Secure remote login interface" + :group 'processes + :group 'unix) + +(defcustom ssh-program "ssh" + "*Name of program to invoke ssh" + :type 'string + :group 'ssh) + +(defcustom ssh-explicit-args '() + "*List of arguments to pass to ssh on the command line." + :type '(repeat (string :tag "Argument")) + :group 'ssh) + +(defcustom ssh-mode-hook nil + "*Hooks to run after setting current buffer to ssh-mode." + :type 'hook + :group 'ssh) + +(defcustom ssh-process-connection-type t + "*If non-`nil', use a pty for the local ssh process. +If `nil', use a pipe (if pipes are supported on the local system). + +Generally it is better not to waste ptys on systems which have a static +number of them. However, ssh won't allocate a pty on the remote host +unless one is used locally as well." + :type '(choice (const :tag "ptys" t) + (const :tag "pipes" nil)) + :group 'ssh) + +(defcustom ssh-directory-tracking-mode 'local + "*Control whether and how to do directory tracking in an ssh buffer. + +nil means don't do directory tracking. + +t means do so using an ftp remote file name. + +Any other value means do directory tracking using local file names. +This works only if the remote machine and the local one +share the same directories (through NFS). This is the default. + +This variable becomes local to a buffer when set in any fashion for it. + +It is better to use the function of the same name to change the behavior of +directory tracking in an ssh session once it has begun, rather than +simply setting this variable, since the function does the necessary +re-synching of directories." + :type '(choice (const :tag "off" nil) + (const :tag "ftp" t) + (const :tag "local" local)) + :group 'ssh) + +(make-variable-buffer-local 'ssh-directory-tracking-mode) + +(defcustom ssh-host nil + "*The name of the remote host. This variable is buffer-local." + :type '(choice (const nil) string) + :group 'ssh) + +(defcustom ssh-remote-user nil + "*The username used on the remote host. +This variable is buffer-local and defaults to your local user name. +If ssh is invoked with the `-l' option to specify the remote username, +this variable is set from that." + :type '(choice (const nil) string) + :group 'ssh) + +;; Initialize ssh mode map. +(defvar ssh-mode-map '()) +(cond + ((null ssh-mode-map) + (setq ssh-mode-map (if (consp shell-mode-map) + (cons 'keymap shell-mode-map) + (copy-keymap shell-mode-map))) + (define-key ssh-mode-map "\C-c\C-c" 'ssh-send-Ctrl-C) + (define-key ssh-mode-map "\C-c\C-d" 'ssh-send-Ctrl-D) + (define-key ssh-mode-map "\C-c\C-z" 'ssh-send-Ctrl-Z) + (define-key ssh-mode-map "\C-c\C-\\" 'ssh-send-Ctrl-backslash) + (define-key ssh-mode-map "\C-d" 'ssh-delchar-or-send-Ctrl-D) + (define-key ssh-mode-map "\C-i" 'ssh-tab-or-complete))) + + +;;;###autoload (add-hook 'same-window-regexps "^\\*ssh-.*\\*\\(\\|<[0-9]+>\\)") + +(defvar ssh-history nil) + +;;;###autoload +(defun ssh (input-args &optional buffer) + "Open a network login connection via `ssh' with args INPUT-ARGS. +INPUT-ARGS should start with a host name; it may also contain +other arguments for `ssh'. + +Input is sent line-at-a-time to the remote connection. + +Communication with the remote host is recorded in a buffer `*ssh-HOST*' +\(or `*ssh-USER@HOST*' if the remote username differs\). +If a prefix argument is given and the buffer `*ssh-HOST*' already exists, +a new buffer with a different connection will be made. + +When called from a program, if the optional second argument BUFFER is +a string or buffer, it specifies the buffer to use. + +The variable `ssh-program' contains the name of the actual program to +run. It can be a relative or absolute path. + +The variable `ssh-explicit-args' is a list of arguments to give to +the ssh when starting. They are prepended to any arguments given in +INPUT-ARGS. + +If the default value of `ssh-directory-tracking-mode' is t, then the +default directory in that buffer is set to a remote (FTP) file name to +access your home directory on the remote machine. Occasionally this causes +an error, if you cannot access the home directory on that machine. This +error is harmless as long as you don't try to use that default directory. + +If `ssh-directory-tracking-mode' is neither t nor nil, then the default +directory is initially set up to your (local) home directory. +This is useful if the remote machine and your local machine +share the same files via NFS. This is the default. + +If you wish to change directory tracking styles during a session, use the +function `ssh-directory-tracking-mode' rather than simply setting the +variable." + (interactive (list + (read-from-minibuffer "ssh arguments (hostname first): " + nil nil nil 'ssh-history) + current-prefix-arg)) + + (let* ((process-connection-type ssh-process-connection-type) + (args (ssh-parse-words input-args)) + (host (car args)) + (user (or (car (cdr (member "-l" args))) + (user-login-name))) + (buffer-name (if (string= user (user-login-name)) + (format "*ssh-%s*" host) + (format "*ssh-%s@%s*" user host))) + proc) + + (and ssh-explicit-args + (setq args (append ssh-explicit-args args))) + + (cond ((null buffer)) + ((stringp buffer) + (setq buffer-name buffer)) + ((bufferp buffer) + (setq buffer-name (buffer-name buffer))) + ((numberp buffer) + (setq buffer-name (format "%s<%d>" buffer-name buffer))) + (t + (setq buffer-name (generate-new-buffer-name buffer-name)))) + + (setq buffer (get-buffer-create buffer-name)) + (pop-to-buffer buffer-name) + + (cond + ((comint-check-proc buffer-name)) + (t + (comint-exec buffer buffer-name ssh-program nil args) + (setq proc (get-buffer-process buffer)) + ;; Set process-mark to point-max in case there is text in the + ;; buffer from a previous exited process. + (set-marker (process-mark proc) (point-max)) + + ;; comint-output-filter-functions is just like a hook, except that the + ;; functions in that list are passed arguments. add-hook serves well + ;; enough for modifying it. + ;; comint-output-filter-functions should already have a + ;; permanent-local property, at least in emacs 19.27 or later. + (if (fboundp 'make-local-hook) + (make-local-hook 'comint-output-filter-functions) + (make-local-variable 'comint-output-filter-functions)) + (add-hook 'comint-output-filter-functions 'ssh-carriage-filter) + + (ssh-mode) + + (make-local-variable 'ssh-host) + (setq ssh-host host) + (make-local-variable 'ssh-remote-user) + (setq ssh-remote-user user) + + (condition-case () + (cond ((eq ssh-directory-tracking-mode t) + ;; Do this here, rather than calling the tracking mode + ;; function, to avoid a gratuitous resync check; the default + ;; should be the user's home directory, be it local or remote. + (setq comint-file-name-prefix + (concat "/" ssh-remote-user "@" ssh-host ":")) + (cd-absolute comint-file-name-prefix)) + ((null ssh-directory-tracking-mode)) + (t + (cd-absolute (concat comint-file-name-prefix "~/")))) + (error nil)))))) + +(put 'ssh-mode 'mode-class 'special) + +(defun ssh-mode () + "Set major-mode for ssh sessions. +If `ssh-mode-hook' is set, run it." + (interactive) + (kill-all-local-variables) + (shell-mode) + (setq major-mode 'ssh-mode) + (setq mode-name "ssh") + (use-local-map ssh-mode-map) + (setq shell-dirtrackp ssh-directory-tracking-mode) + (make-local-variable 'comint-file-name-prefix) + (run-hooks 'ssh-mode-hook)) + +(defun ssh-directory-tracking-mode (&optional prefix) + "Do remote or local directory tracking, or disable entirely. + +If called with no prefix argument or a unspecified prefix argument (just +``\\[universal-argument]'' with no number) do remote directory tracking via +ange-ftp. If called as a function, give it no argument. + +If called with a negative prefix argument, disable directory tracking +entirely. + +If called with a positive, numeric prefix argument, e.g. +``\\[universal-argument] 1 M-x ssh-directory-tracking-mode\'', +then do directory tracking but assume the remote filesystem is the same as +the local system. This only works in general if the remote machine and the +local one share the same directories (through NFS)." + (interactive "P") + (cond + ((or (null prefix) + (consp prefix)) + (setq ssh-directory-tracking-mode t) + (setq shell-dirtrackp t) + (setq comint-file-name-prefix + (concat "/" ssh-remote-user "@" ssh-host ":"))) + ((< prefix 0) + (setq ssh-directory-tracking-mode nil) + (setq shell-dirtrackp nil)) + (t + (setq ssh-directory-tracking-mode 'local) + (setq comint-file-name-prefix "") + (setq shell-dirtrackp t))) + (cond + (shell-dirtrackp + (let* ((proc (get-buffer-process (current-buffer))) + (proc-mark (process-mark proc)) + (current-input (buffer-substring proc-mark (point-max))) + (orig-point (point)) + (offset (and (>= orig-point proc-mark) + (- (point-max) orig-point)))) + (unwind-protect + (progn + (delete-region proc-mark (point-max)) + (goto-char (point-max)) + (shell-resync-dirs)) + (goto-char proc-mark) + (insert current-input) + (if offset + (goto-char (- (point-max) offset)) + (goto-char orig-point))))))) + + +;; Parse a line into its constituent parts (words separated by +;; whitespace). Return a list of the words. +(defun ssh-parse-words (line) + (let ((list nil) + (posn 0) + (match-data (match-data))) + (while (string-match "[^ \t\n]+" line posn) + (setq list (cons (substring line (match-beginning 0) (match-end 0)) + list)) + (setq posn (match-end 0))) + (store-match-data (match-data)) + (nreverse list))) + +(defun ssh-carriage-filter (string) + (let* ((point-marker (point-marker)) + (end (process-mark (get-buffer-process (current-buffer)))) + (beg (or (and (boundp 'comint-last-output-start) + comint-last-output-start) + (- end (length string))))) + (goto-char beg) + (while (search-forward "\C-m" end t) + (delete-char -1)) + (goto-char point-marker))) + +(defun ssh-send-Ctrl-C () + (interactive) + (send-string nil "\C-c")) + +(defun ssh-send-Ctrl-D () + (interactive) + (send-string nil "\C-d")) + +(defun ssh-send-Ctrl-Z () + (interactive) + (send-string nil "\C-z")) + +(defun ssh-send-Ctrl-backslash () + (interactive) + (send-string nil "\C-\\")) + +(defun ssh-delchar-or-send-Ctrl-D (arg) + "\ +Delete ARG characters forward, or send a C-d to process if at end of buffer." + (interactive "p") + (if (eobp) + (ssh-send-Ctrl-D) + (delete-char arg))) + +(defun ssh-tab-or-complete () + "Complete file name if doing directory tracking, or just insert TAB." + (interactive) + (if ssh-directory-tracking-mode + (comint-dynamic-complete) + (insert "\C-i"))) + +;;; ssh.el ends here diff --git a/tar-mode.el b/tar-mode.el new file mode 100644 --- /dev/null +++ b/tar-mode.el @@ -0,0 +1,1388 @@ +;;; tar-mode.el --- simple editing of tar files from GNU emacs + +;; Copyright (C) 1990-1993, 1997 Free Software Foundation, Inc. + +;; Author: Jamie Zawinski <jwz@netscape.com> +;; Keywords: unix +;; Created: 4 Apr 1990 +;; Version: 1.32 + +;; This file is part of XEmacs. + +;; XEmacs 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 2, or (at your option) +;; any later version. + +;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Synched up with: partially synched with Emacs 20. + +;;; Commentary: + +;; This package attempts to make dealing with Unix 'tar' archives easier. +;; When this code is loaded, visiting a file whose name ends in '.tar' will +;; cause the contents of that archive file to be displayed in a Dired-like +;; listing. It is then possible to use the customary Dired keybindings to +;; extract sub-files from that archive, either by reading them into their own +;; editor buffers, or by copying them directly to arbitrary files on disk. +;; It is also possible to delete sub-files from within the tar file and write +;; the modified archive back to disk, or to edit sub-files within the archive +;; and re-insert the modified files into the archive. See the documentation +;; string of tar-mode for more info. + +;; To autoload, add this to your .emacs file: +;; +;; (setq auto-mode-alist (cons '("\\.tar$" . tar-mode) auto-mode-alist)) +;; (autoload 'tar-mode "tar-mode") +;; +;; But beware: for certain tar files - those whose very first file has +;; a -*- property line - autoloading won't work. See the function +;; "tar-normal-mode" to understand why. + +;; This code now understands the extra fields that GNU tar adds to tar files. + +;; This interacts correctly with "uncompress.el" in the Emacs library, +;; and with sufficiently recent versions of "crypt.el" by Kyle Jones. + +;; *************** TO DO *************** +;; +;; o chmod should understand "a+x,og-w". +;; +;; o It's not possible to add a NEW file to a tar archive; not that +;; important, but still... +;; +;; o The code is less efficient that it could be - in a lot of places, I +;; pull a 512-character string out of the buffer and parse it, when I could +;; be parsing it in place, not garbaging a string. Should redo that. +;; +;; o I'd like a command that searches for a string/regexp in every subfile +;; of an archive, where <esc> would leave you in a subfile-edit buffer. +;; (Like M-s in VM and M-r in the Zmacs mail reader.) +;; +;; o Sometimes (but not always) reverting the tar-file buffer does not +;; re-grind the listing, and you are staring at the binary tar data. +;; Typing 'g' again immediately after that will always revert and re-grind +;; it, though. I have no idea why this happens. +;; +;; o Tar-mode interacts poorly with crypt.el and zcat.el because the tar +;; write-file-hook actually writes the file. Instead it should remove the +;; header (and conspire to put it back afterwards) so that other write-file +;; hooks which frob the buffer have a chance to do their dirty work. There +;; might be a problem if the tar write-file-hook does not come *first* on +;; the list. +;; +;; o Block files, sparse files, continuation files, and the various header +;; types aren't editable. Actually I don't know that they work at all. +;; If you know that they work, or know that they don't, please let me know. +;; +;; o Tar files inside of tar files don't work. +;; +;; o When using crypt-mode, you can't save a compressed or encrypted subfile +;; of a tar file back into the tar file: it is saved uncompressed. + +;;; Code: + +(defgroup tar () + "Simple editing of tar files from GNU emacs." + :group 'unix + :group 'data) + + +(defcustom tar-anal-blocksize 20 + "*The blocksize of tar files written by Emacs, or nil, meaning don't care. +The blocksize of a tar file is not really the size of the blocks; rather, it is +the number of blocks written with one system call. When tarring to a tape, +this is the size of the *tape* blocks, but when writing to a file, it doesn't +matter much. The only noticeable difference is that if a tar file does not +have a blocksize of 20, the tar program will issue a warning; all this really +controls is how many null padding bytes go on the end of the tar file." + :type 'integer + :group 'tar) + +(defcustom tar-update-datestamp t + "*Whether tar-mode should play fast and loose with sub-file datestamps; +if this is true, then editing and saving a tar file entry back into its +tar file will update its datestamp. If false, the datestamp is unchanged. +You may or may not want this - it is good in that you can tell when a file +in a tar archive has been changed, but it is bad for the same reason that +editing a file in the tar archive at all is bad - the changed version of +the file never exists on disk. + +This does not work in Emacs 18, because there's no way to get the current +time as an integer - if this var is true, then editing a file sets its date +to midnight, Jan 1 1970 GMT, which happens to be what 0 encodes." + :type 'boolean + :group 'tar) + + +;;; First, duplicate some Common Lisp functions; I used to just (require 'cl) +;;; but "cl.el" was messing some people up (also it's really big). + +;; No need for that stuff anymore -- XEmacs preloads cl.el anyway. + + +;;; down to business. + +(defmacro tar-make-header (name mode uid git size date ck lt ln + magic uname gname devmaj devmin) + (list 'vector name mode uid git size date ck lt ln + magic uname gname devmaj devmin)) + +(defmacro tar-header-name (x) (list 'aref x 0)) +(defmacro tar-header-mode (x) (list 'aref x 1)) +(defmacro tar-header-uid (x) (list 'aref x 2)) +(defmacro tar-header-gid (x) (list 'aref x 3)) +(defmacro tar-header-size (x) (list 'aref x 4)) +(defmacro tar-header-date (x) (list 'aref x 5)) +(defmacro tar-header-checksum (x) (list 'aref x 6)) +(defmacro tar-header-link-type (x) (list 'aref x 7)) +(defmacro tar-header-link-name (x) (list 'aref x 8)) +(defmacro tar-header-magic (x) (list 'aref x 9)) +(defmacro tar-header-uname (x) (list 'aref x 10)) +(defmacro tar-header-gname (x) (list 'aref x 11)) +(defmacro tar-header-dmaj (x) (list 'aref x 12)) +(defmacro tar-header-dmin (x) (list 'aref x 13)) + +(defmacro tar-make-desc (data-start tokens) + (list 'cons data-start tokens)) + +(defmacro tar-desc-data-start (x) (list 'car x)) +(defmacro tar-desc-tokens (x) (list 'cdr x)) + +(defconst tar-name-offset 0) +(defconst tar-mode-offset (+ tar-name-offset 100)) +(defconst tar-uid-offset (+ tar-mode-offset 8)) +(defconst tar-gid-offset (+ tar-uid-offset 8)) +(defconst tar-size-offset (+ tar-gid-offset 8)) +(defconst tar-time-offset (+ tar-size-offset 12)) +(defconst tar-chk-offset (+ tar-time-offset 12)) +(defconst tar-linkp-offset (+ tar-chk-offset 8)) +(defconst tar-link-offset (+ tar-linkp-offset 1)) +;;; GNU-tar specific slots. +(defconst tar-magic-offset (+ tar-link-offset 100)) +(defconst tar-uname-offset (+ tar-magic-offset 8)) +(defconst tar-gname-offset (+ tar-uname-offset 32)) +(defconst tar-dmaj-offset (+ tar-gname-offset 32)) +(defconst tar-dmin-offset (+ tar-dmaj-offset 8)) +(defconst tar-end-offset (+ tar-dmin-offset 8)) + +(defun tar-tokenize-header-block (string) + "Return a `tar-header' structure. +This is a list of name, mode, uid, gid, size, +write-date, checksum, link-type, and link-name." + (cond ((< (length string) 512) nil) + (;(some 'plusp string) ; <-- oops, massive cycle hog! + (or (not (= 0 (aref string 0))) ; This will do. + (not (= 0 (aref string 101)))) + (let* ((name-end (1- tar-mode-offset)) + (link-end (1- tar-magic-offset)) + (uname-end (1- tar-gname-offset)) + (gname-end (1- tar-dmaj-offset)) + (link-p (aref string tar-linkp-offset)) + (magic-str (substring string tar-magic-offset (1- tar-uname-offset))) + (uname-valid-p (or (string= "ustar " magic-str) (string= "GNUtar " magic-str))) + name + (nulsexp "[^\000]*\000")) + (and (string-match nulsexp string tar-name-offset) (setq name-end (min name-end (1- (match-end 0))))) + (and (string-match nulsexp string tar-link-offset) (setq link-end (min link-end (1- (match-end 0))))) + (and (string-match nulsexp string tar-uname-offset) (setq uname-end (min uname-end (1- (match-end 0))))) + (and (string-match nulsexp string tar-gname-offset) (setq gname-end (min gname-end (1- (match-end 0))))) + (setq name (substring string tar-name-offset name-end) + link-p (if (or (= link-p 0) (= link-p ?0)) + nil + (- link-p ?0))) + (if (and (null link-p) (string-match "/$" name)) (setq link-p 5)) ; directory + (tar-make-header + name + (tar-parse-octal-integer string tar-mode-offset (1- tar-uid-offset)) + (tar-parse-octal-integer string tar-uid-offset (1- tar-gid-offset)) + (tar-parse-octal-integer string tar-gid-offset (1- tar-size-offset)) + (tar-parse-octal-integer string tar-size-offset (1- tar-time-offset)) + (tar-parse-octal-integer-32 string tar-time-offset (1- tar-chk-offset)) + (tar-parse-octal-integer string tar-chk-offset (1- tar-linkp-offset)) + link-p + (substring string tar-link-offset link-end) + uname-valid-p + (and uname-valid-p (substring string tar-uname-offset uname-end)) + (and uname-valid-p (substring string tar-gname-offset gname-end)) + (tar-parse-octal-integer string tar-dmaj-offset (1- tar-dmin-offset)) + (tar-parse-octal-integer string tar-dmin-offset (1- tar-end-offset)) + ))) + (t 'empty-tar-block))) + + +(defun tar-parse-octal-integer (string &optional start end) + (if (null start) (setq start 0)) + (if (null end) (setq end (length string))) + (if (= (aref string start) 0) + 0 + (let ((n 0)) + (while (< start end) + (setq n (if (< (aref string start) ?0) n + (+ (* n 8) (- (aref string start) 48))) + start (1+ start))) + n))) + +(defun tar-parse-octal-integer-32 (string &optional start end) + ;; like tar-parse-octal-integer, but returns a cons of two 16-bit numbers, + ;; since elisp can't handle integers of that magnitude. + (or start (setq start 0)) + (or end (setq end (length string))) + (let ((top (tar-parse-octal-integer string start (- end 6))) + (bot (tar-parse-octal-integer string (- end 6) end))) + (setq top (logior (ash top 2) (ash bot -16))) + (setq bot (logand bot 65535)) + (cons top bot))) + +(defun tar-parse-octal-integer-safe (string) + (let ((L (length string))) + (if (= L 0) (error "empty string")) + (dotimes (i L) + (if (or (< (aref string i) ?0) + (> (aref string i) ?7)) + (error "'%c' is not an octal digit.")))) + (tar-parse-octal-integer string)) + + +(defun tar-header-block-checksum (string) + "Compute and return a tar-acceptable checksum for this block." + (let* ((chk-field-start tar-chk-offset) + (chk-field-end (+ chk-field-start 8)) + (sum 0) + (i 0)) + ;; Add up all of the characters except the ones in the checksum field. + ;; Add that field as if it were filled with spaces. + (while (< i chk-field-start) + (setq sum (+ sum (aref string i)) + i (1+ i))) + (setq i chk-field-end) + (while (< i 512) + (setq sum (+ sum (aref string i)) + i (1+ i))) + (+ sum (* 32 8)))) + +(defun tar-header-block-check-checksum (hblock desired-checksum file-name) + "Beep and print a warning if the checksum doesn't match." + (if (not (= desired-checksum (tar-header-block-checksum hblock))) + (progn (beep) (message "Invalid checksum for file %s!" file-name)))) + +(defun tar-header-block-recompute-checksum (hblock) + "Modifies the given string to have a valid checksum field." + (let* ((chk (tar-header-block-checksum hblock)) + (chk-string (format "%6o" chk)) + (l (length chk-string))) + (aset hblock 154 0) + (aset hblock 155 32) + (dotimes (i l) (aset hblock (- 153 i) (aref chk-string (- l i 1))))) + hblock) + + +(defun tar-grind-file-mode (mode string start) + "Store `-rw--r--r--' indicating MODE into STRING beginning at START. +MODE should be an integer which is a file mode value." + (aset string start (if (zerop (logand 256 mode)) ?- ?r)) + (aset string (+ start 1) (if (zerop (logand 128 mode)) ?- ?w)) + (aset string (+ start 2) (if (zerop (logand 64 mode)) ?- ?x)) + (aset string (+ start 3) (if (zerop (logand 32 mode)) ?- ?r)) + (aset string (+ start 4) (if (zerop (logand 16 mode)) ?- ?w)) + (aset string (+ start 5) (if (zerop (logand 8 mode)) ?- ?x)) + (aset string (+ start 6) (if (zerop (logand 4 mode)) ?- ?r)) + (aset string (+ start 7) (if (zerop (logand 2 mode)) ?- ?w)) + (aset string (+ start 8) (if (zerop (logand 1 mode)) ?- ?x)) + (if (zerop (logand 1024 mode)) nil (aset string (+ start 2) ?s)) + (if (zerop (logand 2048 mode)) nil (aset string (+ start 5) ?s)) + string) + + +(defconst tar-can-print-dates (or (fboundp 'current-time) + (fboundp 'current-time-seconds)) + "true if this emacs has been built with time-printing support") + +(defun tar-summarize-header-block (tar-hblock &optional mod-p) + "Returns a line similar to the output of `tar -vtf'." + (let ((name (tar-header-name tar-hblock)) + (mode (tar-header-mode tar-hblock)) + (uid (tar-header-uid tar-hblock)) + (gid (tar-header-gid tar-hblock)) + (uname (tar-header-uname tar-hblock)) + (gname (tar-header-gname tar-hblock)) + (size (tar-header-size tar-hblock)) + (time (tar-header-date tar-hblock)) + (ck (tar-header-checksum tar-hblock)) + (link-p (tar-header-link-type tar-hblock)) + (link-name (tar-header-link-name tar-hblock)) + ) + (let* ((left 11) + (namew 8) + (groupw 8) + (sizew 8) + (datew (if tar-can-print-dates 15 2)) + (slash (1- (+ left namew))) + (lastdigit (+ slash groupw sizew)) + (namestart (+ lastdigit datew)) + (string (make-string (+ namestart (length name) (if link-p (+ 5 (length link-name)) 0)) 32)) + (type (tar-header-link-type tar-hblock))) + (aset string 0 (if mod-p ?* ? )) + (aset string 1 + (cond ((or (eq type nil) (eq type 0)) ?-) + ((eq type 1) ?l) ; link + ((eq type 2) ?s) ; symlink + ((eq type 3) ?c) ; char special + ((eq type 4) ?b) ; block special + ((eq type 5) ?d) ; directory + ((eq type 6) ?p) ; FIFO/pipe + ((eq type 20) ?*) ; directory listing + ((eq type 29) ?M) ; multivolume continuation + ((eq type 35) ?S) ; sparse + ((eq type 38) ?V) ; volume header + )) + (tar-grind-file-mode mode string 2) + (setq uid (if (= 0 (length uname)) (int-to-string uid) uname)) + (setq gid (if (= 0 (length gname)) (int-to-string gid) gname)) + (setq size (int-to-string size)) + (dotimes (i (min (1- namew) (length uid))) (aset string (- slash i) (aref uid (- (length uid) i 1)))) + (aset string (1+ slash) ?/) + (dotimes (i (min (1- groupw) (length gid))) (aset string (+ (+ slash 2) i) (aref gid i))) + (dotimes (i (min sizew (length size))) (aset string (- lastdigit i) (aref size (- (length size) i 1)))) + + (if tar-can-print-dates + (let* ((year (substring (current-time-string) -4)) + ;; in v18, current-time-string doesn't take an argument + (file (current-time-string time)) + (file-year (substring file -4)) + (str (if (equal year file-year) + (substring file 4 16) + (concat (substring file 4 11) " " file-year)))) + (dotimes (i 12) (aset string (- namestart (- 13 i)) (aref str i))))) + + (dotimes (i (length name)) (aset string (+ namestart i) (aref name i))) + (if (or (eq link-p 1) (eq link-p 2)) + (progn + (dotimes (i 3) (aset string (+ namestart 1 (length name) i) (aref (if (= link-p 1) "==>" "-->") i))) + (dotimes (i (length link-name)) (aset string (+ namestart 5 (length name) i) (aref link-name i))))) + string))) + + +;; buffer-local variables in the tar file's buffer: +;; +(defvar tar-parse-info) ; the header structures +(defvar tar-header-offset) ; the end of the "pretty" data + +(defun tar-summarize-buffer () + "Parse the contents of the tar file in the current buffer, and place a +dired-like listing on the front; then narrow to it, so that only that listing +is visible (and the real data of the buffer is hidden)." + (message "parsing tar file...") + (let* ((result '()) + (pos 1) + (bs (max 1 (- (buffer-size) 1024))) ; always 2+ empty blocks at end. + (bs100 (max 1 (/ bs 100))) + (tokens nil)) + (while (not (eq tokens 'empty-tar-block)) + (if (> (+ pos 512) (point-max)) + (error "truncated tar file")) + (let* ((hblock (buffer-substring pos (+ pos 512)))) + (setq tokens (tar-tokenize-header-block hblock)) + (setq pos (+ pos 512)) + (message "parsing tar file...%s%%" + ;(/ (* pos 100) bs) ; this gets round-off lossage + (/ pos bs100) ; this doesn't + ) + (if (eq tokens 'empty-tar-block) + nil + (if (null tokens) (error "premature EOF parsing tar file.")) + (if (eq (tar-header-link-type tokens) 20) + ;; Foo. There's an extra empty block after these. + (setq pos (+ pos 512))) + (let ((size (tar-header-size tokens))) + (if (< size 0) + (error "%s has size %s - corrupted." + (tar-header-name tokens) size)) + ; + ; This is just too slow. Don't really need it anyway.... + ;(tar-check-header-block-checksum + ; hblock (tar-checksum-header-block hblock) + ; (tar-header-name tokens)) + + (setq result (cons (tar-make-desc pos tokens) result)) + + (if (and (null (tar-header-link-type tokens)) + (> size 0)) + (setq pos + (+ pos 512 (ash (ash (1- size) -9) 9)) ; this works + ;(+ pos (+ size (- 512 (rem (1- size) 512)))) ; this doesn't + )) + )))) + (make-local-variable 'tar-parse-info) + (setq tar-parse-info (nreverse result))) + (message "parsing tar file...formatting...") + (save-excursion + (goto-char (point-min)) + (let ((buffer-read-only nil)) + (dolist (tar-desc tar-parse-info) + (insert + (tar-summarize-header-block (tar-desc-tokens tar-desc)) + "\n")) + (make-local-variable 'tar-header-offset) + (setq tar-header-offset (point)) + (narrow-to-region 1 tar-header-offset) + (set-buffer-modified-p nil))) + (message "parsing tar file...done.")) + + +(defvar tar-mode-map nil "*Local keymap for tar-mode listings.") + +(if tar-mode-map + nil + (setq tar-mode-map (make-keymap)) + (suppress-keymap tar-mode-map) + (define-key tar-mode-map " " 'tar-next-line) + (define-key tar-mode-map "c" 'tar-copy) + (define-key tar-mode-map "d" 'tar-flag-deleted) + (define-key tar-mode-map "\^D" 'tar-flag-deleted) + (define-key tar-mode-map "e" 'tar-extract) + (define-key tar-mode-map "f" 'tar-extract) + (define-key tar-mode-map [return] 'tar-extract) + (define-key tar-mode-map "g" 'revert-buffer) + (define-key tar-mode-map "h" 'describe-mode) + (define-key tar-mode-map "n" 'tar-next-line) + (define-key tar-mode-map "\^N" 'tar-next-line) + (define-key tar-mode-map [down] 'tar-next-line) + (define-key tar-mode-map "o" 'tar-extract-other-window) + (define-key tar-mode-map "p" 'tar-previous-line) + (define-key tar-mode-map "\^P" 'tar-previous-line) + (define-key tar-mode-map [up] 'tar-previous-line) + (define-key tar-mode-map "r" 'tar-rename-entry) + (define-key tar-mode-map "u" 'tar-unflag) + (define-key tar-mode-map "v" 'tar-view) + (define-key tar-mode-map "x" 'tar-expunge) + (define-key tar-mode-map 'backspace 'tar-unflag-backwards) + (define-key tar-mode-map 'delete 'tar-unflag-backwards) + (define-key tar-mode-map "E" 'tar-extract-other-window) + (define-key tar-mode-map "M" 'tar-chmod-entry) + (define-key tar-mode-map "G" 'tar-chgrp-entry) + (define-key tar-mode-map "O" 'tar-chown-entry) + + (cond ((and (featurep 'xemacs) + (not (featurep 'infodock))) + (define-key tar-mode-map 'button2 'tar-track-mouse-and-extract-file) + (define-key tar-mode-map 'button3 'tar-popup-menu))) + ) + + +;; XEmacs menu mouse/support added by Heiko Muenkel +;; muenkel@tnt.uni-hannover.de + +(autoload 'dired-mark-region "dired-xemacs-menu") + +(defvar tar-menu + '("Tar Mode Commands" + ["Copy Subfile to Disk" tar-copy t] + ["Rename Subfile" tar-rename-entry t] + "----" + ["Delete Flaged Subfiles" tar-expunge t] + ["Flag Subfile for Deletion" tar-flag-deleted t] + ["Flag Subfiles in Region for Deletion" + (dired-mark-region '(tar-flag-deleted 1)) + (mark)] + ["Unflag Subfile" tar-unflag t] + ["Unflag Subfiles in Region" + (dired-mark-region '(tar-flag-deleted 1 t)) + (mark)] + "----" + ["Change Permissions of Subfile..." tar-chmod-entry t] + ["Change Group of Subfile..." tar-chgrp-entry t] + ["Change Owner of Subfile..." tar-chown-entry t] + "----" + ["Edit Subfile Other Window" tar-extract-other-window t] + ["Edit Subfile" tar-extract t] + ["View Subfile" tar-view t] + )) + + +(defun tar-track-mouse-and-extract-file (event) + "Visit the tar-file-entry upon which the mouse is clicked." + (interactive "e") + (mouse-set-point event) + (tar-next-line 0) + (let (buffer) + (save-excursion + (tar-extract) + (setq buffer (current-buffer))) + (switch-to-buffer buffer))) + +(defun tar-popup-menu (event) + "Display the tar-mode menu." + (interactive "@e") + (mouse-set-point event) + (tar-next-line 0) + (popup-menu tar-menu)) + + +;; tar mode is suitable only for specially formatted data. +(put 'tar-mode 'mode-class 'special) +(put 'tar-subfile-mode 'mode-class 'special) + +;;;###autoload +(defun tar-mode () + "Major mode for viewing a tar file as a dired-like listing of its contents. +You can move around using the usual cursor motion commands. +Letters no longer insert themselves. +Type `e' to pull a file out of the tar file and into its own buffer; +or click mouse-2 on the file's line in the Tar mode buffer. +Type `c' to copy an entry from the tar file into another file on disk. + +If you edit a sub-file of this archive (as with the `e' command) and +save it with Control-x Control-s, the contents of that buffer will be +saved back into the tar-file buffer; in this way you can edit a file +inside of a tar archive without extracting it and re-archiving it. + +See also: variables `tar-update-datestamp' and `tar-anal-blocksize'. +\\{tar-mode-map}" + ;; this is not interactive because you shouldn't be turning this + ;; mode on and off. You can corrupt things that way. + (make-local-variable 'tar-header-offset) + (make-local-variable 'tar-parse-info) + (make-local-variable 'require-final-newline) + (setq require-final-newline nil) ; binary data, dude... + (make-local-variable 'revert-buffer-function) + (setq revert-buffer-function 'tar-mode-revert) + (setq major-mode 'tar-mode) + (setq mode-name "Tar") + (use-local-map tar-mode-map) + (auto-save-mode 0) + (widen) + (if (and (boundp 'tar-header-offset) tar-header-offset) + (narrow-to-region 1 tar-header-offset) + (tar-summarize-buffer)) + (cond ((string-match "XEmacs" emacs-version) + (require 'mode-motion) + (setq mode-motion-hook 'mode-motion-highlight-line) + (when (and (boundp 'current-menubar) + current-menubar + (not (assoc "Tar" current-menubar))) + (set-buffer-menubar (copy-sequence current-menubar)) + (add-menu nil "Tar" (cdr tar-menu))) + )) + (run-hooks 'tar-mode-hook)) + +;; buffer-local variables in subfile mode. +;; +(defvar tar-subfile-mode nil) ; whether the minor-mode is on +(defvar tar-superior-buffer) ; parent buffer +(defvar tar-superior-descriptor) ; header object of this file +(defvar tar-subfile-buffer-id) ; pretty name-string +(defvar subfile-orig-mlbid) ; orig mode-line-buffer-identification + +(defun tar-subfile-mode (p) + "Minor mode for editing an element of a tar-file. +This mode arranges for \"saving\" this buffer to write the data +into the tar-file buffer that it came from. The changes will actually +appear on disk when you save the tar-file's buffer." + (interactive "P") + (or (and (boundp 'tar-superior-buffer) tar-superior-buffer) + (error "This buffer is not an element of a tar file.")) + (or (assq 'tar-subfile-mode minor-mode-alist) + (setq minor-mode-alist (append minor-mode-alist + (list '(tar-subfile-mode " TarFile"))))) + (make-local-variable 'tar-subfile-mode) + (setq tar-subfile-mode + (if (null p) + (not tar-subfile-mode) + (> (prefix-numeric-value p) 0))) + (cond (tar-subfile-mode + ;; copy the local keymap so that we don't accidentally + ;; alter a keymap like 'lisp-mode-map' which is shared + ;; by all buffers in that mode. + (let ((m (current-local-map))) + (if m (use-local-map (copy-keymap m)))) + (local-set-key "\^X\^S" 'tar-subfile-save-buffer) + ;; turn off auto-save. + (auto-save-mode nil) + (setq buffer-auto-save-file-name nil) + (run-hooks 'tar-subfile-mode-hook)) + (t + ;; remove the local binding for C-x C-s. + (local-unset-key "\^X\^S") + (if subfile-orig-mlbid + (set (make-local-variable 'mode-line-buffer-identification) + subfile-orig-mlbid)) + (setq tar-superior-buffer nil + tar-superior-descriptor nil + subfile-orig-mlbid nil) + )) + ) + +(defun tar-subfile-after-write-file-hook () + ;; if the buffer has a filename, then it is no longer associated with + ;; the tar file. Turn off subfile mode. + (if (and buffer-file-name tar-subfile-mode) + (tar-subfile-mode -1))) + +(defun tar-mode-revert (&optional no-autosave no-confirm) + "Revert this buffer and turn on tar mode again, to re-compute the +directory listing." + (setq tar-header-offset nil) + (let ((revert-buffer-function nil)) + (revert-buffer t no-confirm) + (widen)) + (tar-mode)) + + +(defun tar-next-line (p) + (interactive "p") + (forward-line p) + (if (eobp) nil (forward-char (if tar-can-print-dates 48 36)))) + +(defun tar-previous-line (p) + (interactive "p") + (tar-next-line (- p))) + +(defun tar-current-descriptor (&optional noerror) + "Returns the tar-descriptor of the current line, or signals an error." + ;; I wish lines had plists, like in ZMACS... + (or (nth (count-lines (point-min) + (save-excursion (beginning-of-line) (point))) + tar-parse-info) + (if noerror + nil + (error "This line does not describe a tar-file entry.")))) + + +(defun tar-extract (&optional other-window-p) + "In tar-mode, extract this entry of the tar file into its own buffer." + (interactive) + (let* ((view-p (eq other-window-p 'view)) + (descriptor (tar-current-descriptor)) + (tokens (tar-desc-tokens descriptor)) + (name (tar-header-name tokens)) + (size (tar-header-size tokens)) + (link-p (tar-header-link-type tokens)) + (start (+ (tar-desc-data-start descriptor) tar-header-offset -1)) + (end (+ start size))) + (if link-p + (error "This is a %s, not a real file." + (cond ((eq link-p 5) "directory") + ((eq link-p 20) "tar directory header") + ((eq link-p 29) "multivolume-continuation") + ((eq link-p 35) "sparse entry") + ((eq link-p 38) "volume header") + (t "link")))) + (if (zerop size) (error "This is a zero-length file.")) + (let* ((tar-buffer (current-buffer)) + (bufname (file-name-nondirectory name)) + (bufid (concat ;" (" name " in " + " (in " + (file-name-nondirectory (buffer-file-name)) + ")")) + (read-only-p (or buffer-read-only view-p)) + (buffer nil) + (buffers (buffer-list)) + (just-created nil)) + ;; find a buffer visiting this subfile from this tar file. + (while (and buffers (not buffer)) + (set-buffer (car buffers)) + (if (and (null (buffer-file-name (car buffers))) + (boundp 'tar-superior-descriptor) + (eq tar-superior-descriptor descriptor)) + (setq buffer (car buffers)) + (setq buffers (cdr buffers)))) + (set-buffer tar-buffer) + (if buffer + nil + (setq buffer (generate-new-buffer bufname)) + (setq just-created t) + (unwind-protect + (progn + (widen) + (save-excursion + (set-buffer buffer) + (insert-buffer-substring tar-buffer start end) + (goto-char 0) + (let ((lock-directory nil)) ; disable locking + (set-visited-file-name name) ; give it a name to decide mode. + ;; (normal-mode) ; pick a mode. + ;; (after-find-file nil nil) ; pick a mode; works with crypt.el + ;; Ok, instead of running after-find-file, just invoke the + ;; find-file-hooks instead. This does everything we want + ;; from after-find-file, without losing when visiting .tar + ;; files via ange-ftp: doesn't probe the ftp site for the + ;; name of the subfile. + (normal-mode t) + (run-hooks 'find-file-hooks) + (set-visited-file-name nil) ; nuke the name - not meaningful. + ) + (make-local-variable 'tar-superior-buffer) + (make-local-variable 'tar-superior-descriptor) + (make-local-variable 'mode-line-buffer-identification) + (make-local-variable 'tar-subfile-buffer-id) + (make-local-variable 'subfile-orig-mlbid) + (setq tar-superior-buffer tar-buffer) + (setq tar-superior-descriptor descriptor) + (setq tar-subfile-buffer-id bufid) + (setq subfile-orig-mlbid mode-line-buffer-identification) + (cond ((stringp mode-line-buffer-identification) + (setq mode-line-buffer-identification + (list mode-line-buffer-identification)))) + (let ((ms (car mode-line-buffer-identification)) + n) + (cond ((and (stringp ms) + (string-match "%\\([0-9]+\\)b\\'" ms)) + (setq mode-line-buffer-identification + (cons + (concat (substring ms 0 + (1- (match-beginning 1))) + (substring ms (1+ (match-end 1)))) + (cons + (list (car (read-from-string + (substring ms (match-beginning 1) + (match-end 1)))) + (concat "%b" tar-subfile-buffer-id)) + (cdr mode-line-buffer-identification))))) + (t + (setq mode-line-buffer-identification + (list "Emacs: " + (list 17 + (concat "%b" + tar-subfile-buffer-id))))))) + (tar-subfile-mode 1) + + (setq buffer-read-only read-only-p) + (set-buffer-modified-p nil)) + (set-buffer tar-buffer)) + (narrow-to-region 1 tar-header-offset))) + (if view-p + (progn + (view-buffer-other-window buffer) + (save-excursion + (set-buffer buffer) + ;; for view-less.el; view.el can't do this. + (set (make-local-variable 'view-kill-on-exit) t))) + (if other-window-p + (switch-to-buffer-other-window buffer) + (switch-to-buffer buffer)))))) + + +(defun tar-extract-other-window () + "In tar-mode, extract this entry of the tar file into its own buffer." + (interactive) + (tar-extract t)) + +(defun tar-view () + "In tar-mode, view the tar file entry on this line." + (interactive) + (tar-extract 'view)) + + +(defun tar-read-file-name (&optional prompt) + "Read a file name with this line's entry as the default." + (or prompt (setq prompt "Copy to: ")) + (let* ((default-file (expand-file-name + (tar-header-name (tar-desc-tokens + (tar-current-descriptor))))) + (target (expand-file-name + (read-file-name prompt + (file-name-directory default-file) + default-file nil)))) + (if (or (string= "" (file-name-nondirectory target)) + (file-directory-p target)) + (setq target (concat (if (string-match "/$" target) + (substring target 0 (1- (match-end 0))) + target) + "/" + (file-name-nondirectory default-file)))) + target)) + + +(defun tar-copy (&optional to-file) + "In tar-mode, extract this entry of the tar file into a file on disk. +If TO-FILE is not supplied, it is prompted for, defaulting to the name of +the current tar-entry." + (interactive (list (tar-read-file-name))) + (let* ((descriptor (tar-current-descriptor)) + (tokens (tar-desc-tokens descriptor)) + (name (tar-header-name tokens)) + (size (tar-header-size tokens)) + (link-p (tar-header-link-type tokens)) + (start (+ (tar-desc-data-start descriptor) tar-header-offset -1)) + (end (+ start size))) + (if link-p (error "This is a link, not a real file.")) + (if (zerop size) (error "This is a zero-length file.")) + (let* ((tar-buffer (current-buffer)) + buffer) + (unwind-protect + (progn + (setq buffer (generate-new-buffer "*tar-copy-tmp*")) + (widen) + (save-excursion + (set-buffer buffer) + (insert-buffer-substring tar-buffer start end) + (set-buffer-modified-p nil) ; in case we abort + (write-file to-file) + (message "Copied tar entry %s to %s" name to-file) + (set-buffer tar-buffer))) + (narrow-to-region 1 tar-header-offset) + (if buffer (kill-buffer buffer))) + ))) + + +(defun tar-flag-deleted (p &optional unflag) + "In tar-mode, mark this sub-file to be deleted from the tar file. +With a prefix argument, mark that many files." + (interactive "p") + (beginning-of-line) + (dotimes (i (if (< p 0) (- p) p)) + (if (tar-current-descriptor unflag) ; barf if we're not on an entry-line. + (progn + (delete-char 1) + (insert (if unflag " " "D")))) + (forward-line (if (< p 0) -1 1))) + (if (eobp) nil (forward-char 36))) + +(defun tar-unflag (p) + "In tar-mode, un-mark this sub-file if it is marked to be deleted. +With a prefix argument, un-mark that many files forward." + (interactive "p") + (tar-flag-deleted p t)) + +(defun tar-unflag-backwards (p) + "In tar-mode, un-mark this sub-file if it is marked to be deleted. +With a prefix argument, un-mark that many files backward." + (interactive "p") + (tar-flag-deleted (- p) t)) + + +(defun tar-expunge-internal () + "Expunge the tar-entry specified by the current line." + (let* ((descriptor (tar-current-descriptor)) + (tokens (tar-desc-tokens descriptor)) + (line (tar-desc-data-start descriptor)) + (name (tar-header-name tokens)) + (size (tar-header-size tokens)) + (link-p (tar-header-link-type tokens)) + (start (tar-desc-data-start descriptor)) + (following-descs (cdr (memq descriptor tar-parse-info)))) + (if link-p (setq size 0)) ; size lies for hard-links. + ;; + ;; delete the current line... + (beginning-of-line) + (let ((line-start (point))) + (end-of-line) (forward-char) + (let ((line-len (- (point) line-start))) + (delete-region line-start (point)) + ;; + ;; decrement the header-pointer to be in synch... + (setq tar-header-offset (- tar-header-offset line-len)))) + ;; + ;; delete the data pointer... + (setq tar-parse-info (delq descriptor tar-parse-info)) + ;; + ;; delete the data from inside the file... + (widen) + (let* ((data-start (+ start tar-header-offset -513)) + (data-end (+ data-start 512 (ash (ash (+ size 511) -9) 9)))) + (delete-region data-start data-end) + ;; + ;; and finally, decrement the start-pointers of all following + ;; entries in the archive. This is a pig when deleting a bunch + ;; of files at once - we could optimize this to only do the + ;; iteration over the files that remain, or only iterate up to + ;; the next file to be deleted. + (let ((data-length (- data-end data-start))) + (dolist (desc following-descs) + (setf (tar-desc-data-start desc) + (- (tar-desc-data-start desc) data-length)))) + )) + (narrow-to-region 1 tar-header-offset)) + + +(defun tar-expunge (&optional noconfirm) + "In tar-mode, delete all the archived files flagged for deletion. +This does not modify the disk image; you must save the tar file itself +for this to be permanent." + (interactive) + (if (or noconfirm + (y-or-n-p "Expunge files marked for deletion? ")) + (let ((n 0)) + (save-excursion + (goto-char 0) + (while (not (eobp)) + (if (looking-at "D") + (progn (tar-expunge-internal) + (setq n (1+ n))) + (forward-line 1))) + ;; after doing the deletions, add any padding that may be necessary. + (tar-pad-to-blocksize) + (narrow-to-region 1 tar-header-offset) + ) + (if (zerop n) + (message "Nothing to expunge.") + (message "%s files expunged. Be sure to save this buffer." n))))) + + +(defun tar-clear-modification-flags () + "Remove the stars at the beginning of each line." + (interactive) + (save-excursion + (goto-char 0) + (while (< (point) tar-header-offset) + (if (looking-at "*") + (progn (delete-char 1) (insert " "))) + (forward-line 1)))) + + +(defun tar-chown-entry (new-uid) + "Change the user-id associated with this entry in the tar file. +If this tar file was written by GNU tar, then you will be able to edit +the user id as a string; otherwise, you must edit it as a number. +You can force editing as a number by calling this with a prefix arg. +This does not modify the disk image; you must save the tar file itself +for this to be permanent." + (interactive (list + (let ((tokens (tar-desc-tokens (tar-current-descriptor)))) + (if (or current-prefix-arg + (not (tar-header-magic tokens))) + (let (n) + (while (not (numberp (setq n (read-minibuffer + "New UID number: " + (format "%s" (tar-header-uid tokens))))))) + n) + (read-string "New UID string: " (tar-header-uname tokens)))))) + (cond ((stringp new-uid) + (setf (tar-header-uname (tar-desc-tokens (tar-current-descriptor))) + new-uid) + (tar-alter-one-field tar-uname-offset (concat new-uid "\000"))) + (t + (setf (tar-header-uid (tar-desc-tokens (tar-current-descriptor))) + new-uid) + (tar-alter-one-field + tar-uid-offset + (concat (substring (format "%6o" new-uid) 0 6) "\000 "))))) + + +(defun tar-chgrp-entry (new-gid) + "Change the group-id associated with this entry in the tar file. +If this tar file was written by GNU tar, then you will be able to edit +the group id as a string; otherwise, you must edit it as a number. +You can force editing as a number by calling this with a prefix arg. +This does not modify the disk image; you must save the tar file itself +for this to be permanent." + (interactive (list + (let ((tokens (tar-desc-tokens (tar-current-descriptor)))) + (if (or current-prefix-arg + (not (tar-header-magic tokens))) + (let (n) + (while (not (numberp (setq n (read-minibuffer + "New GID number: " + (format "%s" (tar-header-gid tokens))))))) + n) + (read-string "New GID string: " (tar-header-gname tokens)))))) + (cond ((stringp new-gid) + (setf (tar-header-gname (tar-desc-tokens (tar-current-descriptor))) + new-gid) + (tar-alter-one-field tar-gname-offset + (concat new-gid "\000"))) + (t + (setf (tar-header-gid (tar-desc-tokens (tar-current-descriptor))) + new-gid) + (tar-alter-one-field + tar-gid-offset + (concat (substring (format "%6o" new-gid) 0 6) "\000 "))))) + +(defun tar-rename-entry (new-name) + "Change the name associated with this entry in the tar file. +This does not modify the disk image; you must save the tar file itself +for this to be permanent." + (interactive + (list (read-string "New name: " + (tar-header-name + (tar-desc-tokens (tar-current-descriptor)))))) + (if (string= "" new-name) (error "zero length name")) + (if (> (length new-name) 98) (error "name too long")) + (setf (tar-header-name (tar-desc-tokens (tar-current-descriptor))) + new-name) + (tar-alter-one-field 0 + (substring (concat new-name (make-string 99 0)) 0 99))) + + +(defun tar-chmod-entry (new-mode) + "Change the protection bits associated with this entry in the tar file. +This does not modify the disk image; you must save the tar file itself +for this to be permanent." + (interactive (list (tar-parse-octal-integer-safe + (read-string "New protection (octal): ")))) + (setf (tar-header-mode (tar-desc-tokens (tar-current-descriptor))) + new-mode) + (tar-alter-one-field + tar-mode-offset + (concat (substring (format "%6o" new-mode) 0 6) "\000 "))) + + +(defun tar-alter-one-field (data-position new-data-string) + (let* ((descriptor (tar-current-descriptor)) + (tokens (tar-desc-tokens descriptor))) + (unwind-protect + (save-excursion + ;; + ;; update the header-line. + (beginning-of-line) + (let ((p (point))) + (forward-line 1) + (delete-region p (point)) + (insert (tar-summarize-header-block tokens) "\n") + (setq tar-header-offset (point-max))) + + (widen) + (let* ((start (+ (tar-desc-data-start descriptor) tar-header-offset -513))) + ;; + ;; delete the old field and insert a new one. + (goto-char (+ start data-position)) + (delete-region (point) (+ (point) (length new-data-string))) ; <-- + (insert new-data-string) ; <-- + ;; + ;; compute a new checksum and insert it. + (let ((chk (tar-header-block-checksum + (buffer-substring start (+ start 512))))) + (goto-char (+ start tar-chk-offset)) + (delete-region (point) (+ (point) 8)) + (insert (format "%6o" chk)) + (insert 0) + (insert ? ) + (setf (tar-header-checksum tokens) chk) + ;; + ;; ok, make sure we didn't botch it. + (tar-header-block-check-checksum + (buffer-substring start (+ start 512)) + chk (tar-header-name tokens))))) + (narrow-to-region 1 tar-header-offset)))) + + +(defun tar-subfile-save-buffer () + "In tar subfile mode, save this buffer into its parent tar-file buffer. +This doesn't write anything to disk; you must save the parent tar-file buffer +to make your changes permanent." + (interactive) + (cond (buffer-file-name + ;; tar-subfile buffers should have nil as buffer-file-name. If they + ;; ever gain a buffer-file-name, that means they have been written to + ;; a real disk file, as with ^X^W. If this happens, behave just like + ;; `save-buffer.' + (call-interactively 'save-buffer)) + (t + (tar-subfile-save-buffer-internal)))) + +(defun tar-subfile-save-buffer-internal () + (if (not (and (boundp 'tar-superior-buffer) tar-superior-buffer)) + (error "This buffer has no superior tar file buffer.")) + (or (buffer-name tar-superior-buffer) + (error "The superior tar file's buffer has been killed.")) + (if (not (and (boundp 'tar-superior-descriptor) tar-superior-descriptor)) + (error "This buffer doesn't have an index into its superior tar file!")) + + ;; Notice when crypt.el has uncompressed while reading the subfile, and + ;; signal an error if the user tries to save back into the parent file + ;; (because it won't work - the .Z subfile it writes won't really be + ;; compressed.) + ;; + ; ;; These are for the old crypt.el + ; (if (and (boundp 'buffer-save-encrypted) buffer-save-encrypted) + ; (error "Don't know how to encrypt back into a tar file.")) + ; (if (and (boundp 'buffer-save-compacted) buffer-save-compacted) + ; (error "Don't know how to compact back into a tar file.")) + ; (if (and (boundp 'buffer-save-compressed) buffer-save-compressed) + ; (error "Don't know how to compress back into a tar file.")) + ; (if (and (boundp 'buffer-save-gzipped) buffer-save-gzipped) + ; (error "Don't know how to gzip back into a tar file.")) + + ;; These are for the new crypt++.el + (if (and (boundp 'crypt-buffer-save-encrypted) crypt-buffer-save-encrypted) + (error "Don't know how to encrypt back into a tar file.")) + (if (and (boundp 'crypt-buffer-save-compact) crypt-buffer-save-compact) + (error "Don't know how to compact back into a tar file.")) + (if (and (boundp 'crypt-buffer-save-compress) crypt-buffer-save-compress) + (error "Don't know how to compress back into a tar file.")) + (if (and (boundp 'crypt-buffer-save-gzip) crypt-buffer-save-gzip) + (error "Don't know how to gzip back into a tar file.")) + (if (and (boundp 'crypt-buffer-save-freeze) crypt-buffer-save-freeze) + (error "Don't know how to freeze back into a tar file.")) + + (save-excursion + (let ((subfile (current-buffer)) + (subfile-size (buffer-size)) + (descriptor tar-superior-descriptor)) + (set-buffer tar-superior-buffer) + (let* ((tokens (tar-desc-tokens descriptor)) + (start (tar-desc-data-start descriptor)) + (name (tar-header-name tokens)) + (size (tar-header-size tokens)) + (size-pad (ash (ash (+ size 511) -9) 9)) + (head (memq descriptor tar-parse-info)) + (following-descs (cdr head))) + (if (not head) + (error "Can't find this tar file entry in its parent tar file!")) + (unwind-protect + (save-excursion + (widen) + ;; delete the old data... + (let* ((data-start (+ start tar-header-offset -1)) + (data-end (+ data-start (ash (ash (+ size 511) -9) 9)))) + (delete-region data-start data-end) + ;; insert the new data... + (goto-char data-start) + (insert-buffer subfile) + ;; + ;; pad the new data out to a multiple of 512... + (let ((subfile-size-pad (ash (ash (+ subfile-size 511) -9) 9))) + (goto-char (+ data-start subfile-size)) + (insert (make-string (- subfile-size-pad subfile-size) 0)) + ;; + ;; update the data pointer of this and all following files... + (setf (tar-header-size tokens) subfile-size) + (let ((difference (- subfile-size-pad size-pad))) + (dolist (desc following-descs) + (setf (tar-desc-data-start desc) + (+ (tar-desc-data-start desc) difference)))) + ;; + ;; Update the size field in the header block. + (let ((header-start (- data-start 512))) + (goto-char (+ header-start tar-size-offset)) + (delete-region (point) (+ (point) 12)) + (insert (format "%11o" subfile-size)) + (insert ? ) + ;; + ;; Maybe update the datestamp. + (if (not tar-update-datestamp) + nil + (goto-char (+ header-start tar-time-offset)) + (delete-region (point) (+ (point) 12)) + (let (now top bot) + (cond ((fboundp 'current-time) + (setq now (current-time)) + (setcdr now (car (cdr now)))) + ; ((fboundp 'current-time-seconds) + ; (setq now (current-time-seconds))) + ) + (setq top (car now) + bot (cdr now)) + (cond + (now + (setf (tar-header-date tokens) now) + ;; hair to print two 16-bit numbers as one octal number. + (setq bot (logior (ash (logand top 3) 16) bot)) + (setq top (ash top -2)) + (insert (format "%5o" top)) + (insert (format "%06o " bot))) + (t + ;; otherwise, set it to the epoch. + (insert (format "%11o " 0)) + (setf (tar-header-date tokens) (cons 0 0)) + )))) + ;; + ;; compute a new checksum and insert it. + (let ((chk (tar-header-block-checksum + (buffer-substring header-start data-start)))) + (goto-char (+ header-start tar-chk-offset)) + (delete-region (point) (+ (point) 8)) + (insert (format "%6o" chk)) + (insert 0) + (insert ? ) + (setf (tar-header-checksum tokens) chk))) + ;; + ;; alter the descriptor-line... + ;; + (let ((position (- (length tar-parse-info) (length head)))) + (goto-char 1) + (next-line position) + (beginning-of-line) + (let ((p (point)) + (m (set-marker (make-marker) tar-header-offset))) + (forward-line 1) + (delete-region p (point)) + (insert-before-markers (tar-summarize-header-block tokens t) "\n") + (setq tar-header-offset (marker-position m))) + ))) + ;; after doing the insertion, add any final padding that may be necessary. + (tar-pad-to-blocksize)) + (narrow-to-region 1 tar-header-offset))) + (set-buffer-modified-p t) ; mark the tar file as modified + (set-buffer subfile) + (set-buffer-modified-p nil) ; mark the tar subfile as unmodified + (message "saved into tar-buffer \"%s\" - remember to save that buffer!" + (buffer-name tar-superior-buffer)) + ))) + + +(defun tar-pad-to-blocksize () + "If we are being anal about tar file blocksizes, fix up the current buffer. +Leaves the region wide." + (if (null tar-anal-blocksize) + nil + (widen) + (let* ((last-desc (nth (1- (length tar-parse-info)) tar-parse-info)) + (start (tar-desc-data-start last-desc)) + (tokens (tar-desc-tokens last-desc)) + (link-p (tar-header-link-type tokens)) + (size (if link-p 0 (tar-header-size tokens))) + (data-end (+ start size)) + (bbytes (ash tar-anal-blocksize 9)) + (pad-to (+ bbytes (* bbytes (/ (1- data-end) bbytes)))) + (buffer-read-only nil) ; ## + ) + ;; If the padding after the last data is too long, delete some; + ;; else insert some until we are padded out to the right number of blocks. + ;; + (goto-char (+ (or tar-header-offset 0) data-end)) + (if (> (1+ (buffer-size)) (+ (or tar-header-offset 0) pad-to)) + (delete-region (+ (or tar-header-offset 0) pad-to) (1+ (buffer-size))) + (insert (make-string (- (+ (or tar-header-offset 0) pad-to) + (1+ (buffer-size))) + 0))) + ))) + + +(defun tar-maybe-write-file () + "Used as a write-file-hook to write tar-files out correctly." + ;; + ;; If the current buffer is in tar-mode and has its header-offset set, + ;; remove the header from the file, call the remaining write-file hooks, + ;; and then write out the buffer (if and only if one of the write-file + ;; hooks didn't write it already). Then put the header back on the + ;; buffer. Many thanks to Piet van Oostrum for this code, which causes + ;; correct interaction with crypt.el (and probably anything like it.) + ;; + ;; Kludge: in XEmacs Emacs, write-file-hooks is bound to nil before the + ;; write-file-hooks are run, to prevent them from being run recursively + ;; (this is more of a danger in v19-vintage emacses, which have both + ;; write-file-hooks and write-contents-hooks.) So, we need to reference + ;; an internal variable of basic-save-buffer to get the list of hooks + ;; remaining to be run. + ;; + (and (eq major-mode 'tar-mode) + (and (boundp 'tar-header-offset) tar-header-offset) + (let* ((hooks (cond ((string-match "XEmacs" emacs-version) + ;; Internal to basic-save-buffer in XEmacs. + (symbol-value 'hooks)) + ((string-lessp "19" emacs-version) + ;; I think this is what we need to do in fsfmacs. + (append write-contents-hooks write-file-hooks)) + (t + write-file-hooks))) + (remaining-hooks (cdr (memq 'tar-maybe-write-file hooks))) + header-string + done) + (save-excursion + (save-restriction + (widen) + (tar-clear-modification-flags) + (setq header-string (buffer-substring 1 tar-header-offset)) + (delete-region 1 tar-header-offset) + (unwind-protect + (progn + (while (and remaining-hooks + (not (setq done (funcall (car remaining-hooks))))) + (setq remaining-hooks (cdr remaining-hooks))) + (cond ((not done) + (write-region 1 (1+ (buffer-size)) + buffer-file-name nil t) + (setq done t)))) + (goto-char 1) + (insert header-string) + (set-buffer-modified-p nil)))) + done))) + + +;;; Patch it in. + +(defvar tar-regexp "\\.\\(tar\\|tgz\\)$" + "The regular expression used to identify tar file names.") + +(setq auto-mode-alist + (cons (cons tar-regexp 'tar-mode) auto-mode-alist)) + +;; Note: the tar write-file-hook should go on the list *before* any other +;; hooks which might write the file. Since things like crypt-mode add things +;; to the end of the write-file-hooks, this will normally be the case. + + ;(or (boundp 'write-file-hooks) (setq write-file-hooks nil)) + ;(or (listp write-file-hooks) + ; (setq write-file-hooks (list write-file-hooks))) + ;(or (memq 'tar-maybe-write-file write-file-hooks) + ; (setq write-file-hooks + ; (cons 'tar-maybe-write-file write-file-hooks))) + +(add-hook 'write-file-hooks 'tar-maybe-write-file) ; ####write-contents-hooks?? +(cond ((boundp 'after-save-hook) + (add-hook 'after-save-hook 'tar-subfile-after-write-file-hook)) + ((boundp 'after-write-file-hooks) + (add-hook 'after-write-file-hooks 'tar-subfile-after-write-file-hook)) + (t (error "neither after-save-hook nor after-write-file-hooks?"))) + + +;;; This is a hack. For files ending in .tar, we want -*- lines to be +;;; completely ignored - if there is one, it applies to the first file +;;; in the archive, and not the archive itself! Similarly for local +;;; variables specifications in the last file of the archive. + +(defun tar-normal-mode (&optional find-file) + "Choose the major mode for this buffer automatically. +Also sets up any specified local variables of the file. +Uses the visited file name, the -*- line, and the local variables spec. + +This function is called automatically from `find-file'. In that case, +if `inhibit-local-variables' is non-`nil' we require confirmation before +processing a local variables spec. If you run `normal-mode' explicitly, +confirmation is never required. + +Note that this version of this function has been hacked to interact +correctly with tar files - when visiting a file which matches +'tar-regexp', the -*- line and local-variables are not examined, +as they would apply to a file within the archive rather than the archive +itself." + (interactive) + (if (and buffer-file-name + (string-match tar-regexp buffer-file-name)) + (tar-mode) + (tar-real-normal-mode find-file))) + +;; We have to shadow this as well to get along with crypt.el. +;; Shadowing this alone isn't enough, though; we need to shadow +;; tar-normal-mode in order to inhibit the local variables of the +;; last file in the tar archive. +;; +(defun tar-set-auto-mode () + "Select major mode appropriate for current buffer. +May base decision on visited file name (See variable auto-mode-list) +or on buffer contents (-*- line or local variables spec), but does not look +for the \"mode:\" local variable. For that, use hack-local-variables. + +Note that this version of this function has been hacked to interact +correctly with tar files - when visiting a file which matches +'tar-regexp', the -*- line and local-variables are not examined, +as they would apply to a file within the archive rather than the archive +itself." + (interactive) + (if (and buffer-file-name + (string-match tar-regexp buffer-file-name)) + (tar-mode) + (tar-real-set-auto-mode))) + +(if (not (fboundp 'tar-real-normal-mode)) + (fset 'tar-real-normal-mode (symbol-function 'normal-mode))) +(fset 'normal-mode 'tar-normal-mode) + +(if (not (fboundp 'tar-real-set-auto-mode)) + (fset 'tar-real-set-auto-mode (symbol-function 'set-auto-mode))) +(fset 'set-auto-mode 'tar-set-auto-mode) + +(provide 'tar-mode) + +;;; tar-mode.el ends here diff --git a/telnet.el b/telnet.el new file mode 100644 --- /dev/null +++ b/telnet.el @@ -0,0 +1,341 @@ +;;; telnet.el --- run a telnet session from within an Emacs buffer + +;; Copyright (C) 1985, 1988, 1992, 1994 Free Software Foundation, Inc. + +;; Author: William F. Schelter +;; Keywords: comm, unix +;; Maintainer: Pete Ware <ware@cis.ohio-state.edu> + +;; This file is part of GNU Emacs. + +;; GNU Emacs 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 2, or (at your option) +;; any later version. + +;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; This mode is intended to be used for telnet or rsh to a remote host; +;; `telnet' and `rsh' are the two entry points. Multiple telnet or rsh +;; sessions are supported. +;; +;; Normally, input is sent to the remote telnet/rsh line-by-line, as you +;; type RET or LFD. C-c C-c sends a C-c to the remote immediately; +;; C-c C-z sends C-z immediately. C-c C-q followed by any character +;; sends that character immediately. +;; +;; All RET characters are filtered out of the output coming back from the +;; remote system. The mode tries to do other useful translations based +;; on what it sees coming back from the other system before the password +;; query. It knows about UNIX, ITS, TOPS-20 and Explorer systems. +;; +;; You can use the global telnet-host-properties to associate a telnet +;; program and login name with each host you regularly telnet to. + +;;; Code: + +;; to do fix software types for lispm: +;; to eval current expression. Also to try to send escape keys correctly. +;; essentially we'll want the rubout-handler off. + +;; filter is simplistic but should be okay for typical shell usage. +;; needs hacking if it is going to deal with asynchronous output in a sane +;; manner + +(require 'comint) + +(defgroup telnet nil + "Run a telnet session from within an Emacs buffer." + :group 'comint) + +(defvar telnet-host-properties () + "Specify which telnet program to use for particular hosts. +Each element has the form (HOSTNAME PROGRAM [LOGIN-NAME]) +HOSTNAME says which machine the element applies to. +PROGRAM says which program to run, to talk to that machine. +LOGIN-NAME, which is optional, says what to log in as on that machine.") + +(defvar telnet-new-line "\r") +(defvar telnet-mode-map nil) +(defvar telnet-default-prompt-pattern "^[^#$%>\n]*[#$%>] *") +(defvar telnet-prompt-pattern telnet-default-prompt-pattern) + +(defvar telnet-replace-c-g nil) +(make-variable-buffer-local + (defvar telnet-remote-echoes t + "True if the telnet process will echo input.")) +(make-variable-buffer-local + (defvar telnet-interrupt-string "\C-c" "String sent by C-c.")) + +(defvar telnet-count 0 + "Number of output strings read from the telnet process +while looking for the initial password.") +;; (make-variable-buffer-local 'telnet-count) + +(defcustom telnet-program "telnet" + "*Program to run to open a telnet connection." + :type 'string + :group 'telnet) + +(defcustom rsh-eat-password-string nil + "Non-nil means rsh will look for a string matching a password prompt." + :type 'boolean + :group 'telnet) + +(defvar telnet-initial-count -75 + "Initial value of `telnet-count'. Should be set to the negative of the +number of terminal writes telnet will make setting up the host connection.") + +(defvar telnet-maximum-count 4 + "Maximum value `telnet-count' can have. +After this many passes, we stop looking for initial setup data. +Should be set to the number of terminal writes telnet will make +rejecting one login and prompting again for a username and password.") + +(defun telnet-interrupt-subjob () + (interactive) + "Interrupt the program running through telnet on the remote host." + (process-send-string nil telnet-interrupt-string)) + +(defun telnet-c-z () + (interactive) + (process-send-string nil "\C-z")) + +;; Keep telnet- prefix) +(defun telnet-send-process-next-char () + (interactive) + (process-send-string nil + (char-to-string + (let ((inhibit-quit t)) + (prog1 (read-char) + (setq quit-flag nil)))))) + +; initialization on first load. +(if telnet-mode-map + nil + (setq telnet-mode-map (make-sparse-keymap)) + (set-keymap-parent telnet-mode-map comint-mode-map) + (define-key telnet-mode-map "\C-m" 'telnet-send-input) +; (define-key telnet-mode-map "\C-j" 'telnet-send-input) + (define-key telnet-mode-map "\C-c\C-q" 'telnet-send-process-next-char) + (define-key telnet-mode-map "\C-c\C-c" 'telnet-interrupt-subjob) + (define-key telnet-mode-map "\C-c\C-z" 'telnet-c-z)) + +;;maybe should have a flag for when have found type +(defun telnet-check-software-type-initialize (string) + "Tries to put correct initializations in. Needs work." + (let ((case-fold-search t)) + (cond ((string-match "unix" string) + (setq telnet-prompt-pattern shell-prompt-pattern) + (setq telnet-new-line "\n")) + ((string-match "tops-20" string) ;;maybe add telnet-replace-c-g + (setq telnet-prompt-pattern "[@>] *")) + ((string-match "its" string) + (setq telnet-prompt-pattern "^[^*>\n]*[*>] *")) + ((string-match "explorer" string) ;;explorer telnet needs work + (setq telnet-replace-c-g ?\n)))) + (setq comint-prompt-regexp telnet-prompt-pattern)) + +(defun telnet-initial-filter (proc string) + (let ((case-fold-search t)) + ;For reading up to and including password; also will get machine type. + (cond ((string-match "No such host" string) + (kill-buffer (process-buffer proc)) + (error "No such host.")) + ((string-match "passw" string) + (telnet-filter proc string) + (let ((password (comint-read-noecho "Password: " t))) + (setq telnet-count 0) + (process-send-string proc (concat password telnet-new-line)))) + (t (telnet-check-software-type-initialize string) + (telnet-filter proc string) + (cond ((> telnet-count telnet-maximum-count) + ;; (set-process-filter proc 'telnet-filter) Kludge + ;; for shell-fonts -- this is the only mode that + ;; actually changes what its process filter is at + ;; run time, which confuses shell-font. So we + ;; special-case that here. + ;; #### Danger, knows an internal shell-font variable name. + (let ((old-filter (process-filter proc))) + (if (eq old-filter 'shell-font-process-filter) + (set (make-local-variable 'shell-font-process-filter) + 'telnet-filter) + (set-process-filter proc 'telnet-filter)))) + (t (setq telnet-count (1+ telnet-count)))))))) + +;; Identical to comint-simple-send, except that it sends telnet-new-line +;; instead of "\n". +(defun telnet-simple-send (proc string) + (comint-send-string proc string) + (comint-send-string proc telnet-new-line)) + +(defun telnet-filter (proc string) + (save-excursion + (set-buffer (process-buffer proc)) + (save-match-data + (let* ((last-insertion (marker-position (process-mark proc))) + (delta (- (point) last-insertion)) + (ie (and comint-last-input-end + (marker-position comint-last-input-end))) + (w (get-buffer-window (current-buffer))) + (ws (and w (window-start w)))) + (goto-char last-insertion) + ;; Insert STRING, omitting all C-m characters. + (insert-before-markers string) + (set-marker (process-mark proc) (point)) + ;; the insert-before-markers may have screwed window-start + ;; and likely moved comint-last-input-end. This is why the + ;; insertion-reaction should be a property of markers, not + ;; of the function which does the inserting. + (if ws (set-window-start w ws t)) + (if ie (set-marker comint-last-input-end ie)) + (while (progn (skip-chars-backward "^\C-m" last-insertion) + (> (point) last-insertion)) + (delete-region (1- (point)) (point))) + (goto-char (process-mark proc)) + (and telnet-replace-c-g + (subst-char-in-region last-insertion (point) ?\C-g + telnet-replace-c-g t)) + ;; If point is after the insertion place, move it + ;; along with the text. + (if (> delta 0) + (goto-char (+ (process-mark proc) delta))))))) + +(defun telnet-send-input () + (interactive) + (let ((proc (get-buffer-process (current-buffer))) + p1 p2) + (if (and telnet-remote-echoes + (>= (point) (process-mark proc))) + (save-excursion + (if comint-eol-on-send (end-of-line)) + (setq p1 (marker-position (process-mark proc)) + p2 (point)))) + (prog1 + (comint-send-input) + ;; at this point, comint-send-input has moved the process mark, inserted + ;; a newline, and possibly inserted the (echoed) output. If the host is + ;; in remote-echo mode, then delete our local copy of the command, and + ;; the newline that comint-send-input sent. + (if p1 + (delete-region p1 (1+ p2)))))) + +;;;###autoload (add-hook 'same-window-regexps "\\*telnet-.*\\*\\(\\|<[0-9]+>\\)") + +;;;###autoload +(defun telnet (host &optional port) + "Open a network login connection to host named HOST (a string). +With a prefix argument, prompts for the port name or number as well. +Communication with HOST is recorded in a buffer `*PROGRAM-HOST*' +where PROGRAM is the telnet program being used. This program +is controlled by the contents of the global variable `telnet-host-properties', +falling back on the value of the global variable `telnet-program'. +Normally input is edited in Emacs and sent a line at a time. +See also `\\[rsh]'." + (interactive (list (read-string "Open telnet connection to host: ") + (if current-prefix-arg + (read-string "Port name or number: ") + nil))) + (let* ((comint-delimiter-argument-list '(?\ ?\t)) + (properties (cdr (assoc host telnet-host-properties))) + (telnet-program (if properties (car properties) telnet-program)) + (name (concat telnet-program "-" (comint-arguments host 0 nil) )) + (buffer (get-buffer (concat "*" name "*"))) + (telnet-options (if (cdr properties) (cons "-l" (cdr properties)))) + process) + (if (and buffer (get-buffer-process buffer)) + (pop-to-buffer buffer) + (pop-to-buffer + (apply 'make-comint name telnet-program nil telnet-options)) + (setq process (get-buffer-process (current-buffer))) + (set-process-filter process 'telnet-initial-filter) + + ;; SunOS and IRIX don't print "unix" in their rsh or telnet + ;; login banners, so let's get a reasonable default here. + ;; #### This patch from jwz mimics what is done in rsh done + ;; below. However, it (along with the one in rsh) mean that + ;; telnet-check-software-type-initialize is effectively a + ;; wastoid function. Reworking it like it claims to need is + ;; probably the better solution but I'm not going to do it. + ;; --cet + (telnet-check-software-type-initialize "unix") + + ;; Don't send the `open' cmd till telnet is ready for it. + (accept-process-output process) + (erase-buffer) + (process-send-string process (concat "open " host + (if port (concat " " port) "") + "\n")) + (setq comint-input-sender 'telnet-simple-send) + (setq telnet-count telnet-initial-count) + (telnet-mode)))) + +(put 'telnet-mode 'mode-class 'special) + +(defun telnet-mode () + "This mode is for using telnet (or rsh) from a buffer to another host. +It has most of the same commands as comint-mode. +There is a variable ``telnet-interrupt-string'' which is the character +sent to try to stop execution of a job on the remote host. +Data is sent to the remote host when RET is typed. + +\\{telnet-mode-map} +" + (interactive) + (comint-mode) + (setq major-mode 'telnet-mode + mode-name "Telnet" + comint-prompt-regexp telnet-prompt-pattern) + (use-local-map telnet-mode-map) + (set (make-local-variable 'telnet-count) telnet-initial-count) + (run-hooks 'telnet-mode-hook)) + +;;;###autoload (add-hook 'same-window-regexps "\\*rsh-[^-]*\\*\\(\\|<[0-9]*>\\)") + +;;;###autoload +(defun rsh (host) + "Open a network login connection to host named HOST (a string). +Communication with HOST is recorded in a buffer `*rsh-HOST*'. +Normally input is edited in Emacs and sent a line at a time. +See also `\\[telnet]'." + (interactive "sOpen rsh connection to host: ") + (require 'shell) + (let ((name (concat "rsh-" host ))) + (pop-to-buffer (make-comint name remote-shell-program nil host)) + (setq telnet-count telnet-initial-count) + ;; + ;; SunOS doesn't print "unix" in its rsh login banner, so let's get a + ;; reasonable default here. There do exist non-Unix machines which + ;; speak the rsh protocol, but let's hope they print their OS name + ;; when one connects. + ;; + (telnet-check-software-type-initialize "unix") + ;; + ;; I think we should use telnet-filter here instead of -initial-filter, + ;; because rsh generally doesn't prompt for a password, and gobbling the + ;; first line that contains "passw" is extremely antisocial. More + ;; antisocial than echoing a password, and more likely than connecting + ;; to a non-Unix rsh host these days... + ;; + ;; I disagree with the above. -sb + ;; + (set-process-filter (get-process name) (if rsh-eat-password-string + 'telnet-initial-filter + 'telnet-filter)) + ;; (set-process-filter (get-process name) 'telnet-filter) + ;; run last so that hooks can change things. + (telnet-mode))) + +(provide 'telnet) + +;;; telnet.el ends here diff --git a/terminal.el b/terminal.el new file mode 100644 --- /dev/null +++ b/terminal.el @@ -0,0 +1,1280 @@ +;;; terminal.el --- terminal emulator for GNU Emacs. +;; Keywords: comm, terminals + +;; Copyright (C) 1986, 1987, 1988, 1989, 1993 Free Software Foundation, Inc. +;; Written by Richard Mlynarik, November 1986. +;; Face and attribute support added by Richard Mlynarik, April 1996. + +;; This file is part of XEmacs. + +;; XEmacs 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 2, or (at your option) +;; any later version. + +;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Synched up with: Not synched with FSF. + +;;#### TODO +;;#### terminfo? + +;;#### One probably wants to do setenv MORE -c when running with +;;#### more-processing enabled. + +(provide 'terminal) +(require 'ehelp) + +(defvar terminal-escape-char ?\C-^ + "*All characters except for this are passed verbatim through the +terminal-emulator. This character acts as a prefix for commands +to the emulator program itself. Type this character twice to send +it through the emulator. Type ? after typing it for a list of +possible commands. +This variable is local to each terminal-emulator buffer.") + +(defvar terminal-scrolling t + "*If non-nil, the terminal-emulator will `scroll' when output occurs +past the bottom of the screen. If nil, output will `wrap' to the top +of the screen. +This variable is local to each terminal-emulator buffer.") + +(defvar terminal-more-processing t + "*If non-nil, do more-processing. +This variable is local to each terminal-emulator buffer.") + +;; If you are the sort of loser who uses scrolling without more breaks +;; and expects to actually see anything, you should probably set this to +;; around 400 +(defvar terminal-redisplay-interval 5000 + "*Maximum number of characters which will be processed by the +terminal-emulator before a screen redisplay is forced. +Set this to a large value for greater throughput, +set it smaller for more frequent updates but overall slower +performance.") + +(defvar terminal-more-break-insertion + "*** More break -- Press space to continue ***") + +(defvar terminal-escape-map nil) +(defvar terminal-map nil) +(defvar terminal-more-break-map nil) +(if terminal-map + nil + (let ((map (make-keymap))) + (set-keymap-name map 'terminal-map) + + (let ((meta-prefix-char -1) + (s (make-string 1 0)) + (i 0)) + (while (< i 256) + (aset s 0 i) + (define-key map s 'te-pass-through) + (setq i (1+ i)))) + + ;(define-key map "\C-l" + ; '(lambda () (interactive) (te-pass-through) (redraw-display))) + (setq terminal-map map))) + +(if terminal-escape-map + nil + (let ((map (make-keymap))) + (set-keymap-name map 'terminal-escape-map) + (let ((s (make-string 1 ?0))) + (while (<= (aref s 0) ?9) + (define-key map s 'digit-argument) + (aset s 0 (1+ (aref s 0))))) + (define-key map "b" 'switch-to-buffer) + (define-key map "o" 'other-window) + (define-key map "e" 'te-set-escape-char) + (define-key map "\C-l" 'redraw-display) + (define-key map "\C-o" 'te-flush-pending-output) + (define-key map "m" 'te-toggle-more-processing) + (define-key map "x" 'te-escape-extended-command) + (define-key map "?" 'te-escape-help) + (define-key map (vector help-char) 'te-escape-help) + (setq terminal-escape-map map))) + +(defvar te-escape-command-alist '()) +(if te-escape-command-alist + nil + (setq te-escape-command-alist + '(("Set Escape Character" . te-set-escape-char) + ("Refresh" . redraw-display) + ("Record Output" . te-set-output-log) + ("Photo" . te-set-output-log) + ("Tofu" . te-tofu) ;; confuse the uninitiated + ("Stuff Input" . te-stuff-string) + ("Flush Pending Output" . te-flush-pending-output) + ("Enable More Processing" . te-enable-more-processing) + ("Disable More Processing" . te-disable-more-processing) + ("Scroll at end of page" . te-do-scrolling) + ("Wrap at end of page" . te-do-wrapping) + ("Switch To Buffer" . switch-to-buffer) + ("Other Window" . other-window) + ("Kill Buffer" . kill-buffer) + ("Help" . te-escape-help) + ("Set Redisplay Interval" . te-set-redisplay-interval) + ))) + +;(setq terminal-more-break-map nil) +(if terminal-more-break-map + nil + (let ((map (make-keymap))) + (set-keymap-name map 'terminal-more-break-map) + + (let ((meta-prefix-char -1) + (s (make-string 1 0)) + (i 0)) + (while (< i 256) + (aset s 0 i) + (define-key map s 'te-more-break-unwind) + (setq i (1+ i)))) + + (define-key map (vector help-char) 'te-more-break-help) + (define-key map " " 'te-more-break-resume) + (define-key map "\C-l" 'redraw-display) + (define-key map "\C-o" 'te-more-break-flush-pending-output) + ;;#### this isn't right + ;(define-key map "\^?" 'te-more-break-flush-pending-output) ;DEL + (define-key map "\r" 'te-more-break-advance-one-line) + + (setq terminal-more-break-map map))) + +(defvar te-width) +(defvar te-height) +(defvar te-process) +(defvar te-pending-output) +(defvar te-saved-point) +(defvar te-pending-output-info) +(defvar te-log-buffer) +(defvar te-more-count) +(defvar te-redisplay-count) +(defvar te-current-face) +(defvar te-current-attributes) + +(make-face 'terminal-default) + +(make-face 'terminal-standout) +(if (not (face-differs-from-default-p 'terminal-standout)) + (copy-face 'bold 'terminal-standout)) + +(make-face 'terminal-underline) +(cond ((face-differs-from-default-p 'terminal-underline)) + ((find-face 'underline) + (copy-face 'underline 'terminal-underline)) + (t + (set-face-underline-p 'terminal-underline t))) + +(make-face 'terminal-standout-underline) +(cond ((face-differs-from-default-p 'terminal-standout-underline)) + (t + (copy-face 'terminal-standout 'terminal-standout-underline) + (set-face-underline-p 'terminal-standout-underline t))) + +(defun te-insert-blank (count) + (let ((p (point))) + (insert-char ?\ count) + (put-text-property p (point) 'face 'terminal-default))) + + +;;;; escape map + +(defun te-escape-p (event) + (cond ((eventp terminal-escape-char) + (cond ((key-press-event-p event) + (and (key-press-event-p terminal-escape-char) + (= (event-modifier-bits event) + (event-modifier-bits terminal-escape-char)) + (eq (event-key event) + (event-key terminal-escape-char)))) + ((button-press-event-p event) + (and (button-press-event-p terminal-escape-char) + (= (event-modifier-bits event) + (event-modifier-bits terminal-escape-char)) + (eq (event-button event) + (event-button terminal-escape-char)))) + (t nil))) + ((numberp terminal-escape-char) + (let ((c (event-to-character event nil t nil))) + (and c (= c terminal-escape-char)))) + (t + nil))) + + +(defun te-escape () + (interactive) + (let ((c (let ((cursor-in-echo-area t) + (prompt (if prefix-arg + (format "Emacs Terminal escape> %d " + (prefix-numeric-value prefix-arg)) + "Emacs Terminal escape> "))) + (message "%s" prompt) + (let ((e (next-command-event))) + (while (button-release-event-p e) + (setq e (next-command-event e))) + (if (te-escape-p e) + e + (progn + (setq unread-command-event e) + (lookup-key terminal-escape-map + (read-key-sequence prompt)))))))) + (cond ((eventp c) + (message nil) + (copy-event c last-command-event) + (let ((terminal-escape-char -259)) + (te-pass-through))) + (c + (call-interactively c))))) + +(defun te-escape-help () + "Provide help on commands available after terminal-escape-char is typed." + (interactive) + (message "Terminal emulator escape help...") + (let ((char (single-key-description terminal-escape-char))) + (with-electric-help + (function (lambda () + (princ (format "Terminal-emulator escape, invoked by \"%s\" +Type \"%s\" twice to send a single \"%s\" through. + +Other chars following \"%s\" are interpreted as follows:\n" + char char char char)) + + (princ (substitute-command-keys "\\{terminal-escape-map}\n")) + (princ (format "\nSubcommands of \"%s\" (%s)\n" + (where-is-internal 'te-escape-extended-command + terminal-escape-map t) + 'te-escape-extended-command)) + (let ((l (if (fboundp 'sortcar) + (sortcar (copy-sequence te-escape-command-alist) + 'string<) + (sort (copy-sequence te-escape-command-alist) + (function (lambda (a b) + (string< (car a) (car b)))))))) + (while l + (let ((doc (or (documentation (cdr (car l))) + "Not documented"))) + (if (string-match "\n" doc) + ;; just use first line of documentation + (setq doc (substring doc 0 (match-beginning 0)))) + (princ " \"") + (princ (car (car l))) + (princ "\":\n ") + (princ doc) + (write-char ?\n)) + (setq l (cdr l)))) + nil))))) + + + +(defun te-escape-extended-command () + (interactive) + (let ((c (let ((completion-ignore-case t)) + (completing-read "terminal command: " + te-escape-command-alist + nil t)))) + (if c + (catch 'foo + (setq c (downcase c)) + (let ((l te-escape-command-alist)) + (while l + (if (string= c (downcase (car (car l)))) + (throw 'foo (call-interactively (cdr (car l)))) + (setq l (cdr l))))))))) + +;; not used. +(defun te-escape-extended-command-unread () + (interactive) + (setq unread-command-event last-command-event) + (te-escape-extended-command)) + +(defun te-set-escape-char (c) + "Change the terminal-emulator escape character." + (interactive (list (let ((cursor-in-echo-area t)) + (message "Set escape character to: ") + (let ((e (next-command-event))) + (while (button-release-event-p e) + (setq e (next-command-event e))) + e)))) + (cond ((te-escape-p c) + (message "\"%s\" is escape char")) + ((and (eventp terminal-escape-char) + (event-to-character terminal-escape-char nil t nil)) + (message "\"%s\" is now escape; \"%s\" passes though" + (single-key-description c) + (single-key-description terminal-escape-char))) + (t + (message "\"%s\" is now escape" + (single-key-description c)) + ;; Let mouse-events, for example, go back to looking at global map + (local-unset-key (vector terminal-escape-char)))) + (local-set-key (vector c) 'te-escape) ;ensure it's defined + (setq terminal-escape-char c)) + + +(defun te-stuff-string (string) + "Read a string to send to through the terminal emulator +as though that string had been typed on the keyboard. + +Very poor man's file transfer protocol." + (interactive "sStuff string: ") + (process-send-string te-process string)) + +(defun te-set-output-log (name) + "Record output from the terminal emulator in a buffer." + (interactive (list (if te-log-buffer + nil + (read-buffer "Record output in buffer: " + (format "%s output-log" + (buffer-name (current-buffer))) + nil)))) + (if (or (null name) (equal name "")) + (progn (setq te-log-buffer nil) + (message "Output logging off.")) + (if (get-buffer name) + nil + (save-excursion + (set-buffer (get-buffer-create name)) + (fundamental-mode) + (buffer-disable-undo (current-buffer)) + (erase-buffer))) + (setq te-log-buffer (get-buffer name)) + (message "Recording terminal emulator output into buffer \"%s\"" + (buffer-name te-log-buffer)))) + +(defun te-tofu () + "Discontinue output log." + (interactive) + (te-set-output-log nil)) + + +(defun te-toggle (sym arg) + (set sym (cond ((not (numberp arg)) arg) + ((= arg 1) (not (symbol-value sym))) + ((< arg 0) nil) + (t t)))) + +(defun te-toggle-more-processing (arg) + (interactive "p") + (message (if (te-toggle 'terminal-more-processing arg) + "More processing on" "More processing off")) + (if terminal-more-processing (setq te-more-count -1))) + +(defun te-toggle-scrolling (arg) + (interactive "p") + (message (if (te-toggle 'terminal-scrolling arg) + "Scroll at end of page" "Wrap at end of page"))) + +(defun te-enable-more-processing () + "Enable ** MORE ** processing" + (interactive) + (te-toggle-more-processing t)) + +(defun te-disable-more-processing () + "Disable ** MORE ** processing" + (interactive) + (te-toggle-more-processing nil)) + +(defun te-do-scrolling () + "Scroll at end of page (yuck)" + (interactive) + (te-toggle-scrolling t)) + +(defun te-do-wrapping () + "Wrap to top of window at end of page" + (interactive) + (te-toggle-scrolling nil)) + + +(defun te-set-redisplay-interval (arg) + "Set the maximum interval (in output characters) between screen updates. +Set this number to large value for greater throughput, +set it smaller for more frequent updates (but overall slower performance." + (interactive "NMax number of output chars between redisplay updates: ") + (setq arg (max arg 1)) + (setq terminal-redisplay-interval arg + te-redisplay-count 0)) + +;;;; more map + +;; every command -must- call te-more-break-unwind +;; or grave lossage will result + +(put 'te-more-break-unread 'suppress-keymap t) +(defun te-more-break-unread () + (interactive) + (if (te-escape-p last-command-event) + (call-interactively 'te-escape) + (message "Continuing from more break (\"%s\" typed, %d chars output pending...)" + (single-key-description last-command-event) + (te-pending-output-length)) + (setq te-more-count 259259) + (te-more-break-unwind) + (let ((terminal-more-processing nil)) + (te-pass-through)))) + +(defun te-more-break-resume () + "Proceed past the **MORE** break, +allowing the next page of output to appear" + (interactive) + (message "Continuing from more break") + (te-more-break-unwind)) + +(defun te-more-break-help () + "Provide help on commands available in a terminal-emulator **MORE** break" + (interactive) + (message "Terminal-emulator more break help...") + (sit-for 0) + (with-electric-help + (function (lambda () + (princ "Terminal-emulator more break.\n\n") + (princ (format "Type \"%s\" (te-more-break-resume)\n%s\n" + (where-is-internal 'te-more-break-resume + terminal-more-break-map t) + (documentation 'te-more-break-resume))) + (princ (substitute-command-keys "\\{terminal-more-break-map}\n")) + (princ "Any other key is passed through to the program +running under the terminal emulator and disables more processing until +all pending output has been dealt with.") + nil)))) + + +(defun te-more-break-advance-one-line () + "Allow one more line of text to be output before doing another more break." + (interactive) + (setq te-more-count 1) + (te-more-break-unwind)) + +(defun te-more-break-flush-pending-output () + "Discard any output which has been received by the terminal emulator but +not yet proceesed and then proceed from the more break." + (interactive) + (te-more-break-unwind) + (te-flush-pending-output)) + +(defun te-flush-pending-output () + "Discard any as-yet-unprocessed output which has been received by +the terminal emulator." + (interactive) + ;; this could conceivably be confusing in the presence of + ;; escape-sequences spanning process-output chunks + (if (null (cdr te-pending-output)) + (message "(There is no output pending)") + (let ((length (te-pending-output-length))) + (message "Flushing %d chars of pending output" length) + (setq te-pending-output + (list 0 (format "\n*** %d chars of pending output flushed ***\n" + length))) + (te-update-pending-output-display) + (te-process-output nil) + (sit-for 0)))) + + +(defun te-pass-through () + "Send the last character typed through the terminal-emulator +without any interpretation" + (interactive) + (if (te-escape-p last-command-event) + (call-interactively 'te-escape) + (and terminal-more-processing + (null (cdr te-pending-output)) + (te-set-more-count nil)) + (let ((c (event-to-character last-command-event nil t nil))) + (if c (process-send-string te-process (make-string 1 c)))) + (te-process-output t))) + +(defun te-set-window-start () + (let* ((w (get-buffer-window (current-buffer))) + (h (if w (window-height w)))) + (cond ((not w)) ; buffer not displayed + ((>= h (/ (- (point) (point-min)) (1+ te-width))) + ;; this is the normal case + (set-window-start w (point-min))) + ;; this happens if some vandal shrinks our window. + ((>= h (/ (- (point-max) (point)) (1+ te-width))) + (set-window-start w (- (point-max) (* h (1+ te-width)) -1))) + ;; I give up. + (t nil)))) + +(defun te-pending-output-length () + (let ((length (car te-pending-output)) + (tem (cdr te-pending-output))) + (while tem + (setq length (+ length (length (car tem))) tem (cdr tem))) + length)) + +;;;; more break hair + +(defun te-more-break () + (te-set-more-count t) + (make-local-variable 'te-more-old-point) + (setq te-more-old-point (point)) + (make-local-variable 'te-more-old-local-map) + (setq te-more-old-local-map (current-local-map)) + (use-local-map terminal-more-break-map) + (make-local-variable 'te-more-old-filter) + (setq te-more-old-filter (process-filter te-process)) + (make-local-variable 'te-more-old-mode-line-format) + (setq te-more-old-mode-line-format mode-line-format + mode-line-format (list "-- **MORE** " + mode-line-buffer-identification + "%-")) + (set-process-filter te-process + (function (lambda (process string) + (save-excursion + (set-buffer (process-buffer process)) + (setq te-pending-output (nconc te-pending-output + (list string)))) + (te-update-pending-output-display)))) + (te-update-pending-output-display) + (if (eq (window-buffer (selected-window)) (current-buffer)) + (message "More break ")) + (or (eobp) + (null terminal-more-break-insertion) + (save-excursion + (forward-char 1) + (delete-region (point) (+ (point) te-width)) + (insert terminal-more-break-insertion))) + (run-hooks 'terminal-more-break-hook) + (sit-for 0) ;get display to update + (throw 'te-process-output t)) + +(defun te-more-break-unwind () + (interactive) + (use-local-map te-more-old-local-map) + (set-process-filter te-process te-more-old-filter) + (goto-char te-more-old-point) + (setq mode-line-format te-more-old-mode-line-format) + (set-buffer-modified-p (buffer-modified-p)) + (let ((buffer-read-only nil)) + (cond ((eobp)) + (terminal-more-break-insertion + (forward-char 1) + (delete-region (point) + (+ (point) (length terminal-more-break-insertion))) + (te-insert-blank te-width) + (goto-char te-more-old-point))) + (setq te-more-old-point nil) + (let ((te-more-count 259259)) + (te-newline))) + ;(sit-for 0) + (te-process-output t)) + +(defun te-set-more-count (newline) + (let ((line (/ (- (point) (point-min)) (1+ te-width)))) + (if newline (setq line (1+ line))) + (cond ((= line te-height) + (setq te-more-count te-height)) + ;#### something is strange. Investigate this! + ((= line (1- te-height)) + (setq te-more-count te-height)) + ((or (< line (/ te-height 2)) + (> (- te-height line) 10)) + ;; break at end of this page + (setq te-more-count (- te-height line))) + (t + ;; migrate back towards top (ie bottom) of screen. + (setq te-more-count (- te-height + (if (> te-height 10) 2 1))))))) + + +;;;; More or less straight-forward terminal escapes + +;; ^j, meaning `newline' to non-display programs. +;; (Who would think of ever writing a system which doesn't understand +;; display terminals natively? Un*x: The Operating System of the Future.) +(defun te-newline () + "Move down a line, optionally do more processing, perhaps wrap/scroll, +move to start of new line, clear to end of line." + (end-of-line) + (cond ((not terminal-more-processing)) + ((< (setq te-more-count (1- te-more-count)) 0) + (te-set-more-count t)) + ((eq te-more-count 0) + ;; this doesn't return + (te-more-break))) + (if (eobp) + (progn + (delete-region (point-min) (+ (point-min) te-width)) + (goto-char (point-min)) + (if terminal-scrolling + (progn (delete-char 1) + (goto-char (point-max)) + (insert ?\n)))) + (forward-char 1) + (delete-region (point) (+ (point) te-width))) + (te-insert-blank te-width) + (beginning-of-line) + (te-set-window-start)) + +;; ^p ^j +;; Handle the `do' or `nl' termcap capability. +;;#### I am not sure why this broken, obsolete, capability is here. +;;#### Perhaps it is for VIle. No comment was made about why it +;;#### was added (in "Sun Dec 6 01:22:27 1987 Richard Stallman") +(defun te-down-vertically-or-scroll () + "Move down a line vertically, or scroll at bottom." + (let ((column (current-column))) + (end-of-line) + (if (eobp) + (progn + (delete-region (point-min) (+ (point-min) te-width)) + (goto-char (point-min)) + (delete-char 1) + (goto-char (point-max)) + (insert ?\n) + (te-insert-blank te-width) + (beginning-of-line)) + (forward-line 1)) + (move-to-column column)) + (te-set-window-start)) + +; ^p = x+32 y+32 +(defun te-move-to-position () + ;; must offset by #o40 since cretinous unix won't send a 004 char through + (let ((y (- (te-get-char) 32)) + (x (- (te-get-char) 32))) + (if (or (> x te-width) + (> y te-height)) + () ;(error "fucked %d %d" x y) + (goto-char (+ (point-min) x (* y (1+ te-width)))) + ;(te-set-window-start?) + )) + (setq te-more-count -1)) + + + +;; ^p c +(defun te-clear-rest-of-line () + (save-excursion + (let ((n (- (point) (progn (end-of-line) (point))))) + (delete-region (point) (+ (point) n)) + (te-insert-blank (- n))))) + + +;; ^p C +(defun te-clear-rest-of-screen () + (save-excursion + (te-clear-rest-of-line) + (while (progn (end-of-line) (not (eobp))) + (forward-char 1) (end-of-line) + (delete-region (- (point) te-width) (point)) + (te-insert-blank te-width)))) + + +;; ^p ^l +(defun te-clear-screen () + ;; regenerate buffer to compensate for (nonexistent!!) bugs. + (erase-buffer) + (let ((i 0)) + (while (< i te-height) + (setq i (1+ i)) + (te-insert-blank te-width) + (insert ?\n))) + (delete-region (1- (point-max)) (point-max)) + (goto-char (point-min)) + (setq te-more-count -1)) + + +;; ^p ^o count+32 +(defun te-insert-lines () + (if (not (bolp)) + ();(error "fooI") + (save-excursion + (let* ((line (- te-height (/ (- (point) (point-min)) (1+ te-width)) -1)) + (n (min (- (te-get-char) ?\ ) line)) + (i 0)) + (delete-region (- (point-max) (* n (1+ te-width))) (point-max)) + (if (eq (point) (point-max)) (insert ?\n)) + (while (< i n) + (setq i (1+ i)) + (te-insert-blank te-width) + (or (eq i line) (insert ?\n)))))) + (setq te-more-count -1)) + + +;; ^p ^k count+32 +(defun te-delete-lines () + (if (not (bolp)) + ();(error "fooD") + (let* ((line (- te-height (/ (- (point) (point-min)) (1+ te-width)) -1)) + (n (min (- (te-get-char) ?\ ) line)) + (i 0)) + (delete-region (point) + (min (+ (point) (* n (1+ te-width))) (point-max))) + (save-excursion + (goto-char (point-max)) + (while (< i n) + (setq i (1+ i)) + (te-insert-blank te-width) + (or (eq i line) (insert ?\n)))))) + (setq te-more-count -1)) + +;; ^p ^a +(defun te-beginning-of-line () + (beginning-of-line)) + +;; ^p ^b +(defun te-backward-char () + (if (not (bolp)) + (backward-char 1))) + +;; ^p ^f +(defun te-forward-char () + (if (not (eolp)) + (forward-char 1))) + + +;; ^p * +(defun te-change-attribute () + (let* ((attribute (te-get-char)) + (on (= (te-get-char) ?1)) + (standout (assq 'standout te-current-attributes)) + (underline (assq 'underline te-current-attributes)) + (frob (function (lambda () + ;; This would be even more of a combinatorial mess if I + ;; decided I wanted to support anything more than the two + ;; standout and underline attributes. + (setq te-current-face + (or (cdr (assoc te-current-attributes + '((((standout . t) (underline . nil)) + . terminal-standout) + (((standout . nil) (underline . t)) + . terminal-standout) + (((standout . t) (underline . nil)) + . terminal-standout-underline)))) + 'terminal-default)))))) + (cond ((= attribute ?+) ;standout on/off + (setcdr standout on) + (funcall frob)) + ((= attribute ?_) ;underline on/off + (setcdr underline on) + (funcall frob)) + ;; reverse, blink, half-bright, double-bright, blank, protect + ;; ??Colours?? + (t ;; #\space + (setcdr underline nil) + (setcdr standout nil) + (setq te-current-face 'terminal-default))))) + + +;; 0177 +(defun te-delete () + (if (bolp) + () + (delete-region (1- (point)) (point)) + (te-insert-blank 1) + (forward-char -1))) + +;; ^p ^g +(defun te-beep () + (beep)) + + +;; ^p _ count+32 +(defun te-insert-spaces () + (let* ((p (point)) + (n (min (- (te-get-char) 32) + (- (progn (end-of-line) (point)) p)))) + (if (<= n 0) + nil + (delete-char (- n)) + (goto-char p) + (insert-char ?\ n)) + (goto-char p))) + +;; ^p d count+32 (should be ^p ^d but cretinous un*x won't send ^d chars!!!) +(defun te-delete-char () + (let* ((p (point)) + (n (min (- (te-get-char) 32) + (- (progn (end-of-line) (point)) p)))) + (if (<= n 0) + nil + (te-insert-blank n) + (goto-char p) + (delete-char n)) + (goto-char p))) + + + +;; disgusting unix-required shit +;; Are we living twenty years in the past yet? + +(defun te-losing-unix () + ;(what lossage) + ;(message "fucking-unix: %d" char) + ) + +;; ^i +(defun te-output-tab () + (let* ((p (point)) + (x (- p (progn (beginning-of-line) (point)))) + (l (min (- 8 (logand x 7)) + (progn (end-of-line) (- (point) p))))) + (goto-char (+ p l)))) + +;; Also: +;; ^m => beginning-of-line (for which it -should- be using ^p ^a, right?!!) +;; ^g => te-beep (for which it should use ^p ^g) +;; ^h => te-backward-char (for which it should use ^p ^b) + + + +(defun te-filter (process string) + (let* ((obuf (current-buffer))) + ;; can't use save-excursion, as that preserves point, which we don't want + (unwind-protect + (progn + (set-buffer (process-buffer process)) + (goto-char te-saved-point) + (and (bufferp te-log-buffer) + (if (null (buffer-name te-log-buffer)) + ;; killed + (setq te-log-buffer nil) + (set-buffer te-log-buffer) + (goto-char (point-max)) + (insert-before-markers string) + (set-buffer (process-buffer process)))) + (setq te-pending-output (nconc te-pending-output (list string))) + (te-update-pending-output-display) + (te-process-output (eq (current-buffer) + (window-buffer (selected-window)))) + (set-buffer (process-buffer process)) + (setq te-saved-point (point))) + (set-buffer obuf)))) + +;; fucking unix has -such- braindamaged lack of tty control... +(defun te-process-output (preemptable) + ;;#### There seems no good reason to ever disallow preemption + (setq preemptable t) + (catch 'te-process-output + (let ((buffer-read-only nil) + (string nil) ostring start char (matchpos nil)) + (while (cdr te-pending-output) + (setq ostring string + start (car te-pending-output) + string (car (cdr te-pending-output)) + char (aref string start)) + (if (eq (setq start (1+ start)) (length string)) + (progn (setq te-pending-output + (cons 0 (cdr (cdr te-pending-output))) + start 0 + string (car (cdr te-pending-output))) + (te-update-pending-output-display)) + (setcar te-pending-output start)) + (if (and (> char ?\037) (< char ?\377)) + (cond ((eolp) + ;; unread char + (if (eq start 0) + (setq te-pending-output + (cons 0 (cons (make-string 1 char) + (cdr te-pending-output)))) + (setcar te-pending-output (1- start))) + (te-newline)) + ((null string) + (delete-char 1) (insert char) + (put-text-property (1- (point)) (point) + 'face te-current-face) + (te-redisplay-if-necessary 1)) + (t + (let ((end (or (and (eq ostring string) matchpos) + (setq matchpos (string-match + "[\000-\037\177-\377]" + string start)) + (length string)))) + (delete-char 1) (insert char) + (setq char (point)) + (put-text-property (1- char) char 'face te-current-face) + (end-of-line) + (setq end (min end (+ start (- (point) char)))) + (goto-char char) + (if (eq end matchpos) (setq matchpos nil)) + (delete-region (point) (+ (point) (- end start))) + (setq char (point)) + (insert (if (and (eq start 0) + (eq end (length string))) + string + (substring string start end))) + (put-text-property char (point) 'face te-current-face) + (if (eq end (length string)) + (setq te-pending-output + (cons 0 (cdr (cdr te-pending-output)))) + (setcar te-pending-output end)) + (te-redisplay-if-necessary (1+ (- end start)))))) + ;; I suppose if I split the guts of this out into a separate + ;; function we could trivially emulate different terminals + ;; Who cares in any case? (Apart from stupid losers using rlogin) + (funcall + (if (eq char ?\^p) + (or (cdr (assq (te-get-char) + '((?= . te-move-to-position) + (?c . te-clear-rest-of-line) + (?C . te-clear-rest-of-screen) + (?\C-o . te-insert-lines) + (?\C-k . te-delete-lines) + (?* . te-change-attribute) + ;; not necessary, but help sometimes. + (?\C-a . te-beginning-of-line) + (?\C-b . te-backward-char) + ;; should be C-d, but un*x + ;; pty's won't send \004 through! + ;; Can you believe this? + (?d . te-delete-char) + (?_ . te-insert-spaces) + ;; random + (?\C-f . te-forward-char) + (?\C-g . te-beep) + (?\C-j . te-down-vertically-or-scroll) + (?\C-l . te-clear-screen) + ))) + 'te-losing-unix) + (or (cdr (assq char + '((?\C-j . te-newline) + (?\177 . te-delete) + ;; Did I ask to be sent these characters? + ;; I don't remember doing so, either. + ;; (Perhaps some operating system or + ;; other is completely incompetent...) + (?\C-m . te-beginning-of-line) ;fuck me harder + (?\C-g . te-beep) ;again and again! + (?\C-h . te-backward-char) ;wa12id!! + (?\C-i . te-output-tab)))) ;(spiked) + 'te-losing-unix))) ;That feels better + (te-redisplay-if-necessary 1)) + (and preemptable + (input-pending-p) + ;; preemptable output! Oh my!! + (throw 'te-process-output t))))) + ;; We must update window-point in every window displaying our buffer + (let* ((s (selected-window)) + (w s)) + (while (not (eq s (setq w (next-window w)))) + (if (eq (window-buffer w) (current-buffer)) + (set-window-point w (point)))))) + +(defun te-get-char () + (if (cdr te-pending-output) + (let ((start (car te-pending-output)) + (string (car (cdr te-pending-output)))) + (prog1 (aref string start) + (if (eq (setq start (1+ start)) (length string)) + (setq te-pending-output (cons 0 (cdr (cdr te-pending-output)))) + (setcar te-pending-output start)))) + (catch 'char + (let ((filter (process-filter te-process))) + (unwind-protect + (progn + (set-process-filter te-process + (function (lambda (p s) + (or (eq (length s) 1) + (setq te-pending-output (list 1 s))) + (throw 'char (aref s 0))))) + (accept-process-output te-process)) + (set-process-filter te-process filter)))))) + + +(defun te-redisplay-if-necessary (length) + (and (<= (setq te-redisplay-count (- te-redisplay-count length)) 0) + (eq (current-buffer) (window-buffer (selected-window))) + (waiting-for-user-input-p) + (progn (te-update-pending-output-display) + (sit-for 0) + (setq te-redisplay-count terminal-redisplay-interval)))) + +(defun te-update-pending-output-display () + (if (null (cdr te-pending-output)) + (setq te-pending-output-info "") + (let ((length (te-pending-output-length))) + (if (< length 1500) + (setq te-pending-output-info "") + (setq te-pending-output-info (format "(%dK chars output pending) " + (/ (+ length 512) 1024)))))) + ;; update mode line + (set-buffer-modified-p (buffer-modified-p))) + + +(defun te-sentinel (process message) + (cond ((eq (process-status process) 'run)) + ((null (buffer-name (process-buffer process)))) ;deleted + (t (let ((b (current-buffer))) + (save-excursion + (set-buffer (process-buffer process)) + (setq buffer-read-only nil) + (fundamental-mode) + (goto-char (point-max)) + (delete-blank-lines) + (delete-horizontal-space) + (insert "\n*******\n" message "*******\n")) + (if (and (eq b (process-buffer process)) + (waiting-for-user-input-p)) + (progn (goto-char (point-max)) + (recenter -1))))))) + +(defvar te-stty-string "stty -nl erase '^?' kill '^u' intr '^c' echo pass8" + "Shell command to set terminal modes for terminal emulator.") +;; This used to have `new' in it, but that loses outside BSD +;; and it's apparently not needed in BSD. + +(defvar explicit-shell-file-name nil + "*If non-nil, is file name to use for explicitly requested inferior shell.") + +;;;###autoload +(defun terminal-emulator (buffer program args &optional width height) + "Under a display-terminal emulator in BUFFER, run PROGRAM on arguments ARGS. +ARGS is a list of argument-strings. Remaining arguments are WIDTH and HEIGHT. +BUFFER's contents are made an image of the display generated by that program, +and any input typed when BUFFER is the current Emacs buffer is sent to that +program an keyboard input. + +Interactively, BUFFER defaults to \"*terminal*\" and PROGRAM and ARGS +are parsed from an input-string using your usual shell. +WIDTH and HEIGHT are determined from the size of the current window +-- WIDTH will be one less than the window's width, HEIGHT will be its height. + +To switch buffers and leave the emulator, or to give commands +to the emulator itself (as opposed to the program running under it), +type Control-^. The following character is an emulator command. +Type Control-^ twice to send it to the subprogram. +This escape character may be changed using the variable `terminal-escape-char'. + +`Meta' characters may not currently be sent through the terminal emulator. + +Here is a list of some of the variables which control the behaviour +of the emulator -- see their documentation for more information: +terminal-escape-char, terminal-scrolling, terminal-more-processing, +terminal-redisplay-interval. + +This function calls the value of terminal-mode-hook if that exists +and is non-nil after the terminal buffer has been set up and the +subprocess started. + +Presently with `termcap' only; if somebody sends us code to make this +work with `terminfo' we will try to use it." + (interactive + (cons (save-excursion + (set-buffer (get-buffer-create "*terminal*")) + (buffer-name (if (or (not (boundp 'te-process)) + (null te-process) + (not (eq (process-status te-process) + 'run))) + (current-buffer) + (generate-new-buffer "*terminal*")))) + (append + (let* ((default-s + ;; Default shell is same thing M-x shell uses. + (or explicit-shell-file-name + (getenv "ESHELL") + (getenv "SHELL") + "/bin/sh")) + (s (read-shell-command + (format "Run program in emulator: (default %s) " + default-s)))) + (if (equal s "") + (list default-s '()) + (te-parse-program-and-args s)))))) + (switch-to-buffer buffer) + (if (null width) (setq width (- (window-width (selected-window)) 1))) + (if (null height) (setq height (- (window-height (selected-window)) 1))) + (terminal-mode) + (setq te-width width te-height height) + (setq mode-line-buffer-identification + (list (format "Emacs terminal %dx%d: %%b " te-width te-height) + 'te-pending-output-info)) + (let ((buffer-read-only nil)) + (te-clear-screen)) + (let (process) + (while (setq process (get-buffer-process (current-buffer))) + (if (y-or-n-p (format "Kill process %s? " (process-name process))) + (delete-process process) + (error "Process %s not killed" (process-name process))))) + (condition-case err + (let ((termcap + ;; Because of Unix Brain Death(tm), we can't change + ;; the terminal type of a running process, and so + ;; terminal size and scrollability are wired-down + ;; at this point. ("Detach? What's that?") + (concat (format "emacs-virtual:co#%d:li#%d:%s:km:" + ;; Sigh. These can't be dynamically changed. + te-width te-height (if terminal-scrolling + "" "ns:")) + ;;-- Basic things + ;; cursor-motion, bol, forward/backward char + "cm=^p=%+ %+ :cr=^p^a:le=^p^b:nd=^p^f:" + ;; newline, clear eof/eof, audible bell + "nw=^j:ce=^pc:cd=^pC:cl=^p^l:bl=^p^g:" + ;; insert/delete char/line + "IC=^p_%+ :DC=^pd%+ :AL=^p^o%+ :DL=^p^k%+ :" + ;;-- Not-widely-known (ie nonstandard) flags, which mean + ;; o writing in the last column of the last line + ;; doesn't cause idiotic scrolling, and + ;; o don't use idiotische c-s/c-q sogenannte + ;; ``flow control'' auf keinen Fall. + "LP:NF:" + ;;-- For stupid or obsolete programs + "ic=^p_!:dc=^pd!:al=^p^o!:dl=^p^k!:ho=^p= :" + ;;-- For disgusting programs. + ;; (VI? What losers need these, I wonder?) + "im=:ei=:dm=:ed=:mi:do=^p^j:nl=^p^j:bs:" + "ms:me=^p* :" + (if (face-equal 'terminal-default 'terminal-standout) + "" "so=^p*+1:se=^p*+0") + (if (face-equal 'terminal-default 'terminal-underline) + "" "us=^p*_1:ue=^p*_0") + ))) + (if (fboundp 'start-subprocess) + ;; this winning function would do everything, except that + ;; rms doesn't want it. + (setq te-process (start-subprocess "terminal-emulator" + program args + 'channel-type 'terminal + 'filter 'te-filter + 'buffer (current-buffer) + 'sentinel 'te-sentinel + 'modify-environment + (list (cons "TERM" "emacs-virtual") + (cons "TERMCAP" termcap)))) + ;; so instead we resort to this... + (setq te-process + (let ((process-environment + (cons "TERM=emacs-virtual" + (cons (concat "TERMCAP=" termcap) + process-environment)))) + (start-process "terminal-emulator" + (current-buffer) + "/bin/sh" "-c" + ;; Yuck!!! Start a shell to set some + ;; terminal control characteristics. + ;; Then exec the program we wanted. + (format "%s; exec %s" + te-stty-string + (mapconcat 'te-quote-arg-for-sh + (cons program args) + " "))))) + (set-process-filter te-process 'te-filter) + (set-process-sentinel te-process 'te-sentinel))) + (error (fundamental-mode) + (signal (car err) (cdr err)))) + ;; sigh + (setq inhibit-quit t) ;sport death + (use-local-map terminal-map) + (run-hooks 'terminal-mode-hook) + (message "Entering emacs terminal-emulator... Type %s %s for help" + (single-key-description terminal-escape-char) + (mapconcat 'single-key-description + (where-is-internal 'te-escape-help + terminal-escape-map + t) + " "))) + + +(defun te-parse-program-and-args (s) + (cond ((string-match "\\`\\([a-zA-Z0-9-+=_.@/:]+[ \t]*\\)+\\'" s) + (let ((l ()) (p 0)) + (while p + (setq l (cons (if (string-match + "\\([a-zA-Z0-9-+=_.@/:]+\\)\\([ \t]+\\)*" + s p) + (prog1 (substring s p (match-end 1)) + (setq p (match-end 0)) + (if (eq p (length s)) (setq p nil))) + (prog1 (substring s p) + (setq p nil))) + l))) + (setq l (nreverse l)) + (list (car l) (cdr l)))) + ((and (string-match "[ \t]" s) (not (file-exists-p s))) + (list shell-file-name (list "-c" (concat "exec " s)))) + (t (list s ())))) + +(put 'terminal-mode 'mode-class 'special) +;; This is only separated out from function terminal-emulator +;; to keep the latter a little more managable. +(defun terminal-mode () + "Set up variables for use f the terminal-emualtor. +One should not call this -- it is an internal function +of the terminal-emulator" + (kill-all-local-variables) + (buffer-disable-undo (current-buffer)) + (setq major-mode 'terminal-mode) + (setq mode-name "terminal") +; (make-local-variable 'Helper-return-blurb) +; (setq Helper-return-blurb "return to terminal simulator") + (setq mode-line-process '(": %s")) + (setq buffer-read-only t) + (setq truncate-lines t) + (make-local-variable 'terminal-escape-char) + (setq terminal-escape-char (default-value 'terminal-escape-char)) + (make-local-variable 'terminal-scrolling) + (setq terminal-scrolling (default-value 'terminal-scrolling)) + (make-local-variable 'terminal-more-processing) + (setq terminal-more-processing (default-value 'terminal-more-processing)) + (make-local-variable 'terminal-redisplay-interval) + (setq terminal-redisplay-interval (default-value 'terminal-redisplay-interval)) + (make-local-variable 'te-width) + (make-local-variable 'te-height) + (make-local-variable 'te-process) + (make-local-variable 'te-pending-output) + (setq te-pending-output (list 0)) + (make-local-variable 'te-saved-point) + (setq te-saved-point (point-min)) + (make-local-variable 'te-pending-output-info) ;for the mode line + (setq te-pending-output-info "") + (make-local-variable 'inhibit-quit) + ;(setq inhibit-quit t) + (make-local-variable 'te-log-buffer) + (setq te-log-buffer nil) + (make-local-variable 'te-more-count) + (setq te-more-count -1) + (make-local-variable 'te-redisplay-count) + (setq te-redisplay-count terminal-redisplay-interval) + (make-local-variable 'te-current-face) + (setq te-current-face 'terminal-default) + (make-local-variable 'te-current-attributes) + (setq te-current-attributes (list (cons 'standout nil) + (cons 'underline nil))) + ;(use-local-map terminal-mode-map) + ;; terminal-mode-hook is called above in function terminal-emulator + (make-local-variable 'meta-prefix-char) + (setq meta-prefix-char -1) ;death to ASCII lossage + ) + +;;;; what a complete loss + +(defun te-quote-arg-for-sh (fuckme) + (cond ((string-match "\\`[a-zA-Z0-9-+=_.@/:]+\\'" + fuckme) + fuckme) + ((not (string-match "[$]" fuckme)) + ;; "[\"\\]" are special to sh and the lisp reader in the same way + (prin1-to-string fuckme)) + (t + (let ((harder "") + (cretin 0) + (stupid 0)) + (while (cond ((>= cretin (length fuckme)) + nil) + ;; this is the set of chars magic with "..." in `sh' + ((setq stupid (string-match "[\"\\$]" + fuckme cretin)) + t) + (t (setq harder (concat harder + (substring fuckme cretin))) + nil)) + (setq harder (concat harder (substring fuckme cretin stupid) + ;; Can't use ?\\ since `concat' + ;; unfortunately does prin1-to-string + ;; on fixna. Amazing. + "\\" + (substring fuckme + stupid + (1+ stupid))) + cretin (1+ stupid))) + (concat "\"" harder "\""))))) diff --git a/uncompress.el b/uncompress.el new file mode 100644 --- /dev/null +++ b/uncompress.el @@ -0,0 +1,100 @@ +;;; uncompress.el --- auto-decompression hook for visiting .Z files + +;; Copyright (C) 1992, 1994 Free Software Foundation, Inc. + +;; Maintainer: FSF +;; Keywords: unix extensions + +;; This file is part of XEmacs. + +;; XEmacs 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 2, or (at your option) +;; any later version. + +;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the Free +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. + +;;; Synched up with: 19.34. + +;;; Commentary: + +;; This package can be used to arrange for automatic uncompress of +;; files packed with the UNIX compress(1) utility when they are visited. +;; All that's necessary is to load it. This can conveniently be done from +;; your .emacs file. + +;;; Code: + +;; When we are about to make a backup file, +;; uncompress the file we visited +;; so that making the backup can work properly. +;; This is used as a write-file-hook. + +(defvar uncompress-program "gunzip" + "Program to use for uncompression.") + +(defun uncompress-backup-file () + (and buffer-file-name make-backup-files (not buffer-backed-up) + (not (file-exists-p buffer-file-name)) + (call-process uncompress-program nil nil nil buffer-file-name)) + nil) + +(or (assoc "\\.Z$" auto-mode-alist) + (setq auto-mode-alist + (cons '("\\.Z$" . uncompress-while-visiting) auto-mode-alist))) +(or (assoc "\\.gz$" auto-mode-alist) + (setq auto-mode-alist + (cons '("\\.gz$" . uncompress-while-visiting) auto-mode-alist))) + +(defun uncompress-while-visiting () + "Temporary \"major mode\" used for .Z and .gz files, to uncompress them. +It then selects a major mode from the uncompressed file name and contents." + (if (and (not (null buffer-file-name)) + (string-match "\\.Z$" buffer-file-name)) + (set-visited-file-name + (substring buffer-file-name 0 (match-beginning 0))) + (if (and (not (null buffer-file-name)) + (string-match "\\.gz$" buffer-file-name)) + (set-visited-file-name + (substring buffer-file-name 0 (match-beginning 0))))) + (message "Uncompressing...") + (let ((buffer-read-only nil)) + (shell-command-on-region (point-min) (point-max) uncompress-program t)) + (message "Uncompressing...done") + (set-buffer-modified-p nil) + (make-local-variable 'write-file-hooks) + (or (memq 'uncompress-backup-file write-file-hooks) + (setq write-file-hooks (cons 'uncompress-backup-file write-file-hooks))) + (normal-mode)) + +(or (memq 'find-compressed-version find-file-not-found-hooks) + (setq find-file-not-found-hooks + (cons 'find-compressed-version find-file-not-found-hooks))) + +(defun find-compressed-version () + "Hook to read and uncompress the compressed version of a file." + ;; Just pretend we had visited the compressed file, + ;; and uncompress-while-visiting will do the rest. + (let (name) + (if (file-exists-p (setq name (concat buffer-file-name ".Z"))) + (setq buffer-file-name name) + (if (file-exists-p (setq name (concat buffer-file-name ".gz"))) + (setq buffer-file-name name))) + (if (eq name buffer-file-name) + (progn + (insert-file-contents buffer-file-name t) + (goto-char (point-min)) + (setq error nil) + t)))) + +(provide 'uncompress) + +;;; uncompress.el ends here