examples/uptop.scm.in: Add to the repository

* examples/uptop.scm.in: Add to the repository.
* examples/Makefile.am (EXTRA_DIST, dist_examples_DATA): Update.
* examples/README, examples/.gitignore: Update.

4 files changed, 97 insertions, 2 deletions

diff --git a/examples/.gitignore b/examples/.gitignore
index ba5543f..3a3604e 100644
--- a/examples/.gitignore
+++ b/examples/.gitignore
@@ -10,4 +10,5 @@ rpc/client.scm
 rpc/server.scm
 sscp.scm
 pg-tunnel.scm
+uptop.scm
 Makefile.in
diff --git a/examples/Makefile.am b/examples/Makefile.am
index c7a3f6f..0528136 100644
--- a/examples/Makefile.am
+++ b/examples/Makefile.am
@@ -25,12 +25,14 @@ EXTRA_DIST = \
 	rpc/client.scm.in	\
 	rpc/server.scm.in	\
 	sscp.scm.in		\
-	pg-tunnel.scm.in
+	pg-tunnel.scm.in	\
+	uptop.scm.in
 
 examplesdir = $(pkgdatadir)/examples
 examples_echodir = $(pkgdatadir)/examples/echo
 examples_rpcdir = $(pkgdatadir)/examples/rpc
-dist_examples_DATA = README sssh.scm ssshd.scm rrepl.scm sscp.scm pg-tunnel.scm
+dist_examples_DATA = README sssh.scm ssshd.scm rrepl.scm sscp.scm pg-tunnel.scm \
+	uptop.scm
 dist_examples_echo_DATA = echo/server.scm echo/client.scm
 dist_examples_rpc_DATA = rpc/client.scm rpc/server.scm
 
diff --git a/examples/README b/examples/README
index 4481bce..a4d2f0d 100644
--- a/examples/README
+++ b/examples/README
@@ -49,3 +49,13 @@ $ sscp avp@127.0.0.1:/etc/profile profile
 $ ./pg-tunnel.scm --host=example.org --dbname=example --user=alice \
     'select * from people'
 #+END_EXAMPLE
+** =uptop.scm=
+   Connect to a remote host, execute =top= command on it and print the output
+   in uppercase letters, with terminal control characters intact.
+
+   The program shows usage of remote pipes (from =(ssh popen)= module.)
+*** Usage
+#+BEGIN_EXAMPLE
+./uptop.scm <hostname>
+#+END_EXAMPLE
+    The program can be stopped by hitting Ctrl-C.
diff --git a/examples/uptop.scm.in b/examples/uptop.scm.in
new file mode 100755
index 0000000..09a3ec9
--- /dev/null
+++ b/examples/uptop.scm.in
@@ -0,0 +1,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.