677 lines
31 KiB
Common Lisp
677 lines
31 KiB
Common Lisp
;;; Copyright (c) 2005, Michael Goffioul (michael dot goffioul at swing dot be)
|
|
;;;
|
|
;;; This program is free software; you can redistribute it and/or
|
|
;;; modify it under the terms of the GNU Library General Public
|
|
;;; License as published by the Free Software Foundation; either
|
|
;;; version 2 of the License, or (at your option) any later version.
|
|
;;;
|
|
;;; See file '../../Copyright' for full details.
|
|
;;;
|
|
;;; SAMPLE TEXT EDITOR APPLICATION USING THE WIN32 API
|
|
;;;
|
|
|
|
(require "WIN32" "win32")
|
|
|
|
(in-package "WIN32")
|
|
|
|
(defvar *txtedit-class-registered* nil)
|
|
(defvar *txtedit-width* 800)
|
|
(defvar *txtedit-height* 600)
|
|
|
|
(defvar *txtedit-edit* nil)
|
|
(defvar *txtedit-tab* *NULL*)
|
|
(defvar *txtedit-tab-proc* *NULL*)
|
|
(defvar *txtedit-current* nil)
|
|
(defvar *txtedit-edit-class* 0)
|
|
(defvar *txtedit-process* nil)
|
|
(defvar *txtedit-handle* *NULL*)
|
|
(defvar *txtedit-files* nil)
|
|
(defvar *txtedit-dlg-handle* *NULL*)
|
|
(defvar *txtedit-findreplace-msg* (registerwindowmessage *FINDMSGSTRING*))
|
|
(defstruct txtedit (handle *NULL*) title dirty)
|
|
|
|
(defvar *txtedit-default-title* "ECL Text Editor")
|
|
|
|
(defparameter +IDM_OPEN+ 100)
|
|
(defparameter +IDM_QUIT+ 101)
|
|
(defparameter +IDM_SAVE+ 102)
|
|
(defparameter +IDM_SAVEAS+ 103)
|
|
(defparameter +IDM_NEW+ 104)
|
|
(defparameter +IDM_CUT+ 105)
|
|
(defparameter +IDM_COPY+ 106)
|
|
(defparameter +IDM_PASTE+ 107)
|
|
(defparameter +IDM_UNDO+ 108)
|
|
(defparameter +IDM_SELECTALL+ 109)
|
|
(defparameter +IDM_ABOUT+ 110)
|
|
(defparameter +IDM_NEXTWINDOW+ 111)
|
|
(defparameter +IDM_PREVWINDOW+ 112)
|
|
(defparameter +IDM_CLOSE+ 113)
|
|
(defparameter +IDM_MATCH_PAREN+ 114)
|
|
(defparameter +IDM_FIND+ 115)
|
|
(defparameter +IDM_WINDOW_FIRST+ 500)
|
|
(defparameter +IDM_WINDOW_LAST+ 600)
|
|
|
|
(defparameter +EDITCTL_ID+ 1000)
|
|
(defparameter +TABCTL_ID+ 1001)
|
|
|
|
(defparameter *txtedit-about-text*
|
|
"Text Editor for ECL.
|
|
|
|
This application serves as a demonstrator
|
|
for the WIN32 FFI interface of ECL.
|
|
|
|
Copyright (c) 2005, Michael Goffioul.")
|
|
|
|
(defun create-menus ()
|
|
;(return *NULL*)
|
|
(let ((bar (createmenu))
|
|
(file_pop (createpopupmenu))
|
|
(edit_pop (createpopupmenu))
|
|
(win_pop (createpopupmenu))
|
|
(help_pop (createpopupmenu)))
|
|
;; File menu
|
|
(appendmenu bar (logior *MF_STRING* *MF_POPUP*) (make-wparam file_pop) "&File")
|
|
(appendmenu file_pop *MF_STRING* +IDM_NEW+ "&New Ctrl+N")
|
|
(appendmenu file_pop *MF_STRING* +IDM_OPEN+ "&Open... Ctrl+O")
|
|
(appendmenu file_pop *MF_STRING* +IDM_CLOSE+ "&Close Ctrl+W")
|
|
(appendmenu file_pop *MF_SEPARATOR* 0 "")
|
|
(appendmenu file_pop *MF_STRING* +IDM_SAVE+ "&Save Ctrl+S")
|
|
(appendmenu file_pop *MF_STRING* +IDM_SAVEAS+ "Save &As...")
|
|
(appendmenu file_pop *MF_SEPARATOR* 0 "")
|
|
(appendmenu file_pop *MF_STRING* +IDM_QUIT+ "&Exit Ctrl+Q")
|
|
;; Edit menu
|
|
(appendmenu bar (logior *MF_STRING* *MF_POPUP*) (make-wparam edit_pop) "&Edit")
|
|
(appendmenu edit_pop *MF_STRING* +IDM_UNDO+ "&Undo Ctrl+Z")
|
|
(appendmenu edit_pop *MF_SEPARATOR* 0 "")
|
|
(appendmenu edit_pop *MF_STRING* +IDM_CUT+ "&Cut Ctrl+X")
|
|
(appendmenu edit_pop *MF_STRING* +IDM_COPY+ "Cop&y Ctrl+C")
|
|
(appendmenu edit_pop *MF_STRING* +IDM_PASTE+ "&Paste Ctrl+V")
|
|
(appendmenu edit_pop *MF_SEPARATOR* 0 "")
|
|
(appendmenu edit_pop *MF_STRING* +IDM_MATCH_PAREN+ "&Match parenthesis Ctrl+D")
|
|
(appendmenu edit_pop *MF_SEPARATOR* 0 "")
|
|
(appendmenu edit_pop *MF_STRING* +IDM_SELECTALL+ "&Select All Ctrl+A")
|
|
;; Windows menu
|
|
(appendmenu bar (logior *MF_STRING* *MF_POPUP*) (make-wparam win_pop) "&Window")
|
|
(appendmenu win_pop *MF_STRING* +IDM_NEXTWINDOW+ "&Next Ctrl+Right")
|
|
(appendmenu win_pop *MF_STRING* +IDM_PREVWINDOW+ "&Previous Ctrl+Left")
|
|
;; Help menu
|
|
(appendmenu bar (logior *MF_STRING* *MF_POPUP*) (make-wparam help_pop) "&Help")
|
|
(appendmenu help_pop *MF_STRING* +IDM_ABOUT+ "&About...")
|
|
bar))
|
|
|
|
(defun create-accels ()
|
|
(macrolet ((add-accel (key ID accTable pos)
|
|
`(with-foreign-object (a 'ACCEL)
|
|
(setf (get-slot-value a 'ACCEL 'fVirt) (logior *FCONTROL* *FVIRTKEY*))
|
|
(setf (get-slot-value a 'ACCEL 'key) ,(if (characterp key) `(char-code ,key) key))
|
|
(setf (get-slot-value a 'ACCEL 'cmd) ,ID)
|
|
(setf (deref-array ,accTable '(* ACCEL) ,pos) a))))
|
|
(let* ((accTableSize (if (= *txtedit-edit-class* 2) 10 9))
|
|
(accTable (allocate-foreign-object 'ACCEL accTableSize)))
|
|
(add-accel #\Q +IDM_QUIT+ accTable 0)
|
|
(add-accel #\N +IDM_NEW+ accTable 1)
|
|
(add-accel #\O +IDM_OPEN+ accTable 2)
|
|
(add-accel #\S +IDM_SAVE+ accTable 3)
|
|
(add-accel #\A +IDM_SELECTALL+ accTable 4)
|
|
(add-accel *VK_LEFT* +IDM_PREVWINDOW+ accTable 5)
|
|
(add-accel *VK_RIGHT* +IDM_NEXTWINDOW+ accTable 6)
|
|
(add-accel #\W +IDM_CLOSE+ accTable 7)
|
|
(add-accel #\F +IDM_FIND+ accTable 8)
|
|
(when (= *txtedit-edit-class* 2)
|
|
(add-accel #\D +IDM_MATCH_PAREN+ accTable 9))
|
|
(prog1
|
|
(createacceleratortable accTable accTableSize)
|
|
(free-foreign-object accTable)))))
|
|
|
|
(defun update-caption (hwnd)
|
|
(let ((str (tab-name (current-editor) #'identity nil)))
|
|
(setwindowtext hwnd (format nil "~@[~A - ~]~A~C" str *txtedit-default-title* #\Null))))
|
|
|
|
(defun current-editor ()
|
|
(nth *txtedit-current* *txtedit-edit*))
|
|
|
|
(defun tab-name (editor &optional (fun #'file-namestring) (final-char #\Null))
|
|
(format nil "~:[New~;~:*~A~]~@[*~*~]~@[~C~]"
|
|
(and (txtedit-title editor) (funcall fun (txtedit-title editor)))
|
|
(txtedit-dirty editor) final-char))
|
|
|
|
(defun update-tab (idx)
|
|
(let ((editor (nth idx *txtedit-edit*)))
|
|
(with-foreign-object (tab 'TCITEM)
|
|
(setf (get-slot-value tab 'TCITEM 'mask) *TCIF_TEXT*)
|
|
(setf (get-slot-value tab 'TCITEM 'pszText) (tab-name editor))
|
|
(sendmessage *txtedit-tab* *TCM_SETITEM* idx (make-lparam tab))
|
|
)))
|
|
|
|
(defun set-current-editor (idx hwnd &optional force-p)
|
|
(when (<= 0 idx (1- (length *txtedit-edit*)))
|
|
(let ((old-ed (and *txtedit-current*
|
|
(current-editor)))
|
|
(new-ed (nth idx *txtedit-edit*)))
|
|
(unless (and (null force-p)
|
|
(eq old-ed new-ed))
|
|
(setq *txtedit-current* idx)
|
|
(setwindowpos (txtedit-handle new-ed) *HWND_TOP* 0 0 0 0 (logior *SWP_NOSIZE* *SWP_NOMOVE*))
|
|
(setfocus (txtedit-handle new-ed))
|
|
(when (/= (sendmessage *txtedit-tab* *TCM_GETCURSEL* 0 0) idx)
|
|
(sendmessage *txtedit-tab* *TCM_SETCURSEL* idx 0))
|
|
(update-caption hwnd)))))
|
|
|
|
(defun close-editor (idx hwnd)
|
|
(let ((editor (nth idx *txtedit-edit*)))
|
|
(if (or (null (txtedit-dirty editor))
|
|
(and (set-current-editor idx hwnd) nil)
|
|
(let ((m-result (messagebox hwnd (format nil "Do you want to save changes?~@[~2%~A~%~]~C"
|
|
(txtedit-title editor) #\Null)
|
|
"Confirmation" (logior *MB_YESNOCANCEL* *MB_ICONQUESTION*))))
|
|
(cond ((= m-result *IDNO*) t)
|
|
((= m-result *IDCANCEL*) nil)
|
|
((= m-result *IDYES*) (warn "Not implemented") nil))))
|
|
(progn
|
|
(destroywindow (txtedit-handle editor))
|
|
(sendmessage *txtedit-tab* *TCM_DELETEITEM* idx 0)
|
|
(setq *txtedit-edit* (remove editor *txtedit-edit*))
|
|
(when *txtedit-edit*
|
|
(set-current-editor (min (1- (length *txtedit-edit*))
|
|
(max *txtedit-current*
|
|
0))
|
|
hwnd t))
|
|
t)
|
|
nil)))
|
|
|
|
(ffi:def-struct SCNotification (NotifyHeader NMHDR) (position :int) (ch :int))
|
|
|
|
(defun init-scintilla-component (hnd)
|
|
;; Set LISP lexer
|
|
(sendmessage hnd 4001 21 0)
|
|
;(sendmessage hnd 2090 7 0)
|
|
;; Define default style attributes
|
|
(with-foreign-string (fn "Courier New")
|
|
(sendmessage hnd 2056 32 (make-lparam fn)))
|
|
(sendmessage hnd 2050 0 0)
|
|
;; Define comment style
|
|
(sendmessage hnd 2051 1 #xDD0000)
|
|
(sendmessage hnd 2054 1 0)
|
|
(sendmessage hnd 2051 12 #xDD0000)
|
|
(sendmessage hnd 2054 12 0)
|
|
;; Define string style
|
|
(sendmessage hnd 2051 6 #x0000C8)
|
|
;; Define number style
|
|
(sendmessage hnd 2051 2 #x0000C8)
|
|
;; Define operator style
|
|
(sendmessage hnd 2051 10 #xC800C8)
|
|
;; Define symbol style
|
|
(sendmessage hnd 2051 5 #xC8C800)
|
|
;; Define brace style
|
|
(sendmessage hnd 2052 34 #xFFCCCC)
|
|
(sendmessage hnd 2051 35 #xFFFFFF)
|
|
(sendmessage hnd 2052 35 #x0000CC)
|
|
;; Define keyword style
|
|
(sendmessage hnd 2051 3 #x00C8C8)
|
|
(sendmessage hnd 2053 3 0)
|
|
(sendmessage hnd 2051 4 #x00C800)
|
|
(sendmessage hnd 2051 11 #x00C800)
|
|
(unless (boundp '*txtedit-lisp-kw*)
|
|
(load "lisp-kw.lisp"))
|
|
(with-foreign-strings ((kwList *txtedit-lisp-kw*)
|
|
(kwList2 *txtedit-lisp-kw2*))
|
|
(sendmessage hnd 4005 0 (make-lparam kwList))
|
|
(sendmessage hnd 4005 1 (make-lparam kwList2)))
|
|
;; Define margins
|
|
(sendmessage hnd 2242 1 0)
|
|
(with-foreign-string (s "_9999")
|
|
(sendmessage hnd 2242 0 (sendmessage hnd 2276 33 (make-lparam s))))
|
|
;; Define selection style
|
|
(sendmessage hnd 2067 1 #xFFFFFF)
|
|
)
|
|
|
|
(defun scintilla-indent-position (pos line hnd)
|
|
(+ (sendmessage hnd 2127 line 0)
|
|
(- pos
|
|
(sendmessage hnd 2128 line 0))))
|
|
|
|
(defun scintilla-read-form (pos hnd)
|
|
(read-from-string
|
|
(with-output-to-string (s)
|
|
(loop for k from pos
|
|
with style = (sendmessage hnd 2010 pos 0)
|
|
for ch = (code-char (sendmessage hnd 2007 k 0))
|
|
for st = (sendmessage hnd 2010 k 0)
|
|
if (and (= st style)
|
|
(graphic-char-p ch)
|
|
(not (eq ch #\Space)))
|
|
do (write-char ch s)
|
|
else
|
|
return nil))
|
|
nil nil))
|
|
|
|
(defun scintilla-declare-form-p (form)
|
|
(member form *txtedit-decl-forms*))
|
|
|
|
(defun scintilla-compute-indentation (curPos curLine hnd)
|
|
(loop for k from curPos downto 0
|
|
for ch = (code-char (sendmessage hnd 2007 k 0))
|
|
for st = (sendmessage hnd 2010 k 0)
|
|
with depth = 0
|
|
with lineIndent = 0
|
|
with lastCharPos = nil
|
|
with prevCharPos = nil
|
|
when (= st 10)
|
|
do (cond ((and (= depth 0) (eq ch #\())
|
|
(if lastCharPos
|
|
(let ((lastChar (code-char (sendmessage hnd 2007 lastCharPos 0)))
|
|
lastForm)
|
|
(cond ((member lastChar (list #\( #\;))
|
|
(return (scintilla-indent-position lastCharPos curLine hnd)))
|
|
((and (setq lastForm (scintilla-read-form lastCharPos hnd))
|
|
(scintilla-declare-form-p lastForm))
|
|
(return (+ (scintilla-indent-position k curLine hnd) 2)))
|
|
((and prevCharPos (not (eq prevCharPos lastCharPos)))
|
|
(return (scintilla-indent-position prevCharPos curLine hnd)))
|
|
(t
|
|
(return (+ (scintilla-indent-position lastCharPos curLine hnd) 1)))))
|
|
(progn
|
|
(return (+ (scintilla-indent-position k curLine hnd) 1)))))
|
|
((eq ch #\() (decf depth))
|
|
((eq ch #\)) (incf depth)))
|
|
if (and (graphic-char-p ch) (not (eq ch #\Space)))
|
|
do (setq lastCharPos k)
|
|
else
|
|
do (setq prevCharPos lastCharPos)
|
|
when (eq ch #\Newline)
|
|
do (decf curLine) and
|
|
do (case lineIndent
|
|
(0 (incf lineIndent))
|
|
(1 (when (= depth 0) (return (sendmessage hnd 2127 (1+ curLine) 0)))))
|
|
finally (return -1)))
|
|
|
|
(defun scintilla-char-added (hnd ch)
|
|
(cond ((eq ch #\Newline)
|
|
(let* ((curPos (sendmessage hnd 2008 0 0))
|
|
(curLine (sendmessage hnd 2166 curPos 0))
|
|
(indent (scintilla-compute-indentation (1- curPos) curLine hnd)))
|
|
(when (>= indent 0)
|
|
(sendmessage hnd 2126 curLine indent)
|
|
(sendmessage hnd 2025 (sendmessage hnd 2128 curLine 0) 0)
|
|
)))
|
|
;((eq ch #\()
|
|
; (let ((curPos (1- (sendmessage hnd 2008 0 0))))
|
|
; (when (scintilla-valid-brace-p curPos hnd)
|
|
; (with-foreign-string (s ")")
|
|
; (sendmessage hnd 2003 (1+ curPos) (make-lparam s))))))
|
|
(t
|
|
)))
|
|
|
|
(defun scintilla-get-matching-braces (hnd &aux curPos)
|
|
(when (>= (setq curPos (1- (sendmessage hnd 2008 0 0))) 0)
|
|
(let ((ch (code-char (sendmessage hnd 2007 curPos 0))))
|
|
(when (and (or (eq ch #\() (eq ch #\)))
|
|
(= (sendmessage hnd 2010 curPos 0) 10))
|
|
(let ((matchPos (sendmessage hnd 2353 curPos 0)))
|
|
(return-from scintilla-get-matching-braces (values curPos matchPos))))))
|
|
(values nil nil))
|
|
|
|
(defun scintilla-check-for-brace (hnd)
|
|
(multiple-value-bind (curPos matchPos) (scintilla-get-matching-braces hnd)
|
|
(if curPos
|
|
(if (>= matchPos 0)
|
|
(sendmessage hnd 2351 curPos matchPos)
|
|
(sendmessage hnd 2352 curPos 0))
|
|
(sendmessage hnd 2351 #xFFFFFFFF -1))))
|
|
|
|
(defun create-editor (parent &optional (set-current t))
|
|
(with-foreign-object (r 'RECT)
|
|
(getclientrect parent r)
|
|
(sendmessage *txtedit-tab* *TCM_ADJUSTRECT* *FALSE* (make-lparam r))
|
|
(let ((new-editor (make-txtedit :handle (createwindowex *WS_EX_CLIENTEDGE* (txtedit-class-name) ""
|
|
(logior *WS_CHILD* *WS_HSCROLL* *WS_VSCROLL* *WS_VISIBLE* *WS_CLIPSIBLINGS*
|
|
*ES_AUTOHSCROLL* *ES_AUTOVSCROLL* *ES_MULTILINE* *ES_LEFT*)
|
|
(get-slot-value r 'RECT 'left)
|
|
(get-slot-value r 'RECT 'top)
|
|
(- (get-slot-value r 'RECT 'right) (get-slot-value r 'RECT 'left))
|
|
(- (get-slot-value r 'RECT 'bottom) (get-slot-value r 'RECT 'top))
|
|
*txtedit-tab* (make-ID +EDITCTL_ID+) *NULL* *NULL*))))
|
|
(sendmessage (txtedit-handle new-editor) *WM_SETFONT* (make-wparam (getstockobject *SYSTEM_FIXED_FONT*)) 0)
|
|
(case *txtedit-edit-class*
|
|
(1 (sendmessage (txtedit-handle new-editor) *EM_SETEVENTMASK* 0 *ENM_CHANGE*))
|
|
(2 (init-scintilla-component (txtedit-handle new-editor))))
|
|
(with-foreign-object (tab 'TCITEM)
|
|
(setf (get-slot-value tab 'TCITEM 'mask) *TCIF_TEXT*)
|
|
(setf (get-slot-value tab 'TCITEM 'pszText) (tab-name new-editor))
|
|
(sendmessage *txtedit-tab* *TCM_INSERTITEM* (length *txtedit-edit*) (make-lparam tab)))
|
|
(setq *txtedit-edit* (append *txtedit-edit* (list new-editor)))
|
|
(when set-current
|
|
(set-current-editor (1- (length *txtedit-edit*)) parent))
|
|
new-editor)))
|
|
|
|
(defun unix2dos (str)
|
|
(let ((new-str (make-array (length str) :element-type 'character :adjustable t :fill-pointer 0))
|
|
(return-p nil)
|
|
c)
|
|
(with-output-to-string (out new-str)
|
|
(do ((it (si::make-seq-iterator str) (si::seq-iterator-next str it)))
|
|
((null it))
|
|
(case (setq c (si::seq-iterator-ref str it))
|
|
(#\Return (setq return-p t))
|
|
(#\Newline (unless return-p (write-char #\Return out)) (setq return-p nil))
|
|
(t (setq return-p nil)))
|
|
(write-char c out)))
|
|
new-str))
|
|
|
|
(defun read-file (pn hwnd)
|
|
(setq pn (probe-file pn))
|
|
(if pn
|
|
(with-open-file (f pn)
|
|
(let* ((len (file-length f))
|
|
(buf (make-string len)))
|
|
(read-sequence buf f)
|
|
(setwindowtext (txtedit-handle (current-editor)) (unix2dos buf))
|
|
(setf (txtedit-dirty (current-editor)) nil)
|
|
(setf (txtedit-title (current-editor)) (substitute #\\ #\/ (namestring pn)))
|
|
(update-caption hwnd)
|
|
(update-tab *txtedit-current*)))
|
|
(messagebox hwnd "File does not exist." "Error" (logior *MB_OK* *MB_ICONERROR*))))
|
|
|
|
(defun save-file (pn hwnd)
|
|
(unless pn
|
|
(setq pn (txtedit-title (current-editor))))
|
|
(with-open-file (f pn :direction :output :if-does-not-exist :create :if-exists :supersede)
|
|
(let ((txt (getwindowtext (txtedit-handle (current-editor)))))
|
|
(write-sequence txt f)
|
|
(setf (txtedit-title (current-editor)) (substitute #\\ #\/(namestring pn)))
|
|
(setf (txtedit-dirty (current-editor)) nil)
|
|
(update-caption hwnd)
|
|
(update-tab *txtedit-current*))))
|
|
|
|
(defun close-or-exit (idx hwnd)
|
|
(if (= (length *txtedit-edit*) 1)
|
|
(postmessage hwnd *WM_CLOSE* 0 0)
|
|
(close-editor idx hwnd)))
|
|
|
|
(defun tab-proc (hwnd umsg wparam lparam)
|
|
(cond ((or (= umsg *WM_COMMAND*)
|
|
(= umsg *WM_NOTIFY*))
|
|
(txtedit-proc (getparent hwnd) umsg wparam lparam))
|
|
(t
|
|
(callwindowproc *txtedit-tab-proc* hwnd umsg wparam lparam))))
|
|
|
|
(defvar *txtedit-level* 0)
|
|
(defun txtedit-proc (hwnd umsg wparam lparam &aux (*txtedit-level* (1+ *txtedit-level*)))
|
|
;(format t "txtedit-proc: ~D~%" *txtedit-level*)
|
|
(cond ((= umsg *WM_DESTROY*)
|
|
(postquitmessage 0)
|
|
0)
|
|
((= umsg *WM_CLOSE*)
|
|
(if (do ((flag t))
|
|
((not (and *txtedit-edit* flag)) flag)
|
|
(setq flag (close-editor 0 hwnd)))
|
|
(destroywindow hwnd)
|
|
0))
|
|
((= umsg *WM_CREATE*)
|
|
(when (null-pointer-p (getmodulehandle "comctl32"))
|
|
(initcommoncontrols))
|
|
(setq *txtedit-tab* (createwindowex 0 *WC_TABCONTROL* ""
|
|
(logior *WS_CHILD* *WS_VISIBLE* *WS_CLIPCHILDREN*) 0 0 0 0
|
|
hwnd (make-ID +TABCTL_ID+) *NULL* *NULL*))
|
|
(setq *txtedit-tab-proc* (register-wndproc *txtedit-tab* #'tab-proc))
|
|
(sendmessage *txtedit-tab* *WM_SETFONT* (make-wparam (getstockobject *DEFAULT_GUI_FONT*)) 0)
|
|
(create-editor hwnd)
|
|
(with-cast-int-pointer (lparam CREATESTRUCT)
|
|
(let ((params (get-slot-value lparam 'CREATESTRUCT 'lpCreateParams)))
|
|
(unless (null-pointer-p params)
|
|
(read-file (convert-from-foreign-string params) hwnd))))
|
|
0)
|
|
((= umsg *WM_SIZE*)
|
|
(unless (null-pointer-p *txtedit-tab*)
|
|
(movewindow *txtedit-tab* 0 0 (loword lparam) (hiword lparam) *TRUE*)
|
|
(with-foreign-object (r 'RECT)
|
|
(setrect r 0 0 (loword lparam) (hiword lparam))
|
|
(sendmessage *txtedit-tab* *TCM_ADJUSTRECT* *FALSE* (make-lparam r))
|
|
(dotimes (k (length *txtedit-edit*))
|
|
(movewindow (txtedit-handle (nth k *txtedit-edit*))
|
|
(get-slot-value r 'RECT 'left) (get-slot-value r 'RECT 'top)
|
|
(- (get-slot-value r 'RECT 'right) (get-slot-value r 'RECT 'left))
|
|
(- (get-slot-value r 'RECT 'bottom) (get-slot-value r 'RECT 'top))
|
|
(if (= k *txtedit-current*) *TRUE* *FALSE*)))))
|
|
0)
|
|
((= umsg *WM_SETFOCUS*)
|
|
(unless (null-pointer-p (txtedit-handle (current-editor)))
|
|
(setfocus (txtedit-handle (current-editor))))
|
|
0)
|
|
((= umsg *WM_NOTIFY*)
|
|
(with-cast-int-pointer (lparam NMHDR)
|
|
(let ((ctrl-ID (get-slot-value lparam 'NMHDR 'idFrom))
|
|
(code (get-slot-value lparam 'NMHDR 'code))
|
|
(hnd (get-slot-value lparam 'NMHDR 'hwndFrom)))
|
|
(cond ((= ctrl-ID +TABCTL_ID+)
|
|
(cond ((= code *TCN_SELCHANGE*)
|
|
(set-current-editor (sendmessage hnd *TCM_GETCURSEL* 0 0) hwnd))
|
|
(t
|
|
)))
|
|
((and (= *txtedit-edit-class* 2)
|
|
(= code 2001))
|
|
(with-cast-pointer (lparam SCNotification)
|
|
(scintilla-char-added hnd (code-char (get-slot-value lparam 'SCNotification 'ch)))))
|
|
((and (= *txtedit-edit-class* 2)
|
|
(= code 2007))
|
|
(scintilla-check-for-brace hnd))
|
|
(t
|
|
))))
|
|
0)
|
|
((= umsg *WM_CONTEXTMENU*)
|
|
(let ((hnd (make-handle wparam))
|
|
(x (get-x-lparam lparam))
|
|
(y (get-y-lparam lparam)))
|
|
(cond ((equal hnd *txtedit-tab*)
|
|
(with-foreign-objects ((ht 'TCHITTESTINFO)
|
|
(pt 'POINT))
|
|
(setf (get-slot-value pt 'POINT 'x) x)
|
|
(setf (get-slot-value pt 'POINT 'y) y)
|
|
(screentoclient *txtedit-tab* pt)
|
|
(setf (get-slot-value ht 'TCHITTESTINFO 'pt) pt)
|
|
(let ((tab (sendmessage *txtedit-tab* *TCM_HITTEST* 0 (make-lparam ht))))
|
|
(when (>= tab 0)
|
|
(let ((hMenu (createpopupmenu))
|
|
menu-ID)
|
|
(appendmenu hMenu *MF_STRING* +IDM_CLOSE+ "&Close")
|
|
(when (/= (setq menu-ID (trackpopupmenuex hMenu (logior *TPM_NONOTIFY* *TPM_RETURNCMD*) x y hwnd *NULL*)) 0)
|
|
(close-or-exit tab hwnd))
|
|
(destroymenu hMenu))))))))
|
|
0)
|
|
((= umsg *WM_INITMENUPOPUP*)
|
|
(case (loword lparam)
|
|
(2 (let* ((wMenu (make-handle wparam))
|
|
(nPos (loword lparam))
|
|
(nItems (getmenuitemcount wMenu)))
|
|
(dotimes (j (- nItems 2))
|
|
(deletemenu wMenu 2 *MF_BYPOSITION*))
|
|
(when *txtedit-edit*
|
|
(appendmenu wMenu *MF_SEPARATOR* 0 "")
|
|
(loop for e in *txtedit-edit*
|
|
for k from 0
|
|
do (progn
|
|
(appendmenu wMenu *MF_STRING* (+ +IDM_WINDOW_FIRST+ k) (tab-name e))
|
|
(when (= k *txtedit-current*)
|
|
(checkmenuitem wMenu (+ k 3) (logior *MF_BYPOSITION* *MF_CHECKED*))))))
|
|
(enablemenuitem wMenu +IDM_PREVWINDOW+ (if (= *txtedit-current* 0) *MF_GRAYED* *MF_ENABLED*))
|
|
(enablemenuitem wMenu +IDM_NEXTWINDOW+ (if (< *txtedit-current* (1- (length *txtedit-edit*))) *MF_ENABLED* *MF_GRAYED*))
|
|
))
|
|
)
|
|
0)
|
|
((= umsg *WM_COMMAND*)
|
|
(let ((ctrl-ID (loword wparam))
|
|
(nmsg (hiword wparam))
|
|
(hnd (make-pointer lparam 'HANDLE)))
|
|
(cond ((= ctrl-ID +EDITCTL_ID+)
|
|
(cond ((= nmsg *EN_CHANGE*)
|
|
(unless (txtedit-dirty (current-editor))
|
|
(setf (txtedit-dirty (current-editor)) t)
|
|
(update-caption hwnd)
|
|
(update-tab *txtedit-current*)))
|
|
(t
|
|
)))
|
|
((= ctrl-ID +IDM_QUIT+)
|
|
(sendmessage hwnd *WM_CLOSE* 0 0))
|
|
((= ctrl-ID +IDM_OPEN+)
|
|
(let ((pn (get-open-filename :owner hwnd :filter '(("LISP source file (*.lisp)" . "*.lisp;*.lsp")
|
|
("All Files (*)" . "*")))))
|
|
(when pn
|
|
(create-editor hwnd)
|
|
(read-file pn hwnd))))
|
|
((and (= ctrl-ID +IDM_SAVE+)
|
|
(txtedit-title (current-editor)))
|
|
(save-file nil hwnd))
|
|
((or (= ctrl-ID +IDM_SAVEAS+)
|
|
(and (= ctrl-ID +IDM_SAVE+)
|
|
(null (txtedit-title (current-editor)))))
|
|
(let ((pn (get-open-filename :owner hwnd :filter '(("LISP source file (*.lisp)" . "*.lisp;*.lsp")
|
|
("All Files (*)" . "*"))
|
|
:dlgfn #'getsavefilename :flags *OFN_OVERWRITEPROMPT*)))
|
|
(when pn
|
|
(save-file pn hwnd))))
|
|
((= ctrl-ID +IDM_NEW+)
|
|
(create-editor hwnd))
|
|
((= ctrl-ID +IDM_CUT+)
|
|
(sendmessage (txtedit-handle (current-editor)) *WM_CUT* 0 0))
|
|
((= ctrl-ID +IDM_COPY+)
|
|
(sendmessage (txtedit-handle (current-editor)) *WM_COPY* 0 0))
|
|
((= ctrl-ID +IDM_PASTE+)
|
|
(sendmessage (txtedit-handle (current-editor)) *WM_PASTE* 0 0))
|
|
((= ctrl-ID +IDM_UNDO+)
|
|
(unless (= (sendmessage (txtedit-handle (current-editor)) *EM_CANUNDO* 0 0) 0)
|
|
(sendmessage (txtedit-handle (current-editor)) *EM_UNDO* 0 0)))
|
|
((= ctrl-ID +IDM_SELECTALL+)
|
|
(sendmessage (txtedit-handle (current-editor)) *EM_SETSEL* 0 -1))
|
|
((= ctrl-ID +IDM_ABOUT+)
|
|
(messagebox hwnd *txtedit-about-text* "About" (logior *MB_OK* *MB_ICONINFORMATION*)))
|
|
((= ctrl-ID +IDM_NEXTWINDOW+)
|
|
(unless (>= (1+ *txtedit-current*) (length *txtedit-edit*))
|
|
(set-current-editor (1+ *txtedit-current*) hwnd)))
|
|
((= ctrl-ID +IDM_PREVWINDOW+)
|
|
(unless (= *txtedit-current* 0)
|
|
(set-current-editor (1- *txtedit-current*) hwnd)))
|
|
((= ctrl-ID +IDM_CLOSE+)
|
|
(close-or-exit *txtedit-current* hwnd))
|
|
((= ctrl-ID +IDM_MATCH_PAREN+)
|
|
(let ((hnd (txtedit-handle (current-editor))))
|
|
(multiple-value-bind (curPos matchPos) (scintilla-get-matching-braces hnd)
|
|
(when (and curPos (>= matchPos 0))
|
|
(sendmessage hnd 2025 (1+ matchPos) 0)))))
|
|
((= ctrl-ID +IDM_FIND+)
|
|
(let* ((fr (allocate-foreign-object 'FINDREPLACE))
|
|
(str (make-string 1024 :initial-element #\Null)))
|
|
(zeromemory fr (size-of-foreign-type 'FINDREPLACE))
|
|
(setf (get-slot-value fr 'FINDREPLACE 'lStructSize) (size-of-foreign-type 'FINDREPLACE))
|
|
(setf (get-slot-value fr 'FINDREPLACE 'hwndOwner) hwnd)
|
|
(setf (get-slot-value fr 'FINDREPLACE 'lpstrFindWhat) str)
|
|
(setf (get-slot-value fr 'FINDREPLACE 'wFindWhatLen) 1024)
|
|
(setf (get-slot-value fr 'FINDREPLACE 'Flags) *FR_DOWN*)
|
|
(setq *txtedit-dlg-handle* (findtext fr))))
|
|
((<= +IDM_WINDOW_FIRST+ ctrl-ID +IDM_WINDOW_LAST+)
|
|
(set-current-editor (- ctrl-ID +IDM_WINDOW_FIRST+) hwnd)
|
|
0)
|
|
(t
|
|
)))
|
|
0)
|
|
((= uMsg (1+ *WM_USER*))
|
|
(print "Open file request received")
|
|
(let ((fname (pop *txtedit-files*)))
|
|
(when fname
|
|
(create-editor hwnd)
|
|
(read-file fname hwnd)))
|
|
0)
|
|
((= uMsg *txtedit-findreplace-msg*)
|
|
(with-cast-int-pointer (lparam FINDREPLACE)
|
|
(let ((flags (get-slot-value lparam 'FINDREPLACE 'Flags))
|
|
(hnd (txtedit-handle (current-editor))))
|
|
(cond ((/= 0 (logand flags *FR_DIALOGTERM*))
|
|
(free-foreign-object lparam)
|
|
(setq *txtedit-dlg-handle* *NULL*))
|
|
((/= 0 (logand flags *FR_FINDNEXT*))
|
|
(let ((str (get-slot-value lparam 'FINDREPLACE 'lpstrFindWhat))
|
|
pos
|
|
(down (/= (logand flags *FR_DOWN*) 0)))
|
|
(cond ((= *txtedit-edit-class* 2)
|
|
(let ((selStart (sendmessage hnd 2143 0 0))
|
|
(selEnd (sendmessage hnd 2145 0 0)))
|
|
(sendmessage hnd 2025 (if down selEnd selStart) 0)
|
|
(sendmessage hnd 2366 0 0)
|
|
(with-foreign-string (s str)
|
|
(if (/= (setq pos (sendmessage hnd (if down 2367 2368) 0 (make-lparam s))) -1)
|
|
(sendmessage hnd 2169 0 0)
|
|
(progn
|
|
(messagebox *txtedit-dlg-handle* "Finished searching the document"
|
|
"Find" (logior *MB_OK* *MB_ICONINFORMATION*))
|
|
(sendmessage hnd 2160 selStart selEnd))))))
|
|
)))
|
|
)))
|
|
0)
|
|
(t
|
|
(defwindowproc hwnd umsg wparam lparam))
|
|
))
|
|
|
|
(defun txtedit-class-name ()
|
|
(case *txtedit-edit-class*
|
|
(0 "EDIT")
|
|
(1 *RICHEDIT_CLASS*)
|
|
(2 "Scintilla")))
|
|
|
|
(defun register-txtedit-class ()
|
|
(unless *txtedit-class-registered*
|
|
(case *txtedit-edit-class*
|
|
(-1 (or (and (not (null-pointer-p (loadlibrary "SciLexer.dll")))
|
|
(setq *txtedit-edit-class* 2))
|
|
(and (not (null-pointer-p (loadlibrary "riched20.dll")))
|
|
(setq *txtedit-edit-class* 1))
|
|
(setq *txtedit-edit-class* 0)))
|
|
(1 (and (null-pointer-p (loadlibrary "riched20.dll"))
|
|
(error "Cannot load WIN32 library: riched20.dll")))
|
|
(2 (and (null-pointer-p (loadlibrary "SciLexer.dll"))
|
|
(error "Cannot load WIN32 library: SciLexer.dll"))))
|
|
(make-wndclass "SimpleTextEditor"
|
|
:lpfnWndProc #'txtedit-proc)
|
|
(setq *txtedit-class-registered* t)))
|
|
|
|
(defun unregister-txtedit-class ()
|
|
(when *txtedit-class-registered*
|
|
(unregisterclass "SimpleTextEditor" *NULL*)
|
|
(case *txtedit-edit-class*
|
|
(1 (freelibrary (getmodulehandle "riched20.dll")))
|
|
(2 (freelibrary (getmodulehandle "SciLexer.dll"))))
|
|
(setq *txtedit-class-registered* nil)))
|
|
|
|
(defun txtedit (&optional fname &key (class -1) &aux (*txtedit-edit-class* class))
|
|
(register-txtedit-class)
|
|
(let* ((fname-str (if fname
|
|
(convert-to-foreign-string (coerce fname 'simple-string))
|
|
*NULL*))
|
|
(w (createwindow "SimpleTextEditor"
|
|
*txtedit-default-title*
|
|
(logior *WS_OVERLAPPEDWINDOW*)
|
|
*CW_USEDEFAULT* *CW_USEDEFAULT*
|
|
*txtedit-width* *txtedit-height*
|
|
*NULL* (create-menus) *NULL* fname-str))
|
|
(accTable (create-accels)))
|
|
(setq *txtedit-handle* w)
|
|
(showwindow w *SW_SHOWNORMAL*)
|
|
(updatewindow w)
|
|
(event-loop :accelTable accTable :accelMain w :dlgSym '*txtedit-dlg-handle*)
|
|
(setq *txtedit-edit* nil)
|
|
(setq *txtedit-process* nil)
|
|
(setq *txtedit-handle* *NULL*)
|
|
(destroyacceleratortable accTable)
|
|
(unless (null-pointer-p fname-str)
|
|
(free-foreign-object fname-str))
|
|
(unregister-txtedit-class)
|
|
nil))
|
|
|
|
(defun edit (&optional fname &key (class -1) (detach-p (member :threads *features*)))
|
|
(if (or detach-p *txtedit-process*)
|
|
(if (member :threads *features*)
|
|
(if *txtedit-process*
|
|
(progn
|
|
(push fname *txtedit-files*)
|
|
(postmessage *txtedit-handle* (1+ *WM_USER*) 0 0))
|
|
#+:threads (setq *txtedit-process* (mp:process-run-function "Text Editor" (lambda () (txtedit fname :class class)))))
|
|
(error "No multi-threading environment detected."))
|
|
(txtedit fname :class class)))
|