212 lines
6.8 KiB

;;;; w w w - b r o w s e r . s t k l o s -- A simple WEB browser
;;;; -- (and a very simple mail composer)
;;;; Copyright © 1993-1999 Erick Gallesio - I3S-CNRS/ESSI <>
;;;; Permission to use, copy, modify, distribute,and license this
;;;; software and its documentation for any purpose is hereby granted,
;;;; provided that existing copyright notices are retained in all
;;;; copies and that this notice is included verbatim in any
;;;; distributions. No written agreement, license, or royalty fee is
;;;; required for any of the authorized uses.
;;;; This software is provided ``AS IS'' without express or implied
;;;; warranty.
;;;; Author: Erick Gallesio []
;;;; Creation date: 21-Oct-1996 14:02
;;;; Last file update: 16-Sep-1999 17:37 (eg)
(require "Tk-classes")
(require "www")
(import WWW)
;;;; W W W : b r o w s e r
(define WWW:browser
(let ((browser #f) ;; Id of browser (#f if no browser exists)
(lentry #f)) ;; The labeled entry of the interface
(lambda args
;; URL history management
(define new-url
(let ((history '())
(current -1))
(lambda (txt url)
(case url
((previous) (when (> (length history) 1)
(set! current (modulo (- current 1) (length history)))
(www:view-url (Id txt) (list-ref history current))))
((next) (when (> (length history) 1)
(set! current (modulo (+ current 1) (length history)))
(www:view-url (Id txt) (list-ref history current))))
((reload) (www:view-url (Id txt) (list-ref history current)))
(ELSE (if (null? history)
(set! history (list url))
(set! current 0))
(unless (string=? (list-ref history current) url)
(set! history (append history (list url)))
(set! current (- (length history) 1)))))))))
;;; Make interface
(define (make-buttons parent txt)
(let ((s (make-toolbar parent
`(("tb_back.gif" "Back" ,(lambda () (new-url (Id txt) 'previous)))
("tb_forward.gif" "Forward" ,(lambda () (new-url (Id txt) 'next)))
("tb_reload.gif" "Reload" ,(lambda () (new-url (Id txt) 'reload)))
("tb_stop.gif" "Stop Loading"
,(lambda () (set! www:stop-loading #t)))
("tb_exit.gif" "Exit" ,(lambda () (destroy parent)))
("tb_info.gif" "Help" ,(lambda ()
(STk:show-help-file "STk-hlp.html"))))
:relief "ridge" :border-width 2
:release-command (default-release-toolbar txt))))
(define (make-location parent txt)
(let* ((s (make-toolbar parent '(0)
:relief "ridge" :border-width 2
:release-command (default-release-toolbar txt)))
(f (toolbar-item s 0))
(le (make <Labeled-entry> :parent f :title "Location:"
:font '(Courier -12))))
(pack le :fill 'x :expand #t)
(bind (Id le) "<Return>" (lambda () (www:view-url (Id txt) (value le))))
;; Keep a reference on the labeled entry for later bindings
(set! lentry le)
(define (make-interface parent)
(let* ((txt (make <Scroll-text> :parent parent :font '(Courier -12)
:width 100 :height 45))
(loc (make-location parent txt))
(f (make-buttons parent txt))
(f1 (make <Frame> :parent parent))
(lab (make <Label> :parent f1 :anchor "w"))
(gauge (make <Gauge> :parent f1 :width 200 :height 10
:background "gray40" :foreground "IndianRed4")))
;; Pack commponents
(pack f loc :expand #f :fill "x")
(pack txt :expand #t :fill "both")
(pack f1 :expand #f :fill "x")
(pack lab :expand #t :fill "x" :side "left")
(pack gauge :expand #f :side "left" :padx 10)
;; Redefinition of WWW hooks
(set! www:hook-formatting
(let ((counter 0)
(pos 0))
(lambda ()
(when (= counter 20)
(set! pos (modulo (+ pos 5) 105))
(set! counter 0)
(set! (value gauge) pos)
(set! counter (+ counter 1)))))
(set! www:hook-start-loading
(lambda ()
(slot-set! txt 'cursor "watch")
(slot-set! lab 'text "Loading Document ...")
(set! www:hook-stop-loading
(lambda ()
(let ((msg "Loading Document ... Done."))
(slot-set! gauge 'value 0)
(slot-set! lab 'text msg)
(slot-set! txt 'cursor "top_left_arrow")
(set! www:stop-loading #f)
(after 5000 (lambda ()
(catch (if (equal? (slot-ref lab 'text) msg)
(slot-set! lab 'text ""))))))))
(set! www:hook-title
(lambda (value)
(slot-set! parent 'title value)))
(set! www:hook-location
(lambda (url)
(set! (value lentry) url)
(new-url txt url)))
;; Return the txt widget
;;;; STk:browse starts here
(let* ((url (get-keyword :url args #f))
(parent (get-keyword :parent args #f)))
(unless browser
(set! browser (make-interface
(or parent
(make <Toplevel> :title "STk Web browser"))))
(bind browser "<Destroy>" (lambda () (set! browser #f))))
(when url
(www:view-url (Id browser) url))
(define (www:mailto . to)
(let* ((top (make <Toplevel> :title "STk Mail Composer"))
(to (make <Labeled-entry> :parent top :title "To:"
:title-width 7 :title-anchor 'e
:value (if (null? to) "" (car to))))
(cc (make <Labeled-entry> :parent top :title "Cc:"
:title-width 7 :title-anchor 'e))
(subject (make <Labeled-entry> :parent top :title "Subject:"
:title-width 7 :title-anchor 'e))
(txt (make <Scroll-text> :parent top))
(f (make <Frame> :parent top :border-width 2 :relief 'ridge))
(send (make <Button> :text "Send" :parent f :border-width 1))
(cancel (make <Button> :text "Cancel" :parent f :border-width 1)))
(pack to cc subject :expand #f :fill 'x :padx 5)
(pack txt :expand #t :fill 'both :padx 5 :pady 3)
(pack send cancel :side 'left)
(pack f :expand #f :fill 'x)
;; Set the background of text to white
(set! (background (text-of txt)) "white")
;; Set action of Send and Cancel button
(set! (command Cancel)
(if (eq? 'yes (Tk:message-box :title "Cancel Message"
:icon 'question :type 'yesno
:message "Close and discard message?"))
(destroy top))))
(set! (command send)
(lambda ()
(unless (string=? (value to) "")
(let ((cmd (string-append "| /bin/mail "
"-s '" (value subject) "' "
"-c '" (value cc) "' "
(value to))))
(with-output-to-file cmd (lambda () (display (value txt))))
(Tk:message-box :title "Message Information"
:message "Message sent" :icon 'info)
(destroy top)))))))
;;; Misc.
(define STk:web-browser WWW:browser) ; for backward compatibility with 3.x versions
(set! www:hook-mailto www:mailto)
(provide "www-browser")