cgit.sxemacs.org Git - packages/blob - xemacs-packages/tooltalk/tooltalk-util.el

   1 ;;; -*- Mode: Emacs-Lisp -*-
   2 ;;;
   3 ;;; Emacs Tooltalk Utility Functions
   4 ;;;
   5 ;;; @(#)tooltalk-util.el 1.7 93/12/07
   6
   7
   8 (defun initialize-tooltalk-message-arg (msg n mode value vtype)
   9   "Initialize the Nth tooltalk message argument of MSG.
  10 A new argument is created if necessary.  No attempt to distinguish
  11 between strings that contain binary data and ordinary strings is made;
  12 all non integer argument values are converted to a string (if not a
  13 string already) and loaded with tt_message_arg_val_set().
  14 Applications that need to put binary data into a ToolTalk message
  15 argument should initialize the argument with:
  16
  17    (set-tooltalk-message-attribute bin-string msg 'arg_bval arg-n)"
  18   (let ((n-args-needed
  19          (- (1+ n) (get-tooltalk-message-attribute msg 'args_count))))
  20     (while (> n-args-needed 0)
  21       (add-tooltalk-message-arg msg mode vtype)
  22       (setq n-args-needed (1- n-args-needed))))
  23
  24   (cond
  25    ((integerp value)
  26     (set-tooltalk-message-attribute value msg 'arg_ival n))
  27    ((stringp value)
  28     (set-tooltalk-message-attribute value msg 'arg_val n))
  29    (t
  30     (error "The value specified for msg %s argument %d, %s, must be a string or an integer"
  31            (prin1-to-string msg)
  32            n
  33            (prin1-to-string value)))))
  34
  35
  36
  37 (defconst tooltalk-arg-mode-ids
  38   (list 'TT_IN 'TT_OUT 'TT_INOUT TT_IN TT_OUT TT_INOUT))
  39
  40 (defun initialize-tooltalk-message/pattern-args (initfn msg args)
  41   "Apply INITFN to each the position mode value and type of
  42 each argument in the list.  The value of INITFN should be either
  43 'initialize-tooltalk-message-arg or 'initialize-tooltalk-pattern-arg.
  44 See `make-tooltalk-message' for a description of how arguments are specified.
  45 We distinguish the short form for arguments, e.g. \"just-a-value\",
  46 from the long form by checking to see if the argument is a list whose
  47 car is one of the ToolTalk mode values like TT_INOUT."
  48   (let ((n 0))
  49     (while args
  50       (let* ((arg (car args))
  51              (long-form
  52               (and (consp arg)
  53                    (member (car arg) tooltalk-arg-mode-ids)))
  54              (mode
  55               (if long-form (car arg) TT_IN))
  56              (value
  57               (cond
  58                ((not long-form) arg)
  59                ((cdr arg) (car (cdr arg)))
  60                (t "")))
  61              (type
  62               (cond
  63                ((and long-form
  64                      (cdr (cdr arg))
  65                      (stringp (car (cdr (cdr arg)))))
  66                 (car (cdr (cdr arg))))
  67                ((integerp value) "int")
  68                (t "string"))))
  69         (funcall initfn msg n mode value type))
  70       (setq args (cdr args))
  71       (setq n (1+ n)))))
  72
  73
  74 (defun initialize-tooltalk-message-attributes (msg attributes)
  75   "Initialize the tooltalk message attributes.  The value of
  76 attributes must be a property list in the same form as for
  77 make-tooltalk-message.  This function can be used to reset
  78 an existing message or to initialize a new one.  See
  79 initialize-tooltalk-message-args for a description of how
  80 arguments are initialized."
  81   (let ((args attributes)
  82         (initfn 'initialize-tooltalk-message-arg))
  83     (while (and args (cdr args))
  84       (let ((indicator (car args))
  85             (value (car (cdr args))))
  86         (if (eq indicator 'args)
  87             (initialize-tooltalk-message/pattern-args initfn msg value)
  88           (set-tooltalk-message-attribute value msg indicator)))
  89       (setq args (cdr (cdr args))))))
  90
  91
  92 (defun make-tooltalk-message (attributes &optional no-callback)
  93   "Create a tooltalk message and initialize its attributes.
  94 The value of attributes must be a list of alternating keyword/values,
  95 where keywords are symbols that name valid message attributes.
  96 For example:
  97
  98   (make-tooltalk-message
  99     '(class TT_NOTICE
 100       scope TT_SESSION
 101       address TT_PROCEDURE
 102       op \"do-something\"
 103       args (\"arg1\" 12345 (TT_INOUT \"arg3\" \"string\"))))
 104
 105 Values must always be strings, integers, or symbols that
 106 represent Tooltalk constants.  Attribute names are the same as
 107 those supported by set-tooltalk-message-attribute, plus 'args.
 108
 109 The value of args should be a list of message arguments where
 110 each message argument has the following form:
 111
 112    (mode [value [type]]) or just value
 113
 114 Where mode is one of TT_IN, TT_OUT, TT_INOUT and type is a string.
 115 If type isn't specified then \"int\" is used if the value is a
 116 number otherwise \"string\" is used.  If only a value is specified
 117 then mode defaults to TT_IN.  If mode is TT_OUT then value and
 118 type don't need to be specified.  You can find out more about the
 119 semantics and uses of ToolTalk message arguments in chapter 4 of the
 120 Tooltalk Programmer's Guide.
 121
 122 The no-callback arg is a hack to prevent the registration of the
 123 C-level callback.  This hack is needed by the current SPARCworks
 124 tool startup mechanism.  Yucko."
 125   (let ((msg (create-tooltalk-message no-callback)))
 126     (initialize-tooltalk-message-attributes msg attributes)
 127     msg))
 128
 129
 130 (defun describe-tooltalk-message (msg &optional stream)
 131   "Print tooltalk message MSG's attributes and arguments to STREAM.
 132 This is often useful for debugging."
 133   (let ((attrs
 134          '(address
 135            class
 136            disposition
 137            file
 138            gid
 139            handler
 140            handler_ptype
 141            object
 142            op
 143            opnum
 144            otype
 145            scope
 146            sender
 147            sender_ptype
 148            session
 149            state
 150            status
 151            status_string
 152            uid
 153            callback)))
 154     (terpri stream)
 155     (while attrs
 156       (princ (car attrs) stream)
 157       (princ "  " stream)
 158       (prin1 (get-tooltalk-message-attribute msg (car attrs)) stream)
 159       (terpri stream)
 160       (setq attrs (cdr attrs))))
 161
 162   (let ((n (get-tooltalk-message-attribute msg 'args_count))
 163         (i 0))
 164     (while (< i n)
 165       (princ "Argument " stream)
 166       (princ i stream)
 167       (princ "  " stream)
 168       (let ((type (get-tooltalk-message-attribute msg 'arg_type i)))
 169         (princ
 170          (prin1-to-string
 171           (list
 172            (get-tooltalk-message-attribute msg 'arg_mode i)
 173            (if (equal type "int")
 174                (get-tooltalk-message-attribute msg 'arg_ival i)
 175                (get-tooltalk-message-attribute msg 'arg_val i))
 176            type))
 177          stream))
 178       (terpri stream)
 179       (setq i (1+ i)))))
 180
 181
 182 (defun initialize-tooltalk-pattern-arg (pat n mode value vtype)
 183   "Add one argument to tooltalk pattern PAT.
 184 No support for specifying pattern arguments whose value is a vector
 185 of binary data is provided."
 186   (let ((converted-value
 187          (if (or (integerp value) (stringp value))
 188              value
 189            (prin1-to-string value))))
 190     (add-tooltalk-pattern-arg pat mode vtype converted-value)))
 191
 192
 193 (defun initialize-tooltalk-pattern-attributes (pat attributes)
 194   "Initialize tooltalk pattern PAT's attributes.
 195 ATTRIBUTES must be a property list in the same form as for
 196 `make-tooltalk-pattern'.  The value of each attribute (except 'category)
 197 can either be a single value or a list of values.  If a list of
 198 values is provided then the pattern will match messages with
 199 a corresponding attribute that matches any member of the list.
 200
 201 This function can be used to add attribute values to an existing
 202 pattern or to initialize a new one.  See
 203 `initialize-tooltalk-message/pattern-args' for a description of how
 204 arguments are initialized."
 205   (let ((args attributes)
 206         (initfn 'initialize-tooltalk-pattern-arg))
 207     (while (and args (cdr args))
 208       (let ((indicator (car args))
 209             (value (car (cdr args))))
 210         (cond
 211          ((eq indicator 'args)
 212           (initialize-tooltalk-message/pattern-args initfn pat value))
 213          ((eq indicator 'plist)
 214           (let ((values value))
 215             (while values
 216               (let ((prop (car values))
 217                     (propval (car (cdr values))))
 218                 (tooltalk-pattern-prop-set pat prop propval))
 219               (setq values (cdr (cdr values))))))
 220          ((consp value)
 221           (let ((values value))
 222             (while values
 223               (add-tooltalk-pattern-attribute (car values) pat indicator)
 224               (setq values (cdr values)))))
 225          (t
 226           (add-tooltalk-pattern-attribute value pat indicator))))
 227       (setq args (cdr (cdr args))))))
 228
 229
 230
 231 (defun make-tooltalk-pattern (attributes)
 232   "Create a tooltalk pattern and initialize its attributes.
 233 The value of attributes must be a list of alternating keyword/values,
 234 where keywords are symbols that name valid pattern attributes
 235 or lists of valid attributes.  For example:
 236
 237   (make-tooltalk-pattern
 238     '(category TT_OBSERVE
 239       scope TT_SESSION
 240       op (\"operation1\" \"operation2\")
 241       args (\"arg1\" 12345 (TT_INOUT \"arg3\" \"string\"))))
 242
 243
 244 Values must always be strings, integers, or symbols that
 245 represent Tooltalk constants or lists of same.  When a list
 246 of values is provided all of the list elements are added to
 247 the attribute.  In the example above, messages whose op
 248 attribute is \"operation1\" or \"operation2\" would match the pattern.
 249
 250 The value of args should be a list of pattern arguments where
 251 each pattern argument has the following form:
 252
 253    (mode [value [type]]) or just value
 254
 255 Where mode is one of TT_IN, TT_OUT, TT_INOUT and type is a string.
 256 If type isn't specified then \"int\" is used if the value is a
 257 number otherwise \"string\" is used.  If only a value is specified
 258 then mode defaults to TT_IN.  If mode is TT_OUT then value and type
 259 don't need to be specified.  You can find out more about the semantics
 260 and uses of ToolTalk pattern arguments in chapter 3 of the Tooltalk
 261 Programmers Guide.
 262 "
 263   (let ((pat (create-tooltalk-pattern)))
 264     (initialize-tooltalk-pattern-attributes pat attributes)
 265     pat))
 266
 267
 268