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

fixed up handling of downloaded files

Browse Source 
svn: r1461
This commit is contained in:
Robby Findler 2005-12-01 18:58:25 +00:00
parent e3375a3c5c
commit b50dea350d
1 changed files with 86 additions and 80 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -56,6 +56,7 @@ A test case:
(define-struct (exn:file-saved-instead exn) (pathname)) (define-struct (exn:file-saved-instead exn) (pathname))
(define-struct (exn:cancelled exn) ()) (define-struct (exn:cancelled exn) ())
(define-struct (exn:tcp-problem exn) ())
(define history-limit 20) (define history-limit 20)
@ -144,15 +145,7 @@ A test case:
(opt-lambda (url-string [post-data #f]) (opt-lambda (url-string [post-data #f])
(on-url-click (on-url-click
(lambda (url-string post-data) (lambda (url-string post-data)
(with-handlers ([(lambda (x) #t) (send (get-canvas) goto-url url-string (get-url) void post-data))
(lambda (x)
(unless (or (exn:break? x)
(exn:file-saved-instead? x)
(exn:cancelled? x))
((error-display-handler)
(if (exn? x) (exn-message x) (format "~s" x))
x)))])
(send (get-canvas) goto-url url-string (get-url) void post-data)))
url-string url-string
post-data))) post-data)))
@ -310,7 +303,6 @@ A test case:
[(or (and mime-type (regexp-match #rx"application/" mime-type)) [(or (and mime-type (regexp-match #rx"application/" mime-type))
(and (url? url) (and (url? url)
(not (null? (url-path url))) (not (null? (url-path url)))
(regexp-match "[.]plt$" (car (last-pair (url-path url))))
; document-not-found produces HTML: ; document-not-found produces HTML:
(not html?))) (not html?)))
; Save the file ; Save the file
@ -416,7 +408,9 @@ A test case:
; Let thread run only after the dialog is shown ; Let thread run only after the dialog is shown
(queue-callback (lambda () (semaphore-post wait-to-start))) (queue-callback (lambda () (semaphore-post wait-to-start)))
(send d show #t) (send d show #t)
(when exn (raise exn))) (when exn
(raise (make-exn:tcp-problem (exn-message exn)
(current-continuation-marks)))))
(let ([sema (make-semaphore 0)]) (let ([sema (make-semaphore 0)])
(when (and tmp-plt-filename install?) (when (and tmp-plt-filename install?)
(run-installer tmp-plt-filename (run-installer tmp-plt-filename
@ -651,46 +645,53 @@ A test case:
(let ([tlw (get-top-level-window)]) (let ([tlw (get-top-level-window)])
(when (and tlw (when (and tlw
(is-a? tlw hyper-frame<%>)) (is-a? tlw hyper-frame<%>))
(let ([pre-url (cond (let* ([pre-url (cond
[(url? in-url) in-url] [(url? in-url) in-url]
[(port? in-url) in-url] [(port? in-url) in-url]
[(string? in-url) [(string? in-url)
(if relative (if relative
(combine-url/relative relative in-url) (combine-url/relative relative in-url)
(string->url in-url))] (string->url in-url))]
[else (error 'goto-url "unknown url ~e\n" in-url)])] [else (error 'goto-url "unknown url ~e\n" in-url)])]
[killable-cust (make-custodian)] [killable-cust (make-custodian)]
[hyper-panel (send tlw get-hyper-panel)]) [hyper-panel (send tlw get-hyper-panel)]
(let-values ([(e url) [result
(let ([e-now (get-editor)]) (let ([e-now (get-editor)])
(cond (cond
[(and e-now [(and e-now
(not post-data) (not post-data)
(same-page-url? pre-url (send e-now get-url))) (same-page-url? pre-url (send e-now get-url)))
(progress #t) (progress #t)
(values e-now pre-url)] (cons e-now pre-url)]
[else [else
(send hyper-panel set-stop-callback (send hyper-panel set-stop-callback
(lambda () (lambda ()
(custodian-shutdown-all killable-cust))) (custodian-shutdown-all killable-cust)))
(send hyper-panel enable-browsing #f) (send hyper-panel enable-browsing #f)
(begin0 (begin0
(make-editor/setup-kill killable-cust (make-editor/setup-kill killable-cust
(get-editor%) (get-editor%)
tlw tlw
pre-url pre-url
progress progress
post-data post-data
(lambda (x) (remap-url x))) (lambda (x) (remap-url x)))
(send hyper-panel set-stop-callback void) (send hyper-panel set-stop-callback void)
(send hyper-panel enable-browsing #t))]))]) (send hyper-panel enable-browsing #t))]))])
(when e (cond
(let* ([tag-pos (send e find-tag (and (url? url) (url-fragment url)))]) [(pair? result)
(let* ([e (car result)]
(unless (and tag-pos (positive? tag-pos)) [url (cdr result)]
(send e hide-caret #t)) [tag-pos (send e find-tag (and (url? url) (url-fragment url)))])
(set-page (list e (or tag-pos 0) (send e last-position)) #t) (unless (and tag-pos (positive? tag-pos))
(when tag-pos (send e set-position tag-pos)))))))))) (send e hide-caret #t))
(set-page (list e (or tag-pos 0) (send e last-position)) #t)
(when tag-pos (send e set-position tag-pos)))]
[(exn? result)
(message-box (string-constant drscheme)
(exn-message result)
tlw)]
[else (void)]))))))
;; remap-url : url? -> (union #f url?) ;; remap-url : url? -> (union #f url?)
;; this method is intended to be overridden so that derived classes can change ;; this method is intended to be overridden so that derived classes can change
@ -724,7 +725,7 @@ A test case:
;; make-editor/setup-kill : custodian editor-class frame%-instance ;; make-editor/setup-kill : custodian editor-class frame%-instance
;; url (boolean??? -> void) ??? (url -> (union port #f url)) ;; url (boolean??? -> void) ??? (url -> (union port #f url))
;; -> (values (union #f editor) (union #f url)) ;; -> (union (cons editor (union #f url)) exn #f)
;; 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)]
@ -751,7 +752,7 @@ A test case:
(progress void))]) (progress void))])
(send t insert "Stopped.") (send t insert "Stopped.")
(set! ans (cons t #f))))))) (set! ans (cons t #f)))))))
(values (car ans) (cdr ans)))) ans))
;; make-editor/follow-redirections : editor-class frame%-instance ;; make-editor/follow-redirections : editor-class frame%-instance
;; url (boolean??? -> void) ??? (url -> (union port #f url)) ;; url (boolean??? -> void) ??? (url -> (union port #f url))
@ -760,33 +761,38 @@ A test case:
;; but stops after 10 redirections (just in case there are too many ;; but stops after 10 redirections (just in case there are too many
;; of these things, give the user a chance to stop) ;; of these things, give the user a chance to stop)
(define (make-editor/follow-redirections html-editor% tlw init-url progress post-data remap-url) (define (make-editor/follow-redirections html-editor% tlw init-url progress post-data remap-url)
(let loop ([n 10] (with-handlers ([(lambda (x)
[unmapped-url init-url]) (or (exn:file-saved-instead? x)
(let ([url (if (url? unmapped-url) (exn:cancelled? x)
(let ([rurl (remap-url unmapped-url)]) (exn:tcp-problem? x)))
(unless (or (url? rurl) values])
(input-port? rurl) (let loop ([n 10]
(not rurl)) [unmapped-url init-url])
(error 'remap-url (let ([url (if (url? unmapped-url)
"expected a url struct, an input-port, or #f, got ~e" (let ([rurl (remap-url unmapped-url)])
rurl)) (unless (or (url? rurl)
rurl) (input-port? rurl)
unmapped-url)]) (not rurl))
(if url (error 'remap-url
(let ([html-editor (new html-editor% "expected a url struct, an input-port, or #f, got ~e"
[url url] rurl))
[top-level-window tlw] rurl)
[progress progress] unmapped-url)])
[post-data post-data])]) (if url
(cond (let ([html-editor (new html-editor%
[(zero? n) [url url]
(cons html-editor url)] [top-level-window tlw]
[(send html-editor get-redirection) [progress progress]
=> [post-data post-data])])
(lambda (new-url) (loop (- n 1) new-url))] (cond
[else [(zero? n)
(cons html-editor url)])) (cons html-editor url)]
(cons #f #f))))) [(send html-editor get-redirection)
=>
(lambda (new-url) (loop (- n 1) new-url))]
[else
(cons html-editor url)]))
(cons #f #f))))))
(define hyper-canvas% (hyper-canvas-mixin canvas:basic%)) (define hyper-canvas% (hyper-canvas-mixin canvas:basic%))