1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
|
#!@GUILE@ \
--debug -e main
!#
;;; uptop.scm -- Uppercase top.
;; Copyright (C) 2016 Artyom V. Poptsov <poptsov.artyom@gmail.com>
;;
;; This program is free software: you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation, either version 3 of the
;; License, or (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; Connect to a remote host, execute 'top' command on it and print the output
;; in uppercase letters.
;;; Code:
(use-modules (srfi srfi-41) ; streams
(ssh session)
(ssh auth)
(ssh popen) ; remote pipes
(ssh channel)) ; channel-set-pty-size!
(define (pipe->stream p)
"Convert a pipe P to a SRFI-41 stream."
(stream-let loop ((c (read-char p)))
(if (eof-object? c)
(begin
(close-input-port p)
stream-null)
(stream-cons c (loop (read-char p))))))
(define (open-remote-input-pipe/pty* session command . args)
"Open remote input pipe with PTY, run a COMMAND with ARGS."
(define OPEN_PTY_READ (string-append OPEN_PTY OPEN_READ))
(let ((p (apply open-remote-pipe* session OPEN_PTY_READ command args)))
(channel-set-pty-size! p 80 40)
p))
(define char-upcase/skip-esc
(let ((state 'regular-char))
(lambda (chr)
"Return the uppercase character version of a CHR, skip therminal escape
sequences."
(cond
((char=? chr (integer->char 27))
(set! state 'escape-sequence)
chr)
((char=? chr #\m)
(if (equal? state 'escape-sequence)
(begin
(set! state 'regular-char)
chr)
(char-upcase chr)))
(else
(char-upcase chr))))))
;;;
(define (main args)
"Entry point."
(let ((s (make-session #:host (cadr args))))
(connect! s)
(userauth-agent! s)
(let ((rs (pipe->stream (open-remote-input-pipe/pty* s "top" "-u $USER"))))
(stream-for-each display (stream-map char-upcase/skip-esc rs)))))
;;; uptop.scm ends here.
|
