+;;;; Conversion between common flavors and Lisp string.
+
+(defconst mac-text-encoding-ascii #x600
+ "ASCII text encoding.")
+
+(defconst mac-text-encoding-mac-japanese-basic-variant #x20001
+ "MacJapanese text encoding without Apple double-byte extensions.")
+
+(defun mac-utxt-to-string (data &optional coding-system)
+ (or coding-system (setq coding-system mac-system-coding-system))
+ (let* ((encoding
+ (and (eq system-type 'darwin)
+ (eq (coding-system-base coding-system) 'japanese-shift-jis)
+ mac-text-encoding-mac-japanese-basic-variant))
+ (str (and (fboundp 'mac-code-convert-string)
+ (mac-code-convert-string data nil
+ (or encoding coding-system)))))
+ (when str
+ (setq str (decode-coding-string str coding-system))
+ (if (eq encoding mac-text-encoding-mac-japanese-basic-variant)
+ ;; Does it contain Apple one-byte extensions other than
+ ;; reverse solidus?
+ (if (string-match "[\xa0\xfd-\xff]" str)
+ (setq str nil)
+ ;; ASCII-only?
+ (unless (mac-code-convert-string data nil mac-text-encoding-ascii)
+ (subst-char-in-string ?\x5c ?\\e(J\\e(B str t)
+ (subst-char-in-string ?\x80 ?\\ str t)))))
+ (or str
+ (decode-coding-string data
+ (if (eq (byteorder) ?B) 'utf-16be 'utf-16le)))))
+
+(defun mac-string-to-utxt (string &optional coding-system)
+ (or coding-system (setq coding-system mac-system-coding-system))
+ (let (data encoding)
+ (when (and (fboundp 'mac-code-convert-string)
+ (memq (coding-system-base coding-system)
+ (find-coding-systems-string string)))
+ (setq coding-system
+ (coding-system-change-eol-conversion coding-system 'mac))
+ (let ((str string))
+ (when (and (eq system-type 'darwin)
+ (eq coding-system 'japanese-shift-jis-mac))
+ (setq encoding mac-text-encoding-mac-japanese-basic-variant)
+ (setq str (subst-char-in-string ?\\ ?\x80 str))
+ (subst-char-in-string ?\\e(J\\e(B ?\x5c str t)
+ ;; ASCII-only?
+ (if (string-match "\\`[\x00-\x7f]*\\'" str)
+ (setq str nil)))
+ (and str
+ (setq data (mac-code-convert-string
+ (encode-coding-string str coding-system)
+ (or encoding coding-system) nil)))))
+ (or data (encode-coding-string string (if (eq (byteorder) ?B)
+ 'utf-16be-mac
+ 'utf-16le-mac)))))
+
+(defun mac-TEXT-to-string (data &optional coding-system)
+ (or coding-system (setq coding-system mac-system-coding-system))
+ (prog1 (setq data (decode-coding-string data coding-system))
+ (when (eq (coding-system-base coding-system) 'japanese-shift-jis)
+ ;; (subst-char-in-string ?\x5c ?\\e(J\\e(B data t)
+ (subst-char-in-string ?\x80 ?\\ data t))))
+
+(defun mac-string-to-TEXT (string &optional coding-system)
+ (or coding-system (setq coding-system mac-system-coding-system))
+ (let ((encodables (find-coding-systems-string string))
+ (rest mac-script-code-coding-systems))
+ (unless (memq (coding-system-base coding-system) encodables)
+ (while (and rest (not (memq (cdar rest) encodables)))
+ (setq rest (cdr rest)))
+ (if rest
+ (setq coding-system (cdar rest)))))
+ (setq coding-system
+ (coding-system-change-eol-conversion coding-system 'mac))
+ (when (eq coding-system 'japanese-shift-jis-mac)
+ ;; (setq string (subst-char-in-string ?\\ ?\x80 string))
+ (setq string (subst-char-in-string ?\\e(J\\e(B ?\x5c string)))
+ (encode-coding-string string coding-system))
+
+(defun mac-furl-to-string (data)
+ ;; Remove a trailing nul character.
+ (let ((len (length data)))
+ (if (and (> len 0) (= (aref data (1- len)) ?\0))
+ (substring data 0 (1- len))
+ data)))
+
+(defun mac-TIFF-to-string (data &optional text)
+ (prog1 (or text (setq text (copy-sequence " ")))
+ (put-text-property 0 (length text) 'display (create-image data 'tiff t)
+ text)))
+\f
+;;;; Selections
+
+;;; We keep track of the last text selected here, so we can check the
+;;; current selection against it, and avoid passing back our own text
+;;; from x-get-selection-value.
+(defvar x-last-selected-text-clipboard nil
+ "The value of the CLIPBOARD selection last time we selected or
+pasted text.")
+(defvar x-last-selected-text-primary nil
+ "The value of the PRIMARY X selection last time we selected or
+pasted text.")
+
+(defcustom x-select-enable-clipboard t
+ "*Non-nil means cutting and pasting uses the clipboard.
+This is in addition to the primary selection."
+ :type 'boolean
+ :group 'killing)
+
+;;; Make TEXT, a string, the primary X selection.
+(defun x-select-text (text &optional push)
+ (x-set-selection 'PRIMARY text)
+ (setq x-last-selected-text-primary text)
+ (if (not x-select-enable-clipboard)
+ (setq x-last-selected-text-clipboard nil)
+ (x-set-selection 'CLIPBOARD text)
+ (setq x-last-selected-text-clipboard text))
+ )
+
+(defun x-get-selection (&optional type data-type)
+ "Return the value of a selection.
+The argument TYPE (default `PRIMARY') says which selection,
+and the argument DATA-TYPE (default `STRING') says
+how to convert the data.
+
+TYPE may be any symbol \(but nil stands for `PRIMARY'). However,
+only a few symbols are commonly used. They conventionally have
+all upper-case names. The most often used ones, in addition to
+`PRIMARY', are `SECONDARY' and `CLIPBOARD'.
+
+DATA-TYPE is usually `STRING', but can also be one of the symbols
+in `selection-converter-alist', which see."
+ (let ((data (x-get-selection-internal (or type 'PRIMARY)
+ (or data-type 'STRING)))
+ (coding (or next-selection-coding-system
+ selection-coding-system)))
+ (when (and (stringp data)
+ (setq data-type (get-text-property 0 'foreign-selection data)))
+ (cond ((eq data-type 'public.utf16-plain-text)
+ (setq data (mac-utxt-to-string data coding)))
+ ((eq data-type 'com.apple.traditional-mac-plain-text)
+ (setq data (mac-TEXT-to-string data coding)))
+ ((eq data-type 'public.file-url)
+ (setq data (mac-furl-to-string data))))
+ (put-text-property 0 (length data) 'foreign-selection data-type data))
+ data))
+
+(defun x-selection-value (type)
+ (let ((data-types '(public.utf16-plain-text
+ com.apple.traditional-mac-plain-text
+ public.file-url))
+ text tiff-image)
+ (while (and (null text) data-types)
+ (setq text (condition-case nil
+ (x-get-selection type (car data-types))
+ (error nil)))
+ (setq data-types (cdr data-types)))
+ (if text
+ (remove-text-properties 0 (length text) '(foreign-selection nil) text))
+ (setq tiff-image (condition-case nil
+ (x-get-selection type 'public.tiff)
+ (error nil)))
+ (when tiff-image
+ (remove-text-properties 0 (length tiff-image)
+ '(foreign-selection nil) tiff-image)
+ (setq text (mac-TIFF-to-string tiff-image text)))
+ text))
+
+;;; Return the value of the current selection.
+;;; Treat empty strings as if they were unset.
+;;; If this function is called twice and finds the same text,
+;;; it returns nil the second time. This is so that a single
+;;; selection won't be added to the kill ring over and over.
+(defun x-get-selection-value ()
+ (let (clip-text primary-text)
+ (if (not x-select-enable-clipboard)
+ (setq x-last-selected-text-clipboard nil)
+ (setq clip-text (x-selection-value 'CLIPBOARD))
+ (if (string= clip-text "") (setq clip-text nil))
+
+ ;; Check the CLIPBOARD selection for 'newness', is it different
+ ;; from what we remebered them to be last time we did a
+ ;; cut/paste operation.
+ (setq clip-text
+ (cond;; check clipboard
+ ((or (not clip-text) (string= clip-text ""))
+ (setq x-last-selected-text-clipboard nil))
+ ((eq clip-text x-last-selected-text-clipboard) nil)
+ ((string= clip-text x-last-selected-text-clipboard)
+ ;; Record the newer string,
+ ;; so subsequent calls can use the `eq' test.
+ (setq x-last-selected-text-clipboard clip-text)
+ nil)
+ (t
+ (setq x-last-selected-text-clipboard clip-text))))
+ )
+
+ (setq primary-text (x-selection-value 'PRIMARY))
+ ;; Check the PRIMARY selection for 'newness', is it different
+ ;; from what we remebered them to be last time we did a
+ ;; cut/paste operation.
+ (setq primary-text
+ (cond;; check primary selection
+ ((or (not primary-text) (string= primary-text ""))
+ (setq x-last-selected-text-primary nil))
+ ((eq primary-text x-last-selected-text-primary) nil)
+ ((string= primary-text x-last-selected-text-primary)
+ ;; Record the newer string,
+ ;; so subsequent calls can use the `eq' test.
+ (setq x-last-selected-text-primary primary-text)
+ nil)
+ (t
+ (setq x-last-selected-text-primary primary-text))))
+
+ ;; As we have done one selection, clear this now.
+ (setq next-selection-coding-system nil)
+
+ ;; At this point we have recorded the current values for the
+ ;; selection from clipboard (if we are supposed to) and primary,
+ ;; So return the first one that has changed (which is the first
+ ;; non-null one).
+ (or clip-text primary-text)
+ ))
+
+(put 'CLIPBOARD 'mac-scrap-name "com.apple.scrap.clipboard")
+(when (eq system-type 'darwin)
+ (put 'FIND 'mac-scrap-name "com.apple.scrap.find")
+ (put 'PRIMARY 'mac-scrap-name
+ (format "org.gnu.Emacs.%d.selection.PRIMARY" (emacs-pid))))
+(put 'com.apple.traditional-mac-plain-text 'mac-ostype "TEXT")
+(put 'public.utf16-plain-text 'mac-ostype "utxt")
+(put 'public.tiff 'mac-ostype "TIFF")
+(put 'public.file-url 'mac-ostype "furl")
+
+(defun mac-select-convert-to-string (selection type value)
+ (let ((str (cdr (xselect-convert-to-string selection nil value)))
+ (coding (or next-selection-coding-system selection-coding-system)))
+ (when str
+ ;; If TYPE is nil, this is a local request, thus return STR as
+ ;; is. Otherwise, encode STR.
+ (if (not type)
+ str
+ (let ((inhibit-read-only t))
+ (remove-text-properties 0 (length str) '(composition nil) str)
+ (cond
+ ((eq type 'public.utf16-plain-text)
+ (setq str (mac-string-to-utxt str coding)))
+ ((eq type 'com.apple.traditional-mac-plain-text)
+ (setq str (mac-string-to-TEXT str coding)))
+ (t
+ (error "Unknown selection type: %S" type))
+ )))
+
+ (setq next-selection-coding-system nil)
+ (cons type str))))
+
+(defun mac-select-convert-to-file-url (selection type value)
+ (let ((filename (xselect-convert-to-filename selection type value))
+ (coding (or file-name-coding-system default-file-name-coding-system)))
+ (if (and filename coding)
+ (setq filename (encode-coding-string filename coding)))
+ (and filename
+ (concat "file://localhost"
+ (mapconcat 'url-hexify-string
+ (split-string filename "/") "/")))))
+
+(setq selection-converter-alist
+ (nconc
+ '((public.utf16-plain-text . mac-select-convert-to-string)
+ (com.apple.traditional-mac-plain-text . mac-select-convert-to-string)
+ ;; This is not enabled by default because the `Import Image'
+ ;; menu makes Emacs crash or hang for unknown reasons.
+ ;; (public.tiff . nil)
+ (public.file-url . mac-select-convert-to-file-url)
+ )
+ selection-converter-alist))
+\f
+;;;; Apple events, HICommand events, and Services menu
+
+;;; Event classes
+(put 'core-event 'mac-apple-event-class "aevt") ; kCoreEventClass
+(put 'internet-event 'mac-apple-event-class "GURL") ; kAEInternetEventClass
+
+;;; Event IDs
+;; kCoreEventClass
+(put 'open-application 'mac-apple-event-id "oapp") ; kAEOpenApplication
+(put 'reopen-application 'mac-apple-event-id "rapp") ; kAEReopenApplication
+(put 'open-documents 'mac-apple-event-id "odoc") ; kAEOpenDocuments
+(put 'print-documents 'mac-apple-event-id "pdoc") ; kAEPrintDocuments
+(put 'open-contents 'mac-apple-event-id "ocon") ; kAEOpenContents
+(put 'quit-application 'mac-apple-event-id "quit") ; kAEQuitApplication
+(put 'application-died 'mac-apple-event-id "obit") ; kAEApplicationDied
+(put 'show-preferences 'mac-apple-event-id "pref") ; kAEShowPreferences
+(put 'autosave-now 'mac-apple-event-id "asav") ; kAEAutosaveNow
+;; kAEInternetEventClass
+(put 'get-url 'mac-apple-event-id "GURL") ; kAEGetURL
+;; Converted HI command events
+(put 'about 'mac-apple-event-id "abou") ; kHICommandAbout
+(put 'show-hide-font-panel 'mac-apple-event-id "shfp") ; kHICommandShowHideFontPanel
+
+(defmacro mac-event-spec (event)
+ `(nth 1 ,event))
+
+(defmacro mac-event-ae (event)
+ `(nth 2 ,event))
+
+(defun mac-ae-parameter (ae &optional keyword type)
+ (or keyword (setq keyword "----")) ;; Direct object.
+ (if (not (and (consp ae) (equal (car ae) "aevt")))
+ (error "Not an Apple event: %S" ae)
+ (let ((type-data (cdr (assoc keyword (cdr ae))))
+ data)
+ (when (and type type-data (not (equal type (car type-data))))
+ (setq data (mac-coerce-ae-data (car type-data) (cdr type-data) type))
+ (setq type-data (if data (cons type data) nil)))
+ type-data)))
+
+(defun mac-ae-list (ae &optional keyword type)
+ (or keyword (setq keyword "----")) ;; Direct object.
+ (let ((desc (mac-ae-parameter ae keyword "list")))
+ (cond ((null desc)
+ nil)
+ ((not (equal (car desc) "list"))
+ (error "Parameter for \"%s\" is not a list" keyword))
+ (t
+ (if (null type)
+ (cdr desc)
+ (mapcar
+ (lambda (type-data)
+ (mac-coerce-ae-data (car type-data) (cdr type-data) type))
+ (cdr desc)))))))
+
+(defun mac-ae-number (ae keyword)
+ (let ((type-data (mac-ae-parameter ae keyword))
+ str)
+ (if (and type-data
+ (setq str (mac-coerce-ae-data (car type-data)
+ (cdr type-data) "TEXT")))
+ (let ((num (string-to-number str)))
+ ;; Mac OS Classic may return "0e+0" as the coerced value for
+ ;; the type "magn" and the data "\000\000\000\000".
+ (if (= num 0.0) 0 num))
+ nil)))
+
+(defun mac-bytes-to-integer (bytes &optional from to)
+ (or from (setq from 0))
+ (or to (setq to (length bytes)))
+ (let* ((len (- to from))
+ (extended-sign-len (- (1+ (ceiling (log most-positive-fixnum 2)))
+ (* 8 len)))
+ (result 0))
+ (dotimes (i len)
+ (setq result (logior (lsh result 8)
+ (aref bytes (+ from (if (eq (byteorder) ?B) i
+ (- len i 1)))))))
+ (if (> extended-sign-len 0)
+ (ash (lsh result extended-sign-len) (- extended-sign-len))
+ result)))
+
+(defun mac-ae-selection-range (ae)
+;; #pragma options align=mac68k
+;; typedef struct SelectionRange {
+;; short unused1; // 0 (not used)
+;; short lineNum; // line to select (<0 to specify range)
+;; long startRange; // start of selection range (if line < 0)
+;; long endRange; // end of selection range (if line < 0)
+;; long unused2; // 0 (not used)
+;; long theDate; // modification date/time
+;; } SelectionRange;
+;; #pragma options align=reset
+ (let ((range-bytes (cdr (mac-ae-parameter ae "kpos" "TEXT"))))
+ (and range-bytes
+ (list (mac-bytes-to-integer range-bytes 2 4)
+ (mac-bytes-to-integer range-bytes 4 8)
+ (mac-bytes-to-integer range-bytes 8 12)
+ (mac-bytes-to-integer range-bytes 16 20)))))
+
+;; On Mac OS X 10.4 and later, the `open-document' event contains an
+;; optional parameter keyAESearchText from the Spotlight search.
+(defun mac-ae-text-for-search (ae)
+ (let ((utf8-text (cdr (mac-ae-parameter ae "stxt" "utf8"))))
+ (and utf8-text
+ (decode-coding-string utf8-text 'utf-8))))
+
+(defun mac-ae-text (ae)
+ (or (cdr (mac-ae-parameter ae nil "TEXT"))
+ (error "No text in Apple event.")))
+
+(defun mac-ae-frame (ae &optional keyword type)
+ (let ((bytes (cdr (mac-ae-parameter ae keyword type))))
+ (if (or (null bytes) (/= (length bytes) 4))
+ (error "No window reference in Apple event.")
+ (let ((window-id (mac-coerce-ae-data "long" bytes "TEXT"))
+ (rest (frame-list))
+ frame)
+ (while (and (null frame) rest)
+ (if (string= (frame-parameter (car rest) 'window-id) window-id)
+ (setq frame (car rest)))
+ (setq rest (cdr rest)))
+ frame))))
+
+(defun mac-ae-script-language (ae keyword)
+;; struct WritingCode {
+;; ScriptCode theScriptCode;
+;; LangCode theLangCode;
+;; };
+ (let ((bytes (cdr (mac-ae-parameter ae keyword "intl"))))
+ (and bytes
+ (cons (mac-bytes-to-integer bytes 0 2)
+ (mac-bytes-to-integer bytes 2 4)))))
+
+(defun mac-bytes-to-text-range (bytes &optional from to)
+;; struct TextRange {
+;; long fStart;
+;; long fEnd;
+;; short fHiliteStyle;
+;; };
+ (or from (setq from 0))
+ (or to (setq to (length bytes)))
+ (and (= (- to from) (+ 4 4 2))
+ (list (mac-bytes-to-integer bytes from (+ from 4))
+ (mac-bytes-to-integer bytes (+ from 4) (+ from 8))
+ (mac-bytes-to-integer bytes (+ from 8) to))))
+
+(defun mac-ae-text-range-array (ae keyword)
+;; struct TextRangeArray {
+;; short fNumOfRanges;
+;; TextRange fRange[1];
+;; };
+ (let* ((bytes (cdr (mac-ae-parameter ae keyword "tray")))
+ (len (length bytes))
+ nranges result)
+ (when (and bytes (>= len 2)
+ (progn
+ (setq nranges (mac-bytes-to-integer bytes 0 2))
+ (= len (+ 2 (* nranges 10)))))
+ (setq result (make-vector nranges nil))
+ (dotimes (i nranges)
+ (aset result i
+ (mac-bytes-to-text-range bytes (+ (* i 10) 2)
+ (+ (* i 10) 12)))))
+ result))
+
+(defconst mac-keyboard-modifier-mask-alist
+ (mapcar
+ (lambda (modifier-bit)
+ (cons (car modifier-bit) (lsh 1 (cdr modifier-bit))))
+ '((command . 8) ; cmdKeyBit
+ (shift . 9) ; shiftKeyBit
+ (option . 11) ; optionKeyBit
+ (control . 12) ; controlKeyBit
+ (function . 17))) ; kEventKeyModifierFnBit
+ "Alist of Mac keyboard modifier symbols vs masks.")
+
+(defun mac-ae-keyboard-modifiers (ae)
+ (let ((modifiers-value (mac-ae-number ae "kmod"))
+ modifiers)
+ (if modifiers-value
+ (dolist (modifier-mask mac-keyboard-modifier-mask-alist)
+ (if (/= (logand modifiers-value (cdr modifier-mask)) 0)
+ (setq modifiers (cons (car modifier-mask) modifiers)))))
+ modifiers))
+
+(defun mac-ae-reopen-application (event)
+ "Show some frame in response to the Apple event EVENT.
+The frame to be shown is chosen from visible or iconified frames
+if possible. If there's no such frame, a new frame is created."
+ (interactive "e")
+ (unless (frame-visible-p (selected-frame))
+ (let ((frame (or (car (visible-frame-list))
+ (car (filtered-frame-list 'frame-visible-p)))))
+ (if frame
+ (select-frame frame)
+ (switch-to-buffer-other-frame "*scratch*"))))
+ (select-frame-set-input-focus (selected-frame)))
+
+(defun mac-ae-open-documents (event)
+ "Open the documents specified by the Apple event EVENT."
+ (interactive "e")
+ (let ((ae (mac-event-ae event)))
+ (dolist (file-name (mac-ae-list ae nil 'undecoded-file-name))
+ (if file-name
+ (dnd-open-local-file
+ (concat "file://"
+ (mapconcat 'url-hexify-string
+ (split-string file-name "/") "/")) nil)))
+ (let ((selection-range (mac-ae-selection-range ae))
+ (search-text (mac-ae-text-for-search ae)))
+ (cond (selection-range
+ (let ((line (car selection-range))
+ (start (cadr selection-range))
+ (end (nth 2 selection-range)))
+ (if (> line 0)
+ (goto-line line)
+ (if (and (> start 0) (> end 0))
+ (progn (set-mark start)
+ (goto-char end))))))
+ ((stringp search-text)
+ (re-search-forward
+ (mapconcat 'regexp-quote (split-string search-text) "\\|")
+ nil t)))))
+ (select-frame-set-input-focus (selected-frame)))
+
+(defun mac-ae-quit-application (event)
+ "Quit the application Emacs with the Apple event EVENT."
+ (interactive "e")
+ (let ((ae (mac-event-ae event)))
+ (unwind-protect
+ (save-buffers-kill-emacs)
+ ;; Reaches here if the user has canceled the quit.
+ (mac-resume-apple-event ae -128)))) ; userCanceledErr
+
+(defun mac-ae-get-url (event)
+ "Open the URL specified by the Apple event EVENT.
+Currently the `mailto' scheme is supported."
+ (interactive "e")
+ (let* ((ae (mac-event-ae event))
+ (parsed-url (url-generic-parse-url (mac-ae-text ae))))
+ (if (string= (url-type parsed-url) "mailto")
+ (progn
+ (url-mailto parsed-url)
+ (select-frame-set-input-focus (selected-frame)))
+ (mac-resume-apple-event ae t))))
+
+(setq mac-apple-event-map (make-sparse-keymap))
+
+;; Received when Emacs is launched without associated documents.
+;; Accept it as an Apple event, but no Emacs event is generated so as
+;; not to erase the splash screen.
+(define-key mac-apple-event-map [core-event open-application] 0)
+
+;; Received when a dock or application icon is clicked and Emacs is
+;; already running.
+(define-key mac-apple-event-map [core-event reopen-application]
+ 'mac-ae-reopen-application)
+
+(define-key mac-apple-event-map [core-event open-documents]
+ 'mac-ae-open-documents)
+(define-key mac-apple-event-map [core-event show-preferences] 'customize)
+(define-key mac-apple-event-map [core-event quit-application]
+ 'mac-ae-quit-application)
+
+(define-key mac-apple-event-map [internet-event get-url] 'mac-ae-get-url)
+
+(define-key mac-apple-event-map [hi-command about] 'about-emacs)
+
+;;; Converted Carbon Events
+(defun mac-handle-toolbar-switch-mode (event)
+ "Toggle visibility of tool-bars in response to EVENT.
+With no keyboard modifiers, it toggles the visibility of the
+frame where the tool-bar toggle button was pressed. With some
+modifiers, it changes the global tool-bar visibility setting."
+ (interactive "e")
+ (let ((ae (mac-event-ae event)))
+ (if (mac-ae-keyboard-modifiers ae)
+ ;; Globally toggle tool-bar-mode if some modifier key is pressed.
+ (tool-bar-mode 'toggle)
+ (let ((frame (mac-ae-frame ae)))
+ (set-frame-parameter frame 'tool-bar-lines
+ (if (= (frame-parameter frame 'tool-bar-lines) 0)
+ 1 0))))))
+
+;; kEventClassWindow/kEventWindowToolbarSwitchMode
+(define-key mac-apple-event-map [window toolbar-switch-mode]
+ 'mac-handle-toolbar-switch-mode)
+
+;;; Font panel
+(when (fboundp 'mac-set-font-panel-visible-p)
+
+(define-minor-mode mac-font-panel-mode
+ "Toggle use of the font panel.
+With numeric ARG, display the font panel if and only if ARG is positive."
+ :init-value nil
+ :global t
+ :group 'mac
+ (mac-set-font-panel-visible-p mac-font-panel-mode))
+
+(defun mac-handle-font-panel-closed (event)
+ "Update internal status in response to font panel closed EVENT."
+ (interactive "e")
+ ;; Synchronize with the minor mode variable.
+ (mac-font-panel-mode 0))
+
+(defun mac-handle-font-selection (event)
+ "Change default face attributes according to font selection EVENT."
+ (interactive "e")
+ (let* ((ae (mac-event-ae event))
+ (fm-font-size (mac-ae-number ae "fmsz"))
+ (atsu-font-id (mac-ae-number ae "auid"))
+ (attribute-values (and atsu-font-id
+ (mac-atsu-font-face-attributes atsu-font-id))))
+ (if fm-font-size
+ (setq attribute-values
+ `(:height ,(* 10 fm-font-size) ,@attribute-values)))
+ (apply 'set-face-attribute 'default (selected-frame) attribute-values)))
+
+;; kEventClassFont/kEventFontPanelClosed
+(define-key mac-apple-event-map [font panel-closed]
+ 'mac-handle-font-panel-closed)
+;; kEventClassFont/kEventFontSelection
+(define-key mac-apple-event-map [font selection] 'mac-handle-font-selection)
+(define-key mac-apple-event-map [hi-command show-hide-font-panel]
+ 'mac-font-panel-mode)
+
+(define-key-after menu-bar-showhide-menu [mac-font-panel-mode]
+ (menu-bar-make-mm-toggle mac-font-panel-mode
+ "Font Panel"
+ "Show the font panel as a floating dialog")
+ 'showhide-speedbar)
+
+) ;; (fboundp 'mac-set-font-panel-visible-p)
+
+;;; Text Services
+(defvar mac-ts-active-input-buf ""
+ "Byte sequence of the current Mac TSM active input area.")
+(defvar mac-ts-update-active-input-area-seqno 0
+ "Number of processed update-active-input-area events.")
+(setq mac-ts-active-input-overlay (make-overlay 0 0))
+
+(defface mac-ts-caret-position
+ '((t :inverse-video t))
+ "Face for caret position in Mac TSM active input area.
+This is used when the active input area is displayed either in
+the echo area or in a buffer where the cursor is not displayed."
+ :group 'mac)
+
+(defface mac-ts-raw-text
+ '((t :underline t))
+ "Face for raw text in Mac TSM active input area."
+ :group 'mac)
+
+(defface mac-ts-selected-raw-text
+ '((t :underline t))
+ "Face for selected raw text in Mac TSM active input area."
+ :group 'mac)
+
+(defface mac-ts-converted-text
+ '((((background dark)) :underline "gray20")
+ (t :underline "gray80"))
+ "Face for converted text in Mac TSM active input area."
+ :group 'mac)
+
+(defface mac-ts-selected-converted-text
+ '((t :underline t))
+ "Face for selected converted text in Mac TSM active input area."
+ :group 'mac)
+
+(defface mac-ts-block-fill-text
+ '((t :underline t))
+ "Face for block fill text in Mac TSM active input area."
+ :group 'mac)
+
+(defface mac-ts-outline-text
+ '((t :underline t))
+ "Face for outline text in Mac TSM active input area."
+ :group 'mac)
+
+(defface mac-ts-selected-text
+ '((t :underline t))
+ "Face for selected text in Mac TSM active input area."
+ :group 'mac)
+
+(defface mac-ts-no-hilite
+ '((t :inherit default))
+ "Face for no hilite in Mac TSM active input area."
+ :group 'mac)
+
+(defconst mac-ts-hilite-style-faces
+ '((2 . mac-ts-raw-text) ; kTSMHiliteRawText
+ (3 . mac-ts-selected-raw-text) ; kTSMHiliteSelectedRawText
+ (4 . mac-ts-converted-text) ; kTSMHiliteConvertedText
+ (5 . mac-ts-selected-converted-text) ; kTSMHiliteSelectedConvertedText
+ (6 . mac-ts-block-fill-text) ; kTSMHiliteBlockFillText
+ (7 . mac-ts-outline-text) ; kTSMHiliteOutlineText
+ (8 . mac-ts-selected-text) ; kTSMHiliteSelectedText
+ (9 . mac-ts-no-hilite)) ; kTSMHiliteNoHilite
+ "Alist of Mac TSM hilite style vs Emacs face.")
+
+(defun mac-ts-update-active-input-buf (text fix-len hilite-rng update-rng)
+ (let ((buf-len (length mac-ts-active-input-buf))
+ confirmed)
+ (if (or (null update-rng)
+ (/= (% (length update-rng) 2) 0))
+ ;; The parameter is missing (or in a bad format). The
+ ;; existing inline input session is completely replaced with
+ ;; the new text.
+ (setq mac-ts-active-input-buf text)
+ ;; Otherwise, the current subtext specified by the (2*j)-th
+ ;; range is replaced with the new subtext specified by the
+ ;; (2*j+1)-th range.
+ (let ((tail buf-len)
+ (i (length update-rng))
+ segments rng)
+ (while (> i 0)
+ (setq i (- i 2))
+ (setq rng (aref update-rng i))
+ (if (and (<= 0 (cadr rng)) (< (cadr rng) tail)
+ (<= tail buf-len))
+ (setq segments
+ (cons (substring mac-ts-active-input-buf (cadr rng) tail)
+ segments)))
+ (setq tail (car rng))
+ (setq rng (aref update-rng (1+ i)))
+ (if (and (<= 0 (car rng)) (< (car rng) (cadr rng))
+ (<= (cadr rng) (length text)))
+ (setq segments
+ (cons (substring text (car rng) (cadr rng))
+ segments))))
+ (if (and (< 0 tail) (<= tail buf-len))
+ (setq segments
+ (cons (substring mac-ts-active-input-buf 0 tail)
+ segments)))
+ (setq mac-ts-active-input-buf (apply 'concat segments))))
+ (setq buf-len (length mac-ts-active-input-buf))
+ ;; Confirm (a part of) inline input session.
+ (cond ((< fix-len 0)
+ ;; Entire inline session is being confirmed.
+ (setq confirmed mac-ts-active-input-buf)
+ (setq mac-ts-active-input-buf ""))
+ ((= fix-len 0)
+ ;; None of the text is being confirmed (yet).
+ (setq confirmed ""))
+ (t
+ (if (> fix-len buf-len)
+ (setq fix-len buf-len))
+ (setq confirmed (substring mac-ts-active-input-buf 0 fix-len))
+ (setq mac-ts-active-input-buf
+ (substring mac-ts-active-input-buf fix-len))))
+ (setq buf-len (length mac-ts-active-input-buf))
+ ;; Update highlighting and the caret position in the new inline
+ ;; input session.
+ (remove-text-properties 0 buf-len '(cursor nil) mac-ts-active-input-buf)
+ (mapc (lambda (rng)
+ (cond ((and (= (nth 2 rng) 1) ; kTSMHiliteCaretPosition
+ (<= 0 (car rng)) (< (car rng) buf-len))
+ (put-text-property (car rng) buf-len
+ 'cursor t mac-ts-active-input-buf))
+ ((and (<= 0 (car rng)) (< (car rng) (cadr rng))
+ (<= (cadr rng) buf-len))
+ (put-text-property (car rng) (cadr rng) 'face
+ (cdr (assq (nth 2 rng)
+ mac-ts-hilite-style-faces))
+ mac-ts-active-input-buf))))
+ hilite-rng)
+ confirmed))
+
+(defun mac-split-string-by-property-change (string)
+ (let ((tail (length string))
+ head result)
+ (unless (= tail 0)
+ (while (setq head (previous-property-change tail string)
+ result (cons (substring string (or head 0) tail) result)
+ tail head)))
+ result))
+
+(defun mac-replace-untranslated-utf-8-chars (string &optional to-string)
+ (or to-string (setq to-string "\e$,3u=\e(B"))
+ (mapconcat
+ (lambda (str)
+ (if (get-text-property 0 'untranslated-utf-8 str) to-string str))
+ (mac-split-string-by-property-change string)
+ ""))
+
+(defun mac-keyboard-translate-char (ch)
+ (if (and (char-valid-p ch)
+ (or (char-table-p keyboard-translate-table)
+ (and (or (stringp keyboard-translate-table)
+ (vectorp keyboard-translate-table))
+ (> (length keyboard-translate-table) ch))))
+ (or (aref keyboard-translate-table ch) ch)
+ ch))
+
+(defun mac-unread-string (string)
+ ;; Unread characters and insert them in a keyboard macro being
+ ;; defined.
+ (apply 'isearch-unread
+ (mapcar 'mac-keyboard-translate-char
+ (mac-replace-untranslated-utf-8-chars string))))
+
+(defun mac-ts-update-active-input-area (event)
+ "Update Mac TSM active input area according to EVENT.
+The confirmed text is converted to Emacs input events and pushed
+into `unread-command-events'. The unconfirmed text is displayed
+either in the current buffer or in the echo area."
+ (interactive "e")
+ (let* ((ae (mac-event-ae event))
+ (type-text (mac-ae-parameter ae "tstx"))
+ (text (or (cdr type-text) ""))
+ (decode-fun (if (equal (car type-text) "TEXT")
+ 'mac-TEXT-to-string 'mac-utxt-to-string))
+ (script-language (mac-ae-script-language ae "tssl"))
+ (coding (or (cdr (assq (car script-language)
+ mac-script-code-coding-systems))
+ 'mac-roman))
+ (fix-len (mac-ae-number ae "tsfx"))
+ ;; Optional parameters
+ (hilite-rng (mac-ae-text-range-array ae "tshi"))
+ (update-rng (mac-ae-text-range-array ae "tsup"))
+ ;;(pin-rng (mac-bytes-to-text-range (cdr (mac-ae-parameter ae "tspn" "txrn"))))
+ ;;(clause-offsets (cdr (mac-ae-parameter ae "tscl" "ofay")))
+ (seqno (mac-ae-number ae "tsSn"))
+ confirmed)
+ (unless (= seqno mac-ts-update-active-input-area-seqno)
+ ;; Reset internal states if sequence number is out of sync.
+ (setq mac-ts-active-input-buf ""))
+ (setq confirmed
+ (mac-ts-update-active-input-buf text fix-len hilite-rng update-rng))
+ (let ((use-echo-area
+ (or isearch-mode
+ (and cursor-in-echo-area (current-message))
+ ;; Overlay strings are not shown in some cases.
+ (get-char-property (point) 'invisible)
+ (and (not (bobp))
+ (or (and (get-char-property (point) 'display)
+ (eq (get-char-property (1- (point)) 'display)
+ (get-char-property (point) 'display)))
+ (and (get-char-property (point) 'composition)
+ (eq (get-char-property (1- (point)) 'composition)
+ (get-char-property (point) 'composition)))))))
+ active-input-string caret-seen)
+ ;; Decode the active input area text with inheriting faces and
+ ;; the caret position.
+ (setq active-input-string
+ (mapconcat
+ (lambda (str)
+ (let ((decoded (funcall decode-fun str coding)))
+ (put-text-property 0 (length decoded) 'face
+ (get-text-property 0 'face str) decoded)
+ (when (and (not caret-seen)
+ (get-text-property 0 'cursor str))
+ (setq caret-seen t)
+ (if (or use-echo-area (null cursor-type))
+ (put-text-property 0 1 'face 'mac-ts-caret-position
+ decoded)
+ (put-text-property 0 1 'cursor t decoded)))
+ decoded))
+ (mac-split-string-by-property-change mac-ts-active-input-buf)
+ ""))
+ (put-text-property 0 (length active-input-string)
+ 'mac-ts-active-input-string t active-input-string)
+ (if use-echo-area
+ (let ((msg (current-message))
+ message-log-max)
+ (if (and msg
+ ;; Don't get confused by previously displayed
+ ;; `active-input-string'.
+ (null (get-text-property 0 'mac-ts-active-input-string
+ msg)))
+ (setq msg (propertize msg 'display
+ (concat msg active-input-string)))
+ (setq msg active-input-string))
+ (message "%s" msg)
+ (overlay-put mac-ts-active-input-overlay 'before-string nil))
+ (move-overlay mac-ts-active-input-overlay
+ (point) (point) (current-buffer))
+ (overlay-put mac-ts-active-input-overlay 'before-string
+ active-input-string))
+ (mac-unread-string (funcall decode-fun confirmed coding)))
+ ;; The event is successfully processed. Sync the sequence number.
+ (setq mac-ts-update-active-input-area-seqno (1+ seqno))))
+
+(defun mac-ts-unicode-for-key-event (event)
+ "Convert Unicode key EVENT to Emacs key events and unread them."
+ (interactive "e")
+ (let* ((ae (mac-event-ae event))
+ (text (cdr (mac-ae-parameter ae "tstx" "utxt")))
+ (script-language (mac-ae-script-language ae "tssl"))
+ (coding (or (cdr (assq (car script-language)
+ mac-script-code-coding-systems))
+ 'mac-roman)))
+ (if text
+ (mac-unread-string (mac-utxt-to-string text coding)))))
+
+;; kEventClassTextInput/kEventTextInputUpdateActiveInputArea
+(define-key mac-apple-event-map [text-input update-active-input-area]
+ 'mac-ts-update-active-input-area)
+;; kEventClassTextInput/kEventTextInputUnicodeForKeyEvent
+(define-key mac-apple-event-map [text-input unicode-for-key-event]
+ 'mac-ts-unicode-for-key-event)
+
+;;; Services
+(defun mac-service-open-file ()
+ "Open the file specified by the selection value for Services."
+ (interactive)
+ (find-file-existing (x-selection-value mac-service-selection)))
+
+(defun mac-service-open-selection ()
+ "Create a new buffer containing the selection value for Services."
+ (interactive)
+ (switch-to-buffer (generate-new-buffer "*untitled*"))
+ (insert (x-selection-value mac-service-selection))
+ (sit-for 0)
+ (save-buffer) ; It pops up the save dialog.
+ )
+
+(defun mac-service-mail-selection ()
+ "Prepare a mail buffer containing the selection value for Services."
+ (interactive)
+ (compose-mail)
+ (rfc822-goto-eoh)
+ (forward-line 1)
+ (insert (x-selection-value mac-service-selection) "\n"))
+
+(defun mac-service-mail-to ()
+ "Prepare a mail buffer to be sent to the selection value for Services."
+ (interactive)
+ (compose-mail (x-selection-value mac-service-selection)))
+
+(defun mac-service-insert-text ()
+ "Insert the selection value for Services."
+ (interactive)
+ (let ((text (x-selection-value mac-service-selection)))
+ (if (not buffer-read-only)
+ (insert text)
+ (kill-new text)
+ (message
+ (substitute-command-keys
+ "The text from the Services menu can be accessed with \\[yank]")))))
+
+;; kEventClassService/kEventServicePaste
+(define-key mac-apple-event-map [service paste] 'mac-service-insert-text)
+;; kEventClassService/kEventServicePerform
+(define-key mac-apple-event-map [service perform open-file]
+ 'mac-service-open-file)
+(define-key mac-apple-event-map [service perform open-selection]
+ 'mac-service-open-selection)
+(define-key mac-apple-event-map [service perform mail-selection]
+ 'mac-service-mail-selection)
+(define-key mac-apple-event-map [service perform mail-to]
+ 'mac-service-mail-to)
+
+(defun mac-dispatch-apple-event (event)
+ "Dispatch EVENT according to the keymap `mac-apple-event-map'."
+ (interactive "e")
+ (let* ((binding (lookup-key mac-apple-event-map (mac-event-spec event)))
+ (ae (mac-event-ae event))
+ (service-message (and (keymapp binding)
+ (cdr (mac-ae-parameter ae "svmg")))))
+ (when service-message
+ (setq service-message
+ (intern (decode-coding-string service-message 'utf-8)))
+ (setq binding (lookup-key binding (vector service-message))))
+ ;; Replace (cadr event) with a dummy position so that event-start
+ ;; returns it.
+ (setcar (cdr event) (list (selected-window) (point) '(0 . 0) 0))
+ (if (null (mac-ae-parameter ae 'emacs-suspension-id))
+ (command-execute binding nil (vector event) t)
+ (condition-case err
+ (progn
+ (command-execute binding nil (vector event) t)
+ (mac-resume-apple-event ae))
+ (error
+ (mac-ae-set-reply-parameter ae "errs"
+ (cons "TEXT" (error-message-string err)))
+ (mac-resume-apple-event ae -10000)))))) ; errAEEventFailed