From c5330194a9a992a8f34781327ff0975624399660 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 10 Nov 2012 12:56:16 -0600 Subject: [PATCH] improve drracket's response to an unhappy aspell program Specifically, two things: - make drracket more careful to not crash when aspell doesn't behave, and - have a more careful test when clicking the menu item (it now does a trial run of aspell instead of just looking for the binary) closes PR 13242 (I realize there is still a feature request mentioned in the audit trail of that PR, but since the main problem is fixed, I'll consider that to just be something separate) --- collects/drracket/private/unit.rkt | 12 ++-- collects/framework/private/aspell.rkt | 64 ++++++++++++++++--- .../private/english-string-constants.rkt | 3 + 3 files changed, 63 insertions(+), 16 deletions(-) diff --git a/collects/drracket/private/unit.rkt b/collects/drracket/private/unit.rkt index 0327fbac58..36dbd6118e 100644 --- a/collects/drracket/private/unit.rkt +++ b/collects/drracket/private/unit.rkt @@ -3645,16 +3645,16 @@ module browser threading seems wrong. (send item check (and on? (send ed get-spell-check-strings))))] [callback (λ (item evt) - (define asp (find-aspell-binary-path)) + (define problem (aspell-problematic?)) (cond - [asp + [problem + (message-box (string-constant drscheme) + problem)] + [else (define ed (get-edit-target-object)) (define old-val (send ed get-spell-check-strings)) (preferences:set 'framework:spell-check-on? (not old-val)) - (send ed set-spell-check-strings (not old-val))] - [else - (message-box (string-constant drscheme) - (string-constant cannot-find-ispell-or-aspell-path))]))]) + (send ed set-spell-check-strings (not old-val))]))]) (new menu:can-restore-menu-item% [label (string-constant complete-word)] [shortcut #\/] diff --git a/collects/framework/private/aspell.rkt b/collects/framework/private/aspell.rkt index 42378eeef1..4c5eddcd48 100644 --- a/collects/framework/private/aspell.rkt +++ b/collects/framework/private/aspell.rkt @@ -1,11 +1,14 @@ #lang racket/base (require racket/system racket/match - racket/contract) + racket/contract + racket/port + string-constants) (provide/contract [query-aspell (-> (and/c string? (not/c #rx"[\n]")) (listof (list/c number? number?)))] - [find-aspell-binary-path (-> (or/c path? #f))]) + [find-aspell-binary-path (-> (or/c path? #f))] + [aspell-problematic? (-> (or/c string? #f))]) (define aspell-candidate-paths '("/usr/bin" @@ -25,6 +28,41 @@ (and (file-exists? c2) c2))))) +(define (start-aspell asp) + (define aspell? (regexp-match? #rx"aspell" (path->string asp))) + (apply process* asp "-a" (if aspell? '("--encoding=utf-8") '()))) + +(define (aspell-problematic?) + (define asp (find-aspell-binary-path)) + (cond + [(not asp) + (string-constant cannot-find-ispell-or-aspell-path)] + [else + (define proc-lst (start-aspell asp)) + (define stdout (list-ref proc-lst 0)) + (define stderr (list-ref proc-lst 3)) + (close-output-port (list-ref proc-lst 1)) ;; close stdin + (close-input-port stdout) + (define sp (open-output-string)) + (copy-port stderr sp) + (define errmsg (get-output-string sp)) + (close-input-port stderr) + (cond + [(not (equal? errmsg "")) + (string-append + (format (string-constant spell-program-wrote-to-stderr-on-startup) asp) + "\n\n" + errmsg)] + [else #f])])) + +(define asp-logger (make-logger 'framework/aspell (current-logger))) +(define-syntax-rule + (asp-log arg) + (when (log-level? asp-logger 'debug) + (asp-log/proc arg))) +(define (asp-log/proc arg) + (log-message asp-logger 'debug arg (current-continuation-marks))) + (define aspell-req-chan (make-channel)) (define aspell-thread #f) (define (start-aspell-thread) @@ -40,12 +78,13 @@ (set! already-attempted-aspell? #t) (define asp (find-aspell-binary-path)) (when asp - (define aspell? (regexp-match? #rx"aspell" (path->string asp))) - (set! aspell-proc (apply process* asp "-a" (if aspell? '("--encoding=utf-8") '()))) - (define line (read-line (list-ref aspell-proc 0))) - (log-info (format "framework: started speller: ~a" line)) + (set! aspell-proc (start-aspell asp)) + (define line (with-handlers ((exn:fail? exn-message)) + (read-line (list-ref aspell-proc 0)))) + (asp-log (format "framework: started speller: ~a" line)) - (when (regexp-match #rx"[Aa]spell" line) + (when (and (string? line) + (regexp-match #rx"[Aa]spell" line)) ;; put aspell in "terse" mode (display "!\n" (list-ref aspell-proc 1)) (flush-output (list-ref aspell-proc 1))) @@ -57,11 +96,11 @@ (define l (with-handlers ((exn:fail? void)) (read-line stderr))) (when (string? l) - (log-warning (format "aspell-proc stderr: ~a" l)) + (asp-log (format "aspell-proc stderr: ~a" l)) (loop)))))))) (define (shutdown-aspell why) - (log-warning (format "aspell.rkt: shutdown connection to aspell: ~a" why)) + (asp-log (format "aspell.rkt: shutdown connection to aspell: ~a" why)) (define proc (list-ref aspell-proc 4)) (close-input-port (list-ref aspell-proc 0)) (close-output-port (list-ref aspell-proc 1)) @@ -94,7 +133,12 @@ (define check-on-aspell (sync/timeout .5 stdout)) (cond [check-on-aspell - (define l (read-line stdout)) + (define l (with-handlers ((exn:fail? (λ (x) + (asp-log + (format "error reading stdout of aspell process: ~a" + (exn-message x))) + eof))) + (read-line stdout))) (cond [(eof-object? l) (send-resp '()) diff --git a/collects/string-constants/private/english-string-constants.rkt b/collects/string-constants/private/english-string-constants.rkt index e7d784f42a..19dbd61485 100644 --- a/collects/string-constants/private/english-string-constants.rkt +++ b/collects/string-constants/private/english-string-constants.rkt @@ -1711,4 +1711,7 @@ please adhere to these guidelines: (spell-check-string-constants "Spell Check String Constants") (misspelled-text-color "Misspelled Text Color") ;; in the preferences dialog (cannot-find-ispell-or-aspell-path "Cannot find the aspell or ispell binary") + ; puts the path to the spell program in the ~a and then the error message + ; is put following this string (with a blank line in between) + (spell-program-wrote-to-stderr-on-startup "The spell program (~a) printed an error message:") )