..
original commit: 81f1b4e98dd489d8e997977df3d906f3dee2cb97
This commit is contained in:
Robby Findler
parent
a265ad934c
commit
b09564645f
|
|
@ -14,6 +14,7 @@
|
|||
"specs.ss")
|
||||
|
||||
(provide-signature-elements framework-class^)
|
||||
|
||||
(provide (all-from "macro.ss")
|
||||
(all-from "specs.ss")
|
||||
(all-from "test.ss")
|
||||
|
|
@ -576,9 +577,20 @@
|
|||
(is-a?/c frame:editor<%>))
|
||||
((filename)
|
||||
((make-default (lambda () (make-object frame:text-info-file\% filename)))))
|
||||
"This function creates a frame to edit a file. "
|
||||
"This function creates a frame or re-uses an existing frame to edit a file. "
|
||||
""
|
||||
"It invokes the appropriate format handler to open the file (see"
|
||||
"If the preference \\scheme{'framework:open-here} is set to \\scheme{#t},"
|
||||
"and (send ("
|
||||
"@flink group:get-the-frame-group %"
|
||||
") "
|
||||
"@milink open-here get-open-here-frame %"
|
||||
") returns a frame, the "
|
||||
"@milink open-here "
|
||||
"method of that frame is used to load"
|
||||
"the file in the existing frame."
|
||||
""
|
||||
"Otherwise, it invokes the appropriate format"
|
||||
"handler to open the file (see"
|
||||
"@flink handler:insert-format-handler %"
|
||||
")."
|
||||
""
|
||||
|
|
@ -626,10 +638,18 @@
|
|||
"with the filename of the recently opened file."
|
||||
""
|
||||
"The menu's size is limited to 10.")
|
||||
|
||||
(handler:add-to-recent
|
||||
(string? . -> . void?)
|
||||
(filename)
|
||||
"Adds a filename to the list of recently opened files.")
|
||||
|
||||
(handler:set-recent-position
|
||||
(string? number? number? . -> . void?)
|
||||
(filename start end)
|
||||
"Sets the selection of the recently opened file to"
|
||||
"\\var{start} and \\end{end}.")
|
||||
|
||||
(icon:get-paren-highlight-bitmap
|
||||
(-> (is-a?/c bitmap%))
|
||||
()
|
||||
|
|
@ -722,8 +742,8 @@
|
|||
|
||||
(keymap:add-to-right-button-menu
|
||||
(case->
|
||||
(((is-a?/c menu%) (is-a?/c editor<%>) (is-a?/c event%) . -> . void?) . -> . void?)
|
||||
(-> ((is-a?/c menu%) (is-a?/c editor<%>) (is-a?/c event%) . -> . void?)))
|
||||
(((is-a?/c popup-menu%) (is-a?/c editor<%>) (is-a?/c event%) . -> . void?) . -> . void?)
|
||||
(-> ((is-a?/c popup-menu%) (is-a?/c editor<%>) (is-a?/c event%) . -> . void?)))
|
||||
((func) ())
|
||||
"When the keymap that "
|
||||
"@flink keymap:get-global"
|
||||
|
|
@ -741,10 +761,10 @@
|
|||
|
||||
(keymap:add-to-right-button-menu/before
|
||||
(case->
|
||||
(((is-a?/c menu%) (is-a?/c editor<%>) (is-a?/c event%) . -> . void?)
|
||||
(((is-a?/c popup-menu%) (is-a?/c editor<%>) (is-a?/c event%) . -> . void?)
|
||||
. -> .
|
||||
void?)
|
||||
(-> ((is-a?/c menu%) (is-a?/c editor<%>) (is-a?/c event%) . -> . void?)))
|
||||
(-> ((is-a?/c popup-menu%) (is-a?/c editor<%>) (is-a?/c event%) . -> . void?)))
|
||||
((func) ())
|
||||
"When the keymap that "
|
||||
"@flink keymap:get-global"
|
||||
|
|
|
|||
|
|
@ -11,20 +11,164 @@
|
|||
(syntax (provide/contract (name contract) ...))]))
|
||||
|
||||
(provide/contract/docs
|
||||
(gui-utils:next-untitled-name any?)
|
||||
(gui-utils:cursor-delay any?)
|
||||
(gui-utils:show-busy-cursor any?)
|
||||
(gui-utils:delay-action any?)
|
||||
(gui-utils:local-busy-cursor any?)
|
||||
(gui-utils:unsaved-warning any?)
|
||||
(gui-utils:read-snips/chars-from-text any?)
|
||||
(gui-utils:get-choice any?)
|
||||
(gui-utils:open-input-buffer any?)
|
||||
(gui-utils:get-clicked-clickback-delta any?)
|
||||
(gui-utils:get-clickback-delta any?))
|
||||
|
||||
(provide (rename alphabetic-list-box% gui-utils:alphabetic-list-box%)
|
||||
(rename text-snip<%> gui-utils:text-snip<%>))
|
||||
(gui-utils:next-untitled-name
|
||||
(-> string?)
|
||||
()
|
||||
"Returns a name for the next opened untitled frame. The first"
|
||||
"name is ``Untitled'', the second is ``Untitled 2'',"
|
||||
"the third is ``Untitled 3'', and so forth.")
|
||||
(gui-utils:cursor-delay
|
||||
(case->
|
||||
(-> real?)
|
||||
(real? . -> . void?))
|
||||
(() (new-delay))
|
||||
"This function is {\\em not\\/} a parameter."
|
||||
"Instead, the state is just stored in the closure."
|
||||
""
|
||||
"The first case in the case lambda"
|
||||
"returns the current delay in seconds before a watch cursor is shown,"
|
||||
"when either \\iscmprocedure{gui-utils:local-busy-cursor} or"
|
||||
"\\iscmprocedure{gui-utils:show-busy-cursor} is called."
|
||||
|
||||
"The second case in the case lambda"
|
||||
"Sets the delay, in seconds, before a watch cursor is shown, when"
|
||||
"either \\iscmprocedure{gui-utils:local-busy-cursor} or"
|
||||
"\\iscmprocedure{gui-utils:show-busy-cursor} is called.")
|
||||
(gui-utils:show-busy-cursor
|
||||
(opt->
|
||||
((-> any?))
|
||||
(integer?)
|
||||
any?)
|
||||
((thunk)
|
||||
((delay (gui-utils:cursor-delay))))
|
||||
"Evaluates \\rawscm{(\\var{thunk})} with a watch cursor. The argument"
|
||||
"\\var{delay} specifies the amount of time before the watch cursor is"
|
||||
"opened. Use \\iscmprocedure{gui-utils:cursor-delay} to set this value"
|
||||
"to all calls."
|
||||
""
|
||||
"This function returns the result of \\var{thunk}.")
|
||||
(gui-utils:delay-action
|
||||
(real?
|
||||
(-> void?)
|
||||
(-> void?)
|
||||
. -> .
|
||||
void?)
|
||||
(delay-time open close)
|
||||
"Use this function to delay an action for some period of time. It also"
|
||||
"supports cancelling the action before the time period elapses. For"
|
||||
"example, if you want to display a watch cursor, but you only want it"
|
||||
"to appear after 2 seconds and the action may or may not take more than"
|
||||
"two seconds, use this pattern:"
|
||||
""
|
||||
"\\begin{schemedisplay}"
|
||||
"(let ([close-down"
|
||||
" (gui-utils:delay-action"
|
||||
" 2"
|
||||
" (lambda () .. init watch cursor ...)"
|
||||
" (lambda () .. close watch cursor ...))])"
|
||||
" ;; .. do action ..."
|
||||
" (close-down))"
|
||||
"\\end{schemedisplay}"
|
||||
""
|
||||
"Creates a thread that waits \\var{delay-time}. After \\var{delay-time}"
|
||||
"has elapsed, if the result thunk has {\\em not} been called, call"
|
||||
"\\var{open}. Then, when the result thunk is called, call"
|
||||
"\\var{close}. The function \\var{close} will only be called if"
|
||||
"\\var{open} has been called.")
|
||||
|
||||
(gui-utils:local-busy-cursor
|
||||
(opt->
|
||||
((is-a?/c window<%>)
|
||||
(-> any?))
|
||||
(integer?)
|
||||
any?)
|
||||
((window thunk)
|
||||
((delay (gui-utils:cursor-delay))))
|
||||
"Evaluates \\rawscm{(\\var{thunk})} with a watch cursor in \\var{window}. If"
|
||||
"\\var{window} is \\rawscm{\\#f}, the watch cursor is turned on globally. The"
|
||||
"argument \\var{delay} specifies the amount of time before the watch"
|
||||
"cursor is opened. Use "
|
||||
"@flink gui-utils:cursor-delay "
|
||||
"to set this value for all uses of this function."
|
||||
""
|
||||
"The result of this function is the result of \\var{thunk}.")
|
||||
|
||||
(gui-utils:unsaved-warning
|
||||
(opt->
|
||||
(string?
|
||||
string?)
|
||||
(boolean?
|
||||
(union false?
|
||||
(is-a?/c frame%)
|
||||
(is-a?/c dialog%)))
|
||||
(symbols 'continue 'save 'cancel))
|
||||
((filename action)
|
||||
((can-save-now? #f)
|
||||
(parent #f)))
|
||||
|
||||
"This displays a dialog that warns the user of a unsaved file."
|
||||
""
|
||||
"The string, \\var{action}, indicates what action is about to"
|
||||
"take place, without saving. For example, if the application"
|
||||
"is about to close a file, a good action is \\rawscm{\"Close"
|
||||
"Anyway\"}. The result symbol indicates the user's choice. If"
|
||||
"\\var{can-save-now?} is \\rawscm{\\#f}, this function does not"
|
||||
"give the user the ``Save'' option and thus will not return"
|
||||
"\rawscm{'save}.")
|
||||
|
||||
(gui-utils:get-choice
|
||||
(opt->
|
||||
(string?
|
||||
string?
|
||||
string?)
|
||||
(string?
|
||||
any?
|
||||
(union false? (is-a?/c frame%) (is-a?/c dialog%)))
|
||||
any?)
|
||||
((message true-choice false-choice)
|
||||
((title "Warning")
|
||||
(default-result 'disallow-close)
|
||||
(paren #f)))
|
||||
|
||||
"Opens a dialog that presents a binary choice to the user. The user is forced"
|
||||
"to choose between these two options, ie cancelling or closing the dialog"
|
||||
"opens a message box asking the user to actually choose one of the two options."
|
||||
""
|
||||
"The dialog will contain the string \\var{message} and two buttons,"
|
||||
"labeled with the \\var{true-choice} and the \\var{false-choice}. If the"
|
||||
"user clicks on \\var{true-choice} \\rawscm{\\#t} is returned. If the user"
|
||||
"clicks on \\var{false-choice}, \\rawscm{\\#f} is returned."
|
||||
""
|
||||
"The argument \\var{default-result} determines how closing the window is"
|
||||
"treated. If the argument is \rawscm{'disallow-close}, closing the window"
|
||||
"is not allowed. If it is anything else, that value is returned when"
|
||||
"the user closes the window.")
|
||||
|
||||
;; (gui-utils:open-input-buffer any?) ;; who uses this?!?!
|
||||
|
||||
(gui-utils:get-clicked-clickback-delta
|
||||
(-> (is-a?/c style-delta%))
|
||||
"This delta is designed for use with"
|
||||
"@link text set-clickback %"
|
||||
". Use it as one of the \\iscmclass{style-delta} argument to"
|
||||
"@link text set-clickback %"
|
||||
"."
|
||||
""
|
||||
"See also"
|
||||
"@flink gui-utils:get-clickback-delta %"
|
||||
".")
|
||||
|
||||
(gui-utils:get-clickback-delta
|
||||
(-> (is-a?/c style-delta%))
|
||||
"This delta is designed for use with"
|
||||
"@link text set-clickback %"
|
||||
". Use the result of this function as the style"
|
||||
"for the region"
|
||||
"text where the clickback is set."
|
||||
""
|
||||
"See also"
|
||||
"@flink gui-utils:get-clickback-clicked-delta %"
|
||||
"."))
|
||||
|
||||
(define clickback-delta (make-object style-delta% 'change-underline #t))
|
||||
(send clickback-delta set-delta-foreground "BLUE")
|
||||
|
|
@ -49,8 +193,8 @@
|
|||
[(v) (set! x v) x])))
|
||||
|
||||
(define show-busy-cursor
|
||||
(lambda (thunk)
|
||||
(local-busy-cursor #f thunk)))
|
||||
(opt-lambda (thunk [delay (cursor-delay)])
|
||||
(local-busy-cursor #f thunk delay)))
|
||||
|
||||
(define delay-action
|
||||
(lambda (delay-time open close)
|
||||
|
|
@ -117,6 +261,7 @@
|
|||
(show #f))
|
||||
|
||||
(super-make-object (string-constant warning) parent)
|
||||
|
||||
(let* ([panel (make-object vertical-panel% this)]
|
||||
[msg
|
||||
(make-object message%
|
||||
|
|
@ -127,25 +272,26 @@
|
|||
(make-object button%
|
||||
(string-append action-anyway)
|
||||
button-panel
|
||||
(lambda (x y) (on-dont-save))
|
||||
(let ([now (make-object button%
|
||||
(string-constant save)
|
||||
button-panel
|
||||
(lambda (x y) (on-save-now))
|
||||
(if can-save-now?
|
||||
'(border)
|
||||
'()))]
|
||||
[cancel (make-object button%
|
||||
(string-constant cancel)
|
||||
button-panel
|
||||
(lambda (x y) (on-cancel))
|
||||
(if can-save-now?
|
||||
'()
|
||||
'(border)))])
|
||||
(if can-save-now?
|
||||
(send now focus)
|
||||
(begin (send cancel focus)
|
||||
(send now show #f)))))
|
||||
(lambda (x y) (on-dont-save)))
|
||||
|
||||
(let ([now (make-object button%
|
||||
(string-constant save)
|
||||
button-panel
|
||||
(lambda (x y) (on-save-now))
|
||||
(if can-save-now?
|
||||
'(border)
|
||||
'()))]
|
||||
[cancel (make-object button%
|
||||
(string-constant cancel)
|
||||
button-panel
|
||||
(lambda (x y) (on-cancel))
|
||||
(if can-save-now?
|
||||
'()
|
||||
'(border)))])
|
||||
(if can-save-now?
|
||||
(send now focus)
|
||||
(begin (send cancel focus)
|
||||
(send now show #f))))
|
||||
|
||||
(center 'both)
|
||||
|
||||
|
|
@ -215,52 +361,6 @@
|
|||
(send dialog show #t)
|
||||
result)))
|
||||
|
||||
(define text-snip<%> (interface () get-string))
|
||||
(define read-snips/chars-from-text
|
||||
(letrec ([get-snips
|
||||
(lambda (text start end)
|
||||
(let* ([pos-box (box 0)]
|
||||
[snip (send text find-snip start 'after-or-none pos-box)])
|
||||
(cond
|
||||
[(not snip) null]
|
||||
[(> (+ (unbox pos-box) (send snip get-count)) end) null]
|
||||
[else (cons snip (get-snips text (+ start (send snip get-count)) end))])))])
|
||||
(case-lambda
|
||||
[(text) (read-snips/chars-from-text text 0)]
|
||||
[(text start) (read-snips/chars-from-text text start (send text last-position))]
|
||||
[(text start end)
|
||||
(define pos-box (box 0))
|
||||
(define (get-next)
|
||||
(send text split-snip start)
|
||||
(send text split-snip end)
|
||||
|
||||
;; must get all of the snips out of the buffer before reading -- they may change.
|
||||
(let loop ([snips (get-snips text start end)])
|
||||
|
||||
(cond
|
||||
[(null? snips)
|
||||
(set! get-next (lambda () eof))
|
||||
eof]
|
||||
[(or (is-a? (car snips) string-snip%)
|
||||
(is-a? (car snips) text-snip<%>))
|
||||
(let ([str (if (is-a? (car snips) text-snip<%>)
|
||||
(send (car snips) get-string)
|
||||
(send (car snips) get-text 0 (send (car snips) get-count)))])
|
||||
(let string-loop ([n 0])
|
||||
(cond
|
||||
[(< n (string-length str))
|
||||
(set! get-next (lambda () (string-loop (+ n 1))))
|
||||
(string-ref str n)]
|
||||
[else
|
||||
(loop (cdr snips))])))]
|
||||
[else
|
||||
(set! get-next (lambda () (loop (cdr snips))))
|
||||
(car snips)])))
|
||||
(let ([read-snips/chars-from-text-thunk
|
||||
(lambda ()
|
||||
(get-next))])
|
||||
read-snips/chars-from-text-thunk)])))
|
||||
|
||||
(define open-input-buffer
|
||||
(lambda (buffer)
|
||||
(let ([pos 0]
|
||||
|
|
@ -290,77 +390,13 @@
|
|||
#f
|
||||
void))))
|
||||
|
||||
(define repeated-keystroke-timeout 300)
|
||||
(define alphabetic-list-box%
|
||||
(class list-box%
|
||||
(init-field choices callback)
|
||||
|
||||
(field (chars null)
|
||||
(last-time-stamp #f))
|
||||
|
||||
(rename [super-on-subwindow-event on-subwindow-event]
|
||||
[super-on-subwindow-char on-subwindow-char])
|
||||
(define/override (on-subwindow-event receiver evt)
|
||||
(set! chars null)
|
||||
(super-on-subwindow-event receiver evt))
|
||||
(define/override (on-subwindow-char receiver evt)
|
||||
(let ([code (send evt get-key-code)])
|
||||
(when (or (not (char? code))
|
||||
(and last-time-stamp
|
||||
((- (send evt get-time-stamp) last-time-stamp)
|
||||
. >= .
|
||||
repeated-keystroke-timeout)))
|
||||
(set! chars null))
|
||||
(set! last-time-stamp (send evt get-time-stamp))
|
||||
(cond
|
||||
[(and (char? code) (or (char-alphabetic? code) (char-numeric? code)))
|
||||
(set! chars (cons code chars))
|
||||
(scroll-to-matching)
|
||||
(callback this (instantiate control-event% ()
|
||||
(event-type 'list-box)
|
||||
(time-stamp (send evt get-time-stamp))))]
|
||||
[else
|
||||
(set! chars null)
|
||||
(super-on-subwindow-char receiver evt)])))
|
||||
|
||||
;; scroll-to-matching : -> void
|
||||
;; scrolls the list box to the first string
|
||||
;; that matches the typed chars in `chars'.
|
||||
(define (scroll-to-matching)
|
||||
(let* ([typed-str (apply string (reverse chars))]
|
||||
[typed-len (string-length typed-str)])
|
||||
(let loop ([n 0])
|
||||
(when (< n (get-number))
|
||||
(let ([str (get-string n)])
|
||||
(cond
|
||||
[(and ((string-length str) . >= . typed-len)
|
||||
(string=? typed-str (substring str 0 typed-len)))
|
||||
(set-selection n)
|
||||
(make-visible n)]
|
||||
[else (loop (+ n 1))]))))))
|
||||
(inherit get-number get-string set-selection)
|
||||
|
||||
;; make-visible : number -> void
|
||||
;; scrolls the list box so that the nth item is visible,
|
||||
;; unless the n'th item is already visible, in which case
|
||||
;; it does nothing.
|
||||
(define (make-visible n)
|
||||
(set-first-visible-item n))
|
||||
(inherit set-first-visible-item)
|
||||
|
||||
(super-instantiate ()
|
||||
(choices choices)
|
||||
(callback callback))))
|
||||
|
||||
;; manual renaming
|
||||
(define gui-utils:next-untitled-name next-untitled-name)
|
||||
(define gui-utils:show-busy-cursor show-busy-cursor)
|
||||
(define gui-utils:delay-action delay-action)
|
||||
(define gui-utils:local-busy-cursor local-busy-cursor)
|
||||
(define gui-utils:unsaved-warning unsaved-warning)
|
||||
(define gui-utils:read-snips/chars-from-text read-snips/chars-from-text)
|
||||
(define gui-utils:get-choice get-choice)
|
||||
(define gui-utils:open-input-buffer open-input-buffer)
|
||||
(define gui-utils:get-clicked-clickback-delta get-clicked-clickback-delta)
|
||||
(define gui-utils:get-clickback-delta get-clickback-delta)
|
||||
(define gui-utils:text-snip<%> text-snip<%>))
|
||||
(define gui-utils:get-clickback-delta get-clickback-delta))
|
||||
|
|
|
|||
|
|
@ -868,6 +868,63 @@
|
|||
;; it might not yet be implemented
|
||||
(send canvas focus)))))
|
||||
|
||||
(define open-here<%>
|
||||
(interface (-editor<%>)
|
||||
get-open-here-editor
|
||||
open-here))
|
||||
|
||||
(define open-here-mixin
|
||||
(mixin (-editor<%>) (open-here<%>)
|
||||
(rename [super-file-menu:open-on-demand file-menu:open-on-demand])
|
||||
(define/override (file-menu:open-on-demand item)
|
||||
(super-file-menu:open-on-demand item)
|
||||
(send item set-label (if (preferences:get 'framework:open-here?)
|
||||
(string-constant open-here-menu-item)
|
||||
(string-constant open-menu-item))))
|
||||
|
||||
(rename [super-on-activate on-activate])
|
||||
(define/override (on-activate on?)
|
||||
(super-on-activate on?)
|
||||
(when on?
|
||||
(send (group:get-the-frame-group) set-open-here-frame this)))
|
||||
|
||||
(inherit get-editor)
|
||||
(define/public (get-open-here-editor) (get-editor))
|
||||
(define/public (open-here filename)
|
||||
(let* ([editor (get-open-here-editor)]
|
||||
[okay-to-switch? (user-okays-switch? editor)])
|
||||
(when okay-to-switch?
|
||||
(when (is-a? editor text%)
|
||||
(let* ([b (box #f)]
|
||||
[filename (send editor get-filename b)])
|
||||
(unless (unbox b)
|
||||
(when filename
|
||||
(handler:set-recent-position
|
||||
filename
|
||||
(send editor get-start-position)
|
||||
(send editor get-end-position))))))
|
||||
(send editor load-file filename)
|
||||
(void))))
|
||||
|
||||
(inherit get-label)
|
||||
(define/private (user-okays-switch? ed)
|
||||
(or (not (send ed is-modified?))
|
||||
(let ([answer
|
||||
(gui-utils:unsaved-warning
|
||||
(or (send ed get-filename) (get-label))
|
||||
(string-constant switch-anyway)
|
||||
#t)])
|
||||
(case answer
|
||||
[(continue)
|
||||
#t]
|
||||
[(save)
|
||||
(send ed save-file/gui-error)]
|
||||
[(cancel)
|
||||
#f]))))
|
||||
|
||||
|
||||
(super-instantiate ())))
|
||||
|
||||
(define text<%> (interface (-editor<%>)))
|
||||
(define text-mixin
|
||||
(mixin (-editor<%>) (text<%>)
|
||||
|
|
@ -1842,11 +1899,12 @@
|
|||
(define pasteboard-info% (pasteboard-info-mixin text-info%))
|
||||
(define standard-menus% (standard-menus-mixin pasteboard-info%))
|
||||
(define editor% (editor-mixin standard-menus%))
|
||||
(define open-here% (open-here-mixin editor%))
|
||||
|
||||
(define -text% (text-mixin editor%))
|
||||
(define -text% (text-mixin open-here%))
|
||||
(define text-info-file% (file-mixin -text%))
|
||||
(define searchable% (searchable-text-mixin (searchable-mixin text-info-file%)))
|
||||
(define delegate% (delegate-mixin searchable%))
|
||||
|
||||
(define -pasteboard% (pasteboard-mixin editor%))
|
||||
(define -pasteboard% (pasteboard-mixin open-here%))
|
||||
(define pasteboard-info-file% (file-mixin -pasteboard%)))))
|
||||
|
|
|
|||
|
|
@ -118,6 +118,11 @@
|
|||
(for-each (lambda (a-frame)
|
||||
(set-close-menu-item-state! a-frame #t))
|
||||
frames))))]
|
||||
|
||||
(field (open-here-frame #f))
|
||||
(define/public (set-open-here-frame fr) (set! open-here-frame fr))
|
||||
(define/public (get-open-here-frame) open-here-frame)
|
||||
|
||||
(public get-mdi-parent set-empty-callbacks frame-label-changed for-each-frame
|
||||
get-active-frame set-active-frame insert-frame can-remove-frame?
|
||||
remove-frame clear on-close-all can-close-all? locate-file get-frames
|
||||
|
|
@ -253,7 +258,7 @@
|
|||
(send (get-the-frame-group) get-frames)
|
||||
(lambda (x y) (string-ci<=? (send x get-label) (send y get-label))))]
|
||||
[d (make-object dialog% (string-constant bring-frame-to-front) parent 400 600)]
|
||||
[lb (instantiate gui-utils:alphabetic-list-box% ()
|
||||
[lb (instantiate list-box% ()
|
||||
(label #f)
|
||||
(choices (map (lambda (x) (send x get-label)) sorted-frames))
|
||||
(callback (lambda (x y) (listbox-callback y)))
|
||||
|
|
|
|||
|
|
@ -4,10 +4,12 @@
|
|||
(lib "class.ss")
|
||||
(lib "class100.ss")
|
||||
(lib "list.ss")
|
||||
(lib "hierlist.ss" "hierlist")
|
||||
"sig.ss"
|
||||
"../gui-utils.ss"
|
||||
(lib "mred-sig.ss" "mred")
|
||||
(lib "file.ss"))
|
||||
(lib "file.ss")
|
||||
(lib "string-constant.ss" "string-constants"))
|
||||
|
||||
(provide handler@)
|
||||
|
||||
|
|
@ -110,56 +112,214 @@
|
|||
(let ([already-open (send (group:get-the-frame-group)
|
||||
locate-file
|
||||
filename)])
|
||||
(if already-open
|
||||
(begin
|
||||
(send already-open show #t)
|
||||
already-open)
|
||||
(let ([handler
|
||||
(if (string? filename)
|
||||
(find-format-handler filename)
|
||||
#f)])
|
||||
(add-to-recent filename)
|
||||
(if handler
|
||||
(handler filename)
|
||||
(make-default)))))
|
||||
(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
|
||||
|
||||
(define recent-max-count 10)
|
||||
;; type recent-list-item = (list/p string? number? number?)
|
||||
|
||||
(define recent-max-count 50)
|
||||
|
||||
;; add-to-recent : string -> void
|
||||
(define (add-to-recent filename)
|
||||
(preferences:set 'framework:recently-opened-files
|
||||
(let loop ([n recent-max-count]
|
||||
[new-recent (cons filename
|
||||
(remove
|
||||
filename
|
||||
(preferences:get
|
||||
'framework:recently-opened-files)))])
|
||||
(cond
|
||||
[(zero? n) null]
|
||||
[(null? new-recent) null]
|
||||
[else
|
||||
(cons (car new-recent)
|
||||
(loop (- n 1)
|
||||
(cdr new-recent)))]))))
|
||||
(let* ([old-list (preferences:get 'framework:recently-opened-files/pos)]
|
||||
[old-ents (filter (lambda (x) (string=? (car x) filename)) old-list)]
|
||||
[old-ent (if (null? old-ents)
|
||||
#f
|
||||
(car old-ents))]
|
||||
[new-ent (list filename
|
||||
(if old-ent (cadr old-ent) 0)
|
||||
(if old-ent (caddr old-ent) 0))]
|
||||
[added-in (cons new-ent (remove new-ent old-list compare-recent-list-items))]
|
||||
[new-recent (size-down added-in)])
|
||||
(preferences:set 'framework:recently-opened-files/pos new-recent)))
|
||||
|
||||
;; compare-recent-list-items : recent-list-item recent-list-item -> boolean
|
||||
(define (compare-recent-list-items l1 l2)
|
||||
(string=? (car l1) (car l2)))
|
||||
|
||||
;; size-down : (listof X) -> (listof X)[< recent-max-count]
|
||||
;; takes a list of stuff and returns the
|
||||
;; front of the list, up to `recent-max-count' items
|
||||
(define (size-down new-recent)
|
||||
(let loop ([n recent-max-count]
|
||||
[new-recent new-recent])
|
||||
(cond
|
||||
[(zero? n) null]
|
||||
[(null? new-recent) null]
|
||||
[else
|
||||
(cons (car new-recent)
|
||||
(loop (- n 1)
|
||||
(cdr new-recent)))])))
|
||||
|
||||
;; set-recent-position : string number number -> void
|
||||
;; updates the recent menu preferences
|
||||
;; with the positions `start' and `end'
|
||||
(define (set-recent-position filename start end)
|
||||
(let ([recent-items
|
||||
(filter (lambda (x) (string=? (car x) filename))
|
||||
(preferences:get 'framework:recently-opened-files/pos))])
|
||||
(unless (null? recent-items)
|
||||
(let ([recent-item (car recent-items)])
|
||||
(set-car! (cdr recent-item) start)
|
||||
(set-car! (cddr recent-item) end)))))
|
||||
|
||||
;; install-recent-items : (is-a?/c menu%) -> void?
|
||||
(define (install-recent-items menu)
|
||||
(let ([recently-opened-files
|
||||
(preferences:get
|
||||
'framework:recently-opened-files)])
|
||||
'framework:recently-opened-files/pos)])
|
||||
(for-each (lambda (item) (send item delete))
|
||||
(send menu get-items))
|
||||
(cond
|
||||
[(null? recently-opened-files)
|
||||
(send menu enable #f)]
|
||||
[else
|
||||
(send menu enable #t)
|
||||
(for-each (lambda (filename)
|
||||
(instantiate menu-item% ()
|
||||
(parent menu)
|
||||
(label filename)
|
||||
(callback (lambda (x y) (edit-file filename)))))
|
||||
recently-opened-files)])))
|
||||
|
||||
(instantiate menu-item% ()
|
||||
(parent menu)
|
||||
(label (string-constant show-recent-items-window-menu-item))
|
||||
(callback (lambda (x y) (show-recent-items-window))))
|
||||
|
||||
(instantiate separator-menu-item% ()
|
||||
(parent menu))
|
||||
|
||||
(for-each (lambda (recent-list-item)
|
||||
(let ([filename (car recent-list-item)])
|
||||
(instantiate menu-item% ()
|
||||
(parent menu)
|
||||
(label filename)
|
||||
(callback (lambda (x y) (open-recent-list-item recent-list-item))))))
|
||||
recently-opened-files)))
|
||||
|
||||
;; open-recent-list-item : recent-list-item -> void
|
||||
(define (open-recent-list-item recent-list-item)
|
||||
(let* ([filename (car recent-list-item)]
|
||||
[start (cadr recent-list-item)]
|
||||
[end (caddr recent-list-item)]
|
||||
[fr (edit-file filename)])
|
||||
(when (is-a? fr frame:open-here<%>)
|
||||
(let ([ed (send fr get-open-here-editor)])
|
||||
(when (equal? (send ed get-filename) filename)
|
||||
(send ed set-position start end))))))
|
||||
|
||||
;; show-recent-items-window : -> void
|
||||
(define (show-recent-items-window)
|
||||
(unless recent-items-window
|
||||
(set! recent-items-window (make-recent-items-window)))
|
||||
(send recent-items-window show #t))
|
||||
|
||||
;; make-recent-items-window : -> frame
|
||||
(define (make-recent-items-window)
|
||||
(make-object recent-items-window%
|
||||
(string-constant show-recent-items-window-label)
|
||||
#f
|
||||
(preferences:get 'framework:recent-items-window-w)
|
||||
(preferences:get 'framework:recent-items-window-h)))
|
||||
|
||||
;; recent-items-window : (union #f (is-a?/c frame%))
|
||||
(define recent-items-window #f)
|
||||
|
||||
(define recent-items-hierarchical-list%
|
||||
(class hierarchical-list%
|
||||
(define/override (on-double-select item)
|
||||
(send item open-item))
|
||||
(super-instantiate ())))
|
||||
|
||||
(define recent-items-window%
|
||||
(class (frame:standard-menus-mixin frame:basic%)
|
||||
|
||||
;; remove extraneous separators
|
||||
(define/override (file-menu:between-print-and-close menu) (void))
|
||||
(define/override (edit-menu:between-find-and-preferences menu) (void))
|
||||
|
||||
(define/override (on-size w h)
|
||||
(preferences:set 'framework:recent-items-window-w w)
|
||||
(preferences:set 'framework:recent-items-window-h h))
|
||||
|
||||
;; refresh-hl : (listof recent-list-item) -> void
|
||||
(define/private (refresh-hl recent-list-items)
|
||||
(let ([ed (send hl get-editor)])
|
||||
(send ed begin-edit-sequence)
|
||||
(for-each (lambda (item) (send hl delete-item item)) (send hl get-items))
|
||||
(for-each (lambda (item) (add-recent-item item))
|
||||
(if (eq? (preferences:get 'framework:recently-opened-sort-by) 'name)
|
||||
(quicksort recent-list-items
|
||||
(lambda (x y) (string<=? (car x) (car y))))
|
||||
recent-list-items))
|
||||
(send ed end-edit-sequence)))
|
||||
|
||||
(define/private (add-recent-item recent-list-item)
|
||||
(let ([item (send hl new-item (make-hierlist-item-mixin recent-list-item))])
|
||||
(send (send item get-editor) insert (car recent-list-item))))
|
||||
|
||||
(field [remove-prefs-callback
|
||||
(preferences:add-callback
|
||||
'framework:recently-opened-files/pos
|
||||
(lambda (p v)
|
||||
(refresh-hl v)))])
|
||||
|
||||
(define/override (on-close)
|
||||
(remove-prefs-callback)
|
||||
(set! recent-items-window #f))
|
||||
|
||||
(super-instantiate ())
|
||||
|
||||
(inherit get-area-container)
|
||||
(field [bp (make-object horizontal-panel% (get-area-container))]
|
||||
[hl (make-object recent-items-hierarchical-list% (get-area-container))]
|
||||
[sort-by-name-button
|
||||
(make-object button%
|
||||
(string-constant sort-by-name)
|
||||
bp
|
||||
(lambda (x y) (set-sort-by 'name)))]
|
||||
[sort-by-age-button
|
||||
(make-object button%
|
||||
(string-constant sort-by-age)
|
||||
bp
|
||||
(lambda (x y) (set-sort-by 'age)))])
|
||||
|
||||
(send bp stretchable-height #f)
|
||||
(send sort-by-name-button stretchable-width #t)
|
||||
(send sort-by-age-button stretchable-width #t)
|
||||
|
||||
(define/private (set-sort-by flag)
|
||||
(preferences:set 'framework:recently-opened-sort-by flag)
|
||||
(case flag
|
||||
[(name)
|
||||
(send sort-by-age-button enable #t)
|
||||
(send sort-by-name-button enable #f)]
|
||||
[(age)
|
||||
(send sort-by-age-button enable #f)
|
||||
(send sort-by-name-button enable #t)])
|
||||
(refresh-hl (preferences:get 'framework:recently-opened-files/pos)))
|
||||
|
||||
(set-sort-by (preferences:get 'framework:recently-opened-sort-by))))
|
||||
|
||||
;; make-hierlist-item-mixin : recent-item -> mixin(arg to new-item method of hierlist)
|
||||
(define (make-hierlist-item-mixin recent-item)
|
||||
(lambda (%)
|
||||
(class %
|
||||
(define/public (open-item)
|
||||
(open-recent-list-item recent-item))
|
||||
(super-instantiate ()))))
|
||||
|
||||
(define *open-directory* ; object to remember last directory
|
||||
(make-object
|
||||
|
|
|
|||
|
|
@ -17,10 +17,23 @@
|
|||
[group : framework:group^])
|
||||
|
||||
;; preferences
|
||||
|
||||
(preferences:set-default 'framework:recently-opened-sort-by 'age
|
||||
(lambda (x) (or (eq? x 'age) (eq? x 'name))))
|
||||
(preferences:set-default 'framework:recent-items-window-w 400 number?)
|
||||
(preferences:set-default 'framework:recent-items-window-h 600 number?)
|
||||
(preferences:set-default 'framework:open-here? #f boolean?)
|
||||
(preferences:set-default 'framework:show-delegate? #f boolean?)
|
||||
(preferences:set-default 'framework:recently-opened-files null
|
||||
(lambda (x) (and (list? x) (andmap string? x))))
|
||||
(preferences:set-default 'framework:recently-opened-files/pos
|
||||
null
|
||||
(lambda (x) (and (list? x)
|
||||
(andmap
|
||||
(lambda (x)
|
||||
(and (list? x)
|
||||
(= 3 (length x))
|
||||
(string? (car x))
|
||||
(number? (cadr x))
|
||||
(number? (caddr x))))
|
||||
x))))
|
||||
(preferences:set-default 'framework:search-using-dialog? #t boolean?)
|
||||
(preferences:set-default 'framework:windows-mdi #f boolean?)
|
||||
(preferences:set-default 'framework:menu-bindings #t boolean?)
|
||||
|
|
|
|||
|
|
@ -387,6 +387,9 @@
|
|||
(make-check 'framework:search-using-dialog?
|
||||
(string-constant separate-dialog-for-searching)
|
||||
id id)
|
||||
(make-check 'framework:open-here?
|
||||
(string-constant reuse-existing-frames)
|
||||
id id)
|
||||
|
||||
main)))
|
||||
(set! local-add-general-panel void))
|
||||
|
|
|
|||
|
|
@ -301,6 +301,7 @@
|
|||
(basic<%>
|
||||
standard-menus<%>
|
||||
editor<%>
|
||||
open-here<%>
|
||||
text<%>
|
||||
pasteboard<%>
|
||||
delegate<%>
|
||||
|
|
@ -326,6 +327,7 @@
|
|||
basic-mixin
|
||||
standard-menus-mixin
|
||||
editor-mixin
|
||||
open-here-mixin
|
||||
text-mixin
|
||||
pasteboard-mixin
|
||||
delegate-mixin
|
||||
|
|
@ -362,7 +364,8 @@
|
|||
edit-file
|
||||
open-file
|
||||
install-recent-items
|
||||
add-to-recent))
|
||||
add-to-recent
|
||||
set-recent-position))
|
||||
(define-signature framework:handler^
|
||||
((open framework:handler-class^)
|
||||
(open framework:handler-fun^)))
|
||||
|
|
|
|||
|
|
@ -11,43 +11,204 @@
|
|||
(syntax (provide/contract (name contract) ...))]))
|
||||
|
||||
(provide/contract/docs
|
||||
(test:run-interval any?)
|
||||
(test:reraise-error any?)
|
||||
(test:run-one any?)
|
||||
(test:current-get-eventspaces any?)
|
||||
(test:close-top-level-window any?)
|
||||
|
||||
;; (frame-has? f p) =
|
||||
(test:run-interval
|
||||
(case->
|
||||
(number? . -> . void?)
|
||||
(-> number?))
|
||||
((msec) ())
|
||||
"See also"
|
||||
"\\hyperref{Actions and completeness}{Actions and completeness, section~}{}{fw:actions-completeness}."
|
||||
"The first case in the case-lambda sets"
|
||||
"the run interval to \\var{msec} milliseconds and the second"
|
||||
"returns the current setting.")
|
||||
|
||||
(test:reraise-error
|
||||
(-> void?)
|
||||
()
|
||||
"See also"
|
||||
"\\hyperref{Errors}{Errors, section~}{}{fw:test:errors}.")
|
||||
|
||||
(test:run-one
|
||||
((-> void?) . -> . void?)
|
||||
(f)
|
||||
"Runs the function \\var{f} as if it was a simulated event. See also"
|
||||
"\\hyperref{the test section}{section ~}{}{fw:test}.")
|
||||
|
||||
(test:current-get-eventspaces
|
||||
(case->
|
||||
((-> (listof eventspace?)) . -> . void?)
|
||||
(-> (-> (listof eventspace?))))
|
||||
((func) ())
|
||||
|
||||
"This parameter that specifies which "
|
||||
"\\hyperref{eventspaces}{eventspace (see section~}{)}{eventspaceinfo}"
|
||||
"are considered when finding the frontmost frame."
|
||||
|
||||
"The first case"
|
||||
"sets the parameter to \\var{func}. The procedure \\var{func} will be"
|
||||
"invoked with no arguments to determine the eventspaces to consider"
|
||||
"when finding the frontmost frame for simulated user events."
|
||||
|
||||
"The second case"
|
||||
"returns the current value of the parameter. This will be a procedure"
|
||||
"which, when invoked, returns a list of eventspaces.")
|
||||
(test:close-top-level-window
|
||||
((is-a?/c top-level-window<%>) . -> . void?)
|
||||
(tlw)
|
||||
"Use this function to simulate clicking on the close box of a frame."
|
||||
"Closes \var{tlw} with this expression:"
|
||||
""
|
||||
"\\begin{schemedisplay}"
|
||||
"(when (send tlw can-close?)"
|
||||
" (send tlw on-close)"
|
||||
" (send tlw show #f))"
|
||||
"\\end{schemedisplay}")
|
||||
|
||||
(test:top-level-focus-window-has?
|
||||
(((is-a?/c area<%>) . -> . boolean?) . -> . boolean?)
|
||||
(test)
|
||||
"Calls \\var{test} for each child of the top-level-focus-frame"
|
||||
"and returns \\scheme|#t| if \\var{test} ever does, otherwise"
|
||||
"returns \\scheme|#f|. If there"
|
||||
"is no top-level-focus-window, returns \\scheme|#f|.")
|
||||
|
||||
;; ((frame-has? p) f) =
|
||||
;; f is a frame and it has a child (in it or a subpanel) that responds #t to p
|
||||
(test:button-push any?)
|
||||
#|
|
||||
((union (lambda (str)
|
||||
(and (string? str)
|
||||
(frame-has? (get-top-level-focus-window)
|
||||
(lambda (x)
|
||||
(and (is-a? x button%)
|
||||
(string=? (send x get-label) str)
|
||||
(send x is-enabled?)
|
||||
(send x is-shown?))))))
|
||||
(lambda (btn)
|
||||
(and (is-a? btn button%)
|
||||
(frame-has? (get-top-level-focus-window)
|
||||
(lambda (x)
|
||||
(and (eq? x btn)
|
||||
(send x is-enabled?)
|
||||
(send x is-shown?)))))))
|
||||
->
|
||||
void)
|
||||
|#
|
||||
(test:set-radio-box! any?)
|
||||
(test:set-radio-box-item! any?)
|
||||
(test:set-check-box! any?)
|
||||
(test:set-choice! any?)
|
||||
(test:keystroke any?)
|
||||
(test:menu-select any?)
|
||||
(test:mouse-click any?)
|
||||
(test:new-window any?))
|
||||
|
||||
(test:button-push
|
||||
((union (and/f string?
|
||||
(lambda (str)
|
||||
(test:top-level-focus-window-has?
|
||||
(lambda (c)
|
||||
(and (is-a? c button%)
|
||||
(string=? (send c get-label) str)
|
||||
(send c is-enabled?)
|
||||
(send c is-shown?))))))
|
||||
(and/f (is-a?/c button%)
|
||||
(lambda (btn)
|
||||
(and (send btn is-enabled?)
|
||||
(send btn is-shown?)))
|
||||
(lambda (btn)
|
||||
(test:top-level-focus-window-has?
|
||||
(lambda (c) (eq? c btn))))))
|
||||
. -> .
|
||||
void?)
|
||||
(button)
|
||||
"Simulates pushing \\var{button}. If a string is supplied, the"
|
||||
"primitive searches for a button labelled with that string in the"
|
||||
"active frame. Otherwise, it pushes the button argument.")
|
||||
|
||||
(test:set-radio-box!
|
||||
((is-a?/c radio-box%) (union string? number?) . -> . void?)
|
||||
(radio-box state)
|
||||
"Sets the radio-box to \\var{state}. If \\var{state} is a"
|
||||
"string, this function finds the choice with that label and"
|
||||
"if it is a number, it uses the number as an index into the"
|
||||
"state. If the number is out of range or if the label isn't"
|
||||
"in the radio box, an exception is raised."
|
||||
""
|
||||
"If \\var{radio-box} is a string, this function searches for a"
|
||||
"\\iscmclass{radio-box} with a label matching that string,"
|
||||
"otherwise it uses \\var{radio-box} itself.")
|
||||
|
||||
(test:set-radio-box-item!
|
||||
(string? . -> . void?)
|
||||
(entry)
|
||||
"Finds a \\iscmclass{radio-box} that has a label \\var{entry}"
|
||||
"and sets the radio-box to \\var{entry}.")
|
||||
(test:set-check-box!
|
||||
((is-a?/c check-box%) boolean? . -> . void?)
|
||||
(check-box state)
|
||||
"Clears the \\iscmclass{check-box} item if \\var{state} is \\rawscm{\\#f}, and sets it"
|
||||
"otherwise."
|
||||
""
|
||||
"If \\var{check-box} is a string,"
|
||||
"this function searches for a \\iscmclass{check-box} with a label matching that string,"
|
||||
"otherwise it uses \var{check-box} itself.")
|
||||
(test:set-choice!
|
||||
((is-a?/c choice%) string? . -> . void?)
|
||||
(choice str)
|
||||
"Selects \\var{choice}'s item \\var{str}. If \\var{choice} is a string,"
|
||||
"this function searches for a \\iscmclass{choice} with a label matching"
|
||||
"that string, otherwise it uses \\var{choice} itself.")
|
||||
(test:keystroke
|
||||
(opt->
|
||||
((union char? symbol?))
|
||||
((listof (symbols 'alt 'control 'meta 'shift 'noalt 'nocontrol 'nometea 'noshift)))
|
||||
void?)
|
||||
((key)
|
||||
((modifier-list null)))
|
||||
"This function simulates a user pressing a key. The argument, \\var{key},"
|
||||
"is just like the argument to the"
|
||||
"@link key-event get-key-code"
|
||||
"method of the"
|
||||
"@link key-event"
|
||||
"class. "
|
||||
""
|
||||
"{\\it Note:}"
|
||||
"To send the ``Enter'' key, use \\verb|#\return|,"
|
||||
"not \\verb|#\newline|."
|
||||
""
|
||||
"The \\rawscm{'shift} or \\rawscm{'noshift} modifier is implicitly set from \\var{key},"
|
||||
"but is overridden by the argument list. The \\rawscm{'shift} modifier is"
|
||||
"set for any capitol alpha-numeric letters and any of the following characters:"
|
||||
"\\begin{schemedisplay}"
|
||||
"#\\? #\\: #\\~ #\\\\ #\\|"
|
||||
"#\\< #\\> #\\{ #\\} #\\[ #\\] #\\( #\\)"
|
||||
"#\\! #\\@ #\\# #\\$ #\\% #\\^ #\\& #\\* #\\_ #\\+"
|
||||
"\\end{schemedisplay}"
|
||||
""
|
||||
"If conflicting modifiers are provided, the ones later in the list are used.")
|
||||
|
||||
(test:menu-select
|
||||
(string? string? . -> . void?)
|
||||
(menu item)
|
||||
"Selects the menu-item named \var{item} in the menu named \var{menu}."
|
||||
""
|
||||
"{\\it Note:}"
|
||||
"The string for the menu item does not include its keyboard equivalent."
|
||||
"For example, to select ``New'' from the ``File'' menu, "
|
||||
"use ``New'', not ``New Ctrl+m n''.")
|
||||
(test:mouse-click
|
||||
(opt->
|
||||
((symbols 'left 'middle 'right)
|
||||
inexact?
|
||||
inexact?)
|
||||
((listof (symbols 'alt 'control 'meta 'shift 'noalt 'nocontrol 'nometa 'noshift)))
|
||||
void?)
|
||||
((button x y)
|
||||
((modifiers null)))
|
||||
"Simulates a mouse click at the coordinate: $(x,y)$ in the currently"
|
||||
"focused \\iscmintf{window}, assuming that it supports the "
|
||||
"@ilink canvas on-event"
|
||||
"method."
|
||||
"Use"
|
||||
"@flink test:button-push"
|
||||
"to click on a button."
|
||||
""
|
||||
"On the Macintosh, \\rawscm{'right} corresponds to holding down the command"
|
||||
"modifier key while clicking and \\rawscm{'middle} cannot be generated."
|
||||
""
|
||||
"Under Windows, \\rawscm{'middle} can only be generated if the user has a"
|
||||
"three button mouse."
|
||||
""
|
||||
"The modifiers later in the list \\var{modifiers} take precedence over"
|
||||
"ones that appear earlier.")
|
||||
|
||||
(test:new-window
|
||||
((is-a?/c window<%>) . -> . void?)
|
||||
(window)
|
||||
"Moves the keyboard focus to a new window within the currently active"
|
||||
"frame. Unfortunately, neither this function nor any other function in"
|
||||
"the test engine can cause the focus to move from the top-most (active)"
|
||||
"frame. "))
|
||||
|
||||
(define (test:top-level-focus-window-has? pred)
|
||||
(let ([tlw (get-top-level-focus-window)])
|
||||
(and tlw
|
||||
(let loop ([tlw tlw])
|
||||
(or (pred tlw)
|
||||
(ormap loop (send tlw get-children)))))))
|
||||
|
||||
(define initial-run-interval 0) ;; milliseconds
|
||||
|
||||
;;
|
||||
|
|
@ -821,13 +982,11 @@
|
|||
(send new-window focus)
|
||||
(void))))]))))
|
||||
|
||||
|
||||
(define (close-top-level-window tlw)
|
||||
(when (send tlw can-close?)
|
||||
(send tlw on-close)
|
||||
(send tlw show #f)))
|
||||
|
||||
|
||||
;; manual renaming
|
||||
(define test:run-interval run-interval)
|
||||
(define test:number-pending-actions number-pending-actions)
|
||||
|
|
@ -843,4 +1002,4 @@
|
|||
(define test:keystroke keystroke)
|
||||
(define test:menu-select menu-select)
|
||||
(define test:mouse-click mouse-click)
|
||||
(define test:new-window new-window))
|
||||
(define test:new-window new-window))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user