AlderconeStudio/PIKApp
0
0
Fork 0
Code Issues 1 Pull Requests Packages Projects Releases 1 Wiki Activity

Initial checkin of Pika from heckimp

Browse Source
This commit is contained in:
Cassowary
2023-09-25 15:35:21 -07:00
commit 891e999216
6761 changed files with 5240685 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

398
plug-ins/script-fu/test/frameworks/testing.scm Normal file
View File

@ -0,0 +1,398 @@
; A testing framework
;
; Independent of PIKA except for pika_message,
; which you can redefine
; Testing language
; AssertStmt ~ (assert '(<code>))
; AssertErrorStmt ~ (assert-error '(<code>) <prefix of expected error string>)
; ReportStmt ~ (testing:report)
; LoadStmt ~ (testing:load-test <filename>)
; AllPassedPredicate ~ (testing:all-passed?)
;
; AssertStmt and AssertErrorStmt have side effects on the testing state,
; and the other statements yield or display the state.
;
; AssertStmt and AssertErrorStmt also have side effects on the display,
; displaying failures.
;
; AssertStmt and AssertErrorStmt also yield #t or #f
; meaning pass or fail.
; Syntax errors
; The test framework WILL NOT handle syntax errors.
; The quoted code under tests must parse without syntax errors.
; Some errors that TinyScheme throws ARE syntax errors, but not named such.
; For example '#\xzzz is a syntax error (z is not a hex digit).
; Thus the test framework won't handle '#\xzzz .
; Algebra of calls
;
; Typically one or more AssertStmt followed by a ReportStmt
; when viewed in the console.
; Or one or more AssertStmt followed by AllPassedPredicate
; to yield an overall testing result,
; when testing is automated.
; Testing error messages
;
; Error messages may have details such as line number of error
; that may change over time.
; Testing expects that details will be a suffix of the error message.
; Passing is measured by comparing given expected prefix of error
; with actual error message.
; Notes on implementation:
;
; Debug stream for testing is pika-message
; EvalResult object
; is-a tuple (result, error)
; <result> is dynamic type returned by eval
; <error> is type string
(define (make-evalresult result errors)
;(pika-message "make-evalresult")
(list result errors))
(define (evalresult-get-result x) (car x))
(define (evalresult-get-error x) (cadr x))
(define (evalresult-has-no-error? x)
(= (string-length (cadr x)) 0))
; state
(define testing:passed 0) ; counter
(define testing:failed '()) ; list
(define (testing:reset!)
(set! testing:passed 0)
(set! testing:failed '()))
(define (testing:log-passed!)
; Not announce success to console, but can debug
(pika-message "Passed")
(set! testing:passed (+ testing:passed 1)))
; log any failure
(define (testing:log-fail! failure-string)
; Announce fail as it happens
(displayln "")
(display "Failed: ")
(displayln failure-string)
; save in state: prepend to list of failures
(set! testing:failed
(cons failure-string
testing:failed)))
(define (testing:log-fail-assert! code eval-result)
(testing:log-fail! (testing:format-fail-assert code eval-result)))
(define (testing:log-fail-assert-error! code actual-error expected-error)
(testing:log-fail! (testing:format-fail-assert-error
code
actual-error
expected-error)))
; reset testing state when test framework is loaded
(testing:reset!)
; reporting
; These methods encapsulate formatting of strings and reports
; A report is a summary of counts
; followed by line for each failure
(define (testing:report)
(testing:display-summary)
(testing:display-fails))
(define (testing:display-summary)
(displayln "")
(display "Passed: ")
(display testing:passed)
(display " Failed: ")
(displayln (length testing:failed)))
; Display list of failures in time order
; This does not iterate over the list.
; It relies on newlines in the individual failure formats.
(define (testing:display-fails)
(if (> (length testing:failed) 0)
(begin
(displayln "Failures:")
; reverse list so it displays in time order
(display (reverse testing:failed)))
'()))
; returns a string for failed assert-error
; Of form: Code: foo Actual: bar Expected: zed
(define (testing:format-fail-assert-error code actual-error expected-error)
(string-append
"<Code> "
(any->string code)
(string #\newline)
" <Actual> "
actual-error
(string #\newline)
" <Expected> "
expected-error
(string #\newline)
(string #\newline))
)
; returns a string for failed assert
; Of form Code: foo Error: bar
(define (testing:format-fail-assert code eval-result)
(string-append
"<Code>"
(any->string code)
(string #\newline)
; Any error message.
"<Error>"
(evalresult-get-error eval-result)
(string #\newline)
(string #\newline)
; We don't display result, it must be false
; because were given a boolean proposition
)
)
; boolean result for entire testing session
(define (testing:all-passed? )
(not (= (length testing:failed) 0)))
; Record eval-result, a tuple, from eval of code.
; This knows that a passed normal test has true result and empty error.
; <code is> a an object? a Scheme text, is a boolean proposition,
(define (testing:record-assert-result eval-result code)
;(pika-message "record-assert-result")
; passed when has no error and result is #t
(if (and (evalresult-has-no-error? eval-result)
(evalresult-get-result eval-result))
(testing:log-passed!)
; fail
(testing:log-fail-assert!
code
eval-result)))
; Record eval-result, a tuple, from eval of code.
; This knows that a passed assert-error test has don't care result.
; Instead, this knows the test passes if given <expected-error>
; matches a prefix of the actual error message yielded by eval.
; <result> is dynamic type returned by eval
; <error-message> is type string
; <code> is a an object? a Scheme text, is a boolean proposition.
; <expected-error> is type string
(define (testing:record-assert-error-result eval-result code expected-error)
; debug
;(displayln "record-assert-error-result")
;(displayln eval-result)
; expected error string a prefix of actual error string?
(if (string-prefix?
expected-error
(evalresult-get-error eval-result))
; passed
(begin
(testing:log-passed!)
#t)
; fail, pass asserted code, actual error, expected error
(begin
(testing:log-fail-assert-error!
code
(evalresult-get-error eval-result)
expected-error)
#f)))
; Strict equality of error strings:
;(if (equal?
; (evalresult-get-error eval-result)
; expected-error)
; Statments in the testing DSL.
; The usual or normal test.
; <code> is a boolean proposition expected to yield #t
(define (assert code)
(let* ((eval-result (harnessed-eval code)))
; eval-result is tuple
; record normal result i.e. error not expected
(testing:record-assert-result
eval-result
code)
; Statements have side-effect on testing state,
; but also return boolean result of predicate.
(evalresult-get-result eval-result )))
; A test of abnormality.
; <code> is not expected to yield any particular value
; <error> is a prefix of error string that <code> is expected to throw.
(define (assert-error code expected-error)
(let* ((eval-result (harnessed-eval code)))
; eval-result is tuple
; record normal result i.e. error not expected
(testing:record-assert-error-result
eval-result
code
expected-error)
; Returns whether error matches expected error prefix.
))
; eval code, returning tuple of result and errors
; This knows how to capture errors
; but not what result and errors mean for testing.
; Harnessed means: surrounded by code to capture error messages.
;
; Assert the pre-condition *error-hook* is (throw msg) see script-fu.init.
; So any call (error msg) is (throw msg)
; But we are not using (catch handler code).
; We are only overriding *error-hook*
;
; Any given eval of code under test may yield many calls to the error hook.
; We only record the first error message in an eval of the code under test.
(define (harnessed-eval code)
;(pika-message "harnessed-eval")
(let* ((old-error-hook *error-hook*) ; save original handler, which is throw
(errors "") ; initial empty string
(result #f) ; initial result is #f, not () which is truthy
(testing-error-hook
(lambda (xs)
;(pika-message "testing-error-hook")
; Only record the first error
(if (= (string-length errors) 0)
(if (string? xs)
(begin
;(pika-message "xs is string")
(set! errors xs))
(set! errors "Non-string error")))
; Do not chain up to old handler: (old-error-hook xs)
; Old handler is usually throw, which is error,
; and that infinite loops
;
; This returns to current eval,
; which may call this error hook again.
;(pika-message "returning from error hook")
)))
;(pika-message "override error hook")
(set! *error-hook* testing-error-hook)
;(pika-message "eval test code")
(set! result (eval code))
;(pika-message "restore error hook")
; restore the error hook for any code in a test script between asserts
(set! *error-hook* old-error-hook)
; return an EvalResult
(make-evalresult result errors)))
; port utility
(define (with-string open-function str function)
(let ((port (open-function str)))
(if (port? port)
(let ((result '()))
(set! result (function port))
(close-port port)
result)
; Testing internal error. Hijack the testing framework
(testing:log-fail! "Failed to open string for string port!" '() ))))
(define (call-with-output-string str function)
(with-string open-output-string str function))
; string utility
(define (trim char chars)
(if (= (char->integer char) (char->integer (car chars)))
(trim char (cdr chars))
chars))
(define (rtrim str)
(list->string (reverse (trim #\space (reverse (string->list str))))))
; any is code
; Not using atom->string. Using write
(define (any->string any)
(let* ((to-string
(lambda (any)
(let* ((str (make-string 256)))
(call-with-output-string str
(lambda (port) (write any port)))
str))))
(rtrim (to-string any))))
; string-prefix? is in R5RS but not tinyscheme.
; string-prefix? is in various SRFI's but we don't have them here
; So yet again, we need to implement it de novo
(define (string-prefix? str1 str2)
; if str1 is longer than str2, it is not a prefix
(if (> (string-length str1) (string-length str2))
#f
; else str2 is longer str2 than str1.
; str1 is a prefix if the leading substring of str2,
; that is the length of str1, equals str1.
(string=?
str1
(substring str2 0 (string-length str1)))))
; filesystem utility
; Return the fullpath of a test script.
; When fileScm is empty, returns path to dir of test scripts.
; From pika-data-directory i.e. the shared install dir for PIKA
; Require filename is string
; Require suffix, usually ".scm" on the filename
(define (path-to-test-scripts fileScm)
(let* ( (path (string-append pika-data-directory DIR-SEPARATOR "tests")))
(if (zero? (string-length fileScm)) path (string-append path DIR-SEPARATOR fileScm))))
(define (path-to-test-images fileScm)
(let* ( (path (string-append pika-data-directory DIR-SEPARATOR "images")))
(if (zero? (string-length fileScm)) path (string-append path DIR-SEPARATOR fileScm))))
; load a test file, which executes it
; Knows where PIKA installs test scripts
;
; Subsequently, testing:report will say results
(define (testing:load-test filename)
(pika-message (path-to-test-scripts filename))
(load (path-to-test-scripts filename)))
; Tell Pika to load a test image
; Returns ID of image
; Knows installed image directory (not dedicated to testing but always there.)
; Accepts image suffixes that Pika can load.
; Typical is /usr/local/share/pika/2.99/images/wilber.png
(define (testing:load-test-image filename)
(pika-message (path-to-test-images filename))
; unpack ID via car
(car (pika-file-load RUN-NONINTERACTIVE (path-to-test-images filename))))

78
plug-ins/script-fu/test/meson.build Normal file
View File

@ -0,0 +1,78 @@
# Install ScriptFu testing framework and test scripts
if not stable
test_framework_scripts = [
'frameworks' / 'testing.scm',
]
test_scripts = [
'tests' / 'PDB' / 'image' / 'image-new.scm',
'tests' / 'PDB' / 'image' / 'image-precision.scm',
'tests' / 'PDB' / 'image' / 'image-indexed.scm',
'tests' / 'PDB' / 'image' / 'image-grayscale.scm',
'tests' / 'PDB' / 'image' / 'image-ops.scm',
'tests' / 'PDB' / 'image' / 'image-layers.scm',
'tests' / 'PDB' / 'layer' / 'layer-new.scm',
'tests' / 'PDB' / 'layer' / 'layer-ops.scm',
'tests' / 'PDB' / 'layer' / 'layer-mask.scm',
'tests' / 'PDB' / 'text-layer' / 'text-layer-new.scm',
'tests' / 'PDB' / 'item' / 'item.scm',
'tests' / 'PDB' / 'channel' / 'channel-new.scm',
'tests' / 'PDB' / 'vectors-new.scm',
'tests' / 'PDB' / 'selection' / 'selection.scm',
'tests' / 'PDB' / 'selection' / 'selection-from.scm',
'tests' / 'PDB' / 'resource' / 'resource.scm',
'tests' / 'PDB' / 'resource' / 'resource-ops.scm',
'tests' / 'PDB' / 'resource' / 'brush.scm',
'tests' / 'PDB' / 'resource' / 'palette.scm',
'tests' / 'PDB' / 'context' / 'context-get-set.scm',
'tests' / 'PDB' / 'context' / 'context-resource.scm',
# TODO context push pop list-paint-methods
'tests' / 'PDB' / 'buffer.scm',
'tests' / 'PDB' / 'misc.scm',
'tests' / 'PDB' / 'enums.scm',
'tests' / 'PDB' / 'refresh.scm',
'tests' / 'PDB' / 'bind-args.scm',
# comprehensive, total test
'tests' / 'PDB' / 'pdb.scm',
'tests' / 'TS' / 'sharp-expr.scm',
'tests' / 'TS' / 'sharp-expr-char.scm',
'tests' / 'TS' / 'sharp-expr-unichar.scm',
'tests' / 'TS' / 'unichar.scm',
'tests' / 'TS' / 'cond-expand.scm',
'tests' / 'TS' / 'atom2string.scm',
'tests' / 'TS' / 'integer2char.scm',
'tests' / 'TS' / 'string-port.scm',
'tests' / 'TS' / 'testing.scm',
'tests' / 'TS' / 'vector.scm',
'tests' / 'TS' / 'no-memory.scm',
# comprehensive, total test
'tests' / 'TS' / 'tinyscheme.scm',
]
endif
# Install test framework to shared /scripts
# Assert: SFConsole, SFExtension, and standalong SFInterpreter will read them.
# SFConsole is primary testing interface.
# Some plugins in /scripts (SFExtension)
# and in /plug-ins (SFInterpreter) may also be interface for testing.
install_data(
test_framework_scripts,
install_dir: pikadatadir / 'scripts',
)
# Install test scripts to shared /tests
# Install flattening the dir structure.
install_data(
test_scripts,
install_dir: pikadatadir / 'tests',
)

87
plug-ins/script-fu/test/tests/PDB/bind-args.scm Normal file
View 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
View 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
View 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))

42
plug-ins/script-fu/test/tests/PDB/context/context-get-set.scm Normal file
View File

@ -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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View File

@ -0,0 +1 @@
See also a plugin in scripts/test/resource-class/

8
plug-ins/script-fu/test/tests/PDB/resource/resource-ops.scm Normal file
View File

@ -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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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.