suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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

Browse Source 
svn: r11675
This commit is contained in:
Eli Barzilay 2008-09-12 14:49:22 +00:00
parent ef92bf90f4
commit 4f1b829413
1 changed files with 778 additions and 773 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

143
collects/handin-client/client-gui.ss
View File

@ -1,14 +1,15 @@
(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@)
(provide tool@)
(define uninstalled? #f)
(define uninstalled? #f)
(define server:port (#%info-lookup 'server:port (lambda () #f)))
(define-values (server port-no)
(define server:port (#%info-lookup 'server:port (lambda () #f)))
(define-values (server port-no)
(if server:port
(let ([m (regexp-match #rx"^([^:]+):([0-9]+)$" server:port)])
(unless m
@ -18,35 +19,35 @@
(values (cadr m) (string->number (caddr m))))
(values #f #f)))
(define handin-name (#%info-lookup 'name))
(define web-menu-name (#%info-lookup 'web-menu-name (lambda () #f)))
(define web-address (#%info-lookup 'web-address (lambda () #f)))
(define handin-name (#%info-lookup 'name))
(define web-menu-name (#%info-lookup 'web-menu-name (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)))
(define handin-dialog-name (string-append handin-name " Handin"))
(define button-label/h (string-append handin-name " Handin"))
(define button-label/r (string-append handin-name " Retrieve"))
(define manage-dialog-name (string-append handin-name " Handin Account"))
(define handin-dialog-name (string-append handin-name " Handin"))
(define button-label/h (string-append handin-name " Handin"))
(define button-label/r (string-append handin-name " Retrieve"))
(define manage-dialog-name (string-append handin-name " Handin Account"))
(define updater?
(define updater?
(#%info-lookup 'enable-auto-update (lambda () #f)))
(define multifile?
(define multifile?
(#%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?)
(define (remembered-user)
(preferences:set-default preference-key "" string?)
(define (remembered-user)
(preferences:get preference-key))
(define (remember-user user)
(define (remember-user 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
(define cached-password
;; parameter-like procedure that keeps the password cached for a few minutes
(define cached-password
(let ([passwd #f]
[timer #f])
(define protect
@ -70,8 +71,8 @@
(protect (lambda ()
(set! passwd #f)
(set! timer #f)))))))))])))
;; a password entry box that uses the one cached above
(define cached-passwd%
;; a password entry box that uses the one cached above
(define cached-passwd%
(class text-field%
(define cached (cached-password))
;; use this instead of a cached password -- to avoid copy/pastes
@ -97,8 +98,8 @@
(super-new [init-value (if cached fake-value "")]
[style '(single password)])))
(provide handin-frame%)
(define handin-frame%
(provide handin-frame%)
(define handin-frame%
(class dialog%
(inherit show is-shown? center)
(super-new [label handin-dialog-name])
@ -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?))
@ -324,8 +333,8 @@
(center)
(show #t)))
(provide manage-handin-dialog%)
(define manage-handin-dialog%
(provide manage-handin-dialog%)
(define manage-handin-dialog%
(class dialog% (init [parent #f])
(inherit show is-shown? center)
@ -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)
@ -633,10 +643,10 @@
(center)
(show #t)))
;; A simple dialog during connection, with an option to cancel (used
;; by `get-user-fields' below, since its value is needed to
;; construct the above dialog).
(define connection-dialog%
;; A simple dialog during connection, with an option to cancel (used
;; by `get-user-fields' below, since its value is needed to
;; construct the above dialog).
(define connection-dialog%
(class dialog% (init receiver [parent #f])
(inherit show is-shown? center)
(super-new [label manage-dialog-name]
@ -669,8 +679,8 @@
(center)
(show #t)))
(define cached-user-fields #f)
(define (get-user-fields parent)
(define cached-user-fields #f)
(define (get-user-fields parent)
(unless cached-user-fields
(new connection-dialog%
[receiver (lambda (h)
@ -678,7 +688,7 @@
[parent parent]))
cached-user-fields)
(define (scale-by-half file)
(define (scale-by-half file)
(let* ([bm (make-object bitmap% file 'unknown/mask)]
[w (send bm get-width)]
[h (send bm get-height)]
@ -699,20 +709,18 @@
(send bm2 set-loaded-mask mbm2))
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%)]
[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)))
(define (string->editor! str defs)
(define (string->editor! str defs)
(let* ([base (make-object editor-stream-in-bytes-base% str)]
[stream (make-object editor-stream-in% base)])
(read-editor-version stream base #t)
@ -720,7 +728,7 @@
(send defs read-from-file stream)
(read-editor-global-footer stream)))
(define tool@
(define tool@
(unit
(import drscheme:tool^)
(export drscheme:tool-exports^)
@ -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))))