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

..

Browse Source 
original commit: 6c528325b02c3f03ad7b2968043d18f4e5734043
This commit is contained in:
Robby Findler 2002-08-18 20:11:22 +00:00
parent 2c349b2c60
commit 112768080f
7 changed files with 145 additions and 94 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

108
collects/framework/private/editor.ss
View File

@ -41,7 +41,8 @@
get-top-level-window get-top-level-window
on-close on-close
save-file-out-of-date? save-file-out-of-date?
save-file/gui-error)) save-file/gui-error
load-file/gui-error))
(define basic-mixin (define basic-mixin
(mixin (editor<%>) (basic<%>) (mixin (editor<%>) (basic<%>)
@ -59,16 +60,47 @@
(mred:get-file) (mred:get-file)
internal-filename)) internal-filename))
input-filename)]) input-filename)])
(if filename (with-handlers ([not-break-exn?
(let ([result (save-file filename fmt #f)]) (lambda (exn)
(unless result (message-box
(when show-errors? (string-constant error-saving)
(message-box (string-append
(string-constant error-saving) (format (string-constant error-saving-file/name)
(format (string-constant error-saving-file/name) filename)
filename)))) "\n\n"
result) (if (exn? exn)
#f)))) (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? (inherit refresh-delayed?
get-canvas get-canvas
@ -415,32 +447,34 @@
[define do-autosave? #t] [define do-autosave? #t]
(public autosave? do-autosave remove-autosave) (public autosave? do-autosave remove-autosave)
[define autosave? (lambda () do-autosave?)] [define autosave? (lambda () do-autosave?)]
[define do-autosave [define (do-autosave)
(lambda () (when (and (autosave?)
(when (and (autosave?) (not auto-save-error?)
(not auto-save-error?) (is-modified?)
(is-modified?) (or (not auto-saved-name)
(or (not auto-saved-name) auto-save-out-of-date?))
auto-save-out-of-date?)) (let* ([orig-name (get-filename)]
(let* ([orig-name (get-filename)] [old-auto-name auto-saved-name]
[old-auto-name auto-saved-name] [auto-name (path-utils:generate-autosave-name orig-name)])
[auto-name (path-utils:generate-autosave-name orig-name)] (with-handlers ([not-break-exn?
[success (save-file auto-name 'copy #f)]) (lambda (exn)
(if success (message-box
(begin (string-constant warning)
(when old-auto-name (string-append
(delete-file old-auto-name)) (format (string-constant error-autosaving)
(set! auto-saved-name auto-name) (or orig-name (string-constant untitled)))
(set! auto-save-out-of-date? #f)) "\n"
(begin (string-constant autosaving-turned-off)
(message-box "\n\n"
(string-constant warning) (if (exn? exn)
(string-append (exn-message exn)
(format (string-constant error-autosaving) (format "~s" exn))))
(or orig-name (string-constant untitled))) (set! auto-save-error? #t))])
"\n" (save-file auto-name 'copy #f)
(string-constant autosaving-turned-off))) (when old-auto-name
(set! auto-save-error? #t))))))] (delete-file old-auto-name))
(set! auto-saved-name auto-name)
(set! auto-save-out-of-date? #f))))]
[define remove-autosave [define remove-autosave
(lambda () (lambda ()
(when auto-saved-name (when auto-saved-name

42
collects/framework/private/frame.ss
View File

@ -25,7 +25,6 @@
[handler : framework:handler^] [handler : framework:handler^]
[application : framework:application^] [application : framework:application^]
[panel : framework:panel^] [panel : framework:panel^]
[exit : framework:exit^]
[finder : framework:finder^] [finder : framework:finder^]
[keymap : framework:keymap^] [keymap : framework:keymap^]
[text : framework:text^] [text : framework:text^]
@ -33,7 +32,8 @@
[editor : framework:editor^] [editor : framework:editor^]
[canvas : framework:canvas^] [canvas : framework:canvas^]
[menu : framework:menu^] [menu : framework:menu^]
[scheme : framework:scheme^]) [scheme : framework:scheme^]
[exit : framework:exit^])
(rename [-editor<%> editor<%>] (rename [-editor<%> editor<%>]
[-pasteboard% pasteboard%] [-pasteboard% pasteboard%]
@ -684,14 +684,11 @@
(lambda () (lambda ()
(super-on-close) (super-on-close)
(send (get-editor) on-close))] (send (get-editor) on-close))]
[define label (if filename [define label ""]
(file-name-from-path filename)
(gui-utils:next-untitled-name))]
[define label-prefix (application:current-app-name)] [define label-prefix (application:current-app-name)]
[define do-label (define (do-label)
(lambda () (super-set-label (get-entire-label))
(super-set-label (get-entire-label)) (send (group:get-the-frame-group) frame-label-changed this))
(send (group:get-the-frame-group) frame-label-changed this))]
(public get-entire-label get-label-prefix set-label-prefix) (public get-entire-label get-label-prefix set-label-prefix)
[define get-entire-label [define get-entire-label
@ -787,7 +784,7 @@
#f #f
this) this)
(send edit begin-edit-sequence) (send edit begin-edit-sequence)
(let ([status (send edit load-file (let ([status (send edit load-file/gui-error
filename filename
'same 'same
#f)]) #f)])
@ -796,12 +793,7 @@
(when (is-a? edit text%) (when (is-a? edit text%)
(send edit set-position start start)) (send edit set-position start start))
(send edit end-edit-sequence)) (send edit end-edit-sequence))
(begin (send edit end-edit-sequence)))))))
(send edit end-edit-sequence)
(message-box
(string-constant error-reverting)
(format (string-constant could-not-read) filename)
this))))))))
#t)) #t))
(define/override file-menu:create-revert? (lambda () #t)) (define/override file-menu:create-revert? (lambda () #t))
(define file-menu:save-callback (lambda (item control) (define file-menu:save-callback (lambda (item control)
@ -875,17 +867,22 @@
(send (get-canvas) set-editor editor)) (send (get-canvas) set-editor editor))
editor)) editor))
(do-label)
(cond (cond
[(and filename (file-exists? filename)) [(and filename (file-exists? filename))
(send (get-editor) load-file filename 'guess #f)] (send (get-editor) load-file/gui-error filename 'guess)]
[filename [filename
(send (get-editor) set-filename filename)] (send (get-editor) set-filename filename)]
[else (void)]) [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)]) (let ([canvas (get-canvas)])
(when (is-a? canvas editor-canvas%) (when (is-a? canvas editor-canvas%)
;; when get-canvas is overridden, ;; when get-canvas is overridden,
;; it might not yet be implemented ;; it might not yet be implemented
(send canvas focus))))) (send canvas focus)))))
(define open-here<%> (define open-here<%>
@ -924,6 +921,7 @@
[else ((handler:current-create-new-window) #f)])) [else ((handler:current-create-new-window) #f)]))
;; cancel-due-to-unsaved-changes : -> boolean ;; cancel-due-to-unsaved-changes : -> boolean
;; returns #t if the action should be cancelled
(define (cancel-due-to-unsaved-changes editor) (define (cancel-due-to-unsaved-changes editor)
(and (send editor is-modified?) (and (send editor is-modified?)
(let ([save (gui-utils:unsaved-warning (let ([save (gui-utils:unsaved-warning
@ -933,7 +931,7 @@
this)]) this)])
(case save (case save
[(continue) #f] [(continue) #f]
[(save) (not (send editor save-file))] [(save) (not (send editor save-file/gui-errors))]
[(cancel) #t])))) [(cancel) #t]))))
;; ask-about-new-here : -> (union 'cancel boolean?) ;; ask-about-new-here : -> (union 'cancel boolean?)
@ -985,7 +983,7 @@
(send editor get-end-position)))))) (send editor get-end-position))))))
(send editor begin-edit-sequence) (send editor begin-edit-sequence)
(send editor lock #f) (send editor lock #f)
(send editor load-file filename) (send editor load-file/gui-error filename)
(send editor end-edit-sequence) (send editor end-edit-sequence)
(void)))) (void))))

67
collects/framework/private/handler.ss
View File

@ -111,34 +111,45 @@
(lambda () (lambda ()
((current-create-new-window) filename)))] ((current-create-new-window) filename)))]
[(filename make-default) [(filename make-default)
(gui-utils:show-busy-cursor (with-handlers ([not-break-exn?
(lambda () (lambda (exn)
(if filename (message-box
(let ([already-open (send (group:get-the-frame-group) (string-constant error-loading)
locate-file (string-append
filename)]) (format (string-constant error-loading-file/name)
(cond (or filename
[already-open (string-constant unknown-filename)))
(send already-open show #t) "\n\n"
already-open] (if (exn? exn) (exn-message exn) (format "~s" exn))))
[(and (preferences:get 'framework:open-here?) #f)])
(send (group:get-the-frame-group) get-open-here-frame)) (gui-utils:show-busy-cursor
=> (lambda ()
(lambda (fr) (if filename
(add-to-recent filename) (let ([already-open (send (group:get-the-frame-group)
(send fr open-here filename) locate-file
(send fr show #t) filename)])
fr)] (cond
[else [already-open
(let ([handler (send already-open show #t)
(if (string? filename) already-open]
(find-format-handler filename) [(and (preferences:get 'framework:open-here?)
#f)]) (send (group:get-the-frame-group) get-open-here-frame))
(add-to-recent filename) =>
(if handler (lambda (fr)
(handler filename) (add-to-recent filename)
(make-default)))])) (send fr open-here filename)
(make-default))))])) (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 ; Query the user for a file and then edit it

4
collects/framework/private/keymap.ss
View File

@ -1108,13 +1108,13 @@
(send edit get-top-level-window))]) (send edit get-top-level-window))])
(let ([file (finder:put-file)]) (let ([file (finder:put-file)])
(when file (when file
(send edit save-file file))))) (send edit save-file/gui-error file)))))
#t)] #t)]
[save-file [save-file
(lambda (this-edit event) (lambda (this-edit event)
(let ([edit (get-outer-editor this-edit)]) (let ([edit (get-outer-editor this-edit)])
(if (send edit get-filename) (if (send edit get-filename)
(send edit save-file) (send edit save-file/gui-error)
(save-file-as edit event))) (save-file-as edit event)))
#t)] #t)]
[load-file [load-file

2
collects/framework/private/text.ss
View File

@ -647,7 +647,7 @@
(when (and delegate success?) (when (and delegate success?)
(send delegate begin-edit-sequence) (send delegate begin-edit-sequence)
(send delegate lock #f) (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 set-filename #f)
(send delegate lock #t) (send delegate lock #t)
(send delegate end-edit-sequence))) (send delegate end-edit-sequence)))

5
collects/framework/test.ss
View File

@ -334,7 +334,7 @@
;; Note: never more than one timer (of ours) on real event queue. ;; Note: never more than one timer (of ours) on real event queue.
;; ;;
'(define run-one (define run-one
(let ([yield-semaphore (make-semaphore 0)] (let ([yield-semaphore (make-semaphore 0)]
[thread-semaphore (make-semaphore 0)]) [thread-semaphore (make-semaphore 0)])
(thread (thread
@ -369,7 +369,8 @@
(semaphore-wait sem) (semaphore-wait sem)
(reraise-error)))))) (reraise-error))))))
(define run-one ;; new, queue-callback based run-one
'(define run-one
(let ([yield-semaphore (make-semaphore 0)] (let ([yield-semaphore (make-semaphore 0)]
[thread-semaphore (make-semaphore 0)]) [thread-semaphore (make-semaphore 0)])
(thread (thread

11
collects/hierlist/hierlist-unit.ss
View File

@ -157,7 +157,8 @@
user-data user-data
get-allow-selection? get-allow-selection?
set-allow-selection set-allow-selection
get-clickable-snip)) get-clickable-snip
get-parent))
(define hierarchical-list-item% (define hierarchical-list-item%
(class100* object% (hierarchical-list-item<%>) (snp) (class100* object% (hierarchical-list-item<%>) (snp)
@ -184,7 +185,13 @@
scroll-to scroll-to
snip snip
0 0 0 (unbox h-box) #t)))] 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)))) (sequence (super-init))))
(define hierarchical-list-compound-item<%> (define hierarchical-list-compound-item<%>