| [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)))
|
|---|
| 15 | (#/setMessageText: alert message)
|
|---|
| 16 | (#/addButtonWithTitle: alert "Yes")
|
|---|
| 17 | (#/addButtonWithTitle: alert "No")
|
|---|
| 18 | (eql (#/runModal alert) #$NSAlertFirstButtonReturn)))
|
|---|
| 19 |
|
|---|
| 20 | (defun choose-file-dialog (&key button-string)
|
|---|
| 21 | (declare (ignorable button-string))
|
|---|
| 22 | (gui::with-autorelease-pool
|
|---|
| 23 | (let* ((panel (dcc (#/autorelease (dcc (#/openPanel ns:ns-open-panel)))))) ; allocate an NSOpenPanel
|
|---|
| 24 | (dcc (#/setAllowsMultipleSelection: panel nil)) ; return at most one filename
|
|---|
| 25 | (when button-string (dcc (#/setPrompt: panel button-string)))
|
|---|
| 26 | (when (eql #$NSOKButton
|
|---|
| 27 | (dcc (#/runModalForDirectory:file:types: panel
|
|---|
| 28 | +null-ptr+ ; default to last dir used
|
|---|
| 29 | +null-ptr+ ; no preselected file
|
|---|
| 30 | ;; If not NIL below then an ObjC array containing NSStrings could be used
|
|---|
| 31 | ;; to restrict the file types we're interested in
|
|---|
| 32 | #$NIL)))
|
|---|
| 33 | ;; Because we told the panel to disallow multiple selection,
|
|---|
| 34 | ;; there should be exactly one object in this array, an
|
|---|
| 35 | ;; NSString describing the selected file.
|
|---|
| 36 | (let* ((files (dcc (#/filenames panel))))
|
|---|
| 37 | (if (eql 1 (dcc (#/count files)))
|
|---|
| 38 | (gui::lisp-string-from-nsstring (dcc (#/objectAtIndex: files 0)))
|
|---|
| 39 | (error "Don't know why we didn't get an NSArray containing exactly 1 file here.")))))))
|
|---|
| 40 |
|
|---|
| 41 | (defun choose-new-file-dialog (&key button-string)
|
|---|
| 42 | (declare (ignorable button-string))
|
|---|
| 43 | (gui::with-autorelease-pool
|
|---|
| 44 | (let* ((panel (dcc (#/autorelease (dcc (#/savePanel ns:ns-save-panel)))))) ; allocate an NSSavePanel
|
|---|
| 45 | (when button-string (dcc (#/setPrompt: panel button-string)))
|
|---|
| 46 | (when (eql #$NSOKButton
|
|---|
| 47 | (dcc (#/runModalForDirectory:file: panel
|
|---|
| 48 | +null-ptr+ ; default to last dir used
|
|---|
| 49 | +null-ptr+)))
|
|---|
| 50 | ;; Because we told the panel to disallow multiple selection,
|
|---|
| 51 | ;; there should be exactly one object in this array, an
|
|---|
| 52 | ;; NSString describing the selected file.
|
|---|
| 53 | (let* ((files (dcc (#/filenames panel))))
|
|---|
| 54 | (if (eql 1 (dcc (#/count files)))
|
|---|
| 55 | (gui::lisp-string-from-nsstring (dcc (#/objectAtIndex: files 0)))
|
|---|
| 56 | (error "Don't know why we didn't get an NSArray containing exactly 1 file here.")))))))
|
|---|
| 57 |
|
|---|
| 58 | (objc:defmethod (#/NSWindowWillCloseNotification :void) ((self ns:ns-color-panel))
|
|---|
| 59 | (dcc (#/stopModal (#/sharedApplication ns:ns-application))))
|
|---|
| 60 |
|
|---|
| 61 | (defun user-pick-color (&key color (prompt "Pick a color") position)
|
|---|
| 62 | "POSITION argument is provided only for Digitool MCL compatibility, it is ignored"
|
|---|
| 63 | (declare (ignore position))
|
|---|
| 64 | (gui::with-autorelease-pool
|
|---|
| 65 | (let* ((panel (dcc (#/sharedColorPanel ns:ns-color-panel)))) ; find or create the NSColorPanel
|
|---|
| 66 | (dcc (#/setPickerMode: ns:ns-color-panel #$NSWheelModeColorPanel))
|
|---|
| 67 | (dcc (#/setTitle: panel prompt))
|
|---|
| 68 | (dcc (#/addObserver:selector:name:object: ; observe yourself close but
|
|---|
| 69 | (dcc (#/defaultCenter ns:ns-notification-center)) ; sadly confound OK & CANCEL
|
|---|
| 70 | panel
|
|---|
| 71 | (objc:\@selector #/NSWindowWillCloseNotification)
|
|---|
| 72 | "NSWindowWillCloseNotification"
|
|---|
| 73 | panel))
|
|---|
| 74 | (when color (dcc (#/setColor: panel color)))
|
|---|
| 75 | (dcc (#/runModalForWindow: (#/sharedApplication ns:ns-application) panel))
|
|---|
| 76 | (dcc (#/removeObserver:name:object: ; prevent pileup
|
|---|
| 77 | (dcc (#/defaultCenter ns:ns-notification-center))
|
|---|
| 78 | panel
|
|---|
| 79 | "NSWindowWillCloseNotification"
|
|---|
| 80 | panel))
|
|---|
| 81 | (dcc (#/retain (dcc (#/color panel)))))))
|
|---|
