[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[PATCH 3/6] move src/cl to src/api/cl
|
From: |
william hubbs |
|
Subject: |
[PATCH 3/6] move src/cl to src/api/cl |
|
Date: |
Wed, 15 Sep 2010 15:55:05 -0500 |
From: William Hubbs <address@hidden>
To: address@hidden
---
src/Makefile.am | 3 +-
src/api/Makefile.am | 2 +
src/api/cl/ChangeLog | 8 +
src/api/cl/README | 16 +
src/api/cl/configuration.lisp | 64 +++++
src/api/cl/elisp.lisp | 61 ++++
src/api/cl/package.lisp | 49 ++++
src/api/cl/ssip.asd | 30 ++
src/api/cl/ssip.lisp | 613 +++++++++++++++++++++++++++++++++++++++++
src/api/cl/sysdep.lisp | 54 ++++
src/cl/ChangeLog | 8 -
src/cl/README | 16 -
src/cl/configuration.lisp | 64 -----
src/cl/elisp.lisp | 61 ----
src/cl/package.lisp | 49 ----
src/cl/ssip.asd | 30 --
src/cl/ssip.lisp | 613 -----------------------------------------
src/cl/sysdep.lisp | 54 ----
18 files changed, 898 insertions(+), 897 deletions(-)
create mode 100644 src/api/cl/ChangeLog
create mode 100644 src/api/cl/README
create mode 100644 src/api/cl/configuration.lisp
create mode 100644 src/api/cl/elisp.lisp
create mode 100644 src/api/cl/package.lisp
create mode 100644 src/api/cl/ssip.asd
create mode 100644 src/api/cl/ssip.lisp
create mode 100644 src/api/cl/sysdep.lisp
delete mode 100644 src/cl/ChangeLog
delete mode 100644 src/cl/README
delete mode 100644 src/cl/configuration.lisp
delete mode 100644 src/cl/elisp.lisp
delete mode 100644 src/cl/package.lisp
delete mode 100644 src/cl/ssip.asd
delete mode 100644 src/cl/ssip.lisp
delete mode 100644 src/cl/sysdep.lisp
diff --git a/src/Makefile.am b/src/Makefile.am
index ea7168d..255f96c 100644
--- a/src/Makefile.am
+++ b/src/Makefile.am
@@ -5,8 +5,7 @@
# in SUBDIRS if they contain another Makefile)
# otherwise they won't be included in distribution packages
-EXTRA_DIST = cl/ChangeLog cl/README cl/configuration.lisp cl/elisp.lisp \
- cl/package.lisp cl/ssip.lisp cl/sysdep.lisp cl/ssip.asd \
+EXTRA_DIST = \
guile/ChangeLog guile/Makefile guile/README guile/gssip.scm.in \
guile/gssip.c guile/gssip.h
diff --git a/src/api/Makefile.am b/src/api/Makefile.am
index 9bee85e..9653288 100644
--- a/src/api/Makefile.am
+++ b/src/api/Makefile.am
@@ -2,3 +2,5 @@
SUBDIRS= c
+EXTRA_DIST = cl
+
diff --git a/src/api/cl/ChangeLog b/src/api/cl/ChangeLog
new file mode 100644
index 0000000..1139b83
--- /dev/null
+++ b/src/api/cl/ChangeLog
@@ -0,0 +1,8 @@
+2004-01-20 Milan Zamazal <pdm at brailcom.org>
+
+ * sysdep.lisp (open-network-stream): Socket creation for SBCL
+ fixed.
+
+ * ssip.lisp: Exportable symbolic parameter values converted to
+ keywords.
+
diff --git a/src/api/cl/README b/src/api/cl/README
new file mode 100644
index 0000000..ea73f4c
--- /dev/null
+++ b/src/api/cl/README
@@ -0,0 +1,16 @@
+This is a simple Common Lisp interface to Speech Dispatcher through the Speech
+Synthesis Interface Protocol (SSIP).
+
+Currently, there is no documentation, read the sources.
+The simplest use can be as follows:
+
+ (asdf:operate-on-system 'asdf:load-op :ssip)
+ (ssip:say-text "Hello, world!")
+
+It works with CLisp and SBCL, but it should be easy to port to other systems,
+just add the support to sysdep.lisp.
+
+Feel free to contact us with any questions regarding the Common Lisp interface
+at the Speech Dispatcher mailing list <speechd at lists.freebsoft.org>.
+
+-- Milan Zamazal <pdm at freebsoft.org>
diff --git a/src/api/cl/configuration.lisp b/src/api/cl/configuration.lisp
new file mode 100644
index 0000000..49a43f8
--- /dev/null
+++ b/src/api/cl/configuration.lisp
@@ -0,0 +1,64 @@
+;;; Configuration variables
+
+;; Author: Milan Zamazal <pdm at brailcom.org>
+
+;; Copyright (C) 2004 Brailcom, o.p.s.
+
+;; COPYRIGHT NOTICE
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA.
+
+
+(in-package :ssip)
+
+
+(defvar *host* "localhost"
+ "Name of the default host running speechd to connect to.")
+
+(defvar *port* (or (ignore-errors
+ (car (read-from-string (getenv "SPEECHD_PORT"))))
+ 6560)
+ "Default port of speechd.")
+
+
+(defvar *default-text-priority* :text
+ "Default Speech Dispatcher priority of sent texts.")
+
+(defvar *default-sound-priority* :message
+ "Default Speech Dispatcher priority of sent sound icons.")
+
+(defvar *default-char-priority* :notification
+ "Default Speech Dispatcher priority of sent single letters.")
+
+
+(defvar *connection-parameters* '()
+ "Alist of connection names and their parameters.
+
+Each element of the list is of the form (CONNECTION-NAME . PARAMETERS), where
+CONNECTION-NAME is a connection name as expected to be in `speechd-client-name'
+and PARAMETERS is a property list with the pairs of parameter identifiers and
+parameter values. Valid parameter names are the following symbols:
+language, message-priority, punctuation-mode, capital-character-mode, voice,
+rate, pitch, output-module. See the corresponding speechd-set-* functions for
+valid parameter values.
+
+If the symbol t is specified as the connection name, the element defines
+default connection parameters if no connection specification applies. Only one
+such an element is allowed in the whole alist.
+
+The message-priority parameter has a special meaning: It overrides priority of
+all messages sent through the connection.
+
+You must reopen the connections to apply the changes to this variable.")
diff --git a/src/api/cl/elisp.lisp b/src/api/cl/elisp.lisp
new file mode 100644
index 0000000..cf1cc2c
--- /dev/null
+++ b/src/api/cl/elisp.lisp
@@ -0,0 +1,61 @@
+;;; Elisp compatibility functions
+
+;; Author: Milan Zamazal <pdm at brailcom.org>
+
+;; Copyright (C) 2004 Brailcom, o.p.s.
+
+;; COPYRIGHT NOTICE
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA.
+
+
+(in-package :ssip)
+
+
+(defmacro while (condition &body body)
+ `(loop while ,condition
+ do (progn , at body)))
+
+
+(defun plist-get-internal (plist prop)
+ (cond
+ ((null plist)
+ nil)
+ ((eq (car plist) prop)
+ (cdr plist))
+ (t
+ (plist-get-internal (nthcdr 2 plist) prop))))
+
+(defun plist-get (plist prop)
+ (first (plist-get-internal plist prop)))
+
+(defun plist-member (plist prop)
+ (not (null (plist-get-internal plist prop))))
+
+(defun plist-put (plist prop val)
+ (let ((value (plist-get-internal plist prop)))
+ (if value
+ (progn
+ (rplaca value val)
+ plist)
+ (list* prop val plist))))
+
+
+(defun user-login-name ()
+ (or (getenv "LOGNAME") (getenv "USER")))
+
+
+(defun concat (&rest args)
+ (apply #'concatenate 'string args))
diff --git a/src/api/cl/package.lisp b/src/api/cl/package.lisp
new file mode 100644
index 0000000..9a1be15
--- /dev/null
+++ b/src/api/cl/package.lisp
@@ -0,0 +1,49 @@
+;;; Package definition
+
+;; Author: Milan Zamazal <pdm at brailcom.org>
+
+;; Copyright (C) 2004 Brailcom, o.p.s.
+
+;; COPYRIGHT NOTICE
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA.
+
+
+(in-package :cl-user)
+
+
+(defpackage :ssip
+ (:use :cl)
+ (:export
+ ;; configuration.lisp
+ #:*application-name*
+ #:*client-name*
+ #:*language*
+ #:*spell*
+ ;; ssip.lisp
+ #:connection-names
+ #:set-language
+ #:open-connection
+ #:close-connection
+ #:reopen-connection
+ #:say-text
+ #:say-sound
+ #:say-char
+ #:cancel
+ #:stop
+ #:pause
+ #:resume
+ ))
+
diff --git a/src/api/cl/ssip.asd b/src/api/cl/ssip.asd
new file mode 100644
index 0000000..690fed0
--- /dev/null
+++ b/src/api/cl/ssip.asd
@@ -0,0 +1,30 @@
+;; Copyright (C) 2004 Brailcom, o.p.s.
+
+;; COPYRIGHT NOTICE
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA.
+
+
+(in-package :asdf)
+
+
+(defsystem :ssip :depends-on (:regex #+SBCL :sb-bsd-sockets)
+ :components
+ ((:file "package")
+ (:file "sysdep")
+ (:file "elisp")
+ (:file "configuration")
+ (:file "ssip"))
+ :serial t)
diff --git a/src/api/cl/ssip.lisp b/src/api/cl/ssip.lisp
new file mode 100644
index 0000000..3a2cddf
--- /dev/null
+++ b/src/api/cl/ssip.lisp
@@ -0,0 +1,613 @@
+;;; Speech Synthesis Interface Protocol (SSIP) interface
+
+;; Author: Milan Zamazal <pdm at brailcom.org>
+
+;; Copyright (C) 2004 Brailcom, o.p.s.
+
+;; COPYRIGHT NOTICE
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA.
+
+
+;;; Note: This library was ported from the Elisp library, so don't wonder much
+;;; about elispisms found here...
+
+
+(in-package :ssip)
+
+
+;;; Exported variables
+
+
+(defvar *application-name* "lisp"
+ "String defining current application name.")
+
+(defvar *client-name* "default"
+ "String defining current client name.
+This variable's value defines which connection is used when communicating via
+SSIP, each connection has its own client name. Usually, you select the proper
+client (connection) by assigning a value to this variable locally through
+`let'.")
+
+(defvar *language* nil
+ "If non-nil, it is an RFC 1766 language code, as a string.
+If text is read and this variable is non-nil, the text is read in the given
+language.")
+
+(defvar *spell* nil
+ "If non-nil, any spoken text is spelled.")
+
+
+;;; Internal constants and configuration variables
+
+
+(defparameter +version+ "$Id: ssip.lisp,v 1.3 2006-02-17 13:18:55 pdm Exp $"
+ "Version stamp of the source file.
+Useful only for diagnosing problems.")
+
+(defvar *language-codes*
+ '(("czech" . "cs")
+ ("english" . "en")
+ ("french" . "fr")
+ ("german" . "de"))
+ "Mapping of LANG values to language ISO codes.")
+
+(defvar *default-voice* "male1")
+(defvar *default-language* (or (cdr (assoc (getenv "LANG") *language-codes*
+ :test #'string=))
+ "en"))
+
+(defparameter +parameter-names+
+ '((client-name . "CLIENT_NAME")
+ (language . "LANGUAGE")
+ (message-priority . "PRIORITY")
+ (punctuation-mode . "PUNCTUATION")
+ (pause-context . "PAUSE_CONTEXT")
+ (capital-character-mode . "CAP_LET_RECOGN")
+ (voice . "VOICE")
+ (rate . "RATE")
+ (pitch . "PITCH")
+ (spelling-mode . "SPELLING")
+ (output-module . "OUTPUT_MODULE")
+ ))
+
+(defparameter +list-parameter-names+
+ '((voices . "VOICES")))
+
+(defparameter +parameter-value-mappings+
+ '((message-priority
+ (:important . "IMPORTANT")
+ (:message . "MESSAGE")
+ (:text . "TEXT")
+ (:notification . "NOTIFICATION")
+ (:progress . "PROGRESS")
+ )
+ (punctuation-mode
+ (:none . "none")
+ (:some . "some")
+ (:all . "all"))
+ (capital-character-mode
+ (:none . "none")
+ (:spell . "spell")
+ (:icon . "icon"))
+ (spelling-mode
+ (t . "on")
+ (nil . "off"))))
+
+(defparameter +volatile-parameters+ '(output-module))
+
+(defparameter +punctuation-modes+ '(("none" . none)
+ ("some" . some)
+ ("all" . all)))
+
+(defparameter +capital-character-modes+ '(("none" . none)
+ ("spell" . spell)
+ ("icon" . icon)))
+
+
+;;; Internal variables
+
+
+(defstruct connection
+ name
+ host
+ port
+ (failure-p nil)
+ stream
+ (paused-p nil)
+ (in-block nil)
+ (transaction-state nil)
+ (parameters ())
+ (forced-priority nil)
+ (last-command nil))
+
+(defstruct request
+ string
+ (transaction-state '(nil nil)))
+
+(defvar *connections* (make-hash-table :test #'equal)
+ "Hash table mapping client names to `connection' instances.")
+
+(defvar *connection* nil
+ "Current connection.")
+
+
+
+;;; Utilities
+
+
+(defmacro iterate-clients (&rest body)
+ `(maphash #'(lambda (*client-name* _) (declare (ignore _)) , at body)
+ *connections*))
+
+(defmacro iterate-connections (&rest body)
+ `(maphash #'(lambda (_ *connection*) (declare (ignore _)) , at body)
+ *connections*))
+
+(defun connection-names ()
+ "Return the list of all present connection names."
+ (let ((names '()))
+ (iterate-clients
+ (push *client-name* names))
+ names))
+
+(defmacro with-current-connection (&rest body)
+ `(let ((*connection* (get-connection)))
+ , at body))
+
+(defmacro with-connection-setting (var value &rest body)
+ (let ((accessor (intern (concat "CONNECTION-" (symbol-name var))))
+ (orig-value (gensym)))
+ `(let ((,orig-value (,accessor *connection*)))
+ (setf (,accessor *connection*) ,value)
+ (unwind-protect
+ (progn
+ , at body)
+ (setf (,accessor *connection*) ,orig-value)))))
+
+(defmacro with-connection-parameters (parameters &rest body)
+ (let (($parameters (gensym))
+ ($orig-parameters (gensym))
+ ($cparameters (gensym))
+ ($p (gensym))
+ ($v (gensym))
+ ($orig-v (gensym))
+ ($pv (gensym)))
+ `(let* ((,$parameters ,parameters)
+ (,$orig-parameters ()))
+ (unwind-protect
+ (progn
+ (while ,$parameters
+ (let* ((,$p (first ,$parameters))
+ (,$v (second ,$parameters))
+ (,$cparameters
+ (connection-parameters *connection*))
+ (,$orig-v (plist-get ,$cparameters ,$p)))
+ (when (and (not (equal ,$v ,$orig-v))
+ (or ,$v
+ (not (member ,$p '(language)))))
+ (when (plist-member ,$cparameters ,$p)
+ (push (cons ,$p ,$orig-v) ,$orig-parameters))
+ (set-parameter ,$p ,$v)))
+ (setq ,$parameters (nthcdr 2 ,$parameters)))
+ , at body)
+ (dolist (,$pv ,$orig-parameters)
+ (set-parameter (car ,$pv) (cdr ,$pv)))))))
+
+
+;;; Process management functions
+
+
+(defun get-connection (&optional (name *client-name*) (create-if-needed t))
+ (or (gethash name *connections*)
+ (and create-if-needed
+ (let ((*client-name* name))
+ (open-connection)))))
+
+(defun close-connection-stream (connection)
+ (let ((stream (connection-stream connection)))
+ (when stream
+ (ignore-errors (close-network-stream stream)))
+ (setf (connection-stream connection) nil)))
+
+(defun open-connection (&optional host port &key quiet force-reopen)
+ "Open SSIP connection to given HOST and PORT.
+If the connection corresponding to the current `*client-name*' value
+already exists, close it and reopen again, with the same connection parameters.
+
+The optional arguments HOST and PORT identify the speechd server location
+differing from the values of `speechd-host' and `speechd-port'.
+
+If the key argument QUIET is non-nil, don't report failures and quit silently.
+If the key argument FORCE-REOPEN is non-nil, try to reopen an existent
+connection even if it previously failed.
+
+Return the opened connection on success, nil otherwise."
+ (let ((connection (gethash *client-name* *connections*)))
+ (let ((host (or host *host*))
+ (port (or port *port*)))
+ (when connection
+ (close-connection connection)
+ (setq host (connection-host connection)
+ port (connection-port connection)))
+ (let* ((name *client-name*)
+ (default-parameters (append
+ (cdr (assoc *client-name*
+ *connection-parameters*
+ :test #'string=))
+ (cdr (assoc t *connection-parameters*))))
+ (parameters (if connection
+ (append
+ (connection-parameters connection)
+ default-parameters)
+ default-parameters))
+ (stream (when (or (not connection)
+ (not (connection-failure-p connection))
+ force-reopen)
+ (ignore-errors
+ (open-network-stream host port)))))
+ (when (and (not stream) (not quiet))
+ (error "Connection to SSIP failed"))
+ (setq connection (make-connection
+ :name name :host host :port port
+ :stream stream :failure-p (not stream)))
+ (setf (gethash name *connections*) connection)
+ (when stream
+ (set-connection-name name)
+ (setq parameters (append parameters
+ (list 'language *default-language*
+ 'voice *default-voice*)))
+ (let ((already-set '(client-name)))
+ (while parameters
+ (destructuring-bind (parameter value . next) parameters
+ (unless (member parameter already-set)
+ (push parameter already-set)
+ (set-parameter parameter value))
+ (setq parameters next)))))
+ (let ((priority (and
+ connection
+ (plist-get default-parameters 'message-priority))))
+ (when priority
+ (set-parameter 'message-priority priority)
+ (setf (connection-forced-priority connection) t)))))
+ connection))
+
+(defun close-connection (&optional (name *client-name*))
+ "Close speechd connection named NAME."
+ (let ((connection (get-connection name nil)))
+ (when connection
+ (close-connection-stream connection)
+ (remhash name *connections*))))
+
+(defun reopen-connection ()
+ "Close and open again all the connections to speechd."
+ (iterate-clients (open-connection :quiet t :force-reopen t)))
+
+(defun running-p ()
+ "Return non-nil, if the current speechd client name process is running."
+ (let ((connection (get-connection)))
+ (and connection (connection-stream connection))))
+
+
+;;; Process communication functions
+
+
+(defun permanent-connection-failure (connection)
+ (close-connection-stream connection)
+ (setf (connection-failure-p connection) t
+ (connection-paused-p connection) nil
+ (connection-transaction-state connection) nil
+ (connection-parameters connection) ()))
+
+(defun send-string (string)
+ (with-current-connection
+ (let ((stream (connection-stream *connection*)))
+ (when stream
+ (unwind-protect
+ (format stream "~A" string)
+ (when (not (running-p))
+ (permanent-connection-failure *connection*)))))))
+
+(defun process-request (request)
+ (with-current-connection
+ ;; Ensure proper transaction state
+ (let* ((state-spec (request-transaction-state request))
+ (required-state (first state-spec))
+ (new-state (second state-spec)))
+ (labels ((check-state (reopen-if-needed)
+ (let ((current-state (connection-transaction-state
+ *connection*)))
+ (when (and (not (eq current-state required-state))
+ (not (eq current-state new-state)))
+ (cond
+ ((and (eq required-state 'in-data)
+ (not (eq new-state nil)))
+ (send-data-begin))
+ ((eq required-state nil)
+ (send-data-end))))
+ (setq current-state (connection-transaction-state
+ *connection*))
+ (if (and reopen-if-needed
+ (not (eq current-state required-state))
+ (not (eq current-state new-state))
+ (not (connection-failure-p *connection*)))
+ (progn
+ (open-connection)
+ (setq *connection* (get-connection))
+ (check-state nil))
+ (eq current-state required-state)))))
+ ;; Continue only if the state can be set properly after reopen,
+ ;; otherwise give up and ignore the request completely.
+ ;; This also works for the "." command when in non-data state.
+ (when (check-state t)
+ (send-string (request-string request))
+ ;; Read command answer
+ (unless (equal state-spec '(in-data in-data))
+ (destructuring-bind (answer-line . data-lines)
+ (loop with stream = (connection-stream *connection*)
+ for line = (read-line stream)
+ for lines = (list line) then (cons line lines)
+ while (and (> (length line) 3)
+ (char= (char line 3) #\-))
+ finally (return lines))
+ (let* ((code (subseq answer-line 0 3))
+ (answer (subseq answer-line 4))
+ (success (member (char code 0) '(#\1 #\2)))
+ (data (and success
+ (mapcar #'(lambda (line) (subseq line 4))
+ data-lines))))
+ (when success
+ (setf (connection-transaction-state *connection*) new-state))
+ (list success data code answer)))))))))
+
+(defun send-request (request)
+ (with-current-connection
+ (process-request request)))
+
+(defparameter +block-commands+
+ '(("speak")
+ ("sound_icon")
+ ("char")
+ ("key")
+ ("quit")
+ ("block" ("end"))
+ ("set" ("self" ("rate" "pitch" "voice" "language")))))
+
+(defun block-command-p (command &optional allowed)
+ (unless allowed
+ (setq allowed +block-commands+))
+ (let* ((match (assoc (first command) allowed :test #'string-equal))
+ (rest-allowed (cdr match)))
+ (and match
+ (or (not rest-allowed)
+ (block-command-p (rest command) rest-allowed)))))
+
+(defun send-command (command &optional (transaction-state '(nil nil)))
+ (unless (listp command)
+ (setq command (list command)))
+ (with-current-connection
+ (setf (connection-last-command *connection*) command)
+ (when (or (not (connection-in-block *connection*))
+ (block-command-p command))
+ (send-request
+ (make-request
+ :string (format nil "~{~A~^ ~}~A~A" command #\Return #\Linefeed)
+ :transaction-state transaction-state)))))
+
+(defun send-data-begin ()
+ (send-command "SPEAK" '(nil in-data)))
+
+(defun send-data (text)
+ (let ((text* text))
+ (flet ((send (string)
+ (unless (string= string "")
+ (send-request (make-request
+ :string string
+ :transaction-state '(in-data in-data))))))
+ (loop with eol = (format nil "~A~A" #\Return #\Linefeed)
+ for length = (length text*)
+ for nlpos = (or (position #\Linefeed text*) length)
+ for dotted = (and (> (length text*) 0)
+ (char= (char text* 0) #\.))
+ until (string= text* "")
+ do (progn
+ (when dotted
+ (send "."))
+ (send (subseq text* 0 nlpos))
+ (send eol)
+ (setq text* (subseq text* (min (1+ nlpos) length))))))))
+
+(defun send-data-end ()
+ (send-command "." '(in-data nil)))
+
+
+;;; Value retrieval functions
+
+
+(defun list-values (parameter)
+ (second (send-command
+ (list "LIST" (cdr (assoc parameter +list-parameter-names+))))))
+
+
+;;; Parameter setting functions
+
+
+(defun convert-numeric (number)
+ (cond ((< number -100) -100)
+ ((> number 100) 100)
+ (t number)))
+
+(defun transform-parameter-value (parameter value)
+ (cond
+ ((stringp value)
+ value)
+ ((integerp value)
+ (format nil "~D" (convert-numeric value)))
+ ((symbolp value)
+ (cdr (assoc value
+ (cdr (assoc parameter +parameter-value-mappings+)))))))
+
+(defun set-parameter (parameter value)
+ (with-current-connection
+ (let* ((plist (connection-parameters *connection*))
+ (orig-value (if (plist-member plist parameter)
+ (plist-get plist parameter)
+ 'unknown)))
+ (when (or (member parameter +volatile-parameters+)
+ (and (not (equal orig-value value))
+ (or (not (eq parameter 'message-priority))
+ (not (connection-forced-priority *connection*)))))
+ (let ((answer
+ (send-command
+ (let ((p (cdr (assoc parameter +parameter-names+)))
+ (v (transform-parameter-value parameter value)))
+ (unless p
+ (error "Invalid parameter name: `~A'" parameter))
+ (unless v
+ (error "Invalid parameter value: ~A=~A" parameter value))
+ (list "SET" "self" p v)))))
+ (setq *connection* (get-connection))
+ (when (first answer)
+ (setf (connection-parameters *connection*)
+ (plist-put (connection-parameters *connection*)
+ parameter value))))))))
+
+(defun set-connection-name (name)
+ (set-parameter
+ 'client-name
+ (format nil "~A:~A:~A" (user-login-name) *application-name* name)))
+
+(defun set-language (language)
+ "Set language of the current client connection to LANGUAGE.
+Language must be an RFC 1766 language code, as a string."
+ (set-parameter 'language language)
+ (setq *language* language))
+
+
+;;; Blocks
+
+
+(defmacro with-block (parameters &rest body)
+ "Set PARAMETERS and enclose BODY by an SSIP block.
+Before invoking BODY, the BLOCK BEGIN command is sent, and the BLOCK END
+command is sent afterwards.
+PARAMETERS is a property list defining parameters to be set before sending the
+BLOCK BEGIN command. The property-value pairs correspond to the arguments of
+the `set-parameter' function."
+ `(with-current-connection
+ (with-connection-parameters ,parameters
+ (if (and *connection* (connection-in-block *connection*))
+ (progn , at body)
+ (let ((block-connection *connection*))
+ (send-command '("BLOCK BEGIN"))
+ (unwind-protect
+ (progn
+ (with-current-connection
+ (when *connection*
+ (setf (connection-in-block *connection*) t)))
+ , at body)
+ (let ((*connection* block-connection))
+ (when *connection*
+ (setf (connection-in-block *connection*) nil)
+ (let ((*client-name*
+ (connection-name *connection*)))
+ (send-command '("BLOCK END")))))))))))
+
+
+;;; Speaking functions
+
+
+(defun say-text (text &key (priority *default-text-priority*))
+ "Speak the given TEXT, represented by a string.
+The key argument `priority' defines the priority of the message and must be one
+of the symbols `important', `message', `text', `notification' or
+`progress'."
+ (set-parameter 'message-priority priority)
+ (unless (string= text "")
+ (send-data-begin)
+ (send-data text)
+ (send-data-end)))
+
+(defun say-sound (name &key (priority *default-sound-priority*))
+ "Play an auditory icon.
+NAME is the name of the icon, any string acceptable by speechd.
+The key argument `priority' defines the priority of the message and must be one
+of the symbols `important', `message', `text', `notification' or
+`progress'."
+ (set-parameter 'message-priority priority)
+ (send-command (list "SOUND_ICON" name)))
+
+(defun say-char (char &key (priority *default-char-priority*))
+ "Speak the given CHAR, any UTF-8 character.
+The key argument `priority' defines the priority of the message and must be one
+of the symbols `important', `message', `text', `notification' or
+`progress'."
+ (set-parameter 'message-priority priority)
+ (with-current-connection
+ (with-connection-parameters `(language ,*language*)
+ (send-command
+ (list "CHAR" (format nil "~A" (case char
+ (? "space")
+ (?\n "linefeed")
+ (t (format nil "~A" char)))))))))
+
+
+;;; Control functions
+
+
+(defun control-command (command all &optional repeatable)
+ (cond
+ ((not all)
+ (when (or repeatable
+ (not (equal (first (connection-last-command (get-connection)))
+ command)))
+ (send-command (list command "self"))))
+ ((numberp all)
+ (iterate-clients (control-command command nil)))
+ (t
+ (send-command (list command "all")))))
+
+(defun cancel (&optional all)
+ "Stop speaking all the messages sent through the current client so far.
+If the universal argument is given, stop speaking messages of all clients.
+If a numeric argument is given, stop speaking messages of all current Emacs
+session clients."
+ (control-command "CANCEL" all))
+
+(defun stop (&optional all)
+ "Stop speaking the currently spoken message (if any) of this client.
+If the optional argument ALL is non-nil, stop speaking the currently spoken
+messages of all clients."
+ (control-command "STOP" all t))
+
+(defun pause (&optional all)
+ "Pause speaking in the current client.
+If the optional argument ALL is non-nil, pause speaking in all clients."
+ (if all
+ (iterate-connections
+ (setf (connection-paused-p *connection*) t))
+ (setf (connection-paused-p (get-connection)) t))
+ (control-command "PAUSE" (not (not all))))
+
+(defun resume (&optional all)
+ "Resume previously stopped speaking in the current client.
+If the optional argument ALL is non-nil, resume speaking messages of all
+clients."
+ (when (or all (connection-paused-p (get-connection)))
+ (control-command "RESUME" (not (not all)))
+ (if all
+ (setf (connection-paused-p (get-connection)) nil)
+ (iterate-connections
+ (setf (connection-paused-p *connection*) nil)))))
diff --git a/src/api/cl/sysdep.lisp b/src/api/cl/sysdep.lisp
new file mode 100644
index 0000000..5232986
--- /dev/null
+++ b/src/api/cl/sysdep.lisp
@@ -0,0 +1,54 @@
+;;; System dependent functions
+
+;; Author: Milan Zamazal <pdm at brailcom.org>
+
+;; Copyright (C) 2004 Brailcom, o.p.s.
+
+;; COPYRIGHT NOTICE
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA.
+
+
+(in-package :ssip)
+
+
+(defun getenv (var)
+ #+SBCL
+ (sb-ext:posix-getenv var)
+ #+CLISP
+ (ext:getenv var))
+
+
+#+CLISP
+(defparameter +encoding+
+ (ext:make-encoding :charset 'charset:utf-8 :line-terminator :unix))
+
+(defun open-network-stream (host port)
+ #+CLISP
+ (socket:socket-connect port host :external-format +encoding+)
+ #+SBCL
+ (let ((s (make-instance 'sb-bsd-sockets:inet-socket :type :stream
+ :protocol :tcp)))
+ (sb-bsd-sockets:socket-connect
+ s
+ (sb-bsd-sockets:host-ent-address (sb-bsd-sockets:get-host-by-name host))
+ port)
+ (sb-bsd-sockets:socket-make-stream s :input t :output t :buffering :none))
+ )
+
+(defun close-network-stream (stream)
+ #+(or SBCL CLISP)
+ (close stream))
+
diff --git a/src/cl/ChangeLog b/src/cl/ChangeLog
deleted file mode 100644
index 1139b83..0000000
--- a/src/cl/ChangeLog
+++ /dev/null
@@ -1,8 +0,0 @@
-2004-01-20 Milan Zamazal <pdm at brailcom.org>
-
- * sysdep.lisp (open-network-stream): Socket creation for SBCL
- fixed.
-
- * ssip.lisp: Exportable symbolic parameter values converted to
- keywords.
-
diff --git a/src/cl/README b/src/cl/README
deleted file mode 100644
index ea73f4c..0000000
--- a/src/cl/README
+++ /dev/null
@@ -1,16 +0,0 @@
-This is a simple Common Lisp interface to Speech Dispatcher through the Speech
-Synthesis Interface Protocol (SSIP).
-
-Currently, there is no documentation, read the sources.
-The simplest use can be as follows:
-
- (asdf:operate-on-system 'asdf:load-op :ssip)
- (ssip:say-text "Hello, world!")
-
-It works with CLisp and SBCL, but it should be easy to port to other systems,
-just add the support to sysdep.lisp.
-
-Feel free to contact us with any questions regarding the Common Lisp interface
-at the Speech Dispatcher mailing list <speechd at lists.freebsoft.org>.
-
--- Milan Zamazal <pdm at freebsoft.org>
diff --git a/src/cl/configuration.lisp b/src/cl/configuration.lisp
deleted file mode 100644
index 49a43f8..0000000
--- a/src/cl/configuration.lisp
+++ /dev/null
@@ -1,64 +0,0 @@
-;;; Configuration variables
-
-;; Author: Milan Zamazal <pdm at brailcom.org>
-
-;; Copyright (C) 2004 Brailcom, o.p.s.
-
-;; COPYRIGHT NOTICE
-
-;; This program is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2 of the License, or
-;; (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful, but
-;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
-;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
-;; for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program; if not, write to the Free Software
-;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA.
-
-
-(in-package :ssip)
-
-
-(defvar *host* "localhost"
- "Name of the default host running speechd to connect to.")
-
-(defvar *port* (or (ignore-errors
- (car (read-from-string (getenv "SPEECHD_PORT"))))
- 6560)
- "Default port of speechd.")
-
-
-(defvar *default-text-priority* :text
- "Default Speech Dispatcher priority of sent texts.")
-
-(defvar *default-sound-priority* :message
- "Default Speech Dispatcher priority of sent sound icons.")
-
-(defvar *default-char-priority* :notification
- "Default Speech Dispatcher priority of sent single letters.")
-
-
-(defvar *connection-parameters* '()
- "Alist of connection names and their parameters.
-
-Each element of the list is of the form (CONNECTION-NAME . PARAMETERS), where
-CONNECTION-NAME is a connection name as expected to be in `speechd-client-name'
-and PARAMETERS is a property list with the pairs of parameter identifiers and
-parameter values. Valid parameter names are the following symbols:
-language, message-priority, punctuation-mode, capital-character-mode, voice,
-rate, pitch, output-module. See the corresponding speechd-set-* functions for
-valid parameter values.
-
-If the symbol t is specified as the connection name, the element defines
-default connection parameters if no connection specification applies. Only one
-such an element is allowed in the whole alist.
-
-The message-priority parameter has a special meaning: It overrides priority of
-all messages sent through the connection.
-
-You must reopen the connections to apply the changes to this variable.")
diff --git a/src/cl/elisp.lisp b/src/cl/elisp.lisp
deleted file mode 100644
index cf1cc2c..0000000
--- a/src/cl/elisp.lisp
+++ /dev/null
@@ -1,61 +0,0 @@
-;;; Elisp compatibility functions
-
-;; Author: Milan Zamazal <pdm at brailcom.org>
-
-;; Copyright (C) 2004 Brailcom, o.p.s.
-
-;; COPYRIGHT NOTICE
-
-;; This program is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2 of the License, or
-;; (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful, but
-;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
-;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
-;; for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program; if not, write to the Free Software
-;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA.
-
-
-(in-package :ssip)
-
-
-(defmacro while (condition &body body)
- `(loop while ,condition
- do (progn , at body)))
-
-
-(defun plist-get-internal (plist prop)
- (cond
- ((null plist)
- nil)
- ((eq (car plist) prop)
- (cdr plist))
- (t
- (plist-get-internal (nthcdr 2 plist) prop))))
-
-(defun plist-get (plist prop)
- (first (plist-get-internal plist prop)))
-
-(defun plist-member (plist prop)
- (not (null (plist-get-internal plist prop))))
-
-(defun plist-put (plist prop val)
- (let ((value (plist-get-internal plist prop)))
- (if value
- (progn
- (rplaca value val)
- plist)
- (list* prop val plist))))
-
-
-(defun user-login-name ()
- (or (getenv "LOGNAME") (getenv "USER")))
-
-
-(defun concat (&rest args)
- (apply #'concatenate 'string args))
diff --git a/src/cl/package.lisp b/src/cl/package.lisp
deleted file mode 100644
index 9a1be15..0000000
--- a/src/cl/package.lisp
+++ /dev/null
@@ -1,49 +0,0 @@
-;;; Package definition
-
-;; Author: Milan Zamazal <pdm at brailcom.org>
-
-;; Copyright (C) 2004 Brailcom, o.p.s.
-
-;; COPYRIGHT NOTICE
-
-;; This program is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2 of the License, or
-;; (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful, but
-;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
-;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
-;; for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program; if not, write to the Free Software
-;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA.
-
-
-(in-package :cl-user)
-
-
-(defpackage :ssip
- (:use :cl)
- (:export
- ;; configuration.lisp
- #:*application-name*
- #:*client-name*
- #:*language*
- #:*spell*
- ;; ssip.lisp
- #:connection-names
- #:set-language
- #:open-connection
- #:close-connection
- #:reopen-connection
- #:say-text
- #:say-sound
- #:say-char
- #:cancel
- #:stop
- #:pause
- #:resume
- ))
-
diff --git a/src/cl/ssip.asd b/src/cl/ssip.asd
deleted file mode 100644
index 690fed0..0000000
--- a/src/cl/ssip.asd
+++ /dev/null
@@ -1,30 +0,0 @@
-;; Copyright (C) 2004 Brailcom, o.p.s.
-
-;; COPYRIGHT NOTICE
-
-;; This program is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2 of the License, or
-;; (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful, but
-;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
-;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
-;; for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program; if not, write to the Free Software
-;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA.
-
-
-(in-package :asdf)
-
-
-(defsystem :ssip :depends-on (:regex #+SBCL :sb-bsd-sockets)
- :components
- ((:file "package")
- (:file "sysdep")
- (:file "elisp")
- (:file "configuration")
- (:file "ssip"))
- :serial t)
diff --git a/src/cl/ssip.lisp b/src/cl/ssip.lisp
deleted file mode 100644
index 3a2cddf..0000000
--- a/src/cl/ssip.lisp
+++ /dev/null
@@ -1,613 +0,0 @@
-;;; Speech Synthesis Interface Protocol (SSIP) interface
-
-;; Author: Milan Zamazal <pdm at brailcom.org>
-
-;; Copyright (C) 2004 Brailcom, o.p.s.
-
-;; COPYRIGHT NOTICE
-
-;; This program is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2 of the License, or
-;; (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful, but
-;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
-;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
-;; for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program; if not, write to the Free Software
-;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA.
-
-
-;;; Note: This library was ported from the Elisp library, so don't wonder much
-;;; about elispisms found here...
-
-
-(in-package :ssip)
-
-
-;;; Exported variables
-
-
-(defvar *application-name* "lisp"
- "String defining current application name.")
-
-(defvar *client-name* "default"
- "String defining current client name.
-This variable's value defines which connection is used when communicating via
-SSIP, each connection has its own client name. Usually, you select the proper
-client (connection) by assigning a value to this variable locally through
-`let'.")
-
-(defvar *language* nil
- "If non-nil, it is an RFC 1766 language code, as a string.
-If text is read and this variable is non-nil, the text is read in the given
-language.")
-
-(defvar *spell* nil
- "If non-nil, any spoken text is spelled.")
-
-
-;;; Internal constants and configuration variables
-
-
-(defparameter +version+ "$Id: ssip.lisp,v 1.3 2006-02-17 13:18:55 pdm Exp $"
- "Version stamp of the source file.
-Useful only for diagnosing problems.")
-
-(defvar *language-codes*
- '(("czech" . "cs")
- ("english" . "en")
- ("french" . "fr")
- ("german" . "de"))
- "Mapping of LANG values to language ISO codes.")
-
-(defvar *default-voice* "male1")
-(defvar *default-language* (or (cdr (assoc (getenv "LANG") *language-codes*
- :test #'string=))
- "en"))
-
-(defparameter +parameter-names+
- '((client-name . "CLIENT_NAME")
- (language . "LANGUAGE")
- (message-priority . "PRIORITY")
- (punctuation-mode . "PUNCTUATION")
- (pause-context . "PAUSE_CONTEXT")
- (capital-character-mode . "CAP_LET_RECOGN")
- (voice . "VOICE")
- (rate . "RATE")
- (pitch . "PITCH")
- (spelling-mode . "SPELLING")
- (output-module . "OUTPUT_MODULE")
- ))
-
-(defparameter +list-parameter-names+
- '((voices . "VOICES")))
-
-(defparameter +parameter-value-mappings+
- '((message-priority
- (:important . "IMPORTANT")
- (:message . "MESSAGE")
- (:text . "TEXT")
- (:notification . "NOTIFICATION")
- (:progress . "PROGRESS")
- )
- (punctuation-mode
- (:none . "none")
- (:some . "some")
- (:all . "all"))
- (capital-character-mode
- (:none . "none")
- (:spell . "spell")
- (:icon . "icon"))
- (spelling-mode
- (t . "on")
- (nil . "off"))))
-
-(defparameter +volatile-parameters+ '(output-module))
-
-(defparameter +punctuation-modes+ '(("none" . none)
- ("some" . some)
- ("all" . all)))
-
-(defparameter +capital-character-modes+ '(("none" . none)
- ("spell" . spell)
- ("icon" . icon)))
-
-
-;;; Internal variables
-
-
-(defstruct connection
- name
- host
- port
- (failure-p nil)
- stream
- (paused-p nil)
- (in-block nil)
- (transaction-state nil)
- (parameters ())
- (forced-priority nil)
- (last-command nil))
-
-(defstruct request
- string
- (transaction-state '(nil nil)))
-
-(defvar *connections* (make-hash-table :test #'equal)
- "Hash table mapping client names to `connection' instances.")
-
-(defvar *connection* nil
- "Current connection.")
-
-
-
-;;; Utilities
-
-
-(defmacro iterate-clients (&rest body)
- `(maphash #'(lambda (*client-name* _) (declare (ignore _)) , at body)
- *connections*))
-
-(defmacro iterate-connections (&rest body)
- `(maphash #'(lambda (_ *connection*) (declare (ignore _)) , at body)
- *connections*))
-
-(defun connection-names ()
- "Return the list of all present connection names."
- (let ((names '()))
- (iterate-clients
- (push *client-name* names))
- names))
-
-(defmacro with-current-connection (&rest body)
- `(let ((*connection* (get-connection)))
- , at body))
-
-(defmacro with-connection-setting (var value &rest body)
- (let ((accessor (intern (concat "CONNECTION-" (symbol-name var))))
- (orig-value (gensym)))
- `(let ((,orig-value (,accessor *connection*)))
- (setf (,accessor *connection*) ,value)
- (unwind-protect
- (progn
- , at body)
- (setf (,accessor *connection*) ,orig-value)))))
-
-(defmacro with-connection-parameters (parameters &rest body)
- (let (($parameters (gensym))
- ($orig-parameters (gensym))
- ($cparameters (gensym))
- ($p (gensym))
- ($v (gensym))
- ($orig-v (gensym))
- ($pv (gensym)))
- `(let* ((,$parameters ,parameters)
- (,$orig-parameters ()))
- (unwind-protect
- (progn
- (while ,$parameters
- (let* ((,$p (first ,$parameters))
- (,$v (second ,$parameters))
- (,$cparameters
- (connection-parameters *connection*))
- (,$orig-v (plist-get ,$cparameters ,$p)))
- (when (and (not (equal ,$v ,$orig-v))
- (or ,$v
- (not (member ,$p '(language)))))
- (when (plist-member ,$cparameters ,$p)
- (push (cons ,$p ,$orig-v) ,$orig-parameters))
- (set-parameter ,$p ,$v)))
- (setq ,$parameters (nthcdr 2 ,$parameters)))
- , at body)
- (dolist (,$pv ,$orig-parameters)
- (set-parameter (car ,$pv) (cdr ,$pv)))))))
-
-
-;;; Process management functions
-
-
-(defun get-connection (&optional (name *client-name*) (create-if-needed t))
- (or (gethash name *connections*)
- (and create-if-needed
- (let ((*client-name* name))
- (open-connection)))))
-
-(defun close-connection-stream (connection)
- (let ((stream (connection-stream connection)))
- (when stream
- (ignore-errors (close-network-stream stream)))
- (setf (connection-stream connection) nil)))
-
-(defun open-connection (&optional host port &key quiet force-reopen)
- "Open SSIP connection to given HOST and PORT.
-If the connection corresponding to the current `*client-name*' value
-already exists, close it and reopen again, with the same connection parameters.
-
-The optional arguments HOST and PORT identify the speechd server location
-differing from the values of `speechd-host' and `speechd-port'.
-
-If the key argument QUIET is non-nil, don't report failures and quit silently.
-If the key argument FORCE-REOPEN is non-nil, try to reopen an existent
-connection even if it previously failed.
-
-Return the opened connection on success, nil otherwise."
- (let ((connection (gethash *client-name* *connections*)))
- (let ((host (or host *host*))
- (port (or port *port*)))
- (when connection
- (close-connection connection)
- (setq host (connection-host connection)
- port (connection-port connection)))
- (let* ((name *client-name*)
- (default-parameters (append
- (cdr (assoc *client-name*
- *connection-parameters*
- :test #'string=))
- (cdr (assoc t *connection-parameters*))))
- (parameters (if connection
- (append
- (connection-parameters connection)
- default-parameters)
- default-parameters))
- (stream (when (or (not connection)
- (not (connection-failure-p connection))
- force-reopen)
- (ignore-errors
- (open-network-stream host port)))))
- (when (and (not stream) (not quiet))
- (error "Connection to SSIP failed"))
- (setq connection (make-connection
- :name name :host host :port port
- :stream stream :failure-p (not stream)))
- (setf (gethash name *connections*) connection)
- (when stream
- (set-connection-name name)
- (setq parameters (append parameters
- (list 'language *default-language*
- 'voice *default-voice*)))
- (let ((already-set '(client-name)))
- (while parameters
- (destructuring-bind (parameter value . next) parameters
- (unless (member parameter already-set)
- (push parameter already-set)
- (set-parameter parameter value))
- (setq parameters next)))))
- (let ((priority (and
- connection
- (plist-get default-parameters 'message-priority))))
- (when priority
- (set-parameter 'message-priority priority)
- (setf (connection-forced-priority connection) t)))))
- connection))
-
-(defun close-connection (&optional (name *client-name*))
- "Close speechd connection named NAME."
- (let ((connection (get-connection name nil)))
- (when connection
- (close-connection-stream connection)
- (remhash name *connections*))))
-
-(defun reopen-connection ()
- "Close and open again all the connections to speechd."
- (iterate-clients (open-connection :quiet t :force-reopen t)))
-
-(defun running-p ()
- "Return non-nil, if the current speechd client name process is running."
- (let ((connection (get-connection)))
- (and connection (connection-stream connection))))
-
-
-;;; Process communication functions
-
-
-(defun permanent-connection-failure (connection)
- (close-connection-stream connection)
- (setf (connection-failure-p connection) t
- (connection-paused-p connection) nil
- (connection-transaction-state connection) nil
- (connection-parameters connection) ()))
-
-(defun send-string (string)
- (with-current-connection
- (let ((stream (connection-stream *connection*)))
- (when stream
- (unwind-protect
- (format stream "~A" string)
- (when (not (running-p))
- (permanent-connection-failure *connection*)))))))
-
-(defun process-request (request)
- (with-current-connection
- ;; Ensure proper transaction state
- (let* ((state-spec (request-transaction-state request))
- (required-state (first state-spec))
- (new-state (second state-spec)))
- (labels ((check-state (reopen-if-needed)
- (let ((current-state (connection-transaction-state
- *connection*)))
- (when (and (not (eq current-state required-state))
- (not (eq current-state new-state)))
- (cond
- ((and (eq required-state 'in-data)
- (not (eq new-state nil)))
- (send-data-begin))
- ((eq required-state nil)
- (send-data-end))))
- (setq current-state (connection-transaction-state
- *connection*))
- (if (and reopen-if-needed
- (not (eq current-state required-state))
- (not (eq current-state new-state))
- (not (connection-failure-p *connection*)))
- (progn
- (open-connection)
- (setq *connection* (get-connection))
- (check-state nil))
- (eq current-state required-state)))))
- ;; Continue only if the state can be set properly after reopen,
- ;; otherwise give up and ignore the request completely.
- ;; This also works for the "." command when in non-data state.
- (when (check-state t)
- (send-string (request-string request))
- ;; Read command answer
- (unless (equal state-spec '(in-data in-data))
- (destructuring-bind (answer-line . data-lines)
- (loop with stream = (connection-stream *connection*)
- for line = (read-line stream)
- for lines = (list line) then (cons line lines)
- while (and (> (length line) 3)
- (char= (char line 3) #\-))
- finally (return lines))
- (let* ((code (subseq answer-line 0 3))
- (answer (subseq answer-line 4))
- (success (member (char code 0) '(#\1 #\2)))
- (data (and success
- (mapcar #'(lambda (line) (subseq line 4))
- data-lines))))
- (when success
- (setf (connection-transaction-state *connection*) new-state))
- (list success data code answer)))))))))
-
-(defun send-request (request)
- (with-current-connection
- (process-request request)))
-
-(defparameter +block-commands+
- '(("speak")
- ("sound_icon")
- ("char")
- ("key")
- ("quit")
- ("block" ("end"))
- ("set" ("self" ("rate" "pitch" "voice" "language")))))
-
-(defun block-command-p (command &optional allowed)
- (unless allowed
- (setq allowed +block-commands+))
- (let* ((match (assoc (first command) allowed :test #'string-equal))
- (rest-allowed (cdr match)))
- (and match
- (or (not rest-allowed)
- (block-command-p (rest command) rest-allowed)))))
-
-(defun send-command (command &optional (transaction-state '(nil nil)))
- (unless (listp command)
- (setq command (list command)))
- (with-current-connection
- (setf (connection-last-command *connection*) command)
- (when (or (not (connection-in-block *connection*))
- (block-command-p command))
- (send-request
- (make-request
- :string (format nil "~{~A~^ ~}~A~A" command #\Return #\Linefeed)
- :transaction-state transaction-state)))))
-
-(defun send-data-begin ()
- (send-command "SPEAK" '(nil in-data)))
-
-(defun send-data (text)
- (let ((text* text))
- (flet ((send (string)
- (unless (string= string "")
- (send-request (make-request
- :string string
- :transaction-state '(in-data in-data))))))
- (loop with eol = (format nil "~A~A" #\Return #\Linefeed)
- for length = (length text*)
- for nlpos = (or (position #\Linefeed text*) length)
- for dotted = (and (> (length text*) 0)
- (char= (char text* 0) #\.))
- until (string= text* "")
- do (progn
- (when dotted
- (send "."))
- (send (subseq text* 0 nlpos))
- (send eol)
- (setq text* (subseq text* (min (1+ nlpos) length))))))))
-
-(defun send-data-end ()
- (send-command "." '(in-data nil)))
-
-
-;;; Value retrieval functions
-
-
-(defun list-values (parameter)
- (second (send-command
- (list "LIST" (cdr (assoc parameter +list-parameter-names+))))))
-
-
-;;; Parameter setting functions
-
-
-(defun convert-numeric (number)
- (cond ((< number -100) -100)
- ((> number 100) 100)
- (t number)))
-
-(defun transform-parameter-value (parameter value)
- (cond
- ((stringp value)
- value)
- ((integerp value)
- (format nil "~D" (convert-numeric value)))
- ((symbolp value)
- (cdr (assoc value
- (cdr (assoc parameter +parameter-value-mappings+)))))))
-
-(defun set-parameter (parameter value)
- (with-current-connection
- (let* ((plist (connection-parameters *connection*))
- (orig-value (if (plist-member plist parameter)
- (plist-get plist parameter)
- 'unknown)))
- (when (or (member parameter +volatile-parameters+)
- (and (not (equal orig-value value))
- (or (not (eq parameter 'message-priority))
- (not (connection-forced-priority *connection*)))))
- (let ((answer
- (send-command
- (let ((p (cdr (assoc parameter +parameter-names+)))
- (v (transform-parameter-value parameter value)))
- (unless p
- (error "Invalid parameter name: `~A'" parameter))
- (unless v
- (error "Invalid parameter value: ~A=~A" parameter value))
- (list "SET" "self" p v)))))
- (setq *connection* (get-connection))
- (when (first answer)
- (setf (connection-parameters *connection*)
- (plist-put (connection-parameters *connection*)
- parameter value))))))))
-
-(defun set-connection-name (name)
- (set-parameter
- 'client-name
- (format nil "~A:~A:~A" (user-login-name) *application-name* name)))
-
-(defun set-language (language)
- "Set language of the current client connection to LANGUAGE.
-Language must be an RFC 1766 language code, as a string."
- (set-parameter 'language language)
- (setq *language* language))
-
-
-;;; Blocks
-
-
-(defmacro with-block (parameters &rest body)
- "Set PARAMETERS and enclose BODY by an SSIP block.
-Before invoking BODY, the BLOCK BEGIN command is sent, and the BLOCK END
-command is sent afterwards.
-PARAMETERS is a property list defining parameters to be set before sending the
-BLOCK BEGIN command. The property-value pairs correspond to the arguments of
-the `set-parameter' function."
- `(with-current-connection
- (with-connection-parameters ,parameters
- (if (and *connection* (connection-in-block *connection*))
- (progn , at body)
- (let ((block-connection *connection*))
- (send-command '("BLOCK BEGIN"))
- (unwind-protect
- (progn
- (with-current-connection
- (when *connection*
- (setf (connection-in-block *connection*) t)))
- , at body)
- (let ((*connection* block-connection))
- (when *connection*
- (setf (connection-in-block *connection*) nil)
- (let ((*client-name*
- (connection-name *connection*)))
- (send-command '("BLOCK END")))))))))))
-
-
-;;; Speaking functions
-
-
-(defun say-text (text &key (priority *default-text-priority*))
- "Speak the given TEXT, represented by a string.
-The key argument `priority' defines the priority of the message and must be one
-of the symbols `important', `message', `text', `notification' or
-`progress'."
- (set-parameter 'message-priority priority)
- (unless (string= text "")
- (send-data-begin)
- (send-data text)
- (send-data-end)))
-
-(defun say-sound (name &key (priority *default-sound-priority*))
- "Play an auditory icon.
-NAME is the name of the icon, any string acceptable by speechd.
-The key argument `priority' defines the priority of the message and must be one
-of the symbols `important', `message', `text', `notification' or
-`progress'."
- (set-parameter 'message-priority priority)
- (send-command (list "SOUND_ICON" name)))
-
-(defun say-char (char &key (priority *default-char-priority*))
- "Speak the given CHAR, any UTF-8 character.
-The key argument `priority' defines the priority of the message and must be one
-of the symbols `important', `message', `text', `notification' or
-`progress'."
- (set-parameter 'message-priority priority)
- (with-current-connection
- (with-connection-parameters `(language ,*language*)
- (send-command
- (list "CHAR" (format nil "~A" (case char
- (? "space")
- (?\n "linefeed")
- (t (format nil "~A" char)))))))))
-
-
-;;; Control functions
-
-
-(defun control-command (command all &optional repeatable)
- (cond
- ((not all)
- (when (or repeatable
- (not (equal (first (connection-last-command (get-connection)))
- command)))
- (send-command (list command "self"))))
- ((numberp all)
- (iterate-clients (control-command command nil)))
- (t
- (send-command (list command "all")))))
-
-(defun cancel (&optional all)
- "Stop speaking all the messages sent through the current client so far.
-If the universal argument is given, stop speaking messages of all clients.
-If a numeric argument is given, stop speaking messages of all current Emacs
-session clients."
- (control-command "CANCEL" all))
-
-(defun stop (&optional all)
- "Stop speaking the currently spoken message (if any) of this client.
-If the optional argument ALL is non-nil, stop speaking the currently spoken
-messages of all clients."
- (control-command "STOP" all t))
-
-(defun pause (&optional all)
- "Pause speaking in the current client.
-If the optional argument ALL is non-nil, pause speaking in all clients."
- (if all
- (iterate-connections
- (setf (connection-paused-p *connection*) t))
- (setf (connection-paused-p (get-connection)) t))
- (control-command "PAUSE" (not (not all))))
-
-(defun resume (&optional all)
- "Resume previously stopped speaking in the current client.
-If the optional argument ALL is non-nil, resume speaking messages of all
-clients."
- (when (or all (connection-paused-p (get-connection)))
- (control-command "RESUME" (not (not all)))
- (if all
- (setf (connection-paused-p (get-connection)) nil)
- (iterate-connections
- (setf (connection-paused-p *connection*) nil)))))
diff --git a/src/cl/sysdep.lisp b/src/cl/sysdep.lisp
deleted file mode 100644
index 5232986..0000000
--- a/src/cl/sysdep.lisp
+++ /dev/null
@@ -1,54 +0,0 @@
-;;; System dependent functions
-
-;; Author: Milan Zamazal <pdm at brailcom.org>
-
-;; Copyright (C) 2004 Brailcom, o.p.s.
-
-;; COPYRIGHT NOTICE
-
-;; This program is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2 of the License, or
-;; (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful, but
-;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
-;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
-;; for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program; if not, write to the Free Software
-;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA.
-
-
-(in-package :ssip)
-
-
-(defun getenv (var)
- #+SBCL
- (sb-ext:posix-getenv var)
- #+CLISP
- (ext:getenv var))
-
-
-#+CLISP
-(defparameter +encoding+
- (ext:make-encoding :charset 'charset:utf-8 :line-terminator :unix))
-
-(defun open-network-stream (host port)
- #+CLISP
- (socket:socket-connect port host :external-format +encoding+)
- #+SBCL
- (let ((s (make-instance 'sb-bsd-sockets:inet-socket :type :stream
- :protocol :tcp)))
- (sb-bsd-sockets:socket-connect
- s
- (sb-bsd-sockets:host-ent-address (sb-bsd-sockets:get-host-by-name host))
- port)
- (sb-bsd-sockets:socket-make-stream s :input t :output t :buffering :none))
- )
-
-(defun close-network-stream (stream)
- #+(or SBCL CLISP)
- (close stream))
-
--
1.7.2.2
- [PATCH 1/6] move src/c/clients to src/clients, william hubbs, 2010/09/15
- [PATCH 3/6] move src/cl to src/api/cl,
william hubbs <=
- [PATCH 4/6] move src/guile to src/api/guile, william hubbs, 2010/09/15
- [PATCH 6/6] remove DIST_SUBDIRS line from src/Makefile.am, william hubbs, 2010/09/15
- [PATCH 2/6] move src/c/api to src/api/c, william hubbs, 2010/09/15
- [PATCH 5/6] move src/python to src/api/python, william hubbs, 2010/09/15
- [PATCH 1/6] move src/c/clients to src/clients, Andrei Kholodnyi, 2010/09/15