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

improve the way errors are reported, avoid unintended multithreading

Browse Source 
svn: r1479
This commit is contained in:
Matthew Flatt 2005-12-02 05:28:30 +00:00
parent d7029f6406
commit e86f372261
1 changed files with 87 additions and 44 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

131
collects/browser/private/hyper.ss
View File

@ -228,28 +228,53 @@ A test case:
(send top-level-window close-status-line 'browser:hyper.ss)) (send top-level-window close-status-line 'browser:hyper.ss))
(define/public reload (define/public reload
;; The reload function is called in a non-main thread,
;; since this class is instantiated in a non-main thread.
(opt-lambda ([progress void]) (opt-lambda ([progress void])
(when url (when url
(init-browser-status-line top-level-window) (let ([s (make-semaphore)]
(update-browser-status-line [closer-t #f]
top-level-window [this-t (current-thread)])
(format "Visiting ~a" (queue-callback
(cond (lambda ()
[(url? url) (url->string url)] (init-browser-status-line top-level-window)
[else "page"]))) (update-browser-status-line
(let ([headers (get-headers/read-from-port progress)]) top-level-window
;; Page is a redirection? (format "Visiting ~a"
(let ([m (regexp-match "^HTTP/[^ ]+ 301 " headers)]) (cond
(when m [(url? url) (url->string url)]
(let ([loc (extract-field "location" headers)]) [else "page"])))
(when loc ;; Yikes! We need to ensure that the browser status
(set! redirection ;; line is closed, even if the reload thread dies.
(cond ;; We use the usual trick of setting up a watcher
[(url? url) ;; thread and then killing it off if its work
(combine-url/relative url loc)] ;; is not needed.
[else (set! closer-t
(string->url loc)]))))))) (thread (lambda ()
(close-browser-status-line top-level-window)))) (sync (thread-dead-evt this-t))
(queue-callback
(lambda ()
(close-browser-status-line top-level-window))))))
(semaphore-post s)))
(yield s)
(let ([headers (get-headers/read-from-port progress)])
;; Page is a redirection?
(let ([m (regexp-match "^HTTP/[^ ]+ 301 " headers)])
(when m
(let ([loc (extract-field "location" headers)])
(when loc
(set! redirection
(cond
[(url? url)
(combine-url/relative url loc)]
[else
(string->url loc)])))))))
(queue-callback
(lambda ()
(kill-thread closer-t)
(close-browser-status-line top-level-window)
(semaphore-post s)))
(yield s)))))
(define/private (get-headers/read-from-port progress) (define/private (get-headers/read-from-port progress)
(cond (cond
@ -260,8 +285,7 @@ A test case:
(let* ([busy? #t] (let* ([busy? #t]
[stop-busy (lambda () [stop-busy (lambda ()
(when busy? (when busy?
(set! busy? #f) (set! busy? #f)))])
(end-busy-cursor)))])
(with-handlers ([(lambda (x) (and (exn:fail? x) busy?)) (with-handlers ([(lambda (x) (and (exn:fail? x) busy?))
(lambda (x) (lambda (x)
(call/input-url (call/input-url
@ -367,7 +391,6 @@ A test case:
#f ; should be calling window! #f ; should be calling window!
#f #f
orig-name))]) orig-name))])
(begin-busy-cursor) ; turn the cursor back on
(when tmp-plt-filename (when tmp-plt-filename
(let* ([d (make-object dialog% (string-constant downloading) top-level-window)] (let* ([d (make-object dialog% (string-constant downloading) top-level-window)]
[message (make-object message% [message (make-object message%
@ -450,7 +473,15 @@ A test case:
(current-load-relative-directory))]) (current-load-relative-directory))])
(parameterize ([html-status-handler (parameterize ([html-status-handler
(lambda (s) (lambda (s)
(update-browser-status-line top-level-window s))] (let ([t (current-thread)])
(queue-callback
(lambda ()
(when (thread-running? t)
;; Since t is running, the status line hasn't been
;; closed by the watcher thread (and there's no
;; race, because it can only be closed in the
;; handler thread)
(update-browser-status-line top-level-window s))))))]
[current-load-relative-directory directory] [current-load-relative-directory directory]
[html-eval-ok (url-allows-evaling? url)]) [html-eval-ok (url-allows-evaling? url)])
(html-convert p this)))] (html-convert p this)))]
@ -470,7 +501,6 @@ A test case:
(end-edit-sequence)]))) (end-edit-sequence)])))
(lambda () (lambda ()
(end-edit-sequence) (end-edit-sequence)
(end-busy-cursor)
(set! htmling? #f) (set! htmling? #f)
(set-modified #f) (set-modified #f)
(auto-wrap wrapping-on?) (auto-wrap wrapping-on?)
@ -733,29 +763,41 @@ A test case:
;; if cust is shutdown, the url will stop being loaded and a dummy editor is returned. ;; if cust is shutdown, the url will stop being loaded and a dummy editor is returned.
(define (make-editor/setup-kill cust html-editor% tlw init-url progress post-data remap-url) (define (make-editor/setup-kill cust html-editor% tlw init-url progress post-data remap-url)
(let* ([c (make-channel)] (let* ([c (make-channel)]
[progs (make-channel)]
[sent-prog? #f]
[t (parameterize ([current-custodian cust]) [t (parameterize ([current-custodian cust])
(thread (thread
(lambda () (lambda ()
(channel-put (with-handlers ([exn? (lambda (exn)
c (channel-put c exn))])
(make-editor/follow-redirections html-editor% (channel-put
tlw c
init-url (make-editor/follow-redirections html-editor%
progress tlw
post-data init-url
remap-url)))))] (lambda (v)
(channel-put progs v))
post-data
remap-url))))))]
[ans #f]) [ans #f])
(yield (let loop ()
(choice-evt (yield
(handle-evt c (lambda (x) (set! ans x))) (choice-evt
(handle-evt (thread-dead-evt t) (handle-evt c (lambda (x) (set! ans x)))
(lambda (_) (handle-evt progs (lambda (v)
(let ([t (new hyper-text% (set! sent-prog? #t)
(url #f) (progress v)
(top-level-window tlw) (loop)))
(progress void))]) (handle-evt (thread-dead-evt t)
(send t insert "Stopped.") (lambda (_)
(set! ans (cons t #f))))))) (let ([t (new hyper-text%
(url #f)
(top-level-window tlw)
(progress void))])
(send t insert "Stopped.")
(set! ans (cons t #f))))))))
(unless sent-prog?
(progress #f))
ans)) ans))
;; make-editor/follow-redirections : editor-class frame%-instance ;; make-editor/follow-redirections : editor-class frame%-instance
@ -873,6 +915,7 @@ A test case:
(cond (cond
[on? [on?
(send stop-button enable #f) (send stop-button enable #f)
(when choice (send choice enable #t))
(update-buttons)] (update-buttons)]
[else [else
(send stop-button enable #t) (send stop-button enable #t)