| [11798] | 1 | (in-package :easygui)
|
|---|
| 2 |
|
|---|
| 3 | ;;; Contributed to Clozure CL by AWSC, Feb 2009.
|
|---|
| 4 | ;;; Permission is granted to use, redistribute, and modify.
|
|---|
| 5 | ;;;
|
|---|
| 6 | ;;; Provides some generally useful dialogs:
|
|---|
| 7 | ;;; y-or-n-dialog
|
|---|
| 8 | ;;; choose-file-dialog (original from Gary Byers)
|
|---|
| 9 | ;;; choose-new-file-dialog (adapted from that)
|
|---|
| 10 | ;;; user-pick-color (TODO: improve)
|
|---|
| 11 | ;;; To use them you will probably want to set *debug-cocoa-calls* to NIL.
|
|---|
| 12 |
|
|---|
| 13 | (defun y-or-n-dialog (message)
|
|---|
| 14 | (let ((alert (make-instance 'ns:ns-alert)))
|
|---|
| [11841] | 15 | (#/setMessageText: alert (ccl::%make-nsstring message))
|
|---|
| 16 | (#/addButtonWithTitle: alert (ccl::%make-nsstring "Yes"))
|
|---|
| 17 | (#/addButtonWithTitle: alert (ccl::%make-nsstring "No"))
|
|---|
| [11798] | 18 | (eql (#/runModal alert) #$NSAlertFirstButtonReturn)))
|
|---|
| 19 |
|
|---|
| [11841] | 20 | (defvar *beepnsleep* t)
|
|---|
| 21 |
|
|---|
| [11798] | 22 | (defun choose-file-dialog (&key button-string)
|
|---|
| 23 | (gui::with-autorelease-pool
|
|---|
| 24 | (let* ((panel (dcc (#/autorelease (dcc (#/openPanel ns:ns-open-panel)))))) ; allocate an NSOpenPanel
|
|---|
| 25 | (dcc (#/setAllowsMultipleSelection: panel nil)) ; return at most one filename
|
|---|
| [11841] | 26 | (when button-string
|
|---|
| 27 | (setf button-string (ccl::%make-nsstring button-string))
|
|---|
| 28 | (dcc (#/setPrompt: panel button-string)))
|
|---|
| [11798] | 29 | (when (eql #$NSOKButton
|
|---|
| 30 | (dcc (#/runModalForDirectory:file:types: panel
|
|---|
| [11841] | 31 | +null-ptr+ ; default to last dir used
|
|---|
| 32 | +null-ptr+ ; no preselected file
|
|---|
| 33 | ;; If not NIL below then an ObjC array containing NSStrings could be used
|
|---|
| 34 | ;; to restrict the file types we're interested in
|
|---|
| 35 | #$NIL)))
|
|---|
| [11798] | 36 | ;; Because we told the panel to disallow multiple selection,
|
|---|
| 37 | ;; there should be exactly one object in this array, an
|
|---|
| 38 | ;; NSString describing the selected file.
|
|---|
| [11841] | 39 | (let* ((files (dcc (#/filenames panel))) thing)
|
|---|
| [11798] | 40 | (if (eql 1 (dcc (#/count files)))
|
|---|
| [11841] | 41 | (progn
|
|---|
| 42 | (setf thing (dcc (#/objectAtIndex: files 0)))
|
|---|
| 43 | (gui::lisp-string-from-nsstring thing))
|
|---|
| 44 | "Don't know why we didn't get an NSArray containing exactly 1 file here."))))))
|
|---|
| [11798] | 45 |
|
|---|
| 46 | (defun choose-new-file-dialog (&key button-string)
|
|---|
| 47 | (declare (ignorable button-string))
|
|---|
| 48 | (gui::with-autorelease-pool
|
|---|
| 49 | (let* ((panel (dcc (#/autorelease (dcc (#/savePanel ns:ns-save-panel)))))) ; allocate an NSSavePanel
|
|---|
| [11841] | 50 | (when button-string (dcc (#/setPrompt: panel (ccl::%make-nsstring button-string))))
|
|---|
| [11798] | 51 | (when (eql #$NSOKButton
|
|---|
| 52 | (dcc (#/runModalForDirectory:file: panel
|
|---|
| 53 | +null-ptr+ ; default to last dir used
|
|---|
| 54 | +null-ptr+)))
|
|---|
| 55 | ;; Because we told the panel to disallow multiple selection,
|
|---|
| 56 | ;; there should be exactly one object in this array, an
|
|---|
| 57 | ;; NSString describing the selected file.
|
|---|
| 58 | (let* ((files (dcc (#/filenames panel))))
|
|---|
| 59 | (if (eql 1 (dcc (#/count files)))
|
|---|
| 60 | (gui::lisp-string-from-nsstring (dcc (#/objectAtIndex: files 0)))
|
|---|
| 61 | (error "Don't know why we didn't get an NSArray containing exactly 1 file here.")))))))
|
|---|
| 62 |
|
|---|
| 63 | (objc:defmethod (#/NSWindowWillCloseNotification :void) ((self ns:ns-color-panel))
|
|---|
| 64 | (dcc (#/stopModal (#/sharedApplication ns:ns-application))))
|
|---|
| 65 |
|
|---|
| 66 | (defun user-pick-color (&key color (prompt "Pick a color") position)
|
|---|
| 67 | "POSITION argument is provided only for Digitool MCL compatibility, it is ignored"
|
|---|
| 68 | (declare (ignore position))
|
|---|
| 69 | (gui::with-autorelease-pool
|
|---|
| 70 | (let* ((panel (dcc (#/sharedColorPanel ns:ns-color-panel)))) ; find or create the NSColorPanel
|
|---|
| 71 | (dcc (#/setPickerMode: ns:ns-color-panel #$NSWheelModeColorPanel))
|
|---|
| [11841] | 72 | (dcc (#/setTitle: panel (ccl::%make-nsstring prompt)))
|
|---|
| [11798] | 73 | (dcc (#/addObserver:selector:name:object: ; observe yourself close but
|
|---|
| 74 | (dcc (#/defaultCenter ns:ns-notification-center)) ; sadly confound OK & CANCEL
|
|---|
| 75 | panel
|
|---|
| 76 | (objc:\@selector #/NSWindowWillCloseNotification)
|
|---|
| [11841] | 77 | (ccl::%make-nsstring "NSWindowWillCloseNotification")
|
|---|
| [11798] | 78 | panel))
|
|---|
| 79 | (when color (dcc (#/setColor: panel color)))
|
|---|
| 80 | (dcc (#/runModalForWindow: (#/sharedApplication ns:ns-application) panel))
|
|---|
| 81 | (dcc (#/removeObserver:name:object: ; prevent pileup
|
|---|
| 82 | (dcc (#/defaultCenter ns:ns-notification-center))
|
|---|
| 83 | panel
|
|---|
| [11841] | 84 | (ccl::%make-nsstring "NSWindowWillCloseNotification")
|
|---|
| [11798] | 85 | panel))
|
|---|
| 86 | (dcc (#/retain (dcc (#/color panel)))))))
|
|---|
