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

reformatting etc

Browse Source 
svn: r6199
This commit is contained in:
Eli Barzilay 2007-05-11 05:47:00 +00:00
parent 091e7c0673
commit 09f09289e2
1 changed files with 209 additions and 215 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

400
collects/browser/external.ss
View File

@ -11,13 +11,12 @@
(provide send-url (provide send-url
(rename raw:browser-preference? browser-preference?) (rename raw:browser-preference? browser-preference?)
update-browser-preference update-browser-preference
install-help-browser-preference-panel install-help-browser-preference-panel
add-to-browser-prefs-panel) add-to-browser-prefs-panel)
; : -> bool ; : -> bool
(define (unix-browser?) (define (unix-browser?)
(and (eq? (system-type) 'unix) (eq? (system-type) 'unix))
(not (equal? "ppc-darwin" (system-library-subpath)))))
(fw:preferences:set-default (fw:preferences:set-default
'external-browser 'external-browser
@ -41,14 +40,10 @@
(let* ([ops (current-proxy-servers)] (let* ([ops (current-proxy-servers)]
[removed (remove-all-proxies "http" ops)]) [removed (remove-all-proxies "http" ops)])
(current-proxy-servers (current-proxy-servers
(if pref-val (if pref-val (cons pref-val removed) removed))))
(cons pref-val removed)
removed))))
(define (remove-all-proxies scheme proxies) (define (remove-all-proxies scheme proxies)
(filter (lambda (x) (filter (lambda (x) (and (pair? x) (not (equal? (car x) scheme))))
(and (pair? x)
(not (equal? (car x) scheme))))
proxies)) proxies))
(fw:preferences:set-default http-proxy-preference #f proxy-pref?) (fw:preferences:set-default http-proxy-preference #f proxy-pref?)
@ -57,18 +52,18 @@
(define send-url (define send-url
(if (unix-browser?) (if (unix-browser?)
(lambda (url . args) (lambda (url . args)
(when (or (get-preference 'external-browser (lambda () #f)) (when (or (get-preference 'external-browser (lambda () #f))
;; either the preference doesn't exist or is #f ;; either the preference doesn't exist or is #f
(update-browser-preference url)) (update-browser-preference url))
(apply raw:send-url url args))) (apply raw:send-url url args)))
raw:send-url)) raw:send-url))
; : str -> void ; : str -> void
; to prompt the user for a browser preference and update the preference ; to prompt the user for a browser preference and update the preference
(define (update-browser-preference url) (define (update-browser-preference url)
(or (not (unix-browser?)) (or (not (unix-browser?))
(choose-browser url))) (choose-browser url)))
; : (U symbol #f) -> void ; : (U symbol #f) -> void
; to set the default browser ; to set the default browser
@ -80,16 +75,16 @@
(define (try-put-preferences names vals) (define (try-put-preferences names vals)
(let loop ([tries 0]) (let loop ([tries 0])
(unless (= tries 3) (unless (= tries 3)
(put-preferences names vals (put-preferences names vals
(lambda (lock-file) (lambda (lock-file)
(sleep 0.2) (sleep 0.2)
(loop (add1 tries))))))) (loop (add1 tries)))))))
(define unix-browser-names (define unix-browser-names
(map (lambda (s) (map (lambda (s)
(let ([l (string->list (symbol->string s))]) (let ([l (string->list (symbol->string s))])
(list->string (cons (char-upcase (car l)) (cdr l))))) (list->string (cons (char-upcase (car l)) (cdr l)))))
raw:unix-browser-list)) raw:unix-browser-list))
;; : (U str #f) -> (U symbol #f) ;; : (U str #f) -> (U symbol #f)
;; to prompt the user for a browser preference ;; to prompt the user for a browser preference
@ -100,35 +95,35 @@
(let* ([title (string-constant choose-browser)] (let* ([title (string-constant choose-browser)]
[d (make-object dialog% title)] [d (make-object dialog% title)]
[main-pane (make-object vertical-pane% d)] [main-pane (make-object vertical-pane% d)]
[internal-ok? (not url)] [internal-ok? (not url)]
[ok? #f] [ok? #f]
[orig-external (fw:preferences:get 'external-browser)]) [orig-external (fw:preferences:get 'external-browser)])
(make-object message% title main-pane) (make-object message% title main-pane)
;; No need to show the URL (it can be very long) ;; No need to show the URL (it can be very long)
;; (when url ;; (when url
;; (make-object message% (format "URL: ~a" url) main-pane)) ;; (make-object message% (format "URL: ~a" url) main-pane))
(let-values ([(panel callbacks) (make-help-browser-preference-panel internal-ok? #f (lambda (f) (f main-pane)))]) (let-values ([(panel callbacks) (make-help-browser-preference-panel internal-ok? #f (lambda (f) (f main-pane)))])
(let*-values ([(button-pane) (instantiate horizontal-panel% (main-pane) (let*-values ([(button-pane) (instantiate horizontal-panel% (main-pane)
(alignment '(right center)))] (alignment '(right center)))]
[(ok-button cancel-button) [(ok-button cancel-button)
(fw:gui-utils:ok/cancel-buttons (fw:gui-utils:ok/cancel-buttons
button-pane button-pane
(lambda (b e) (set! ok? #t) (send d show #f)) (lambda (b e) (set! ok? #t) (send d show #f))
(lambda (b e) (lambda (b e)
(fw:preferences:set 'external-browser orig-external) (fw:preferences:set 'external-browser orig-external)
(send d show #f)))] (send d show #f)))]
[(enable-button) (lambda (_n _v) [(enable-button) (lambda (_n _v)
(queue-callback (queue-callback
(lambda () (lambda ()
(send ok-button enable (fw:preferences:get 'external-browser)))))]) (send ok-button enable (fw:preferences:get 'external-browser)))))])
(send ok-button enable #f) (send ok-button enable #f)
(set! callbacks (set! callbacks
(cons (cons
(fw:preferences:add-callback 'external-browser enable-button) (fw:preferences:add-callback 'external-browser enable-button)
callbacks))) callbacks)))
(send d show #t) (send d show #t)
(map (lambda (f) (f)) callbacks) (map (lambda (f) (f)) callbacks)
ok?))) ok?)))
(define panel-installed? #f) (define panel-installed? #f)
(define prefs-panel #f) (define prefs-panel #f)
@ -141,176 +136,175 @@
(make-help-browser-preference-panel (make-help-browser-preference-panel
#t #t #t #t
(lambda (f) (fw:preferences:add-panel (lambda (f) (fw:preferences:add-panel
(string-constant browser) (string-constant browser)
(lambda (parent) (lambda (parent)
(let-values ([(panel cbs) (f parent)]) (let-values ([(panel cbs) (f parent)])
(set! prefs-panel panel) (set! prefs-panel panel)
(map (lambda (f) (f panel)) additions) (map (lambda (f) (f panel)) additions)
(set! additions null) (set! additions null)
panel))))))) panel)))))))
(define (add-to-browser-prefs-panel proc) (define (add-to-browser-prefs-panel proc)
(if prefs-panel (if prefs-panel
(proc prefs-panel) (proc prefs-panel)
(set! additions (append additions (list proc))))) (set! additions (append additions (list proc)))))
(define (make-help-browser-preference-panel set-help? ask-later? mk) (define (make-help-browser-preference-panel set-help? ask-later? mk)
(mk (mk
(lambda (parent) (lambda (parent)
(define callbacks null) (define callbacks null)
(let ([pref-panel (instantiate vertical-panel% () (let ([pref-panel (instantiate vertical-panel% ()
(parent parent) (alignment '(left center)))]) [parent parent]
[alignment '(left center)])])
;; -------------------- external browser for Unix -------------------- ;; -------------------- external browser for Unix --------------------
(when (unix-browser?) (when (unix-browser?)
(unless synchronized? (unless synchronized?
;; Keep 'external-browser in sync ;; Keep 'external-browser in sync
(fw:preferences:add-callback 'external-browser (fw:preferences:add-callback 'external-browser
(lambda (name browser) (lambda (name browser)
(try-put-preferences (list 'external-browser) (list browser))))) (try-put-preferences (list 'external-browser) (list browser)))))
(letrec ([v-panel (instantiate group-box-panel% () (letrec ([v-panel (instantiate group-box-panel% ()
(parent pref-panel) (parent pref-panel)
(alignment '(right center)) (alignment '(right center))
(stretchable-height #f) (stretchable-height #f)
(label (string-constant external-browser-choice-title)))] (label (string-constant external-browser-choice-title)))]
[h-panel (instantiate horizontal-panel% () [h-panel (instantiate horizontal-panel% ()
(parent v-panel) (parent v-panel)
(alignment '(center bottom)))] (alignment '(center bottom)))]
[none-index (length raw:unix-browser-list)] [none-index (length raw:unix-browser-list)]
[custom-index (add1 none-index)] [custom-index (add1 none-index)]
[r (instantiate radio-box% () [r (instantiate radio-box% ()
(label #f) (label #f)
(choices (append unix-browser-names (choices (append unix-browser-names
(list (string-constant no-browser) (list (string-constant no-browser)
(string-constant browser-command-line-label)))) (string-constant browser-command-line-label))))
(parent h-panel) (parent h-panel)
(callback (callback
(lambda (radio event) (lambda (radio event)
(let ([n (send radio get-selection)]) (let ([n (send radio get-selection)])
(set-browser! (set-browser!
(cond (cond
[(= n none-index) #f] [(= n none-index) #f]
[(= n custom-index) (get-custom)] [(= n custom-index) (get-custom)]
[else (list-ref raw:unix-browser-list n)]))))))] [else (list-ref raw:unix-browser-list n)]))))))]
[select-custom [select-custom
(lambda (_ __) (lambda (_ __)
(send r set-selection custom-index) (send r set-selection custom-index)
(set-browser! (get-custom)))] (set-browser! (get-custom)))]
[get-custom [get-custom
(lambda () (cons (send pre get-value) (send post get-value)))] (lambda () (cons (send pre get-value) (send post get-value)))]
[template-panel (instantiate horizontal-panel% (h-panel) [template-panel (instantiate horizontal-panel% (h-panel)
(spacing 0) (spacing 0)
(stretchable-height #f))] (stretchable-height #f))]
[pre (instantiate text-field% () [pre (instantiate text-field% ()
(label #f) (parent template-panel) (callback select-custom) (label #f) (parent template-panel) (callback select-custom)
(horiz-margin 0))] (horiz-margin 0))]
[mess (instantiate message% () (label "<URL>") (parent template-panel) [mess (instantiate message% () (label "<URL>") (parent template-panel)
(horiz-margin 0))] (horiz-margin 0))]
[post (instantiate text-field% () [post (instantiate text-field% ()
(label #f) (parent template-panel) (callback select-custom) (label #f) (parent template-panel) (callback select-custom)
(horiz-margin 0))] (horiz-margin 0))]
[note1 (instantiate message% ((string-constant browser-cmdline-expl-line-1) [note1 (instantiate message% ((string-constant browser-cmdline-expl-line-1)
v-panel))] v-panel))]
[note2 (instantiate message% ((string-constant browser-cmdline-expl-line-2) [note2 (instantiate message% ((string-constant browser-cmdline-expl-line-2)
v-panel))] v-panel))]
[refresh-controls (lambda (pref) [refresh-controls (lambda (pref)
(if (pair? pref) (if (pair? pref)
(begin (begin
(send r set-selection custom-index) (send r set-selection custom-index)
(send pre set-value (car pref)) (send pre set-value (car pref))
(send post set-value (cdr pref))) (send post set-value (cdr pref)))
(let init ([x raw:unix-browser-list] [n 0]) (let init ([x raw:unix-browser-list] [n 0])
(cond (cond
[(null? x) (send r set-selection n)] [(null? x) (send r set-selection n)]
[else (if (eq? pref (car x)) [else (if (eq? pref (car x))
(send r set-selection n) (send r set-selection n)
(init (cdr x) (add1 n)))]))))]) (init (cdr x) (add1 n)))]))))])
(unless ask-later? (unless ask-later?
(send r enable none-index #f)) (send r enable none-index #f))
(refresh-controls (fw:preferences:get 'external-browser)) (refresh-controls (fw:preferences:get 'external-browser))
(set! callbacks (set! callbacks
(cons (cons (fw:preferences:add-callback 'external-browser
(fw:preferences:add-callback 'external-browser (lambda (name browser) (refresh-controls browser)))
(lambda (name browser) callbacks))
(refresh-controls browser)))
callbacks))
(let disable ([x raw:unix-browser-list] [n 0]) (let disable ([x raw:unix-browser-list] [n 0])
(cond (cond
[(null? x) (void)] [(null? x) (void)]
[else (unless (find-executable-path (symbol->string (car x)) #f) [else (unless (find-executable-path
(send r enable n #f)) (symbol->string (car x)) #f)
(disable (cdr x) (add1 n))])))) (send r enable n #f))
(disable (cdr x) (add1 n))]))))
;; -------------------- proxy for doc downloads -------------------- ;; -------------------- proxy for doc downloads --------------------
(when set-help? (when set-help?
(letrec ([p (instantiate group-box-panel% () (letrec ([p (instantiate group-box-panel% ()
(label (string-constant http-proxy)) [label (string-constant http-proxy)]
(parent pref-panel) [parent pref-panel]
(stretchable-height #f) [stretchable-height #f]
(alignment '(left top)))] [alignment '(left top)])]
[rb (make-object radio-box% [rb (make-object radio-box%
#f (list (string-constant proxy-direct-connection) #f (list (string-constant proxy-direct-connection)
(string-constant proxy-use-proxy)) (string-constant proxy-use-proxy))
p p
(lambda (r e) (lambda (r e)
(let ([proxy? (= 1 (send r get-selection))]) (let ([proxy? (= 1 (send r get-selection))])
(send proxy-spec enable proxy?) (send proxy-spec enable proxy?)
(if proxy? (if proxy?
(update-proxy) (update-proxy)
(fw:preferences:set http-proxy-preference #f)))))] (fw:preferences:set http-proxy-preference #f)))))]
[proxy-spec (instantiate horizontal-panel% (p) [proxy-spec (instantiate horizontal-panel% (p)
[stretchable-width #f] [stretchable-width #f]
[stretchable-height #f] [stretchable-height #f]
[alignment '(left center)])] [alignment '(left center)])]
[update-proxy (lambda () [update-proxy (lambda ()
(let ([host (send host get-value)] (let ([host (send host get-value)]
[port (send port get-value)]) [port (send port get-value)])
(let ([ok? (and (regexp-match "^[-0-9a-zA-Z.]+$" host) (let ([ok? (and (regexp-match? #rx"^[-0-9a-zA-Z.]+$" host)
(regexp-match "^[0-9]+$" port) (regexp-match? #rx"^[0-9]+$" port)
(string->number port) (string->number port)
(<= 1 (string->number port) 65535))]) (<= 1 (string->number port) 65535))])
(when ok? (when ok?
(fw:preferences:set (fw:preferences:set
http-proxy-preference http-proxy-preference
(list "http" host (string->number port)))) (list "http" host (string->number port))))
(send bad-host show (not ok?)))))] (send bad-host show (not ok?)))))]
[host (make-object text-field% [host (make-object text-field%
(string-constant proxy-host) (string-constant proxy-host)
proxy-spec (lambda (x y) (update-proxy)) proxy-spec (lambda (x y) (update-proxy))
"www.someplacethatisaproxy.domain.comm")] "www.someplacethatisaproxy.domain.com")]
[port (make-object text-field% [port (make-object text-field%
(string-constant proxy-port) (string-constant proxy-port)
proxy-spec (lambda (x y) (update-proxy)) "65535")] proxy-spec (lambda (x y) (update-proxy)) "65535")]
[bad-host (make-object message% [bad-host (make-object message%
(string-constant proxy-bad-host) (string-constant proxy-bad-host)
p)] p)]
[update-gui [update-gui
(lambda (proxy-val) (lambda (proxy-val)
(send bad-host show #f) (send bad-host show #f)
(if proxy-val (if proxy-val
(begin (begin
(send rb set-selection 1) (send rb set-selection 1)
(send proxy-spec enable #t) (send proxy-spec enable #t)
(unless (string=? (cadr proxy-val) (send host get-value)) (unless (string=? (cadr proxy-val) (send host get-value))
(send host set-value (cadr proxy-val))) (send host set-value (cadr proxy-val)))
(unless (equal? (caddr proxy-val) (string->number (send port get-value))) (unless (equal? (caddr proxy-val) (string->number (send port get-value)))
(send port set-value (number->string (caddr proxy-val))))) (send port set-value (number->string (caddr proxy-val)))))
(begin (begin
(send rb set-selection 0) (send rb set-selection 0)
(send proxy-spec enable #f) (send proxy-spec enable #f)
(send host set-value "") (send host set-value "")
(send port set-value ""))))]) (send port set-value ""))))])
(fw:preferences:add-callback http-proxy-preference (fw:preferences:add-callback http-proxy-preference
(lambda (name val) (lambda (name val)
(update-gui val))) (update-gui val)))
(update-gui (fw:preferences:get http-proxy-preference)) (update-gui (fw:preferences:get http-proxy-preference))
(send bad-host show #f))) (send bad-host show #f)))
(set! synchronized? #t) (set! synchronized? #t)
(values pref-panel callbacks)))))) (values pref-panel callbacks))))))