...

original commit: 96bbae900f69185fc62b5e05b6a385cb6184a317

collects/framework/framework.ss

@@ -626,13 +626,14 @@
     "."
     ""
     "It finds a handler based on \\var{filename}.")
+
    (handler:edit-file
     (opt->
      ((union string? false?))
      ((-> (is-a?/c frame:editor<%>)))
      (union false? (is-a?/c frame:editor<%>)))
     ((filename)
-     ((make-default (lambda () (make-object frame:text-info-file\% filename)))))
+     ((make-default (lambda () ((handler:current-create-new-window) filename)))))
     "This function creates a frame or re-uses an existing frame to edit a file. "
     ""
     "If the preference \\scheme{'framework:open-here} is set to \\scheme{#t},"
@@ -671,6 +672,23 @@
     "\\item"
     "If \\var{filename} is \\rawscm{\\#f}, \\var{make-default} is used."
     "\\end{itemize}")
+
+   (handler:current-create-new-window
+    (case->
+     (((union false? string?) . -> . (is-a?/c frame%)) . -> . void)
+     (-> ((union false? string?) . -> . (is-a?/c frame%))))
+    ((new-window-handler) ())
+    "This is a parameter that controls how the framework"
+    "creates new application windows."
+    ""
+    "The default setting is this:"
+    "\\begin{schemedisplay}"
+    "(lambda (filename)"
+    "  (let ([frame (make-object frame:text-info-file% filename)])"
+    "    (send frame show #t)"
+    "    frame))"
+    "\\end{schemedisplay}")
+
    (handler:open-file
     (-> (union false? (is-a?/c frame:basic<%>)))
     ()

collects/framework/private/frame.ss

@@ -874,7 +874,8 @@
       (define open-here<%>
         (interface (-editor<%>)
           get-open-here-editor
-	  open-here))
+	  open-here
+          create-empty-window))
       
       (define open-here-mixin
         (mixin (-editor<%>) (open-here<%>)
@@ -886,7 +887,6 @@
                                      (string-constant new-...-menu-item)
                                      (string-constant new-menu-item))))
           
-          (rename [super-file-menu:new-callback file-menu:new-callback])
           (define/override (file-menu:new-callback item event)
             (cond
               [(preferences:get 'framework:open-here?)
@@ -894,14 +894,30 @@
                  (cond
                    [(eq? clear-current 'cancel) (void)]
                    [clear-current
-                    (let ([editor (get-editor)])
-                      (send editor begin-edit-sequence)
-                      (send editor set-filename #f)
-                      (send editor erase)
-                      (send editor set-modified #f)
-                      (send editor end-edit-sequence))]
-                   [else (super-file-menu:new-callback item event)]))]
-              [else (super-file-menu:new-callback item event)]))
+                    (let* ([editor (get-editor)]
+                           [canceled? (cancel-due-to-unsaved-changes editor)])
+                      (unless canceled?
+                        (send editor begin-edit-sequence)
+                        (send editor set-filename #f)
+                        (send editor erase)
+                        (send editor set-modified #f)
+                        (send editor clear-undos)
+                        (send editor end-edit-sequence)))]
+                   [else ((handler:current-create-new-window) #f)]))]
+              [else ((handler:current-create-new-window) #f)]))
+
+          ;; cancel-due-to-unsaved-changes : -> boolean
+          (define (cancel-due-to-unsaved-changes editor)
+            (and (send editor is-modified?)
+                 (let ([save (gui-utils:unsaved-warning
+                              (or (send editor get-filename) (get-label))
+                              (string-constant clear-anyway)
+                              #t
+                              this)])
+                   (case save
+                     [(continue) #f]
+                     [(save) (not (send editor save-file))]
+                     [(cancel) #t]))))
           
           ;; ask-about-new-here : -> (union 'cancel boolean?)
           ;; prompts the user about creating a new window
@@ -911,10 +927,15 @@
              (string-constant create-new-window-or-clear-current)
              (string-constant clear-current)
              (string-constant new-window)
-             (string-constant drscheme)
+             (string-constant warning)
              'cancel
              this))
-            
+ 
+          ;; create-empty-window : -> void
+          (define/public (create-empty-window) 
+            (make-object text-info-file%)
+            (void))
+          
           (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)

collects/framework/private/handler.ss

@@ -97,14 +97,19 @@
 	  (find-named-handler name format-handlers)))
 
 					; Open a file for editing
+      (define current-create-new-window
+	(make-parameter
+	 (lambda (filename)
+	   (let ([frame (make-object frame:text-info-file% filename)])
+	     (send frame show #t)
+	     frame))))
+
       (define edit-file
 	(case-lambda
 	 [(filename) (edit-file
 		      filename
 		      (lambda ()
-			(let ([frame (make-object frame:text-info-file% filename)])
-			  (send frame show #t)
-			  frame)))]
+			((current-create-new-window) filename)))]
 	 [(filename make-default)
 	  (gui-utils:show-busy-cursor
 	   (lambda ()

collects/framework/private/sig.ss

@@ -378,6 +378,7 @@
      insert-format-handler
      find-format-handler 
      find-named-format-handler 
+     current-create-new-window
      edit-file
      open-file
      install-recent-items