get confirmation for overwrite only by request

pollen/private/command.rkt

@@ -36,10 +36,7 @@
     [("version") (handle-version)]
     [("reset") (handle-reset (get-first-arg-or-current-dir))]
     [("setup") (handle-setup (get-first-arg-or-current-dir))]
-    [("clone" "publish") (define rest-args
+    [("clone" "publish") (handle-publish)]
-                           (with-handlers ([exn:fail? (λ _ #f)])
-                             (cddr (vector->list (current-command-line-arguments)))))
-                         (handle-publish (get-first-arg-or-current-dir) rest-args command-name)]
     [else (handle-unknown command-name)]))
 
 (define (very-nice-path x)
@@ -58,7 +55,7 @@ render  [dir] [dest]   render project in dir (default is current dir)
 render filename        render filename only (can be source or output name)
 publish                copy project to ~a without source files
 publish [dir] [dest]   copy project in dir to dest without source files
-                          (warning: overwrites existing dest dir)
+                          (warning: overwrites existing dest)
 setup                  preload cache
 reset                  reset cache
 version                print the version" (current-server-port) (make-publish-dir-name))))
@@ -142,11 +139,29 @@ version                print the version" (current-server-port) (make-publish-di
                                 "clone"
                                 user-publish-path))))))
 
-(define (handle-publish directory-maybe rest-args arg-command-name)
+(define (handle-publish)
-  (define target-path
+  (define command-name ; either "publish" or "clone"
+    (vector-ref (current-command-line-arguments) 0))
+  (define force-target-overwrite? (make-parameter #t))
+  (define fake-command-line (command-line
+                             ;; drop command name
+                             #:argv (vector-drop (current-command-line-arguments) 1)
+                             #:once-each
+                             [("-c" "--confirm") "Confirm overwrite of existing dest dir"
+                                                 (force-target-overwrite? #f)]
+                             #:args other-args
+                             (cons command-name other-args)))
+  ;; fake-command-line looks like
+  ;; command-name [maybe-source-dir-arg] [maybe-dest-dir-arg]
+  (define source-dir
+    (simplify-path (get-first-arg-or-current-dir (list->vector fake-command-line))))
+  
+  (define dest-dir
+    (simplify-path
      (or 
-     (and rest-args (not (null? rest-args)) (path->complete-path (string->path (car rest-args))))
+      (and (>= (length fake-command-line) 3)
-     (make-publish-dir-name arg-command-name)))
+           (path->complete-path (string->path (third fake-command-line))))
+      (make-publish-dir-name command-name))))
 
   (define (delete-it path)
     (cond
@@ -159,34 +174,37 @@ version                print the version" (current-server-port) (make-publish-di
            (andmap equal? prefix (take xs (length prefix)))))
     ((explode-path possible-subdir) . has-prefix? . (explode-path possible-superdir)))
   
-  (define source-dir (simplify-path directory-maybe))
   (when (not (directory-exists? source-dir))
     (error 'publish (format "source directory ~a does not exist" source-dir)))
-  (define target-dir (simplify-path target-path))
+  
-  (when (source-dir . contains-directory? . target-dir)
+  (when (source-dir . contains-directory? . dest-dir)
-    (error 'publish "aborted because target directory for publishing (~a) can't be inside source directory (~a)" target-dir source-dir))
+    (error 'publish "aborted because destination directory for publishing (~a) can't be inside source directory (~a)" dest-dir source-dir))
-  (when (target-dir . contains-directory? . source-dir)
+  
-    (error 'publish "aborted because target directory for publishing (~a) can't contain source directory (~a)" target-dir source-dir))
+  (when (dest-dir . contains-directory? . source-dir)
-  (when (equal? target-dir (current-directory))
+    (error 'publish "aborted because destination directory for publishing (~a) can't contain source directory (~a)" dest-dir source-dir))
-    (error 'publish "aborted because target directory for publishing (~a) can't be the same as current directory (~a)" target-dir (current-directory)))
+  
+  (when (equal? dest-dir (current-directory))
+    (error 'publish "aborted because destination directory for publishing (~a) can't be the same as current directory (~a)" dest-dir (current-directory)))
+  
   (display (format "publishing from ~a " source-dir))
-  (displayln (format "to ~a ..." target-dir))
+  (displayln (format "to ~a ..." dest-dir))
   (define do-publish-operation?
-    (or (not (directory-exists? target-dir))
+    (or (not (directory-exists? dest-dir))
+        (force-target-overwrite?)
         (begin
-          (display (format "target directory ~a exists. Overwrite? [yes/no] " target-dir))
+          (display (format "destination directory ~a exists. Overwrite? [yes/no] " dest-dir))
           (case (read)
             [(y yes) #t]
             [else #f]))))
   (cond
     [do-publish-operation?
-     (when (directory-exists? target-dir)
+     (when (directory-exists? dest-dir)
-       (delete-directory/files target-dir))
+       (delete-directory/files dest-dir))
-     (copy-directory/files source-dir target-dir)
+     (copy-directory/files source-dir dest-dir)
      (parameterize ([current-project-root (current-directory)])
        (define (delete-from-publish-dir? p)
          (and (omitted-path? p) (not (extra-path? p))))
-       (for-each delete-it (find-files delete-from-publish-dir? target-dir)))
+       (for-each delete-it (find-files delete-from-publish-dir? dest-dir)))
      (displayln "publish completed")]
     [else (displayln "publish aborted")]))
 

pollen/private/ts.rktd

@@ -1 +1 @@
-1469813715
+1469834090

pollen/scribblings/raco.scrbl

@@ -110,6 +110,8 @@ Make a copy of the project directory on the desktop, but without any source file
 
 If you're already in your project directory and want to publish somewhere other than the desktop, use @racket[raco pollen publish _. _dest-dir].
 
+By default, this command will automatically overwrite the destination directory. Adding the optional @exec{-c} or @exec{--confirm} switch will ask for confirmation if the destination already exists.
+
 You can determine the default publishing destination for a project by overriding @racket[default-publish-directory].
 
 Certain files and directories are automatically omitted from the published directory, including Racket and Pollen sources, Pollen caches, and source-control directories (like @tt{.git} and @tt{.svn}). You can omit other files by overriding @racket[default-omitted-path?]. You can override these omissions — that is, force a path to be published — by overriding @racket[default-extra-path?].