110 lines
3.2 KiB
Bash
110 lines
3.2 KiB
Bash
#!/bin/sh
|
|
:;exec /usr/local/bin/stk -f "$0" "$@"
|
|
;;;;
|
|
;;;; h b r o w s e -- A HTML browser
|
|
;;;;
|
|
;;;; Copyright © 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
|
|
;;;;
|
|
;;;; Permission to use, copy, and/or distribute this software and its
|
|
;;;; documentation for any purpose and without fee is hereby granted, provided
|
|
;;;; that both the above copyright notice and this permission notice appear in
|
|
;;;; all copies and derived works. Fees for distribution or use of this
|
|
;;;; software or derived works may only be charged with express written
|
|
;;;; permission of the copyright holder.
|
|
;;;; This software is provided ``as is'' without express or implied warranty.
|
|
;;;;
|
|
;;;; Author: Erick Gallesio [eg@unice.fr]
|
|
;;;; Creation date: 31-Aug-1995 15:15
|
|
;;;; Last file update: 17-Sep-1996 11:49
|
|
;;;;
|
|
|
|
(require "Tk-classes")
|
|
(require "Basics")
|
|
(require "html")
|
|
|
|
(expand-heap 100000) ; but far lower than netscape ;-)
|
|
|
|
;;;
|
|
;;; <Gauge> class definition
|
|
;;;
|
|
;;; I don't use the <Canvas> class to avoid its (long) loading.
|
|
;;; Only a little bit of canvas capabilities are used here
|
|
|
|
(define-class <Gauge> (<Tk-simple-widget> <Tk-sizeable>)
|
|
((foreground :accessor foreground :initform "red" :init-keyword :foreground)))
|
|
|
|
(define-method tk-constructor ((self <Gauge>))
|
|
Tk:canvas)
|
|
|
|
(define-method initialize ((self <Gauge>) initargs)
|
|
(next-method)
|
|
(slot-set! self 'highlight-thickness 0)
|
|
((slot-ref self 'Id) 'create 'line 0 0 0 0
|
|
:fill (foreground self)
|
|
:width (* 2 (+ (height self) 2))))
|
|
|
|
(define (update-gauge g percent)
|
|
((slot-ref g 'Id) 'coords "1" 0 0 (quotient (* (width g) percent) 100) 0)
|
|
(update))
|
|
|
|
;;;
|
|
;;; Make interface
|
|
;;;
|
|
(let ((loc (make <Labeled-entry>
|
|
:title "Location:"
|
|
:text-variable '*location*
|
|
:font "fixed"))
|
|
(txt (make <Scroll-text>
|
|
:font "fixed"
|
|
:width 80
|
|
:height 45)))
|
|
|
|
(bind (Id loc) "<Return>" (lambda () (Html:view-url (Id txt) (value loc))))
|
|
(pack loc :expand #f :fill "x" :padx 30 :pady 4)
|
|
(pack txt :expand #t :fill "both")
|
|
|
|
(let* ((f (make <Frame>))
|
|
(lab (make <Label> :parent f :anchor "w"))
|
|
(gauge (make <Gauge> :width 200 :height 10 :background "blue")))
|
|
(pack lab :padx 30 :pady 4 :side "left")
|
|
(pack gauge :padx 10 :side "right")
|
|
(pack f :fill "x")
|
|
|
|
;; See if a file was specified
|
|
(when (> *argc* 0)
|
|
(set! *location* (car *argv*))
|
|
(Html:view-url (Id txt) *location*))
|
|
|
|
;; Initialize hooks
|
|
(let ((counter 0)
|
|
(pos 0))
|
|
(set! html:hook-formatting
|
|
(lambda ()
|
|
(when (= counter 20)
|
|
(set! pos (modulo (+ pos 5) 105))
|
|
(set! counter 0)
|
|
(update-gauge gauge pos))
|
|
(set! counter (+ counter 1))))
|
|
|
|
(set! html:hook-start-loading
|
|
(lambda ()
|
|
(slot-set! txt 'cursor "watch")
|
|
(slot-set! lab 'text "Loading Document ...")
|
|
(update)))
|
|
|
|
(set! html:hook-stop-loading
|
|
(lambda ()
|
|
(update-gauge gauge 0)
|
|
(slot-set! lab 'text "Document done.")
|
|
(slot-set! txt 'cursor "top_left_arrow")
|
|
(after 5000 (lambda () (slot-set! lab 'text "")))))
|
|
|
|
(set! html:hook-title
|
|
(lambda (value)
|
|
(slot-set! *top-root* 'title value)))
|
|
|
|
(set! html:hook-location
|
|
(lambda (value)
|
|
(set! *location* value))))))
|
|
|