;;;-*- Mode: Lisp; Package: CCL -*-
;;;
;;; ask-save-changes.lisp
;;;
;;; MacOS8 style dialogs for asking to save or discard changes to a document, with bw compatability.
;;; Typically used as a patch for MCL 4.2 or earlier.
;;;
;;; Copyright © 1999 Terje Norderhaug and Media Design inĄProgress
;;;
;;; Use and copying of this software and preparation of derivative works
;;; based upon this software are permitted, so long as this copyright 
;;; notice is included intact.
;;;
;;; Digitool is welcome to integrate parts or whole of this module in MCL without
;;; including the copyright note, as long as the author is mentioned in the version history
;;; and notified.
;;;
;;; This software is made available AS IS, and no warranty is made about 
;;; the software or its performance. 
;;;
;;; Author: Terje Norderhaug <terje@in-progress.com> of Media Design in*Progress.
;;;
;;; Latest version available from <http://www.in-progress.com/src/ask-save-changes.lisp>.
;;; Tested on MCL 4.2, but should also work with other recent versions of MCL.
;;; Should normally be used with the Navigation Services module from Digitool.
;;;
;;; Technical documentation for NavAskSaveChanges (which displays the Save Changes alert box) is at:
;;; http://developer.apple.com/techpubs/macos8/Files/NavigationServices/ProgWithNavSrvcs1.1/NavSvcs.e.html

#| VERSION HISTORY

1999-07-12 Terje  Version 1.0 released.

|#

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(in-package :ccl)

#|

ACTION values as specified by Apple's documentation for NavAskSaveChanges:

:CLOSING 
      Requests a Save Changes alert box that asks the user whether to save changes when
      closing a document. 
:QUITTING 
      Requests a Save Changes alert box that asks the user whether to save changes when
      quitting your application. 
NIL (default) 
      Requests a Save Changes alert box that asks the user whether to save changes at some
      time other than closing or quitting. This is useful when your application prompts the
      user to save documents at timed intervals, for example.

|#

(defun ask-save-changes (document &key action message)
  "Displays a Save Changes alert box, returning when the user makes a choice"
  (cond
    ((and (boundp '*nav-services-available*) *nav-services-available*)
      (rlet ((reply :NavAskSaveChangesResult)
             (options :navdialogoptions))         
          (set-default-dialog-options options
            :message
              (or message
                (when (typep document 'window)
                  (format NIL 
                    (ecase action 
                      ((NIL) "Do you want to save the document ~s?") 
                      (:quitting "Do you want to save the document ~s before quitting this application?")
                      (:closing "Do you want to save the document ~s before closing the window?"))
                    (window-title document))))
            :savedFileName 
              (etypecase document
                ((or string pathname) 
                  (mac-file-namestring document))
                (window 
                  (window-title document))))
          (check-nav-result
            (if (or message (typep document 'window))
             (#_NavCustomAskSaveChanges options reply (or *event-ptr* *null-ptr*) 999)
             (#_NavAskSaveChanges 
              options
              (case action
                (:closing 1) ; kNavSaveChangesClosingDocument
                (:quitting 2) ; $kNavSaveChangesQuittingApplication
                (otherwise 0)) ; kNavSaveChangesOther
               reply
               (or *event-ptr* *null-ptr*)
               999))) ; callBackUD
         (ecase (%get-signed-long reply)
           (1 T) ; $kNavAskSaveChangesSave
           (2 (cancel))
           (3 NIL))))
    (T
      (y-or-n-dialog
        (etypecase document
           ((or string pathname) 
             (format nil "Save changes to file ~s?"
                          (namestring document)))
           (window
             (format nil "Save window ~s to a file?"
               (window-title document))))
        :help-spec '(:dialog 11061 :yes-text 11062 :no-text 11063 :cancel-text 11064)))))

(defun ask-discard-changes (document)
  "Display a confirmation alert box to use when a user selects Revert to Saved for a document with unsaved changes"
  (cond
    ((and (boundp '*nav-services-available*) *nav-services-available*)
      (rlet ((reply :NavAskDiscardChangesResult)
             (options :navdialogoptions))         
          (set-default-dialog-options options
            :savedFileName (mac-file-namestring document))
          (check-nav-result
            (#_NavAskDiscardChanges options reply (or *event-ptr* *null-ptr*) 999))
         (ecase (%get-signed-long reply)
           (1 T) ; $kNavAskDiscardChanges
           (2 NIL))))
    (T
       (y-or-n-dialog 
          (format nil
            "Throw away changes to or get newer version of ~s from disk?"
            (file-namestring document))
          :yes-text "Revert"
          :no-text "Cancel"
          :cancel-text nil))))

(let ((*warn-if-redefine* nil)
      (*warn-if-redefine-kernel* nil))

(defmethod window-ask-save ((w fred-mixin))
  (when (and (window-needs-saving-p w)
             (ask-save-changes (or (window-filename w) (view-window w)) 
               :action (if *quitting* :quitting :closing)))
    (window-save w)))

;; Use ask-discard-changes instead of y-or-n-dialog:

(defmethod window-revert ((w fred-mixin) &optional dont-prompt)
  (let ((my-file-name (window-filename w))
        (frec (frec w)))
    (when (and my-file-name
               (or dont-prompt
                   (ask-discard-changes my-file-name)))
      (unless (probe-file my-file-name)
        (signal-file-error $err-no-file my-file-name))
      (let* ((buf (fr.cursor frec))
             (size (buffer-size buf))
             stuff owner curs
             (mapper #'(lambda (frec)
                         (when (and (same-buffer-p buf (setq curs (fr.cursor frec)))
                                    (typep (setq owner (fr.owner frec)) 'fred-mixin))
                           (push (list curs
                                       owner
                                       (buffer-position curs)
                                       (buffer-position (fr.wposm frec)))
                                 stuff)))))
        (declare (dynamic-extent mapper))
        (map-frecs mapper)        
        (buffer-delete buf 0 t)
        (buffer-insert-file buf my-file-name)
        (clear-edit-history w)
        (let* ((new-size (buffer-size buf))
               (modcnt (buffer-modcnt buf)))
          (dolist (s stuff)
            (destructuring-bind (curs owner pos wpos) s
              (setf (file-modcnt owner) modcnt)
              (set-mark curs (if (%izerop size) 0
                                 (round (* pos new-size) size)))
              (set-fred-display-start-mark owner (if (%izerop size) 0
                                                     (round (* wpos new-size)
                                                            size)))
              (reparse-modeline owner t))))))))

)

#| DEMO

(require :nav-services)

(ask-save-changes "test.lisp")
(ask-discard-changes "test.lisp")
(ask-save-changes "test.lisp" :action :closing)
(ask-save-changes "test.lisp" :action :quitting)
(ask-save-changes "test.lisp" :message "Are you sure you want to keep the changes?")
(ask-save-changes (front-window))
(ask-save-changes (front-window) :action :closing)
(ask-save-changes (front-window) :action :quitting)

(y-or-n-dialog "Save changes to file?")
|#

;;;;;;;;;;;;;;;;;;;;;;;;;

(provide :ask-save-changes)