Initial add - works on CCL and SBCL
Sun Dec 9 17:18:34 PST 2007 Daniel Dickison <danieldickison@gmail.com>
* Initial add - works on CCL and SBCL
diff -rN -u old-cl-applescript/cl-applescript.asd new-cl-applescript/cl-applescript.asd
--- old-cl-applescript/cl-applescript.asd 1969-12-31 16:00:00.000000000 -0800
+++ new-cl-applescript/cl-applescript.asd 2014-04-19 23:28:22.000000000 -0700
@@ -0,0 +1,14 @@
+(defpackage #:cl-applescript-system
+ (:use :cl :asdf))
+
+(in-package #:cl-applescript-system)
+
+
+(defsystem cl-applescript
+ :author "Daniel Dickison <danieldickison@gmail.com>"
+ :version "1.0"
+ :depends-on ("flexi-streams")
+ :serial t
+ :components ((:file "package")
+ (:file "unportable")
+ (:file "portable")))
diff -rN -u old-cl-applescript/package.lisp new-cl-applescript/package.lisp
--- old-cl-applescript/package.lisp 1969-12-31 16:00:00.000000000 -0800
+++ new-cl-applescript/package.lisp 2014-04-19 23:28:22.000000000 -0700
@@ -0,0 +1,7 @@
+(defpackage #:cl-applescript
+ (:use :cl :flexi-streams)
+ (:export #:run-applescript
+ #:parse-applescript-output
+ #:native-namestring
+ #:*applescript-symbol-package*)
+ (:documentation "Provides a portable interface to running AppleScript scripts on Mac OS X 10.5 and later systems."))
diff -rN -u old-cl-applescript/portable.lisp new-cl-applescript/portable.lisp
--- old-cl-applescript/portable.lisp 1969-12-31 16:00:00.000000000 -0800
+++ new-cl-applescript/portable.lisp 2014-04-19 23:28:22.000000000 -0700
@@ -0,0 +1,166 @@
+(in-package #:cl-applescript)
+
+
+(defvar *utf-8*
+ (make-external-format :utf-8 :eol-style :lf))
+
+
+(defparameter *applescript-symbol-package* (find-package :keyword)
+ "The package where AppleScript symbols are interned when calling `parse-applescript-output`.")
+
+
+(defun run-applescript (script)
+ "Executes the AppleScript `script` and returns the output string of the script."
+ (utf-8-program-output "osascript" (list "-s" "s") script))
+
+
+(defun utf-8-program-output (program args input-string)
+ "Runs an external program, passing input-string to its standard input as a stream of UTF-8 encoded bytes, and parses the standard output data as UTF-8 and returns the decoded string. `program` and `args` should be ASCII, but `input-string` can contain any character you like."
+ (let* ((process (run-program program args
+ :wait nil
+ :output :stream
+ :input :stream
+ :sharing nil
+ :element-type 'octet))
+ (input (process-input-stream process))
+ (input-octets (string-to-octets input-string
+ :external-format *utf-8*))
+ ;; Send the input on a new thread to prevent deadlock...
+ (input-thread (spawn-thread
+ (lambda ()
+ (write-sequence input-octets input)
+ (finish-output input)
+ (close input))))
+ (output (process-output-stream process))
+ (output-buffer (make-array 1024 :element-type 'octet))
+ (output-octets
+ (with-output-to-sequence (output-seq)
+ (loop ;; Read output in a loop until EOF...
+ for bytes = (read-sequence output-buffer output)
+ do (write-sequence output-buffer output-seq
+ :start 0 :end bytes)
+ until (< bytes (length output-buffer))))))
+ (kill-thread input-thread) ;Just in case.
+ (octets-to-string output-octets
+ :external-format *utf-8*)))
+
+
+(defun parse-applescript-output (str &optional (start 0))
+ "Parses output from AppleScript by recursively reading lists, strings, numbers, symbols, class names and hex-encoded binary data. The following grammar describes the AppleScript output format (note that '<<' and '>>' are actually left and right chevron characters):
+
+ as-object := as-list | as-string | as-number | as-symbol | as-binary | as-class
+ as-list := '{' [as-object] [, as-object]* '}'
+ as-class := '<<class ' as-symbol '>>'
+ as-binary := '<<data ' [hex]* '>>'
+ as-string := '\"'string'\"'
+ as-number := 0-9[.0-9]
+ as-symbol := characters
+
+The tricky part is that AppleScript symbols can include spaces, so a symbol is only terminated if a comma, }, >> or EOF are encountered. Symbols are interned in the package designated by `*applescript-symbol-package* which defaults to the keyword package, with spaces replaced by hyphens. Class names are simply interned in the same way as regular symbols. Other <<foo ...>> structures are possible, but only <<data ...>> and <<class ...>> are currently supported. Also, named lists (i.e. dictionaries) of the form {key:value, ...} are not supported."
+ (when (< start (length str))
+ (case (char str start)
+ (#\{
+ (parse-applescript-list str start))
+ (#\left-pointing_double_angle_quotation_mark
+ (parse-applescript-chevron str start))
+ ((#\space #\newline #\return #\tab)
+ (parse-applescript-output str (1+ start)))
+ (#\"
+ (read-from-string str t nil :start start :preserve-whitespace t))
+ ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
+ (read-from-string str t nil :start start :preserve-whitespace t))
+ (t
+ (parse-applescript-symbol str start)))))
+
+(defvar *applescript-token-terminators*
+ '(#\, #\} #\right-pointing_double_angle_quotation_mark))
+(defvar *applescript-token-starters*
+ '(#\" #\{ #\left-pointing_double_angle_quotation_mark))
+
+(defun parse-applescript-symbol (str &optional (start 0))
+ "Parses an AppleScript symbol, which can contain spaces."
+ (let ((end (or (position-if (lambda (char)
+ (find char *applescript-token-terminators*
+ :test #'char=))
+ str
+ :start start)
+ (length str)))
+ (bad-end (position-if (lambda (char)
+ (find char *applescript-token-starters*
+ :test #'char=))
+ str
+ :start start)))
+ (when (and bad-end (< bad-end end))
+ (error "Illegal AppleScript token terminator ~S encountered at position ~A in ~S"
+ (char str bad-end) bad-end str))
+ (let ((name (subseq str start end)))
+ ;; Replace spaces with hyphens...
+ (do ((space-pos (position #\space name :test #'char=)
+ (position #\space name :test #'char=)))
+ ((null space-pos))
+ (setf (char name space-pos) #\-))
+ ;; Intern the symbol and return end position too.
+ (values (intern (string-upcase name)
+ *applescript-symbol-package*)
+ end))))
+
+(defun parse-applescript-chevron (str &optional (start 0))
+ (assert (char= #\left-pointing_double_angle_quotation_mark
+ (char str start)))
+ (incf start)
+ (let ((*package* (find-package :keyword)))
+ (multiple-value-bind (type start) (read-from-string str t nil
+ :start start)
+ (case type
+ (:data (parse-applescript-raw-bytes str start))
+ (:class (parse-applescript-raw-class str start))
+ (t (values nil start))))))
+
+(defun parse-applescript-raw-bytes (str &optional (start 0))
+ (let* ((type (subseq str start (+ start 4)))
+ (start (+ start 4))
+ (end (or (position #\right-pointing_double_angle_quotation_mark
+ str :start start)
+ (length str)))
+ (hex-chars (- end start))
+ (num-bytes (/ hex-chars 2)) ; 2 chars per byte in hex encoding.
+ (bytes (make-array num-bytes
+ :element-type '(unsigned-byte 8))))
+ (dotimes (i num-bytes)
+ (setf (aref bytes i)
+ (parse-integer str
+ :start start
+ :end (+ start 2)
+ :radix 16))
+ (incf start 2))
+ (values (list type bytes) (1+ end))))
+
+(defun parse-applescript-raw-class (str &optional (start 0))
+ (assert (char= #\right-pointing_double_angle_quotation_mark
+ (char str (+ start 4))))
+ (let ((*package* *applescript-symbol-package*))
+ (values (read-from-string str t nil
+ :start start
+ :end (+ start 4))
+ (+ start 5))))
+
+
+(defun parse-applescript-list (str &optional (start 0))
+ (assert (char= #\{ (char str start)))
+ (incf start)
+ (when (char= #\} (char str start))
+ (return-from parse-applescript-list
+ (values nil (1+ start))))
+ (let ((values nil)
+ (value nil)
+ (*readtable* (copy-readtable nil)))
+ (set-syntax-from-char #\} #\))
+ (loop
+ (multiple-value-setq (value start)
+ (parse-applescript-output str start))
+ (push value values)
+ (case (char str start)
+ (#\} (return (values (nreverse values) (1+ start))))
+ (#\, (incf start))
+ (t (error "AppleScript output parse error: #\\, or #\\} expected but found ~S at position ~A in ~S." (char str start) start str))))))
+
diff -rN -u old-cl-applescript/unportable.lisp new-cl-applescript/unportable.lisp
--- old-cl-applescript/unportable.lisp 1969-12-31 16:00:00.000000000 -0800
+++ new-cl-applescript/unportable.lisp 2014-04-19 23:28:22.000000000 -0700
@@ -0,0 +1,58 @@
+(in-package #:cl-applescript)
+
+
+(defun native-namestring (path)
+ "Returns a string representation of `path` that can be passed to OS API's."
+ #+:clozure (namestring (translate-logical-pathname path))
+ #+:sbcl (sb-ext:native-namestring path))
+
+
+(defun spawn-thread (function
+ &key (name "itunes-puppeteer"))
+ "Creates a new thread that runs `function`."
+ #+:clozure (ccl:process-run-function name function)
+ #+:sbcl (sb-thread:make-thread function :name name))
+
+
+(defun kill-thread (thread)
+ "Kills `thread` if it's not dead already."
+ #+:clozure (ccl:process-kill thread)
+ #+:sbcl (when (sb-thread:thread-alive-p thread)
+ (sb-thread:terminate-thread)))
+
+
+(defun run-program (program args
+ &key
+ input output error wait
+ (sharing :private)
+ (element-type 'character))
+ "Runs an external program as a sub-process. See CCL's documentation of `ccl:run-program` which is the model for this function."
+ #+:clozure (ccl:run-program program args
+ :sharing sharing
+ :element-type element-type
+ :wait wait
+ :input input
+ :output output
+ :error error)
+ #+:sbcl (sb-ext:run-program program args
+ :search t
+ :wait wait
+ :input input
+ :output output
+ :error error))
+
+
+(defun process-output-stream (proc)
+ "Gets the output stream associated with the external program process `proc`."
+ #+:clozure (ccl:external-process-output-stream proc)
+ #+:sbcl (sb-ext:process-output proc))
+
+(defun process-input-stream (proc)
+ "Gets the input stream associated with the external program process `proc`."
+ #+:clozure (ccl:external-process-input-stream proc)
+ #+:sbcl (sb-ext:process-input proc))
+
+(defun process-error-stream (proc)
+ "Gets the error stream associated with the external program process `proc`."
+ #+:clozure (ccl:external-process-error-stream proc)
+ #+:sbcl (sb-ext:process-error proc))