home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
The World of Computer Software
/
World_Of_Computer_Software-02-385-Vol-1of3.iso
/
x
/
xscm105.zip
/
xscm
/
xftp.scm
< prev
next >
Wrap
Text File
|
1992-08-29
|
5KB
|
147 lines
#! /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))