src/attribute-test.lisp

(in-package :lol-test)

(in-suite lisp-on-lines)

(deftest test-attribute-value ()
  (eval
   '(progn
     (define-description attribute-test-description ()
       ((attribute-1 :value "VALUE")
	(attribute-2 :function (constantly "VALUE"))))

     (deflayer attribute-test)

     (define-description attribute-test-description ()
       ((attribute-1 :value "VALUE2")
	(attribute-2 :function (constantly "VALUE2")))
       (:in-layer . attribute-test))))

  (let ((d (find-description 'attribute-test-description)))
    (dletf (((described-object d) nil))
    (is (equalp "VALUE" (slot-value (find-attribute d 'attribute-1) 'lol::value)))

    (with-active-layers (attribute-test)
      (is (equalp (attribute-value (find-attribute d 'attribute-1))
		  (attribute-value (find-attribute d 'attribute-2))))
      (is (equalp "VALUE2" (attribute-value (find-attribute d 'attribute-1))))))))

(deftest test-attribute-property-inheriting ()
  (test-attribute-value)
  (eval '(progn
	  (deflayer attribute-property-test)
	  (define-description attribute-test-description ()
	    ((attribute-1 :label "attribute1")
	     (attribute-2 :label "attribute2"))
	    (:in-layer . attribute-property-test))))
  (with-active-layers (attribute-property-test)
    (let ((d (find-description 'attribute-test-description)))
      (dletf (((described-object d) nil))

	(is (equalp "VALUE" (slot-value (find-attribute d 'attribute-1) 'lol::value)))

	(is (equalp "attribute1" (attribute-label (find-attribute d 'attribute-1))))
	(is (equalp "attribute2" (attribute-label (find-attribute d 'attribute-2))))


	(with-active-layers (attribute-test)
	  (is (equalp (attribute-value (find-attribute d 'attribute-1))
		      (attribute-value (find-attribute d 'attribute-2))))
	  (is (equalp "VALUE2" (attribute-value (find-attribute d 'attribute-1)))))))))

(deftest (test-attribute-with-different-class :compile-before-run t) ()
  (eval '(progn
;;;; We cannot ever redefine this class ic think...
;;; as attributes are also slot meta-objects.


	  (define-layered-class
		test-attribute-class (lol::standard-attribute)
		((some-slot :initarg :some-slot
			    :layered t
			    :layered-accessor some-slot)))

	  (define-description test-attribute-with-different-class-description ()
	    ((attribute-with-different-class :attribute-class test-attribute-class :some-slot "BRILLANT!")))))

  (let* ((d (find-description 'test-attribute-with-different-class-description))

	 (a (find-attribute d 'attribute-with-different-class)))
    (is (eq (class-of a)
	    (find-class 'test-attribute-class)))
    (is (equalp "BRILLANT!" (some-slot a)))))
Commit	Line	Data
	1	(in-package :lol-test)
	2
	3	(in-suite lisp-on-lines)
	4
	5	(deftest test-attribute-value ()
	6	(eval
	7	'(progn
	8	(define-description attribute-test-description ()
	9	((attribute-1 :value "VALUE")
	10	(attribute-2 :function (constantly "VALUE"))))
	11
	12	(deflayer attribute-test)
	13
	14	(define-description attribute-test-description ()
	15	((attribute-1 :value "VALUE2")
	16	(attribute-2 :function (constantly "VALUE2")))
	17	(:in-layer . attribute-test))))
	18
	19	(let ((d (find-description 'attribute-test-description)))
	20	(dletf (((described-object d) nil))
	21	(is (equalp "VALUE" (slot-value (find-attribute d 'attribute-1) 'lol::value)))
	22
	23	(with-active-layers (attribute-test)
	24	(is (equalp (attribute-value (find-attribute d 'attribute-1))
	25	(attribute-value (find-attribute d 'attribute-2))))
	26	(is (equalp "VALUE2" (attribute-value (find-attribute d 'attribute-1))))))))
	27
	28	(deftest test-attribute-property-inheriting ()
	29	(test-attribute-value)
	30	(eval '(progn
	31	(deflayer attribute-property-test)
	32	(define-description attribute-test-description ()
	33	((attribute-1 :label "attribute1")
	34	(attribute-2 :label "attribute2"))
	35	(:in-layer . attribute-property-test))))
	36	(with-active-layers (attribute-property-test)
	37	(let ((d (find-description 'attribute-test-description)))
	38	(dletf (((described-object d) nil))
	39
	40	(is (equalp "VALUE" (slot-value (find-attribute d 'attribute-1) 'lol::value)))
	41
	42	(is (equalp "attribute1" (attribute-label (find-attribute d 'attribute-1))))
	43	(is (equalp "attribute2" (attribute-label (find-attribute d 'attribute-2))))
	44
	45
	46	(with-active-layers (attribute-test)
	47	(is (equalp (attribute-value (find-attribute d 'attribute-1))
	48	(attribute-value (find-attribute d 'attribute-2))))
	49	(is (equalp "VALUE2" (attribute-value (find-attribute d 'attribute-1)))))))))
	50
	51	(deftest (test-attribute-with-different-class :compile-before-run t) ()
	52	(eval '(progn
	53	;;;; We cannot ever redefine this class ic think...
	54	;;; as attributes are also slot meta-objects.
	55
	56
	57	(define-layered-class
	58	test-attribute-class (lol::standard-attribute)
	59	((some-slot :initarg :some-slot
	60	:layered t
	61	:layered-accessor some-slot)))
	62
	63	(define-description test-attribute-with-different-class-description ()
	64	((attribute-with-different-class :attribute-class test-attribute-class :some-slot "BRILLANT!")))))
	65
	66	(let* ((d (find-description 'test-attribute-with-different-class-description))
	67
	68	(a (find-attribute d 'attribute-with-different-class)))
	69	(is (eq (class-of a)
	70	(find-class 'test-attribute-class)))
	71	(is (equalp "BRILLANT!" (some-slot a)))))
	72
	73
	74
	75
	76
	77
	78