dsill@RELAY.NSWC.NAVY.MIL (04/15/89)
;;;;;;;;;;;;;;;;;;;;;;;;;;; -*- Mode: Emacs-Lisp -*- ;;;;;;;;;;;;;;;;;;;;;;;;;;
;; unshar.el --- unpack shar archives in the comfort of your own Emacs
;; Author : dsill@relay.nswc.navy.mil
;; Created On : Fri Apr 14 10:41:57 1989
;; Last Modified By: dsill
;; Last Modified On: Fri Apr 14 14:51:32 1989
;; Update Count : 3
;; Status : Alpha release, use with caution.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; This is a little quickie that unpacks "shar" files. My reasons for wanting
; to do this within Emacs are convenience and safety. Rather than having to
; edit off the headers, save the archives in a file, and run /bin/sh on them,
; one can simply type `M-x unshar' and watch it run. Secondly, I've always
; felt a bit queasy running /bin/sh on an unknown script. Call me paranoid.
;
; As always, please feel free to send me your comments.
;
; Dave Sill (dsill@relay.nswc.navy.mil)
;
; Note: This version doesn't check to see that the extracted files are the
; correct size, and relies on Emacs to create a backup file when extracting
; a file that already exists.
(defun unshar (to-dir)
"Safely unpack the 'shar' archive in current buffer, putting files under
the directory TO-DIR."
(interactive "DExtract files to: ")
(save-excursion
(goto-char (point-min))
(let ((last-shell-command ""))
(while (search-forward "<< \\" nil t)
(let* ((beg (point))
(end (progn (search-forward " ") (backward-char) (point)))
(key-string (buffer-substring beg end))
(beg (progn (search-forward "'") (point)))
(end (progn (search-forward "'") (backward-char) (point)))
(file-name (buffer-substring beg end))
(beg (progn (beginning-of-line) (point)))
(end (progn (search-forward "<") (backward-char 2) (point)))
(shell-command (buffer-substring beg end)))
(setq beg (progn (forward-line) (point)))
(re-search-forward (concat "^" key-string))
(beginning-of-line)
(save-excursion
(copy-region-as-kill beg (point))
(message "Extracting %s" file-name)
(set-buffer (get-buffer-create file-name))
(erase-buffer)
(insert (car kill-ring-yank-pointer))
(if (not (equal shell-command last-shell-command))
(if (y-or-n-p (concat "Okay to execute \"" shell-command "\" "))
()
(setq shell-command (read-string "Shell command to use: "))))
(setq last-shell-command shell-command)
(shell-command-on-region (point-min) (point-max) shell-command t)
(write-file (concat to-dir file-name)))))
(message "Extraction complete."))))