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

fixed a bug in preferences reading

Browse Source 
svn: r5158
This commit is contained in:
Robby Findler 2006-12-22 00:22:17 +00:00
parent 01a4a5c804
commit 41675aa2ec
4 changed files with 399 additions and 385 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

41
collects/framework/private/finder.ss
View File

@ -65,24 +65,24 @@
#f] #f]
[else f])))))) [else f]))))))
(define (*get-file style) (define (*get-file style)
(opt-lambda ([directory #f] (opt-lambda ([directory #f]
[prompt (string-constant select-file)] [prompt (string-constant select-file)]
[filter #f] [filter #f]
[filter-msg (string-constant file-wrong-form)] [filter-msg (string-constant file-wrong-form)]
[parent-win (dialog-parent-parameter)]) [parent-win (dialog-parent-parameter)])
(let ([f (get-file prompt parent-win directory #f #f style)]) (let ([f (get-file prompt parent-win directory #f #f style)])
(and f (or (not filter) (filter-match? filter f filter-msg)) (and f (or (not filter) (filter-match? filter f filter-msg))
(let ([f (normalize-path f)]) (let ([f (normalize-path f)])
(cond [(directory-exists? f) (cond [(directory-exists? f)
(message-box (string-constant error) (message-box (string-constant error)
(string-constant that-is-dir-name)) (string-constant that-is-dir-name))
#f] #f]
[(not (file-exists? f)) [(not (file-exists? f))
(message-box (string-constant error) (message-box (string-constant error)
(string-constant file-dne)) (string-constant file-dne))
#f] #f]
[else f])))))) [else f]))))))
;; external interfaces to file functions ;; external interfaces to file functions
@ -94,13 +94,14 @@
(define -put-file (define -put-file
(λ args (λ args
(apply (case (preferences:get 'framework:file-dialogs) (printf "put-file ~s\n" (preferences:get 'framework:file-dialogs))
(apply (case (preferences:get 'framework:file-dialogs)
[(std) std-put-file] [(std) std-put-file]
[(common) common-put-file]) [(common) common-put-file])
args))) args)))
(define -get-file (define -get-file
(λ args (λ args
(apply (case (preferences:get 'framework:file-dialogs) (apply (case (preferences:get 'framework:file-dialogs)
[(std) std-get-file] [(std) std-get-file]
[(common) common-get-file]) [(common) common-get-file])
args)))) args))))

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

@ -19,375 +19,374 @@
(export framework:handler^) (export framework:handler^)
(init-depend framework:frame^) (init-depend framework:frame^)
(define-struct handler (name extension handler)) (define-struct handler (name extension handler))
(define format-handlers '()) (define format-handlers '())
(define make-insert-handler (define make-insert-handler
(letrec ([string-list? (letrec ([string-list?
(λ (l) (λ (l)
(cond (cond
[(null? l) #t] [(null? l) #t]
[(not (pair? l)) #f] [(not (pair? l)) #f]
[else [else
(and (string? (car l)) (and (string? (car l))
(string-list? (cdr l)))]))]) (string-list? (cdr l)))]))])
(λ (who name extension handler) (λ (who name extension handler)
(cond (cond
[(not (string? name)) [(not (string? name))
(error who "name was not a string")] (error who "name was not a string")]
[(and (not (procedure? extension)) [(and (not (procedure? extension))
(not (string? extension)) (not (string? extension))
(not (string-list? extension))) (not (string-list? extension)))
(error who (error who
"extension was not a string, list of strings, or a predicate")] "extension was not a string, list of strings, or a predicate")]
[(not (procedure? handler)) [(not (procedure? handler))
(error who "handler was not a function")] (error who "handler was not a function")]
[else (make-handler name [else (make-handler name
(if (string? extension) (if (string? extension)
(list extension) (list extension)
extension) extension)
handler)])))) handler)]))))
(define insert-format-handler (define insert-format-handler
(λ args (λ args
(set! format-handlers (set! format-handlers
(cons (apply make-insert-handler 'insert-format-handler args) (cons (apply make-insert-handler 'insert-format-handler args)
format-handlers)))) format-handlers))))
(define find-handler (define find-handler
(λ (name handlers) (λ (name handlers)
(let/ec exit (let/ec exit
(let ([extension (if (string? name) (let ([extension (if (string? name)
(or (filename-extension name) (or (filename-extension name)
"") "")
"")]) "")])
(for-each (for-each
(λ (handler) (λ (handler)
(let ([ext (handler-extension handler)]) (let ([ext (handler-extension handler)])
(when (or (and (procedure? ext) (when (or (and (procedure? ext)
(ext name)) (ext name))
(and (pair? ext) (and (pair? ext)
(ormap (λ (ext) (string=? ext extension)) (ormap (λ (ext) (string=? ext extension))
ext))) ext)))
(exit (handler-handler handler))))) (exit (handler-handler handler)))))
handlers) handlers)
#f)))) #f))))
(define find-format-handler (define find-format-handler
(λ (name) (λ (name)
(find-handler name format-handlers))) (find-handler name format-handlers)))
; Finding format & mode handlers by name ; Finding format & mode handlers by name
(define find-named-handler (define find-named-handler
(λ (name handlers) (λ (name handlers)
(let loop ([l handlers]) (let loop ([l handlers])
(cond (cond
[(null? l) #f] [(null? l) #f]
[(string-ci=? (handler-name (car l)) name) [(string-ci=? (handler-name (car l)) name)
(handler-handler (car l))] (handler-handler (car l))]
[else (loop (cdr l))])))) [else (loop (cdr l))]))))
(define find-named-format-handler (define find-named-format-handler
(λ (name) (λ (name)
(find-named-handler name format-handlers))) (find-named-handler name format-handlers)))
; Open a file for editing ; Open a file for editing
(define current-create-new-window (define current-create-new-window
(make-parameter (make-parameter
(λ (filename) (λ (filename)
(let ([frame (make-object frame:text% filename)]) (let ([frame (make-object frame:text% filename)])
(send frame show #t) (send frame show #t)
frame)))) frame))))
(define edit-file (define edit-file
(case-lambda (case-lambda
[(filename) (edit-file [(filename) (edit-file
filename filename
(λ () (λ ()
((current-create-new-window) filename)))] ((current-create-new-window) filename)))]
[(filename make-default) [(filename make-default)
(with-handlers ([(λ (x) #f) ;exn:fail? (with-handlers ([(λ (x) #f) ;exn:fail?
(λ (exn) (λ (exn)
(message-box (message-box
(string-constant error-loading) (string-constant error-loading)
(string-append (string-append
(format (string-constant error-loading-file/name) (format (string-constant error-loading-file/name)
(or filename (or filename
(string-constant unknown-filename))) (string-constant unknown-filename)))
"\n\n" "\n\n"
(if (exn? exn) (if (exn? exn)
(format "~a" (exn-message exn)) (format "~a" (exn-message exn))
(format "~s" exn)))) (format "~s" exn))))
#f)]) #f)])
(gui-utils:show-busy-cursor (gui-utils:show-busy-cursor
(λ () (λ ()
(if filename (if filename
(let ([already-open (send (group:get-the-frame-group) (let ([already-open (send (group:get-the-frame-group)
locate-file locate-file
filename)]) filename)])
(cond (cond
[already-open [already-open
(send already-open make-visible filename) (send already-open make-visible filename)
(send already-open show #t) (send already-open show #t)
already-open] already-open]
[(and (preferences:get 'framework:open-here?) [(and (preferences:get 'framework:open-here?)
(send (group:get-the-frame-group) get-open-here-frame)) (send (group:get-the-frame-group) get-open-here-frame))
=> =>
(λ (fr) (λ (fr)
(add-to-recent filename) (add-to-recent filename)
(send fr open-here filename) (send fr open-here filename)
(send fr show #t) (send fr show #t)
fr)] fr)]
[else [else
(let ([handler (let ([handler
(if (path? filename) (if (path? filename)
(find-format-handler filename) (find-format-handler filename)
#f)]) #f)])
(add-to-recent filename) (add-to-recent filename)
(if handler (if handler
(handler filename) (handler filename)
(make-default)))])) (make-default)))]))
(make-default)))))])) (make-default)))))]))
;; type recent-list-item = (list/p string? number? number?) ;; type recent-list-item = (list/p string? number? number?)
;; add-to-recent : path -> void ;; add-to-recent : path -> void
(define (add-to-recent filename) (define (add-to-recent filename)
(let* ([old-list (preferences:get 'framework:recently-opened-files/pos)] (let* ([old-list (preferences:get 'framework:recently-opened-files/pos)]
[old-ents (filter (λ (x) (string=? (path->string (car x)) [old-ents (filter (λ (x) (string=? (path->string (car x))
(path->string filename))) (path->string filename)))
old-list)] old-list)]
[old-ent (if (null? old-ents) [old-ent (if (null? old-ents)
#f #f
(car old-ents))] (car old-ents))]
[new-ent (list filename [new-ent (list filename
(if old-ent (cadr old-ent) 0) (if old-ent (cadr old-ent) 0)
(if old-ent (caddr old-ent) 0))] (if old-ent (caddr old-ent) 0))]
[added-in (cons new-ent (remove new-ent old-list compare-recent-list-items))] [added-in (cons new-ent (remove new-ent old-list compare-recent-list-items))]
[new-recent (size-down added-in (preferences:get 'framework:recent-max-count))]) [new-recent (size-down added-in (preferences:get 'framework:recent-max-count))])
(preferences:set 'framework:recently-opened-files/pos new-recent))) (preferences:set 'framework:recently-opened-files/pos new-recent)))
;; compare-recent-list-items : recent-list-item recent-list-item -> boolean ;; compare-recent-list-items : recent-list-item recent-list-item -> boolean
(define (compare-recent-list-items l1 l2) (define (compare-recent-list-items l1 l2)
(string=? (path->string (car l1)) (string=? (path->string (car l1))
(path->string (car l2)))) (path->string (car l2))))
;; size-down : (listof X) -> (listof X)[< recent-max-count] ;; size-down : (listof X) -> (listof X)[< recent-max-count]
;; takes a list of stuff and returns the ;; takes a list of stuff and returns the
;; front of the list, up to `recent-max-count' items ;; front of the list, up to `recent-max-count' items
(define (size-down new-recent n) (define (size-down new-recent n)
(let loop ([n n] (let loop ([n n]
[new-recent new-recent]) [new-recent new-recent])
(cond (cond
[(zero? n) null] [(zero? n) null]
[(null? new-recent) null] [(null? new-recent) null]
[else [else
(cons (car new-recent) (cons (car new-recent)
(loop (- n 1) (loop (- n 1)
(cdr new-recent)))]))) (cdr new-recent)))])))
;; size-recently-opened-files : number -> void ;; size-recently-opened-files : number -> void
;; sets the recently-opened-files/pos preference ;; sets the recently-opened-files/pos preference
;; to a size limited by `n' ;; to a size limited by `n'
(define (size-recently-opened-files n) (define (size-recently-opened-files n)
(preferences:set (preferences:set
'framework:recently-opened-files/pos 'framework:recently-opened-files/pos
(size-down (preferences:get 'framework:recently-opened-files/pos) (size-down (preferences:get 'framework:recently-opened-files/pos)
n))) n)))
;; set-recent-position : path number number -> void ;; set-recent-position : path number number -> void
;; updates the recent menu preferences ;; updates the recent menu preferences
;; with the positions `start' and `end' ;; with the positions `start' and `end'
(define (set-recent-position filename start end) (define (set-recent-position filename start end)
(let ([recent-items (let ([recent-items
(filter (λ (x) (string=? (path->string (car x)) (filter (λ (x) (string=? (path->string (car x))
(path->string filename))) (path->string filename)))
(preferences:get 'framework:recently-opened-files/pos))]) (preferences:get 'framework:recently-opened-files/pos))])
(unless (null? recent-items) (unless (null? recent-items)
(let ([recent-item (car recent-items)]) (let ([recent-item (car recent-items)])
(set-car! (cdr recent-item) start) (set-car! (cdr recent-item) start)
(set-car! (cddr recent-item) end))))) (set-car! (cddr recent-item) end)))))
;; install-recent-items : (is-a?/c menu%) -> void? ;; install-recent-items : (is-a?/c menu%) -> void?
(define (install-recent-items menu) (define (install-recent-items menu)
(let ([recently-opened-files (let ([recently-opened-files
(preferences:get (preferences:get
'framework:recently-opened-files/pos)]) 'framework:recently-opened-files/pos)])
(for-each (λ (item) (send item delete)) (for-each (λ (item) (send item delete))
(send menu get-items)) (send menu get-items))
(instantiate menu-item% () (instantiate menu-item% ()
(parent menu) (parent menu)
(label (string-constant show-recent-items-window-menu-item)) (label (string-constant show-recent-items-window-menu-item))
(callback (λ (x y) (show-recent-items-window)))) (callback (λ (x y) (show-recent-items-window))))
(instantiate separator-menu-item% () (instantiate separator-menu-item% ()
(parent menu)) (parent menu))
(for-each (λ (recent-list-item) (for-each (λ (recent-list-item)
(let ([filename (car recent-list-item)]) (let ([filename (car recent-list-item)])
(instantiate menu-item% () (instantiate menu-item% ()
(parent menu) (parent menu)
(label (gui-utils:trim-string (label (gui-utils:trim-string
(regexp-replace* (regexp-replace*
"&" "&"
(path->string filename) (path->string filename)
"&&") "&&")
200)) 200))
(callback (λ (x y) (open-recent-list-item recent-list-item)))))) (callback (λ (x y) (open-recent-list-item recent-list-item))))))
recently-opened-files) recently-opened-files)
(void))) (void)))
;; open-recent-list-item : recent-list-item -> void ;; open-recent-list-item : recent-list-item -> void
(define (open-recent-list-item recent-list-item) (define (open-recent-list-item recent-list-item)
(let* ([filename (car recent-list-item)] (let* ([filename (car recent-list-item)]
[start (cadr recent-list-item)] [start (cadr recent-list-item)]
[end (caddr recent-list-item)]) [end (caddr recent-list-item)])
(cond (cond
[(file-exists? filename) [(file-exists? filename)
(let ([fr (edit-file filename)]) (let ([fr (edit-file filename)])
(when (is-a? fr frame:open-here<%>) (when (is-a? fr frame:open-here<%>)
(let ([ed (send fr get-open-here-editor)]) (let ([ed (send fr get-open-here-editor)])
(when (equal? (send ed get-filename) filename) (when (equal? (send ed get-filename) filename)
(send ed set-position start end)))))] (send ed set-position start end)))))]
[else [else
(message-box (string-constant error) (message-box (string-constant error)
(format (string-constant cannot-open-because-dne) (format (string-constant cannot-open-because-dne)
filename))]))) filename))])))
;; show-recent-items-window : -> void ;; show-recent-items-window : -> void
(define (show-recent-items-window) (define (show-recent-items-window)
(unless recent-items-window (unless recent-items-window
(set! recent-items-window (make-recent-items-window))) (set! recent-items-window (make-recent-items-window)))
(send recent-items-window show #t)) (send recent-items-window show #t))
;; make-recent-items-window : -> frame ;; make-recent-items-window : -> frame
(define (make-recent-items-window) (define (make-recent-items-window)
(make-object (get-recent-items-window%) (make-object (get-recent-items-window%)
(string-constant show-recent-items-window-label) (string-constant show-recent-items-window-label)
#f #f
(preferences:get 'framework:recent-items-window-w) (preferences:get 'framework:recent-items-window-w)
(preferences:get 'framework:recent-items-window-h))) (preferences:get 'framework:recent-items-window-h)))
;; recent-items-window : (union #f (is-a?/c frame%)) ;; recent-items-window : (union #f (is-a?/c frame%))
(define recent-items-window #f) (define recent-items-window #f)
(define recent-items-hierarchical-list% (define recent-items-hierarchical-list%
(class hierarchical-list% (class hierarchical-list%
(define/override (on-double-select item) (define/override (on-double-select item)
(send item open-item)) (send item open-item))
(super-instantiate ()))) (super-instantiate ())))
(define recent-items-super% (frame:standard-menus-mixin frame:basic%)) (define recent-items-super% (frame:standard-menus-mixin frame:basic%))
(define (set-recent-items-frame-superclass super%) (define (set-recent-items-frame-superclass super%)
(set! recent-items-super% super%)) (set! recent-items-super% super%))
(define (get-recent-items-window%) (define (get-recent-items-window%)
(class recent-items-super% (class recent-items-super%
;; remove extraneous separators ;; remove extraneous separators
(define/override (file-menu:between-print-and-close menu) (void)) (define/override (file-menu:between-print-and-close menu) (void))
(define/override (edit-menu:between-find-and-preferences menu) (void)) (define/override (edit-menu:between-find-and-preferences menu) (void))
(define/override (on-size w h) (define/override (on-size w h)
(preferences:set 'framework:recent-items-window-w w) (preferences:set 'framework:recent-items-window-w w)
(preferences:set 'framework:recent-items-window-h h)) (preferences:set 'framework:recent-items-window-h h))
;; refresh-hl : (listof recent-list-item) -> void ;; refresh-hl : (listof recent-list-item) -> void
(define/private (refresh-hl recent-list-items) (define/private (refresh-hl recent-list-items)
(let ([ed (send hl get-editor)]) (let ([ed (send hl get-editor)])
(send ed begin-edit-sequence) (send ed begin-edit-sequence)
(for-each (λ (item) (send hl delete-item item)) (send hl get-items)) (for-each (λ (item) (send hl delete-item item)) (send hl get-items))
(for-each (λ (item) (add-recent-item item)) (for-each (λ (item) (add-recent-item item))
(if (eq? (preferences:get 'framework:recently-opened-sort-by) 'name) (if (eq? (preferences:get 'framework:recently-opened-sort-by) 'name)
(sort recent-list-items (sort recent-list-items
(λ (x y) (string<=? (path->string (car x)) (λ (x y) (string<=? (path->string (car x))
(path->string (car y))))) (path->string (car y)))))
recent-list-items)) recent-list-items))
(send ed end-edit-sequence))) (send ed end-edit-sequence)))
(define/private (add-recent-item recent-list-item) (define/private (add-recent-item recent-list-item)
(let ([item (send hl new-item (make-hierlist-item-mixin recent-list-item))]) (let ([item (send hl new-item (make-hierlist-item-mixin recent-list-item))])
(send (send item get-editor) insert (path->string (car recent-list-item))))) (send (send item get-editor) insert (path->string (car recent-list-item)))))
(field [remove-prefs-callback (field [remove-prefs-callback
(preferences:add-callback (preferences:add-callback
'framework:recently-opened-files/pos 'framework:recently-opened-files/pos
(λ (p v) (λ (p v)
(refresh-hl v)))]) (refresh-hl v)))])
(define/augment (on-close) (define/augment (on-close)
(inner (void) on-close) (inner (void) on-close)
(remove-prefs-callback) (remove-prefs-callback)
(set! recent-items-window #f)) (set! recent-items-window #f))
(super-new) (super-new)
(inherit get-area-container) (inherit get-area-container)
(field [bp (make-object horizontal-panel% (get-area-container))] (field [bp (make-object horizontal-panel% (get-area-container))]
[hl (make-object recent-items-hierarchical-list% (get-area-container) '())] [hl (make-object recent-items-hierarchical-list% (get-area-container) '())]
[sort-by-name-button [sort-by-name-button
(make-object button% (make-object button%
(string-constant recent-items-sort-by-name) (string-constant recent-items-sort-by-name)
bp bp
(λ (x y) (set-sort-by 'name)))] (λ (x y) (set-sort-by 'name)))]
[sort-by-age-button [sort-by-age-button
(make-object button% (make-object button%
(string-constant recent-items-sort-by-age) (string-constant recent-items-sort-by-age)
bp bp
(λ (x y) (set-sort-by 'age)))]) (λ (x y) (set-sort-by 'age)))])
(send bp stretchable-height #f) (send bp stretchable-height #f)
(send sort-by-name-button stretchable-width #t) (send sort-by-name-button stretchable-width #t)
(send sort-by-age-button stretchable-width #t) (send sort-by-age-button stretchable-width #t)
(define/private (set-sort-by flag) (define/private (set-sort-by flag)
(preferences:set 'framework:recently-opened-sort-by flag) (preferences:set 'framework:recently-opened-sort-by flag)
(case flag (case flag
[(name) [(name)
(send sort-by-age-button enable #t) (send sort-by-age-button enable #t)
(send sort-by-name-button enable #f)] (send sort-by-name-button enable #f)]
[(age) [(age)
(send sort-by-age-button enable #f) (send sort-by-age-button enable #f)
(send sort-by-name-button enable #t)]) (send sort-by-name-button enable #t)])
(refresh-hl (preferences:get 'framework:recently-opened-files/pos))) (refresh-hl (preferences:get 'framework:recently-opened-files/pos)))
(set-sort-by (preferences:get 'framework:recently-opened-sort-by)))) (set-sort-by (preferences:get 'framework:recently-opened-sort-by))))
;; make-hierlist-item-mixin : recent-item -> mixin(arg to new-item method of hierlist) ;; make-hierlist-item-mixin : recent-item -> mixin(arg to new-item method of hierlist)
(define (make-hierlist-item-mixin recent-item) (define (make-hierlist-item-mixin recent-item)
(λ (%) (λ (%)
(class % (class %
(define/public (open-item) (define/public (open-item)
(open-recent-list-item recent-item)) (open-recent-list-item recent-item))
(super-instantiate ())))) (super-instantiate ()))))
(define *open-directory* ; object to remember last directory (define *open-directory* ; object to remember last directory
(new (class object% (new (class object%
(field [the-dir #f]) (field [the-dir #f])
[define/public get (λ () the-dir)] [define/public get (λ () the-dir)]
[define/public set-from-file! [define/public set-from-file!
(λ (file) (λ (file)
(set! the-dir (path-only file)))] (set! the-dir (path-only file)))]
[define/public set-to-default [define/public set-to-default
(λ () (λ ()
(set! the-dir (current-directory)))] (set! the-dir (current-directory)))]
(set-to-default) (set-to-default)
(super-new)))) (super-new))))
(define open-file (define (open-file)
(λ () (let* ([parent (and (or (not (eq? 'macosx (system-type)))
(let* ([parent (and (or (not (eq? 'macosx (system-type))) (preferences:get 'framework:open-here?))
(preferences:get 'framework:open-here?)) (get-top-level-focus-window))]
(get-top-level-focus-window))] [file
[file (parameterize ([finder:dialog-parent-parameter parent])
(parameterize ([finder:dialog-parent-parameter parent]) (finder:get-file
(finder:get-file (send *open-directory* get)))])
(send *open-directory* get)))]) (when file
(when file (send *open-directory*
(send *open-directory* set-from-file! file))
set-from-file! file)) (and file
(and file (edit-file file)))))
(edit-file file))))))

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

@ -101,7 +101,9 @@ the state transitions / contracts are:
;; unmarshall, if required ;; unmarshall, if required
(when (hash-table-bound? marshalled p) (when (hash-table-bound? marshalled p)
(hash-table-put! preferences p (unmarshall-pref p (hash-table-get marshalled p))) ;; if `preferences' is already bound, that means the unmarshalled value isn't useful.
(unless (hash-table-bound? preferences p)
(hash-table-put! preferences p (unmarshall-pref p (hash-table-get marshalled p))))
(hash-table-remove! marshalled p)) (hash-table-remove! marshalled p))
;; if there is no value in the preferences table, but there is one ;; if there is no value in the preferences table, but there is one

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

@ -24,7 +24,8 @@ WARNING: printf is rebound in the body of the unit to always
[prefix color-model: framework:color-model^] [prefix color-model: framework:color-model^]
[prefix frame: framework:frame^] [prefix frame: framework:frame^]
[prefix scheme: framework:scheme^] [prefix scheme: framework:scheme^]
[prefix number-snip: framework:number-snip^]) [prefix number-snip: framework:number-snip^]
[prefix finder: framework:finder^])
(export (rename framework:text^ (export (rename framework:text^
[-keymap% keymap%])) [-keymap% keymap%]))
(init-depend framework:editor^) (init-depend framework:editor^)
@ -52,7 +53,7 @@ WARNING: printf is rebound in the body of the unit to always
(define basic-mixin (define basic-mixin
(mixin (editor:basic<%> (class->interface text%)) (basic<%>) (mixin (editor:basic<%> (class->interface text%)) (basic<%>)
(inherit get-canvases get-admin split-snip get-snip-position (inherit get-canvas get-canvases get-admin split-snip get-snip-position
begin-edit-sequence end-edit-sequence begin-edit-sequence end-edit-sequence
set-autowrap-bitmap set-autowrap-bitmap
delete find-snip invalidate-bitmap-cache delete find-snip invalidate-bitmap-cache
@ -350,7 +351,18 @@ WARNING: printf is rebound in the body of the unit to always
(public initial-autowrap-bitmap) (public initial-autowrap-bitmap)
(define (initial-autowrap-bitmap) (icon:get-autowrap-bitmap)) (define (initial-autowrap-bitmap) (icon:get-autowrap-bitmap))
(super-instantiate ()) (define/override (put-file directory default-name)
(let* ([canvas (get-canvas)]
[parent (and canvas (send canvas get-top-level-window))])
(finder:put-file default-name
directory
#f
(string-constant select-file)
#f
""
parent)))
(super-new)
(set-autowrap-bitmap (initial-autowrap-bitmap)))) (set-autowrap-bitmap (initial-autowrap-bitmap))))
(define foreground-color<%> (define foreground-color<%>