Initial checkin of Pika from heckimp
This commit is contained in:
87
plug-ins/script-fu/test/tests/PDB/bind-args.scm
Normal file
87
plug-ins/script-fu/test/tests/PDB/bind-args.scm
Normal file
@ -0,0 +1,87 @@
|
||||
|
||||
; Test ScriptFu's binding to all Pika C arg types of the PDB
|
||||
|
||||
|
||||
; The PDB procedures called are arbitrary, chosen for the type of their args.
|
||||
|
||||
; The test is only that no error is thrown, not necessarily that the call is effective.
|
||||
|
||||
; Test binding in both directions: args passed and args returned.
|
||||
|
||||
; Testing is not complete, but illustrative of special cases.
|
||||
|
||||
; Testing is not blindly exhaustive of every type declarable for PDB procedures.
|
||||
; Testing is with knowledge of the code.
|
||||
; Only testing representatives for cases in switch statement of scheme-wrapper.c.
|
||||
; For example, the code has a case for GObject that covers most subclasses
|
||||
; of PikaItem, so we only test once, say for PikaLayer.
|
||||
|
||||
; Also, we don't test all primitive types.
|
||||
; We know they are tested drive-by in other tests,
|
||||
; so we don't necessarily test them here.
|
||||
; Int, String, Double, UInt
|
||||
|
||||
; Note that no PDB procedure takes or returns:
|
||||
; gchar (the type for a single character.)
|
||||
; GParam or PikaParam
|
||||
; There is no case in scheme-wrapper.c.
|
||||
|
||||
|
||||
|
||||
; int
|
||||
; float
|
||||
|
||||
; PikaRGB is tested e.g. with Palette
|
||||
; PikaRGBArray is tested e.g.
|
||||
; from palette-get-colormap
|
||||
; to is not tested: not an arg to any PDB proc
|
||||
|
||||
; GStrv string array
|
||||
; from brushes-get-list
|
||||
; to file-gih-save or extension-pika-help
|
||||
; TODO test GStrv to file-gih-save
|
||||
|
||||
; GBytes
|
||||
; from image-get-colormap
|
||||
; to image-set-colormap
|
||||
|
||||
; FloatArray
|
||||
; from pika-context-get-line-dash-pattern
|
||||
; to pika-context-set-line-dash-pattern
|
||||
|
||||
|
||||
; PikaResource
|
||||
; see resource.scm and context.scm
|
||||
|
||||
|
||||
; GFile
|
||||
|
||||
; PikaParasite
|
||||
|
||||
; ScriptFu takes and returns a list of attributes of a PikaParasite
|
||||
; A PikaParasite is a named string having a flags attribute ?
|
||||
; Also tested elsewhere, many objects can have parasites.
|
||||
; This tests the global parasites, on the pika instance.
|
||||
|
||||
; to
|
||||
(assert '(pika-attach-parasite (list "foo" 1 "zed")))
|
||||
; from
|
||||
(assert `(equal? (car (pika-get-parasite "foo"))
|
||||
'("foo" 1 "zed")))
|
||||
|
||||
|
||||
; PikaUnit
|
||||
|
||||
; A PikaUnit is both an enum and an object???
|
||||
; ScriptFu converts to int. More or less an ID.
|
||||
|
||||
; to
|
||||
; unit index 0 is px
|
||||
(assert '(string=? (car (pika-unit-get-abbreviation 0))
|
||||
"px"))
|
||||
|
||||
; from
|
||||
; default line width unit is px
|
||||
(assert '(= (car (pika-context-get-line-width-unit))
|
||||
0))
|
||||
|
||||
93
plug-ins/script-fu/test/tests/PDB/buffer.scm
Normal file
93
plug-ins/script-fu/test/tests/PDB/buffer.scm
Normal file
@ -0,0 +1,93 @@
|
||||
; Test methods of Buffer class of the PDB
|
||||
|
||||
; aka NamedBuffer i.e. the clipboard saved with a name.
|
||||
|
||||
; Edit methods that create buffers is tested elsewhere.
|
||||
; The names of those methods is hard to understand:
|
||||
; because they used "named" to mean "buffer"
|
||||
; E.G. pika-edit-named-copy might be better named:
|
||||
; pika-edit-copy-to-named-buffer
|
||||
|
||||
|
||||
|
||||
; Prereq: no buffer exists yet.
|
||||
|
||||
|
||||
|
||||
; setup
|
||||
; Load test image that already has drawable
|
||||
(define testImage (testing:load-test-image "wilber.png"))
|
||||
|
||||
; the layer is the zeroeth element in the vector which is the second element
|
||||
; but cadr returns the second element!!
|
||||
; TODO make this a library routine: get-first-layer
|
||||
; (1 #(<layerID>))
|
||||
(define testDrawable (vector-ref (cadr (pika-image-get-layers testImage ))
|
||||
0))
|
||||
|
||||
; Create new named buffer
|
||||
; There is no pika-buffer-new method,
|
||||
; instead it is a method of the Edit class so-to-speak
|
||||
; You can't: #(testDrawable)
|
||||
(define testBuffer (car (pika-edit-named-copy
|
||||
1
|
||||
(make-vector 1 testDrawable)
|
||||
"bufferName")))
|
||||
; Since no selection, the buffer is same size as image
|
||||
|
||||
; Creation was effective: pika knows the buffer
|
||||
; get-list takes a regex, here empty ""
|
||||
; get-list returns (("bufferName")) : a list of strings
|
||||
; and the first string is "bufferName"
|
||||
(assert `(string=? (caar (pika-buffers-get-list ""))
|
||||
"bufferName"))
|
||||
|
||||
; buffer has same size as image when created with no selection
|
||||
; test image is 256x256
|
||||
(assert `(= (car (pika-buffer-get-width "bufferName"))
|
||||
256))
|
||||
(assert `(= (car (pika-buffer-get-height "bufferName"))
|
||||
256))
|
||||
|
||||
; new buffer has alpha: the image is RGB but the buffer has bpp 4
|
||||
; This is not well documented.
|
||||
; FIXME the docs and the method name should say "bpp"
|
||||
; or "bytes per pixel" instead of "bytes"
|
||||
(assert `(= (car (pika-buffer-get-bytes "bufferName"))
|
||||
4))
|
||||
|
||||
; image type is RGBA
|
||||
; FIXME: the docs erroneously say "ImageBaseType" => "ImageType"
|
||||
(assert `(= (car (pika-buffer-get-image-type "bufferName"))
|
||||
RGBA-IMAGE))
|
||||
|
||||
|
||||
|
||||
; renaming
|
||||
|
||||
; Renaming returns the given name if it doesn't clash with existing name.
|
||||
(assert `(string=? (car (pika-buffer-rename "bufferName" "renamedName"))
|
||||
"renamedName"))
|
||||
|
||||
; Effect renaming: pika knows the renamed name
|
||||
(assert `(string=? (caar (pika-buffers-get-list ""))
|
||||
"renamedName"))
|
||||
|
||||
; Renaming does not add another buffer
|
||||
|
||||
; TODO list-length 1
|
||||
|
||||
|
||||
; deleting
|
||||
|
||||
; Delete evaluates but is void
|
||||
(assert `(pika-buffer-delete "renamedName"))
|
||||
|
||||
; Delete was effective: pika no longer knows
|
||||
; and returns nil i.e. empty list (())
|
||||
(assert `(null? (car (pika-buffers-get-list ""))))
|
||||
|
||||
|
||||
; TODO test two buffers
|
||||
|
||||
; TODO test renaming when name already in use
|
||||
57
plug-ins/script-fu/test/tests/PDB/channel/channel-new.scm
Normal file
57
plug-ins/script-fu/test/tests/PDB/channel/channel-new.scm
Normal file
@ -0,0 +1,57 @@
|
||||
; Test methods of Channel class of the PDB
|
||||
|
||||
|
||||
|
||||
; setup
|
||||
; new, empty image
|
||||
(define testImage (car (pika-image-new 21 22 RGB)))
|
||||
|
||||
|
||||
; new image has no custom channels
|
||||
(assert `(= (car (pika-image-get-channels ,testImage))
|
||||
0))
|
||||
|
||||
; setup (not in an assert and not quoted)
|
||||
; vectors-new succeeds
|
||||
(define testChannel (car (pika-channel-new
|
||||
testImage ; image
|
||||
23 24 ; width, height
|
||||
"Test Channel" ; name
|
||||
50.0 ; opacity
|
||||
"red" ))) ; compositing color
|
||||
|
||||
; new channel is not in image until inserted
|
||||
; get-channels yields (0 #())
|
||||
(assert `(= (car (pika-image-get-channels ,testImage))
|
||||
0))
|
||||
|
||||
; channel ID is valid
|
||||
(assert `(= (car (pika-item-id-is-channel ,testChannel))
|
||||
1)) ; #t
|
||||
|
||||
|
||||
; attributes
|
||||
|
||||
; get-color
|
||||
; FIXME: this passes but should test return red ???
|
||||
(assert `(equal?
|
||||
(car (pika-channel-get-color ,testChannel))
|
||||
'(0 0 0)))
|
||||
|
||||
|
||||
|
||||
|
||||
; insert
|
||||
|
||||
; insert succeeds
|
||||
(assert `(pika-image-insert-channel
|
||||
,testImage
|
||||
,testChannel
|
||||
0 ; parent, moot since channel groups not supported
|
||||
0)) ; position in stack
|
||||
|
||||
; insert was effective
|
||||
; testImage now has one channel
|
||||
(assert `(= (car (pika-image-get-channels ,testImage))
|
||||
1))
|
||||
|
||||
@ -0,0 +1,42 @@
|
||||
; test getters and setters of PikaContext
|
||||
; (sic its not an object or class)
|
||||
|
||||
|
||||
|
||||
; set-line-dash-pattern
|
||||
|
||||
; tests binding of FloatArray
|
||||
|
||||
; Default is no pattern
|
||||
; Even if user has stroked already and chosen a stroke>line>pattern
|
||||
(assert `(= (car (pika-context-get-line-dash-pattern))
|
||||
0))
|
||||
|
||||
; setter succeeds
|
||||
(assert `(pika-context-set-line-dash-pattern 2 #(5.0 11.0)))
|
||||
|
||||
; setter effective
|
||||
(assert `(= (car (pika-context-get-line-dash-pattern))
|
||||
2))
|
||||
(assert `(equal? (cadr (pika-context-get-line-dash-pattern))
|
||||
#(5.0 11.0)))
|
||||
|
||||
|
||||
; get-line-dash-offset
|
||||
|
||||
;tests binding of float i.e. gdouble
|
||||
|
||||
; defaults to 0.0 until set
|
||||
; FIXME why doesn't it persist in settings?
|
||||
(assert `(= (car (pika-context-get-line-dash-offset))
|
||||
0.0))
|
||||
|
||||
; setter succeeds
|
||||
(assert `(pika-context-set-line-dash-offset 3.3 ))
|
||||
; setter effective
|
||||
(assert `(= (car (pika-context-get-line-dash-offset))
|
||||
3.3))
|
||||
|
||||
|
||||
|
||||
|
||||
113
plug-ins/script-fu/test/tests/PDB/context/context-resource.scm
Normal file
113
plug-ins/script-fu/test/tests/PDB/context/context-resource.scm
Normal file
@ -0,0 +1,113 @@
|
||||
; test resource methods of Context
|
||||
|
||||
|
||||
|
||||
; function to test methods on Resource
|
||||
; for a valid Resource ID
|
||||
(define (test-resource-methods resource)
|
||||
|
||||
; a resource is an int ID in ScriptFu
|
||||
(assert `(integer? ,resource))
|
||||
|
||||
; get-name returns a string
|
||||
(assert `(string? (car (pika-resource-get-name ,resource))))
|
||||
|
||||
; id-is-valid returns truth
|
||||
; (1) FUTURE #t
|
||||
(assert `(car (pika-resource-id-is-valid ,resource)))
|
||||
|
||||
; pika-resource-get-identifiers succeeds
|
||||
; it returns a triplet
|
||||
(assert `(pika-resource-get-identifiers ,resource))
|
||||
|
||||
; pika-resource-get-identifiers returns numeric for is-internal
|
||||
; Some of the fresh pika active resource are internal, some not !!!
|
||||
(assert `(number? (car (pika-resource-get-identifiers ,resource))))
|
||||
|
||||
; name from get-identifiers is same as from pika-resource-get-name
|
||||
; name is second field of triplet i.e. cadr
|
||||
(assert `(string=? (cadr (pika-resource-get-identifiers ,resource))
|
||||
(car (pika-resource-get-name ,resource))))
|
||||
|
||||
; pika-resource-is-editable succeeds
|
||||
; Returns a wrapped boolean
|
||||
(assert `(pika-resource-is-editable ,resource))
|
||||
|
||||
; The fresh pika active resources are all system resources i.e. not editable
|
||||
; returns 0 for #f
|
||||
(assert `(= (car(pika-resource-is-editable ,resource))
|
||||
0))
|
||||
)
|
||||
|
||||
; "Test Parasite") ; name
|
||||
; "Procedure execution of pika-resource-get-parasite failed")
|
||||
|
||||
|
||||
|
||||
; test context-get-resource returns active resource of given className
|
||||
; Setup. Not assert.
|
||||
|
||||
(define testBrush (car (pika-context-get-resource "PikaBrush")))
|
||||
(define testFont (car (pika-context-get-resource "PikaFont")))
|
||||
(define testGradient (car (pika-context-get-resource "PikaGradient")))
|
||||
(define testPalette (car (pika-context-get-resource "PikaPalette")))
|
||||
(define testPattern (car (pika-context-get-resource "PikaPattern")))
|
||||
; FUTURE Dynamics and other Resource subclasses
|
||||
|
||||
|
||||
; test methods on active resource ID's
|
||||
|
||||
(test-resource-methods testBrush)
|
||||
(test-resource-methods testFont)
|
||||
(test-resource-methods testGradient)
|
||||
(test-resource-methods testPalette)
|
||||
(test-resource-methods testPattern)
|
||||
|
||||
|
||||
; test more specific context methods return same result
|
||||
; as the general context-get-resource
|
||||
|
||||
; test equality of numeric IDs
|
||||
(assert `(= (car(pika-context-get-brush))
|
||||
,testBrush))
|
||||
(assert `(= (car(pika-context-get-font))
|
||||
,testFont))
|
||||
(assert `(= (car(pika-context-get-gradient))
|
||||
,testGradient))
|
||||
(assert `(= (car(pika-context-get-palette))
|
||||
,testPalette))
|
||||
(assert `(= (car(pika-context-get-pattern))
|
||||
,testPattern))
|
||||
|
||||
|
||||
; test resource-id-is-foo methods
|
||||
|
||||
; the resource IDs from setup work with the specific id-is-foo methods
|
||||
|
||||
(assert `(= (car(pika-resource-id-is-brush ,testBrush))
|
||||
1))
|
||||
(assert `(= (car(pika-resource-id-is-font ,testFont))
|
||||
1))
|
||||
(assert `(= (car(pika-resource-id-is-gradient ,testGradient))
|
||||
1))
|
||||
(assert `(= (car(pika-resource-id-is-palette ,testPalette))
|
||||
1))
|
||||
(assert `(= (car(pika-resource-id-is-pattern ,testPattern))
|
||||
1))
|
||||
|
||||
|
||||
; test errors
|
||||
|
||||
|
||||
; invalid type name
|
||||
(assert-error `(pika-context-get-resource "InvalidTypeName")
|
||||
"Procedure execution of pika-context-get-resource failed")
|
||||
|
||||
; invalid numeric ID
|
||||
; -1 is out of range
|
||||
(assert-error `(pika-resource-get-name -1)
|
||||
"Procedure execution of pika-resource-get-name failed on invalid input arguments:")
|
||||
; 12345678 is in range but invalid
|
||||
(assert-error `(pika-resource-get-name 12345678)
|
||||
"Procedure execution of pika-resource-get-name failed on invalid input arguments:")
|
||||
|
||||
19
plug-ins/script-fu/test/tests/PDB/enums.scm
Normal file
19
plug-ins/script-fu/test/tests/PDB/enums.scm
Normal file
@ -0,0 +1,19 @@
|
||||
|
||||
; Test enums of the PDB
|
||||
|
||||
; These test and illustrate enums
|
||||
|
||||
|
||||
; ImageBaseType
|
||||
(assert '(= RGB 0))
|
||||
(assert '(= GRAY 1))
|
||||
(assert '(= INDEXED 2))
|
||||
|
||||
; ImageType is not same as ImageBaseType
|
||||
(assert '(= RGB-IMAGE 0))
|
||||
(assert '(= RGBA-IMAGE 1))
|
||||
(assert '(= GRAY-IMAGE 2))
|
||||
(assert '(= GRAYA-IMAGE 3))
|
||||
(assert '(= INDEXED-IMAGE 4))
|
||||
(assert '(= INDEXEDA-IMAGE 5))
|
||||
|
||||
54
plug-ins/script-fu/test/tests/PDB/image/image-grayscale.scm
Normal file
54
plug-ins/script-fu/test/tests/PDB/image/image-grayscale.scm
Normal file
@ -0,0 +1,54 @@
|
||||
; test Image of mode grayscale methods of PDB
|
||||
|
||||
; !!! Note inconsistent use in PIKA of GRAY versus GRAYSCALE
|
||||
|
||||
|
||||
|
||||
; Basic grayscale tests
|
||||
|
||||
|
||||
; setup
|
||||
|
||||
(define testImage (car (pika-image-new 21 22 RGB)))
|
||||
|
||||
|
||||
|
||||
|
||||
; method pika-image-convert-grayscale does not error
|
||||
(assert `(pika-image-convert-grayscale ,testImage))
|
||||
|
||||
; conversion was effective:
|
||||
; basetype of grayscale is GRAY
|
||||
(assert `(=
|
||||
(car (pika-image-get-base-type ,testImage))
|
||||
GRAY))
|
||||
|
||||
; conversion was effective:
|
||||
; grayscale image has-a colormap
|
||||
; colormap is-a vector of length zero, when image has no drawable.
|
||||
; FIXME doc says num-bytes is returned, obsolete since GBytes
|
||||
(assert `(=
|
||||
(vector-length
|
||||
(car (pika-image-get-colormap ,testImage)))
|
||||
0))
|
||||
|
||||
; grayscale images have precision PRECISION-U8-NON-LINEAR
|
||||
; FIXME annotation of PDB procedure says PIKA_PRECISION_U8
|
||||
(assert `(=
|
||||
(car (pika-image-get-precision ,testImage))
|
||||
PRECISION-U8-NON-LINEAR ))
|
||||
|
||||
; TODO
|
||||
; drawable of grayscale image is also grayscale
|
||||
;(assert `(car (pika-drawable-is-grayscale
|
||||
; ()
|
||||
; ,testImage)
|
||||
|
||||
; convert precision of grayscale image succeeds
|
||||
(assert `(pika-image-convert-precision
|
||||
,testImage
|
||||
PRECISION-DOUBLE-GAMMA))
|
||||
|
||||
|
||||
|
||||
|
||||
128
plug-ins/script-fu/test/tests/PDB/image/image-indexed.scm
Normal file
128
plug-ins/script-fu/test/tests/PDB/image/image-indexed.scm
Normal file
@ -0,0 +1,128 @@
|
||||
; test Image of mode indexed methods of PDB
|
||||
|
||||
; Now independent of image ID
|
||||
|
||||
|
||||
; Basic indexed tests
|
||||
|
||||
|
||||
; an empty image for testing
|
||||
(define newTestImage (car (pika-image-new 21 22 RGB)))
|
||||
|
||||
; Load test image that already has drawable
|
||||
(define testImage (testing:load-test-image "wilber.png"))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
; testImage is mode RGB
|
||||
(assert `(=
|
||||
(car (pika-image-get-base-type ,testImage))
|
||||
RGB))
|
||||
|
||||
|
||||
; method pika-image-convert-indexed yields truthy (now yields (#t) )
|
||||
(assert `(pika-image-convert-indexed
|
||||
,testImage
|
||||
CONVERT-DITHER-NONE
|
||||
CONVERT-PALETTE-GENERATE
|
||||
2 ; color count
|
||||
1 ; alpha-dither. FUTURE: #t
|
||||
1 ; remove-unused. FUTURE: #t
|
||||
"myPalette" ; ignored
|
||||
))
|
||||
|
||||
; method pika-image-convert-indexed works even on empty image
|
||||
(assert `(pika-image-convert-indexed
|
||||
,newTestImage
|
||||
CONVERT-DITHER-NONE
|
||||
CONVERT-PALETTE-GENERATE
|
||||
25 ; color count
|
||||
1 ; alpha-dither. FUTURE: #t
|
||||
1 ; remove-unused. FUTURE: #t
|
||||
"myPalette" ; ignored
|
||||
))
|
||||
|
||||
; conversion was effective:
|
||||
; basetype of indexed image is INDEXED
|
||||
(assert `(=
|
||||
(car (pika-image-get-base-type ,testImage))
|
||||
INDEXED))
|
||||
|
||||
; conversion was effective:
|
||||
; basetype of indexed image is INDEXED
|
||||
(assert `(=
|
||||
(car (pika-image-get-base-type ,newTestImage))
|
||||
INDEXED))
|
||||
|
||||
|
||||
; testImage has a layer named same as file "wilber.png"
|
||||
; TODO Why does "Background" work but app shows "wilber.png"
|
||||
|
||||
; drawable of indexed image is also indexed
|
||||
(assert `(= (car (pika-drawable-is-indexed
|
||||
; unwrap the drawable ID
|
||||
(car (pika-image-get-layer-by-name ,testImage "Background"))))
|
||||
1)) ; FUTURE #t
|
||||
|
||||
|
||||
|
||||
; colormaps of indexed images
|
||||
|
||||
; conversion was effective:
|
||||
; indexed image has-a colormap
|
||||
|
||||
; colormap is-a vector of length zero, when image has no drawable.
|
||||
; get-colormap returns (#( <bytes of color>))
|
||||
; FIXME doc says num-bytes is returned, obsolete since GBytes
|
||||
(assert `(=
|
||||
(vector-length
|
||||
(car (pika-image-get-colormap ,newTestImage)))
|
||||
0))
|
||||
|
||||
; colormap is-a vector of length 3*<color count given during conversion>,
|
||||
; when image has a drawable.
|
||||
; 3*2=6
|
||||
; FIXME doc says num-bytes is returned, obsolete since GBytes
|
||||
(assert `(=
|
||||
(vector-length
|
||||
(car (pika-image-get-colormap ,testImage)))
|
||||
(* 3 2)))
|
||||
|
||||
; set-colormap succeeds
|
||||
; This tests marshalling of GBytes to PDB
|
||||
(assert `(pika-image-set-colormap ,testImage #(1 1 1 9 9 9)))
|
||||
|
||||
; TODO set-colormap effective
|
||||
; colormap vector is same as given
|
||||
(assert `(equal?
|
||||
(car (pika-image-get-colormap ,testImage))
|
||||
#(1 1 1 9 9 9)))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
; precision of indexed images
|
||||
|
||||
; indexed images have precision PRECISION-U8-NON-LINEAR
|
||||
; FIXME annotation of PDB procedure says PIKA_PRECISION_U8
|
||||
(assert `(=
|
||||
(car (pika-image-get-precision ,testImage))
|
||||
PRECISION-U8-NON-LINEAR ))
|
||||
|
||||
|
||||
|
||||
|
||||
; !!! This depends on ID 4 for image
|
||||
|
||||
; convert precision of indexed images yields error
|
||||
(assert-error `(car (pika-image-convert-precision
|
||||
,newTestImage
|
||||
PRECISION-DOUBLE-GAMMA))
|
||||
"Procedure execution of pika-image-convert-precision failed on invalid input arguments: ")
|
||||
; "Image '[Untitled]' (4) must not be of type 'indexed'"
|
||||
|
||||
|
||||
|
||||
58
plug-ins/script-fu/test/tests/PDB/image/image-layers.scm
Normal file
58
plug-ins/script-fu/test/tests/PDB/image/image-layers.scm
Normal file
@ -0,0 +1,58 @@
|
||||
; test Image methods of PDB
|
||||
; where methods deal with layers owned by image.
|
||||
|
||||
|
||||
; setup
|
||||
; Load test image that already has drawable
|
||||
(define testImage (testing:load-test-image "wilber.png"))
|
||||
|
||||
|
||||
|
||||
; get-layers
|
||||
; procedure returns (1 #(<layerID>)) ....in the REPL
|
||||
|
||||
|
||||
; the testImage has one layer
|
||||
(assert `(= (car (pika-image-get-layers ,testImage ))
|
||||
1))
|
||||
|
||||
; get-layers returns second result a vector of ID's
|
||||
; !!! use cadr to get second result
|
||||
(assert `(vector? (cadr (pika-image-get-layers ,testImage ))))
|
||||
|
||||
; the vector also has one element
|
||||
(assert `(= (vector-length (cadr (pika-image-get-layers ,testImage )))
|
||||
1))
|
||||
|
||||
; the vector can be indexed at first element
|
||||
; and is a numeric ID
|
||||
(assert `(number?
|
||||
(vector-ref (cadr (pika-image-get-layers ,testImage ))
|
||||
0)))
|
||||
|
||||
; store the layer ID
|
||||
(define testLayer (vector-ref (cadr (pika-image-get-layers testImage ))
|
||||
0))
|
||||
|
||||
; FIXME seems to fail??? because name is actually "Background"
|
||||
|
||||
; the same layer can be got by name
|
||||
; FIXME app shows layer name is "wilber.png" same as image name
|
||||
(assert `(= (car (pika-image-get-layer-by-name ,testImage "Background"))
|
||||
,testLayer))
|
||||
|
||||
; the single layer's position is zero
|
||||
; pika-image-get-layer-position is deprecated
|
||||
(assert `(= (car (pika-image-get-item-position ,testImage ,testLayer))
|
||||
0))
|
||||
|
||||
|
||||
; TODO pika-image-get-layer-by-tattoo
|
||||
|
||||
; the single layer is selected in freshly opened image
|
||||
(assert `(= (car (pika-image-get-selected-layers ,testImage ))
|
||||
1))
|
||||
|
||||
; TODO test selected layer is same layer
|
||||
|
||||
|
||||
148
plug-ins/script-fu/test/tests/PDB/image/image-new.scm
Normal file
148
plug-ins/script-fu/test/tests/PDB/image/image-new.scm
Normal file
@ -0,0 +1,148 @@
|
||||
; test Image methods of PDB
|
||||
|
||||
; loading this file changes testing state
|
||||
|
||||
; Using numeric equality operator '=' on numeric ID's
|
||||
|
||||
|
||||
; setup
|
||||
|
||||
; method new from fresh PIKA state returns ID 1
|
||||
(define testImage (car (pika-image-new 21 22 RGB)))
|
||||
|
||||
|
||||
|
||||
|
||||
; FUTURE method is_valid on new image yields #t
|
||||
; method is_valid on new image yields 1 i.e. true
|
||||
(assert `(=
|
||||
(car (pika-image-id-is-valid ,testImage))
|
||||
1))
|
||||
|
||||
; Ensure attributes of new image are correct
|
||||
|
||||
; method is_dirty on new image is true
|
||||
(assert `(=
|
||||
(car (pika-image-is-dirty ,testImage))
|
||||
1))
|
||||
|
||||
; method get_width on new image yields same width given when created
|
||||
(assert `(=
|
||||
(car (pika-image-get-width ,testImage))
|
||||
21))
|
||||
|
||||
; method get_height on new image yields same height given when created
|
||||
(assert `(=
|
||||
(car (pika-image-get-height ,testImage))
|
||||
22))
|
||||
|
||||
; method get-base-type yields same image type given when created
|
||||
(assert `(=
|
||||
(car (pika-image-get-base-type ,testImage))
|
||||
RGB))
|
||||
|
||||
; new image is known to pika
|
||||
; Returns (<length> #(1))
|
||||
(assert `(= (car (pika-get-images))
|
||||
,testImage))
|
||||
|
||||
|
||||
; new image has no components
|
||||
|
||||
; new image has zero layers
|
||||
(assert `(= (car (pika-image-get-layers ,testImage))
|
||||
0))
|
||||
|
||||
; new image has zero vectors
|
||||
(assert `(= (car (pika-image-get-vectors ,testImage))
|
||||
0))
|
||||
|
||||
; new image has no parasites
|
||||
(assert `(= (length
|
||||
(car (pika-image-get-parasite-list ,testImage)))
|
||||
0))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
; new image has-a selection
|
||||
(assert `(pika-image-get-selection ,testImage))
|
||||
|
||||
; new image has no floating selection
|
||||
(assert `(=
|
||||
(car (pika-image-get-floating-sel ,testImage))
|
||||
-1))
|
||||
|
||||
; TODO floating-sel-attached-to
|
||||
|
||||
|
||||
|
||||
; new image has unit having ID 1
|
||||
(assert `(=
|
||||
(car (pika-image-get-unit ,testImage))
|
||||
1))
|
||||
|
||||
; new image has name
|
||||
(assert `(string=?
|
||||
(car (pika-image-get-name ,testImage))
|
||||
"[Untitled]"))
|
||||
|
||||
; new image has empty metadata string
|
||||
(assert `(string=?
|
||||
(car (pika-image-get-metadata ,testImage))
|
||||
""))
|
||||
|
||||
; has an effective color profile
|
||||
(assert `(pika-image-get-effective-color-profile ,testImage))
|
||||
|
||||
|
||||
|
||||
; new image has no associated files
|
||||
|
||||
; GFile is string in ScriptFu
|
||||
|
||||
; no file, xcf file, imported file, or exported file
|
||||
(assert `(string=? (car (pika-image-get-file ,testImage)) ""))
|
||||
(assert `(string=? (car (pika-image-get-xcf-file ,testImage)) ""))
|
||||
(assert `(string=? (car (pika-image-get-imported-file ,testImage)) ""))
|
||||
(assert `(string=? (car (pika-image-get-exported-file ,testImage)) ""))
|
||||
|
||||
|
||||
|
||||
; Test delete method.
|
||||
; !!! ID 1 is no longer valid
|
||||
|
||||
; method delete succeeds on new image
|
||||
; returns 1 for true. FUTURE returns #t
|
||||
(assert `(car (pika-image-delete ,testImage)))
|
||||
|
||||
; ensure id invalid for deleted image
|
||||
; returns 0 for false. FUTURE returns #f
|
||||
(assert `(=
|
||||
(car (pika-image-id-is-valid ,testImage))
|
||||
0))
|
||||
|
||||
; deleted image is not in pika
|
||||
; Returns (<length> #())
|
||||
; FUTURE Returns empty list `()
|
||||
(assert `(=
|
||||
(car (pika-get-images))
|
||||
0))
|
||||
; !!! This only passes when testing is from fresh Pika restart
|
||||
|
||||
|
||||
; Test abnormal args to image-new
|
||||
|
||||
|
||||
; Dimension zero yields error
|
||||
; It does NOT yield invalid ID -1
|
||||
(assert-error `(pika-image-new 0 0 RGB)
|
||||
(string-append
|
||||
"Procedure execution of pika-image-new failed on invalid input arguments: "
|
||||
"Procedure 'pika-image-new' has been called with value '0' for argument 'width' (#1, type gint)."))
|
||||
; " This value is out of range."
|
||||
|
||||
|
||||
|
||||
|
||||
83
plug-ins/script-fu/test/tests/PDB/image/image-ops.scm
Normal file
83
plug-ins/script-fu/test/tests/PDB/image/image-ops.scm
Normal file
@ -0,0 +1,83 @@
|
||||
; Test various operations on image
|
||||
|
||||
|
||||
; setup
|
||||
(define testImage (car (pika-image-new 21 22 RGB)))
|
||||
|
||||
|
||||
; transformations
|
||||
|
||||
; flip
|
||||
(assert `(pika-image-flip ,testImage ORIENTATION-HORIZONTAL))
|
||||
(assert `(pika-image-flip ,testImage ORIENTATION-VERTICAL))
|
||||
; TODO rotate scale resize policy
|
||||
|
||||
(assert-error `(pika-image-flip ,testImage ORIENTATION-UNKNOWN)
|
||||
(string-append
|
||||
"Procedure execution of pika-image-flip failed on invalid input arguments: "
|
||||
"Procedure 'pika-image-flip' has been called with value 'PIKA_ORIENTATION_UNKNOWN'"
|
||||
" for argument 'flip-type' (#2, type PikaOrientationType). This value is out of range."))
|
||||
|
||||
; rotate
|
||||
(assert `(pika-image-rotate ,testImage ROTATE-90))
|
||||
(assert `(pika-image-rotate ,testImage ROTATE-180))
|
||||
(assert `(pika-image-rotate ,testImage ROTATE-270))
|
||||
|
||||
; scale
|
||||
; up
|
||||
(assert `(pika-image-scale ,testImage 100 100))
|
||||
|
||||
; down to min
|
||||
(assert `(pika-image-scale ,testImage 1 1))
|
||||
|
||||
; up to max
|
||||
; Performance:
|
||||
; This seems to work fast when previous scaled to 1,1
|
||||
; but then seems to slow down testing
|
||||
; unless we scale down afterwards.
|
||||
; This seems glacial if not scaled to 1,1 prior.
|
||||
(assert `(pika-image-scale ,testImage 524288 524288))
|
||||
|
||||
; down to min
|
||||
(assert `(pika-image-scale ,testImage 1 1))
|
||||
|
||||
|
||||
; policy ops
|
||||
|
||||
; 0 means non-interactive
|
||||
(assert `(pika-image-policy-color-profile ,testImage 0))
|
||||
(assert `(pika-image-policy-rotate ,testImage 0))
|
||||
|
||||
|
||||
|
||||
; freezing and unfreezing (avoid updates to dialogs)
|
||||
; Used for performance.
|
||||
(assert `(pika-image-freeze-channels ,testImage))
|
||||
(assert `(pika-image-freeze-layers ,testImage))
|
||||
(assert `(pika-image-freeze-vectors ,testImage))
|
||||
(assert `(pika-image-thaw-channels ,testImage))
|
||||
(assert `(pika-image-thaw-layers ,testImage))
|
||||
(assert `(pika-image-thaw-vectors ,testImage))
|
||||
|
||||
; clean-all makes image not dirty
|
||||
(assert `(pika-image-clean-all ,testImage))
|
||||
(assert `(=
|
||||
(car (pika-image-is-dirty ,testImage))
|
||||
0))
|
||||
|
||||
; TODO test flatten is effective
|
||||
; crop
|
||||
|
||||
|
||||
; painting ops
|
||||
; TODO
|
||||
; heal
|
||||
; erase
|
||||
; smudge
|
||||
; pencil
|
||||
; clone
|
||||
; airbrush
|
||||
|
||||
; cannot flatten empty image
|
||||
(assert-error `(pika-image-flatten ,testImage)
|
||||
"Procedure execution of pika-image-flatten failed: Cannot flatten an image without any visible layer.")
|
||||
55
plug-ins/script-fu/test/tests/PDB/image/image-precision.scm
Normal file
55
plug-ins/script-fu/test/tests/PDB/image/image-precision.scm
Normal file
@ -0,0 +1,55 @@
|
||||
; test Image precision methods of PDB
|
||||
|
||||
; Using numeric equality operator '=' on numeric ID's
|
||||
|
||||
|
||||
; setup
|
||||
|
||||
(define testImage (car (pika-image-new 21 22 RGB)))
|
||||
|
||||
|
||||
; Basic precision tests
|
||||
|
||||
; method get_precision on new image yields PRECISION-U8-NON-LINEAR 150
|
||||
(assert `(=
|
||||
(car (pika-image-get-precision ,testImage))
|
||||
PRECISION-U8-NON-LINEAR ))
|
||||
|
||||
|
||||
|
||||
; Convert precision
|
||||
|
||||
; method convert-precision yields true, with side effect on image
|
||||
(assert `(car (pika-image-convert-precision
|
||||
,testImage
|
||||
PRECISION-U8-LINEAR)))
|
||||
|
||||
|
||||
; converted image is the precision
|
||||
(assert `(=
|
||||
(car (pika-image-get-precision ,testImage))
|
||||
PRECISION-U8-LINEAR ))
|
||||
|
||||
; converting to the same precision yields error message
|
||||
(assert-error `(pika-image-convert-precision
|
||||
,testImage
|
||||
PRECISION-U8-LINEAR)
|
||||
"Procedure execution of pika-image-convert-precision failed on invalid input arguments: ")
|
||||
; "Image '[Untitled]' (2) must not be of precision 'u8-linear'"
|
||||
|
||||
|
||||
|
||||
; Indexed images precision tested elsewhere
|
||||
|
||||
|
||||
|
||||
; New with precision
|
||||
|
||||
; setup
|
||||
(define testImageWithPrecision (car (pika-image-new-with-precision 21 22 RGB PRECISION-DOUBLE-GAMMA)))
|
||||
|
||||
|
||||
; image has given precision
|
||||
(assert `(=
|
||||
(car (pika-image-get-precision ,testImageWithPrecision))
|
||||
PRECISION-DOUBLE-GAMMA ))
|
||||
218
plug-ins/script-fu/test/tests/PDB/item/item.scm
Normal file
218
plug-ins/script-fu/test/tests/PDB/item/item.scm
Normal file
@ -0,0 +1,218 @@
|
||||
; test item methods of PDB
|
||||
|
||||
; Define function that is a sequence of tests.
|
||||
; Iterate over items of different types, applying test function.
|
||||
; 1. test attributes of a minimal item
|
||||
; 2. test transformations of item
|
||||
|
||||
; Test of pika-item-is-<ItemType> are elsewhere
|
||||
|
||||
; Test of tree/group (raise/lower, reorder) are elsewhere
|
||||
|
||||
|
||||
|
||||
|
||||
; Implementation of test:
|
||||
; function using assert must backquote ` and unquote , item.
|
||||
|
||||
|
||||
|
||||
; Test methods of bare, minimal item.
|
||||
(define (test-bare-item item)
|
||||
; item is a numeric ID is valid
|
||||
(assert `(pika-item-id-is-valid ,item))
|
||||
|
||||
; item is not a group (can have no children)
|
||||
(assert `(= (car (pika-item-is-group ,item))
|
||||
0))
|
||||
|
||||
; item has no color tag
|
||||
(assert `(= (car (pika-item-get-color-tag ,item))
|
||||
COLOR-TAG-NONE))
|
||||
|
||||
; item is not expanded
|
||||
(assert `(= (car (pika-item-get-expanded ,item))
|
||||
0))
|
||||
|
||||
; item has name, tattoo
|
||||
; Test does not check returned value
|
||||
(assert `(pika-item-get-name ,item))
|
||||
(assert `(pika-item-get-tattoo ,item))
|
||||
|
||||
; item has no parasites, yields no list of string
|
||||
; !!! C GStrv marshaled to empty list
|
||||
; Scheme null? tests for empty list
|
||||
(assert `(null? (car (pika-item-get-parasite-list ,item))))
|
||||
|
||||
; item has no parent
|
||||
; yields -1 for NULL ID
|
||||
(assert `(= (car (pika-item-get-parent ,item))
|
||||
-1))
|
||||
|
||||
; item has-a image
|
||||
; Test does not compare item ID
|
||||
(assert `(pika-item-get-image ,item))
|
||||
|
||||
; item's content, position, visibility is not locked
|
||||
(assert `(= (car (pika-item-get-lock-content ,item))
|
||||
0))
|
||||
(assert `(= (car (pika-item-get-lock-position ,item))
|
||||
0))
|
||||
(assert `(= (car (pika-item-get-lock-visibility ,item))
|
||||
0))
|
||||
)
|
||||
|
||||
|
||||
; Test methods of image,item
|
||||
(define (test-item-in-image image item)
|
||||
; item can produce a selection
|
||||
(assert `(pika-image-select-item
|
||||
,image
|
||||
CHANNEL-OP-ADD
|
||||
,item))
|
||||
)
|
||||
|
||||
|
||||
|
||||
; !!! PikaParasite does not have method new in PDB.
|
||||
; But you can create one in ScriptFu as (list "name" <flags> "data")
|
||||
; <flags>
|
||||
; 0 - Not persistent and not UNDOable
|
||||
; 1 - Persistent and not UNDOable
|
||||
; 2 - Not persistent and UNDOable
|
||||
; 3 - Persistent and UNDOable
|
||||
|
||||
; https://www.pikausers.com/forums/pika-user/12970-how-are-parasites-represented-in-script-fu
|
||||
; https://www.mail-archive.com/pika-user@lists.xcf.berkeley.edu/msg20099.html
|
||||
|
||||
; A returned parasite in ScriptFu is-a list (list "name" <flags> "data")
|
||||
|
||||
; You can use this in testing but requires (quote ,testParasite) ???
|
||||
;(define testParasite (list "Parasite New" 1 "Parasite Data"))
|
||||
|
||||
(define (test-item-parasite item)
|
||||
|
||||
; not has-a parasite
|
||||
; !!! procedure expected to fail when no parasite
|
||||
(assert-error `(pika-item-get-parasite
|
||||
,item
|
||||
"Test Parasite") ; name
|
||||
"Procedure execution of pika-item-get-parasite failed")
|
||||
|
||||
; can attach parasite
|
||||
(assert `(pika-item-attach-parasite
|
||||
,item
|
||||
(list "Parasite New" 1 "Parasite Data")))
|
||||
; attach was effective: now item has parasite
|
||||
; and its name is as previously given
|
||||
(assert `(string=?
|
||||
; !!! Parasite is list in list, and first element is name
|
||||
(caar (pika-item-get-parasite
|
||||
,item
|
||||
"Parasite New")) ; name
|
||||
"Parasite New"))
|
||||
|
||||
; can detach parasite
|
||||
(assert `(pika-item-detach-parasite
|
||||
,item
|
||||
"Parasite New"))
|
||||
; detach was effective
|
||||
(assert-error `(pika-item-get-parasite
|
||||
,item
|
||||
"Test Parasite") ; name
|
||||
"Procedure execution of pika-item-get-parasite failed")
|
||||
)
|
||||
|
||||
|
||||
; OLD use image,item instance extant from previous tests.
|
||||
|
||||
; setup
|
||||
|
||||
; All the items in the same testImage
|
||||
; See earlier tests, where setup is lifted from
|
||||
|
||||
(define testImage (testing:load-test-image "wilber.png"))
|
||||
(define testLayer (vector-ref (cadr (pika-image-get-layers testImage ))
|
||||
0))
|
||||
(define testSelection (car (pika-image-get-selection testImage)))
|
||||
(define
|
||||
testTextLayer
|
||||
(car (pika-text-fontname
|
||||
testImage
|
||||
-1 ; drawable. -1 means NULL means create new text layer
|
||||
0 0 ; coords
|
||||
"bar" ; text
|
||||
1 ; border size
|
||||
1 ; antialias true
|
||||
31 ; fontsize
|
||||
PIXELS ; size units. !!! See UNIT-PIXEL
|
||||
"fontName" )))
|
||||
(define testChannel (car (pika-channel-new
|
||||
testImage ; image
|
||||
23 24 ; width, height
|
||||
"Test Channel" ; name
|
||||
50.0 ; opacity
|
||||
"red" ))) ; compositing color
|
||||
; must add to image
|
||||
(pika-image-insert-channel
|
||||
testImage
|
||||
testChannel
|
||||
0 ; parent, moot since channel groups not supported
|
||||
0)
|
||||
(define
|
||||
testLayerMask
|
||||
(car (pika-layer-create-mask
|
||||
testLayer
|
||||
ADD-MASK-WHITE)))
|
||||
; must add to layer
|
||||
(pika-layer-add-mask
|
||||
testLayer
|
||||
testLayerMask)
|
||||
(define testPath (car (pika-vectors-new testImage "Test Path")))
|
||||
; must add to image
|
||||
(pika-image-insert-vectors
|
||||
testImage
|
||||
testPath
|
||||
0 0) ; parent=0 position=0
|
||||
|
||||
|
||||
|
||||
; tests start here
|
||||
|
||||
; layer
|
||||
(test-bare-item testLayer)
|
||||
(test-item-in-image testImage testLayer)
|
||||
(test-item-parasite testLayer)
|
||||
|
||||
; text layer
|
||||
(test-bare-item testTextLayer)
|
||||
(test-item-in-image testImage testTextLayer)
|
||||
(test-item-parasite testTextLayer)
|
||||
|
||||
; layerMask
|
||||
(test-bare-item testLayerMask)
|
||||
(test-item-in-image testImage testLayerMask)
|
||||
(test-item-parasite testLayerMask)
|
||||
|
||||
; vectors
|
||||
(test-bare-item testPath)
|
||||
(test-item-in-image testImage testPath)
|
||||
(test-item-parasite testPath)
|
||||
|
||||
; channel
|
||||
(test-bare-item testChannel)
|
||||
(test-item-in-image testImage testChannel)
|
||||
(test-item-parasite testChannel)
|
||||
|
||||
; selection
|
||||
(test-bare-item testSelection)
|
||||
(test-item-in-image testImage testSelection)
|
||||
(test-item-parasite testSelection)
|
||||
|
||||
; TODO other item types e.g. ?
|
||||
|
||||
; pika-image-get-item-position
|
||||
; pika-image-raise-item
|
||||
; pika-image-raise-item-to-top
|
||||
; lower
|
||||
; reorder
|
||||
110
plug-ins/script-fu/test/tests/PDB/layer/layer-mask.scm
Normal file
110
plug-ins/script-fu/test/tests/PDB/layer/layer-mask.scm
Normal file
@ -0,0 +1,110 @@
|
||||
; tests of methods re masks on layers
|
||||
|
||||
; masks are a separate class in Pika PikaLayerMask
|
||||
; but the methods are named strangely,
|
||||
; e.g. there is no pika-layer-mask-get-layer
|
||||
|
||||
|
||||
; setup
|
||||
;
|
||||
(define testImage (car (pika-image-new 21 22 RGB)))
|
||||
|
||||
(define
|
||||
testLayer (car (pika-layer-new
|
||||
testImage
|
||||
21
|
||||
22
|
||||
RGB-IMAGE
|
||||
"LayerNew"
|
||||
50.0
|
||||
LAYER-MODE-NORMAL)))
|
||||
; assert layer is not inserted in image
|
||||
|
||||
; assert layerMask not on the layer yet!!!
|
||||
(define
|
||||
testLayerMask (car (pika-layer-create-mask
|
||||
testLayer
|
||||
ADD-MASK-WHITE)))
|
||||
|
||||
|
||||
; mask is not on layer until added.
|
||||
; Getting the mask for the layer yields -1.
|
||||
(assert `(= (car (pika-layer-mask ,testLayer))
|
||||
-1))
|
||||
|
||||
; add layerMask created on a layer to that layer succeeds
|
||||
(assert `(pika-layer-add-mask
|
||||
,testLayer
|
||||
,testLayerMask))
|
||||
|
||||
; add layerMask to layer was effective:
|
||||
; Getting the mask for the layer yields layerMask ID
|
||||
(assert `(= (car (pika-layer-mask ,testLayer))
|
||||
,testLayerMask))
|
||||
|
||||
; and vice versa
|
||||
(assert `(= (car (pika-layer-from-mask ,testLayerMask))
|
||||
,testLayer))
|
||||
|
||||
|
||||
|
||||
; creating and adding second mask
|
||||
|
||||
; creating a second mask from layer succeeds
|
||||
(define
|
||||
testLayerMask2
|
||||
(car (pika-layer-create-mask
|
||||
testLayer
|
||||
ADD-MASK-WHITE)))
|
||||
|
||||
|
||||
; adding a second layerMask fails
|
||||
(assert-error `(pika-layer-add-mask
|
||||
,testLayer
|
||||
,testLayerMask2)
|
||||
(string-append
|
||||
"Procedure execution of pika-layer-add-mask failed: "
|
||||
"Unable to add a layer mask since the layer already has one."))
|
||||
|
||||
|
||||
|
||||
; mask removal
|
||||
|
||||
; remove-mask fails if the layer is not on image
|
||||
(assert-error `(pika-layer-remove-mask
|
||||
,testLayer
|
||||
MASK-APPLY) ; removal mode
|
||||
"Procedure execution of pika-layer-remove-mask failed on invalid input arguments: ")
|
||||
; "Item 'LayerNew' (12) cannot be used because it has not been added to an image"))
|
||||
|
||||
; adding layer to image succeeds
|
||||
(assert `(pika-image-insert-layer
|
||||
,testImage
|
||||
,testLayer
|
||||
0 ; parent
|
||||
0 )) ; position within parent
|
||||
|
||||
; remove-mask succeeds
|
||||
; when layer is in image
|
||||
(assert `(pika-layer-remove-mask
|
||||
,testLayer
|
||||
MASK-APPLY)) ; removal mode
|
||||
|
||||
; and is effective
|
||||
; layer no longer has a mask
|
||||
(assert `(= (car (pika-layer-mask ,testLayer))
|
||||
-1))
|
||||
|
||||
; and now we can add the second mask
|
||||
(assert `(pika-layer-add-mask
|
||||
,testLayer
|
||||
,testLayerMask2))
|
||||
|
||||
|
||||
; fails when mask different size from layer?
|
||||
|
||||
; fails create layerMask when ADD-CHANNEL-MASK and no active channel
|
||||
|
||||
; create layerMask ADD-ALPHA-MASK works even when no alpha channel
|
||||
|
||||
; TODO many variations of create
|
||||
120
plug-ins/script-fu/test/tests/PDB/layer/layer-new.scm
Normal file
120
plug-ins/script-fu/test/tests/PDB/layer/layer-new.scm
Normal file
@ -0,0 +1,120 @@
|
||||
; test Layer methods of PDB
|
||||
|
||||
|
||||
; setup
|
||||
|
||||
|
||||
(define testImage (car (pika-image-new 21 22 RGB)))
|
||||
|
||||
(define testLayer
|
||||
(car (pika-layer-new
|
||||
testImage
|
||||
21
|
||||
22
|
||||
RGB-IMAGE
|
||||
"LayerNew"
|
||||
50.0
|
||||
LAYER-MODE-NORMAL)))
|
||||
|
||||
|
||||
|
||||
|
||||
; new layer is not in the image until inserted
|
||||
(assert `(= (car (pika-image-get-layers ,testImage))
|
||||
0))
|
||||
|
||||
|
||||
|
||||
; attributes of new layer
|
||||
|
||||
; defaulted attributes
|
||||
|
||||
; apply-mask default false
|
||||
(assert `(=
|
||||
(car (pika-layer-get-apply-mask ,testLayer))
|
||||
0))
|
||||
|
||||
; blend-space default LAYER-COLOR-SPACE-AUTO
|
||||
(assert `(=
|
||||
(car (pika-layer-get-blend-space ,testLayer))
|
||||
LAYER-COLOR-SPACE-AUTO))
|
||||
|
||||
; composite-mode default LAYER-COMPOSITE-AUTO
|
||||
(assert `(=
|
||||
(car (pika-layer-get-composite-mode ,testLayer))
|
||||
LAYER-COMPOSITE-AUTO))
|
||||
|
||||
; composite-space default LAYER-COLOR-SPACE-AUTO
|
||||
(assert `(=
|
||||
(car (pika-layer-get-composite-space ,testLayer))
|
||||
LAYER-COLOR-SPACE-AUTO))
|
||||
|
||||
; edit-mask default false
|
||||
(assert `(=
|
||||
(car (pika-layer-get-edit-mask ,testLayer))
|
||||
0))
|
||||
|
||||
; lock-alpha default false
|
||||
; deprecated? pika-layer-get-preserve-trans
|
||||
(assert `(=
|
||||
(car (pika-layer-get-lock-alpha ,testLayer))
|
||||
0))
|
||||
|
||||
; mask not exist, ID -1
|
||||
; deprecated? pika-layer-mask
|
||||
(assert `(=
|
||||
(car (pika-layer-get-mask ,testLayer))
|
||||
-1))
|
||||
|
||||
; mode default LAYER-MODE-NORMAL
|
||||
(assert `(=
|
||||
(car (pika-layer-get-mode ,testLayer))
|
||||
LAYER-MODE-NORMAL))
|
||||
|
||||
; show-mask default false
|
||||
(assert `(=
|
||||
(car (pika-layer-get-show-mask ,testLayer))
|
||||
0))
|
||||
|
||||
; visible default true
|
||||
; FIXME doc says default false
|
||||
(assert `(=
|
||||
(car (pika-layer-get-visible ,testLayer))
|
||||
1))
|
||||
|
||||
; is-floating-sel default false
|
||||
(assert `(=
|
||||
(car (pika-layer-is-floating-sel ,testLayer))
|
||||
0))
|
||||
|
||||
; !!! No get-offsets
|
||||
|
||||
|
||||
|
||||
|
||||
; attributes are as given when created
|
||||
|
||||
; name is as given
|
||||
(assert `(string=? (car (pika-layer-get-name ,testLayer))
|
||||
"LayerNew"))
|
||||
|
||||
; opacity is as given
|
||||
(assert `(=
|
||||
(car (pika-layer-get-opacity ,testLayer))
|
||||
50.0))
|
||||
|
||||
|
||||
; generated attributes
|
||||
|
||||
; tattoo
|
||||
; tattoo is generated unique within image?
|
||||
(assert `(=
|
||||
(car (pika-layer-get-tattoo ,testLayer))
|
||||
2))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
88
plug-ins/script-fu/test/tests/PDB/layer/layer-ops.scm
Normal file
88
plug-ins/script-fu/test/tests/PDB/layer/layer-ops.scm
Normal file
@ -0,0 +1,88 @@
|
||||
; test Layer methods of PDB
|
||||
; where methods are operations
|
||||
|
||||
|
||||
; setup
|
||||
|
||||
(define testImage (car (pika-image-new 21 22 RGB)))
|
||||
|
||||
(define
|
||||
testLayer (car (pika-layer-new
|
||||
testImage
|
||||
21
|
||||
22
|
||||
RGB-IMAGE
|
||||
"LayerNew#2"
|
||||
50.0
|
||||
LAYER-MODE-NORMAL)))
|
||||
; assert layer is not inserted in image
|
||||
|
||||
|
||||
; errors when layer not in image
|
||||
|
||||
; resize fails
|
||||
(assert-error `(pika-layer-resize ,testLayer 23 24 0 0)
|
||||
(string-append
|
||||
"Procedure execution of pika-layer-resize failed on invalid input arguments: "))
|
||||
;"Item 'LayerNew#2' (10) cannot be used because it has not been added to an image"))
|
||||
|
||||
; scale fails
|
||||
(assert-error `(pika-layer-scale ,testLayer
|
||||
23 24 ; width height
|
||||
0) ; is local origin?
|
||||
(string-append
|
||||
"Procedure execution of pika-layer-scale failed on invalid input arguments: "))
|
||||
;"Item 'LayerNew#2' (10) cannot be used because it has not been added to an image"))
|
||||
|
||||
; pika-layer-resize-to-image-size fails
|
||||
; TODO
|
||||
|
||||
; pika-layer-remove-mask fails when layer has no mask
|
||||
(assert-error `(pika-layer-remove-mask
|
||||
,testLayer
|
||||
MASK-APPLY)
|
||||
(string-append
|
||||
"Procedure execution of pika-layer-remove-mask failed on invalid input arguments: "))
|
||||
; "Item 'LayerNew#2' (10) cannot be used because it has not been added to an image"))
|
||||
|
||||
|
||||
|
||||
; alpha operations
|
||||
|
||||
; add-alpha succeeds
|
||||
(assert `(pika-layer-add-alpha ,testLayer))
|
||||
|
||||
; and is effective
|
||||
; Note method on superclass Drawable
|
||||
(assert `(= (car (pika-drawable-has-alpha ,testLayer))
|
||||
1))
|
||||
|
||||
; flatten succeeds
|
||||
(assert `(pika-layer-flatten ,testLayer))
|
||||
|
||||
; flatten was effective: no longer has alpha
|
||||
; flatten a layer means "remove alpha"
|
||||
(assert `(= (car (pika-drawable-has-alpha ,testLayer))
|
||||
0))
|
||||
|
||||
|
||||
|
||||
|
||||
; delete
|
||||
|
||||
; delete succeeds
|
||||
(assert `(pika-layer-delete ,testLayer))
|
||||
|
||||
; delete second time fails
|
||||
(assert-error `(pika-layer-delete ,testLayer)
|
||||
"runtime: invalid item ID")
|
||||
|
||||
; Error for flatten:
|
||||
; "Procedure execution of pika-layer-delete failed on invalid input arguments: "
|
||||
; "Procedure 'pika-layer-delete' has been called with an invalid ID for argument 'layer'. "
|
||||
; "Most likely a plug-in is trying to work on a layer that doesn't exist any longer."))
|
||||
|
||||
; delete layer when image already deleted fails
|
||||
; TODO
|
||||
|
||||
|
||||
13
plug-ins/script-fu/test/tests/PDB/misc.scm
Normal file
13
plug-ins/script-fu/test/tests/PDB/misc.scm
Normal file
@ -0,0 +1,13 @@
|
||||
|
||||
; Miscellaneous tests of the PDB
|
||||
; These are not associated with an object class
|
||||
|
||||
|
||||
; 0 is an invalid item id
|
||||
; FUTURE pika returns #f instead of 0
|
||||
; FUTURE pika doesn't wrap in extra list
|
||||
(assert '(= (car (pika-item-id-is-vectors 0)) 0))
|
||||
|
||||
; -1 is an invalid item id
|
||||
; FUTURE: '(not (pika-item-id-is-valid -1))
|
||||
(assert '(= (car (pika-item-id-is-valid -1)) 0))
|
||||
83
plug-ins/script-fu/test/tests/PDB/pdb.scm
Normal file
83
plug-ins/script-fu/test/tests/PDB/pdb.scm
Normal file
@ -0,0 +1,83 @@
|
||||
; Complete test of PDB
|
||||
|
||||
; to run in SF Console:
|
||||
; (testing:load-test "pdb.scm")
|
||||
; Expect a report of passed and failed
|
||||
|
||||
; This knows the set of files which are tests.
|
||||
; The test files might be organized in directories in the repo,
|
||||
; but all flattened into the /tests directory when installed.
|
||||
|
||||
; images
|
||||
(testing:load-test "image-new.scm")
|
||||
(testing:load-test "image-precision.scm")
|
||||
(testing:load-test "image-indexed.scm")
|
||||
(testing:load-test "image-grayscale.scm")
|
||||
(testing:load-test "image-ops.scm")
|
||||
(testing:load-test "image-layers.scm")
|
||||
|
||||
(testing:load-test "layer-new.scm")
|
||||
(testing:load-test "layer-ops.scm")
|
||||
(testing:load-test "layer-mask.scm")
|
||||
; TODO layer stack ops
|
||||
|
||||
; Commented out until PDB is fixed
|
||||
; Known to crash PIKA
|
||||
;(testing:load-test "text-layer-new.scm")
|
||||
|
||||
(testing:load-test "vectors-new.scm")
|
||||
(testing:load-test "channel-new.scm")
|
||||
; TODO channel-ops.scm
|
||||
|
||||
(testing:load-test "selection.scm")
|
||||
(testing:load-test "selection-from.scm")
|
||||
|
||||
; Test superclass methods.
|
||||
; Drawable and Item are superclasses
|
||||
; Testing Drawable and Item uses extant instances;
|
||||
; must be after instances of subclasses are created.
|
||||
; commented out until text-get-fontname is fixed
|
||||
; Known to crash PIKA
|
||||
;(testing:load-test "item.scm")
|
||||
; todo item ordering operations
|
||||
|
||||
; TODO drawable
|
||||
|
||||
; context
|
||||
(testing:load-test "context-get-set.scm")
|
||||
|
||||
; Temporarily commented out until pikagpparam-body.c is fixed for PikaParamResource
|
||||
; If you uncomment it, see warnings in stderr
|
||||
;(testing:load-test "context-resource.scm")
|
||||
|
||||
(testing:load-test "resource.scm")
|
||||
(testing:load-test "brush.scm")
|
||||
(testing:load-test "palette.scm")
|
||||
; TODO other resources gradient, etc
|
||||
(testing:load-test "resource-ops.scm")
|
||||
|
||||
(testing:load-test "buffer.scm")
|
||||
|
||||
; TODO edit ops
|
||||
; TODO undo
|
||||
; TODO progress
|
||||
|
||||
; tested in bind-args.scm:
|
||||
; unit
|
||||
; parasite
|
||||
|
||||
; pdb the object
|
||||
; pika the class, pika-get, pika-parasite
|
||||
|
||||
|
||||
(testing:load-test "misc.scm")
|
||||
(testing:load-test "enums.scm")
|
||||
(testing:load-test "refresh.scm")
|
||||
(testing:load-test "bind-args.scm")
|
||||
|
||||
; report the result
|
||||
(testing:report)
|
||||
|
||||
; yield the session overall result
|
||||
(testing:all-passed?)
|
||||
|
||||
69
plug-ins/script-fu/test/tests/PDB/refresh.scm
Normal file
69
plug-ins/script-fu/test/tests/PDB/refresh.scm
Normal file
@ -0,0 +1,69 @@
|
||||
; test refresh methods
|
||||
|
||||
; make the app read resources from configuration files
|
||||
|
||||
; methods of the app
|
||||
; the app manages collections of resources
|
||||
; app can refresh and list the resources.
|
||||
|
||||
; A collection is named by the plural of the singular element,
|
||||
; i.e. brushes is a collection of brush.
|
||||
|
||||
|
||||
|
||||
|
||||
; Deprecations:
|
||||
; pika-palette-refresh
|
||||
; pika-brushes-list => pika-brushes-get-list etc.
|
||||
; pika-parasite-list => pika-get-parasite-list
|
||||
|
||||
|
||||
; refresh
|
||||
|
||||
; always succeeds
|
||||
; FIXME but wraps result in list (#t)
|
||||
(assert `(car (pika-brushes-refresh)))
|
||||
(assert `(car (pika-dynamics-refresh)))
|
||||
(assert `(car (pika-fonts-refresh)))
|
||||
(assert `(car (pika-gradients-refresh)))
|
||||
(assert `(car (pika-palettes-refresh)))
|
||||
(assert `(car (pika-patterns-refresh)))
|
||||
|
||||
|
||||
; list
|
||||
|
||||
; always succeeds
|
||||
; take an optional regex string
|
||||
(assert `(list? (car (pika-brushes-get-list ""))))
|
||||
(assert `(list? (car (pika-dynamics-get-list ""))))
|
||||
(assert `(list? (car (pika-fonts-get-list ""))))
|
||||
(assert `(list? (car (pika-gradients-get-list ""))))
|
||||
(assert `(list? (car (pika-palettes-get-list ""))))
|
||||
(assert `(list? (car (pika-patterns-get-list ""))))
|
||||
|
||||
|
||||
; listing app's collection of things not resources
|
||||
; But taking a regex
|
||||
|
||||
(assert `(list? (car (pika-buffers-get-list ""))))
|
||||
|
||||
|
||||
; listing app's other collections not resources
|
||||
; Not taking a regex
|
||||
|
||||
; FIXME the naming does not follow the pattern, should be plural parasites
|
||||
; Not: (pika-parasites-get-list "")
|
||||
(assert `(list? (car (pika-get-parasite-list))))
|
||||
|
||||
; the app, images, vectors, drawables, items
|
||||
; can all have parasites.
|
||||
; Tested elsewhere.
|
||||
|
||||
|
||||
; pika-get-images does not follow the pattern:
|
||||
; it doesn't take a regex
|
||||
; and it returns a vector of image objects (0 #())
|
||||
(assert `(vector? (cadr (pika-get-images))))
|
||||
|
||||
|
||||
|
||||
151
plug-ins/script-fu/test/tests/PDB/resource/brush.scm
Normal file
151
plug-ins/script-fu/test/tests/PDB/resource/brush.scm
Normal file
@ -0,0 +1,151 @@
|
||||
; Test methods of Brush subclass of Resource class
|
||||
|
||||
; !!! See also resource.scm
|
||||
|
||||
; !!! Testing depends on a fresh install of PIKA.
|
||||
; A prior testing failure may leave brushes in PIKA.
|
||||
; The existing brush may have the same name as hard coded in tests.
|
||||
; In future, will be possible to create new brush with same name as existing?
|
||||
|
||||
|
||||
; new
|
||||
|
||||
|
||||
; new succeeds
|
||||
; setup, not an assert
|
||||
(define testNewBrush (car (pika-brush-new "TestBrushNew")))
|
||||
|
||||
; a resource is an int ID in ScriptFu
|
||||
(assert `(number? ,testNewBrush))
|
||||
|
||||
; new returns brush of given name
|
||||
; note call superclass method
|
||||
(assert `(string=?
|
||||
(car (pika-resource-get-name ,testNewBrush))
|
||||
"TestBrushNew"))
|
||||
|
||||
|
||||
|
||||
; attributes of new brush
|
||||
|
||||
; new brush is kind generated versus raster
|
||||
(assert `(= (car (pika-brush-is-generated ,testNewBrush))
|
||||
1))
|
||||
|
||||
; angle default is 0
|
||||
(assert `(=
|
||||
(car (pika-brush-get-angle ,testNewBrush))
|
||||
0))
|
||||
|
||||
; aspect-ratio default is 1.0
|
||||
; FIXME: the doc says 0.0
|
||||
(assert `(=
|
||||
(car (pika-brush-get-aspect-ratio ,testNewBrush))
|
||||
1.0))
|
||||
|
||||
; hardness default is 0.5
|
||||
; FIXME: the doc says 0
|
||||
(assert `(=
|
||||
(car (pika-brush-get-hardness ,testNewBrush))
|
||||
0.5))
|
||||
|
||||
; shape default is GENERATED-CIRCLE
|
||||
(assert `(=
|
||||
(car (pika-brush-get-shape ,testNewBrush))
|
||||
BRUSH-GENERATED-CIRCLE))
|
||||
|
||||
; spikes default is 2
|
||||
; FIXME: docs says 0
|
||||
(assert `(=
|
||||
(car (pika-brush-get-spikes ,testNewBrush))
|
||||
2))
|
||||
|
||||
; get-radius default 5.0
|
||||
; FIXME: docs says 0
|
||||
(assert `(=
|
||||
(car (pika-brush-get-radius ,testNewBrush))
|
||||
5.0))
|
||||
|
||||
|
||||
; spacing default 20
|
||||
; FIXME: docs says 0
|
||||
(assert `(=
|
||||
(car (pika-brush-get-spacing ,testNewBrush))
|
||||
20))
|
||||
|
||||
; get-info returns a list of attributes
|
||||
; For generated, color bytes is zero
|
||||
(assert `(equal? (pika-brush-get-info ,testNewBrush)
|
||||
`(11 11 1 0)))
|
||||
|
||||
; get-pixels returns a list of attributes
|
||||
; It is is long so we don't compare.
|
||||
; This test is just that it doesn't crash or return #f.
|
||||
(assert `(pika-brush-get-pixels ,testNewBrush))
|
||||
|
||||
|
||||
|
||||
; delete
|
||||
|
||||
; can delete a new brush
|
||||
; PDB returns void, ScriptFu returns wrapped truth i.e. (#t)
|
||||
(assert `(car (pika-resource-delete ,testNewBrush)))
|
||||
|
||||
; delete was effective
|
||||
; ID is now invalid
|
||||
(assert `(= (car (pika-resource-id-is-valid ,testNewBrush))
|
||||
0))
|
||||
|
||||
|
||||
|
||||
; Kind non-generated brush
|
||||
|
||||
; Brush named "z Pepper" is non-generated and is a system brush always installed
|
||||
|
||||
; setup, not an assert
|
||||
(define testNongenBrush (car (pika-resource-get-by-name "PikaBrush" "z Pepper")))
|
||||
|
||||
; brush says itself is not generated
|
||||
|
||||
|
||||
|
||||
; Certain attributes of non-generated brush yield errors
|
||||
; angle, aspect-ratio, hardness, shape, spikes, radius
|
||||
|
||||
|
||||
; angle is not an attribute of non-generated brush
|
||||
(assert-error
|
||||
`(pika-brush-get-angle ,testNongenBrush)
|
||||
"Procedure execution of pika-brush-get-angle failed")
|
||||
|
||||
; TODO all the other attributes
|
||||
|
||||
|
||||
; Non-generated brush attributes
|
||||
|
||||
; is not generated
|
||||
(assert `(=
|
||||
(car (pika-brush-is-generated ,testNongenBrush))
|
||||
0))
|
||||
|
||||
; spacing
|
||||
(assert `(=
|
||||
(car (pika-brush-get-spacing ,testNongenBrush))
|
||||
100))
|
||||
|
||||
; pixels returns a list of attributes
|
||||
; FAIL: CRASH Inconsistency detected by ld.so: dl-runtime.c: 63: _dl_fixup: Assertion `ELFW(R_TYPE)(reloc->r_info) == ELF_MACHINE_JMP_SLOT' failed!
|
||||
; Known to fail because TS allocation of 120k byte contiguous cells for vector fails.
|
||||
; (assert `(pika-brush-get-pixels ,testNongenBrush))
|
||||
|
||||
; get-info returns a list of attributes
|
||||
(assert `(equal? (pika-brush-get-info ,testNongenBrush)
|
||||
`(180 220 1 3)))
|
||||
|
||||
|
||||
|
||||
; miscellaneous
|
||||
|
||||
; pika-brush-get-by-name returns error, when brush of that name not exists
|
||||
(assert-error '(pika-brush-get-by-name "foo")
|
||||
"Procedure execution of pika-brush-get-by-name failed on invalid input arguments: Brush 'foo' not found")
|
||||
201
plug-ins/script-fu/test/tests/PDB/resource/palette.scm
Normal file
201
plug-ins/script-fu/test/tests/PDB/resource/palette.scm
Normal file
@ -0,0 +1,201 @@
|
||||
; Test methods of palette subclass of Resource class
|
||||
|
||||
; !!! See also resource.scm
|
||||
|
||||
; !!! Testing depends on a fresh install of PIKA.
|
||||
; A prior testing failure may leave palettees in PIKA.
|
||||
; The existing palette may have the same name as hard coded in tests.
|
||||
; In future, will be possible to create new palette with same name as existing.
|
||||
|
||||
|
||||
|
||||
|
||||
; setup, not assert
|
||||
; but tests the -new method
|
||||
(define testNewPalette (car (pika-palette-new "testNewPalette")))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
; attributes of new palette
|
||||
|
||||
|
||||
; pika-palette-get-background deprecated => pika-context-get-background
|
||||
; ditto foreground
|
||||
|
||||
; new palette has given name
|
||||
; !!! Fails if not a fresh install, then name is like "testNewPalette #2"
|
||||
(assert `(string=?
|
||||
(car (pika-resource-get-name ,testNewPalette))
|
||||
"testNewPalette"))
|
||||
|
||||
; new palette has zero colors
|
||||
(assert `(= (car (pika-palette-get-color-count ,testNewPalette))
|
||||
0))
|
||||
|
||||
; new palette has empty colormap
|
||||
; (0 #())
|
||||
(assert `(= (car (pika-palette-get-colors ,testNewPalette))
|
||||
0))
|
||||
|
||||
; new palette has zero columns
|
||||
; (0 #())
|
||||
(assert `(= (car (pika-palette-get-columns ,testNewPalette))
|
||||
0))
|
||||
|
||||
; new palette is-editable
|
||||
; method on Resource class
|
||||
(assert `(= (car (pika-resource-is-editable ,testNewPalette))
|
||||
1))
|
||||
|
||||
; can set new palette in context
|
||||
; Despite having empty colormap
|
||||
(assert `(pika-context-set-palette ,testNewPalette))
|
||||
|
||||
|
||||
|
||||
; attributes of existing palette
|
||||
|
||||
; setup
|
||||
(define testBearsPalette (car (pika-palette-get-by-name "Bears")))
|
||||
|
||||
|
||||
; Max size palette is 256
|
||||
|
||||
; Bears palette has 256 colors
|
||||
(assert `(= (car (pika-palette-get-color-count ,testBearsPalette))
|
||||
256))
|
||||
|
||||
; Bears palette colormap is size 256
|
||||
; (256)
|
||||
(assert `(= (car (pika-palette-get-color-count ,testBearsPalette))
|
||||
256))
|
||||
|
||||
; Bears palette colormap array is size 256 vector of 3-tuple lists
|
||||
; (256 #((8 8 8) ... ))
|
||||
(assert `(= (vector-length (cadr (pika-palette-get-colors ,testBearsPalette)))
|
||||
256))
|
||||
|
||||
; Bears palette has zero columns
|
||||
; (0 #())
|
||||
(assert `(= (car (pika-palette-get-columns ,testBearsPalette))
|
||||
0))
|
||||
|
||||
; system palette is not editable
|
||||
(assert `(= (car (pika-resource-is-editable ,testBearsPalette))
|
||||
0))
|
||||
|
||||
|
||||
|
||||
; setting attributes of existing palette
|
||||
|
||||
; Can not change column count on system palette
|
||||
(assert-error `(pika-palette-set-columns ,testBearsPalette 1)
|
||||
"Procedure execution of pika-palette-set-columns failed")
|
||||
|
||||
|
||||
; add entry to full system palette
|
||||
|
||||
; error to add entry to palette which is non-editable and has full colormap
|
||||
(assert-error `(pika-palette-add-entry ,testBearsPalette "fooEntryName" "red")
|
||||
"Procedure execution of pika-palette-add-entry failed ")
|
||||
|
||||
|
||||
|
||||
; setting attributes of new palette
|
||||
|
||||
; succeeds
|
||||
(assert `(pika-palette-set-columns ,testNewPalette 1))
|
||||
|
||||
; effective
|
||||
(assert `(= (car (pika-palette-get-columns ,testNewPalette))
|
||||
1))
|
||||
|
||||
|
||||
; adding color "entry" to new palette
|
||||
|
||||
; add first entry returns index 0
|
||||
; result is wrapped (0)
|
||||
(assert `(= (car (pika-palette-add-entry ,testNewPalette "fooEntryName" "red"))
|
||||
0))
|
||||
|
||||
; was effective on color
|
||||
; FIXME returns ((0 0 0)) which is not "red"
|
||||
(assert `(equal? (car (pika-palette-entry-get-color ,testNewPalette 0))
|
||||
(list 0 0 0)))
|
||||
|
||||
; was effective on name
|
||||
(assert `(equal? (car (pika-palette-entry-get-name ,testNewPalette 0))
|
||||
"fooEntryName"))
|
||||
|
||||
|
||||
|
||||
; delete colormap entry
|
||||
|
||||
; succeeds
|
||||
; FIXME: the name seems backward, could be entry-delete
|
||||
(assert `(pika-palette-delete-entry ,testNewPalette 0))
|
||||
; effective, color count is back to 0
|
||||
(assert `(= (car (pika-palette-get-color-count ,testNewPalette))
|
||||
0))
|
||||
|
||||
|
||||
; adding color "entry" to new palette which is full
|
||||
|
||||
|
||||
; TODO locked palette? See issue about locking palette?
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
; delete palette
|
||||
|
||||
; can delete a new palette
|
||||
(assert `(pika-resource-delete ,testNewPalette))
|
||||
|
||||
; delete was effective
|
||||
; ID is now invalid
|
||||
(assert `(= (car(pika-resource-id-is-palette ,testNewPalette))
|
||||
0))
|
||||
|
||||
; delete was effective
|
||||
; not findable by name anymore
|
||||
; If the name DOES exist (because not started fresh) yields "substring out of bounds"
|
||||
(assert-error `(pika-palette-get-by-name "testNewPalette")
|
||||
"Procedure execution of pika-palette-get-by-name failed on invalid input arguments: Palette 'testNewPalette' not found")
|
||||
|
||||
|
||||
|
||||
|
||||
; see context.scm
|
||||
|
||||
|
||||
|
||||
|
||||
; test deprecated methods
|
||||
|
||||
; These should give warnings in Pika Error Console.
|
||||
; Now they are methods on Context, not Palette.
|
||||
|
||||
(pika-palettes-set-palette testBearsPalette)
|
||||
|
||||
(pika-palette-swap-colors)
|
||||
(pika-palette-set-foreground "pink")
|
||||
(pika-palette-set-background "purple")
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
1
plug-ins/script-fu/test/tests/PDB/resource/readme.md
Normal file
1
plug-ins/script-fu/test/tests/PDB/resource/readme.md
Normal file
@ -0,0 +1 @@
|
||||
See also a plugin in scripts/test/resource-class/
|
||||
@ -0,0 +1,8 @@
|
||||
; test operations on resource pool
|
||||
|
||||
; TODO
|
||||
|
||||
; pika-resource-rename
|
||||
; pika-resource-duplicate
|
||||
; pika-resource-delete
|
||||
; pika-resource-rename
|
||||
12
plug-ins/script-fu/test/tests/PDB/resource/resource.scm
Normal file
12
plug-ins/script-fu/test/tests/PDB/resource/resource.scm
Normal file
@ -0,0 +1,12 @@
|
||||
; Test methods of Resource class
|
||||
|
||||
; This is currently empty of tests
|
||||
|
||||
; See brush.scm, palette.scm etc. for test of subclasses of Resource
|
||||
|
||||
; See resource-ops.scm for tests of:
|
||||
;pika-resource-delete -duplicate -rename
|
||||
|
||||
; See context/context-resource.scm
|
||||
; for tests of generic methods
|
||||
; e.g. pika-resource-get-name -id-is-valid -is-editable
|
||||
107
plug-ins/script-fu/test/tests/PDB/selection/selection-from.scm
Normal file
107
plug-ins/script-fu/test/tests/PDB/selection/selection-from.scm
Normal file
@ -0,0 +1,107 @@
|
||||
; test PDB methods that change selection from existing selection
|
||||
|
||||
|
||||
; setup
|
||||
; Reusing image 10
|
||||
(define testImage 10)
|
||||
|
||||
|
||||
; Test a selection-changing function
|
||||
; starting from selection None.
|
||||
;
|
||||
; The testFunction takes a "step" arg
|
||||
; and does not change the selection bounds.
|
||||
|
||||
; {none <func> is-empty} yields true
|
||||
; {none <func>} is not an error
|
||||
|
||||
(define (test-selection-change-from-none testFunction testImage)
|
||||
; Starting state: selection none
|
||||
(assert `(pika-selection-none ,testImage))
|
||||
; test the testFunction
|
||||
(assert `(,testFunction
|
||||
,testImage
|
||||
4 )) ; radius or step
|
||||
; expect selection is still empty
|
||||
(assert `(= (car (pika-selection-is-empty ,testImage))
|
||||
1))
|
||||
; expect since there is no selection, the bounds are the entire image
|
||||
(assert `(equal? (cdr (pika-selection-bounds ,testImage))
|
||||
'(0 0 21 22)))
|
||||
)
|
||||
|
||||
(define (test-selection-change-from-all testFunction testImage isIdempotent)
|
||||
; Starting state: selection all
|
||||
(assert `(pika-selection-all ,testImage))
|
||||
; test the testFunction
|
||||
(assert `(,testFunction
|
||||
,testImage
|
||||
4 )) ; radius or step
|
||||
|
||||
(if isIdempotent
|
||||
(begin
|
||||
; expect selection is still not empty
|
||||
(assert `(= (car (pika-selection-is-empty ,testImage))
|
||||
0))
|
||||
; expect selection bounds are still entire image
|
||||
(assert `(equal? (cdr (pika-selection-bounds ,testImage))
|
||||
'(0 0 21 22)))))
|
||||
)
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
; test selection methods that change by a pixel amount
|
||||
(test-selection-change-from-none pika-selection-feather testImage)
|
||||
(test-selection-change-from-none pika-selection-grow testImage)
|
||||
(test-selection-change-from-none pika-selection-shrink testImage)
|
||||
(test-selection-change-from-none pika-selection-border testImage)
|
||||
|
||||
; feather and grow from all are idempotent
|
||||
(test-selection-change-from-all pika-selection-feather testImage #t)
|
||||
(test-selection-change-from-all pika-selection-grow testImage #t)
|
||||
|
||||
(test-selection-change-from-all pika-selection-shrink testImage #f)
|
||||
; shrink from all changes bounds
|
||||
(assert `(equal? (cdr (pika-selection-bounds ,testImage))
|
||||
'(4 4 17 18)))
|
||||
(test-selection-change-from-all pika-selection-border testImage #f)
|
||||
; border from all empties the selection
|
||||
(assert `(= (car (pika-selection-is-empty ,testImage))
|
||||
1))
|
||||
|
||||
|
||||
|
||||
|
||||
; Effectiveness
|
||||
; When starting from a typical selection (not empty, not all)
|
||||
|
||||
; TODO feather effective?
|
||||
; Might feather change bounds?
|
||||
|
||||
; grow is effective
|
||||
; bounds are larger
|
||||
; TODO
|
||||
(assert `(equal? (cdr (pika-selection-bounds ,testImage))
|
||||
'(0 0 21 22)))
|
||||
|
||||
; TODO test flood effective: holes were filled
|
||||
; Can't do it without knowing how many pixels are selected?
|
||||
; Knowing bounds is not adequate.
|
||||
|
||||
; Simple tests of success
|
||||
(assert `(pika-selection-flood ,testImage))
|
||||
(assert `(pika-selection-invert ,testImage))
|
||||
(assert `(pika-selection-sharpen ,testImage))
|
||||
(assert `(pika-selection-translate
|
||||
,testImage
|
||||
4 4))
|
||||
|
||||
; TODO invert none is all and vice versa
|
||||
|
||||
; TODO translate effective
|
||||
; TODO translate by large offset is empty selection
|
||||
; TODO sharpen is effective at removing antialiasing
|
||||
|
||||
; save creates a new channel
|
||||
111
plug-ins/script-fu/test/tests/PDB/selection/selection.scm
Normal file
111
plug-ins/script-fu/test/tests/PDB/selection/selection.scm
Normal file
@ -0,0 +1,111 @@
|
||||
; Test methods of selection class of the PDB
|
||||
|
||||
|
||||
|
||||
; setup
|
||||
|
||||
(define testImage (car (pika-image-new 21 22 RGB)))
|
||||
|
||||
|
||||
; get-selection yields an ID.
|
||||
; Image always yields a selection object.
|
||||
; It is a singleton.
|
||||
(define testSelection (car (pika-image-get-selection testImage)))
|
||||
|
||||
|
||||
|
||||
|
||||
; The returned ID is-a Selection
|
||||
(assert `(= (car (pika-item-id-is-selection ,testSelection))
|
||||
1))
|
||||
|
||||
; !!! Note there is little use for a Selection instance.
|
||||
; There are no methods on the class per se i.e. taking the instance ID.
|
||||
; Except for methods on the superclass Item of subclass Selection.
|
||||
;
|
||||
; Instead the methods seem to be on an image.
|
||||
; Its not clear whether changing the selection in an image
|
||||
; also changes the singleton Selection instance,
|
||||
; and there is no way of knowing, since the Selection instance
|
||||
; has no methods.
|
||||
|
||||
; selection on new image is empty
|
||||
; !!! Requre no prior test on this image selected
|
||||
; !!! Arg is the image, not the selection object instance.
|
||||
(assert `(= (car (pika-selection-is-empty ,testImage))
|
||||
1))
|
||||
|
||||
; selection bounds yields (1 0 0 21 22)
|
||||
; First element of tuple is 0 (false)
|
||||
; indicates user or program has not made selection
|
||||
(assert `(= (car (pika-selection-bounds ,testImage))
|
||||
0))
|
||||
; selection bounds equal bounds of image
|
||||
(assert `(equal? (cdr (pika-selection-bounds ,testImage))
|
||||
'(0 0 21 22)))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
; select all and none
|
||||
|
||||
; select all succeeds
|
||||
(assert `(pika-selection-all ,testImage))
|
||||
; !!! A selection operation does not create a new selection object
|
||||
; i.e. ID is the same.
|
||||
; get-selection yields same singleton on image
|
||||
(assert `(= (car (pika-image-get-selection ,testImage))
|
||||
,testSelection))
|
||||
; after select all, selection bound indicates selection created
|
||||
(assert `(= (car (pika-selection-bounds ,testImage))
|
||||
1))
|
||||
; and now is-empty is false
|
||||
(assert `(= (car (pika-selection-is-empty ,testImage))
|
||||
0))
|
||||
|
||||
|
||||
; clear and none are the synonyms
|
||||
|
||||
; clear does not invalidate a prior selection object
|
||||
; i.e. get-selection returns same ID
|
||||
|
||||
; clear makes selection bounds equal entire image
|
||||
; TODO
|
||||
|
||||
; select none succeeds
|
||||
(assert `(pika-selection-none ,testImage))
|
||||
; effective: is-empty is true
|
||||
(assert `(= (car (pika-selection-is-empty ,testImage))
|
||||
1))
|
||||
; same singleton on image exists
|
||||
(assert `(= (car (pika-image-get-selection ,testImage))
|
||||
,testSelection))
|
||||
|
||||
|
||||
; misc selection operations
|
||||
|
||||
; pika-selection-value
|
||||
|
||||
|
||||
; change selection to totally new selection
|
||||
; Not a function of existing selection, by color or shape.
|
||||
|
||||
;pika-image-select-color
|
||||
; ,testImage
|
||||
; CHANNEL-OP-ADD
|
||||
; drawable
|
||||
; "red")
|
||||
|
||||
; pika-image-select-contiguous-color
|
||||
; ellipse
|
||||
; polygon
|
||||
; rectangle
|
||||
; round-rectangle
|
||||
|
||||
|
||||
|
||||
|
||||
; pika-selection-float is tested elsewhere
|
||||
; It is not an op on the selection, but an op on the image that uses the selection.
|
||||
; See pika-image-floating-selection
|
||||
150
plug-ins/script-fu/test/tests/PDB/text-layer/text-layer-new.scm
Normal file
150
plug-ins/script-fu/test/tests/PDB/text-layer/text-layer-new.scm
Normal file
@ -0,0 +1,150 @@
|
||||
; tests of TextLayer class
|
||||
|
||||
; !!! Some methods tested here are named strangely:
|
||||
; text-fontname returns a new TextLayer
|
||||
|
||||
|
||||
|
||||
|
||||
; setup
|
||||
|
||||
; Require image has no layer
|
||||
(define testImage (car (pika-image-new 21 22 RGB)))
|
||||
|
||||
; setup (not an assert )
|
||||
(define
|
||||
testTextLayer
|
||||
(car (pika-text-layer-new
|
||||
testImage
|
||||
"textOfTestTextLayer" ; text
|
||||
"fontName" ; fontname
|
||||
30 ; fontsize
|
||||
UNIT-PIXEL)))
|
||||
|
||||
|
||||
; !!!! fontName is not valid
|
||||
; The text displays anyway, using some font family, without error.
|
||||
; The docs don't seem to say which font family is used.
|
||||
; TODO better documentation
|
||||
; The text layer still says it is using the given font family.
|
||||
; TODO yield actual font family used.
|
||||
|
||||
; !!! UNIT-PIXEL PikaUnitsType is distinct from PIXELS PikaSizeType
|
||||
|
||||
|
||||
; TODO test UNIT-POINT
|
||||
|
||||
|
||||
; is-a TextLayer
|
||||
(assert `(= (car (pika-item-id-is-text-layer ,testTextLayer))
|
||||
1))
|
||||
|
||||
; text layer is not in image yet
|
||||
(assert `(= (car (pika-image-get-layers ,testImage))
|
||||
0))
|
||||
|
||||
; adding layer to image succeeds
|
||||
(assert `(pika-image-insert-layer
|
||||
,testImage
|
||||
,testTextLayer ; layer
|
||||
0 ; parent
|
||||
0 )) ; position within parent
|
||||
|
||||
|
||||
|
||||
|
||||
; attributes
|
||||
|
||||
; antialias default true
|
||||
; FIXME doc says false
|
||||
(assert `(= (car (pika-text-layer-get-antialias ,testTextLayer))
|
||||
1))
|
||||
|
||||
; base-direction default TEXT-DIRECTION-LTR
|
||||
(assert `(= (car (pika-text-layer-get-base-direction ,testTextLayer))
|
||||
TEXT-DIRECTION-LTR))
|
||||
|
||||
; language default "C"
|
||||
(assert `(string=? (car (pika-text-layer-get-language ,testTextLayer))
|
||||
"C"))
|
||||
|
||||
; TODO other attributes
|
||||
|
||||
; TODO setters effective
|
||||
|
||||
; attributes as given
|
||||
|
||||
; text
|
||||
(assert `(string=? (car (pika-text-layer-get-text ,testTextLayer))
|
||||
"textOfTestTextLayer"))
|
||||
; font
|
||||
(assert `(string=? (car (pika-text-layer-get-font ,testTextLayer))
|
||||
"fontName"))
|
||||
; font-size
|
||||
(assert `(= (car (pika-text-layer-get-font-size ,testTextLayer))
|
||||
30))
|
||||
|
||||
; is no method to get fontSize unit
|
||||
|
||||
|
||||
; misc ops
|
||||
|
||||
; vectors from text succeeds
|
||||
(assert `(pika-vectors-new-from-text-layer
|
||||
,testImage
|
||||
,testTextLayer))
|
||||
; not capturing returned ID of vectors
|
||||
|
||||
|
||||
|
||||
|
||||
; misc method
|
||||
|
||||
; pika-text-get-extents-fontname
|
||||
; Yields extent of rendered text, independent of image or layer.
|
||||
; Extent is (width, height, ascent, descent) in unstated units, pixels?
|
||||
; Does not affect image.
|
||||
(assert `(= (car (pika-text-get-extents-fontname
|
||||
"zed" ; text
|
||||
32 ; fontsize
|
||||
POINTS ; size units. !!! See UNIT-PIXEL
|
||||
"fontName" )) ; fontname
|
||||
57))
|
||||
; usual result is (57 38 30 -8)
|
||||
|
||||
|
||||
|
||||
; alternate method for creating text layer
|
||||
|
||||
|
||||
; pika-text-fontname creates text layer AND inserts it into image
|
||||
; setup, not assert
|
||||
(define
|
||||
testTextLayer2
|
||||
(car (pika-text-fontname
|
||||
testImage
|
||||
-1 ; drawable. -1 means NULL means create new text layer
|
||||
0 0 ; coords
|
||||
"bar" ; text
|
||||
1 ; border size
|
||||
1 ; antialias true
|
||||
31 ; fontsize
|
||||
PIXELS ; size units. !!! See UNIT-PIXEL
|
||||
"fontName" )))
|
||||
|
||||
|
||||
; error to insert layer created by pika-text-fontname
|
||||
; TODO make the error message matching by prefix only
|
||||
(assert-error `(pika-image-insert-layer
|
||||
,testImage
|
||||
,testTextLayer2
|
||||
0 ; parent
|
||||
0 ) ; position within parent
|
||||
"Procedure execution of pika-image-insert-layer failed on invalid input arguments: ")
|
||||
; "Item 'bar' (17) has already been added to an image"
|
||||
|
||||
|
||||
|
||||
; for debugging: display
|
||||
(assert `(= (car (pika-display-new ,testImage))
|
||||
1))
|
||||
86
plug-ins/script-fu/test/tests/PDB/vectors-new.scm
Normal file
86
plug-ins/script-fu/test/tests/PDB/vectors-new.scm
Normal file
@ -0,0 +1,86 @@
|
||||
|
||||
; Test methods of vector class of the PDB
|
||||
|
||||
; aka Path. Image has set of Paths. Path has strokes.
|
||||
|
||||
|
||||
; setup
|
||||
|
||||
(define testImage (car (pika-image-new 21 22 RGB)))
|
||||
(pika-message "testImage is:" (number->string testImage))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
; ID methods
|
||||
|
||||
; ensure ID 0 and negative are not vectors
|
||||
; FIXME #f/#t
|
||||
(assert '(= (car (pika-item-id-is-vectors 0))
|
||||
0)) ; FUTURE #f
|
||||
|
||||
; Test valid ID is tested drive-by
|
||||
|
||||
|
||||
|
||||
; image get/set vectors methods
|
||||
; This sequence of tests requires image 6 has no vectors yet
|
||||
|
||||
; ensure get-vectors from image having no vectors yields zero vectors
|
||||
; FUTURE: returns just #(), not (0 #())
|
||||
(assert `(= (car (pika-image-get-vectors ,testImage))
|
||||
0))
|
||||
|
||||
|
||||
; setup, not an assert
|
||||
; vectors-new succeeds
|
||||
(define testPath (car (pika-vectors-new
|
||||
testImage
|
||||
"Test Path")))
|
||||
|
||||
|
||||
; !!! id is valid even though vectors is not inserted in image
|
||||
(assert `(= (car (pika-item-id-is-vectors ,testPath))
|
||||
1)) ; #t
|
||||
|
||||
; new path name is as given
|
||||
(assert `(string=?
|
||||
(car (pika-item-get-name ,testPath))
|
||||
"Test Path"))
|
||||
|
||||
; new vectors is not in image yet
|
||||
; image still has count of vectors == 0
|
||||
(assert `(= (car (pika-image-get-vectors ,testImage))
|
||||
0))
|
||||
|
||||
; new path has no strokes
|
||||
; path has stroke count == 0
|
||||
(assert `(= (car (pika-vectors-get-strokes ,testPath))
|
||||
0))
|
||||
|
||||
|
||||
; insert vector in image yields (#t)
|
||||
(assert `(car (pika-image-insert-vectors
|
||||
,testImage
|
||||
,testPath
|
||||
0 0))) ; parent=0 position=0
|
||||
|
||||
; image with inserted vectors now has count of vectors == 1
|
||||
(assert `(= (car (pika-image-get-vectors ,testImage))
|
||||
1))
|
||||
|
||||
; FIXME: crashes in pikavectors-export.c line 234
|
||||
; possibly because path has no strokes?
|
||||
; export to string succeeds
|
||||
;(assert `(pika-vectors-export-to-string
|
||||
; ,testImage
|
||||
; ,testPath))
|
||||
|
||||
; export-to-string all
|
||||
; FAIL: crashes
|
||||
; PDB doc says 0 should work, and ScriptFu is marshalling to a null PikaVectors*
|
||||
; so the PDB function in C is at fault?
|
||||
;(assert `(pika-vectors-export-to-string
|
||||
; ,testImage
|
||||
; 0))
|
||||
179
plug-ins/script-fu/test/tests/TS/atom2string.scm
Normal file
179
plug-ins/script-fu/test/tests/TS/atom2string.scm
Normal file
@ -0,0 +1,179 @@
|
||||
|
||||
; test atom->string function
|
||||
|
||||
; atom->string is not R5RS
|
||||
; Instead, it is TinyScheme specific.
|
||||
|
||||
; atom->string works for atoms of type: number, char, string, byte, symbol.
|
||||
; This is not the usual definition of atom.
|
||||
; Others define atom as anything but list and pair.
|
||||
|
||||
; For atom of type number,
|
||||
; accepts an optional second arg: <base> in [2,8,10,16]
|
||||
; Meaning arithmetic base binary, octal, decimal, hexadecimal.
|
||||
; For atoms of other types, passing a base returns an error.
|
||||
|
||||
|
||||
; The REPL uses an internal C function atom2str()
|
||||
; which is not exposed in the TS language.
|
||||
; It *DOES* represent every object (all atoms) as strings.
|
||||
; But the representation is sometimes a string that can
|
||||
; be turned around and evaluated,
|
||||
; which is not the same string as atom->string produces.
|
||||
|
||||
; !!! Note readstring() internal function
|
||||
; accepts and reduces C "escaped" string representations
|
||||
; i.e. \x07 or \t for tab.
|
||||
; Thus in a test, a double-quoted string enclosing
|
||||
; an escape sequence can be equivalent to a
|
||||
; string for a char atom.
|
||||
|
||||
|
||||
|
||||
; normal tests (without error)
|
||||
|
||||
|
||||
; number
|
||||
|
||||
; number, integer aka fixnum
|
||||
(assert `(string=? (atom->string 1)
|
||||
"1"))
|
||||
|
||||
; number, float aka flonum
|
||||
(assert `(string=? (atom->string 1.0)
|
||||
"1.0"))
|
||||
|
||||
; FIXME the above is known to fail in German:
|
||||
; currently prints 1,0.
|
||||
; To test, set locale to German and retest.
|
||||
|
||||
; There are no other numeric types in TinyScheme.
|
||||
; Refer to discussions of "Lisp numeric tower"
|
||||
|
||||
|
||||
|
||||
; char
|
||||
|
||||
; ASCII, i.e. fits in 8-bit byte
|
||||
|
||||
; char, ASCII, printing and visible
|
||||
(assert `(string=? (atom->string 'a)
|
||||
"a"))
|
||||
|
||||
; char, ASCII, non-printing, whitespace
|
||||
(assert `(string=? (atom->string #\space)
|
||||
" "))
|
||||
|
||||
; Note the char between quotes is a tab char
|
||||
; whose display when viewing this source depends on editor.
|
||||
; Some editors will show just a single white glyph.
|
||||
;
|
||||
; Note also that the SF Console will print "\t"
|
||||
; i.e. this is not a test of the REPL.
|
||||
(assert `(string=? (atom->string #\tab)
|
||||
" "))
|
||||
; Note the char between quotes is a newline char
|
||||
(assert `(string=? (atom->string #\newline)
|
||||
"
|
||||
"))
|
||||
; Note between quotes is an escaped return char,
|
||||
; which readstring() converts to a single char
|
||||
; decimal 13, hex 0d
|
||||
(assert `(string=? (atom->string #\return)
|
||||
"\x0d"))
|
||||
|
||||
; char, ASCII, non-printing control
|
||||
(assert `(string=? (atom->string #\x7)
|
||||
""))
|
||||
; !!! This also passes, because readstring converts
|
||||
; the \x.. escape sequence to a char.
|
||||
(assert `(string=? (atom->string #\x7)
|
||||
"\x07"))
|
||||
; !!! Note the REPL for (atom->string #\x7)
|
||||
; yields "\x07" which is not a sharp char expr wrapped in quotes
|
||||
; but is a string that can be turned around and evaluated
|
||||
; to a string containing one character.
|
||||
|
||||
|
||||
|
||||
; multi-byte UTF-8 encoded chars
|
||||
|
||||
; see more tests in sharp-expr-unichar.scm
|
||||
|
||||
; char, unichar outside the ASCII range
|
||||
(assert `(string=? (atom->string #\λ)
|
||||
"λ"))
|
||||
|
||||
|
||||
|
||||
; symbol
|
||||
(assert `(string=? (atom->string 'pika-message)
|
||||
"pika-message"))
|
||||
; symbol having multibyte char
|
||||
(assert `(string=? (atom->string 'λ)
|
||||
"λ"))
|
||||
|
||||
; string
|
||||
(assert `(string=? (atom->string "foo")
|
||||
"foo"))
|
||||
; string having multibyte char
|
||||
(assert `(string=? (atom->string "λ")
|
||||
"λ"))
|
||||
|
||||
|
||||
; byte
|
||||
|
||||
; Note that readstring() accepts and reduces \x.. notation.
|
||||
|
||||
; Test against a glyph
|
||||
(assert `(string=? (atom->string (integer->byte 31))
|
||||
" "))
|
||||
;Test for equivalence to reduced string
|
||||
(assert `(string=? (atom->string (integer->byte 1))
|
||||
"\x01"))
|
||||
(assert `(string=? (atom->string (integer->byte 255))
|
||||
"\xff"))
|
||||
; integer->byte truncates a number that does not fit in 8-bits
|
||||
(assert `(string=? (atom->string (integer->byte 256))
|
||||
"\xff"))
|
||||
|
||||
; Note some TinyScheme C code uses printf ("%lu", var) where var is unsigned char,
|
||||
; and that prints unsigned char in this format.
|
||||
; The above tests are not a test of that code path.
|
||||
|
||||
|
||||
; test optional base arg for numeric atom
|
||||
|
||||
; binary, octal, decimal, hexadecimal
|
||||
(assert `(string=? (atom->string 15 2)
|
||||
"1111"))
|
||||
(assert `(string=? (atom->string 15 8)
|
||||
"17"))
|
||||
(assert `(string=? (atom->string 15 10)
|
||||
"15"))
|
||||
(assert `(string=? (atom->string 15 16)
|
||||
"f"))
|
||||
|
||||
; passing <base> arg for non-numeric atom is error
|
||||
(assert-error `(atom->string (integer->byte 255) 2)
|
||||
"atom->string: bad base:")
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
; tests of abnormality i.e. error messages
|
||||
|
||||
; atom->string does not work for [#t, nil, closure, port, list, vector, foreign function]
|
||||
|
||||
; foreign function
|
||||
(assert-error `(atom->string pika-message)
|
||||
"atom->string: not an atom:")
|
||||
; nil aka '()
|
||||
(assert-error `(atom->string '() )
|
||||
"atom->string: not an atom:")
|
||||
; #t
|
||||
(assert-error `(atom->string #t )
|
||||
"atom->string: not an atom:")
|
||||
|
||||
; TODO port etc.
|
||||
78
plug-ins/script-fu/test/tests/TS/cond-expand.scm
Normal file
78
plug-ins/script-fu/test/tests/TS/cond-expand.scm
Normal file
@ -0,0 +1,78 @@
|
||||
|
||||
; Test cases for cond-expand in ScriptFu interpreter of PIKA app.
|
||||
|
||||
; cond-expand is SRFI-0
|
||||
; https://www.gnu.org/software/mit-scheme/documentation/stable/mit-scheme-ref/cond_002dexpand-_0028SRFI-0_0029.html
|
||||
|
||||
; ScriptFu cond-expand is defined in the tail of script-fu.init
|
||||
|
||||
; This tests existing ScriptFu code, which is not a full implementation of cond-expand.
|
||||
; ScriptFu omits "else" clause.
|
||||
; PIKA issue #9729 proposes an enhancement that adds else clause to cond-expand, etc.
|
||||
|
||||
|
||||
; *features* is a defined symbol that names features of language
|
||||
(assert '(equal?
|
||||
*features*
|
||||
'(srfi-0 tinyscheme)))
|
||||
|
||||
; srfi-0 is not a defined symbol
|
||||
(assert-error '(srfi-0)
|
||||
"eval: unbound variable:")
|
||||
; Note that *error-hook* erroneously omits tail of error message
|
||||
|
||||
|
||||
|
||||
; simple condition on one supported feature
|
||||
(assert '(equal?
|
||||
(cond-expand (tinyscheme "implements tinyscheme"))
|
||||
"implements tinyscheme"))
|
||||
|
||||
; simple clause on one unsupported feature
|
||||
; Since the condition fails there is no expansion.
|
||||
; Since there is no 'else clause', there is no expansion for false condition.
|
||||
; The cond-expand doc says:
|
||||
; "It either expands into the body of one of its clauses or signals an error during syntactic processing."
|
||||
; Yielding #t is not "signals an error" so is not correct.
|
||||
; This documents what ScriptFu does, until we decide whether and how to fix it.
|
||||
(assert '(equal?
|
||||
(cond-expand (srfi-38 "implements srfi-38"))
|
||||
#t))
|
||||
|
||||
; multiple clauses
|
||||
(assert '(equal?
|
||||
(cond-expand
|
||||
(srfi-38 "implements srfi-38")
|
||||
((not srfi-38) "not implements srfi-38"))
|
||||
"not implements srfi-38"))
|
||||
|
||||
|
||||
; clauses start with 'and', 'or', or 'not'
|
||||
|
||||
; 'not clause'
|
||||
(assert '(equal?
|
||||
(cond-expand ((not srfi-38) "not implements srfi-38"))
|
||||
"not implements srfi-38"))
|
||||
|
||||
; 'and clause' having two logical conditions that are true
|
||||
(assert '(equal?
|
||||
(cond-expand ((and tinyscheme srfi-0) "implements both tinyscheme and srfi-0"))
|
||||
"implements both tinyscheme and srfi-0"))
|
||||
|
||||
; 'or clause' having two logical conditions, one of which is false
|
||||
(assert '(equal?
|
||||
(cond-expand ((or tinyscheme srfi-38) "implements tinyscheme or srfi-38"))
|
||||
"implements tinyscheme or srfi-38"))
|
||||
|
||||
|
||||
; nested logical clauses
|
||||
(assert '(equal?
|
||||
(cond-expand ((or srfi-38 (and tinyscheme srfi-0)) "implements srfi-38 or tinyscheme and srfi-0"))
|
||||
"implements srfi-38 or tinyscheme and srfi-0"))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
106
plug-ins/script-fu/test/tests/TS/integer2char.scm
Normal file
106
plug-ins/script-fu/test/tests/TS/integer2char.scm
Normal file
@ -0,0 +1,106 @@
|
||||
; test integer->char function
|
||||
|
||||
; Is R5RS, but ScriptFu supports unicode
|
||||
|
||||
; Also test the inverse operation: char->integer
|
||||
|
||||
; TinyScheme does not implement some char functions in MIT Scheme.
|
||||
; For example char->name char->digit
|
||||
|
||||
; TODO test char=? char-upcase
|
||||
|
||||
; General test strategy:
|
||||
; Generate char atom using integer->char.
|
||||
; Convert each such char atom to string.
|
||||
; In all cases where it was possible to create such a string, test length is 1.
|
||||
|
||||
; See also number->string which is similar to (atom->string (integer->char <foo>) <base>)
|
||||
|
||||
|
||||
; integer->char takes only unsigned (positive or zero) codepoints
|
||||
; -1 in twos complement is out of range of UTF-8
|
||||
(assert-error `(integer->char -1)
|
||||
"integer->char: argument 1 must be: non-negative integer")
|
||||
|
||||
|
||||
|
||||
; ASCII NUL character.
|
||||
|
||||
; 0 is a valid codepoint.
|
||||
; But ASCII null terminates the string early, so to speak.
|
||||
|
||||
; Since null byte terminates string early
|
||||
; the repr in the REPL of codepoint 0 is #\
|
||||
|
||||
; re-test
|
||||
; (integer->char 0)
|
||||
; #\
|
||||
|
||||
(assert (= (char->integer (integer->char 0))
|
||||
0))
|
||||
|
||||
; codepoint zero equals its sharp char hex repr
|
||||
(assert (equal? (integer->char 0)
|
||||
#\x0))
|
||||
|
||||
; Converting the atom to string yields an empty string
|
||||
(assert `(string=? (atom->string (integer->char 0))
|
||||
""))
|
||||
|
||||
; You can also represent as escaped hex "x\00"
|
||||
(assert `(string=? "\x00"
|
||||
""))
|
||||
|
||||
; Escaped hex must have more than one hex digit.
|
||||
; Testing framework can't test: (assert-error `(string? "\x0") "Error reading string ")
|
||||
|
||||
; re-test REPL
|
||||
; (null? "\x0")
|
||||
; Error: Error reading string
|
||||
|
||||
|
||||
; the first non-ASCII character (often the euro sign)
|
||||
|
||||
(assert (integer->char 128))
|
||||
|
||||
; converted string is equivalent to a string literal that displays
|
||||
(assert `(string=? (atom->string (integer->char 128))
|
||||
""))
|
||||
|
||||
; first Unicode character outside the 8-bit range
|
||||
|
||||
; evaluates without complaint
|
||||
(assert (integer->char 256))
|
||||
|
||||
(assert (= (char->integer (integer->char 256))
|
||||
256))
|
||||
|
||||
; length of converted string is 1
|
||||
; The length is count of characters, not the count of bytes.
|
||||
(assert `(= (string-length (atom->string (integer->char 256)))
|
||||
1))
|
||||
|
||||
; converted string is equivalent to a string literal that displays
|
||||
(assert `(string=? (atom->string (integer->char 256))
|
||||
"Ā"))
|
||||
|
||||
|
||||
; first Unicode character outside the Basic Multilingual Plane
|
||||
(assert (integer->char 65536))
|
||||
|
||||
(assert (= (char->integer (integer->char 65536))
|
||||
65536))
|
||||
|
||||
(assert `(= (string-length (atom->string (integer->char 65536)))
|
||||
1))
|
||||
|
||||
; The usual glyph in some editors is a wide box with these digits inside:
|
||||
; 010
|
||||
; 000
|
||||
; Other editors may display a small empty box.
|
||||
(assert `(string=? (atom->string (integer->char 65536))
|
||||
"𐀀"))
|
||||
|
||||
; re-test REPL yields a sharp char expr
|
||||
; (integer->char 65536)
|
||||
; #\𐀀
|
||||
55
plug-ins/script-fu/test/tests/TS/no-memory.scm
Normal file
55
plug-ins/script-fu/test/tests/TS/no-memory.scm
Normal file
@ -0,0 +1,55 @@
|
||||
; test memory limits in TS
|
||||
|
||||
; TS is known to be non-robust in face of memory exhaustion.
|
||||
; See Manual.txt which says "TinyScheme is known to misbehave when memory is exhausted."
|
||||
|
||||
; numeric constants from tinyscheme-private.h
|
||||
|
||||
; There is no document (only the source code itself)
|
||||
; explaining the limits.
|
||||
; The limits here are from experiments.
|
||||
|
||||
; These only test the limits.
|
||||
; Methods on the objects (string, vector, etc.) are tested elsewhere.
|
||||
|
||||
; Symbol limits
|
||||
|
||||
; There is no defined limit on count of symbols.
|
||||
; The objlist is a hash table, entries allocated from cells.
|
||||
; The lists in the hash table are practically unlimited.
|
||||
|
||||
|
||||
; String limits
|
||||
|
||||
; Strings are malloced.
|
||||
; Limit on string size derives from OS malloc limits.
|
||||
; No practical limit in ScriptFu.
|
||||
|
||||
; Seems to work
|
||||
; (make-string 260000 #\A)
|
||||
|
||||
|
||||
; Vector limits.
|
||||
|
||||
; A vector is contiguous cells.
|
||||
; TS allocates in segments.
|
||||
|
||||
|
||||
; A vector can be no larger than two segments?
|
||||
|
||||
; succeeds
|
||||
(assert '(make-vector 25000))
|
||||
; REPL shows as #(() () ... ()) i.e. a vector of NIL, not initialized
|
||||
|
||||
; might not crash?
|
||||
(define testVector (make-vector 25001))
|
||||
|
||||
; ????
|
||||
(assert `(vector-fill! ,testVector 1))
|
||||
|
||||
; seems to hang
|
||||
; (assert '(make-vector 50001))
|
||||
|
||||
; seems to crash
|
||||
; (assert '(make-vector 200000))
|
||||
|
||||
233
plug-ins/script-fu/test/tests/TS/sharp-expr-char.scm
Normal file
233
plug-ins/script-fu/test/tests/TS/sharp-expr-char.scm
Normal file
@ -0,0 +1,233 @@
|
||||
; Tests of sharp char expressions in ScriptFu
|
||||
|
||||
; This only tests:
|
||||
; "sharp character" #\<c>
|
||||
; "sharp character hex" #\x<hex digits>
|
||||
; sharp expressions for whitespace
|
||||
; See also:
|
||||
; sharp-expr.scm
|
||||
; sharp-expr-number.scm
|
||||
|
||||
; This also only tests a subset: the ASCII subset.
|
||||
; See also: sharp-expr-unichar.scm
|
||||
|
||||
; #\<char> denotes a character constant where <char> is one character
|
||||
; The one character may be multiple bytes in UTF-8,
|
||||
; but should appear in the display as a single glyph,
|
||||
; but may appear as a box glyph for unichar chars outside ASCII.
|
||||
|
||||
; #\x<x> denotes a character constant where <x> is a sequence of hex digits
|
||||
; See mk_sharp_const()
|
||||
|
||||
; #\space #\newline #\return and #\tab also denote character constants.
|
||||
|
||||
; sharp backslash space "#\ " parses as a token and yields a char atom.
|
||||
; See the code, there is a space here: " tfodxb\\"
|
||||
; See the test below.
|
||||
|
||||
; #U+<x> notation for unichar character constants is not in ScriptFu
|
||||
|
||||
; Any sharp character followed by characters not described above
|
||||
; MAY optionally be a sharp expression when a program
|
||||
; uses the "sharp hook" by defining symbol *sharp-hook* .
|
||||
|
||||
|
||||
|
||||
|
||||
; sharp constants for whitespace
|
||||
|
||||
; codepoints tab 9, newline 10, return 13, space 32 (aka whitespace)
|
||||
; TinyScheme and ScriptFu prints these solitary unichars by a string representation,
|
||||
; but only when they are not in a string!
|
||||
; This subset of codepoints are ignored by the parser as whitespace.
|
||||
; It is common for older scripts to use sharp expression constants for these codepoints.
|
||||
(assert '(equal? (integer->char 9) #\tab))
|
||||
(assert '(equal? (integer->char 10) #\newline))
|
||||
(assert '(equal? (integer->char 13) #\return))
|
||||
(assert '(equal? (integer->char 32) #\space))
|
||||
|
||||
|
||||
|
||||
; sharp constant character
|
||||
|
||||
; Unicode codepoints in range [33, 126]
|
||||
; e.g. the letter A, ASCII 65
|
||||
(assert '(equal? (integer->char 65) #\A))
|
||||
(assert '(char? #\A))
|
||||
(assert '(atom? #\A))
|
||||
|
||||
; Tests of functions using a non-printing, control character ASCII
|
||||
; Codepoint BEL \x7
|
||||
(assert '(equal? (integer->char 7) #\))
|
||||
(assert '(char? #\))
|
||||
(assert '(atom? #\))
|
||||
; string function takes sequence of chars
|
||||
(assert (equal? (string #\) ""))
|
||||
|
||||
; Unicode codepoints [0-8][11-12][14-31]
|
||||
; (less than 32 excepting tab 9, newline 10, return 13)
|
||||
; The "non-printing" characters
|
||||
; e.g. 7, the character that in ancient times rang a bell sound
|
||||
|
||||
; Upstream TinyScheme prints these differently from ScriptFu, as a string repr of the char.
|
||||
; since TinyScheme default compiles with option "USE_ASCII_NAMES"
|
||||
;>(integer->char 7)
|
||||
;#\bel
|
||||
;>(integer->char 127)
|
||||
;#\del
|
||||
|
||||
; ScriptFu prints solitary Unichars
|
||||
; for codepoints below 32 and also 127 differently than upstream TinyScheme.
|
||||
; Except ScriptFu is same as TinyScheme for tab, space, newline, return codepoints.
|
||||
; ScriptFu shows a glyph that is a box with a hex number.
|
||||
; Formerly (before the fixes for this test plan) Scriptfu printed these like TinyScheme,
|
||||
; by a sharp constant hex e.g. #\x1f for 31
|
||||
|
||||
|
||||
; Edge codepoint tests
|
||||
; Tests of edge cases, near a code slightly different
|
||||
|
||||
; Codepoint US Unit Separator, edge case to 32, space
|
||||
(assert '(equal? (integer->char 31) #\ ))
|
||||
(assert '(equal? #\ #\x1f))
|
||||
|
||||
; codepoint 127 x7f (DEL), edge case to 128
|
||||
(assert '(equal? (integer->char 127) #\x7f))
|
||||
|
||||
|
||||
|
||||
|
||||
; sharp constant hex character
|
||||
|
||||
; Sharp char expr hex denotes char atom
|
||||
; But not the REPL printed representation of characters.
|
||||
|
||||
; is-a char
|
||||
(assert '(char? #\x65))
|
||||
; equals a sharp character: lower case e
|
||||
(assert '(equal? #\x65 #\e))
|
||||
|
||||
; sharp char hex notation accepts a single hex digit
|
||||
(assert '(char? #\x3))
|
||||
; sharp char hex notation accepts two hex digits
|
||||
(assert '(char? #\x33))
|
||||
|
||||
; edge case, max hex that fits in 8-bits
|
||||
(assert '(char? #\xff))
|
||||
|
||||
; sharp car expr hex accepts three digits
|
||||
; when they are leading zeroes
|
||||
(assert '(char? #\x033))
|
||||
|
||||
; Otherwise, three digits not leading zeros
|
||||
; are unicode.
|
||||
|
||||
|
||||
; codepoint x3bb is a valid character (greek lambda)
|
||||
; but is outside ASCII range.
|
||||
; See sharp-expr-unichar.scm
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
; sharp constant hex character: invalid unichar
|
||||
|
||||
; Unicode has a range, but sparsely populated with valid codes.
|
||||
; Unicode is unsigned, range is [0,x10FFF]
|
||||
; Greatest valid codepoint is x10FFFF (to match UTF-16)
|
||||
; Sparsely populated: some codepoints in range are not valid
|
||||
; because they are incorrectly encoded using UTF-8 algorithm.
|
||||
; (This is a paraphrase: please consult the standard.)
|
||||
|
||||
; These tests are not a complete test of UTF-8 compliance !!!
|
||||
|
||||
; Edge case: max valid codepoint
|
||||
(assert (equal? #\x10FFFF #\))
|
||||
|
||||
; Edge case: zero is considered a valid codepoint
|
||||
; !!! Although also a string terminator.
|
||||
(assert '(equal?
|
||||
(integer->char 0)
|
||||
#\x0))
|
||||
|
||||
|
||||
; sharp constants for delimiter characters
|
||||
|
||||
; These test the sharp constant notation for characters space and parens
|
||||
; These are in the ASCII range
|
||||
|
||||
|
||||
; !!! A space char in a sharp constant expr
|
||||
(assert (char? #\ ))
|
||||
; Whose representation is a space character.
|
||||
(assert (string=? (atom->string #\ )
|
||||
" "))
|
||||
|
||||
; !!! A right paren char in a sharp constant expr
|
||||
; Note that backslash captures the first right paren:
|
||||
; the parens do not appear to match.
|
||||
(assert (char? #\)))
|
||||
; Ditto for left paren
|
||||
(assert (char? #\())
|
||||
; !!! But easy for author to confuse the parser
|
||||
; assert-error can't catch syntax errors.
|
||||
; So can only test in the REPL.
|
||||
; > (char? #\)
|
||||
; Error: syntax error: expected right paren, found EOF"
|
||||
|
||||
; #\# is the sharp or pound sign char
|
||||
(assert (char? #\#))
|
||||
(assert (string=? (atom->string #\# )
|
||||
"#"))
|
||||
; #\x is lower case x
|
||||
(assert (char? #\x))
|
||||
(assert (string=? (atom->string #\x )
|
||||
"x"))
|
||||
|
||||
|
||||
|
||||
; see also integer2char.scm
|
||||
|
||||
|
||||
|
||||
; Common misunderstandings or typos
|
||||
|
||||
; #\t is a character, lower case t
|
||||
|
||||
; It is not the denotation for truth.
|
||||
(assert `(not (equal? #\t #t)))
|
||||
|
||||
; It is not the denotation for #\tab.
|
||||
(assert `(not (equal? #\t #\tab)))
|
||||
|
||||
; It is a char
|
||||
(assert `(char? #\t))
|
||||
|
||||
; Its string representation is lower case t character
|
||||
(assert `(string=? (atom->string #\t)
|
||||
"t"))
|
||||
|
||||
|
||||
|
||||
; a number converted to string that is representation in base 16
|
||||
; !!! This is not creating a Unichar.
|
||||
; It is printing the hex representation of decimal 955, without a leading "\x"
|
||||
(assert `(string=? (number->string 955 16)
|
||||
"3bb"))
|
||||
|
||||
|
||||
; Untestable sharp constant hex character
|
||||
|
||||
; Test framework can't test, these cases are syntax errors.
|
||||
; These cases yield "syntax: illegal sharp constant expression" in REPL
|
||||
|
||||
; sharp constant hex having non-hex digit is an error
|
||||
; z is not in [a-f0-9]
|
||||
; > #\xz
|
||||
; Error: syntax: illegal sharp constant expression
|
||||
; Also prints warning "Hex literal has invalid digits" in stderr
|
||||
|
||||
|
||||
|
||||
162
plug-ins/script-fu/test/tests/TS/sharp-expr-unichar.scm
Normal file
162
plug-ins/script-fu/test/tests/TS/sharp-expr-unichar.scm
Normal file
@ -0,0 +1,162 @@
|
||||
; Test cases for sharp char expr for unicode chars outside ASCII range
|
||||
|
||||
; See sharp-expr-char.scm for sharp char expr inside ASCII range.
|
||||
|
||||
; See unichar.scm for tests of unichar without using sharp char expr
|
||||
|
||||
; This file also documents cases that the testing framework can't test
|
||||
; since they are syntax errors
|
||||
; or otherwise throw error in way that testing framework can't catch.
|
||||
; Such cases are documented with pairs of comments in re-test format:
|
||||
; First line starting with "; (" and next line "; <expected REPL display>"
|
||||
|
||||
; This is NOT a test of the REPL: ScriptFu Console.
|
||||
; A REPL displays using obj2str,
|
||||
; or internal atom2str() which this doesn't test.
|
||||
|
||||
; ScriptFu Console (the REPL) displays a "sharp char expression" to represent
|
||||
; all atoms which are characters, e.g. #\a .
|
||||
; A "sharp hex char expression" also
|
||||
; represents a character, e.g. #\x32.
|
||||
; But the REPL does not display that representation.
|
||||
|
||||
|
||||
; conversion from number to character equal sharp char expr unicode
|
||||
(assert `(equal? (integer->char 955) #\λ))
|
||||
; char=? also works
|
||||
(assert `(char=? (integer->char 955) #\λ))
|
||||
|
||||
; a sharp char expr unicode is-a char
|
||||
(assert (char? #\λ))
|
||||
|
||||
; sharp char hex expr is same as sharp char expr
|
||||
(assert (equal? #\x3bb #\λ))
|
||||
; sharp char hex expr is-a char
|
||||
(assert '(char? #\x3bb))
|
||||
|
||||
; Unichar extracted from string equals sharp char expr unicode
|
||||
(assert (equal? (string-ref "λ" 0) #\λ))
|
||||
|
||||
|
||||
|
||||
; Edge cases for sharp char expressions: hex: Unicode
|
||||
|
||||
; see also integer2char.scm
|
||||
; where same cases are tested
|
||||
|
||||
|
||||
; extended ASCII 128-255
|
||||
|
||||
; 128 the euro sign
|
||||
(assert #\x80)
|
||||
; 255
|
||||
(assert #\xff)
|
||||
|
||||
; 159 \xao is non-breaking space, not visible in most editors
|
||||
|
||||
; 256, does not fit in one byte
|
||||
(assert #\x100)
|
||||
|
||||
|
||||
; outside the Basic Multilingual Plane
|
||||
; won't fit in two bytes
|
||||
|
||||
; Least outside: 65536
|
||||
(assert #\x10000)
|
||||
|
||||
; max valid codepoint #\x10ffff
|
||||
(assert #\x10ffff)
|
||||
|
||||
; Any 32-bit value greater than x10ffff yields a syntax error:
|
||||
; syntax: illegal sharp constant expression
|
||||
; and not testable in testing framework
|
||||
|
||||
|
||||
|
||||
; extra tests of sharp char expr in other constructed expressions
|
||||
|
||||
; sharp char expr unicode passed to string function
|
||||
(assert (string=? (string #\λ) "λ"))
|
||||
|
||||
; sharp char expr unicode in a list
|
||||
(assert (equal? (list (string-ref "λ" 0)) '(#\λ)))
|
||||
|
||||
; sharp char expr unicode in vector
|
||||
(assert (equal? (vector (string-ref "λ" 0)) '#(#\λ)))
|
||||
|
||||
; atom->string
|
||||
(assert `(string=? (atom->string #\λ)
|
||||
"λ"))
|
||||
|
||||
|
||||
|
||||
; Quoted unichar
|
||||
|
||||
; quoted unichar is not type char
|
||||
(assert `(not (char? 'λ)))
|
||||
; quoted unichar is type symbol
|
||||
(assert `(symbol? 'λ))
|
||||
|
||||
|
||||
|
||||
|
||||
; unichar tested in REPL
|
||||
|
||||
; What follows are tests that can't be tested by the "testing" framework
|
||||
; but can be tested by the "re-test" framework
|
||||
; Testing framework can't test side effects on display.
|
||||
|
||||
|
||||
|
||||
; re-test display unichar
|
||||
; (display (string-ref "λ" 0))
|
||||
; λ#t
|
||||
|
||||
; re-test
|
||||
; (begin (display "Unicode lambda char: ") (string-ref "λ" 0))
|
||||
; Unicode lambda char: #\λ
|
||||
|
||||
|
||||
|
||||
; Unicode character can be passed to error function and displayed
|
||||
|
||||
; Seems to be flaw in testing framework,
|
||||
; this can't be tested:
|
||||
;(assert-error `(error "Error λ")
|
||||
; "Error: Error λ")
|
||||
|
||||
; re-test
|
||||
; (error "Error λ")
|
||||
; Error: Error: λ
|
||||
|
||||
|
||||
|
||||
; syntax errors in sharp char hex expr
|
||||
|
||||
; Syntax errors are not testable in testing framework.
|
||||
|
||||
|
||||
; exceeding max range of int 32 codepoint
|
||||
; longer than 8 hex digits \xf87654321
|
||||
; > (assert '#\xf87654321
|
||||
|
||||
; re-test
|
||||
; (null? #\xf87654321 )
|
||||
; syntax: illegal sharp constant expression
|
||||
; Also prints warning "Hex literal larger than 32-bit" to stderr
|
||||
|
||||
|
||||
; A codepoint that fits in 32 bits but invalid UTF-8 encoding
|
||||
|
||||
; re-test
|
||||
; (null? '#\xd800)
|
||||
; syntax: illegal sharp constant expression
|
||||
; Also prints warning "Failed make character from invalid codepoint." to stderr
|
||||
|
||||
|
||||
; Edge error case: first invalid codepoint greater than max valid
|
||||
|
||||
; re-test
|
||||
; (null? '#\x110000)
|
||||
; syntax: illegal sharp constant expression
|
||||
; Also prints warning "Failed make character from invalid codepoint." to stderr
|
||||
85
plug-ins/script-fu/test/tests/TS/sharp-expr.scm
Normal file
85
plug-ins/script-fu/test/tests/TS/sharp-expr.scm
Normal file
@ -0,0 +1,85 @@
|
||||
; Tests of sharp expressions in ScriptFu
|
||||
|
||||
; This only tests:
|
||||
; miscellaneous sharp expressions
|
||||
; See also:
|
||||
; sharp-expr-char.scm
|
||||
; sharp-expr-number.scm
|
||||
|
||||
; Some "sharp expressions" e.g. #t and #f might not be explicitly tested,
|
||||
; but tested "driveby" by other tests.
|
||||
|
||||
; Terminology:
|
||||
; The code says "sharp constant expression".
|
||||
; A "sharp expression" is text in the language that denotes a "sharp constant."
|
||||
; A constant is an atom of various types: char, byte, number.
|
||||
; The expression is distinct from the thing it denotes.
|
||||
|
||||
; A "sharp expression" is *recognized* by the interpreter.
|
||||
; But also *printed* by the interpreter REPL.
|
||||
; Mostly these are tests of recognition.
|
||||
; The testing framework cannot test the REPL.
|
||||
|
||||
; See scheme.c, the token() function, about line 2000
|
||||
; and the mk_sharp_constant() function, for sharp character constant
|
||||
|
||||
; #( token denotes start of a vector
|
||||
|
||||
; #! token denotes start of a comment terminated by newline
|
||||
; aka shebang or hashbang, a notation that OS shells read
|
||||
|
||||
; #t denotes true
|
||||
; #f denotes false
|
||||
|
||||
; #odxb<x> denotes a numeric constant in octal, decimal, hex, binary base
|
||||
; where <x> are digits of that base
|
||||
|
||||
; #\<char> denotes a character constant where <char> is one character
|
||||
; The one character may be multiple bytes in UTF-8,
|
||||
; but should appear in the display as a single glyph,
|
||||
; but may appear as a box glyph for unichar chars outside ASCII.
|
||||
|
||||
; #\x<x> denotes a character constant where <x> is a sequence of hex digits
|
||||
; See mk_sharp_const()
|
||||
|
||||
; #\space #\newline #\return and #\tab also denote character constants.
|
||||
|
||||
; Note: sharp backslash followed by space/blank parses as a token,
|
||||
|
||||
; #U+<x> notation for unichar character constants is not in ScriptFu
|
||||
|
||||
; Any sharp character followed by characters not described above
|
||||
; MAY optionally be a sharp expression when a program
|
||||
; uses the "sharp hook" by defining symbol *sharp-hook* .
|
||||
|
||||
|
||||
; block quote parses
|
||||
; Seems only testable in REPL?
|
||||
; Note there is a newline after foo
|
||||
;(assert '#! foo
|
||||
; )
|
||||
; but is not testable by the framework
|
||||
|
||||
; #t denotes truth
|
||||
(assert #t)
|
||||
|
||||
; #t denotes an atom
|
||||
(assert (atom? #t))
|
||||
|
||||
; #t is type boolean
|
||||
(assert (boolean? #t))
|
||||
; #t is neither type number or symbol
|
||||
(assert (not (number? #t)))
|
||||
(assert (not (symbol? #t)))
|
||||
|
||||
; #t denotes constant, and constant means immutable
|
||||
; You cannot redefine #t
|
||||
(assert-error `(define #t 1)
|
||||
"variable is not a symbol")
|
||||
; You cannot set #t
|
||||
(assert-error `(set! #t 1)
|
||||
"set!: unbound variable:")
|
||||
; error-hook omits suffix: #t
|
||||
|
||||
; There is no predicate immutable? in Scheme language?
|
||||
|
||||
56
plug-ins/script-fu/test/tests/TS/string-port.scm
Normal file
56
plug-ins/script-fu/test/tests/TS/string-port.scm
Normal file
@ -0,0 +1,56 @@
|
||||
; Test cases for string ports
|
||||
|
||||
; a string port is-a port (having read and write methods).
|
||||
; a string port stores its contents in memory (unlike device ports).
|
||||
; A read returns contents previously written.
|
||||
; A string port is practically infinite.
|
||||
|
||||
; a string port is like a string
|
||||
; a sequence of writes are like a sequence of appends to a string
|
||||
|
||||
|
||||
; Note that each assert is in its own environment,
|
||||
; so we can't define a global port outside????
|
||||
; Why shouldn't this work?
|
||||
; (define aStringPort (open-output-string))
|
||||
; (assert `(port? aStringPort))
|
||||
|
||||
|
||||
; open-output-string yields a port
|
||||
(assert '(port? (open-output-string)))
|
||||
|
||||
; string read from port equals string written to port
|
||||
; !!! with escaped double quote
|
||||
(assert '(string=?
|
||||
(let* ((aStringPort (open-output-string)))
|
||||
(write "foo" aStringPort)
|
||||
(get-output-string aStringPort))
|
||||
"\"foo\""))
|
||||
|
||||
; string read from port equals string repr of symbol written to port
|
||||
; !!! without escaped double quote
|
||||
(assert '(string=?
|
||||
(let* ((aStringPort (open-output-string)))
|
||||
; !!! 'foo is-a symbol whose repr is three characters: foo
|
||||
; write to a port writes the repr
|
||||
(write 'foo aStringPort)
|
||||
(get-output-string aStringPort))
|
||||
(symbol->string 'foo)))
|
||||
|
||||
; What is read equals the string written.
|
||||
; For edge case: writing more than 256 characters in two tranches
|
||||
; where second write crosses end boundary of 256 char buffer.
|
||||
|
||||
; issue #9495
|
||||
; Failing
|
||||
;(assert '(string=?
|
||||
; (let* ((aStringPort (open-output-string)))
|
||||
; (write (string->symbol (make-string 250 #\A)) aStringPort)
|
||||
; (write (string->symbol (make-string 7 #\B)) aStringPort)
|
||||
; (get-output-string aStringPort))
|
||||
; (string-append
|
||||
; (make-string 250 #\A)
|
||||
; (make-string 7 #\B))))
|
||||
|
||||
|
||||
|
||||
52
plug-ins/script-fu/test/tests/TS/testing.scm
Normal file
52
plug-ins/script-fu/test/tests/TS/testing.scm
Normal file
@ -0,0 +1,52 @@
|
||||
; test the testing framework
|
||||
|
||||
; assert stmt
|
||||
|
||||
|
||||
; a result that is #t passes
|
||||
(assert #t)
|
||||
|
||||
; other truthy results pass
|
||||
(assert 1)
|
||||
|
||||
; 0 is truthy and passes
|
||||
(assert 0)
|
||||
|
||||
; If you really want to assert that exactly #t is the result,
|
||||
; you should eval a topmost predicate that yields only #t or #f
|
||||
; For example, where eq? is equality of pointers:
|
||||
(assert '(not (eq? 0 #t)))
|
||||
|
||||
; a symbol defined outside an assert is visible
|
||||
; when you backquote and unquote it.
|
||||
(define aTrue #t)
|
||||
(assert `,aTrue)
|
||||
|
||||
; Here
|
||||
; backquote passes the following expression as data without evaluating it
|
||||
; singlequote makes a list literal instead of a function call
|
||||
; unquote i.e. comma evaluates the following symbol before backquote passes expression as data
|
||||
(assert `(car '(,aTrue)))
|
||||
|
||||
|
||||
|
||||
; assert-error statment
|
||||
|
||||
; assert-error tests for error messages
|
||||
; assert-error omits the "Error: " prefix printed by the REPL
|
||||
|
||||
; case: Error1 called with pointer to errant atom
|
||||
; symbol aFalse is not bound
|
||||
(assert-error 'aFalse
|
||||
"eval: unbound variable:")
|
||||
|
||||
; assert-error currently omits the suffix <repr of errant code>
|
||||
; printed by the usual error mechanism.
|
||||
; (Since I think error hook mechanism is broken.)
|
||||
|
||||
; case: Error0 called with null pointer
|
||||
; numeric literal 1 is not a function
|
||||
(assert-error '(1)
|
||||
"illegal function")
|
||||
|
||||
|
||||
36
plug-ins/script-fu/test/tests/TS/tinyscheme.scm
Normal file
36
plug-ins/script-fu/test/tests/TS/tinyscheme.scm
Normal file
@ -0,0 +1,36 @@
|
||||
; Complete test of TinyScheme
|
||||
|
||||
; This does NOT KNOW the directory organization of the test files in repo.
|
||||
|
||||
; When you add a test file, also add it to meson.build,
|
||||
; which DOES KNOW the dirs of the repo, but flattens into /test.
|
||||
|
||||
; Name clash must be avoided on the leaf filenames.
|
||||
|
||||
|
||||
; test the testing framework itself
|
||||
(testing:load-test "testing.scm")
|
||||
|
||||
(testing:load-test "cond-expand.scm")
|
||||
(testing:load-test "atom2string.scm")
|
||||
(testing:load-test "integer2char.scm")
|
||||
|
||||
(testing:load-test "string-port.scm")
|
||||
|
||||
(testing:load-test "sharp-expr.scm")
|
||||
(testing:load-test "sharp-expr-char.scm")
|
||||
(testing:load-test "sharp-expr-unichar.scm")
|
||||
|
||||
; test unichar without using sharp char expr
|
||||
(testing:load-test "unichar.scm")
|
||||
|
||||
(testing:load-test "vector.scm")
|
||||
|
||||
(testing:load-test "no-memory.scm")
|
||||
|
||||
; report the result
|
||||
(testing:report)
|
||||
|
||||
; yield the session result
|
||||
(testing:all-passed?)
|
||||
|
||||
58
plug-ins/script-fu/test/tests/TS/unichar.scm
Normal file
58
plug-ins/script-fu/test/tests/TS/unichar.scm
Normal file
@ -0,0 +1,58 @@
|
||||
; Test cases for unicode chars outside ASCII range
|
||||
|
||||
; !!! These tests don't use sharp char expr, but the chars themselves.
|
||||
; See sharp-expr-unichar.scm for sharp char expr denoting unichars
|
||||
; outside ASCII range.
|
||||
|
||||
; History: we avoid sharp char expr for unicode here
|
||||
; because of bug #9660.
|
||||
; Loosely speaking, ScriptFu was handling unichars,
|
||||
; but not sharp char expr for them.
|
||||
|
||||
; Most test cases are for atoms that are type "char",
|
||||
; meaning a component of a string.
|
||||
; ScriptFu implementation uses a C type: gunichar,
|
||||
; which holds a UTF-8 encoding of any Unicode code point.)
|
||||
; A unichar is as many as four bytes, not always one byte.
|
||||
|
||||
; This is NOT a test of the REPL: ScriptFu Console.
|
||||
; A REPL displays using obj2str,
|
||||
; or internal atom2str() which this doesn't test.
|
||||
|
||||
; ScriptFu Console (the REPL) displays a "sharp char expression" to represent
|
||||
; all atoms of type char, e.g. #\a .
|
||||
; A "sharp hex char expression" also
|
||||
; represents a character, e.g. #\x32.
|
||||
; But the REPL does not display that representation.
|
||||
|
||||
|
||||
; conversion from number to character equal sharp char
|
||||
(assert `(equal? (integer->char 955)
|
||||
(string-ref "λ" 0)))
|
||||
|
||||
|
||||
; Unichar itself (a wide character) can be in the script
|
||||
; but is unbound
|
||||
(assert-error `(eval λ) "eval: unbound variable:")
|
||||
; Note the error message is currently omitting the errant symbol
|
||||
|
||||
|
||||
; Unichar in a string
|
||||
(assert (string=? (string (string-ref "λ" 0)) "λ"))
|
||||
|
||||
|
||||
; Omitted: a test of REPL
|
||||
; display unichar
|
||||
; > (display (string-ref "λ" 0))
|
||||
; λ#t
|
||||
|
||||
|
||||
; Quoted unichar
|
||||
; These test that the script can contain unichars
|
||||
; versus test that a script can process unichars.
|
||||
|
||||
; quoted unichar is not type char
|
||||
(assert `(not (char? 'λ)))
|
||||
|
||||
; quoted unichar is type symbol
|
||||
(assert (symbol? 'λ))
|
||||
85
plug-ins/script-fu/test/tests/TS/vector.scm
Normal file
85
plug-ins/script-fu/test/tests/TS/vector.scm
Normal file
@ -0,0 +1,85 @@
|
||||
; test vector methods of TS
|
||||
|
||||
|
||||
|
||||
; make-vector
|
||||
|
||||
; make-vector succeeds
|
||||
(assert '(make-vector 25))
|
||||
; Note vector is anonymous and will be garbage collected
|
||||
|
||||
; make-vector of size 0 succeeds
|
||||
(assert '(make-vector 0))
|
||||
|
||||
(define testVector (make-vector 25))
|
||||
|
||||
; make-vector yields a vector
|
||||
(assert `(vector? ,testVector))
|
||||
|
||||
; make-vector yields a vector of given length
|
||||
(assert `(= (vector-length ,testVector)
|
||||
25))
|
||||
|
||||
; make-vector initializes each element to empty list
|
||||
(assert `(equal?
|
||||
(vector-ref ,testVector 0)
|
||||
'()))
|
||||
|
||||
|
||||
; other vector construction methods
|
||||
|
||||
(assert '(equal?
|
||||
(vector 'a 'b 'c)
|
||||
#(a b c)))
|
||||
|
||||
(assert '(equal?
|
||||
(list->vector '(dididit dah))
|
||||
#(dididit dah)))
|
||||
|
||||
|
||||
; fill
|
||||
|
||||
; fill succeeds
|
||||
(assert `(vector-fill! ,testVector 99))
|
||||
|
||||
; fill effective
|
||||
(assert `(=
|
||||
(vector-ref ,testVector 0)
|
||||
99))
|
||||
|
||||
|
||||
; referencing out of bounds
|
||||
|
||||
; past end fails
|
||||
(assert-error `(vector-ref ,testVector 25)
|
||||
"vector-ref: out of bounds:")
|
||||
; error msg omits repr of atom
|
||||
|
||||
; negative index fails
|
||||
(assert-error `(vector-ref ,testVector -1)
|
||||
"vector-ref: argument 2 must be: non-negative integer")
|
||||
|
||||
|
||||
|
||||
|
||||
; undefined vector ops in TS
|
||||
|
||||
; make-initialized-vector
|
||||
(assert-error '(equal?
|
||||
(make-initialized-vector 5 (lambda (x) (* x x)))
|
||||
#(0 1 4 9 16))
|
||||
"eval: unbound variable:")
|
||||
; error msg omits prefix "Error: " and suffix "make-initialized-vector"
|
||||
|
||||
; vector-copy
|
||||
; equals the original
|
||||
(assert-error
|
||||
`(equal?
|
||||
(vector-copy ,testVector)
|
||||
,testVector)
|
||||
"eval: unbound variable:")
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
293
plug-ins/script-fu/test/tests/readme.md
Normal file
293
plug-ins/script-fu/test/tests/readme.md
Normal file
@ -0,0 +1,293 @@
|
||||
# Testing ScriptFu using the testing framework
|
||||
|
||||
## Quick start
|
||||
|
||||
0. Rebuild PIKA.
|
||||
The build must be a non-stable build (nightly/development version.)
|
||||
1. View the Pika Error Console dockable
|
||||
2. Open the SF Console
|
||||
3. Enter '(testing:load-test "tinyscheme.scm")'
|
||||
|
||||
Expect to finally see a report of testing in the SF Console.
|
||||
Also expect to see "Passed" messages, as progress indicators,
|
||||
in the Pika Error Console.
|
||||
You may also see much extraneous data in the SF Console,
|
||||
since as a REPL, it prints the value yielded by each expression.
|
||||
|
||||
Some extreme test cases may take about a minute.
|
||||
If you see a "Pika is not responding" dialog, choose Wait.
|
||||
|
||||
"tinyscheme.scm" tests the embedded interpreter.
|
||||
You can also try "pdb.scm" to test the PDB.
|
||||
Or another test script to test a smaller portion.
|
||||
|
||||
## Organization and naming
|
||||
|
||||
The test language itself does not name a test.
|
||||
|
||||
The test scripts are in the repo at /plug-ins/script-fu/test/tests.
|
||||
|
||||
The filesystem of the repo organizes and names the tests.
|
||||
The name of a file or directory indicates what is tested.
|
||||
The tests don't know their own names.
|
||||
|
||||
A test script is usually many tests of one PIKA or ScriptFu object or function.
|
||||
There may be many test script files for the same object.
|
||||
|
||||
Tests and test groups can be organized in directories in the source repo.
|
||||
A directory of tests can be named for the PIKA object under test.
|
||||
|
||||
The leaf files and directories
|
||||
are coded into larger test files.
|
||||
The larger test files simply load all the files for a PIKA object.
|
||||
Loading a file executes the tests and alters testing state.
|
||||
|
||||
The test files when installed are flattened into one directory.
|
||||
Thus a test file that loads many tests loads them from the same top directory.
|
||||
|
||||
### Major test groups
|
||||
|
||||
1. PDB: Tests ScriptFu binding to the PIKA PDB.
|
||||
2. tinyscheme: Tests the embedded TinyScheme interpreter.
|
||||
3. other: Special test programs, often contributed with a new feature of ScriptFu.
|
||||
|
||||
## Testing State
|
||||
|
||||
The process of testing produces a state in the testing framework and in Pika.
|
||||
|
||||
### Testing framework state
|
||||
|
||||
The test framework state is the count of tests and info about failed tests.
|
||||
It accumulates over a session of Gimp
|
||||
(more precisely, over a session of ScriptFu Console
|
||||
or over a session of any plugin that loads the testing framework.)
|
||||
|
||||
The tests themselves do not usually reset the test state using '(testing:reset)'.
|
||||
|
||||
You can get a boolean of the total testing framework state
|
||||
using the predicate (testing:all-passed?) .
|
||||
|
||||
### Pika State
|
||||
|
||||
Pika state includes open images, installed resources, the selection, etc.
|
||||
Testing has side effects on Pika state.
|
||||
|
||||
To ensure tests succeed, you should test a new install of Pika.
|
||||
If you don't mind a few failed tests,
|
||||
you can test later than a new install.
|
||||
|
||||
Tests may require that PIKA be newly started:
|
||||
|
||||
1. PDB tests may hardcode certain constant ID's and rely on PIKA
|
||||
to consistently number ID's.
|
||||
|
||||
Tests may require that PIKA be newly installed:
|
||||
|
||||
1. PDB tests may depend on the initial set of Pika resources in ~/.config/PIKA
|
||||
|
||||
## Building for testing
|
||||
|
||||
### Non stable build
|
||||
|
||||
The test framework and test scripts are only installed in a non-stable build.
|
||||
|
||||
### Line numbers in error messages
|
||||
|
||||
The test scripts are intended to be portable across platforms
|
||||
and robust to changes in the test scripts.
|
||||
When testing error conditions (using assert-error)
|
||||
the testing framework compares expected prefix of error messages
|
||||
with actual error messages.
|
||||
To do that requires either that TinyScheme be built without the compile option
|
||||
to display file and line number in error messages,
|
||||
OR that TinyScheme puts details such as line number as the suffix of error message.
|
||||
|
||||
In other words, the testing of error conditions is not exact,
|
||||
only a prefix of the error message is compared.
|
||||
When you are writing such a test,
|
||||
write an expected error string that is a prefix that omits details.
|
||||
|
||||
In libscriptfu/tinyscheme/scheme.h :
|
||||
```
|
||||
# define SHOW_ERROR_LINE 0
|
||||
```
|
||||
## Test flavors
|
||||
|
||||
The testing framework can test normal operation and some error detection.
|
||||
The test framework does not test detection of syntax errors because parsing errors
|
||||
prevent the test framework from starting.
|
||||
|
||||
### Unit tests of small fragments
|
||||
|
||||
1. Normal operation: "assert"
|
||||
2. Expected runtime errors: "assert-error"
|
||||
|
||||
|
||||
|
||||
### Functional tests of plugins
|
||||
|
||||
The tests are plugins themselves.
|
||||
They are not usually automated, but require manual running and visual inspection.
|
||||
They are found in /scripts/test
|
||||
|
||||
## Testing framework features
|
||||
|
||||
The "testing.scm" framework is simple.
|
||||
Mostly it keeps stats for tests passed/failed
|
||||
and some information about failed tests.
|
||||
|
||||
This section describes the "testing.scm" framework.
|
||||
In the future, other test frameworks may coexist.
|
||||
|
||||
Some contributed tests have their own testing code
|
||||
e.g. "byte IO".
|
||||
|
||||
### Tests are not embedded in the tested source
|
||||
|
||||
Any tests of Scheme code are NOT annotations
|
||||
in the Scheme code they test.
|
||||
Tests are separate scripts.
|
||||
|
||||
### Tests are declarative
|
||||
|
||||
Tests are declarative, short, and readable.
|
||||
They may be ordered or have ordered expressions,
|
||||
especially when they test side effects on the Pika state.
|
||||
|
||||
### Tests can be order independent and repeated
|
||||
|
||||
Often, you can run tests in any order and repeat tests, up to a point.
|
||||
Then test objects that have accumulated
|
||||
might start to interfere with certain tests.
|
||||
|
||||
Tests generally should not hardcode PIKA ID's that PIKA assigns.
|
||||
|
||||
In general, run a large test, such as pdb.scm or tinyscheme.scm.
|
||||
But you can also run a small test such as layer-new.scm.
|
||||
Just be aware that if you run tests in an order of your choice,
|
||||
and if you repeat tests in the same session,
|
||||
you might start to see more errors than on the first run of a test
|
||||
after a fresh start of Pika.
|
||||
|
||||
### Some tests require a clean install
|
||||
|
||||
Tests of resources may try to create a resource (e.g. brush)
|
||||
that a prior run of the test already created
|
||||
and that was saved by Pika as a setting.
|
||||
|
||||
For such tests, you may need to test only after a fresh install of Gimp
|
||||
(when the set of resources is the set that Pika installs.)
|
||||
|
||||
### The test framework does not name or number tests
|
||||
|
||||
The filesystem names the test files.
|
||||
|
||||
You identify a test by the code it executes and its order in a file.
|
||||
|
||||
### Progress
|
||||
|
||||
The test framework logs progress to the PIKA Error Console
|
||||
using pika-message.
|
||||
|
||||
The test framework displays failures, but not successes, as they occur.
|
||||
Display is usually to the SF Console.
|
||||
|
||||
### History of test results
|
||||
|
||||
The test framework does not keep a permanent history of test results.
|
||||
The test framework does not write into the file system.
|
||||
|
||||
It does not alter the testing scripts,
|
||||
so you can load test scripts by name from a git repo
|
||||
without dirtying the repo.
|
||||
|
||||
Test scripts may test Pika features that write the file system.
|
||||
|
||||
### Known to fail tests
|
||||
|
||||
The test framework does not have a feature to ignore tests that fail.
|
||||
That is, the framework does not support a third category of test result: known-to-fail.
|
||||
Other frameworks might report success even though a known-to-fail test did fail.
|
||||
|
||||
You can comment out tests that fail.
|
||||
|
||||
### Tests cannot catch syntax errors
|
||||
|
||||
The test framework can not test detection of syntax errors
|
||||
because parsing errors
|
||||
prevent the test framework from starting.
|
||||
|
||||
## Writing tests
|
||||
|
||||
See /test/frameworks/testing.scm for more explanation of the testing language.
|
||||
|
||||
### Writing tests from examples
|
||||
|
||||
In the "MIT Scheme Reference" you might see examples like:
|
||||
|
||||
```
|
||||
(vector 'a 'b 'c) => #(a b c)
|
||||
```
|
||||
|
||||
The '=>' symbol should be read as 'yields.'
|
||||
|
||||
You can convert to this test:
|
||||
```
|
||||
(assert '(equal?
|
||||
(vector 'a 'b 'c)
|
||||
#(a b c)))
|
||||
```
|
||||
|
||||
Note the left and right hand sides of the MIT spec
|
||||
go directly into the test.
|
||||
|
||||
### Equality in tests
|
||||
|
||||
The testing framework does not choose the notion of equality.
|
||||
|
||||
You can choose from among equal? string=? and other predicates.
|
||||
Generally you should prefer equal?
|
||||
since it tests for object sameness, component by component,
|
||||
instead of pointer equality.
|
||||
|
||||
Often you don't need an equality predicate,
|
||||
when the test expression itself has a boolean result.
|
||||
|
||||
### Quoting in tests
|
||||
|
||||
Note the use of backquote ` (backtick) and unquote , (comma).
|
||||
When writing tests,
|
||||
you must often do this to make certain expressions evaluate later,
|
||||
after the assert statement starts and installs an error-hook.
|
||||
|
||||
The backquote makes an expression into data to pass to assert,
|
||||
which will evaluate the expression.
|
||||
Otherwise, if the expression is evaluated before passing, an error may come before the assert function starts,
|
||||
and the test is not properly caught or logged.
|
||||
|
||||
The unquote undoes the effect of the backquote: it makes the unquoted expression evaluate before passing it to an assert statement.
|
||||
|
||||
### Defining symbols outside a test expression
|
||||
|
||||
You can define symbols (say a variable or a function)
|
||||
before a test expression
|
||||
and refer to that symbol in the test expression
|
||||
but you might need to unquote it so it evaluates
|
||||
before the test expression function (assert or assert-error)
|
||||
is evaluated.
|
||||
|
||||
## Internationalization
|
||||
|
||||
We intend the tests are independent of locale
|
||||
(the user's preferred language.)
|
||||
|
||||
There is no test that changes the locale
|
||||
as part of the test process.
|
||||
(There is no API such as pika-set-locale.)
|
||||
|
||||
To test that ScriptFu properly internationalizes,
|
||||
you must change the locale and retest.
|
||||
The printing of numbers is known to fail in German.
|
||||
|
||||
|
||||
|
||||
Reference in New Issue
Block a user
