source: release/1.3/source/examples/cocoa/easygui/dialogs.lisp @ 11841

Last change on this file since 11841 was 11841, checked in by cater, 10 years ago

Canned EASYGUI dialogs

File size: 4.4 KB
Line 
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 (ccl::%make-nsstring message))
16    (#/addButtonWithTitle: alert (ccl::%make-nsstring "Yes"))
17    (#/addButtonWithTitle: alert (ccl::%make-nsstring "No"))
18    (eql (#/runModal alert) #$NSAlertFirstButtonReturn)))
19
20(defvar *beepnsleep* t)
21
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
26        (when button-string
27          (setf button-string (ccl::%make-nsstring button-string))
28          (dcc (#/setPrompt: panel button-string)))
29        (when (eql #$NSOKButton
30                   (dcc (#/runModalForDirectory:file:types: panel
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)))
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.
39          (let* ((files (dcc (#/filenames panel))) thing)
40            (if (eql 1 (dcc (#/count files)))
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."))))))
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
50        (when button-string (dcc (#/setPrompt: panel (ccl::%make-nsstring button-string))))
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))
72      (dcc (#/setTitle: panel (ccl::%make-nsstring prompt)))
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)
77       (ccl::%make-nsstring "NSWindowWillCloseNotification")
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
84       (ccl::%make-nsstring "NSWindowWillCloseNotification")
85       panel))
86      (dcc (#/retain (dcc (#/color panel)))))))
Note: See TracBrowser for help on using the repository browser.