├── .gitignore ├── Chrome.el ├── Contacts.el ├── Makefile ├── Notes.el ├── README.rst ├── Reminders.el ├── osa.el └── osascripts.el /.gitignore: -------------------------------------------------------------------------------- 1 | *.elc 2 | osascripts-loaddefs.el 3 | -------------------------------------------------------------------------------- /Chrome.el: -------------------------------------------------------------------------------- 1 | ;;; Chrome.el --- Chrome.app -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2013-2018 Leo Liu 4 | 5 | ;; Author: Leo Liu 6 | ;; Keywords: tools, processes 7 | 8 | ;; This program is free software; you can redistribute it and/or modify 9 | ;; it under the terms of the GNU General Public License as published by 10 | ;; the Free Software Foundation, either version 3 of the License, or 11 | ;; (at your option) any later version. 12 | 13 | ;; This program is distributed in the hope that it will be useful, 14 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 15 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 16 | ;; GNU General Public License for more details. 17 | 18 | ;; You should have received a copy of the GNU General Public License 19 | ;; along with this program. If not, see . 20 | 21 | ;;; Commentary: 22 | 23 | ;; Control Chrome from Emacs. 24 | 25 | ;;; Code: 26 | 27 | (eval-when-compile (require 'osa)) 28 | (require 'cl-lib) 29 | 30 | (defcustom Chrome-application-name "Google Chrome Canary" 31 | "Chrome application name." 32 | :type 'string 33 | :group 'osa) 34 | 35 | (defun Chrome-tabs () 36 | (split-string (read (osa " 37 | tell application #{Chrome-application-name} 38 | set allTabs to {} 39 | repeat with w in windows 40 | repeat with x in tabs of w 41 | copy URL of x as text to end of allTabs 42 | end repeat 43 | end repeat 44 | set AppleScript's text item delimiters to {\"----\"} 45 | return allTabs as text 46 | end tell")) 47 | "----")) 48 | 49 | (defun Chrome-read-tab () 50 | (completing-read "Chrome tab: " (Chrome-tabs) nil t)) 51 | 52 | ;;;###autoload 53 | (defun Chrome-reload (&optional tab) 54 | (interactive (and current-prefix-arg (list (Chrome-read-tab)))) 55 | (osa "tell application #{Chrome-application-name} 56 | set nil to missing value 57 | if #{tab} is missing value then 58 | tell active tab of front window to reload 59 | else 60 | repeat with t in (first tab of windows whose URL is #{tab}) 61 | if t is not missing value then 62 | tell t to reload 63 | end if 64 | end repeat 65 | end if 66 | end tell")) 67 | 68 | ;;;###autoload 69 | (defun Chrome-browse-url-helper (url prefix &optional background) 70 | (let ((url (substring-no-properties url)) 71 | (prefix (substring-no-properties prefix)) 72 | (background (if background "true" "false"))) 73 | (osa "tell application #{Chrome-application-name} 74 | try 75 | set x to (first tab of front window whose URL starts with #{prefix}) 76 | on error 77 | tell front window 78 | set x to make tab 79 | end tell 80 | end try 81 | if x is loading then 82 | tell x to stop 83 | end if 84 | set URL of x to #{url} 85 | if #{background} is \"false\" then 86 | tell x to activate 87 | end if 88 | end tell"))) 89 | 90 | (provide 'Chrome) 91 | ;;; Chrome.el ends here 92 | -------------------------------------------------------------------------------- /Contacts.el: -------------------------------------------------------------------------------- 1 | ;;; Contacts.el --- Contacts.app -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2013-2018 Leo Liu 4 | 5 | ;; Author: Leo Liu 6 | ;; Version: 0.5.0 7 | ;; Keywords: tools, applescript 8 | ;; Created: 2013-09-10 9 | 10 | ;; This program is free software; you can redistribute it and/or modify 11 | ;; it under the terms of the GNU General Public License as published by 12 | ;; the Free Software Foundation, either version 3 of the License, or 13 | ;; (at your option) any later version. 14 | 15 | ;; This program is distributed in the hope that it will be useful, 16 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 17 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 18 | ;; GNU General Public License for more details. 19 | 20 | ;; You should have received a copy of the GNU General Public License 21 | ;; along with this program. If not, see . 22 | 23 | ;;; Commentary: 24 | 25 | ;; Allow BBDB to push and pull from Contacts.app. 26 | 27 | ;;; Code: 28 | 29 | (eval-when-compile (require 'osa)) 30 | 31 | (eval-and-compile 32 | (or (fboundp 'user-error) 33 | (defalias 'user-error 'error))) 34 | 35 | (defun Contacts-groups () 36 | "List of contact groups." 37 | (split-string (read (osa "\ 38 | tell application \"Contacts\" 39 | set gs to {} 40 | repeat with g in groups 41 | copy name of g to end of gs 42 | end repeat 43 | set AppleScript's text item delimiters to {\"----\"} 44 | return gs as text 45 | end tell")) 46 | "----")) 47 | 48 | (defcustom Contacts-query-limit 30 49 | "Maximum number of entries returned by `Contacts-query'." 50 | :type 'integer 51 | :group 'osa) 52 | 53 | ;;;###autoload 54 | (defun Contacts-query (string &optional group) 55 | "Get a list of vCards containing STRING. 56 | The list length is limited by `Contacts-query-limit'. 57 | Allow the user to choose a GROUP to query when called with prefix." 58 | (interactive 59 | (prog1 60 | (list (read-string "Query string: ") 61 | (and current-prefix-arg 62 | (completing-read "Which group: " (Contacts-groups) nil t))) 63 | (ignore (message "Pulling contacts from Contacts...") (sit-for 0.1)))) 64 | 65 | (let ((result (split-string (read (osa "\ 66 | tell application \"Contacts\" 67 | set thePeople to {} 68 | set nil to missing value 69 | set G to #{group} 70 | set Q to #{string} 71 | ignoring case 72 | if G is missing value then 73 | set thePeople to people whose vcard contains Q 74 | else 75 | set thePeople to people in group G whose vcard contains Q 76 | end if 77 | end ignoring 78 | 79 | if (count thePeople) > #{Contacts-query-limit} then 80 | set thePeople to items 1 thru #{Contacts-query-limit} of thePeople 81 | end if 82 | 83 | set theVcards to {} 84 | -- using a Ref is more efficient 85 | set theVcardsRef to a reference to theVcards 86 | repeat with p in thePeople 87 | copy the vcard of p to the end of theVcardsRef 88 | end repeat 89 | set AppleScript's text item delimiters to {\"----\"} 90 | return theVcardsRef as text 91 | end tell")) "----" t))) 92 | (when (called-interactively-p 'interactive) 93 | (if (null result) 94 | (message "No contacts matching %S" string) 95 | (help-setup-xref (list #'Contacts-query string group) 96 | (called-interactively-p 'interactive)) 97 | (with-help-window (help-buffer) 98 | (princ (mapconcat 'identity result " \n"))))) 99 | result)) 100 | 101 | (provide 'Contacts) 102 | ;;; Contacts.el ends here 103 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: all clean autoloads 2 | 3 | EMACS=emacs 4 | 5 | ELCFILES = $(addsuffix .elc, $(basename $(wildcard *.el))) 6 | 7 | all: $(ELCFILES) autoloads 8 | 9 | autoloads: 10 | @$(EMACS) -batch -q -no-site-file -L . -l autoload \ 11 | --eval '(setq backup-inhibited t)' \ 12 | --eval '(setq generated-autoload-file "$(PWD)/osascripts-loaddefs.el")' \ 13 | -f batch-update-autoloads . 14 | 15 | %.elc : %.el 16 | @echo Compiling $< 17 | @$(EMACS) -batch -q -no-site-file -L . -f batch-byte-compile $< 18 | 19 | clean: 20 | @rm -f *.elc 21 | -------------------------------------------------------------------------------- /Notes.el: -------------------------------------------------------------------------------- 1 | ;;; Notes.el --- Notes.app -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2013-2018 Leo Liu 4 | 5 | ;; Author: Leo Liu 6 | ;; Version: 0.8.0 7 | ;; Keywords: tools, applescript 8 | ;; Created: 2013-09-10 9 | 10 | ;; This program is free software; you can redistribute it and/or modify 11 | ;; it under the terms of the GNU General Public License as published by 12 | ;; the Free Software Foundation, either version 3 of the License, or 13 | ;; (at your option) any later version. 14 | 15 | ;; This program is distributed in the hope that it will be useful, 16 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 17 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 18 | ;; GNU General Public License for more details. 19 | 20 | ;; You should have received a copy of the GNU General Public License 21 | ;; along with this program. If not, see . 22 | 23 | ;;; Commentary: 24 | 25 | ;; REF: http://www.macosxautomation.com/applescript/notes/index.html 26 | 27 | ;;; Code: 28 | 29 | (eval-when-compile (require 'osa)) 30 | (require 'cl-lib) 31 | (require 'shr) 32 | 33 | (require 'org) 34 | (require 'org-element) 35 | (require 'ox-html) 36 | 37 | (defcustom Notes-default-folder "Notes" 38 | "Default folder to create a new note." 39 | :type 'string 40 | :group 'osa) 41 | 42 | (defconst Notes-ut-handler "\ 43 | -- date string is locale-dependent so converted to unix time 44 | -- to make sure emacs can always parse it 45 | on ut(d) -- convert d to unix time 46 | if d is missing value 47 | return -1 48 | else 49 | -- Cannot use the locale-dependent value \"1 January 1970\" 50 | set unixTimeStarts to current date 51 | set time of unixTimeStarts to 0 52 | set day of unixTimeStarts to 1 53 | set month of unixTimeStarts to 1 54 | set year of unixTimeStarts to 1970 55 | return (d - unixTimeStarts - (time to GMT)) 56 | end if 57 | end ut") 58 | 59 | (defconst Notes-dateFromUT-handler "\ 60 | -- http://lists.apple.com/archives/applescript-users/2011/Mar/msg00044.html 61 | on dateFromUT(UTS) 62 | if UTS is missing value 63 | return missing value 64 | end if 65 | set unixTimeStampStarts to current date -- just any date 66 | set time of unixTimeStampStarts to 0 67 | set day of unixTimeStampStarts to 1 68 | set month of unixTimeStampStarts to 1 69 | set year of unixTimeStampStarts to 1970 70 | return unixTimeStampStarts + (UTS as real) + (time to GMT) 71 | end dateFromUT") 72 | 73 | (defun Notes-accounts () 74 | "Return a list of account names." 75 | (let ((a (split-string (read (osa "\ 76 | tell application \"Notes\" 77 | set XX to {} 78 | set AppleScript's text item delimiters to {\"----\"} 79 | repeat with a in accounts 80 | set {name:x1, id:x2} to properties of a 81 | copy {x1, x2} as text to end of XX 82 | end repeat 83 | set AppleScript's text item delimiters to {\"####\"} 84 | return XX as text 85 | end tell")) 86 | "####" t))) 87 | (mapcar (lambda (x) (split-string x "----")) a))) 88 | 89 | (defun Notes-folders (account) 90 | "Return a list of folder names in ACCOUNT." 91 | (let ((f (split-string (read (osa "\ 92 | tell application \"Notes\" 93 | set FF to {} 94 | set AppleScript's text item delimiters to {\"----\"} 95 | repeat with f in folders of account #{account} 96 | set {name:x1, id:x2} to f 97 | copy {x1,x2} as text to end of FF 98 | end repeat 99 | set AppleScript's text item delimiters to {\"####\"} 100 | return FF as text 101 | end tell")) 102 | "####" t))) 103 | (mapcar (lambda (x) (split-string x "----")) f))) 104 | 105 | (defun Notes-to-plist (note &optional sep) 106 | (let ((sep (or sep "----"))) 107 | (cl-loop for v in (split-string note sep) 108 | for k in '(:name :note-id :body :creation-date :modification-date) 109 | collect k collect (if (string-match "date\\'" (symbol-name k)) 110 | (string-to-number v) 111 | v)))) 112 | 113 | ;; (Notes-notes-1 "iCloud" "Notes") 114 | (defun Notes-notes-1 (account folder) 115 | (let ((notes (split-string (read (osa Notes-ut-handler 116 | "\ 117 | tell application \"Notes\" 118 | set AppleScript's text item delimiters to {\"----\"} 119 | set myNotes to {} 120 | set myNotesRef to a reference to myNotes 121 | repeat with n in notes of folder #{folder} of account #{account} 122 | set {name:x1, id:x2, body:x3, creation date:x4, modification date:x5} \ 123 | to properties of n 124 | copy {x1, x2, x3, my ut(x4), my ut(x5)} as text to end of myNotesRef 125 | end repeat 126 | set AppleScript's text item delimiters to {\"####\"} 127 | return myNotesRef as text 128 | end tell")) 129 | "####" t))) 130 | (mapcar #'Notes-to-plist notes))) 131 | 132 | (defun Notes-notes () ; TODO: handle attachment 133 | (cl-loop for a in (Notes-accounts) 134 | collect (cons a (cl-loop for f in (Notes-folders (car a)) 135 | collect (cons f (Notes-notes-1 (car a) (car f))))))) 136 | 137 | (defun Notes-normalise (n) ; same as `Reminders-normalise'. 138 | (cl-loop for x in n 139 | collect (cond ((not (stringp x)) x) 140 | ((equal x "missing value") nil) 141 | ((equal x "true") t) 142 | ((equal x "false") nil) 143 | (t x)))) 144 | 145 | (defun Notes-update (data) 146 | (cl-destructuring-bind (&key note-id name body container modification-date 147 | &allow-other-keys) 148 | data 149 | (read (osa Notes-ut-handler 150 | Notes-dateFromUT-handler 151 | "\ 152 | tell application \"Notes\" 153 | set nil to missing value 154 | if #{container} is missing value then 155 | set f to first folder whose name is #{Notes-default-folder} 156 | else 157 | set f to first folder whose id is #{container} 158 | end if 159 | 160 | if #{note-id} is missing value then 161 | set n to make new note at f 162 | else 163 | set n to first note whose id is #{note-id} 164 | -- Mind the round-off error by org mode 165 | if #{modification-date} is not missing value and \ 166 | (modification date of n) - my dateFromUT(#{modification-date}) > 59 167 | error \"Current note is modified outside org\" 168 | end if 169 | end if 170 | 171 | set name of n to #{name} 172 | if #{body} is missing value and body of n is not missing value then 173 | delete body of n 174 | else 175 | set body of n to #{body} 176 | end if 177 | 178 | set {name:x1, id:x2, body:x3, creation date:x4, modification date:x5} \ 179 | to properties of n 180 | set AppleScript's text item delimiters to {\"----\"} 181 | return {x1, x2, x3, my ut(x4), my ut(x5)} as text 182 | end tell")))) 183 | 184 | (defun Notes-normalise-org (p) 185 | (cl-loop for (k v) on p by #'cddr 186 | collect k 187 | collect (pcase k 188 | ((guard (and v (string-match-p "-date\\'" (symbol-name k)))) 189 | (float-time (apply #'encode-time (org-parse-time-string v)))) 190 | (_ v)))) 191 | 192 | (defun Notes-from-org-data (data) 193 | (let ((n (make-symbol "note"))) 194 | (org-element-map data '(headline node-property) 195 | (lambda (x) 196 | (pcase (car x) 197 | (`headline 198 | (when (eq (org-element-property :level x) 199 | (org-reduced-level (org-current-level))) 200 | (put n :name (org-element-property :raw-value x)))) 201 | (`node-property 202 | (put n (intern (concat ":" (org-element-property :key x))) 203 | (org-element-property :value x)))))) 204 | (symbol-plist n))) 205 | 206 | (defun Notes-export-org-subtree () 207 | (let ((org-html-text-markup-alist (cons '(underline . "%s") 208 | org-html-text-markup-alist))) 209 | (prog1 (concat (nth 4 (org-heading-components)) 210 | "

" 211 | ;; XXX: why does it recenter the selected window? 212 | (org-export-as 'html t nil t)) 213 | ;; Clear the ugly message from `org-cycle-internal-global'. 214 | (message nil)))) 215 | 216 | (defun Notes-update-from-org () 217 | (interactive) 218 | (when (= 3 (org-reduced-level (org-current-level))) 219 | (or (not (org-entry-get (point) "note-id")) 220 | (fboundp 'libxml-parse-html-region) 221 | (error "Sync from org to Notes unsafe")) 222 | (let* ((ws (window-start)) ; org-export-as seems to change this 223 | (pt (point)) 224 | (folder-id (org-entry-get-with-inheritance "folder-id")) 225 | (elems (Notes-from-org-data 226 | (save-restriction 227 | (widen) 228 | (org-narrow-to-subtree) 229 | (org-element-parse-buffer)))) 230 | (body (Notes-export-org-subtree)) 231 | (data (Notes-update 232 | (Notes-normalise-org 233 | (plist-put (plist-put elems :container folder-id) 234 | :body body))))) 235 | (Notes-kill-org-subtree) 236 | (Notes-insert-note (Notes-to-plist data)) 237 | (set-window-start nil ws) 238 | (set-window-point nil pt)) 239 | (message "Current note updated") 240 | 'synced)) 241 | 242 | (defun Notes-seconds-to-org (s) 243 | (format-time-string (cdr org-time-stamp-formats) (seconds-to-time s))) 244 | 245 | (defun Notes-shr-tag-li (cont) 246 | (unless (bolp) (insert "\n")) 247 | (shr-indent) 248 | (let* ((bullet 249 | (if (numberp shr-list-mode) 250 | (prog1 251 | (format "%d. " shr-list-mode) 252 | (setq shr-list-mode (1+ shr-list-mode))) 253 | "- ")) 254 | (shr-indentation (+ shr-indentation (length bullet)))) 255 | (insert bullet) 256 | (shr-generic cont))) 257 | 258 | (defun Notes-shr-tag-a (cont) 259 | (let ((url (cdr (assq :href cont))) 260 | (start (point)) 261 | shr-start) 262 | (let ((shr-width most-positive-fixnum)) 263 | (shr-generic cont)) 264 | (let ((text (delete-and-extract-region (or shr-start start) (point)))) 265 | (if (equal text url) 266 | (insert url) 267 | (insert (format "[[%s][%s]]" url text)))))) 268 | 269 | (defun Notes-shr-tag-pre (cont) 270 | (let ((shr-folding-mode 'none)) 271 | (shr-ensure-newline) 272 | (insert "#+BEGIN_EXAMPLE") 273 | (shr-indent) 274 | (shr-generic cont) 275 | (shr-ensure-newline) 276 | (insert "#+END_EXAMPLE"))) 277 | 278 | (autoload 'sgml-pretty-print "sgml-mode" nil t) 279 | 280 | (defun Notes-html2org (html) 281 | "Convert HTML string to org markup." 282 | (with-temp-buffer 283 | (insert html) 284 | (if (fboundp 'libxml-parse-html-region) 285 | (let ((dom (libxml-parse-html-region (point-min) (point-max)))) 286 | (erase-buffer) 287 | (cl-letf (((symbol-function 'shr-tag-li) #'Notes-shr-tag-li) 288 | ((symbol-function 'shr-tag-a) #'Notes-shr-tag-a) 289 | ((symbol-function 'shr-tag-pre) #'Notes-shr-tag-pre)) 290 | (shr-insert-document dom))) 291 | (sgml-pretty-print (point-min) (point-max)) 292 | (html2text)) 293 | (let ((delete-trailing-lines t)) 294 | (delete-trailing-whitespace)) 295 | (goto-char (point-min)) 296 | (skip-chars-forward " \t\n") 297 | (goto-char (line-beginning-position 2)) 298 | (skip-chars-forward " \t\n") 299 | (delete-region (point-min) (line-beginning-position)) 300 | (let ((markup (lambda (o s) 301 | (unless (eq (overlay-start o) (overlay-end o)) 302 | (goto-char (overlay-start o)) 303 | (insert s) 304 | (goto-char (overlay-end o)) 305 | (insert s))))) 306 | (dolist (o (overlays-in (point-min) (point-max))) 307 | (pcase (overlay-get o 'face) 308 | (`bold (funcall markup o "*")) 309 | (`underline (funcall markup o "_")) 310 | (`italic (funcall markup o "/"))))) 311 | (buffer-substring-no-properties (point-min) (point-max)))) 312 | 313 | (defun Notes-insert-note (n) 314 | (cl-destructuring-bind (&key name note-id body creation-date modification-date) 315 | (Notes-normalise n) 316 | (insert (make-string (1+ (* 2 (org-level-increment))) ?*) 317 | " " (org-trim name) "\n") 318 | (when body 319 | (indent-rigidly (point) 320 | (progn 321 | (insert (Notes-html2org body)) 322 | (point)) 323 | (+ 2 (* 2 (org-level-increment)))) 324 | (or (bolp) (insert "\n"))) 325 | (save-excursion 326 | (forward-line -1) 327 | (org-set-property "note-id" note-id) 328 | (org-set-property "creation-date" (Notes-seconds-to-org creation-date)) 329 | (org-set-property "modification-date" 330 | (Notes-seconds-to-org modification-date))))) 331 | 332 | (defun Notes-kill-org-subtree () 333 | (org-back-to-heading t) 334 | (kill-region (point) (progn (org-end-of-subtree t t) (point)))) 335 | 336 | ;;; NOTE: with the introduction of nadvice.el in emacs 24.4 it might 337 | ;;; be alright to use advice after all. 338 | (defadvice org-kill-line (around delete-note activate) 339 | (let ((note-id (when (and (bolp) 340 | (org-at-heading-p) 341 | (= 3 (org-reduced-level (org-current-level))) 342 | (org-entry-get (point) "note-id") 343 | (yes-or-no-p "Delete this note? ")) 344 | (org-entry-get (point) "note-id")))) 345 | (if (not note-id) ad-do-it 346 | (osa "tell application \"Notes\" to \ 347 | delete (first note whose id is #{note-id})") 348 | (Notes-kill-org-subtree)))) 349 | 350 | (defvar Notes-org-map 351 | (let ((m (make-sparse-keymap))) 352 | (define-key m [remap save-buffer] 'Notes-update-from-org) 353 | m)) 354 | 355 | ;;;###autoload 356 | (defun Notes (&optional buffer) 357 | "Pull all notes into a org-mode buffer BUFFER." 358 | (interactive (ignore (message "Pulling notes...") (sit-for 0.1))) 359 | (switch-to-buffer (or buffer "*Notes*")) 360 | (erase-buffer) 361 | (insert "#+TITLE: Notes\n\n") 362 | (org-mode) 363 | (add-hook 'org-ctrl-c-ctrl-c-hook #'Notes-update-from-org nil t) 364 | (push (cons t Notes-org-map) minor-mode-overriding-map-alist) 365 | (dolist (a (Notes-notes)) 366 | (insert "* " (caar a) "\n") 367 | (org-set-property "account-id" (cadr (car a))) 368 | (dolist (f (cdr a)) 369 | (insert (make-string (1+ (org-level-increment)) ?*) " " (caar f) "\n") 370 | (org-set-property "folder-id" (cadr (car f))) 371 | (dolist (n (cdr f)) 372 | (Notes-insert-note n)))) 373 | (goto-char (point-min)) 374 | (outline-next-visible-heading 1) 375 | (and (org-goto-first-child) (org-goto-first-child)) 376 | (org-content (1+ (* 2 (org-level-increment)))) 377 | (set-buffer-modified-p nil) 378 | (setq-local revert-buffer-function 379 | (lambda (_ignore-auto noconfirm) 380 | (when (or noconfirm 381 | (yes-or-no-p "Pull from Notes.app? ")) 382 | (Notes buffer))))) 383 | 384 | ;;;###autoload 385 | (defun Notes-new-note (name &optional body) 386 | "Make a new note with NAME and BODY in `Notes-default-folder'. 387 | If region is active it is used for BODY." 388 | (interactive (list (read-string "Title: ") 389 | (if (use-region-p) 390 | (concat "#+BEGIN_EXAMPLE\n" 391 | (buffer-substring-no-properties 392 | (region-beginning) (region-end)) 393 | "\n#+END_EXAMPLE") 394 | (read-string "Body: ")))) 395 | (when (or (not name) (equal name "")) 396 | (error "Title required")) 397 | (let ((body (unless (equal body "") body))) 398 | (Notes-update (Notes-normalise-org 399 | (list :name name 400 | :body (with-temp-buffer 401 | (org-mode) 402 | (insert "* " name "\n") 403 | (when body 404 | (indent-rigidly (point) 405 | (progn (insert body "\n") 406 | (point)) 407 | 2)) 408 | (Notes-export-org-subtree))))))) 409 | 410 | (defun Notes-view-body () 411 | "View the html source of the note body." 412 | (interactive) 413 | (let ((note-id (or (org-entry-get-with-inheritance "note-id") 414 | (error "No existing note at point"))) 415 | (print-escape-newlines nil)) 416 | (with-output-to-temp-buffer "*note-html*" 417 | (princ (read (osa "\ 418 | tell application \"Notes\" to get body of note id #{note-id}")))))) 419 | 420 | (provide 'Notes) 421 | ;;; Notes.el ends here 422 | -------------------------------------------------------------------------------- /README.rst: -------------------------------------------------------------------------------- 1 | ======================= 2 | OSA Scripts for Emacs 3 | ======================= 4 | 5 | A collection of OSA scripts. This repo was moved from `AppleScripts 6 | `_. 7 | 8 | OSA Scripts 9 | ~~~~~~~~~~~ 10 | 11 | A dumping ground for smallish AppleScripts: 12 | 13 | #. ``osx-notify`` 14 | #. ``osx-emacs-selected-p`` 15 | #. ``osx-say`` 16 | #. ``osx-summarize`` 17 | #. ``osx-empty-trash`` 18 | #. ``osx-choose-color`` 19 | #. ``osx-finder-or-terminal`` 20 | 21 | Reminders 22 | ~~~~~~~~~ 23 | 24 | Pull reminders from `Reminders.app` into an ``org-mode`` buffer. The 25 | following commands are provided: 26 | 27 | #. ``M-x Reminders`` to list all reminders containing some string 28 | #. ``M-x Reminders-new-reminder`` to make a new reminder 29 | #. ``C-k`` at the beginning of line on a heading deletes the reminder 30 | 31 | TODO: 32 | 33 | #. make new reminders using ``org-capture`` 34 | 35 | Notes 36 | ~~~~~ 37 | 38 | Pull notes from `Notes.app` into an ``org-mode`` buffer. Commands: 39 | 40 | #. ``M-x Notes`` 41 | #. ``M-x Notes-new-note`` 42 | #. ``C-k`` at the beginning of line on a heading deletes the note 43 | 44 | TODO: 45 | 46 | #. make new notes using ``org-capture`` 47 | 48 | Contacts 49 | ~~~~~~~~ 50 | 51 | Allow `BBDB `_ to push and 52 | pull from `Contacts.app`. 53 | -------------------------------------------------------------------------------- /Reminders.el: -------------------------------------------------------------------------------- 1 | ;;; Reminders.el --- Reminders.app -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2013-2018 Leo Liu 4 | 5 | ;; Author: Leo Liu 6 | ;; Version: 1.0 7 | ;; Keywords: tools, applescript 8 | ;; Created: 2013-09-10 9 | 10 | ;; This program is free software; you can redistribute it and/or modify 11 | ;; it under the terms of the GNU General Public License as published by 12 | ;; the Free Software Foundation, either version 3 of the License, or 13 | ;; (at your option) any later version. 14 | 15 | ;; This program is distributed in the hope that it will be useful, 16 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 17 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 18 | ;; GNU General Public License for more details. 19 | 20 | ;; You should have received a copy of the GNU General Public License 21 | ;; along with this program. If not, see . 22 | 23 | ;;; Commentary: 24 | 25 | ;; Interact with the Reminders.app seamlessly in Emacs. 26 | 27 | ;;; Code: 28 | 29 | (eval-when-compile (require 'osa)) 30 | (require 'cl-lib) 31 | 32 | (require 'org) 33 | (require 'org-element) 34 | 35 | (defun Reminders-accounts () 36 | (let ((a (split-string (read (osa 37 | "set AppleScript's text item delimiters to {\"----\"} 38 | tell application \"Reminders\" 39 | set XX to {} 40 | repeat with A in accounts 41 | set {name:x1, id:x2} to properties of A 42 | if x2 is not missing value 43 | copy {x1, x2} as text to end of XX 44 | end if 45 | end repeat 46 | set AppleScript's text item delimiters to {\"####\"} 47 | return XX as text 48 | end tell")) 49 | "####"))) 50 | (mapcar (lambda (x) (split-string x "----")) a))) 51 | 52 | (defun Reminders-lists (account) 53 | (let ((l (split-string (read (osa "\ 54 | set AppleScript's text item delimiters to {\"----\"} 55 | tell application \"Reminders\" 56 | set XX to {} 57 | repeat with L in lists of account #{account} 58 | set {name:x1, id:x2} to L 59 | copy {x1, x2} as text to end of XX 60 | end repeat 61 | set AppleScript's text item delimiters to {\"####\"} 62 | return XX as text 63 | end tell")) 64 | "####"))) 65 | (mapcar (lambda (x) (split-string x "----")) l))) 66 | 67 | (defconst Reminders-property-keys 68 | '(:name :reminder-id :body :completed :completion-date :creation-date 69 | :due-date :modification-date :remind-me-date :priority)) 70 | 71 | (defconst Reminders-ut-handler "\ 72 | -- date string is locale-dependent so converted to unix time 73 | -- to make sure emacs can always parse it 74 | on ut(d) -- convert d to unix time 75 | if d is missing value 76 | return -1 77 | else 78 | -- Cannot use the locale-dependent value \"1 January 1970\" 79 | set unixTimeStarts to current date 80 | set time of unixTimeStarts to 0 81 | set day of unixTimeStarts to 1 82 | set month of unixTimeStarts to 1 83 | set year of unixTimeStarts to 1970 84 | return (d - unixTimeStarts - (time to GMT)) 85 | end if 86 | end ut") 87 | 88 | (defconst Reminders-dateFromUT-handler "\ 89 | -- http://lists.apple.com/archives/applescript-users/2011/Mar/msg00044.html 90 | on dateFromUT(UTS) 91 | if UTS is missing value 92 | return missing value 93 | end if 94 | set unixTimeStampStarts to current date -- just any date 95 | set time of unixTimeStampStarts to 0 96 | set day of unixTimeStampStarts to 1 97 | set month of unixTimeStampStarts to 1 98 | set year of unixTimeStampStarts to 1970 99 | return unixTimeStampStarts + (UTS as real) + (time to GMT) 100 | end dateFromUT") 101 | 102 | (defconst Reminders-reminderProps-handler "\ 103 | on reminderProps(r) 104 | tell application \"Reminders\" 105 | set {name:x1, id:x2, body:x3, completed:x4, completion date:x5, ¬ 106 | creation date:x6, due date:x7, modification date:x8, remind me date:x9,¬ 107 | priority:x10} to (properties of r) 108 | return ({x1,x2,x3,x4,my ut(x5),my ut(x6),my ut(x7),my ut(x8),my ut(x9), x10} as text) 109 | end tell 110 | end reminderProps") 111 | 112 | (defun Reminders-to-plist (r &optional sep) 113 | (let ((sep (or sep "----"))) 114 | (cl-loop for k in Reminders-property-keys 115 | for v in (split-string r sep) 116 | collect k collect (if (string-match "date\\'" (symbol-name k)) 117 | (string-to-number v) 118 | v)))) 119 | 120 | ;;; (Reminders-reminders-1 "iCloud" "Reminders") 121 | (defun Reminders-reminders-1 (account list &optional qs) 122 | "Return all reminders in LIST of ACCOUNT." 123 | (let ((rs (split-string (read (osa Reminders-ut-handler 124 | Reminders-reminderProps-handler "\ 125 | tell application \"Reminders\" 126 | set myReminders to {} 127 | set myRemindersRef to a reference to myReminders 128 | set AppleScript's text item delimiters to {\"----\"} 129 | set nil to missing value 130 | repeat with r in (every reminder of list #{list} in account #{account}) 131 | set temp to my reminderProps(r) 132 | if (#{qs} is missing value) or #{qs} is in temp then 133 | copy temp to end of myRemindersRef 134 | end if 135 | end repeat 136 | set AppleScript's text item delimiters to {\"####\"} 137 | return myRemindersRef as text 138 | end tell")) 139 | "####" t))) 140 | (mapcar #'Reminders-to-plist rs))) 141 | 142 | (defun Reminders-reminders (&optional qs) 143 | "Return all reminders as a tree." 144 | (cl-loop for a in (Reminders-accounts) 145 | collect (cons a (cl-loop for l in (Reminders-lists (car a)) 146 | collect (cons l (Reminders-reminders-1 147 | (car a) (car l) qs)))))) 148 | 149 | (defun Reminders-normalise (r) 150 | (cl-loop for x in r 151 | collect (cond ((not (stringp x)) x) 152 | ((equal x "missing value") nil) 153 | ((equal x "true") t) 154 | ((equal x "false") nil) 155 | (t x)))) 156 | 157 | ;;; FIXME: too slow 158 | (defun Reminders-update (data) 159 | (cl-destructuring-bind (&key reminder-id name body priority due-date completion-date 160 | remind-me-date container modification-date 161 | &allow-other-keys) 162 | data 163 | (let ((priority (or priority 0))) 164 | (read (osa Reminders-ut-handler 165 | Reminders-dateFromUT-handler 166 | Reminders-reminderProps-handler 167 | "set nil to missing value 168 | tell application \"Reminders\" 169 | if #{container} is not missing value then 170 | set l to first list whose id is #{container} 171 | else 172 | set l to default list 173 | end if 174 | 175 | if (class of l) is not list then 176 | error \"Cannot not find a container\" 177 | end if 178 | 179 | if #{reminder-id} is missing value then 180 | set r to make new reminder in l 181 | else 182 | set r to first reminder whose id is #{reminder-id} 183 | 184 | -- Mind the round-off error by org mode 185 | if #{modification-date} is not missing value and \ 186 | (modification date of r) - my dateFromUT(#{modification-date}) > 59 187 | error \"Reminder is modified outside org\" 188 | end if 189 | end if 190 | 191 | set name of r to #{name} 192 | set priority of r to #{priority} 193 | 194 | if #{body} is missing value or #{body} is \"\" then 195 | delete body of r 196 | else 197 | set body of r to #{body} 198 | end if 199 | 200 | -- XXX: due date and remind me date are the same as of 2013-09-16 201 | if #{due-date} is missing value and #{remind-me-date} is missing value then 202 | -- NB: delete seems slow 203 | if due date of r is not missing value then 204 | delete due date of r 205 | else if remind me date of r is not missing value 206 | delete remind me date of r 207 | end if 208 | else if #{due-date} is not missing value 209 | set due date of r to my dateFromUT(#{due-date}) 210 | else 211 | set remind me date of r to my dateFromUT(#{remind-me-date}) 212 | end if 213 | 214 | if #{completion-date} is missing value then 215 | if completion date of r is not missing value then 216 | delete completion date of r 217 | end if 218 | set completed of r to false 219 | else 220 | set completion date of r to my dateFromUT(#{completion-date}) 221 | set completed of r to true 222 | end if 223 | set AppleScript's text item delimiters to {\"----\"} 224 | return my reminderProps(r) 225 | end tell"))))) 226 | 227 | (defun Reminders-normalise-org (p) 228 | (cl-loop for (k v) on p by #'cddr 229 | collect k 230 | collect (pcase k 231 | (:priority (pcase v 232 | (?A 1) 233 | (?B 5) 234 | (?C 9) 235 | (_ 0))) 236 | ((pred (lambda (x) 237 | (and v (string-match-p "-date\\'" (symbol-name x))))) 238 | (float-time (apply #'encode-time (org-parse-time-string v)))) 239 | (_ v)))) 240 | 241 | (defun Reminders-from-org-data (data) 242 | (let ((r (make-symbol "reminder"))) 243 | (org-element-map data '(headline planning node-property) 244 | (lambda (x) 245 | (pcase (car x) 246 | (`headline 247 | (put r :name (org-element-property :raw-value x)) 248 | (put r :priority (org-element-property :priority x))) 249 | (`planning 250 | (put r :due-date 251 | (org-element-property :raw-value 252 | (org-element-property :deadline x))) 253 | (put r :remind-me-date 254 | (org-element-property :raw-value 255 | (org-element-property :scheduled x))) 256 | (put r :completion-date 257 | (org-element-property :raw-value 258 | (org-element-property :closed x)))) 259 | (`node-property 260 | (put r (intern (concat ":" (org-element-property :key x))) 261 | (org-element-property :value x)))))) 262 | (symbol-plist r))) 263 | 264 | (defun Reminders-insert-reminder (r) 265 | (cl-destructuring-bind (&key name reminder-id body completed completion-date 266 | creation-date due-date modification-date 267 | remind-me-date priority) 268 | (Reminders-normalise r) 269 | (insert (make-string (1+ (* 2 (org-level-increment))) ?*) " " 270 | (if completed "DONE " "") 271 | (pcase (string-to-number priority) 272 | (0 "") 273 | (1 "[#A] ") 274 | (5 "[#B] ") 275 | (9 "[#C] ") 276 | (_ "")) 277 | name "\n") 278 | (when body 279 | (indent-rigidly (point) 280 | (progn (insert body) (point)) 281 | (+ 2 (* 2 (org-level-increment)))) 282 | (or (bolp) (insert "\n"))) 283 | (save-excursion 284 | (forward-line -1) 285 | (org-set-property "reminder-id" reminder-id) 286 | (when (> due-date 0) 287 | (org-add-planning-info 288 | 'deadline (Reminders-seconds-to-org due-date))) 289 | (when (and (> remind-me-date 0) (/= remind-me-date due-date)) 290 | (org-add-planning-info 291 | 'scheduled (Reminders-seconds-to-org remind-me-date))) 292 | (when (> completion-date 0) 293 | ;; NOTE: seconds are lost 294 | (org-add-planning-info 295 | 'closed (Reminders-seconds-to-org completion-date))) 296 | (org-set-property "creation-date" 297 | (Reminders-seconds-to-org creation-date)) 298 | (org-set-property "modification-date" 299 | (Reminders-seconds-to-org modification-date))))) 300 | 301 | (defun Reminders-kill-org-subtree () 302 | (org-back-to-heading t) 303 | (kill-region (point) (progn (org-end-of-subtree t t) (point)))) 304 | 305 | (defun Reminders-seconds-to-org (s) 306 | (format-time-string (cdr org-time-stamp-formats) (seconds-to-time s))) 307 | 308 | (defun Reminders-update-from-org () 309 | (when (= 3 (org-reduced-level (org-current-level))) 310 | (pcase-let* ((ws (window-start)) 311 | (pt (point)) 312 | (list-id (org-entry-get-with-inheritance "list-id")) 313 | (elems (Reminders-from-org-data 314 | (save-restriction 315 | (widen) 316 | (org-narrow-to-subtree) 317 | (org-element-parse-buffer)))) 318 | (body (org-export-as 'ascii t nil t)) 319 | (r (Reminders-update 320 | (Reminders-normalise-org 321 | (plist-put (plist-put elems :body body) :container list-id))))) 322 | (Reminders-kill-org-subtree) 323 | (Reminders-insert-reminder (Reminders-to-plist r)) 324 | (set-window-start nil ws) 325 | (goto-char pt)) 326 | (message "Current reminder updated") 327 | 'synced)) 328 | 329 | (defun Reminders-sort (rs) 330 | "Sort reminders in date reverse order with completed at the end." 331 | (sort rs (lambda (r1 r2) 332 | (let ((r1 (Reminders-normalise r1)) 333 | (r2 (Reminders-normalise r2))) 334 | (cond 335 | ((and (plist-get r1 :completed) 336 | (not (plist-get r2 :completed))) 337 | nil) 338 | ((and (not (plist-get r1 :completed)) 339 | (plist-get r2 :completed)) 340 | t) 341 | (t (> (plist-get r1 :creation-date) 342 | (plist-get r2 :creation-date)))))))) 343 | 344 | ;;; NOTE: with the introduction of nadvice.el in emacs 24.4 it might 345 | ;;; be alright to use advice after all. 346 | (defadvice org-kill-line (around delete-reminder activate) 347 | (let ((reminder-id (when (and (bolp) 348 | (org-at-heading-p) 349 | (= 3 (org-reduced-level (org-current-level))) 350 | (org-entry-get (point) "reminder-id") 351 | (yes-or-no-p "Delete this reminder? ")) 352 | (org-entry-get (point) "reminder-id")))) 353 | (if (not reminder-id) ad-do-it 354 | (osa "tell application \"Reminders\" to delete \ 355 | (first reminder whose id is #{reminder-id})") 356 | (kill-region (point) (progn (org-end-of-subtree t t) (point)))))) 357 | 358 | ;;;###autoload 359 | (defun Reminders-new-reminder (name body &rest props) 360 | (interactive (list (read-string "Name: ") (read-string "Body: "))) 361 | (cl-check-type name string) 362 | (when (equal name "") 363 | (error "Name is empty")) 364 | (prog1 (if (consp props) 365 | (Reminders-update (cl-list* :name name :body body props)) 366 | ;; Optimise for a common case. 367 | (osa "\ 368 | tell application \"Reminders\" 369 | set nil to missing value 370 | if #{body} is missing value then 371 | set props to {name:#{name}} 372 | else 373 | set props to {name:#{name},body:#{body}} 374 | end 375 | make new reminder in default list with properties props 376 | end tell")) 377 | (when (called-interactively-p 'interactive) 378 | (message "done")))) 379 | 380 | ;;;###autoload 381 | (defun Reminders (&optional qs buffer) 382 | "Import all reminders from Reminders.app to an org buffer. 383 | Mapping between reminder and org 384 | remind me date => scheduled 385 | due date => deadline 386 | completion date => closed 387 | 388 | Note: seconds may be rounded off due to limits of org." 389 | (interactive 390 | (prog1 (list (read-string "Query string: ")) 391 | (ignore (message "Pulling reminders...") (sit-for 0.1)))) 392 | (let* ((qs (if (equal qs "") nil qs)) 393 | (buffer (or buffer "*Reminders*")) 394 | ;; Oddly in applescript "" is in "whatever" is false 395 | (reminders (Reminders-reminders qs))) 396 | (with-current-buffer (get-buffer-create buffer) 397 | (erase-buffer) 398 | (insert "#+TITLE: Reminders.app\n#+TODO: TODO | DONE\n#+STARTUP: logdone\n\n") 399 | (org-mode) 400 | (add-hook 'org-ctrl-c-ctrl-c-hook #'Reminders-update-from-org nil t) 401 | (dolist (a reminders) 402 | (insert "* " (car (car a)) "\n") 403 | (org-set-property "account-id" (cadr (car a))) 404 | (dolist (l (cdr a)) 405 | (insert (make-string (1+ (org-level-increment)) ?*) " " (car (car l)) "\n") 406 | (org-set-property "list-id" (cadr (car l))) 407 | (when (and qs (not (consp (cdr l)))) 408 | (kill-buffer (current-buffer)) 409 | (error "No reminders matching `%s' found" qs)) 410 | (dolist (r (Reminders-sort (cdr l))) 411 | (Reminders-insert-reminder r)))) 412 | (goto-char (point-min)) 413 | (org-content (1+ (* 2 (org-level-increment)))) 414 | (set-buffer-modified-p nil) 415 | (setq-local revert-buffer-function 416 | (lambda (_ignore-auto noconfirm) 417 | (when (or noconfirm 418 | (yes-or-no-p "Pull from Reminders.app? ")) 419 | (Reminders qs buffer)))) 420 | (switch-to-buffer (current-buffer))))) 421 | 422 | (provide 'Reminders) 423 | ;;; Reminders.el ends here 424 | -------------------------------------------------------------------------------- /osa.el: -------------------------------------------------------------------------------- 1 | ;;; osa.el --- OSA script wrapper -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2013-2018 Leo Liu 4 | 5 | ;; Author: Leo Liu 6 | ;; Version: 0.6.0 7 | ;; Keywords: OSA, languages, tools 8 | ;; Created: 2013-09-08 9 | 10 | ;; This program is free software; you can redistribute it and/or modify 11 | ;; it under the terms of the GNU General Public License as published by 12 | ;; the Free Software Foundation, either version 3 of the License, or 13 | ;; (at your option) any later version. 14 | 15 | ;; This program is distributed in the hope that it will be useful, 16 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 17 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 18 | ;; GNU General Public License for more details. 19 | 20 | ;; You should have received a copy of the GNU General Public License 21 | ;; along with this program. If not, see . 22 | 23 | ;;; Commentary: 24 | 25 | ;; AppleScript Guide: search 'applescript' in 26 | ;; http://developer.apple.com/library/mac/navigation 27 | ;; 28 | ;; JavaScript for Automation: 29 | ;; https://developer.apple.com/videos/wwdc/2014/?id=403 30 | 31 | ;;; Code: 32 | 33 | (defgroup osa nil 34 | "OSA scripts (AppleScript, JavaScript etc)." 35 | :group 'languages) 36 | 37 | (defcustom osa-debug nil 38 | "Non-nil to log the OSA script string." 39 | :type 'boolean 40 | :group 'osa) 41 | 42 | (defconst osa-lisp-start "#{" 43 | "String marking the start of lisp code.") 44 | 45 | (defconst osa-lisp-end "}" 46 | "String marking the end of lisp code.") 47 | 48 | (defvar osa-lisp-re 49 | (concat (regexp-quote osa-lisp-start) 50 | "\\(\\(?:.\\|\n\\)*?\\)\\(?:#\\(.\\)\\)?" 51 | (regexp-quote osa-lisp-end))) 52 | 53 | (defun osa-parse-line (line) 54 | (let ((start 0) 55 | (lisp-code)) 56 | (when (stringp line) 57 | (while (string-match osa-lisp-re line start) 58 | (push (condition-case err 59 | (read (match-string 1 line)) 60 | (error (error "%s: %s" (error-message-string err) line))) 61 | lisp-code) 62 | (setq start (match-beginning 0)) 63 | ;; XXX: makes a new string every time 64 | (setq line (replace-match (concat "%" (or (match-string 2 line) "S")) 65 | nil nil line)))) 66 | (if (consp lisp-code) 67 | (cons 'format (cons line (nreverse lisp-code))) 68 | line))) 69 | 70 | (defun osa-parse-lines (lines) 71 | (mapcar #'osa-parse-line lines)) 72 | 73 | (defmacro osa-debug (form) 74 | (if osa-debug 75 | (let ((-value- (make-symbol "-value-"))) 76 | `(let ((,-value- ,form)) 77 | (message "DEBUG [%s]: \n%s" 78 | (format-time-string "%Y-%m-%dT%T%z") 79 | ,-value-) 80 | ,-value-)) 81 | form)) 82 | 83 | (defun osa-build-script (lines) 84 | (let ((lines (osa-parse-lines lines))) 85 | (cond 86 | ((cl-every #'stringp lines) (mapconcat 'identity lines "\n")) 87 | ((not (cdr lines)) (car lines)) 88 | (t `(mapconcat 'identity (list ,@lines) "\n"))))) 89 | 90 | ;;;###autoload 91 | (defmacro osa (&rest lines) 92 | "Like `do-applescript' but allow embedding lisp code. 93 | The value of the lisp code is interpolated in the applescript 94 | string using format control string `%S'. It can also be specified 95 | by appending `#C' where C is one of the chars supported by 96 | `format'. Examples: \"#{fill-column}\" and \"#{fill-column#x}\"." 97 | ;; Check doc-string of `do-applescript' to see why 98 | ;; `string-to-multibyte' is needed. 99 | `(do-applescript (osa-debug (string-to-multibyte ,(osa-build-script lines))))) 100 | 101 | ;;;###autoload 102 | (defmacro osajs (&rest lines) 103 | "Like `osa' (which see) but use JavaScript instead." 104 | `(mac-osa-script (osa-debug (string-to-multibyte ,(osa-build-script lines))) 105 | "JavaScript")) 106 | 107 | (provide 'osa) 108 | ;;; osa.el ends here 109 | -------------------------------------------------------------------------------- /osascripts.el: -------------------------------------------------------------------------------- 1 | ;;; osascripts.el --- collection of smallish OSA scripts -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2013-2018 Leo Liu 4 | 5 | ;; Author: Leo Liu 6 | ;; Version: 0.6.0 7 | ;; Keywords: OSA, languages, tools, extensions 8 | ;; Created: 2013-09-10 9 | 10 | ;; This program is free software; you can redistribute it and/or modify 11 | ;; it under the terms of the GNU General Public License as published by 12 | ;; the Free Software Foundation, either version 3 of the License, or 13 | ;; (at your option) any later version. 14 | 15 | ;; This program is distributed in the hope that it will be useful, 16 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 17 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 18 | ;; GNU General Public License for more details. 19 | 20 | ;; You should have received a copy of the GNU General Public License 21 | ;; along with this program. If not, see . 22 | 23 | ;;; Commentary: 24 | 25 | ;; All symbols use prefix osx-. 26 | 27 | ;;; Code: 28 | 29 | (eval-when-compile (require 'osa)) 30 | (require 'cl-lib) 31 | 32 | (eval-and-compile 33 | (or (fboundp 'user-error) 34 | (defalias 'user-error 'error))) 35 | 36 | (defcustom osx-notify-sound nil 37 | "Default sound for `osx-notify'." 38 | :type '(choice (const :tag "System default" nil) file) 39 | :group 'osa) 40 | 41 | (defun osx-emacs-selected-p () 42 | "Return t if Emacs is currently selected." 43 | (equal (osa "current application is frontmost") "true")) 44 | 45 | (defun osx-notify (body &optional title subtitle sound) 46 | "Post a notification using the Notification Center. 47 | SOUND may be the base name of any sound installed in 48 | Library/Sounds." 49 | (let ((title (substring-no-properties (or title "Emacs"))) 50 | (subtitle (substring-no-properties (or subtitle ""))) 51 | (sound (substring-no-properties (or sound osx-notify-sound "")))) 52 | (osa "display notification #{body} with title #{title} \ 53 | subtitle #{subtitle} sound name #{sound}"))) 54 | 55 | (defun osx-say (text &optional nato) 56 | "Speak TEXT." 57 | (interactive 58 | (let ((text 59 | (if (use-region-p) 60 | (buffer-substring-no-properties 61 | (region-beginning) (region-end)) 62 | (read-string (if (current-word t) 63 | (format "Text (default %s): " (current-word t)) 64 | "Text: ") 65 | nil nil (current-word t))))) 66 | (or (< (length text) 300) 67 | (yes-or-no-p "Text longer than 300 chars; go ahead? ") 68 | (user-error "Aborted")) 69 | (setq deactivate-mark t) 70 | (list text current-prefix-arg))) 71 | (let ((text (if nato 72 | (with-temp-buffer 73 | (insert text) 74 | (nato-region (point-min) (point-max)) 75 | (buffer-string)) 76 | text))) 77 | (osa "say #{text} without waiting until completion"))) 78 | 79 | (defun osx-summarize (beg end &optional number) 80 | (interactive 81 | (if (use-region-p) 82 | (list (region-beginning) (region-end)) 83 | (list (point-min) (point-max)))) 84 | (let* ((number (or number 1)) 85 | (text (buffer-substring-no-properties beg end)) 86 | (sum (read (osa "summarize #{text} in #{number}")))) 87 | (when (called-interactively-p 'interactive) 88 | (display-message-or-buffer sum)) 89 | sum)) 90 | 91 | (defun osx-empty-trash (&optional no-confirm) 92 | (interactive "P") 93 | (let* ((items (split-string (read (osa "\ 94 | tell application \"Finder\" 95 | set temp to name of items in trash 96 | copy (length of temp) to beginning of temp 97 | if (count temp) > 30 then 98 | set temp to items 1 thru 31 of temp 99 | end if 100 | set AppleScript's text item delimiters to {\"----\"} 101 | return temp as text 102 | end tell")) 103 | "----")) 104 | (count (string-to-number (pop items)))) 105 | (and (zerop count) (user-error "No trash")) 106 | (when (or no-confirm 107 | (let ((split-height-threshold 0)) 108 | ;; See `dired-mark-pop-up' for example. 109 | (with-temp-buffer-window 110 | " *Trashes*" 111 | (cons 'display-buffer-below-selected 112 | '((window-height . fit-window-to-buffer))) 113 | (lambda (window _v) 114 | (unwind-protect (yes-or-no-p 115 | (format "Empty Trash (%s %s)? " 116 | count 117 | (if (eq count 1) "item" "items"))) 118 | (when (window-live-p window) 119 | (quit-restore-window window 'kill)))) 120 | ;; Split items 5-item lines 121 | (cl-loop for f in items 122 | for c from 1 123 | do (princ (format "%d. %s\t" c f)) 124 | when (zerop (mod c 5)) 125 | do (princ "\n")) 126 | (unless (= (length items) count) 127 | (princ "......"))))) 128 | (osa "ignoring application responses 129 | tell application \"Finder\" to empty the trash 130 | end ignoring")))) 131 | 132 | (let (default-color) 133 | (defun osx-choose-color () 134 | "Allows the user to choose a color from a color picker dialog. 135 | The return value is a list similar to that of `color-values'." 136 | (interactive) 137 | (let* ((default (concat "{" 138 | (mapconcat #'number-to-string 139 | (or default-color '(65535 65535 65535)) 140 | ", ") 141 | "}")) 142 | (color (read (osa 143 | "set myColor to choose color default color #{default#s}" 144 | ;; XXX: restore old text item delimiters 145 | "set AppleScript's text item delimiters to {\":\"}" 146 | "return myColor as text"))) 147 | (result (mapcar 'string-to-number (split-string color ":")))) 148 | (when (called-interactively-p 'interactive) 149 | (apply #'message 150 | "RGB:#%02x%02x%02x Emacs:%s" 151 | (append (mapcar (lambda (x) (floor x 256)) result) 152 | (list result)))) 153 | (setq default-color result) 154 | result))) 155 | 156 | (defun osx-get-default-browser () 157 | "Get the default browser application name." 158 | (with-temp-buffer 159 | (if (and (zerop (process-file "defaults" nil t nil "read" 160 | "com.apple.LaunchServices/com.apple.LaunchServices.secure" 161 | "LSHandlers")) 162 | (progn (goto-char (point-min)) 163 | (re-search-forward "LSHandlerRoleAll = \"\\([^\"\n]+\\)\";\n[ \t]*LSHandlerURLScheme = http;" nil t))) 164 | (read (osa "tell application \"Finder\" to get name of application file id #{(match-string 1)}")) 165 | "Safari.app"))) 166 | 167 | (defun osx-make-browse-url-function () 168 | "A `browse-url' function that supports file:/// with anchors." 169 | (let ((browser (osx-get-default-browser))) 170 | (lambda (url &rest _args) 171 | (do-applescript 172 | (string-to-multibyte 173 | (format "tell application %S to (open location %S) activate" browser 174 | (substring-no-properties (url-encode-url url)))))))) 175 | 176 | (defun osx-finder () 177 | "Open Finder.app and reveal `buffer-file-name' if any." 178 | (interactive) 179 | (let ((dir (expand-file-name 180 | (or (and (fboundp 'dired-file-name-at-point) 181 | (dired-file-name-at-point)) 182 | (and buffer-file-name 183 | (file-exists-p buffer-file-name) 184 | buffer-file-name) 185 | default-directory)))) 186 | (or (not (file-remote-p dir)) 187 | (error "Remote file/directory not supported")) 188 | (osa "set f to POSIX file #{dir}" 189 | "tell application \"Finder\"" 190 | "reveal f" 191 | "activate" 192 | "end tell"))) 193 | 194 | (defun osx-terminal () 195 | "Open Terminal.app and cd `default-directory'." 196 | (interactive) 197 | (let ((dir (expand-file-name default-directory))) 198 | (or (not (file-remote-p dir)) 199 | (error "Remote file/directory not supported")) 200 | (osa 201 | "tell application \"Terminal\" 202 | if not running then 203 | launch 204 | delay 0.5 -- launch can take time 205 | end if 206 | set aDir to the quoted form of #{dir} 207 | try 208 | set aTab to selected tab of the front window 209 | -- if selected tab is not busy, reuse it 210 | if aTab is not busy and processes of aTab doesn't end with \"ssh\" then 211 | do script \"cd \" & aDir in aTab 212 | else 213 | error 214 | end if 215 | on error 216 | do script \"cd \" & aDir 217 | end try 218 | activate 219 | end tell"))) 220 | 221 | (defun osx-finder-or-terminal (&optional arg) 222 | "Open Terminal.app if ARG else Finder.app." 223 | (interactive "P") 224 | (if arg (osx-terminal) (osx-finder))) 225 | 226 | (provide 'osascripts) 227 | ;;; osascripts.el ends here 228 | --------------------------------------------------------------------------------