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,6 +1,7 @@
(module client-gui scheme/base
(require mzlib/class mzlib/unit mzlib/file mrlib/switchable-button
mrlib/bitmap-label net/sendurl mred drscheme/tool framework
#lang scheme/base
(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")
(provide tool@)
@ -110,31 +111,37 @@
[on-retrieve 'retrieve]
[else (error 'handin-frame "bad initial values")]))
(define status (new message%
(define status
(new message%
[label (format "Making secure connection to ~a..." server)]
[parent this]
[stretchable-width #t]))
(define username (new text-field%
(define username
(new text-field%
[label "Username:"]
[init-value (remembered-user)]
[parent this]
[callback (lambda (t e) (activate-ok))]
[stretchable-width #t]))
(define passwd (new cached-passwd%
(define passwd
(new cached-passwd%
[label "Password:"]
[parent this]
[callback (lambda (t e) (activate-ok))]
[stretchable-width #t]))
(define assignment (new choice%
(define assignment
(new choice%
[label "Assignment:"]
[choices null]
[parent this]
[callback void]
[stretchable-width #t]))
(define button-panel (new horizontal-pane%
(define button-panel
(new horizontal-pane%
[parent this]
[stretchable-height #f]))
(make-object vertical-pane% button-panel) ; spacer
(define retrieve?
@ -212,7 +219,8 @@
(not (string=? "" (send username get-value)))
(not (string=? "" (send passwd get-value))))))
(define cancel (new button%
(define cancel
(new button%
[label "Cancel"]
[parent button-panel]
[callback (lambda (b e) (do-cancel-button))]))
@ -239,10 +247,11 @@
[parent d]
[stretchable-height #f]
[alignment '(center center)])])
(make-object button% "Continue Commit" d (lambda (b e) (send d show #f)))
(make-object button% "Try to Cancel" d (lambda (b e)
(set! continue-abort? #t)
(send d show #f))))))
(make-object button% "Continue Commit" d
(lambda (b e) (send d show #f)))
(make-object button% "Try to Cancel" d
(lambda (b e)
(set! continue-abort? #t) (send d show #f))))))
(define interface-widgets
(list ok username passwd assignment retrieve?))
@ -466,7 +475,8 @@
(delete-directory/files (in-this-collection))
(set! uninstalled? #t)
(send uninstall-button enable #f)
(message-box "Uninstall"
(message-box
"Uninstall"
(format "The ~a tool has been uninstalled. ~a~a"
handin-name
"The Handin button and associated menu items will"
@ -522,9 +532,9 @@
(when (is-shown?)
(message-box
"Server Error"
(when (exn? exn)
(let ([s (exn-message exn)])
(if (string? s) s (format "~e" s))))
(if (exn? exn)
(let ([s (exn-message exn)]) (if (string? s) s (format "~e" s)))
(format "~e" exn))
this)
(set! comm-cust (make-custodian))))))
@ -562,9 +572,9 @@
(check-length pw1 50 l1 k)
;; not really needed, but leave just in case
(unless (string=? (send pw1 get-value) (send pw2 get-value))
(message-box "Password Error"
(format "The \"~a\" and \"~a\" passwords are not the same."
l1 l2))
(message-box
"Password Error"
(format "The \"~a\" and \"~a\" passwords are not the same." l1 l2))
(k (void))))
(for-each (lambda (t f) (check-length t 100 f k))
(if new? add-user-fields change-user-fields)
@ -706,9 +716,7 @@
[stream (make-object editor-stream-out% base)])
(write-editor-version stream base)
(write-editor-global-header stream)
(for-each (lambda (ed)
(send ed write-to-file stream))
editors)
(for-each (lambda (ed) (send ed write-to-file stream)) editors)
(write-editor-global-footer stream)
(send base get-bytes)))
@ -770,10 +778,9 @@
(define/override (help-menu:after-about menu)
(when web-menu-name
(new menu-item%
(label web-menu-name)
(parent menu)
(callback (lambda (item evt)
(send-url web-address)))))
[label web-menu-name]
[parent menu]
[callback (lambda (item evt) (send-url web-address))]))
(super help-menu:after-about menu))
(define client-panel
@ -803,9 +810,7 @@
(register-toolbar-button client-button)
(send (get-button-panel) change-children
(lambda (_)
(cons client-panel
(remq client-panel _))))))
(lambda (l) (cons client-panel (remq client-panel l))))))
(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))))