From ee161b9b2785e187e4d8352afcc1538e0ba1a178 Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Fri, 27 May 2005 21:53:51 +0000
Subject: [PATCH] Added src, set properties for all DOS files.

svn: r4

original commit: e41b2fb359d69543359c625e130f01456974a8cb
---
 collects/mred/private/check.ss       |   4 -
 collects/mred/private/editor.ss      | 141 +++++----------------------
 collects/mred/private/kernel.ss      |   2 +-
 collects/mred/private/moredialogs.ss |  37 ++-----
 collects/tests/mred/editor.ss        | 123 -----------------------
 5 files changed, 31 insertions(+), 276 deletions(-)

diff --git a/collects/mred/private/check.ss b/collects/mred/private/check.ss
index 67771b7b..8449b7d3 100644
--- a/collects/mred/private/check.ss
+++ b/collects/mred/private/check.ss
@@ -43,10 +43,6 @@
     (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 433a24a0..b4241a8f 100644
--- a/collects/mred/private/editor.ss
+++ b/collects/mred/private/editor.ss
@@ -36,24 +36,15 @@
       get-active-canvas set-active-canvas
       get-canvas
       add-canvas remove-canvas
-      auto-wrap get-max-view-size
-      save-file))
+      auto-wrap get-max-view-size))
 
   (define-local-member-name 
     -format-filter
-    -format-filter/save
     -get-current-format
     -get-file-format
     -set-file-format
-    -set-position
     -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 ...) ...)
@@ -62,7 +53,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<%>)
@@ -71,15 +62,13 @@
 			  [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
-		     get-file put-file)
+		     set-modified set-filename)
 	    (define canvases null)
 	    (define active-canvas #f)
 	    (define auto-set-wrap? #f)
@@ -103,30 +92,19 @@
 		  (values (unbox wb) (unbox hb))))])
 	    (public*
 	     [-format-filter (lambda (f) f)]
-	     [-format-filter/save (lambda (f) f)]
 	     [-set-file-format (lambda (f) (void))]
-	     [-set-position (lambda () (void))]
 	     [-get-file-format (lambda () 'standard)])
 	    
 	    (override*
 	     [insert-file
-	      (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))]
+	      (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))))]
 
 	     [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
@@ -136,17 +114,15 @@
 				     (let ([path (if old-filename
 						     (path-only old-filename)
 						     #f)])
-				       (get-file path))
+				       ((get-get-file) path))
 				     old-filename)]
 				[(path? file) file]
 				[else (string->path file)])])
 		    (and 
 		     file
-		     (or (not load?)
-			 (can-load-file? file (-format-filter format)))
+		     (can-load-file? file (-format-filter format))
 		     (begin
-		       (or (not load?)
-			   (on-load-file file (-format-filter format)))
+		       (on-load-file file (-format-filter format))
 		       (let ([port (open-input-file file)]
 			     [finished? #f])
 			 (dynamic-wind
@@ -157,11 +133,10 @@
 			       (dynamic-wind
 				   void
 				   (lambda ()
-				     (when load?
-				       (super-erase)
-				       (unless (and (not (unbox temp-filename?-box))
-						    (equal? file old-filename))
-					 (set-filename file #f)))
+				     (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)])
@@ -171,84 +146,20 @@
 									(raise x))])
 						(super-insert-port port 
 								   (-format-filter format) 
-								   (and load?
-									(super-get-load-overwrites-styles))))])
+								   (super-get-load-overwrites-styles)))])
 					 (close-input-port port) ; close as soon as possible
-					 (when load?
-					   (-set-file-format new-format)
-					   (-set-position))))) ; text% only
+					 (-set-file-format new-format)))) ; text% only
 				   (lambda ()
 				     (super-end-edit-sequence)
 				     (wx:end-busy-cursor)))
-			       (when load?
-				 (super-clear-undos)
-				 (set-modified #f))
+			       (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)
-			       (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?)))))))))])
+			       (close-input-port port)))))))))])
 
 	    (public*
 	     [get-canvases (entry-point (lambda () (map wx->mred canvases)))]
@@ -379,9 +290,8 @@
        [-get-file-format (lambda ()
 			   (super-get-file-format))]
        [-set-file-format (lambda (format)
-			   (super-set-file-format format))]
-       [-set-position (lambda ()
-			(super-set-position 0 0))])
+			   (super-set-file-format format)
+			   (super-set-position 0 0))])
 
       (augmentize (#t can-insert? s e)
 		  ((void) on-insert s e)
@@ -406,10 +316,7 @@
   (define pasteboard%
     (class (es-contract-mixin (make-editor-buffer% wx:pasteboard% #f (lambda () pasteboard%))) ()
 	   (override*
-	    [-format-filter (lambda (f) 'standard)]
-	    [-format-filter/save (lambda (f) (if (eq? f 'copy)
-						 f
-						 'standard))])
+	    [-format-filter (lambda (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 4a5744a4..88a83ab1 100644
--- a/collects/mred/private/kernel.ss
+++ b/collects/mred/private/kernel.ss
@@ -225,7 +225,7 @@
     insert-file
     load-file
     insert-port
-    save-port
+    save-file
     get-flattened-text
     put-file
     get-file
diff --git a/collects/mred/private/moredialogs.ss b/collects/mred/private/moredialogs.ss
index 70b462b3..46e65892 100644
--- a/collects/mred/private/moredialogs.ss
+++ b/collects/mred/private/moredialogs.ss
@@ -49,21 +49,6 @@
 	  (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 
@@ -82,14 +67,11 @@
       (define sp (make-object vertical-pane% ssp))
       (define def-scale "0100.000")
       (define def-offset "0000.000")
-      (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 xscale (make-object text-field% "Horizontal Scale:" sp void def-scale))
+      (define xoffset (make-object text-field% "Horizontal Translation:" sp void def-offset))
       (define sp2 (make-object vertical-pane% ssp))
-      (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 yscale (make-object text-field% "Vertical Scale:" sp2 void def-scale))
+      (define yoffset (make-object text-field% "Vertical Translation:" sp2 void def-offset))
 
       (define l2 (make-object check-box% "PostScript Level 2" f void))
 
@@ -102,8 +84,7 @@
 	(send f show #f)
 	(set! ok? ?))
 
-      (define-values (xsb ysb xtb ytb xmb ymb) 
-	(values (box 0) (box 0) (box 0) (box 0) (box 0) (box 0)))
+      (define-values (xsb ysb xtb ytb) (values (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))
@@ -121,21 +102,16 @@
       (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 xmargin ymargin dp))
+      (map no-stretch (list f xscale yscale xoffset yoffset dp))
 
       (send f center)
 
@@ -156,7 +132,6 @@
 				 [(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)
diff --git a/collects/tests/mred/editor.ss b/collects/tests/mred/editor.ss
index cf60ac67..3c62a80b 100644
--- a/collects/tests/mred/editor.ss
+++ b/collects/tests/mred/editor.ss
@@ -5,129 +5,6 @@
 ;;                            Editor Tests                                    ;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-;;;;;; File and port save/load tests
-
-(define (run-save/load-tests editor% insert reset?)
-  (when reset?
-    (map (lambda (f)
-	   (when (file-exists? f) (delete-file f)))
-	 '("tmp99" "tmp98" "tmp97" "tmp96" "tmp95")))
-  (let* ([mode #f]
-	 [editor+% (class editor%
-		     (define/augment (on-load-file path -mode)
-		       (set! mode -mode))
-		     (define/augment (on-save-file path -mode)
-		       (set! mode -mode))
-		     (super-new))]
-	 [e (make-object editor+%)]
-	 [ck-text (lambda (path)
-		    (when (eq? editor% text%)
-		      (st 'text e get-file-format)
-		      (when path
-			(test "Hello" 'content (with-input-from-file path
-						 (lambda ()
-						   (read-string 100)))))))]
-	 [ck-binary (lambda (path)
-		      (when (eq? editor% text%)
-			(st 'standard e get-file-format))
-		      (when path
-			(test #"WXME" 'content (with-input-from-file path
-						 (lambda ()
-						   (read-bytes 4))))))]
-	 [ck-mode (lambda (-mode)
-		    (test (if (eq? editor% pasteboard%) 
-			      (if (eq? -mode 'copy)
-				  'copy
-				  'standard) 
-			      -mode) 
-			  'mode mode))])
-    (insert e "Hello")
-    (st #t e is-modified?)
-    (st #f e get-filename)
-    (when (eq? editor% text%)
-      (st 'standard e get-file-format))
-    (st #t e save-file "tmp99" 'text)
-    (ck-mode 'text)
-    (st (string->path "tmp99") e get-filename)
-    (st #f e is-modified?)
-    (ck-text "tmp99")
-    (insert e "Ack")
-    (st #t e is-modified?)
-    (st #t e load-file "tmp99" 'guess)
-    (ck-mode 'guess)
-    (ck-text #f)
-    (st #f e is-modified?)
-    (st "Hello" e get-flattened-text)
-    (let ([now (file-or-directory-modify-seconds "tmp99")])
-      (st #t e save-file "tmp99" 'same)
-      (ck-text "tmp99")
-      (st (string->path "tmp99") e get-filename)
-      (let ([later (file-or-directory-modify-seconds "tmp99")])
-	(test #t 'file-date (now . <= . later))
-	(st #t e save-file "tmp98" 'standard)
-	(test #f 'file-date (later . < . (file-or-directory-modify-seconds "tmp99")))
-	(ck-binary "tmp98")
-	(st #t e load-file "tmp98" 'guess)
-	(ck-mode 'guess)
-	(ck-binary #f)
-	(st #t e load-file "tmp98" 'text)
-	(ck-mode 'text)
-	(ck-text #f)
-	(when (eq? editor% text%)
-	  (st "WXME" e get-text 0 4))
-	(st #t e load-file "tmp98" 'same)
-	(ck-mode 'same)
-	(ck-text #f)
-	(when (eq? editor% text%)
-	  (st "WXME" e get-text 0 4))
-	(st #t e load-file "tmp98" 'guess)
-	(ck-mode 'guess)
-	(ck-binary #f)
-	(st "Hello" e get-flattened-text)))
-    (let ([target "tmp97"])
-      ;; Check [non-]temporary file names
-      (set! e (make-object (class editor+%
-			     (define/override (put-file file dir)
-			       (string->path target))
-			     (super-new))))
-      (insert e "Howdy")
-      (st #t e is-modified?)
-      (set! mode #f)
-      (st #t e save-file #f 'copy)
-      (ck-mode 'copy)
-      (set! target "tmp95")
-      (st #t e is-modified?)
-      (ck-binary "tmp97")
-      (stv e set-filename "tmp96")
-      (st #t e save-file #f)
-      (st #f e is-modified?)
-      (st (string->path "tmp96") e get-filename)
-      (ck-binary "tmp96")
-      (stv e set-filename "tmp96" #t)
-      (st #t e save-file #f)
-      (ck-mode 'same)
-      (st (string->path "tmp95") e get-filename)
-      (stv e set-filename "tmp96" #t)
-      (st #t e save-file "")
-      (st (string->path "tmp95") e get-filename)
-      (ck-binary "tmp95")
-      (st "Howdy" e get-flattened-text)
-      (when (eq? editor% text%)
-	(stv e set-position 100))
-      (st #t e insert-file "tmp98")
-      (st "HowdyHello" e get-flattened-text)
-      (st #t e insert-file "tmp99")
-      (st "HowdyHelloHello" e get-flattened-text)
-      (st (string->path "tmp95") e get-filename))))
-    
-(map (lambda (reset?)
-       (run-save/load-tests text% (lambda (e t) (send e insert t)) reset?)
-       (run-save/load-tests pasteboard% (lambda (e t) (send e insert (make-object string-snip% t))) reset?))
-     '(#t #f))
-
-(report-errs)
-done
-
 ;;;;;; Undo tests
 
 (define e (make-object text%))