diff --git a/collects/framework/private/editor.ss b/collects/framework/private/editor.ss index 22885515..84f60d48 100644 --- a/collects/framework/private/editor.ss +++ b/collects/framework/private/editor.ss @@ -41,7 +41,8 @@ get-top-level-window on-close save-file-out-of-date? - save-file/gui-error)) + save-file/gui-error + load-file/gui-error)) (define basic-mixin (mixin (editor<%>) (basic<%>) @@ -59,16 +60,47 @@ (mred:get-file) internal-filename)) input-filename)]) - (if filename - (let ([result (save-file filename fmt #f)]) - (unless result - (when show-errors? - (message-box - (string-constant error-saving) - (format (string-constant error-saving-file/name) - filename)))) - result) - #f)))) + (with-handlers ([not-break-exn? + (lambda (exn) + (message-box + (string-constant error-saving) + (string-append + (format (string-constant error-saving-file/name) + filename) + "\n\n" + (if (exn? exn) + (exn-message exn) + (format "~s" exn)))) + #f)]) + (when filename + (save-file filename fmt #f)) + #t)))) + + (inherit load-file) + (define/public load-file/gui-error + (opt-lambda ([input-filename #f] + [fmt 'guess] + [show-errors? #t]) + (let ([filename (if (or (not input-filename) + (equal? input-filename "")) + (let ([internal-filename (get-filename)]) + (if (or (not internal-filename) + (equal? internal-filename "")) + (mred:get-file) + internal-filename)) + input-filename)]) + (with-handlers ([not-break-exn? + (lambda (exn) + (message-box + (string-constant error-loading) + (string-append + (format (string-constant error-loading-file/name) + filename) + "\n\n" + (if (exn? exn) (exn-message exn) (format "~s" exn)))) + #f)]) + (load-file input-filename fmt show-errors?) + #t)))) (inherit refresh-delayed? get-canvas @@ -415,32 +447,34 @@ [define do-autosave? #t] (public autosave? do-autosave remove-autosave) [define autosave? (lambda () do-autosave?)] - [define do-autosave - (lambda () - (when (and (autosave?) - (not auto-save-error?) - (is-modified?) - (or (not auto-saved-name) - auto-save-out-of-date?)) - (let* ([orig-name (get-filename)] - [old-auto-name auto-saved-name] - [auto-name (path-utils:generate-autosave-name orig-name)] - [success (save-file auto-name 'copy #f)]) - (if success - (begin - (when old-auto-name - (delete-file old-auto-name)) - (set! auto-saved-name auto-name) - (set! auto-save-out-of-date? #f)) - (begin - (message-box - (string-constant warning) - (string-append - (format (string-constant error-autosaving) - (or orig-name (string-constant untitled))) - "\n" - (string-constant autosaving-turned-off))) - (set! auto-save-error? #t))))))] + [define (do-autosave) + (when (and (autosave?) + (not auto-save-error?) + (is-modified?) + (or (not auto-saved-name) + auto-save-out-of-date?)) + (let* ([orig-name (get-filename)] + [old-auto-name auto-saved-name] + [auto-name (path-utils:generate-autosave-name orig-name)]) + (with-handlers ([not-break-exn? + (lambda (exn) + (message-box + (string-constant warning) + (string-append + (format (string-constant error-autosaving) + (or orig-name (string-constant untitled))) + "\n" + (string-constant autosaving-turned-off) + "\n\n" + (if (exn? exn) + (exn-message exn) + (format "~s" exn)))) + (set! auto-save-error? #t))]) + (save-file auto-name 'copy #f) + (when old-auto-name + (delete-file old-auto-name)) + (set! auto-saved-name auto-name) + (set! auto-save-out-of-date? #f))))] [define remove-autosave (lambda () (when auto-saved-name diff --git a/collects/framework/private/frame.ss b/collects/framework/private/frame.ss index 0ee3b2b7..19897424 100644 --- a/collects/framework/private/frame.ss +++ b/collects/framework/private/frame.ss @@ -25,7 +25,6 @@ [handler : framework:handler^] [application : framework:application^] [panel : framework:panel^] - [exit : framework:exit^] [finder : framework:finder^] [keymap : framework:keymap^] [text : framework:text^] @@ -33,7 +32,8 @@ [editor : framework:editor^] [canvas : framework:canvas^] [menu : framework:menu^] - [scheme : framework:scheme^]) + [scheme : framework:scheme^] + [exit : framework:exit^]) (rename [-editor<%> editor<%>] [-pasteboard% pasteboard%] @@ -684,14 +684,11 @@ (lambda () (super-on-close) (send (get-editor) on-close))] - [define label (if filename - (file-name-from-path filename) - (gui-utils:next-untitled-name))] + [define label ""] [define label-prefix (application:current-app-name)] - [define do-label - (lambda () - (super-set-label (get-entire-label)) - (send (group:get-the-frame-group) frame-label-changed this))] + (define (do-label) + (super-set-label (get-entire-label)) + (send (group:get-the-frame-group) frame-label-changed this)) (public get-entire-label get-label-prefix set-label-prefix) [define get-entire-label @@ -787,7 +784,7 @@ #f this) (send edit begin-edit-sequence) - (let ([status (send edit load-file + (let ([status (send edit load-file/gui-error filename 'same #f)]) @@ -796,12 +793,7 @@ (when (is-a? edit text%) (send edit set-position start start)) (send edit end-edit-sequence)) - (begin - (send edit end-edit-sequence) - (message-box - (string-constant error-reverting) - (format (string-constant could-not-read) filename) - this)))))))) + (send edit end-edit-sequence))))))) #t)) (define/override file-menu:create-revert? (lambda () #t)) (define file-menu:save-callback (lambda (item control) @@ -875,17 +867,22 @@ (send (get-canvas) set-editor editor)) editor)) - (do-label) (cond [(and filename (file-exists? filename)) - (send (get-editor) load-file filename 'guess #f)] + (send (get-editor) load-file/gui-error filename 'guess)] [filename (send (get-editor) set-filename filename)] [else (void)]) + (let ([ed-fn (send (get-editor) get-filename)]) + (set! label (if ed-fn + (or (file-name-from-path ed-fn) + (gui-utils:next-untitled-name)) + (gui-utils:next-untitled-name)))) + (do-label) (let ([canvas (get-canvas)]) (when (is-a? canvas editor-canvas%) - ;; when get-canvas is overridden, - ;; it might not yet be implemented + ;; when get-canvas is overridden, + ;; it might not yet be implemented (send canvas focus))))) (define open-here<%> @@ -924,6 +921,7 @@ [else ((handler:current-create-new-window) #f)])) ;; cancel-due-to-unsaved-changes : -> boolean + ;; returns #t if the action should be cancelled (define (cancel-due-to-unsaved-changes editor) (and (send editor is-modified?) (let ([save (gui-utils:unsaved-warning @@ -933,7 +931,7 @@ this)]) (case save [(continue) #f] - [(save) (not (send editor save-file))] + [(save) (not (send editor save-file/gui-errors))] [(cancel) #t])))) ;; ask-about-new-here : -> (union 'cancel boolean?) @@ -985,7 +983,7 @@ (send editor get-end-position)))))) (send editor begin-edit-sequence) (send editor lock #f) - (send editor load-file filename) + (send editor load-file/gui-error filename) (send editor end-edit-sequence) (void)))) diff --git a/collects/framework/private/handler.ss b/collects/framework/private/handler.ss index a6fe0231..ce28e821 100644 --- a/collects/framework/private/handler.ss +++ b/collects/framework/private/handler.ss @@ -111,34 +111,45 @@ (lambda () ((current-create-new-window) filename)))] [(filename make-default) - (gui-utils:show-busy-cursor - (lambda () - (if filename - (let ([already-open (send (group:get-the-frame-group) - locate-file - filename)]) - (cond - [already-open - (send already-open show #t) - already-open] - [(and (preferences:get 'framework:open-here?) - (send (group:get-the-frame-group) get-open-here-frame)) - => - (lambda (fr) - (add-to-recent filename) - (send fr open-here filename) - (send fr show #t) - fr)] - [else - (let ([handler - (if (string? filename) - (find-format-handler filename) - #f)]) - (add-to-recent filename) - (if handler - (handler filename) - (make-default)))])) - (make-default))))])) + (with-handlers ([not-break-exn? + (lambda (exn) + (message-box + (string-constant error-loading) + (string-append + (format (string-constant error-loading-file/name) + (or filename + (string-constant unknown-filename))) + "\n\n" + (if (exn? exn) (exn-message exn) (format "~s" exn)))) + #f)]) + (gui-utils:show-busy-cursor + (lambda () + (if filename + (let ([already-open (send (group:get-the-frame-group) + locate-file + filename)]) + (cond + [already-open + (send already-open show #t) + already-open] + [(and (preferences:get 'framework:open-here?) + (send (group:get-the-frame-group) get-open-here-frame)) + => + (lambda (fr) + (add-to-recent filename) + (send fr open-here filename) + (send fr show #t) + fr)] + [else + (let ([handler + (if (string? filename) + (find-format-handler filename) + #f)]) + (add-to-recent filename) + (if handler + (handler filename) + (make-default)))])) + (make-default)))))])) ; Query the user for a file and then edit it diff --git a/collects/framework/private/keymap.ss b/collects/framework/private/keymap.ss index a6ff3085..8ef9b0d4 100644 --- a/collects/framework/private/keymap.ss +++ b/collects/framework/private/keymap.ss @@ -1108,13 +1108,13 @@ (send edit get-top-level-window))]) (let ([file (finder:put-file)]) (when file - (send edit save-file file))))) + (send edit save-file/gui-error file))))) #t)] [save-file (lambda (this-edit event) (let ([edit (get-outer-editor this-edit)]) (if (send edit get-filename) - (send edit save-file) + (send edit save-file/gui-error) (save-file-as edit event))) #t)] [load-file diff --git a/collects/framework/private/text.ss b/collects/framework/private/text.ss index c18c2741..b5ef318e 100644 --- a/collects/framework/private/text.ss +++ b/collects/framework/private/text.ss @@ -647,7 +647,7 @@ (when (and delegate success?) (send delegate begin-edit-sequence) (send delegate lock #f) - (send delegate load-file filename format) + (send delegate load-file/gui-error filename format) (send delegate set-filename #f) (send delegate lock #t) (send delegate end-edit-sequence))) diff --git a/collects/framework/test.ss b/collects/framework/test.ss index 0c6d3ed8..9f906a68 100644 --- a/collects/framework/test.ss +++ b/collects/framework/test.ss @@ -334,7 +334,7 @@ ;; Note: never more than one timer (of ours) on real event queue. ;; - '(define run-one + (define run-one (let ([yield-semaphore (make-semaphore 0)] [thread-semaphore (make-semaphore 0)]) (thread @@ -369,7 +369,8 @@ (semaphore-wait sem) (reraise-error)))))) - (define run-one + ;; new, queue-callback based run-one + '(define run-one (let ([yield-semaphore (make-semaphore 0)] [thread-semaphore (make-semaphore 0)]) (thread diff --git a/collects/hierlist/hierlist-unit.ss b/collects/hierlist/hierlist-unit.ss index d97dfe67..ff76536d 100644 --- a/collects/hierlist/hierlist-unit.ss +++ b/collects/hierlist/hierlist-unit.ss @@ -157,7 +157,8 @@ user-data get-allow-selection? set-allow-selection - get-clickable-snip)) + get-clickable-snip + get-parent)) (define hierarchical-list-item% (class100* object% (hierarchical-list-item<%>) (snp) @@ -184,7 +185,13 @@ scroll-to snip 0 0 0 (unbox h-box) #t)))] - [user-data (case-lambda [() data][(x) (set! data x)])]) + [user-data (case-lambda [() data][(x) (set! data x)])] + [get-parent (lambda () + (let ([parent-of-snip (send snip get-parent)]) + (and parent-of-snip + (let ([parent-snip (send parent-of-snip get-parent-snip)]) + (and parent-snip + (send parent-snip get-item))))))]) (sequence (super-init)))) (define hierarchical-list-compound-item<%>