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
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

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

@ -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))))

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

@ -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

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

@ -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

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

@ -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)))

5
collects/framework/test.ss
View File

@ -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

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

@ -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<%>