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

..

Browse Source 
original commit: 66b994ad812701bb81802b48e2c6cdf1523b8fa8
This commit is contained in:
Robby Findler 2002-06-12 18:27:06 +00:00
parent b1c16cfbeb
commit 0403e29bdc
1 changed files with 217 additions and 216 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -40,223 +40,224 @@
save-file/gui-error)) save-file/gui-error))
(define basic-mixin (define basic-mixin
(mixin (editor<%>) (basic<%>) (let ([mred:get-file get-file])
(mixin (editor<%>) (basic<%>)
(inherit get-filename save-file)
(define/public save-file/gui-error (inherit get-filename save-file)
(opt-lambda ([input-filename #f] (define/public save-file/gui-error
[fmt 'same] (opt-lambda ([input-filename #f]
[show-errors? #t]) [fmt 'same]
(let ([filename (if (or (not input-filename) [show-errors? #t])
(equal? input-filename "")) (let ([filename (if (or (not input-filename)
(let ([internal-filename (get-filename)]) (equal? input-filename ""))
(if (or (not internal-filename) (let ([internal-filename (get-filename)])
(equal? internal-filename "")) (if (or (not internal-filename)
(get-file) (equal? internal-filename ""))
internal-filename)) (mred:get-file)
input-filename)]) internal-filename))
(if filename input-filename)])
(let ([result (save-file filename fmt #f)]) (if filename
(unless result (let ([result (save-file filename fmt #f)])
(when show-errors? (unless result
(message-box (when show-errors?
(string-constant error-saving) (message-box
(format (string-constant error-saving-file/name) (string-constant error-saving)
filename)))) (format (string-constant error-saving-file/name)
result) filename))))
#f)))) result)
#f))))
(inherit refresh-delayed?
get-canvas (inherit refresh-delayed?
get-max-width get-admin) get-canvas
get-max-width get-admin)
(rename [super-can-save-file? can-save-file?])
(override can-save-file?) (rename [super-can-save-file? can-save-file?])
[define can-save-file? (override can-save-file?)
(lambda (filename format) [define can-save-file?
(and (if (equal? filename (get-filename)) (lambda (filename format)
(if (save-file-out-of-date?) (and (if (equal? filename (get-filename))
(gui-utils:get-choice (if (save-file-out-of-date?)
(string-constant file-has-been-modified) (gui-utils:get-choice
(string-constant overwrite-file-button-label) (string-constant file-has-been-modified)
(string-constant cancel) (string-constant overwrite-file-button-label)
(string-constant warning) (string-constant cancel)
#f (string-constant warning)
(get-top-level-focus-window)) #f
#t) (get-top-level-focus-window))
#t) #t)
(super-can-save-file? filename format)))] #t)
(super-can-save-file? filename format)))]
(rename [super-after-save-file after-save-file]
[super-after-load-file after-load-file]) (rename [super-after-save-file after-save-file]
[define last-saved-file-time #f] [super-after-load-file after-load-file])
[define last-saved-file-time #f]
[define/override after-save-file
(lambda (sucess?) [define/override after-save-file
(lambda (sucess?)
;; update recently opened file names
(let* ([temp-b (box #f)] ;; update recently opened file names
[filename (get-filename temp-b)]) (let* ([temp-b (box #f)]
(unless (unbox temp-b) [filename (get-filename temp-b)])
(when filename (unless (unbox temp-b)
(handler:add-to-recent filename)))) (when filename
(handler:add-to-recent filename))))
;; update last-saved-file-time
(when sucess? ;; update last-saved-file-time
(let ([filename (get-filename)]) (when sucess?
(set! last-saved-file-time (let ([filename (get-filename)])
(and filename (set! last-saved-file-time
(file-exists? filename) (and filename
(file-or-directory-modify-seconds filename))))) (file-exists? filename)
(file-or-directory-modify-seconds filename)))))
(super-after-save-file sucess?))]
(super-after-save-file sucess?))]
[define/override after-load-file
(lambda (sucess?) [define/override after-load-file
(when sucess? (lambda (sucess?)
(let ([filename (get-filename)]) (when sucess?
(set! last-saved-file-time (let ([filename (get-filename)])
(and filename (set! last-saved-file-time
(file-exists? filename) (and filename
(file-or-directory-modify-seconds filename))))) (file-exists? filename)
(super-after-load-file sucess?))] (file-or-directory-modify-seconds filename)))))
(public save-file-out-of-date?) (super-after-load-file sucess?))]
[define save-file-out-of-date? (public save-file-out-of-date?)
(lambda () [define save-file-out-of-date?
(and (lambda ()
last-saved-file-time (and
(let ([fn (get-filename)]) last-saved-file-time
(and fn (let ([fn (get-filename)])
(file-exists? fn) (and fn
(let ([ms (file-or-directory-modify-seconds fn)]) (file-exists? fn)
(< last-saved-file-time ms))))))] (let ([ms (file-or-directory-modify-seconds fn)])
(< last-saved-file-time ms))))))]
[define has-focus #f]
(rename [super-on-focus on-focus]) [define has-focus #f]
(override on-focus) (rename [super-on-focus on-focus])
[define on-focus (override on-focus)
(lambda (x) [define on-focus
(set! has-focus x))] (lambda (x)
(public has-focus?) (set! has-focus x))]
[define has-focus? (public has-focus?)
(lambda () [define has-focus?
has-focus)] (lambda ()
has-focus)]
(public on-close get-top-level-window)
[define on-close (lambda () (void))] (public on-close get-top-level-window)
[define get-top-level-window [define on-close (lambda () (void))]
(lambda () [define get-top-level-window
(let loop ([text this]) (lambda ()
(let ([editor-admin (send text get-admin)]) (let loop ([text this])
(cond (let ([editor-admin (send text get-admin)])
[(is-a? editor-admin editor-snip-editor-admin<%>) (cond
(let* ([snip (send editor-admin get-snip)] [(is-a? editor-admin editor-snip-editor-admin<%>)
[snip-admin (send snip get-admin)]) (let* ([snip (send editor-admin get-snip)]
(loop (send snip-admin get-editor)))] [snip-admin (send snip get-admin)])
[(send text get-canvas) => (lambda (canvas) (loop (send snip-admin get-editor)))]
(send canvas get-top-level-window))] [(send text get-canvas) => (lambda (canvas)
[else (send canvas get-top-level-window))]
#f]))))] [else
#f]))))]
(public editing-this-file?)
[define editing-this-file? (lambda () #f)] (public editing-this-file?)
[define editing-this-file? (lambda () #f)]
[define edit-sequence-queue null]
[define edit-sequence-ht (make-hash-table)] [define edit-sequence-queue null]
[define in-local-edit-sequence? #f] [define edit-sequence-ht (make-hash-table)]
(public local-edit-sequence? run-after-edit-sequence extend-edit-sequence-queue) [define in-local-edit-sequence? #f]
[define local-edit-sequence? (lambda () in-local-edit-sequence?)] (public local-edit-sequence? run-after-edit-sequence extend-edit-sequence-queue)
[define run-after-edit-sequence [define local-edit-sequence? (lambda () in-local-edit-sequence?)]
(case-lambda [define run-after-edit-sequence
[(t) (run-after-edit-sequence t #f)] (case-lambda
[(t sym) [(t) (run-after-edit-sequence t #f)]
(unless (and (procedure? t) [(t sym)
(= 0 (procedure-arity t))) (unless (and (procedure? t)
(error 'editor:basic::run-after-edit-sequence (= 0 (procedure-arity t)))
"expected procedure of arity zero, got: ~s~n" t)) (error 'editor:basic::run-after-edit-sequence
(unless (or (symbol? sym) (not sym)) "expected procedure of arity zero, got: ~s~n" t))
(error 'editor:basic::run-after-edit-sequence (unless (or (symbol? sym) (not sym))
"expected second argument to be a symbol or #f, got: ~s~n" (error 'editor:basic::run-after-edit-sequence
sym)) "expected second argument to be a symbol or #f, got: ~s~n"
(if (refresh-delayed?) sym))
(if in-local-edit-sequence? (if (refresh-delayed?)
(cond (if in-local-edit-sequence?
[(symbol? sym)
(hash-table-put! edit-sequence-ht sym t)]
[else (set! edit-sequence-queue
(cons t edit-sequence-queue))])
(let ([snip-admin (get-admin)])
(cond
[(not snip-admin)
(t)] ;; refresh-delayed? is always #t when there is no admin.
[(is-a? snip-admin editor-snip-editor-admin<%>)
(send (send (send (send snip-admin get-snip) get-admin) get-editor)
run-after-edit-sequence t sym)]
[else
(message-box "run-after-edit-sequence error"
(format "refresh-delayed? is #t but snip admin, ~s, is not an editor-snip-editor-admin<%>"
snip-admin))
'(t)])))
(t))
(void)])]
[define extend-edit-sequence-queue
(lambda (l ht)
(hash-table-for-each ht (lambda (k t)
(hash-table-put!
edit-sequence-ht
k t)))
(set! edit-sequence-queue (append l edit-sequence-queue)))]
(rename
[super-after-edit-sequence after-edit-sequence]
[super-on-edit-sequence on-edit-sequence])
(override on-edit-sequence after-edit-sequence)
[define on-edit-sequence
(lambda ()
(super-on-edit-sequence)
(set! in-local-edit-sequence? #t))]
[define after-edit-sequence
(lambda ()
(set! in-local-edit-sequence? #f)
(super-after-edit-sequence)
(let ([queue edit-sequence-queue]
[ht edit-sequence-ht]
[find-enclosing-edit
(lambda (edit)
(let ([admin (send edit get-admin)])
(cond (cond
[(is-a? admin editor-snip-editor-admin<%>) [(symbol? sym)
(send (send (send admin get-snip) get-admin) get-editor)] (hash-table-put! edit-sequence-ht sym t)]
[else #f])))]) [else (set! edit-sequence-queue
(set! edit-sequence-queue null) (cons t edit-sequence-queue))])
(set! edit-sequence-ht (make-hash-table)) (let ([snip-admin (get-admin)])
(let loop ([edit (find-enclosing-edit this)]) (cond
(cond [(not snip-admin)
[(and edit (not (send edit local-edit-sequence?))) (t)] ;; refresh-delayed? is always #t when there is no admin.
(loop (find-enclosing-edit edit))] [(is-a? snip-admin editor-snip-editor-admin<%>)
[edit (send edit extend-edit-sequence-queue queue ht)] (send (send (send (send snip-admin get-snip) get-admin) get-editor)
[else run-after-edit-sequence t sym)]
(hash-table-for-each ht (lambda (k t) (t))) [else
(for-each (lambda (t) (t)) queue)]))))] (message-box "run-after-edit-sequence error"
(format "refresh-delayed? is #t but snip admin, ~s, is not an editor-snip-editor-admin<%>"
(override on-new-box) snip-admin))
[define on-new-box '(t)])))
(lambda (type) (t))
(cond (void)])]
[(eq? type 'text) (make-object editor-snip% (make-object text:basic%))] [define extend-edit-sequence-queue
[else (make-object editor-snip% (make-object pasteboard:basic%))]))] (lambda (l ht)
(hash-table-for-each ht (lambda (k t)
(hash-table-put!
(override get-file put-file) edit-sequence-ht
[define get-file (lambda (d) k t)))
(parameterize ([finder:dialog-parent-parameter (set! edit-sequence-queue (append l edit-sequence-queue)))]
(get-top-level-window)]) (rename
(finder:get-file d)))] [super-after-edit-sequence after-edit-sequence]
[define put-file (lambda (d f) (parameterize ([finder:dialog-parent-parameter [super-on-edit-sequence on-edit-sequence])
(get-top-level-window)]) (override on-edit-sequence after-edit-sequence)
(finder:put-file f d)))] [define on-edit-sequence
(lambda ()
(super-on-edit-sequence)
(super-instantiate ()))) (set! in-local-edit-sequence? #t))]
[define after-edit-sequence
(lambda ()
(set! in-local-edit-sequence? #f)
(super-after-edit-sequence)
(let ([queue edit-sequence-queue]
[ht edit-sequence-ht]
[find-enclosing-edit
(lambda (edit)
(let ([admin (send edit get-admin)])
(cond
[(is-a? admin editor-snip-editor-admin<%>)
(send (send (send admin get-snip) get-admin) get-editor)]
[else #f])))])
(set! edit-sequence-queue null)
(set! edit-sequence-ht (make-hash-table))
(let loop ([edit (find-enclosing-edit this)])
(cond
[(and edit (not (send edit local-edit-sequence?)))
(loop (find-enclosing-edit edit))]
[edit (send edit extend-edit-sequence-queue queue ht)]
[else
(hash-table-for-each ht (lambda (k t) (t)))
(for-each (lambda (t) (t)) queue)]))))]
(override on-new-box)
[define on-new-box
(lambda (type)
(cond
[(eq? type 'text) (make-object editor-snip% (make-object text:basic%))]
[else (make-object editor-snip% (make-object pasteboard:basic%))]))]
(override get-file put-file)
[define get-file (lambda (d)
(parameterize ([finder:dialog-parent-parameter
(get-top-level-window)])
(finder:get-file d)))]
[define put-file (lambda (d f) (parameterize ([finder:dialog-parent-parameter
(get-top-level-window)])
(finder:put-file f d)))]
(super-instantiate ()))))
(define -keymap<%> (interface (basic<%>) get-keymaps)) (define -keymap<%> (interface (basic<%>) get-keymaps))
(define keymap-mixin (define keymap-mixin