IUP

<h2>Attribute Functions</h2>

<h3><a id="attribute"><code><nowiki>(attribute [handle (or/c ihandle? #f)] [name (or/c symbol? string?)]) → (or/c string? #f)</nowiki></code></a></h3>

Gets the value of an attribute. If the handle is <code>#f</code>, a global
attribute is accessed. Attribute values are always returned as strings,
which is the native form in which they are stored.

<h3><a id="attributes"><code><nowiki>(attributes [handle (or/c ihandle? #f)]) → (listof string?)</nowiki></code></a></h3>

Gets a list of all user-defined attributes set on a given handle. If
the handle is <code>#f</code>, the global attributes are examined.

<h3><a id="attribute-set_"><code>
	<nowiki>(attribute-set! [handle (or/c ihandle? #f)] [name (or/c symbol? string?)] [value any/c]) → void?</nowiki><br>
	<nowiki>(set! (attribute [handle (or/c ihandle? #f)] [name (or/c symbol? string?)]) [value any/c]) → void?</nowiki>
</code></a></h3>

Sets the value of an attribute. If the handle is <code>#f</code>, a global

	(foreign-safe-lambda void "IupResetAttribute" ihandle iname/upcase))

(define attribute
  (getter-with-setter
  	(foreign-safe-lambda c-string "IupGetAttribute" ihandle iname/upcase)
  	attribute-set!))

(define attributes
	(foreign-primitive scheme-object ([ihandle handle])
		"int n = IupGetAllAttributes(handle, NULL, 0);"
		"if (n > 0) {"
		"  char **buf = (char **) alloca(n * sizeof(char *));"
		"  if (IupGetAllAttributes(handle, buf, n) == n) {"
		"    int i, m = C_SIZEOF_LIST(n);"
		"    for (i = 0; i < n; ++i) m += C_SIZEOF_STRING(strlen(buf[i]));"
		"    C_word *mrk = C_alloc(m), lst = C_SCHEME_END_OF_LIST;"
		"    for (i = n-1; i >= 0; --i) lst = C_pair(&mrk, C_string2(&mrk, buf[i]), lst);"
		"    C_return(lst);"
		"  }"
		"}"
		"C_return(C_SCHEME_END_OF_LIST);"))

(define handle-name-set!
	(letrec ([handle-set! (foreign-lambda ihandle "IupSetHandle" iname/downcase ihandle)])
		(lambda (handle name)
			(handle-set! (or name (handle-name handle)) (and name handle)))))

(define handle-name
  (getter-with-setter

;; -*- mode: Scheme; tab-width: 2; -*- ;;

(require-library
  lolevel data-structures extras srfi-1 srfi-13 srfi-42 srfi-69 irregex posix)

(module iup-base
	(ihandle->pointer pointer->ihandle ihandle-list->pointer-vector ihandle?
	 istatus->integer integer->istatus
	 iname->string string->iname
	 thread-watchdog iup-version load/led
	 attribute attributes attribute-set! attribute-reset!
	 handle-name handle-name-set! handle-ref
	 main-loop main-loop-step main-loop-level main-loop-exit main-loop-flush
	 callback callback-set!
	 make-constructor-procedure optional-args
	 create destroy! map-peer! unmap-peer!
	 class-name class-type save-attributes!
	 parent parent-dialog sibling

(define attribute
  (getter-with-setter
   (get-ffi-obj
    "IupGetAttribute" libiup
    (_fun [handle : _ihandle/null] [name : _iname/upcase] -> [value : _string/utf-8]))
   attribute-set!))

(define attributes
  (letrec ([get-attributes
            (get-ffi-obj
             "IupGetAllAttributes" libiup
             (_fun [handle : _ihandle/null] [names : (_list o _string/utf-8 n)] [n : _int]
                   -> [n* : _int]
                   -> (values n* names)))])
    (λ (handle)
      (let-values ([(n names) (get-attributes handle 0)])
        (if (zero? n)
            names
            (let-values ([(n names) (get-attributes handle n)])
              names))))))

(define handle-name-set!
  (get-ffi-obj
   "IupSetHandle" libiup
   (_fun (handle name)
         :: [name : _iname/downcase = (or name (handle-name handle))]
         [handle : _ihandle/null = (and name handle)]
         -> [handle : _ihandle/null])))

      (callback-set! watchdog 'action-cb scheme-check-threads)
      (attribute-set! watchdog 'time 500)
      (attribute-set! watchdog 'run #t)
      watchdog)))

(provide
 thread-watchdog iup-version load/led
 attribute attributes attribute-set! attribute-reset!
 handle-name handle-name-set! handle-ref
 main-loop main-loop-step main-loop-level main-loop-exit main-loop-flush
 callback callback-set!
 make-constructor-procedure
 create destroy! map-peer! unmap-peer!
 class-name class-type save-attributes!
 parent parent-dialog sibling