From 09549c33355852fe49a9bc53c90578e63d022418 Mon Sep 17 00:00:00 2001 From: Steve Youngs Date: Sun, 12 Jun 2016 20:21:28 +1000 Subject: [PATCH] Remove old and crusty tooltalk pkg Signed-off-by: Steve Youngs --- package-compile.el | 1 - xemacs-packages/Makefile | 2 +- xemacs-packages/tooltalk/ChangeLog | 73 ------ xemacs-packages/tooltalk/Makefile | 30 --- xemacs-packages/tooltalk/Makefile.XEmacs | 18 -- xemacs-packages/tooltalk/package-info.in | 19 -- xemacs-packages/tooltalk/tooltalk-init.el | 215 ---------------- xemacs-packages/tooltalk/tooltalk-macros.el | 92 ------- xemacs-packages/tooltalk/tooltalk-util.el | 268 -------------------- 9 files changed, 1 insertion(+), 717 deletions(-) delete mode 100644 xemacs-packages/tooltalk/ChangeLog delete mode 100644 xemacs-packages/tooltalk/Makefile delete mode 100644 xemacs-packages/tooltalk/Makefile.XEmacs delete mode 100644 xemacs-packages/tooltalk/package-info.in delete mode 100644 xemacs-packages/tooltalk/tooltalk-init.el delete mode 100644 xemacs-packages/tooltalk/tooltalk-macros.el delete mode 100644 xemacs-packages/tooltalk/tooltalk-util.el diff --git a/package-compile.el b/package-compile.el index 3e3dce4c..6bf83d18 100644 --- a/package-compile.el +++ b/package-compile.el @@ -188,7 +188,6 @@ ("textools" . "xemacs-packages") ("time" . "xemacs-packages") ("tm" . "xemacs-packages") - ("tooltalk" . "xemacs-packages") ("tpu" . "xemacs-packages") ("tramp" . "xemacs-packages") ("vc" . "xemacs-packages") diff --git a/xemacs-packages/Makefile b/xemacs-packages/Makefile index 3fe5647f..13b43e67 100644 --- a/xemacs-packages/Makefile +++ b/xemacs-packages/Makefile @@ -55,7 +55,7 @@ PACKAGES := xemacs-base fsf-compat mail-lib \ prog-modes ps-print psgml psgml-dtds python-modes re-builder \ reftex riece rmail ruby-modes sasl scheme sgml \ sieve slider sml-mode sounds-au sounds-wav strokes \ - supercite textools time tm tooltalk tpu tramp \ + supercite textools time tm tpu tramp \ vc vc-cc vhdl view-process viper vm w3 x-symbol \ xetla xslide xslt-process xwem zenirc else diff --git a/xemacs-packages/tooltalk/ChangeLog b/xemacs-packages/tooltalk/ChangeLog deleted file mode 100644 index ad9fb555..00000000 --- a/xemacs-packages/tooltalk/ChangeLog +++ /dev/null @@ -1,73 +0,0 @@ -2014-05-15 Norbert Koch - - * Makefile (VERSION): XEmacs package 1.17 released. - -2014-05-15 Norbert Koch - - * Makefile (VERSION): XEmacs package 1.16 released. - -2014-05-13 Jerry James - - * .cvsignore: Remove. - * .hgignore: New file. - -2003-10-31 Norbert Koch - - * Makefile (VERSION): XEmacs package 1.15 released. - -2003-09-15 Norbert Koch - - * Makefile (VERSION): XEmacs package 1.14 released. - -2003-03-30 Steve Youngs - - * Makefile (EARLY_GENERATED_LISP): Revert previous change. - -2003-03-22 Steve Youngs - - * Makefile (EARLY_GENERATED_LISP): Explicitly set so we don't try - to build custom-loads, this package doesn't have any. - -2003-03-09 Ben Wing - - * Makefile: - Delete explicit compile:: and binkit: rules. - -2002-11-29 Ben Wing - - * .cvsignore: Remove files now handled automatically by CVS. - * Makefile: Use `compile' instead of hard-coded `all'. - -2002-10-15 Ville Skyttä - - * Makefile (srckit): Remove. - -2000-10-05 Martin Buchholz - - * *: Mega typo fix. - -1998-07-25 SL Baur - - * dumped-lisp.el: removed. - -1998-07-18 SL Baur - - * dumped-lisp.el: Elimination of Lisp read-time macros. - -1998-01-24 SL Baur - - * Makefile (VERSION): Update to package standard 1.0. - * package-info.in: Ditto. - -1998-01-11 SL Baur - - * Makefile (VERSION): Update to newer package interface. - -1998-01-04 SL Baur - - * dumped-lisp.el: New file from standard dumped-lisp.el. - -1997-12-21 SL Baur - - * Makefile: Created. - diff --git a/xemacs-packages/tooltalk/Makefile b/xemacs-packages/tooltalk/Makefile deleted file mode 100644 index 19d8fb6b..00000000 --- a/xemacs-packages/tooltalk/Makefile +++ /dev/null @@ -1,30 +0,0 @@ -# Makefile for tooltalk lisp code - -# This file is part of XEmacs. - -# XEmacs 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, or (at your option) any -# later version. - -# XEmacs 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 XEmacs; see the file COPYING. If not, write to -# the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -# Boston, MA 02111-1307, USA. - -VERSION = 1.17 -AUTHOR_VERSION = -MAINTAINER = XEmacs Development Team -PACKAGE = tooltalk -PKG_TYPE = regular -REQUIRES = -CATEGORY = standard - -ELCS = tooltalk-init.elc tooltalk-macros.elc tooltalk-util.elc - -include ../../XEmacs.rules diff --git a/xemacs-packages/tooltalk/Makefile.XEmacs b/xemacs-packages/tooltalk/Makefile.XEmacs deleted file mode 100644 index ef14a273..00000000 --- a/xemacs-packages/tooltalk/Makefile.XEmacs +++ /dev/null @@ -1,18 +0,0 @@ -# @(#)Makefile 1.4 94/04/19 - -EMACS=../../src/xemacs - -TOOLTALK.el = tooltalk-macros.el tooltalk-init.el tooltalk-util.el -TOOLTALK.elc = $(TOOLTALK.el:.el=.elc) - -all: $(TOOLTALK.elc) - -.INIT: tooltalk-load.el $(TOOLTALK.el) - -.SUFFIXES: .elc .el - -.el.elc: - $(EMACS) -batch -q -f batch-byte-compile $(@:.elc=.el) - -clean: - $(RM) $(TOOLTALK.elc) diff --git a/xemacs-packages/tooltalk/package-info.in b/xemacs-packages/tooltalk/package-info.in deleted file mode 100644 index 17ddcd96..00000000 --- a/xemacs-packages/tooltalk/package-info.in +++ /dev/null @@ -1,19 +0,0 @@ -(tooltalk - (standards-version 1.1 - version VERSION - author-version AUTHOR_VERSION - date DATE - build-date BUILD_DATE - maintainer MAINTAINER - distribution xemacs - priority low - category CATEGORY - dump nil - description "Support for building with Tooltalk." - filename FILENAME - md5sum MD5SUM - size SIZE - provides () - requires (REQUIRES) - type regular -)) diff --git a/xemacs-packages/tooltalk/tooltalk-init.el b/xemacs-packages/tooltalk/tooltalk-init.el deleted file mode 100644 index 6eb163b4..00000000 --- a/xemacs-packages/tooltalk/tooltalk-init.el +++ /dev/null @@ -1,215 +0,0 @@ -;;; -*- Mode: Emacs-Lisp -*- -;;; -;;; Registration of the default Tooltalk patterns and handlers. -;;; -;;; @(#)tooltalk-init.el 1.8 94/02/22 - - -(defvar tooltalk-eval-pattern - '(category TT_HANDLE - scope TT_SESSION - op "emacs-eval" - callback tooltalk-eval-handler)) - -(defvar tooltalk-load-file-pattern - '(category TT_HANDLE - scope TT_SESSION - op "emacs-load-file" - args ((TT_IN "file" "string")) - callback tooltalk-load-file-handler)) - -(defvar tooltalk-make-client-frame-pattern - '(category TT_HANDLE - scope TT_SESSION - op "emacs-make-client-screen" - callback tooltalk-make-client-frame-handler)) - -(defvar tooltalk-status-pattern - '(category TT_HANDLE - scope TT_SESSION - op "emacs-status" - callback tooltalk-status-handler)) - - -(defvar initial-tooltalk-patterns ()) - -(defun dispatch-initial-tooltalk-message (m) - (let ((op (get-tooltalk-message-attribute m 'op)) - (patterns initial-tooltalk-patterns)) - (if (stringp op) - (while patterns - (let ((p (car patterns))) - (if (eq (intern op) (tooltalk-pattern-prop-get p 'opsym)) - (let ((callback (tooltalk-pattern-prop-get p 'callback))) - (if callback (funcall callback m p)) - (setq patterns '())) - (setq patterns (cdr patterns)))))))) - -(defun make-initial-tooltalk-pattern (args) - (let ((opcdr (cdr (memq 'op args))) - (cbcdr (cdr (memq 'callback args)))) - (if (and (consp opcdr) (consp cbcdr)) - (let ((plist (list 'opsym (intern (car opcdr)) 'callback (car cbcdr)))) - (make-tooltalk-pattern (append args (list 'plist plist)))) - (make-tooltalk-pattern args)))) - -(defun register-initial-tooltalk-patterns () - (mapcar #'register-tooltalk-pattern - (setq initial-tooltalk-patterns - (mapcar #'make-initial-tooltalk-pattern - (list tooltalk-eval-pattern - tooltalk-load-file-pattern - tooltalk-make-client-frame-pattern - tooltalk-status-pattern)))) - (add-hook 'tooltalk-unprocessed-message-hook 'dispatch-initial-tooltalk-message)) - - -(defun unregister-initial-tooltalk-patterns () - (mapcar 'destroy-tooltalk-pattern initial-tooltalk-patterns) - (setq initial-tooltalk-patterns ()) - (remove-hook 'tooltalk-unprocessed-message-hook 'dispatch-initial-tooltalk-message)) - - -(defun tooltalk:prin1-to-string (form) - "Like prin1-to-string except: if the string contains embedded nulls (unlikely -but possible) then replace each one with \"\\000\"." - (let ((string (prin1-to-string form))) - (let ((parts '()) - index) - (while (setq index (string-match "\0" string)) - (setq parts - (apply 'list "\\000" (substring string 0 index) parts)) - (setq string (substring string (1+ index)))) - (if (not parts) - string - (setq parts (apply 'list string parts)) - (apply 'concat (nreverse parts)))))) - -;; Backwards compatibility -(fset 'tooltalk::prin1-to-string-carefully 'tooltalk:prin1-to-string) - - -(defun tooltalk:read-from-string (str) - "Like read-from-string except: an error is signalled if the entire -string can't be parsed." - (let ((res (read-from-string str))) - (if (< (cdr res) (length str)) - (error "Parse of input string ended prematurely." - str)) - (car res))) - - -(defun tooltalk::eval-string (str) - (let ((result (eval (car (read-from-string str))))) - (tooltalk:prin1-to-string result))) - - -(defun tooltalk-eval-handler (msg pat) - (let ((str (get-tooltalk-message-attribute msg 'arg_val 0)) - (result-str nil) - (failp t)) - (unwind-protect - (cond - ;; Assume That the emacs debugger will handle errors. - ;; If the user throws from the debugger to the cleanup - ;; form below, failp will remain t. - (debug-on-error - (setq result-str (tooltalk::eval-string str) - failp nil)) - - ;; If an error occurs as a result of evaluating - ;; the string or printing the result, then we'll return - ;; a string version of error-info. - (t - (condition-case error-info - (setq result-str (tooltalk::eval-string str) - failp nil) - (error - (let ((error-str (tooltalk:prin1-to-string error-info))) - (setq result-str error-str - failp t)))))) - - ;; If we get to this point and result-str is still nil, the - ;; user must have thrown out of the debugger - (let ((reply-type (if failp 'fail 'reply)) - (reply-value (or result-str "(debugger exit)"))) - (set-tooltalk-message-attribute reply-value msg 'arg_val 0) - (return-tooltalk-message msg reply-type))))) - - -(defun tooltalk-make-client-frame-handler (m p) - (let ((nargs (get-tooltalk-message-attribute m 'args_count))) - (if (not (= 3 nargs)) - (progn - (set-tooltalk-message-attribute "wrong number of arguments" m 'status_string) - (return-tooltalk-message m 'fail)))) - - ;; Note: relying on the fact that arg_ival is returned as a string - - (let* ((name (get-tooltalk-message-attribute m 'arg_val 0)) - (window (get-tooltalk-message-attribute m 'arg_ival 1)) - (args (list (cons 'name name) (cons 'window-id window))) - (frame (make-frame args))) - (set-tooltalk-message-attribute (frame-name frame) m 'arg_val 2) - (return-tooltalk-message m 'reply))) - - - -(defun tooltalk-load-file-handler (m p) - (let ((path (get-tooltalk-message-attribute m 'file))) - (condition-case error-info - (progn - (load-file path) - (return-tooltalk-message m 'reply)) - (error - (let ((error-string (tooltalk:prin1-to-string error-info))) - (set-tooltalk-message-attribute error-string m 'status_string) - (return-tooltalk-message m 'fail)))))) - - -(defun tooltalk-status-handler (m p) - (return-tooltalk-message m 'reply)) - - -;; Hack the command-line. - -(defun command-line-do-tooltalk (arg) - "Connect to the ToolTalk server." -; (setq command-line-args-left -; (cdr (tooltalk-open-connection (cons (car command-line-args) -; command-line-args-left)))) - (if (tooltalk-open-connection) - (register-initial-tooltalk-patterns) - (display-warning 'tooltalk "Warning: unable to connect to a ToolTalk server."))) - -(setq command-switch-alist - (append command-switch-alist - '(("-tooltalk" . command-line-do-tooltalk)))) - -;; Add some selection converters. - -(defun xselect-convert-to-ttprocid (selection type value) - (let* ((msg (create-tooltalk-message)) - (ttprocid (get-tooltalk-message-attribute msg 'sender))) - (destroy-tooltalk-message msg) - ttprocid - )) - -(defun xselect-convert-to-ttsession (selection type value) - (let* ((msg (create-tooltalk-message)) - (ttsession (get-tooltalk-message-attribute msg 'session))) - (destroy-tooltalk-message msg) - ttsession - )) - -(if (boundp 'selection-converter-alist) - (setq selection-converter-alist - (append - selection-converter-alist - '((SPRO_PROCID . xselect-convert-to-ttprocid) - (SPRO_SESSION . xselect-convert-to-ttsession) - ))) - (setq selection-converter-alist - '((SPRO_PROCID . xselect-convert-to-ttprocid) - (SPRO_SESSION . xselect-convert-to-ttsession)))) - diff --git a/xemacs-packages/tooltalk/tooltalk-macros.el b/xemacs-packages/tooltalk/tooltalk-macros.el deleted file mode 100644 index a50d0c52..00000000 --- a/xemacs-packages/tooltalk/tooltalk-macros.el +++ /dev/null @@ -1,92 +0,0 @@ -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Date: Wed Dec 16 17:40:58 1992 -;;; File: tooltalk-macros.el -;;; Title: Useful macros for ToolTalk/elisp interface -;;; SCCS: @(#)tooltalk-macros.el 1.5 21 Jan 1993 19:09:24 -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defmacro destructuring-bind-tooltalk-message (variables - args-count - message - &rest body) - " -arglist: (variables args-count message &rest body) - -Binds VARIABLES to the ARG_VALs and ARG_IVALs of MESSAGE, -starting from N = 0, and executes BODY in that context. -Binds actual number of message args to ARGS-COUNT. - -VARIABLES is a list of local variables to bind. -Each item in VARIABLES is either nil, a symbol, or a list of the form: - - (symbol type) - -If the item is nil, the nth ARG_VAL or ARG_IVAL of MESSAGE is skipped. -If the item is a symbol, the nth ARG_VAL of MESSAGE is bound. -If the item is a list - If type = \"int\" the nth ARG_IVAL of MESSAGE is bound, - otherwise the nth ARG_VAL of MESSAGE is bound. - -If there are more items than actual arguments in MESSAGE, the extra -items are bound to nil. - -For example, - -(destructuring-bind-tooltalk-message (a (b \"int\") nil d) foo msg - x y z) - -expands to - -(let* ((foo (get-tooltalk-message-attribute msg 'args_count)) - (a (if (< 0 foo) - (get-tooltalk-message-attribute msg 'arg_val 0))) - (b (if (< 1 foo) - (get-tooltalk-message-attribute msg 'arg_val 1))) - (d (if (< 3 foo) - (get-tooltalk-message-attribute msg 'arg_val 3)))) - x y z) - -See GET-TOOLTALK-MESSAGE-ATTRIBUTE for more information. -" - (let* ((var-list variables) - (nargs args-count) - (msg message) - (n -1) - var-item - var - type - request - bindings) - (setq bindings (cons - (list nargs - (list - 'get-tooltalk-message-attribute - msg - ''args_count)) - bindings)) - (while var-list - (setq var-item (car var-list) - var-list (cdr var-list)) - (if (eq 'nil var-item) - (setq n (1+ n)) - (progn - (if (listp var-item) - (setq var (car var-item) - type (car (cdr var-item))) - (setq var var-item - type "string")) - (setq n (1+ n)) - (setq request (list - 'get-tooltalk-message-attribute - msg - (if (equal "int" type) - ''arg_ival - ''arg_val) - n)) - (setq bindings (cons - (list var - (list 'if - (list '< n nargs) - request)) - bindings))))) - (nconc (list 'let* (nreverse bindings)) body))) diff --git a/xemacs-packages/tooltalk/tooltalk-util.el b/xemacs-packages/tooltalk/tooltalk-util.el deleted file mode 100644 index f8e4e489..00000000 --- a/xemacs-packages/tooltalk/tooltalk-util.el +++ /dev/null @@ -1,268 +0,0 @@ -;;; -*- Mode: Emacs-Lisp -*- -;;; -;;; Emacs Tooltalk Utility Functions -;;; -;;; @(#)tooltalk-util.el 1.7 93/12/07 - - -(defun initialize-tooltalk-message-arg (msg n mode value vtype) - "Initialize the Nth tooltalk message argument of MSG. -A new argument is created if necessary. No attempt to distinguish -between strings that contain binary data and ordinary strings is made; -all non integer argument values are converted to a string (if not a -string already) and loaded with tt_message_arg_val_set(). -Applications that need to put binary data into a ToolTalk message -argument should initialize the argument with: - - (set-tooltalk-message-attribute bin-string msg 'arg_bval arg-n)" - (let ((n-args-needed - (- (1+ n) (get-tooltalk-message-attribute msg 'args_count)))) - (while (> n-args-needed 0) - (add-tooltalk-message-arg msg mode vtype) - (setq n-args-needed (1- n-args-needed)))) - - (cond - ((integerp value) - (set-tooltalk-message-attribute value msg 'arg_ival n)) - ((stringp value) - (set-tooltalk-message-attribute value msg 'arg_val n)) - (t - (error "The value specified for msg %s argument %d, %s, must be a string or an integer" - (prin1-to-string msg) - n - (prin1-to-string value))))) - - - -(defconst tooltalk-arg-mode-ids - (list 'TT_IN 'TT_OUT 'TT_INOUT TT_IN TT_OUT TT_INOUT)) - -(defun initialize-tooltalk-message/pattern-args (initfn msg args) - "Apply INITFN to each the position mode value and type of -each argument in the list. The value of INITFN should be either -'initialize-tooltalk-message-arg or 'initialize-tooltalk-pattern-arg. -See `make-tooltalk-message' for a description of how arguments are specified. -We distinguish the short form for arguments, e.g. \"just-a-value\", -from the long form by checking to see if the argument is a list whose -car is one of the ToolTalk mode values like TT_INOUT." - (let ((n 0)) - (while args - (let* ((arg (car args)) - (long-form - (and (consp arg) - (member (car arg) tooltalk-arg-mode-ids))) - (mode - (if long-form (car arg) TT_IN)) - (value - (cond - ((not long-form) arg) - ((cdr arg) (car (cdr arg))) - (t ""))) - (type - (cond - ((and long-form - (cdr (cdr arg)) - (stringp (car (cdr (cdr arg))))) - (car (cdr (cdr arg)))) - ((integerp value) "int") - (t "string")))) - (funcall initfn msg n mode value type)) - (setq args (cdr args)) - (setq n (1+ n))))) - - -(defun initialize-tooltalk-message-attributes (msg attributes) - "Initialize the tooltalk message attributes. The value of -attributes must be a property list in the same form as for -make-tooltalk-message. This function can be used to reset -an existing message or to initialize a new one. See -initialize-tooltalk-message-args for a description of how -arguments are initialized." - (let ((args attributes) - (initfn 'initialize-tooltalk-message-arg)) - (while (and args (cdr args)) - (let ((indicator (car args)) - (value (car (cdr args)))) - (if (eq indicator 'args) - (initialize-tooltalk-message/pattern-args initfn msg value) - (set-tooltalk-message-attribute value msg indicator))) - (setq args (cdr (cdr args)))))) - - -(defun make-tooltalk-message (attributes &optional no-callback) - "Create a tooltalk message and initialize its attributes. -The value of attributes must be a list of alternating keyword/values, -where keywords are symbols that name valid message attributes. -For example: - - (make-tooltalk-message - '(class TT_NOTICE - scope TT_SESSION - address TT_PROCEDURE - op \"do-something\" - args (\"arg1\" 12345 (TT_INOUT \"arg3\" \"string\")))) - -Values must always be strings, integers, or symbols that -represent Tooltalk constants. Attribute names are the same as -those supported by set-tooltalk-message-attribute, plus 'args. - -The value of args should be a list of message arguments where -each message argument has the following form: - - (mode [value [type]]) or just value - -Where mode is one of TT_IN, TT_OUT, TT_INOUT and type is a string. -If type isn't specified then \"int\" is used if the value is a -number otherwise \"string\" is used. If only a value is specified -then mode defaults to TT_IN. If mode is TT_OUT then value and -type don't need to be specified. You can find out more about the -semantics and uses of ToolTalk message arguments in chapter 4 of the -Tooltalk Programmer's Guide. - -The no-callback arg is a hack to prevent the registration of the -C-level callback. This hack is needed by the current SPARCworks -tool startup mechanism. Yucko." - (let ((msg (create-tooltalk-message no-callback))) - (initialize-tooltalk-message-attributes msg attributes) - msg)) - - -(defun describe-tooltalk-message (msg &optional stream) - "Print tooltalk message MSG's attributes and arguments to STREAM. -This is often useful for debugging." - (let ((attrs - '(address - class - disposition - file - gid - handler - handler_ptype - object - op - opnum - otype - scope - sender - sender_ptype - session - state - status - status_string - uid - callback))) - (terpri stream) - (while attrs - (princ (car attrs) stream) - (princ " " stream) - (prin1 (get-tooltalk-message-attribute msg (car attrs)) stream) - (terpri stream) - (setq attrs (cdr attrs)))) - - (let ((n (get-tooltalk-message-attribute msg 'args_count)) - (i 0)) - (while (< i n) - (princ "Argument " stream) - (princ i stream) - (princ " " stream) - (let ((type (get-tooltalk-message-attribute msg 'arg_type i))) - (princ - (prin1-to-string - (list - (get-tooltalk-message-attribute msg 'arg_mode i) - (if (equal type "int") - (get-tooltalk-message-attribute msg 'arg_ival i) - (get-tooltalk-message-attribute msg 'arg_val i)) - type)) - stream)) - (terpri stream) - (setq i (1+ i))))) - - -(defun initialize-tooltalk-pattern-arg (pat n mode value vtype) - "Add one argument to tooltalk pattern PAT. -No support for specifying pattern arguments whose value is a vector -of binary data is provided." - (let ((converted-value - (if (or (integerp value) (stringp value)) - value - (prin1-to-string value)))) - (add-tooltalk-pattern-arg pat mode vtype converted-value))) - - -(defun initialize-tooltalk-pattern-attributes (pat attributes) - "Initialize tooltalk pattern PAT's attributes. -ATTRIBUTES must be a property list in the same form as for -`make-tooltalk-pattern'. The value of each attribute (except 'category) -can either be a single value or a list of values. If a list of -values is provided then the pattern will match messages with -a corresponding attribute that matches any member of the list. - -This function can be used to add attribute values to an existing -pattern or to initialize a new one. See -`initialize-tooltalk-message/pattern-args' for a description of how -arguments are initialized." - (let ((args attributes) - (initfn 'initialize-tooltalk-pattern-arg)) - (while (and args (cdr args)) - (let ((indicator (car args)) - (value (car (cdr args)))) - (cond - ((eq indicator 'args) - (initialize-tooltalk-message/pattern-args initfn pat value)) - ((eq indicator 'plist) - (let ((values value)) - (while values - (let ((prop (car values)) - (propval (car (cdr values)))) - (tooltalk-pattern-prop-set pat prop propval)) - (setq values (cdr (cdr values)))))) - ((consp value) - (let ((values value)) - (while values - (add-tooltalk-pattern-attribute (car values) pat indicator) - (setq values (cdr values))))) - (t - (add-tooltalk-pattern-attribute value pat indicator)))) - (setq args (cdr (cdr args)))))) - - - -(defun make-tooltalk-pattern (attributes) - "Create a tooltalk pattern and initialize its attributes. -The value of attributes must be a list of alternating keyword/values, -where keywords are symbols that name valid pattern attributes -or lists of valid attributes. For example: - - (make-tooltalk-pattern - '(category TT_OBSERVE - scope TT_SESSION - op (\"operation1\" \"operation2\") - args (\"arg1\" 12345 (TT_INOUT \"arg3\" \"string\")))) - - -Values must always be strings, integers, or symbols that -represent Tooltalk constants or lists of same. When a list -of values is provided all of the list elements are added to -the attribute. In the example above, messages whose op -attribute is \"operation1\" or \"operation2\" would match the pattern. - -The value of args should be a list of pattern arguments where -each pattern argument has the following form: - - (mode [value [type]]) or just value - -Where mode is one of TT_IN, TT_OUT, TT_INOUT and type is a string. -If type isn't specified then \"int\" is used if the value is a -number otherwise \"string\" is used. If only a value is specified -then mode defaults to TT_IN. If mode is TT_OUT then value and type -don't need to be specified. You can find out more about the semantics -and uses of ToolTalk pattern arguments in chapter 3 of the Tooltalk -Programmers Guide. -" - (let ((pat (create-tooltalk-pattern))) - (initialize-tooltalk-pattern-attributes pat attributes) - pat)) - - - -- 2.25.1