switch to #lang, reindent, minor fix (when -> if), merge stuff with csu660 version

svn: r11675
This commit is contained in:
Eli Barzilay 2008-09-12 14:49:22 +00:00
parent ef92bf90f4
commit 4f1b829413

View File

@ -1,14 +1,15 @@
(module client-gui scheme/base #lang scheme/base
(require mzlib/class mzlib/unit mzlib/file mrlib/switchable-button
mrlib/bitmap-label net/sendurl mred drscheme/tool framework (require mzlib/class mzlib/unit mzlib/file mred net/sendurl
mrlib/switchable-button mrlib/bitmap-label drscheme/tool framework
"info.ss" "client.ss" "this-collection.ss") "info.ss" "client.ss" "this-collection.ss")
(provide tool@) (provide tool@)
(define uninstalled? #f) (define uninstalled? #f)
(define server:port (#%info-lookup 'server:port (lambda () #f))) (define server:port (#%info-lookup 'server:port (lambda () #f)))
(define-values (server port-no) (define-values (server port-no)
(if server:port (if server:port
(let ([m (regexp-match #rx"^([^:]+):([0-9]+)$" server:port)]) (let ([m (regexp-match #rx"^([^:]+):([0-9]+)$" server:port)])
(unless m (unless m
@ -18,35 +19,35 @@
(values (cadr m) (string->number (caddr m)))) (values (cadr m) (string->number (caddr m))))
(values #f #f))) (values #f #f)))
(define handin-name (#%info-lookup 'name)) (define handin-name (#%info-lookup 'name))
(define web-menu-name (#%info-lookup 'web-menu-name (lambda () #f))) (define web-menu-name (#%info-lookup 'web-menu-name (lambda () #f)))
(define web-address (#%info-lookup 'web-address (lambda () #f))) (define web-address (#%info-lookup 'web-address (lambda () #f)))
(define password-keep-minutes (define password-keep-minutes
(#%info-lookup 'password-keep-minutes (lambda () #f))) (#%info-lookup 'password-keep-minutes (lambda () #f)))
(define handin-dialog-name (string-append handin-name " Handin")) (define handin-dialog-name (string-append handin-name " Handin"))
(define button-label/h (string-append handin-name " Handin")) (define button-label/h (string-append handin-name " Handin"))
(define button-label/r (string-append handin-name " Retrieve")) (define button-label/r (string-append handin-name " Retrieve"))
(define manage-dialog-name (string-append handin-name " Handin Account")) (define manage-dialog-name (string-append handin-name " Handin Account"))
(define updater? (define updater?
(#%info-lookup 'enable-auto-update (lambda () #f))) (#%info-lookup 'enable-auto-update (lambda () #f)))
(define multifile? (define multifile?
(#%info-lookup 'enable-multifile-handin (lambda () #f))) (#%info-lookup 'enable-multifile-handin (lambda () #f)))
(define preference-key (make-my-key 'submit:username)) (define preference-key (make-my-key 'submit:username))
(preferences:set-default preference-key "" string?) (preferences:set-default preference-key "" string?)
(define (remembered-user) (define (remembered-user)
(preferences:get preference-key)) (preferences:get preference-key))
(define (remember-user user) (define (remember-user user)
(preferences:set preference-key user)) (preferences:set preference-key user))
(define (connect) (handin-connect server port-no)) (define (connect) (handin-connect server port-no))
;; parameter-like procedure that keeps the password cached for a few minutes ;; parameter-like procedure that keeps the password cached for a few minutes
(define cached-password (define cached-password
(let ([passwd #f] (let ([passwd #f]
[timer #f]) [timer #f])
(define protect (define protect
@ -70,8 +71,8 @@
(protect (lambda () (protect (lambda ()
(set! passwd #f) (set! passwd #f)
(set! timer #f)))))))))]))) (set! timer #f)))))))))])))
;; a password entry box that uses the one cached above ;; a password entry box that uses the one cached above
(define cached-passwd% (define cached-passwd%
(class text-field% (class text-field%
(define cached (cached-password)) (define cached (cached-password))
;; use this instead of a cached password -- to avoid copy/pastes ;; use this instead of a cached password -- to avoid copy/pastes
@ -97,8 +98,8 @@
(super-new [init-value (if cached fake-value "")] (super-new [init-value (if cached fake-value "")]
[style '(single password)]))) [style '(single password)])))
(provide handin-frame%) (provide handin-frame%)
(define handin-frame% (define handin-frame%
(class dialog% (class dialog%
(inherit show is-shown? center) (inherit show is-shown? center)
(super-new [label handin-dialog-name]) (super-new [label handin-dialog-name])
@ -110,31 +111,37 @@
[on-retrieve 'retrieve] [on-retrieve 'retrieve]
[else (error 'handin-frame "bad initial values")])) [else (error 'handin-frame "bad initial values")]))
(define status (new message% (define status
(new message%
[label (format "Making secure connection to ~a..." server)] [label (format "Making secure connection to ~a..." server)]
[parent this] [parent this]
[stretchable-width #t])) [stretchable-width #t]))
(define username (new text-field% (define username
(new text-field%
[label "Username:"] [label "Username:"]
[init-value (remembered-user)] [init-value (remembered-user)]
[parent this] [parent this]
[callback (lambda (t e) (activate-ok))] [callback (lambda (t e) (activate-ok))]
[stretchable-width #t])) [stretchable-width #t]))
(define passwd (new cached-passwd% (define passwd
(new cached-passwd%
[label "Password:"] [label "Password:"]
[parent this] [parent this]
[callback (lambda (t e) (activate-ok))] [callback (lambda (t e) (activate-ok))]
[stretchable-width #t])) [stretchable-width #t]))
(define assignment (new choice% (define assignment
(new choice%
[label "Assignment:"] [label "Assignment:"]
[choices null] [choices null]
[parent this] [parent this]
[callback void] [callback void]
[stretchable-width #t])) [stretchable-width #t]))
(define button-panel (new horizontal-pane% (define button-panel
(new horizontal-pane%
[parent this] [parent this]
[stretchable-height #f])) [stretchable-height #f]))
(make-object vertical-pane% button-panel) ; spacer (make-object vertical-pane% button-panel) ; spacer
(define retrieve? (define retrieve?
@ -212,7 +219,8 @@
(not (string=? "" (send username get-value))) (not (string=? "" (send username get-value)))
(not (string=? "" (send passwd get-value)))))) (not (string=? "" (send passwd get-value))))))
(define cancel (new button% (define cancel
(new button%
[label "Cancel"] [label "Cancel"]
[parent button-panel] [parent button-panel]
[callback (lambda (b e) (do-cancel-button))])) [callback (lambda (b e) (do-cancel-button))]))
@ -239,10 +247,11 @@
[parent d] [parent d]
[stretchable-height #f] [stretchable-height #f]
[alignment '(center center)])]) [alignment '(center center)])])
(make-object button% "Continue Commit" d (lambda (b e) (send d show #f))) (make-object button% "Continue Commit" d
(make-object button% "Try to Cancel" d (lambda (b e) (lambda (b e) (send d show #f)))
(set! continue-abort? #t) (make-object button% "Try to Cancel" d
(send d show #f)))))) (lambda (b e)
(set! continue-abort? #t) (send d show #f))))))
(define interface-widgets (define interface-widgets
(list ok username passwd assignment retrieve?)) (list ok username passwd assignment retrieve?))
@ -324,8 +333,8 @@
(center) (center)
(show #t))) (show #t)))
(provide manage-handin-dialog%) (provide manage-handin-dialog%)
(define manage-handin-dialog% (define manage-handin-dialog%
(class dialog% (init [parent #f]) (class dialog% (init [parent #f])
(inherit show is-shown? center) (inherit show is-shown? center)
@ -466,7 +475,8 @@
(delete-directory/files (in-this-collection)) (delete-directory/files (in-this-collection))
(set! uninstalled? #t) (set! uninstalled? #t)
(send uninstall-button enable #f) (send uninstall-button enable #f)
(message-box "Uninstall" (message-box
"Uninstall"
(format "The ~a tool has been uninstalled. ~a~a" (format "The ~a tool has been uninstalled. ~a~a"
handin-name handin-name
"The Handin button and associated menu items will" "The Handin button and associated menu items will"
@ -522,9 +532,9 @@
(when (is-shown?) (when (is-shown?)
(message-box (message-box
"Server Error" "Server Error"
(when (exn? exn) (if (exn? exn)
(let ([s (exn-message exn)]) (let ([s (exn-message exn)]) (if (string? s) s (format "~e" s)))
(if (string? s) s (format "~e" s)))) (format "~e" exn))
this) this)
(set! comm-cust (make-custodian)))))) (set! comm-cust (make-custodian))))))
@ -562,9 +572,9 @@
(check-length pw1 50 l1 k) (check-length pw1 50 l1 k)
;; not really needed, but leave just in case ;; not really needed, but leave just in case
(unless (string=? (send pw1 get-value) (send pw2 get-value)) (unless (string=? (send pw1 get-value) (send pw2 get-value))
(message-box "Password Error" (message-box
(format "The \"~a\" and \"~a\" passwords are not the same." "Password Error"
l1 l2)) (format "The \"~a\" and \"~a\" passwords are not the same." l1 l2))
(k (void)))) (k (void))))
(for-each (lambda (t f) (check-length t 100 f k)) (for-each (lambda (t f) (check-length t 100 f k))
(if new? add-user-fields change-user-fields) (if new? add-user-fields change-user-fields)
@ -633,10 +643,10 @@
(center) (center)
(show #t))) (show #t)))
;; A simple dialog during connection, with an option to cancel (used ;; A simple dialog during connection, with an option to cancel (used
;; by `get-user-fields' below, since its value is needed to ;; by `get-user-fields' below, since its value is needed to
;; construct the above dialog). ;; construct the above dialog).
(define connection-dialog% (define connection-dialog%
(class dialog% (init receiver [parent #f]) (class dialog% (init receiver [parent #f])
(inherit show is-shown? center) (inherit show is-shown? center)
(super-new [label manage-dialog-name] (super-new [label manage-dialog-name]
@ -669,8 +679,8 @@
(center) (center)
(show #t))) (show #t)))
(define cached-user-fields #f) (define cached-user-fields #f)
(define (get-user-fields parent) (define (get-user-fields parent)
(unless cached-user-fields (unless cached-user-fields
(new connection-dialog% (new connection-dialog%
[receiver (lambda (h) [receiver (lambda (h)
@ -678,7 +688,7 @@
[parent parent])) [parent parent]))
cached-user-fields) cached-user-fields)
(define (scale-by-half file) (define (scale-by-half file)
(let* ([bm (make-object bitmap% file 'unknown/mask)] (let* ([bm (make-object bitmap% file 'unknown/mask)]
[w (send bm get-width)] [w (send bm get-width)]
[h (send bm get-height)] [h (send bm get-height)]
@ -699,20 +709,18 @@
(send bm2 set-loaded-mask mbm2)) (send bm2 set-loaded-mask mbm2))
bm2)) bm2))
(define handin-icon (scale-by-half (in-this-collection "icon.png"))) (define handin-icon (scale-by-half (in-this-collection "icon.png")))
(define (editors->string editors) (define (editors->string editors)
(let* ([base (make-object editor-stream-out-bytes-base%)] (let* ([base (make-object editor-stream-out-bytes-base%)]
[stream (make-object editor-stream-out% base)]) [stream (make-object editor-stream-out% base)])
(write-editor-version stream base) (write-editor-version stream base)
(write-editor-global-header stream) (write-editor-global-header stream)
(for-each (lambda (ed) (for-each (lambda (ed) (send ed write-to-file stream)) editors)
(send ed write-to-file stream))
editors)
(write-editor-global-footer stream) (write-editor-global-footer stream)
(send base get-bytes))) (send base get-bytes)))
(define (string->editor! str defs) (define (string->editor! str defs)
(let* ([base (make-object editor-stream-in-bytes-base% str)] (let* ([base (make-object editor-stream-in-bytes-base% str)]
[stream (make-object editor-stream-in% base)]) [stream (make-object editor-stream-in% base)])
(read-editor-version stream base #t) (read-editor-version stream base #t)
@ -720,7 +728,7 @@
(send defs read-from-file stream) (send defs read-from-file stream)
(read-editor-global-footer stream))) (read-editor-global-footer stream)))
(define tool@ (define tool@
(unit (unit
(import drscheme:tool^) (import drscheme:tool^)
(export drscheme:tool-exports^) (export drscheme:tool-exports^)
@ -770,10 +778,9 @@
(define/override (help-menu:after-about menu) (define/override (help-menu:after-about menu)
(when web-menu-name (when web-menu-name
(new menu-item% (new menu-item%
(label web-menu-name) [label web-menu-name]
(parent menu) [parent menu]
(callback (lambda (item evt) [callback (lambda (item evt) (send-url web-address))]))
(send-url web-address)))))
(super help-menu:after-about menu)) (super help-menu:after-about menu))
(define client-panel (define client-panel
@ -803,9 +810,7 @@
(register-toolbar-button client-button) (register-toolbar-button client-button)
(send (get-button-panel) change-children (send (get-button-panel) change-children
(lambda (_) (lambda (l) (cons client-panel (remq client-panel l))))))
(cons client-panel
(remq client-panel _))))))
(when (and server port-no) (when (and server port-no)
(drscheme:get/extend:extend-unit-frame make-new-unit-frame% #f))))) (drscheme:get/extend:extend-unit-frame make-new-unit-frame% #f))))