diff --git a/collects/mred/private/check.ss b/collects/mred/private/check.ss index 8449b7d3..67771b7b 100644 --- a/collects/mred/private/check.ss +++ b/collects/mred/private/check.ss @@ -43,6 +43,10 @@ (unless (or (not str) (string? str)) (raise-type-error (who->name who) "string or #f" str))) + (define (check-path who str) + (unless (path-string? str) + (raise-type-error (who->name who) "path or string" str))) + (define (check-path/false who str) (unless (or (not str) (path-string? str)) (raise-type-error (who->name who) "path, string, or #f" str))) diff --git a/collects/mred/private/editor.ss b/collects/mred/private/editor.ss index b4241a8f..3f3578b8 100644 --- a/collects/mred/private/editor.ss +++ b/collects/mred/private/editor.ss @@ -36,15 +36,23 @@ get-active-canvas set-active-canvas get-canvas add-canvas remove-canvas - auto-wrap get-max-view-size)) + auto-wrap get-max-view-size + save-file)) (define-local-member-name -format-filter + -format-filter/save -get-current-format -get-file-format -set-file-format -set-format) + (define (check-format who format) + (unless (memq format '(guess standard text text-force-cr same copy)) + (raise-type-error (who->name who) + "'guess, 'standard, 'text, 'text-force-cr, 'same, or 'copy" + format))) + (define-syntax (augmentize stx) (syntax-case stx () [(_ (result id arg ...) ...) @@ -53,7 +61,7 @@ (and (super id arg ...) (inner result id arg ...))) ...)])) - + (define (make-editor-buffer% % can-wrap? get-editor%) ; >>> This class is instantiated directly by the end-user <<< (class* % (editor<%> internal-editor<%>) @@ -62,13 +70,15 @@ [super-begin-edit-sequence begin-edit-sequence] [super-end-edit-sequence end-edit-sequence] [super-insert-port insert-port] + [super-save-port save-port] [super-erase erase] [super-clear-undos clear-undos] [super-get-load-overwrites-styles get-load-overwrites-styles] [super-get-filename get-filename]) (inherit get-max-width set-max-width get-admin get-keymap get-style-list - set-modified set-filename) + set-modified set-filename + get-file put-file) (define canvases null) (define active-canvas #f) (define auto-set-wrap? #f) @@ -92,19 +102,29 @@ (values (unbox wb) (unbox hb))))]) (public* [-format-filter (lambda (f) f)] + [-format-filter/save (lambda (f) f)] [-set-file-format (lambda (f) (void))] [-get-file-format (lambda () 'standard)]) (override* [insert-file - (opt-lambda ([file #f] [format 'guess] [show-errors? #t]) - (dynamic-wind - (lambda () (super-begin-edit-sequence)) - (lambda () (super-insert-port file format #f)) - (lambda () (super-end-edit-sequence))))] + (opt-lambda (file [format 'guess] [show-errors? #t]) + (let ([who '(method editor<%> insert-file)]) + (check-path who file) + (check-format who format)) + (do-load-file file format #f))] [load-file (opt-lambda ([file #f] [format 'guess] [show-errors? #t]) + (do-load-file file format #t))]) + + (private* + [do-load-file + (lambda (file format load?) + (let ([who '(method editor<%> load-file)]) + (unless (equal? file "") + (check-path/false who file)) + (check-format who format)) (let* ([temp-filename?-box (box #f)] [old-filename (super-get-filename temp-filename?-box)]) (let* ([file (cond @@ -114,15 +134,17 @@ (let ([path (if old-filename (path-only old-filename) #f)]) - ((get-get-file) path)) + (get-file path)) old-filename)] [(path? file) file] [else (string->path file)])]) (and file - (can-load-file? file (-format-filter format)) + (or (not load?) + (can-load-file? file (-format-filter format))) (begin - (on-load-file file (-format-filter format)) + (or (not load?) + (on-load-file file (-format-filter format))) (let ([port (open-input-file file)] [finished? #f]) (dynamic-wind @@ -133,10 +155,11 @@ (dynamic-wind void (lambda () - (super-erase) - (unless (and (not (unbox temp-filename?-box)) - (equal? file old-filename)) - (set-filename file #f)) + (when load? + (super-erase) + (unless (and (not (unbox temp-filename?-box)) + (equal? file old-filename)) + (set-filename file #f))) (let ([format (if (eq? format 'same) (-get-file-format) format)]) @@ -146,20 +169,83 @@ (raise x))]) (super-insert-port port (-format-filter format) - (super-get-load-overwrites-styles)))]) + (and load? + (super-get-load-overwrites-styles))))]) (close-input-port port) ; close as soon as possible - (-set-file-format new-format)))) ; text% only + (when load? + (-set-file-format new-format))))) ; text% only (lambda () (super-end-edit-sequence) (wx:end-busy-cursor))) - (super-clear-undos) - (set-modified #f) + (when load? + (super-clear-undos) + (set-modified #f)) (set! finished? #t) #t) (lambda () - (after-load-file finished?) ;; In case it wasn't closed before: - (close-input-port port)))))))))]) + (close-input-port port) + (when load? + (after-load-file finished?))))))))))]) + (public* + [save-file + (opt-lambda ([file #f] [format 'same] [show-errors? #t]) + (let ([who '(method editor<%> save-file)]) + (unless (equal? file "") + (check-path/false who file)) + (check-format who format)) + (let* ([temp-filename?-box (box #f)] + [old-filename (super-get-filename temp-filename?-box)]) + (let* ([file (cond + [(or (not (path-string? file)) + (equal? file "")) + (if (or (equal? file "") (not old-filename) (unbox temp-filename?-box)) + (let ([path (if old-filename + (path-only old-filename) + #f)]) + (put-file path (and old-filename + (file-name-from-path old-filename)))) + old-filename)] + [(path? file) file] + [else (string->path file)])] + [f-format (-format-filter/save format)] + [actual-format (if (memq f-format '(copy same)) + (-get-file-format) + f-format)] + [text? (not (memq actual-format '(text text-force-cr)))]) + (and + file + (can-save-file? file f-format) + (begin + (on-save-file file f-format) + (let ([port (open-output-file file (if text? 'text 'binary) 'truncate/replace)] + [finished? #f]) + (dynamic-wind + void + (lambda () + (wx:file-creator-and-type file #"mReD" (if text? #"TEXT" #"WXME")) + (wx:begin-busy-cursor) + (dynamic-wind + void + (lambda () + (super-save-port port format #t) + (close-output-port port) ; close as soon as possible + (unless (or (eq? format 'copy) + (and (not (unbox temp-filename?-box)) + (equal? file old-filename))) + (set-filename file #f)) + (unless (eq? format 'copy) + (-set-file-format actual-format))) ; text% only + (lambda () + (wx:end-busy-cursor))) + (unless (eq? format 'copy) + (set-modified #f)) + (set! finished? #t) + #t) + (lambda () + ;; In case it wasn't closed before: + (close-output-port port) + (after-save-file finished?)))))))))]) (public* [get-canvases (entry-point (lambda () (map wx->mred canvases)))] @@ -316,7 +402,10 @@ (define pasteboard% (class (es-contract-mixin (make-editor-buffer% wx:pasteboard% #f (lambda () pasteboard%))) () (override* - [-format-filter (lambda (f) 'standard)]) + [-format-filter (lambda (f) 'standard)] + [-format-filter/save (lambda (f) (if (eq? f 'copy) + f + 'standard))]) (augmentize (#t can-insert? s s2 x y) ((void) on-insert s s2 x y) ((void) after-insert s s2 x y) diff --git a/collects/mred/private/kernel.ss b/collects/mred/private/kernel.ss index 88a83ab1..4a5744a4 100644 --- a/collects/mred/private/kernel.ss +++ b/collects/mred/private/kernel.ss @@ -225,7 +225,7 @@ insert-file load-file insert-port - save-file + save-port get-flattened-text put-file get-file diff --git a/collects/mred/private/moredialogs.ss b/collects/mred/private/moredialogs.ss index 46e65892..70b462b3 100644 --- a/collects/mred/private/moredialogs.ss +++ b/collects/mred/private/moredialogs.ss @@ -49,6 +49,21 @@ (check-instance 'get-ps-setup-from-user wx:ps-setup% 'ps-setup% #t pss-in) (check-style 'get-ps-setup-from-user #f null style))) + (define bad-fields null) + (define number-callback + (lambda (f ev) + (let ([e (send f get-editor)] + [ok? (real? (string->number (send f get-value)))]) + (send e change-style + (send (make-object wx:style-delta%) + set-delta-background + (if ok? "white" "yellow")) + 0 (send e last-position)) + (set! bad-fields (remq f bad-fields)) + (unless ok? + (set! bad-fields (cons f bad-fields))) + (send ok enable (null? bad-fields))))) + (define pss (or pss-in (wx:current-ps-setup))) (define f (make-object dialog% "PostScript Setup" parent)) (define papers @@ -67,11 +82,14 @@ (define sp (make-object vertical-pane% ssp)) (define def-scale "0100.000") (define def-offset "0000.000") - (define xscale (make-object text-field% "Horizontal Scale:" sp void def-scale)) - (define xoffset (make-object text-field% "Horizontal Translation:" sp void def-offset)) + (define def-margin "0016.000") + (define xscale (make-object text-field% "Horizontal Scale:" sp number-callback def-scale)) + (define xoffset (make-object text-field% "Horizontal Translation:" sp number-callback def-offset)) + (define xmargin (make-object text-field% "Horizontal Margin:" sp number-callback def-margin)) (define sp2 (make-object vertical-pane% ssp)) - (define yscale (make-object text-field% "Vertical Scale:" sp2 void def-scale)) - (define yoffset (make-object text-field% "Vertical Translation:" sp2 void def-offset)) + (define yscale (make-object text-field% "Vertical Scale:" sp2 number-callback def-scale)) + (define yoffset (make-object text-field% "Vertical Translation:" sp2 number-callback def-offset)) + (define ymargin (make-object text-field% "Vertical Margin:" sp2 number-callback def-margin)) (define l2 (make-object check-box% "PostScript Level 2" f void)) @@ -84,7 +102,8 @@ (send f show #f) (set! ok? ?)) - (define-values (xsb ysb xtb ytb) (values (box 0) (box 0) (box 0) (box 0))) + (define-values (xsb ysb xtb ytb xmb ymb) + (values (box 0) (box 0) (box 0) (box 0) (box 0) (box 0))) (send paper set-selection (or (find-pos papers (send pss get-paper-name) equal?) 0)) (send orientation set-selection (if (eq? (send pss get-orientation) 'landscape) 1 0)) @@ -102,16 +121,21 @@ (send pss get-translation xtb ytb) (send xoffset set-value (number->string* (unbox xtb))) (send yoffset set-value (number->string* (unbox ytb))) + (send pss get-margin xmb ymb) + (send xmargin set-value (number->string* (unbox xmb))) + (send ymargin set-value (number->string* (unbox ymb))) (send xscale stretchable-width #f) (send yscale stretchable-width #f) (send xoffset stretchable-width #f) (send yoffset stretchable-width #f) + (send xmargin stretchable-width #f) + (send ymargin stretchable-width #f) (send l2 set-value (send pss get-level-2)) (send f set-alignment 'center 'top) - (map no-stretch (list f xscale yscale xoffset yoffset dp)) + (map no-stretch (list f xscale yscale xoffset yoffset xmargin ymargin dp)) (send f center) @@ -132,6 +156,7 @@ [(2) 'file]))) (send s set-scaling (gv xscale xsb) (gv yscale ysb)) (send s set-translation (gv xoffset xtb) (gv yoffset ytb)) + (send s set-margin (gv xmargin xmb) (gv ymargin ymb)) (send s set-level-2 (send l2 get-value)) (when (eq? (system-type) 'unix)