#! /usr/local/bin/xmscm
; $Header: /home/campbell/Languages/Scheme/scm/x-scm/RCS/xftp.scm,v 1.4 1992/08/12 01:57:29 campbell Beta $
;
; Sample X-scheme program for requesting files or RFCs from an FTP
; mail server.  It pops up a dialog in which you fill in the host
; name, filename, RFC number, etc. and then mails off a request.
; I wrote this partly to play with X-scheme and partly so I wouldn't
; have to remember the magic incantations for the FTP mail server.
;
; Author: Larry Campbell (campbell@redsox.bsw.com)
;
(require 'stdio)
(require 'x11)
(require 'xt)
(require 'xm)
(require 'xmsubs)

; Mail request to ftpmail@decwrl.dec.com and to the user
;
(define request-destination
  (string-append "ftpmail@decwrl.dec.com " (getenv "USER")))

; Send an email request to the DECWRL FTP server to fetch a file,
; or get a directory listing, or both.
;
(define (send-ftp-request host file dir)
  (let* ((tmpfilename (tmpnam))
	 (tmpfile (open-output-file tmpfilename)))
    (fprintf tmpfile "connect %s\\n" host)
    (fprintf tmpfile "binary\\n")
    (fprintf tmpfile "uuencode\\n")
    (if (> (string-length file) 0)
	(fprintf tmpfile "get %s\\n" file))
    (if (> (string-length dir) 0)
	(fprintf tmpfile "ls %s\\n" dir))
    (fprintf tmpfile "quit")
    (close-output-port tmpfile)
    (let* ((s (make-string 80 #\space))
	   (len
	    (sprintf
	     s "elm -s request %s <%s" request-destination tmpfilename)))
      (system (substring s 0 len))
      (delete-file tmpfilename))))

; Send an email request to the DECWRL FTP server to fetch an RFC
;
(define (send-rfc-request rfc-number)
  (let* ((tmpfilename (tmpnam))
	 (tmpfile (open-output-file tmpfilename)))
    (fprintf tmpfile "connect gatekeeper.dec.com\\n")
    (fprintf tmpfile "binary\\n")
    (fprintf tmpfile "uuencode\\n")
    (fprintf tmpfile "get /pub/net/info/RFC/rfc%d.txt\\n" rfc-number)
    (fprintf tmpfile "quit")
    (close-output-port tmpfile)
    (let* ((s (make-string 80 #\space))
	   (slen
	    (sprintf
	     s "elm -s request %s <%s" request-destination tmpfilename)))
      (system (substring s 0 slen))
      (delete-file tmpfilename))))

(define top-level
  (if (defined? vs:top-level)
      (xt:app-create-shell "xftp" "Xftp"
			   xt:application-shell
			   (xt:display vs:top-level))
      (xt:initialize "xftp" "Xftp")))

(xt:set-values
 top-level
 xt:n-allow-shell-resize #t
 xt:n-title "FTP mail server requestor")

(define ftp-panel
  (xt:create-managed-widget
   "ftppanel" xm:row-column top-level))

(define ftp-host-widget
  (make-captioned-text-widget ftp-panel "Host:" 30))
(define ftp-file-widget
  (make-captioned-text-widget ftp-panel "File to retrieve:" 30))
(define ftp-dir-widget
  (make-captioned-text-widget ftp-panel "Directory to list:" 30))

(xt:create-managed-widget "separator" xm:separator ftp-panel)

(define rfc-number-widget
  (make-captioned-text-widget ftp-panel "RFC number:" 30))

(xt:create-managed-widget "separator" xm:separator ftp-panel)

(make-button-row
 ftp-panel
 `(
   ("OK" ,(lambda (w)
	    (let* ((host (xm:text-get-string ftp-host-widget))
		   (file (xm:text-get-string ftp-file-widget))
		   (dir  (xm:text-get-string ftp-dir-widget))
		   (rfc  (xm:text-get-string rfc-number-widget)))
	      (if (and (not (zero? (string-length host)))
		       (or (not (zero? (string-length file)))
			   (not (zero? (string-length dir)))))
		  (begin
		    (with-busy-cursor
		     top-level
		     (lambda ()
		       (send-ftp-request host file dir)
		       (popup-information
			top-level "Your FTP request has been mailed.")))))
	      (if (not (zero? (string-length rfc)))
		  (begin
		    (send-rfc-request (string->number rfc 10))
		    (popup-information
		     top-level
		     (string-append "Your FTP request for RFC"
		      rfc
		      " has been mailed.")))))))

   ("Clear" ,(lambda (w)
	       (xt:set-values ftp-host-widget    xm:n-value "")
	       (xt:set-values ftp-file-widget    xm:n-value "")
	       (xt:set-values ftp-dir-widget     xm:n-value "")
	       (xt:set-values rfc-number-widget  xm:n-value "")))

   ("Exit" ,(lambda (w) (quit)))

   ("Help" ,(lambda (w)
	      (popup-information
	       top-level
"To request a file from an FTP site, fill in the host name and file
name to retrieve and click `OK'.  To get a listing of a directory
on a remote host, fill in the directory name and click `OK'.  You
can combine these to fetch a file and get a directory listing from
one host in a single request.

To request a copy of an RFC, fill in the RFC number and click `OK'."
)))

   ))

(xt:realize-widget top-level)

(if (not (defined? vs:top-level))
    (xt:main-loop))

