source: trunk/source/cocoa-ide/file-dialogs.lisp

Last change on this file was 16686, checked in by rme, 4 years ago

Update copyright/license headers in cocoa-ide directory.

File size: 5.0 KB
Line 
1;;;
2;;; Copyright 2016 Clozure Associates
3;;;
4;;; Licensed under the Apache License, Version 2.0 (the "License");
5;;; you may not use this file except in compliance with the License.
6;;; You may obtain a copy of the License at
7;;;
8;;;     http://www.apache.org/licenses/LICENSE-2.0
9;;;
10;;; Unless required by applicable law or agreed to in writing, software
11;;; distributed under the License is distributed on an "AS IS" BASIS,
12;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
13;;; See the License for the specific language governing permissions and
14;;; limitations under the License.
15(in-package "GUI")
16
17;;;; MCL-ish file dialogs
18
19(defun %cocoa-choose-file-dialog (directory file-types file button-string)
20  (assume-cocoa-thread)
21  (let* ((open-panel (#/openPanel ns:ns-open-panel))
22         (types-array +null-ptr+))
23    ;; Maybe support multiple file selection later.
24    (#/setAllowsMultipleSelection: open-panel #$NO)
25    (when directory
26      (setq directory (#/autorelease (%make-nsstring directory))))
27    (when file
28      (setq file (#/autorelease (%make-nsstring file))))
29    (when file-types
30      (setq types-array (make-instance 'ns:ns-mutable-array))
31      (dolist (type file-types)
32        (let ((s (%make-nsstring type)))
33          (#/addObject: types-array s)
34          (#/release s)))
35      (#/autorelease types-array))
36    (when button-string
37      (#/setPrompt: open-panel (#/autorelease (%make-nsstring button-string))))
38    (let ((result (#/runModalForDirectory:file:types: open-panel directory
39                                                      file types-array)))
40      (cond ((= result #$NSOKButton)
41             (lisp-string-from-nsstring (#/filename open-panel)))
42            ((= result #$NSCancelButton)
43             nil)
44            (t
45             (error "couldn't run the open panel: error code ~d" result))))))
46       
47(defun cocoa-choose-file-dialog (&key directory file-types file button-string)
48  (when directory
49    (setq directory (directory-namestring directory)))
50  (when file-types
51    (unless (and (listp file-types)
52                 (every #'stringp file-types))
53      (error "~s is not a list of strings." file-types)))
54  (when file
55    (setq file (file-namestring file)))
56  (check-type button-string (or null string))
57  (execute-in-gui #'(lambda () (%cocoa-choose-file-dialog directory file-types file button-string))))
58
59(defun %cocoa-choose-new-file-dialog (directory file-types file)
60  (assume-cocoa-thread)
61  (let* ((save-panel (#/savePanel ns:ns-save-panel))
62         (types-array +null-ptr+))
63    #-cocotron (#/setCanSelectHiddenExtension: save-panel t)
64    (when directory
65      (setq directory (#/autorelease (%make-nsstring directory))))
66    (when file
67      (setq file (#/autorelease (%make-nsstring file))))
68    (when file-types
69      (setq types-array (make-instance 'ns:ns-mutable-array))
70      (dolist (type file-types)
71        (let ((s (%make-nsstring type)))
72          (#/addObject: types-array s)
73          (#/release s)))
74      (#/autorelease types-array))
75    #-cocotron (#/setAllowedFileTypes: save-panel types-array)
76    (let ((result (#/runModalForDirectory:file: save-panel directory file)))
77      (cond ((= result #$NSOKButton)
78             (lisp-string-from-nsstring (#/filename save-panel)))
79            ((= result #$NSCancelButton)
80             nil)
81            (t
82             (error "couldn't run the save panel: error code ~d" result))))))
83
84(defun cocoa-choose-new-file-dialog (&key directory file-types file)
85  (when directory
86    (setq directory (directory-namestring directory)))
87  (when file
88    (setq file (file-namestring file)))
89  (when file-types
90    (unless (and (listp file-types)
91                 (every #'stringp file-types))
92      (error "~s is not a list of strings." file-types)))
93  (execute-in-gui #'(lambda () (%cocoa-choose-new-file-dialog directory file-types file))))
94
95(defun cocoa-choose-file-dialog-hook-function (must-exist prompt file-types)
96  (declare (ignore prompt))
97  (if must-exist
98    (cocoa-choose-file-dialog :file-types file-types)
99    (cocoa-choose-new-file-dialog :file-types file-types)))
100
101(setq ccl::*choose-file-dialog-hook* 'cocoa-choose-file-dialog-hook-function)
102(setq ccl::*choose-directory-dialog-hook* 'cocoa-choose-directory-dialog)
103
104(defun %cocoa-choose-directory-dialog (directory)
105  (assume-cocoa-thread)
106  (let ((open-panel (#/openPanel ns:ns-open-panel)))
107    (#/setCanChooseFiles: open-panel #$NO)
108    (#/setCanChooseDirectories: open-panel #$YES)
109    (#/setAllowsMultipleSelection: open-panel #$NO)
110    (#/setTitle: open-panel #@"Choose Directory")
111    (#/setPrompt: open-panel #@"Choose")
112    (when directory
113      (setq directory (#/autorelease (%make-nsstring directory))))
114    (let  ((result (#/runModalForDirectory:file:types: open-panel directory
115                                                       nil nil)))
116      (cond ((= result #$NSOKButton)
117             (make-pathname :directory (lisp-string-from-nsstring
118                                        (#/directory open-panel))))
119            ((= result #$NSCancelButton)
120             nil)
121            (t
122             (error "couldn't run the open panel: error code ~d" result))))))
123
124(defun cocoa-choose-directory-dialog (&key directory)
125  (when directory
126    (setq directory (directory-namestring directory)))
127  (execute-in-gui #'(lambda () (%cocoa-choose-directory-dialog directory))))
Note: See TracBrowser for help on using the repository browser.