1
;;; Copyright (c) 2005, Michael Goffioul (michael dot goffioul at swing dot be)
3
;;; This program is free software; you can redistribute it and/or
4
;;; modify it under the terms of the GNU Library General Public
5
;;; License as published by the Free Software Foundation; either
6
;;; version 2 of the License, or (at your option) any later version.
8
;;; See file '../../Copyright' for full details.
10
;;; SAMPLE TEXT EDITOR APPLICATION USING THE WIN32 API
13
(require "WIN32" "win32")
17
(defvar *txtedit-class-registered* nil)
18
(defvar *txtedit-width* 800)
19
(defvar *txtedit-height* 600)
21
(defvar *txtedit-edit* nil)
22
(defvar *txtedit-tab* *NULL*)
23
(defvar *txtedit-tab-proc* *NULL*)
24
(defvar *txtedit-current* nil)
25
(defvar *txtedit-edit-class* 0)
26
(defvar *txtedit-process* nil)
27
(defvar *txtedit-handle* *NULL*)
28
(defvar *txtedit-files* nil)
29
(defvar *txtedit-dlg-handle* *NULL*)
30
(defvar *txtedit-findreplace-msg* (registerwindowmessage *FINDMSGSTRING*))
31
(defstruct txtedit (handle *NULL*) title dirty)
33
(defvar *txtedit-default-title* "ECL Text Editor")
35
(defparameter +IDM_OPEN+ 100)
36
(defparameter +IDM_QUIT+ 101)
37
(defparameter +IDM_SAVE+ 102)
38
(defparameter +IDM_SAVEAS+ 103)
39
(defparameter +IDM_NEW+ 104)
40
(defparameter +IDM_CUT+ 105)
41
(defparameter +IDM_COPY+ 106)
42
(defparameter +IDM_PASTE+ 107)
43
(defparameter +IDM_UNDO+ 108)
44
(defparameter +IDM_SELECTALL+ 109)
45
(defparameter +IDM_ABOUT+ 110)
46
(defparameter +IDM_NEXTWINDOW+ 111)
47
(defparameter +IDM_PREVWINDOW+ 112)
48
(defparameter +IDM_CLOSE+ 113)
49
(defparameter +IDM_MATCH_PAREN+ 114)
50
(defparameter +IDM_FIND+ 115)
51
(defparameter +IDM_WINDOW_FIRST+ 500)
52
(defparameter +IDM_WINDOW_LAST+ 600)
54
(defparameter +EDITCTL_ID+ 1000)
55
(defparameter +TABCTL_ID+ 1001)
57
(defparameter *txtedit-about-text*
60
This application serves as a demonstrator
61
for the WIN32 FFI interface of ECL.
63
Copyright (c) 2005, Michael Goffioul.")
65
(defun create-menus ()
67
(let ((bar (createmenu))
68
(file_pop (createpopupmenu))
69
(edit_pop (createpopupmenu))
70
(win_pop (createpopupmenu))
71
(help_pop (createpopupmenu)))
73
(appendmenu bar (logior *MF_STRING* *MF_POPUP*) (make-wparam file_pop) "&File")
74
(appendmenu file_pop *MF_STRING* +IDM_NEW+ "&New Ctrl+N")
75
(appendmenu file_pop *MF_STRING* +IDM_OPEN+ "&Open... Ctrl+O")
76
(appendmenu file_pop *MF_STRING* +IDM_CLOSE+ "&Close Ctrl+W")
77
(appendmenu file_pop *MF_SEPARATOR* 0 "")
78
(appendmenu file_pop *MF_STRING* +IDM_SAVE+ "&Save Ctrl+S")
79
(appendmenu file_pop *MF_STRING* +IDM_SAVEAS+ "Save &As...")
80
(appendmenu file_pop *MF_SEPARATOR* 0 "")
81
(appendmenu file_pop *MF_STRING* +IDM_QUIT+ "&Exit Ctrl+Q")
83
(appendmenu bar (logior *MF_STRING* *MF_POPUP*) (make-wparam edit_pop) "&Edit")
84
(appendmenu edit_pop *MF_STRING* +IDM_UNDO+ "&Undo Ctrl+Z")
85
(appendmenu edit_pop *MF_SEPARATOR* 0 "")
86
(appendmenu edit_pop *MF_STRING* +IDM_CUT+ "&Cut Ctrl+X")
87
(appendmenu edit_pop *MF_STRING* +IDM_COPY+ "Cop&y Ctrl+C")
88
(appendmenu edit_pop *MF_STRING* +IDM_PASTE+ "&Paste Ctrl+V")
89
(appendmenu edit_pop *MF_SEPARATOR* 0 "")
90
(appendmenu edit_pop *MF_STRING* +IDM_MATCH_PAREN+ "&Match parenthesis Ctrl+D")
91
(appendmenu edit_pop *MF_SEPARATOR* 0 "")
92
(appendmenu edit_pop *MF_STRING* +IDM_SELECTALL+ "&Select All Ctrl+A")
94
(appendmenu bar (logior *MF_STRING* *MF_POPUP*) (make-wparam win_pop) "&Window")
95
(appendmenu win_pop *MF_STRING* +IDM_NEXTWINDOW+ "&Next Ctrl+Right")
96
(appendmenu win_pop *MF_STRING* +IDM_PREVWINDOW+ "&Previous Ctrl+Left")
98
(appendmenu bar (logior *MF_STRING* *MF_POPUP*) (make-wparam help_pop) "&Help")
99
(appendmenu help_pop *MF_STRING* +IDM_ABOUT+ "&About...")
102
(defun create-accels ()
103
(macrolet ((add-accel (key ID accTable pos)
104
`(with-foreign-object (a 'ACCEL)
105
(setf (get-slot-value a 'ACCEL 'fVirt) (logior *FCONTROL* *FVIRTKEY*))
106
(setf (get-slot-value a 'ACCEL 'key) ,(if (characterp key) `(char-code ,key) key))
107
(setf (get-slot-value a 'ACCEL 'cmd) ,ID)
108
(setf (deref-array ,accTable '(* ACCEL) ,pos) a))))
109
(let* ((accTableSize (if (= *txtedit-edit-class* 2) 10 9))
110
(accTable (allocate-foreign-object 'ACCEL accTableSize)))
111
(add-accel #\Q +IDM_QUIT+ accTable 0)
112
(add-accel #\N +IDM_NEW+ accTable 1)
113
(add-accel #\O +IDM_OPEN+ accTable 2)
114
(add-accel #\S +IDM_SAVE+ accTable 3)
115
(add-accel #\A +IDM_SELECTALL+ accTable 4)
116
(add-accel *VK_LEFT* +IDM_PREVWINDOW+ accTable 5)
117
(add-accel *VK_RIGHT* +IDM_NEXTWINDOW+ accTable 6)
118
(add-accel #\W +IDM_CLOSE+ accTable 7)
119
(add-accel #\F +IDM_FIND+ accTable 8)
120
(when (= *txtedit-edit-class* 2)
121
(add-accel #\D +IDM_MATCH_PAREN+ accTable 9))
123
(createacceleratortable accTable accTableSize)
124
(free-foreign-object accTable)))))
126
(defun update-caption (hwnd)
127
(let ((str (tab-name (current-editor) #'identity nil)))
128
(setwindowtext hwnd (format nil "~@[~A - ~]~A~C" str *txtedit-default-title* #\Null))))
130
(defun current-editor ()
131
(nth *txtedit-current* *txtedit-edit*))
133
(defun tab-name (editor &optional (fun #'file-namestring) (final-char #\Null))
134
(format nil "~:[New~;~:*~A~]~@[*~*~]~@[~C~]"
135
(and (txtedit-title editor) (funcall fun (txtedit-title editor)))
136
(txtedit-dirty editor) final-char))
138
(defun update-tab (idx)
139
(let ((editor (nth idx *txtedit-edit*)))
140
(with-foreign-object (tab 'TCITEM)
141
(setf (get-slot-value tab 'TCITEM 'mask) *TCIF_TEXT*)
142
(setf (get-slot-value tab 'TCITEM 'pszText) (tab-name editor))
143
(sendmessage *txtedit-tab* *TCM_SETITEM* idx (make-lparam tab))
146
(defun set-current-editor (idx hwnd &optional force-p)
147
(when (<= 0 idx (1- (length *txtedit-edit*)))
148
(let ((old-ed (and *txtedit-current*
150
(new-ed (nth idx *txtedit-edit*)))
151
(unless (and (null force-p)
153
(setq *txtedit-current* idx)
154
(setwindowpos (txtedit-handle new-ed) *HWND_TOP* 0 0 0 0 (logior *SWP_NOSIZE* *SWP_NOMOVE*))
155
(setfocus (txtedit-handle new-ed))
156
(when (/= (sendmessage *txtedit-tab* *TCM_GETCURSEL* 0 0) idx)
157
(sendmessage *txtedit-tab* *TCM_SETCURSEL* idx 0))
158
(update-caption hwnd)))))
160
(defun close-editor (idx hwnd)
161
(let ((editor (nth idx *txtedit-edit*)))
162
(if (or (null (txtedit-dirty editor))
163
(and (set-current-editor idx hwnd) nil)
164
(let ((m-result (messagebox hwnd (format nil "Do you want to save changes?~@[~2%~A~%~]~C"
165
(txtedit-title editor) #\Null)
166
"Confirmation" (logior *MB_YESNOCANCEL* *MB_ICONQUESTION*))))
167
(cond ((= m-result *IDNO*) t)
168
((= m-result *IDCANCEL*) nil)
169
((= m-result *IDYES*) (warn "Not implemented") nil))))
171
(destroywindow (txtedit-handle editor))
172
(sendmessage *txtedit-tab* *TCM_DELETEITEM* idx 0)
173
(setq *txtedit-edit* (remove editor *txtedit-edit*))
175
(set-current-editor (min (1- (length *txtedit-edit*))
176
(max *txtedit-current*
182
(ffi:def-struct SCNotification (NotifyHeader NMHDR) (position :int) (ch :int))
184
(defun init-scintilla-component (hnd)
186
(sendmessage hnd 4001 21 0)
187
;(sendmessage hnd 2090 7 0)
188
;; Define default style attributes
189
(with-foreign-string (fn "Courier New")
190
(sendmessage hnd 2056 32 (make-lparam fn)))
191
(sendmessage hnd 2050 0 0)
192
;; Define comment style
193
(sendmessage hnd 2051 1 #xDD0000)
194
(sendmessage hnd 2054 1 0)
195
(sendmessage hnd 2051 12 #xDD0000)
196
(sendmessage hnd 2054 12 0)
197
;; Define string style
198
(sendmessage hnd 2051 6 #x0000C8)
199
;; Define number style
200
(sendmessage hnd 2051 2 #x0000C8)
201
;; Define operator style
202
(sendmessage hnd 2051 10 #xC800C8)
203
;; Define symbol style
204
(sendmessage hnd 2051 5 #xC8C800)
205
;; Define brace style
206
(sendmessage hnd 2052 34 #xFFCCCC)
207
(sendmessage hnd 2051 35 #xFFFFFF)
208
(sendmessage hnd 2052 35 #x0000CC)
209
;; Define keyword style
210
(sendmessage hnd 2051 3 #x00C8C8)
211
(sendmessage hnd 2053 3 0)
212
(sendmessage hnd 2051 4 #x00C800)
213
(sendmessage hnd 2051 11 #x00C800)
214
(unless (boundp '*txtedit-lisp-kw*)
215
(load "lisp-kw.lisp"))
216
(with-foreign-strings ((kwList *txtedit-lisp-kw*)
217
(kwList2 *txtedit-lisp-kw2*))
218
(sendmessage hnd 4005 0 (make-lparam kwList))
219
(sendmessage hnd 4005 1 (make-lparam kwList2)))
221
(sendmessage hnd 2242 1 0)
222
(with-foreign-string (s "_9999")
223
(sendmessage hnd 2242 0 (sendmessage hnd 2276 33 (make-lparam s))))
224
;; Define selection style
225
(sendmessage hnd 2067 1 #xFFFFFF)
228
(defun scintilla-indent-position (pos line hnd)
229
(+ (sendmessage hnd 2127 line 0)
231
(sendmessage hnd 2128 line 0))))
233
(defun scintilla-read-form (pos hnd)
235
(with-output-to-string (s)
237
with style = (sendmessage hnd 2010 pos 0)
238
for ch = (code-char (sendmessage hnd 2007 k 0))
239
for st = (sendmessage hnd 2010 k 0)
242
(not (eq ch #\Space)))
248
(defun scintilla-declare-form-p (form)
249
(member form *txtedit-decl-forms*))
251
(defun scintilla-compute-indentation (curPos curLine hnd)
252
(loop for k from curPos downto 0
253
for ch = (code-char (sendmessage hnd 2007 k 0))
254
for st = (sendmessage hnd 2010 k 0)
257
with lastCharPos = nil
258
with prevCharPos = nil
260
do (cond ((and (= depth 0) (eq ch #\())
262
(let ((lastChar (code-char (sendmessage hnd 2007 lastCharPos 0)))
264
(cond ((member lastChar (list #\( #\;))
265
(return (scintilla-indent-position lastCharPos curLine hnd)))
266
((and (setq lastForm (scintilla-read-form lastCharPos hnd))
267
(scintilla-declare-form-p lastForm))
268
(return (+ (scintilla-indent-position k curLine hnd) 2)))
269
((and prevCharPos (not (eq prevCharPos lastCharPos)))
270
(return (scintilla-indent-position prevCharPos curLine hnd)))
272
(return (+ (scintilla-indent-position lastCharPos curLine hnd) 1)))))
274
(return (+ (scintilla-indent-position k curLine hnd) 1)))))
275
((eq ch #\() (decf depth))
276
((eq ch #\)) (incf depth)))
277
if (and (graphic-char-p ch) (not (eq ch #\Space)))
278
do (setq lastCharPos k)
280
do (setq prevCharPos lastCharPos)
281
when (eq ch #\Newline)
282
do (decf curLine) and
284
(0 (incf lineIndent))
285
(1 (when (= depth 0) (return (sendmessage hnd 2127 (1+ curLine) 0)))))
286
finally (return -1)))
288
(defun scintilla-char-added (hnd ch)
289
(cond ((eq ch #\Newline)
290
(let* ((curPos (sendmessage hnd 2008 0 0))
291
(curLine (sendmessage hnd 2166 curPos 0))
292
(indent (scintilla-compute-indentation (1- curPos) curLine hnd)))
294
(sendmessage hnd 2126 curLine indent)
295
(sendmessage hnd 2025 (sendmessage hnd 2128 curLine 0) 0)
298
; (let ((curPos (1- (sendmessage hnd 2008 0 0))))
299
; (when (scintilla-valid-brace-p curPos hnd)
300
; (with-foreign-string (s ")")
301
; (sendmessage hnd 2003 (1+ curPos) (make-lparam s))))))
305
(defun scintilla-get-matching-braces (hnd &aux curPos)
306
(when (>= (setq curPos (1- (sendmessage hnd 2008 0 0))) 0)
307
(let ((ch (code-char (sendmessage hnd 2007 curPos 0))))
308
(when (and (or (eq ch #\() (eq ch #\)))
309
(= (sendmessage hnd 2010 curPos 0) 10))
310
(let ((matchPos (sendmessage hnd 2353 curPos 0)))
311
(return-from scintilla-get-matching-braces (values curPos matchPos))))))
314
(defun scintilla-check-for-brace (hnd)
315
(multiple-value-bind (curPos matchPos) (scintilla-get-matching-braces hnd)
318
(sendmessage hnd 2351 curPos matchPos)
319
(sendmessage hnd 2352 curPos 0))
320
(sendmessage hnd 2351 #xFFFFFFFF -1))))
322
(defun create-editor (parent &optional (set-current t))
323
(with-foreign-object (r 'RECT)
324
(getclientrect parent r)
325
(sendmessage *txtedit-tab* *TCM_ADJUSTRECT* *FALSE* (make-lparam r))
326
(let ((new-editor (make-txtedit :handle (createwindowex *WS_EX_CLIENTEDGE* (txtedit-class-name) ""
327
(logior *WS_CHILD* *WS_HSCROLL* *WS_VSCROLL* *WS_VISIBLE* *WS_CLIPSIBLINGS*
328
*ES_AUTOHSCROLL* *ES_AUTOVSCROLL* *ES_MULTILINE* *ES_LEFT*)
329
(get-slot-value r 'RECT 'left)
330
(get-slot-value r 'RECT 'top)
331
(- (get-slot-value r 'RECT 'right) (get-slot-value r 'RECT 'left))
332
(- (get-slot-value r 'RECT 'bottom) (get-slot-value r 'RECT 'top))
333
*txtedit-tab* (make-ID +EDITCTL_ID+) *NULL* *NULL*))))
334
(sendmessage (txtedit-handle new-editor) *WM_SETFONT* (make-wparam (getstockobject *SYSTEM_FIXED_FONT*)) 0)
335
(case *txtedit-edit-class*
336
(1 (sendmessage (txtedit-handle new-editor) *EM_SETEVENTMASK* 0 *ENM_CHANGE*))
337
(2 (init-scintilla-component (txtedit-handle new-editor))))
338
(with-foreign-object (tab 'TCITEM)
339
(setf (get-slot-value tab 'TCITEM 'mask) *TCIF_TEXT*)
340
(setf (get-slot-value tab 'TCITEM 'pszText) (tab-name new-editor))
341
(sendmessage *txtedit-tab* *TCM_INSERTITEM* (length *txtedit-edit*) (make-lparam tab)))
342
(setq *txtedit-edit* (append *txtedit-edit* (list new-editor)))
344
(set-current-editor (1- (length *txtedit-edit*)) parent))
347
(defun unix2dos (str)
348
(let ((new-str (make-array (length str) :element-type 'character :adjustable t :fill-pointer 0))
351
(with-output-to-string (out new-str)
352
(do ((it (si::make-seq-iterator str) (si::seq-iterator-next str it)))
354
(case (setq c (si::seq-iterator-ref str it))
355
(#\Return (setq return-p t))
356
(#\Newline (unless return-p (write-char #\Return out)) (setq return-p nil))
357
(t (setq return-p nil)))
361
(defun read-file (pn hwnd)
362
(setq pn (probe-file pn))
364
(with-open-file (f pn)
365
(let* ((len (file-length f))
366
(buf (make-string len)))
367
(read-sequence buf f)
368
(setwindowtext (txtedit-handle (current-editor)) (unix2dos buf))
369
(setf (txtedit-dirty (current-editor)) nil)
370
(setf (txtedit-title (current-editor)) (substitute #\\ #\/ (namestring pn)))
371
(update-caption hwnd)
372
(update-tab *txtedit-current*)))
373
(messagebox hwnd "File does not exist." "Error" (logior *MB_OK* *MB_ICONERROR*))))
375
(defun save-file (pn hwnd)
377
(setq pn (txtedit-title (current-editor))))
378
(with-open-file (f pn :direction :output :if-does-not-exist :create :if-exists :supersede)
379
(let ((txt (getwindowtext (txtedit-handle (current-editor)))))
380
(write-sequence txt f)
381
(setf (txtedit-title (current-editor)) (substitute #\\ #\/(namestring pn)))
382
(setf (txtedit-dirty (current-editor)) nil)
383
(update-caption hwnd)
384
(update-tab *txtedit-current*))))
386
(defun close-or-exit (idx hwnd)
387
(if (= (length *txtedit-edit*) 1)
388
(postmessage hwnd *WM_CLOSE* 0 0)
389
(close-editor idx hwnd)))
391
(defun tab-proc (hwnd umsg wparam lparam)
392
(cond ((or (= umsg *WM_COMMAND*)
393
(= umsg *WM_NOTIFY*))
394
(txtedit-proc (getparent hwnd) umsg wparam lparam))
396
(callwindowproc *txtedit-tab-proc* hwnd umsg wparam lparam))))
398
(defvar *txtedit-level* 0)
399
(defun txtedit-proc (hwnd umsg wparam lparam &aux (*txtedit-level* (1+ *txtedit-level*)))
400
;(format t "txtedit-proc: ~D~%" *txtedit-level*)
401
(cond ((= umsg *WM_DESTROY*)
406
((not (and *txtedit-edit* flag)) flag)
407
(setq flag (close-editor 0 hwnd)))
410
((= umsg *WM_CREATE*)
411
(when (null-pointer-p (getmodulehandle "comctl32"))
412
(initcommoncontrols))
413
(setq *txtedit-tab* (createwindowex 0 *WC_TABCONTROL* ""
414
(logior *WS_CHILD* *WS_VISIBLE* *WS_CLIPCHILDREN*) 0 0 0 0
415
hwnd (make-ID +TABCTL_ID+) *NULL* *NULL*))
416
(setq *txtedit-tab-proc* (register-wndproc *txtedit-tab* #'tab-proc))
417
(sendmessage *txtedit-tab* *WM_SETFONT* (make-wparam (getstockobject *DEFAULT_GUI_FONT*)) 0)
419
(with-cast-int-pointer (lparam CREATESTRUCT)
420
(let ((params (get-slot-value lparam 'CREATESTRUCT 'lpCreateParams)))
421
(unless (null-pointer-p params)
422
(read-file (convert-from-foreign-string params) hwnd))))
425
(unless (null-pointer-p *txtedit-tab*)
426
(movewindow *txtedit-tab* 0 0 (loword lparam) (hiword lparam) *TRUE*)
427
(with-foreign-object (r 'RECT)
428
(setrect r 0 0 (loword lparam) (hiword lparam))
429
(sendmessage *txtedit-tab* *TCM_ADJUSTRECT* *FALSE* (make-lparam r))
430
(dotimes (k (length *txtedit-edit*))
431
(movewindow (txtedit-handle (nth k *txtedit-edit*))
432
(get-slot-value r 'RECT 'left) (get-slot-value r 'RECT 'top)
433
(- (get-slot-value r 'RECT 'right) (get-slot-value r 'RECT 'left))
434
(- (get-slot-value r 'RECT 'bottom) (get-slot-value r 'RECT 'top))
435
(if (= k *txtedit-current*) *TRUE* *FALSE*)))))
437
((= umsg *WM_SETFOCUS*)
438
(unless (null-pointer-p (txtedit-handle (current-editor)))
439
(setfocus (txtedit-handle (current-editor))))
441
((= umsg *WM_NOTIFY*)
442
(with-cast-int-pointer (lparam NMHDR)
443
(let ((ctrl-ID (get-slot-value lparam 'NMHDR 'idFrom))
444
(code (get-slot-value lparam 'NMHDR 'code))
445
(hnd (get-slot-value lparam 'NMHDR 'hwndFrom)))
446
(cond ((= ctrl-ID +TABCTL_ID+)
447
(cond ((= code *TCN_SELCHANGE*)
448
(set-current-editor (sendmessage hnd *TCM_GETCURSEL* 0 0) hwnd))
451
((and (= *txtedit-edit-class* 2)
453
(with-cast-pointer (lparam SCNotification)
454
(scintilla-char-added hnd (code-char (get-slot-value lparam 'SCNotification 'ch)))))
455
((and (= *txtedit-edit-class* 2)
457
(scintilla-check-for-brace hnd))
461
((= umsg *WM_CONTEXTMENU*)
462
(let ((hnd (make-handle wparam))
463
(x (get-x-lparam lparam))
464
(y (get-y-lparam lparam)))
465
(cond ((equal hnd *txtedit-tab*)
466
(with-foreign-objects ((ht 'TCHITTESTINFO)
468
(setf (get-slot-value pt 'POINT 'x) x)
469
(setf (get-slot-value pt 'POINT 'y) y)
470
(screentoclient *txtedit-tab* pt)
471
(setf (get-slot-value ht 'TCHITTESTINFO 'pt) pt)
472
(let ((tab (sendmessage *txtedit-tab* *TCM_HITTEST* 0 (make-lparam ht))))
474
(let ((hMenu (createpopupmenu))
476
(appendmenu hMenu *MF_STRING* +IDM_CLOSE+ "&Close")
477
(when (/= (setq menu-ID (trackpopupmenuex hMenu (logior *TPM_NONOTIFY* *TPM_RETURNCMD*) x y hwnd *NULL*)) 0)
478
(close-or-exit tab hwnd))
479
(destroymenu hMenu))))))))
481
((= umsg *WM_INITMENUPOPUP*)
482
(case (loword lparam)
483
(2 (let* ((wMenu (make-handle wparam))
484
(nPos (loword lparam))
485
(nItems (getmenuitemcount wMenu)))
486
(dotimes (j (- nItems 2))
487
(deletemenu wMenu 2 *MF_BYPOSITION*))
489
(appendmenu wMenu *MF_SEPARATOR* 0 "")
490
(loop for e in *txtedit-edit*
493
(appendmenu wMenu *MF_STRING* (+ +IDM_WINDOW_FIRST+ k) (tab-name e))
494
(when (= k *txtedit-current*)
495
(checkmenuitem wMenu (+ k 3) (logior *MF_BYPOSITION* *MF_CHECKED*))))))
496
(enablemenuitem wMenu +IDM_PREVWINDOW+ (if (= *txtedit-current* 0) *MF_GRAYED* *MF_ENABLED*))
497
(enablemenuitem wMenu +IDM_NEXTWINDOW+ (if (< *txtedit-current* (1- (length *txtedit-edit*))) *MF_ENABLED* *MF_GRAYED*))
501
((= umsg *WM_COMMAND*)
502
(let ((ctrl-ID (loword wparam))
503
(nmsg (hiword wparam))
504
(hnd (make-pointer lparam 'HANDLE)))
505
(cond ((= ctrl-ID +EDITCTL_ID+)
506
(cond ((= nmsg *EN_CHANGE*)
507
(unless (txtedit-dirty (current-editor))
508
(setf (txtedit-dirty (current-editor)) t)
509
(update-caption hwnd)
510
(update-tab *txtedit-current*)))
513
((= ctrl-ID +IDM_QUIT+)
514
(sendmessage hwnd *WM_CLOSE* 0 0))
515
((= ctrl-ID +IDM_OPEN+)
516
(let ((pn (get-open-filename :owner hwnd :filter '(("LISP source file (*.lisp)" . "*.lisp;*.lsp")
517
("All Files (*)" . "*")))))
520
(read-file pn hwnd))))
521
((and (= ctrl-ID +IDM_SAVE+)
522
(txtedit-title (current-editor)))
523
(save-file nil hwnd))
524
((or (= ctrl-ID +IDM_SAVEAS+)
525
(and (= ctrl-ID +IDM_SAVE+)
526
(null (txtedit-title (current-editor)))))
527
(let ((pn (get-open-filename :owner hwnd :filter '(("LISP source file (*.lisp)" . "*.lisp;*.lsp")
528
("All Files (*)" . "*"))
529
:dlgfn #'getsavefilename :flags *OFN_OVERWRITEPROMPT*)))
531
(save-file pn hwnd))))
532
((= ctrl-ID +IDM_NEW+)
533
(create-editor hwnd))
534
((= ctrl-ID +IDM_CUT+)
535
(sendmessage (txtedit-handle (current-editor)) *WM_CUT* 0 0))
536
((= ctrl-ID +IDM_COPY+)
537
(sendmessage (txtedit-handle (current-editor)) *WM_COPY* 0 0))
538
((= ctrl-ID +IDM_PASTE+)
539
(sendmessage (txtedit-handle (current-editor)) *WM_PASTE* 0 0))
540
((= ctrl-ID +IDM_UNDO+)
541
(unless (= (sendmessage (txtedit-handle (current-editor)) *EM_CANUNDO* 0 0) 0)
542
(sendmessage (txtedit-handle (current-editor)) *EM_UNDO* 0 0)))
543
((= ctrl-ID +IDM_SELECTALL+)
544
(sendmessage (txtedit-handle (current-editor)) *EM_SETSEL* 0 -1))
545
((= ctrl-ID +IDM_ABOUT+)
546
(messagebox hwnd *txtedit-about-text* "About" (logior *MB_OK* *MB_ICONINFORMATION*)))
547
((= ctrl-ID +IDM_NEXTWINDOW+)
548
(unless (>= (1+ *txtedit-current*) (length *txtedit-edit*))
549
(set-current-editor (1+ *txtedit-current*) hwnd)))
550
((= ctrl-ID +IDM_PREVWINDOW+)
551
(unless (= *txtedit-current* 0)
552
(set-current-editor (1- *txtedit-current*) hwnd)))
553
((= ctrl-ID +IDM_CLOSE+)
554
(close-or-exit *txtedit-current* hwnd))
555
((= ctrl-ID +IDM_MATCH_PAREN+)
556
(let ((hnd (txtedit-handle (current-editor))))
557
(multiple-value-bind (curPos matchPos) (scintilla-get-matching-braces hnd)
558
(when (and curPos (>= matchPos 0))
559
(sendmessage hnd 2025 (1+ matchPos) 0)))))
560
((= ctrl-ID +IDM_FIND+)
561
(let* ((fr (allocate-foreign-object 'FINDREPLACE))
562
(str (make-string 1024 :initial-element #\Null)))
563
(zeromemory fr (size-of-foreign-type 'FINDREPLACE))
564
(setf (get-slot-value fr 'FINDREPLACE 'lStructSize) (size-of-foreign-type 'FINDREPLACE))
565
(setf (get-slot-value fr 'FINDREPLACE 'hwndOwner) hwnd)
566
(setf (get-slot-value fr 'FINDREPLACE 'lpstrFindWhat) str)
567
(setf (get-slot-value fr 'FINDREPLACE 'wFindWhatLen) 1024)
568
(setf (get-slot-value fr 'FINDREPLACE 'Flags) *FR_DOWN*)
569
(setq *txtedit-dlg-handle* (findtext fr))))
570
((<= +IDM_WINDOW_FIRST+ ctrl-ID +IDM_WINDOW_LAST+)
571
(set-current-editor (- ctrl-ID +IDM_WINDOW_FIRST+) hwnd)
576
((= uMsg (1+ *WM_USER*))
577
(print "Open file request received")
578
(let ((fname (pop *txtedit-files*)))
581
(read-file fname hwnd)))
583
((= uMsg *txtedit-findreplace-msg*)
584
(with-cast-int-pointer (lparam FINDREPLACE)
585
(let ((flags (get-slot-value lparam 'FINDREPLACE 'Flags))
586
(hnd (txtedit-handle (current-editor))))
587
(cond ((/= 0 (logand flags *FR_DIALOGTERM*))
588
(free-foreign-object lparam)
589
(setq *txtedit-dlg-handle* *NULL*))
590
((/= 0 (logand flags *FR_FINDNEXT*))
591
(let ((str (get-slot-value lparam 'FINDREPLACE 'lpstrFindWhat))
593
(down (/= (logand flags *FR_DOWN*) 0)))
594
(cond ((= *txtedit-edit-class* 2)
595
(let ((selStart (sendmessage hnd 2143 0 0))
596
(selEnd (sendmessage hnd 2145 0 0)))
597
(sendmessage hnd 2025 (if down selEnd selStart) 0)
598
(sendmessage hnd 2366 0 0)
599
(with-foreign-string (s str)
600
(if (/= (setq pos (sendmessage hnd (if down 2367 2368) 0 (make-lparam s))) -1)
601
(sendmessage hnd 2169 0 0)
603
(messagebox *txtedit-dlg-handle* "Finished searching the document"
604
"Find" (logior *MB_OK* *MB_ICONINFORMATION*))
605
(sendmessage hnd 2160 selStart selEnd))))))
610
(defwindowproc hwnd umsg wparam lparam))
613
(defun txtedit-class-name ()
614
(case *txtedit-edit-class*
619
(defun register-txtedit-class ()
620
(unless *txtedit-class-registered*
621
(case *txtedit-edit-class*
622
(-1 (or (and (not (null-pointer-p (loadlibrary "SciLexer.dll")))
623
(setq *txtedit-edit-class* 2))
624
(and (not (null-pointer-p (loadlibrary "riched20.dll")))
625
(setq *txtedit-edit-class* 1))
626
(setq *txtedit-edit-class* 0)))
627
(1 (and (null-pointer-p (loadlibrary "riched20.dll"))
628
(error "Cannot load WIN32 library: riched20.dll")))
629
(2 (and (null-pointer-p (loadlibrary "SciLexer.dll"))
630
(error "Cannot load WIN32 library: SciLexer.dll"))))
631
(make-wndclass "SimpleTextEditor"
632
:lpfnWndProc #'txtedit-proc)
633
(setq *txtedit-class-registered* t)))
635
(defun unregister-txtedit-class ()
636
(when *txtedit-class-registered*
637
(unregisterclass "SimpleTextEditor" *NULL*)
638
(case *txtedit-edit-class*
639
(1 (freelibrary (getmodulehandle "riched20.dll")))
640
(2 (freelibrary (getmodulehandle "SciLexer.dll"))))
641
(setq *txtedit-class-registered* nil)))
643
(defun txtedit (&optional fname &key (class -1) &aux (*txtedit-edit-class* class))
644
(register-txtedit-class)
645
(let* ((fname-str (if fname
646
(convert-to-foreign-string (coerce fname 'simple-string))
648
(w (createwindow "SimpleTextEditor"
649
*txtedit-default-title*
650
(logior *WS_OVERLAPPEDWINDOW*)
651
*CW_USEDEFAULT* *CW_USEDEFAULT*
652
*txtedit-width* *txtedit-height*
653
*NULL* (create-menus) *NULL* fname-str))
654
(accTable (create-accels)))
655
(setq *txtedit-handle* w)
656
(showwindow w *SW_SHOWNORMAL*)
658
(event-loop :accelTable accTable :accelMain w :dlgSym '*txtedit-dlg-handle*)
659
(setq *txtedit-edit* nil)
660
(setq *txtedit-process* nil)
661
(setq *txtedit-handle* *NULL*)
662
(destroyacceleratortable accTable)
663
(unless (null-pointer-p fname-str)
664
(free-foreign-object fname-str))
665
(unregister-txtedit-class)
668
(defun edit (&optional fname &key (class -1) (detach-p (member :threads *features*)))
669
(if (or detach-p *txtedit-process*)
670
(if (member :threads *features*)
671
(if *txtedit-process*
673
(push fname *txtedit-files*)
674
(postmessage *txtedit-handle* (1+ *WM_USER*) 0 0))
675
#+:threads (setq *txtedit-process* (mp:process-run-function "Text Editor" (lambda () (txtedit fname :class class)))))
676
(error "No multi-threading environment detected."))
677
(txtedit fname :class class)))
added
removed
contrib/win32/txtedit.lisp
