switch to #lang, reindent, minor fix (when -> if), merge stuff with csu660 version
svn: r11675
This commit is contained in:
parent
ef92bf90f4
commit
4f1b829413
|
@ -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))))
|
||||
|
|
Loading…
Reference in New Issue
Block a user