From 09f09289e24f0a566aeb85879e24fc6cbb2631fc Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 11 May 2007 05:47:00 +0000 Subject: [PATCH] reformatting etc svn: r6199 --- collects/browser/external.ss | 424 +++++++++++++++++------------------ 1 file changed, 209 insertions(+), 215 deletions(-) diff --git a/collects/browser/external.ss b/collects/browser/external.ss index 91b4cbc78e..9a6124cdef 100644 --- a/collects/browser/external.ss +++ b/collects/browser/external.ss @@ -11,19 +11,18 @@ (provide send-url (rename raw:browser-preference? browser-preference?) update-browser-preference - install-help-browser-preference-panel - add-to-browser-prefs-panel) - + install-help-browser-preference-panel + add-to-browser-prefs-panel) + ; : -> bool (define (unix-browser?) - (and (eq? (system-type) 'unix) - (not (equal? "ppc-darwin" (system-library-subpath))))) - + (eq? (system-type) 'unix)) + (fw:preferences:set-default 'external-browser (get-preference 'external-browser (lambda () #f)) raw:browser-preference?) - + (define http-proxy-preference 'plt:http-proxy) ;; proxy-pref? : any -> boolean @@ -34,62 +33,58 @@ [#f #t] [`("http" ,(? string?) ,(? number?)) #t] [else #f])) - + ;; sync-current-proxy-servers : proxy-pref -> void ;; syncs current-proxy-servers parameter with the proxy-pref-val (define (sync-current-proxy-servers pref-val) (let* ([ops (current-proxy-servers)] [removed (remove-all-proxies "http" ops)]) (current-proxy-servers - (if pref-val - (cons pref-val removed) - removed)))) + (if pref-val (cons pref-val removed) removed)))) (define (remove-all-proxies scheme proxies) - (filter (lambda (x) - (and (pair? x) - (not (equal? (car x) scheme)))) + (filter (lambda (x) (and (pair? x) (not (equal? (car x) scheme)))) proxies)) - + (fw:preferences:set-default http-proxy-preference #f proxy-pref?) (sync-current-proxy-servers (fw:preferences:get http-proxy-preference)) (fw:preferences:add-callback http-proxy-preference (lambda (p v) (sync-current-proxy-servers v))) - + (define send-url (if (unix-browser?) - (lambda (url . args) - (when (or (get-preference 'external-browser (lambda () #f)) - ;; either the preference doesn't exist or is #f - (update-browser-preference url)) - (apply raw:send-url url args))) - raw:send-url)) - + (lambda (url . args) + (when (or (get-preference 'external-browser (lambda () #f)) + ;; either the preference doesn't exist or is #f + (update-browser-preference url)) + (apply raw:send-url url args))) + raw:send-url)) + ; : str -> void ; to prompt the user for a browser preference and update the preference (define (update-browser-preference url) (or (not (unix-browser?)) - (choose-browser url))) - + (choose-browser url))) + ; : (U symbol #f) -> void ; to set the default browser (define (set-browser! browser) (fw:preferences:set 'external-browser browser)) - + ;; Tries to put low-level prefs three times, sleeping a bit in ;; between, then gives up. (define (try-put-preferences names vals) (let loop ([tries 0]) (unless (= tries 3) - (put-preferences names vals - (lambda (lock-file) - (sleep 0.2) - (loop (add1 tries))))))) + (put-preferences names vals + (lambda (lock-file) + (sleep 0.2) + (loop (add1 tries))))))) (define unix-browser-names (map (lambda (s) - (let ([l (string->list (symbol->string s))]) - (list->string (cons (char-upcase (car l)) (cdr l))))) - raw:unix-browser-list)) + (let ([l (string->list (symbol->string s))]) + (list->string (cons (char-upcase (car l)) (cdr l))))) + raw:unix-browser-list)) ;; : (U str #f) -> (U symbol #f) ;; to prompt the user for a browser preference @@ -100,36 +95,36 @@ (let* ([title (string-constant choose-browser)] [d (make-object dialog% title)] [main-pane (make-object vertical-pane% d)] - [internal-ok? (not url)] + [internal-ok? (not url)] [ok? #f] - [orig-external (fw:preferences:get 'external-browser)]) + [orig-external (fw:preferences:get 'external-browser)]) (make-object message% title main-pane) ;; No need to show the URL (it can be very long) ;; (when url ;; (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 ([(button-pane) (instantiate horizontal-panel% (main-pane) - (alignment '(right center)))] - [(ok-button cancel-button) - (fw:gui-utils:ok/cancel-buttons - button-pane - (lambda (b e) (set! ok? #t) (send d show #f)) - (lambda (b e) - (fw:preferences:set 'external-browser orig-external) - (send d show #f)))] - [(enable-button) (lambda (_n _v) - (queue-callback - (lambda () - (send ok-button enable (fw:preferences:get 'external-browser)))))]) - (send ok-button enable #f) - (set! callbacks - (cons - (fw:preferences:add-callback 'external-browser enable-button) - callbacks))) - (send d show #t) - (map (lambda (f) (f)) callbacks) - ok?))) - + (let*-values ([(button-pane) (instantiate horizontal-panel% (main-pane) + (alignment '(right center)))] + [(ok-button cancel-button) + (fw:gui-utils:ok/cancel-buttons + button-pane + (lambda (b e) (set! ok? #t) (send d show #f)) + (lambda (b e) + (fw:preferences:set 'external-browser orig-external) + (send d show #f)))] + [(enable-button) (lambda (_n _v) + (queue-callback + (lambda () + (send ok-button enable (fw:preferences:get 'external-browser)))))]) + (send ok-button enable #f) + (set! callbacks + (cons + (fw:preferences:add-callback 'external-browser enable-button) + callbacks))) + (send d show #t) + (map (lambda (f) (f)) callbacks) + ok?))) + (define panel-installed? #f) (define prefs-panel #f) (define synchronized? #f) @@ -141,176 +136,175 @@ (make-help-browser-preference-panel #t #t (lambda (f) (fw:preferences:add-panel - (string-constant browser) - (lambda (parent) - (let-values ([(panel cbs) (f parent)]) - (set! prefs-panel panel) - (map (lambda (f) (f panel)) additions) - (set! additions null) - panel))))))) + (string-constant browser) + (lambda (parent) + (let-values ([(panel cbs) (f parent)]) + (set! prefs-panel panel) + (map (lambda (f) (f panel)) additions) + (set! additions null) + panel))))))) (define (add-to-browser-prefs-panel proc) (if prefs-panel - (proc prefs-panel) - (set! additions (append additions (list proc))))) - + (proc prefs-panel) + (set! additions (append additions (list proc))))) + (define (make-help-browser-preference-panel set-help? ask-later? mk) - (mk (lambda (parent) (define callbacks null) (let ([pref-panel (instantiate vertical-panel% () - (parent parent) (alignment '(left center)))]) + [parent parent] + [alignment '(left center)])]) - ;; -------------------- external browser for Unix -------------------- - (when (unix-browser?) - (unless synchronized? - ;; Keep 'external-browser in sync - (fw:preferences:add-callback 'external-browser - (lambda (name browser) - (try-put-preferences (list 'external-browser) (list browser))))) + ;; -------------------- external browser for Unix -------------------- + (when (unix-browser?) + (unless synchronized? + ;; Keep 'external-browser in sync + (fw:preferences:add-callback 'external-browser + (lambda (name browser) + (try-put-preferences (list 'external-browser) (list browser))))) - (letrec ([v-panel (instantiate group-box-panel% () - (parent pref-panel) - (alignment '(right center)) - (stretchable-height #f) - (label (string-constant external-browser-choice-title)))] - [h-panel (instantiate horizontal-panel% () - (parent v-panel) - (alignment '(center bottom)))] - [none-index (length raw:unix-browser-list)] - [custom-index (add1 none-index)] - [r (instantiate radio-box% () - (label #f) - (choices (append unix-browser-names - (list (string-constant no-browser) - (string-constant browser-command-line-label)))) - (parent h-panel) - (callback - (lambda (radio event) - (let ([n (send radio get-selection)]) - (set-browser! - (cond - [(= n none-index) #f] - [(= n custom-index) (get-custom)] - [else (list-ref raw:unix-browser-list n)]))))))] - [select-custom - (lambda (_ __) - (send r set-selection custom-index) - (set-browser! (get-custom)))] - [get-custom - (lambda () (cons (send pre get-value) (send post get-value)))] - [template-panel (instantiate horizontal-panel% (h-panel) - (spacing 0) - (stretchable-height #f))] - [pre (instantiate text-field% () - (label #f) (parent template-panel) (callback select-custom) - (horiz-margin 0))] - [mess (instantiate message% () (label "") (parent template-panel) - (horiz-margin 0))] - [post (instantiate text-field% () - (label #f) (parent template-panel) (callback select-custom) - (horiz-margin 0))] - [note1 (instantiate message% ((string-constant browser-cmdline-expl-line-1) - v-panel))] - [note2 (instantiate message% ((string-constant browser-cmdline-expl-line-2) - v-panel))] - [refresh-controls (lambda (pref) - (if (pair? pref) - (begin - (send r set-selection custom-index) - (send pre set-value (car pref)) - (send post set-value (cdr pref))) - (let init ([x raw:unix-browser-list] [n 0]) - (cond - [(null? x) (send r set-selection n)] - [else (if (eq? pref (car x)) - (send r set-selection n) - (init (cdr x) (add1 n)))]))))]) + (letrec ([v-panel (instantiate group-box-panel% () + (parent pref-panel) + (alignment '(right center)) + (stretchable-height #f) + (label (string-constant external-browser-choice-title)))] + [h-panel (instantiate horizontal-panel% () + (parent v-panel) + (alignment '(center bottom)))] + [none-index (length raw:unix-browser-list)] + [custom-index (add1 none-index)] + [r (instantiate radio-box% () + (label #f) + (choices (append unix-browser-names + (list (string-constant no-browser) + (string-constant browser-command-line-label)))) + (parent h-panel) + (callback + (lambda (radio event) + (let ([n (send radio get-selection)]) + (set-browser! + (cond + [(= n none-index) #f] + [(= n custom-index) (get-custom)] + [else (list-ref raw:unix-browser-list n)]))))))] + [select-custom + (lambda (_ __) + (send r set-selection custom-index) + (set-browser! (get-custom)))] + [get-custom + (lambda () (cons (send pre get-value) (send post get-value)))] + [template-panel (instantiate horizontal-panel% (h-panel) + (spacing 0) + (stretchable-height #f))] + [pre (instantiate text-field% () + (label #f) (parent template-panel) (callback select-custom) + (horiz-margin 0))] + [mess (instantiate message% () (label "") (parent template-panel) + (horiz-margin 0))] + [post (instantiate text-field% () + (label #f) (parent template-panel) (callback select-custom) + (horiz-margin 0))] + [note1 (instantiate message% ((string-constant browser-cmdline-expl-line-1) + v-panel))] + [note2 (instantiate message% ((string-constant browser-cmdline-expl-line-2) + v-panel))] + [refresh-controls (lambda (pref) + (if (pair? pref) + (begin + (send r set-selection custom-index) + (send pre set-value (car pref)) + (send post set-value (cdr pref))) + (let init ([x raw:unix-browser-list] [n 0]) + (cond + [(null? x) (send r set-selection n)] + [else (if (eq? pref (car x)) + (send r set-selection n) + (init (cdr x) (add1 n)))]))))]) - (unless ask-later? - (send r enable none-index #f)) + (unless ask-later? + (send r enable none-index #f)) - (refresh-controls (fw:preferences:get 'external-browser)) - (set! callbacks - (cons - (fw:preferences:add-callback 'external-browser - (lambda (name browser) - (refresh-controls browser))) - callbacks)) + (refresh-controls (fw:preferences:get 'external-browser)) + (set! callbacks + (cons (fw:preferences:add-callback 'external-browser + (lambda (name browser) (refresh-controls browser))) + callbacks)) - (let disable ([x raw:unix-browser-list] [n 0]) - (cond - [(null? x) (void)] - [else (unless (find-executable-path (symbol->string (car x)) #f) - (send r enable n #f)) - (disable (cdr x) (add1 n))])))) + (let disable ([x raw:unix-browser-list] [n 0]) + (cond + [(null? x) (void)] + [else (unless (find-executable-path + (symbol->string (car x)) #f) + (send r enable n #f)) + (disable (cdr x) (add1 n))])))) - ;; -------------------- proxy for doc downloads -------------------- - (when set-help? - (letrec ([p (instantiate group-box-panel% () - (label (string-constant http-proxy)) - (parent pref-panel) - (stretchable-height #f) - (alignment '(left top)))] - [rb (make-object radio-box% - #f (list (string-constant proxy-direct-connection) - (string-constant proxy-use-proxy)) - p - (lambda (r e) - (let ([proxy? (= 1 (send r get-selection))]) - (send proxy-spec enable proxy?) - (if proxy? - (update-proxy) - (fw:preferences:set http-proxy-preference #f)))))] - [proxy-spec (instantiate horizontal-panel% (p) - [stretchable-width #f] - [stretchable-height #f] - [alignment '(left center)])] - [update-proxy (lambda () - (let ([host (send host get-value)] - [port (send port get-value)]) - (let ([ok? (and (regexp-match "^[-0-9a-zA-Z.]+$" host) - (regexp-match "^[0-9]+$" port) - (string->number port) - (<= 1 (string->number port) 65535))]) - (when ok? - (fw:preferences:set - http-proxy-preference - (list "http" host (string->number port)))) - (send bad-host show (not ok?)))))] - [host (make-object text-field% - (string-constant proxy-host) - proxy-spec (lambda (x y) (update-proxy)) - "www.someplacethatisaproxy.domain.comm")] - [port (make-object text-field% - (string-constant proxy-port) - proxy-spec (lambda (x y) (update-proxy)) "65535")] - [bad-host (make-object message% - (string-constant proxy-bad-host) - p)] - [update-gui - (lambda (proxy-val) - (send bad-host show #f) - (if proxy-val - (begin - (send rb set-selection 1) - (send proxy-spec enable #t) - (unless (string=? (cadr proxy-val) (send host get-value)) - (send host set-value (cadr proxy-val))) - (unless (equal? (caddr proxy-val) (string->number (send port get-value))) - (send port set-value (number->string (caddr proxy-val))))) - (begin - (send rb set-selection 0) - (send proxy-spec enable #f) - (send host set-value "") - (send port set-value ""))))]) - - (fw:preferences:add-callback http-proxy-preference - (lambda (name val) - (update-gui val))) - (update-gui (fw:preferences:get http-proxy-preference)) - (send bad-host show #f))) + ;; -------------------- proxy for doc downloads -------------------- + (when set-help? + (letrec ([p (instantiate group-box-panel% () + [label (string-constant http-proxy)] + [parent pref-panel] + [stretchable-height #f] + [alignment '(left top)])] + [rb (make-object radio-box% + #f (list (string-constant proxy-direct-connection) + (string-constant proxy-use-proxy)) + p + (lambda (r e) + (let ([proxy? (= 1 (send r get-selection))]) + (send proxy-spec enable proxy?) + (if proxy? + (update-proxy) + (fw:preferences:set http-proxy-preference #f)))))] + [proxy-spec (instantiate horizontal-panel% (p) + [stretchable-width #f] + [stretchable-height #f] + [alignment '(left center)])] + [update-proxy (lambda () + (let ([host (send host get-value)] + [port (send port get-value)]) + (let ([ok? (and (regexp-match? #rx"^[-0-9a-zA-Z.]+$" host) + (regexp-match? #rx"^[0-9]+$" port) + (string->number port) + (<= 1 (string->number port) 65535))]) + (when ok? + (fw:preferences:set + http-proxy-preference + (list "http" host (string->number port)))) + (send bad-host show (not ok?)))))] + [host (make-object text-field% + (string-constant proxy-host) + proxy-spec (lambda (x y) (update-proxy)) + "www.someplacethatisaproxy.domain.com")] + [port (make-object text-field% + (string-constant proxy-port) + proxy-spec (lambda (x y) (update-proxy)) "65535")] + [bad-host (make-object message% + (string-constant proxy-bad-host) + p)] + [update-gui + (lambda (proxy-val) + (send bad-host show #f) + (if proxy-val + (begin + (send rb set-selection 1) + (send proxy-spec enable #t) + (unless (string=? (cadr proxy-val) (send host get-value)) + (send host set-value (cadr proxy-val))) + (unless (equal? (caddr proxy-val) (string->number (send port get-value))) + (send port set-value (number->string (caddr proxy-val))))) + (begin + (send rb set-selection 0) + (send proxy-spec enable #f) + (send host set-value "") + (send port set-value ""))))]) - (set! synchronized? #t) - (values pref-panel callbacks)))))) + (fw:preferences:add-callback http-proxy-preference + (lambda (name val) + (update-gui val))) + (update-gui (fw:preferences:get http-proxy-preference)) + (send bad-host show #f))) + + (set! synchronized? #t) + (values pref-panel callbacks))))))