lisp/eshell/esh-io.el

   1 ;;; esh-io.el --- I/O management
   2
   3 ;; Copyright (C) 1999-2011  Free Software Foundation, Inc.
   4
   5 ;; Author: John Wiegley <johnw@gnu.org>
   6
   7 ;; This file is part of GNU Emacs.
   8
   9 ;; GNU Emacs is free software: you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation, either version 3 of the License, or
  12 ;; (at your option) any later version.
  13
  14 ;; GNU Emacs is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  21
  22 ;;; Commentary:
  23
  24 ;; At the moment, only output redirection is supported in Eshell.  To
  25 ;; use input redirection, the following syntax will work, assuming
  26 ;; that the command after the pipe is always an external command:
  27 ;;
  28 ;;   cat <file> | <command>
  29 ;;
  30 ;; Otherwise, output redirection and piping are provided in a manner
  31 ;; consistent with most shells.  Therefore, only unique features are
  32 ;; mentioned here.
  33 ;;
  34 ;;;_* Insertion
  35 ;;
  36 ;; To insert at the location of point in a buffer, use '>>>':
  37 ;;
  38 ;;   echo alpha >>> #<buffer *scratch*>;
  39 ;;
  40 ;;;_* Pseudo-devices
  41 ;;
  42 ;; A few pseudo-devices are provided, since Emacs cannot write
  43 ;; directly to a UNIX device file:
  44 ;;
  45 ;;   echo alpha > /dev/null   ; the bit bucket
  46 ;;   echo alpha > /dev/kill   ; set the kill ring
  47 ;;   echo alpha >> /dev/clip  ; append to the clipboard
  48 ;;
  49 ;;;_* Multiple output targets
  50 ;;
  51 ;; Eshell can write to multiple output targets, including pipes.
  52 ;; Example:
  53 ;;
  54 ;;   (+ 1 2) > a > b > c   ; prints number to all three files
  55 ;;   (+ 1 2) > a | wc      ; prints to 'a', and pipes to 'wc'
  56
  57 ;;; Code:
  58
  59 (provide 'esh-io)
  60
  61 (eval-when-compile
  62   (require 'cl)
  63   (require 'eshell))
  64
  65 (defgroup eshell-io nil
  66   "Eshell's I/O management code provides a scheme for treating many
  67 different kinds of objects -- symbols, files, buffers, etc. -- as
  68 though they were files."
  69   :tag "I/O management"
  70   :group 'eshell)
  71
  72 ;;; User Variables:
  73
  74 (defcustom eshell-io-load-hook '(eshell-io-initialize)
  75   "A hook that gets run when `eshell-io' is loaded."
  76   :type 'hook
  77   :group 'eshell-io)
  78
  79 (defcustom eshell-number-of-handles 3
  80   "The number of file handles that eshell supports.
  81 Currently this is standard input, output and error.  But even all of
  82 these Emacs does not currently support with asynchronous processes
  83 \(which is what eshell uses so that you can continue doing work in
  84 other buffers) ."
  85   :type 'integer
  86   :group 'eshell-io)
  87
  88 (defcustom eshell-output-handle 1
  89   "The index of the standard output handle."
  90   :type 'integer
  91   :group 'eshell-io)
  92
  93 (defcustom eshell-error-handle 2
  94   "The index of the standard error handle."
  95   :type 'integer
  96   :group 'eshell-io)
  97
  98 (defcustom eshell-buffer-shorthand nil
  99   "If non-nil, a symbol name can be used for a buffer in redirection.
 100 If nil, redirecting to a buffer requires buffer name syntax.  If this
 101 variable is set, redirection directly to Lisp symbols will be
 102 impossible.
 103
 104 Example:
 105
 106   echo hello > '*scratch*  ; works if `eshell-buffer-shorthand' is t
 107   echo hello > #<buffer *scratch*>  ; always works"
 108   :type 'boolean
 109   :group 'eshell-io)
 110
 111 (defcustom eshell-print-queue-size 5
 112   "The size of the print queue, for doing buffered printing.
 113 This is basically a speed enhancement, to avoid blocking the Lisp code
 114 from executing while Emacs is redisplaying."
 115   :type 'integer
 116   :group 'eshell-io)
 117
 118 (defcustom eshell-virtual-targets
 119   '(("/dev/eshell" eshell-interactive-print nil)
 120     ("/dev/kill" (lambda (mode)
 121                    (if (eq mode 'overwrite)
 122                        (kill-new ""))
 123                    'eshell-kill-append) t)
 124     ("/dev/clip" (lambda (mode)
 125                    (if (eq mode 'overwrite)
 126                        (let ((x-select-enable-clipboard t))
 127                          (kill-new "")))
 128                    'eshell-clipboard-append) t))
 129   "Map virtual devices name to Emacs Lisp functions.
 130 If the user specifies any of the filenames above as a redirection
 131 target, the function in the second element will be called.
 132
 133 If the third element is non-nil, the redirection mode is passed as an
 134 argument (which is the symbol `overwrite', `append' or `insert'), and
 135 the function is expected to return another function -- which is the
 136 output function.  Otherwise, the second element itself is the output
 137 function.
 138
 139 The output function is then called repeatedly with single strings,
 140 which represents successive pieces of the output of the command, until nil
 141 is passed, meaning EOF.
 142
 143 NOTE: /dev/null is handled specially as a virtual target, and should
 144 not be added to this variable."
 145   :type '(repeat
 146           (list (string :tag "Target")
 147                 function
 148                 (choice (const :tag "Func returns output-func" t)
 149                         (const :tag "Func is output-func" nil))))
 150   :group 'eshell-io)
 151
 152 (put 'eshell-virtual-targets 'risky-local-variable t)
 153
 154 ;;; Internal Variables:
 155
 156 (defvar eshell-current-handles nil)
 157
 158 (defvar eshell-last-command-status 0
 159   "The exit code from the last command.  0 if successful.")
 160
 161 (defvar eshell-last-command-result nil
 162   "The result of the last command.  Not related to success.")
 163
 164 (defvar eshell-output-file-buffer nil
 165   "If non-nil, the current buffer is a file output buffer.")
 166
 167 (defvar eshell-print-count)
 168 (defvar eshell-current-redirections)
 169
 170 ;;; Functions:
 171
 172 (defun eshell-io-initialize ()
 173   "Initialize the I/O subsystem code."
 174   (add-hook 'eshell-parse-argument-hook
 175             'eshell-parse-redirection nil t)
 176   (make-local-variable 'eshell-current-redirections)
 177   (add-hook 'eshell-pre-rewrite-command-hook
 178             'eshell-strip-redirections nil t)
 179   (add-hook 'eshell-post-rewrite-command-hook
 180             'eshell-apply-redirections nil t))
 181
 182 (defun eshell-parse-redirection ()
 183   "Parse an output redirection, such as '2>'."
 184   (if (and (not eshell-current-quoted)
 185            (looking-at "\\([0-9]\\)?\\(<\\|>+\\)&?\\([0-9]\\)?\\s-*"))
 186       (if eshell-current-argument
 187           (eshell-finish-arg)
 188         (let ((sh (match-string 1))
 189               (oper (match-string 2))
 190 ;             (th (match-string 3))
 191               )
 192           (if (string= oper "<")
 193               (error "Eshell does not support input redirection"))
 194           (eshell-finish-arg
 195            (prog1
 196                (list 'eshell-set-output-handle
 197                      (or (and sh (string-to-number sh)) 1)
 198                      (list 'quote
 199                            (aref [overwrite append insert]
 200                                  (1- (length oper)))))
 201              (goto-char (match-end 0))))))))
 202
 203 (defun eshell-strip-redirections (terms)
 204   "Rewrite any output redirections in TERMS."
 205   (setq eshell-current-redirections (list t))
 206   (let ((tl terms)
 207         (tt (cdr terms)))
 208     (while tt
 209       (if (not (and (consp (car tt))
 210                     (eq (caar tt) 'eshell-set-output-handle)))
 211           (setq tt (cdr tt)
 212                 tl (cdr tl))
 213         (unless (cdr tt)
 214           (error "Missing redirection target"))
 215         (nconc eshell-current-redirections
 216                (list (list 'ignore
 217                            (append (car tt) (list (cadr tt))))))
 218         (setcdr tl (cddr tt))
 219         (setq tt (cddr tt))))
 220     (setq eshell-current-redirections
 221           (cdr eshell-current-redirections))))
 222
 223 (defun eshell-apply-redirections (cmdsym)
 224   "Apply any redirection which were specified for COMMAND."
 225   (if eshell-current-redirections
 226       (set cmdsym
 227            (append (list 'progn)
 228                    eshell-current-redirections
 229                    (list (symbol-value cmdsym))))))
 230
 231 (defun eshell-create-handles
 232   (standard-output output-mode &optional standard-error error-mode)
 233   "Create a new set of file handles for a command.
 234 The default location for standard output and standard error will go to
 235 STANDARD-OUTPUT and STANDARD-ERROR, respectively.
 236 OUTPUT-MODE and ERROR-MODE are either `overwrite', `append' or `insert';
 237 a nil value of mode defaults to `insert'."
 238   (let ((handles (make-vector eshell-number-of-handles nil))
 239         (output-target (eshell-get-target standard-output output-mode))
 240         (error-target (eshell-get-target standard-error error-mode)))
 241     (aset handles eshell-output-handle (cons output-target 1))
 242     (if standard-error
 243         (aset handles eshell-error-handle (cons error-target 1))
 244       (aset handles eshell-error-handle (cons output-target 1)))
 245     handles))
 246
 247 (defun eshell-protect-handles (handles)
 248   "Protect the handles in HANDLES from a being closed."
 249   (let ((idx 0))
 250     (while (< idx eshell-number-of-handles)
 251       (if (aref handles idx)
 252           (setcdr (aref handles idx)
 253                   (1+ (cdr (aref handles idx)))))
 254       (setq idx (1+ idx))))
 255   handles)
 256
 257 (defun eshell-close-target (target status)
 258   "Close an output TARGET, passing STATUS as the result.
 259 STATUS should be non-nil on successful termination of the output."
 260   (cond
 261    ((symbolp target) nil)
 262
 263    ;; If we were redirecting to a file, save the file and close the
 264    ;; buffer.
 265    ((markerp target)
 266     (let ((buf (marker-buffer target)))
 267       (when buf                         ; somebody's already killed it!
 268         (save-current-buffer
 269           (set-buffer buf)
 270           (when eshell-output-file-buffer
 271             (save-buffer)
 272             (when (eq eshell-output-file-buffer t)
 273               (or status (set-buffer-modified-p nil))
 274               (kill-buffer buf)))))))
 275
 276    ;; If we're redirecting to a process (via a pipe, or process
 277    ;; redirection), send it EOF so that it knows we're finished.
 278    ((eshell-processp target)
 279     (if (eq (process-status target) 'run)
 280         (process-send-eof target)))
 281
 282    ;; A plain function redirection needs no additional arguments
 283    ;; passed.
 284    ((functionp target)
 285     (funcall target status))
 286
 287    ;; But a more complicated function redirection (which can only
 288    ;; happen with aliases at the moment) has arguments that need to be
 289    ;; passed along with it.
 290    ((consp target)
 291     (apply (car target) status (cdr target)))))
 292
 293 (defun eshell-close-handles (exit-code &optional result handles)
 294   "Close all of the current handles, taking refcounts into account.
 295 EXIT-CODE is the process exit code; mainly, it is zero, if the command
 296 completed successfully.  RESULT is the quoted value of the last
 297 command.  If nil, then the meta variables for keeping track of the
 298 last execution result should not be changed."
 299   (let ((idx 0))
 300     (assert (or (not result) (eq (car result) 'quote)))
 301     (setq eshell-last-command-status exit-code
 302           eshell-last-command-result (cadr result))
 303     (while (< idx eshell-number-of-handles)
 304       (let ((handles (or handles eshell-current-handles)))
 305         (when (aref handles idx)
 306           (setcdr (aref handles idx)
 307                   (1- (cdr (aref handles idx))))
 308           (when (= (cdr (aref handles idx)) 0)
 309             (let ((target (car (aref handles idx))))
 310               (if (not (listp target))
 311                   (eshell-close-target target (= exit-code 0))
 312                 (while target
 313                   (eshell-close-target (car target) (= exit-code 0))
 314                   (setq target (cdr target)))))
 315             (setcar (aref handles idx) nil))))
 316       (setq idx (1+ idx)))
 317     nil))
 318
 319 (defun eshell-kill-append (string)
 320   "Call `kill-append' with STRING, if it is indeed a string."
 321   (if (stringp string)
 322       (kill-append string nil)))
 323
 324 (defun eshell-clipboard-append (string)
 325   "Call `kill-append' with STRING, if it is indeed a string."
 326   (if (stringp string)
 327       (let ((x-select-enable-clipboard t))
 328         (kill-append string nil))))
 329
 330 (defun eshell-get-target (target &optional mode)
 331   "Convert TARGET, which is a raw argument, into a valid output target.
 332 MODE is either `overwrite', `append' or `insert'; if it is omitted or nil,
 333 it defaults to `insert'."
 334   (setq mode (or mode 'insert))
 335   (cond
 336    ((stringp target)
 337     (let ((redir (assoc target eshell-virtual-targets)))
 338       (if redir
 339           (if (nth 2 redir)
 340               (funcall (nth 1 redir) mode)
 341             (nth 1 redir))
 342         (let* ((exists (get-file-buffer target))
 343                (buf (find-file-noselect target t)))
 344           (with-current-buffer buf
 345             (if buffer-file-read-only
 346                 (error "Cannot write to read-only file `%s'" target))
 347             (setq buffer-read-only nil)
 348             (set (make-local-variable 'eshell-output-file-buffer)
 349                  (if (eq exists buf) 0 t))
 350             (cond ((eq mode 'overwrite)
 351                    (erase-buffer))
 352                   ((eq mode 'append)
 353                    (goto-char (point-max))))
 354             (point-marker))))))
 355
 356    ((or (bufferp target)
 357         (and (boundp 'eshell-buffer-shorthand)
 358              (symbol-value 'eshell-buffer-shorthand)
 359              (symbolp target)
 360              (not (memq target '(t nil)))))
 361     (let ((buf (if (bufferp target)
 362                    target
 363                  (get-buffer-create
 364                   (symbol-name target)))))
 365       (with-current-buffer buf
 366         (cond ((eq mode 'overwrite)
 367                (erase-buffer))
 368               ((eq mode 'append)
 369                (goto-char (point-max))))
 370         (point-marker))))
 371
 372    ((functionp target) nil)
 373
 374    ((symbolp target)
 375     (if (eq mode 'overwrite)
 376         (set target nil))
 377     target)
 378
 379    ((or (eshell-processp target)
 380         (markerp target))
 381     target)
 382
 383    (t
 384     (error "Invalid redirection target: %s"
 385            (eshell-stringify target)))))
 386
 387 (defvar grep-null-device)
 388
 389 (defun eshell-set-output-handle (index mode &optional target)
 390   "Set handle INDEX, using MODE, to point to TARGET."
 391   (when target
 392     (if (and (stringp target)
 393              (or (cond
 394                   ((boundp 'null-device)
 395                    (string= target null-device))
 396                   ((boundp 'grep-null-device)
 397                    (string= target grep-null-device))
 398                   (t nil))
 399                  (string= target "/dev/null")))
 400         (aset eshell-current-handles index nil)
 401       (let ((where (eshell-get-target target mode))
 402             (current (car (aref eshell-current-handles index))))
 403         (if (and (listp current)
 404                  (not (member where current)))
 405             (setq current (append current (list where)))
 406           (setq current (list where)))
 407         (if (not (aref eshell-current-handles index))
 408             (aset eshell-current-handles index (cons nil 1)))
 409         (setcar (aref eshell-current-handles index) current)))))
 410
 411 (defun eshell-interactive-output-p ()
 412   "Return non-nil if current handles are bound for interactive display."
 413   (and (eq (car (aref eshell-current-handles
 414                       eshell-output-handle)) t)
 415        (eq (car (aref eshell-current-handles
 416                       eshell-error-handle)) t)))
 417
 418 (defvar eshell-print-queue nil)
 419 (defvar eshell-print-queue-count -1)
 420
 421 (defsubst eshell-print (object)
 422   "Output OBJECT to the standard output handle."
 423   (eshell-output-object object eshell-output-handle))
 424
 425 (defun eshell-flush (&optional reset-p)
 426   "Flush out any lines that have been queued for printing.
 427 Must be called before printing begins with -1 as its argument, and
 428 after all printing is over with no argument."
 429   (ignore
 430    (if reset-p
 431        (setq eshell-print-queue nil
 432              eshell-print-queue-count reset-p)
 433      (if eshell-print-queue
 434          (eshell-print eshell-print-queue))
 435      (eshell-flush 0))))
 436
 437 (defun eshell-init-print-buffer ()
 438   "Initialize the buffered printing queue."
 439   (eshell-flush -1))
 440
 441 (defun eshell-buffered-print (&rest strings)
 442   "A buffered print -- *for strings only*."
 443   (if (< eshell-print-queue-count 0)
 444       (progn
 445         (eshell-print (apply 'concat strings))
 446         (setq eshell-print-queue-count 0))
 447     (if (= eshell-print-queue-count eshell-print-queue-size)
 448         (eshell-flush))
 449     (setq eshell-print-queue
 450           (concat eshell-print-queue (apply 'concat strings))
 451           eshell-print-queue-count (1+ eshell-print-queue-count))))
 452
 453 (defsubst eshell-error (object)
 454   "Output OBJECT to the standard error handle."
 455   (eshell-output-object object eshell-error-handle))
 456
 457 (defsubst eshell-errorn (object)
 458   "Output OBJECT followed by a newline to the standard error handle."
 459   (eshell-error object)
 460   (eshell-error "\n"))
 461
 462 (defsubst eshell-printn (object)
 463   "Output OBJECT followed by a newline to the standard output handle."
 464   (eshell-print object)
 465   (eshell-print "\n"))
 466
 467 (defun eshell-output-object-to-target (object target)
 468   "Insert OBJECT into TARGET.
 469 Returns what was actually sent, or nil if nothing was sent."
 470   (cond
 471    ((functionp target)
 472     (funcall target object))
 473
 474    ((symbolp target)
 475     (if (eq target t)                   ; means "print to display"
 476         (eshell-output-filter nil (eshell-stringify object))
 477       (if (not (symbol-value target))
 478           (set target object)
 479         (setq object (eshell-stringify object))
 480         (if (not (stringp (symbol-value target)))
 481             (set target (eshell-stringify
 482                          (symbol-value target))))
 483         (set target (concat (symbol-value target) object)))))
 484
 485    ((markerp target)
 486     (if (buffer-live-p (marker-buffer target))
 487         (with-current-buffer (marker-buffer target)
 488           (let ((moving (= (point) target)))
 489             (save-excursion
 490               (goto-char target)
 491               (unless (stringp object)
 492                 (setq object (eshell-stringify object)))
 493               (insert-and-inherit object)
 494               (set-marker target (point-marker)))
 495             (if moving
 496                 (goto-char target))))))
 497
 498    ((eshell-processp target)
 499     (when (eq (process-status target) 'run)
 500       (unless (stringp object)
 501         (setq object (eshell-stringify object)))
 502       (process-send-string target object)))
 503
 504    ((consp target)
 505     (apply (car target) object (cdr target))))
 506   object)
 507
 508 (defun eshell-output-object (object &optional handle-index handles)
 509   "Insert OBJECT, using HANDLE-INDEX specifically)."
 510   (let ((target (car (aref (or handles eshell-current-handles)
 511                            (or handle-index eshell-output-handle)))))
 512     (if (and target (not (listp target)))
 513         (eshell-output-object-to-target object target)
 514       (while target
 515         (eshell-output-object-to-target object (car target))
 516         (setq target (cdr target))))))
 517
 518 ;;; esh-io.el ends here