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