mirror of https://github.com/GNOME/gimp.git
ScriptFu: #9755 Add test framework and tests for TS and PDB
Test framework and tests in Scheme, and portable. Work in progress. Expect commits for more tests. Testing framework is stable, more or less. Add more tests Add tests layer and layerMask. test Item methods More tests, selection Test memory, vector in TS. More tests char functions sharp expr tests
This commit is contained in:
bootchk
Lloyd Konneker
parent
dc50bf0601
commit
2f360ddb34
|
|
@ -72,7 +72,7 @@ extern "C" {
|
|||
#endif
|
||||
|
||||
#ifndef USE_TRACING
|
||||
# define USE_TRACING 1
|
||||
#define USE_TRACING 1
|
||||
#endif
|
||||
|
||||
#ifndef USE_PLIST
|
||||
|
|
|
|||
|
|
@ -12,6 +12,7 @@ subdir('scripts')
|
|||
subdir('server')
|
||||
subdir('interpreter')
|
||||
subdir('console')
|
||||
subdir('test')
|
||||
|
||||
|
||||
executable_name = 'script-fu'
|
||||
|
|
|
|||
|
|
@ -0,0 +1,354 @@
|
|||
; A testing framework
|
||||
;
|
||||
; Independent of GIMP except for gimp_message,
|
||||
; which you can redefine
|
||||
|
||||
|
||||
; Testing language
|
||||
|
||||
; AssertStmt ~ (assert '(<code>))
|
||||
; AssertErrorStmt ~ (assert-error '(<code>) <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.
|
||||
|
||||
|
||||
|
||||
; Notes on implementation:
|
||||
;
|
||||
; Debug stream for testing is gimp-message
|
||||
|
||||
|
||||
; EvalResult object
|
||||
; is-a tuple (result, error)
|
||||
; <result> is dynamic type returned by eval
|
||||
; <error> is type string
|
||||
|
||||
(define (make-evalresult result errors)
|
||||
;(gimp-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
|
||||
(gimp-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)
|
||||
;(gimp-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
|
||||
; and error-message matching given <foo>
|
||||
; <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)
|
||||
|
||||
; passed?
|
||||
(if (equal?
|
||||
(evalresult-get-error eval-result)
|
||||
expected-error)
|
||||
(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)))
|
||||
|
||||
|
||||
; 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 string for an error 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.
|
||||
))
|
||||
|
||||
|
||||
; 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)
|
||||
;(gimp-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)
|
||||
;(gimp-message "testing-error-hook")
|
||||
|
||||
; Only record the first error
|
||||
(if (= (string-length errors) 0)
|
||||
(if (string? xs)
|
||||
(begin
|
||||
;(gimp-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.
|
||||
;(gimp-message "returning from error hook")
|
||||
)))
|
||||
;(gimp-message "override error hook")
|
||||
(set! *error-hook* testing-error-hook)
|
||||
;(gimp-message "eval test code")
|
||||
(set! result (eval code))
|
||||
;(gimp-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))))
|
||||
|
||||
|
||||
|
||||
; filesystem utility
|
||||
|
||||
; Return the fullpath of a test script
|
||||
; From gimp-data-directory i.e. the shared install dir for GIMP
|
||||
; Require filename is string
|
||||
; Require suffix, usually ".scm" on the filename
|
||||
|
||||
(define (path-user-script fileScm)
|
||||
(let* ( (path (string-append gimp-data-directory DIR-SEPARATOR "tests")))
|
||||
(if (zero? (string-length fileScm)) path (string-append path DIR-SEPARATOR fileScm))))
|
||||
|
||||
|
||||
; load a test file, which executes it
|
||||
; This knows where GIMP installs test scripts
|
||||
;
|
||||
; Subsequently, testing:report will say results
|
||||
(define (testing:load-test filename)
|
||||
(gimp-message (path-user-script filename))
|
||||
(load (path-user-script filename)))
|
||||
|
|
@ -0,0 +1,68 @@
|
|||
|
||||
# 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' / '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.scm',
|
||||
'tests' / 'PDB' / 'brush.scm',
|
||||
'tests' / 'PDB' / 'misc.scm',
|
||||
'tests' / 'PDB' / 'enums.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: gimpdatadir / 'scripts',
|
||||
)
|
||||
|
||||
# Install test scripts to shared /tests
|
||||
# Install flattening the dir structure.
|
||||
|
||||
install_data(
|
||||
test_scripts,
|
||||
install_dir: gimpdatadir / 'tests',
|
||||
)
|
||||
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,14 @@
|
|||
|
||||
; Test ScriptFu's binding to all Gimp 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 that the call is effective.
|
||||
|
||||
; int
|
||||
; 1 is image ID and 1,1 is an int coord
|
||||
(assert '(gimp-image-add-sample-point 1 1 1))
|
||||
|
||||
; float
|
||||
(assert '(= (car (gimp-item-id-is-valid -1)) 0))
|
||||
|
|
@ -0,0 +1,130 @@
|
|||
; Test methods of Brush subclass of Resource class
|
||||
|
||||
; !!! See also resource.scm
|
||||
; Currently using string names instead of numeric ID
|
||||
|
||||
; !!! Testing depends on a fresh install of GIMP.
|
||||
; A prior testing failure may leave brushes in GIMP.
|
||||
; 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 and delete
|
||||
|
||||
; new returns brush of given name
|
||||
(assert '(string=?
|
||||
(car (gimp-brush-new "TestBrushNew"))
|
||||
"TestBrushNew"))
|
||||
|
||||
; TODO delete
|
||||
; can delete a new brush
|
||||
; FAIL _gimp_gp_param_def_to_param_spec: GParamSpec type unsupported 'GimpParamResource'
|
||||
;(assert '(string=?
|
||||
; (car (gimp-resource-delete "TestBrushNew"))
|
||||
; "TestBrushNew"))
|
||||
|
||||
|
||||
; Kind generated vesus raster
|
||||
|
||||
; new brush is kind generated
|
||||
(assert '(equal?
|
||||
(car (gimp-brush-is-generated "TestBrushNew"))
|
||||
1))
|
||||
|
||||
; angle default is 0
|
||||
(assert '(=
|
||||
(car (gimp-brush-get-angle "TestBrushNew"))
|
||||
0))
|
||||
|
||||
; aspect-ratio default is 1.0
|
||||
; FIXME: the doc says 0.0
|
||||
(assert '(=
|
||||
(car (gimp-brush-get-aspect-ratio "TestBrushNew"))
|
||||
1.0))
|
||||
|
||||
; hardness default is 0.5
|
||||
; FIXME: the doc says 0
|
||||
(assert '(=
|
||||
(car (gimp-brush-get-hardness "TestBrushNew"))
|
||||
0.5))
|
||||
|
||||
; shape default is GENERATED-CIRCLE
|
||||
(assert '(=
|
||||
(car (gimp-brush-get-shape "TestBrushNew"))
|
||||
BRUSH-GENERATED-CIRCLE))
|
||||
|
||||
; spikes default is 2
|
||||
; FIXME: docs says 0
|
||||
(assert '(=
|
||||
(car (gimp-brush-get-spikes "TestBrushNew"))
|
||||
2))
|
||||
|
||||
; get-radius default 5.0
|
||||
; FIXME: docs says 0
|
||||
(assert '(=
|
||||
(car (gimp-brush-get-radius "TestBrushNew"))
|
||||
5.0))
|
||||
|
||||
|
||||
; spacing default 20
|
||||
; FIXME: docs says 0
|
||||
(assert '(=
|
||||
(car (gimp-brush-get-spacing "TestBrushNew"))
|
||||
20))
|
||||
|
||||
; get-info returns a list of attributes
|
||||
; For generated, color bytes is zero
|
||||
(assert '(equal? (gimp-brush-get-info "TestBrushNew")
|
||||
'(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 '(gimp-brush-get-pixels "TestBrushNew"))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
; Kind non-generated brush
|
||||
|
||||
; "z Pepper" is non-generated and is a system brush always installed
|
||||
|
||||
; Certain attributes of non-generated brush yield errors
|
||||
; angle, aspect-ratio, hardness, shape, spikes, radius
|
||||
|
||||
; angle
|
||||
(assert-error
|
||||
'(gimp-brush-get-angle "z Pepper")
|
||||
"Procedure execution of gimp-brush-get-angle failed")
|
||||
|
||||
; TODO all the other attributes
|
||||
|
||||
|
||||
; Non-generated brush attributes
|
||||
|
||||
; is not generated
|
||||
(assert '(=
|
||||
(car (gimp-brush-is-generated "z Pepper"))
|
||||
0))
|
||||
|
||||
; spacing
|
||||
(assert '(=
|
||||
(car (gimp-brush-get-spacing "z Pepper"))
|
||||
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!
|
||||
; (assert '(gimp-brush-get-pixels "z Pepper"))
|
||||
|
||||
; get-info returns a list of attributes
|
||||
(assert '(equal? (gimp-brush-get-info "z Pepper")
|
||||
'(180 220 1 3)))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,56 @@
|
|||
; Test methods of Channel class of the PDB
|
||||
|
||||
|
||||
|
||||
; setup
|
||||
; Reusing image 10
|
||||
(define testImage 10)
|
||||
|
||||
|
||||
; new image has no custom channels
|
||||
(assert `(= (car (gimp-image-get-channels ,testImage))
|
||||
0))
|
||||
|
||||
; vectors-new succeeds
|
||||
(assert `(car (gimp-channel-new
|
||||
,testImage ; image
|
||||
23 24 ; width, height
|
||||
"Test Channel" ; name
|
||||
50.0 ; opacity
|
||||
"red" ))) ; compositing color
|
||||
|
||||
(define testChannel 20)
|
||||
|
||||
; new returns a valid ID
|
||||
(assert `(= (car (gimp-item-id-is-channel ,testChannel))
|
||||
1)) ; #t
|
||||
|
||||
; new channel is not in image until inserted
|
||||
(assert `(= (car (gimp-image-get-channels ,testImage))
|
||||
0))
|
||||
|
||||
|
||||
; attributes
|
||||
|
||||
; get-color
|
||||
; FIXME: this passes but should test return red ???
|
||||
(assert `(equal?
|
||||
(car (gimp-channel-get-color ,testChannel))
|
||||
'(0 0 0)))
|
||||
|
||||
|
||||
|
||||
|
||||
; insert
|
||||
|
||||
; insert succeeds
|
||||
(assert `(gimp-image-insert-channel
|
||||
,testImage
|
||||
,testChannel
|
||||
0 ; parent, moot since channel groups not supported
|
||||
0)) ; position in stack
|
||||
|
||||
; insert was effective
|
||||
(assert `(= (car (gimp-image-get-channels ,testImage))
|
||||
1))
|
||||
|
||||
|
|
@ -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))
|
||||
|
||||
|
|
@ -0,0 +1,56 @@
|
|||
; test Image of mode grayscale methods of PDB
|
||||
|
||||
|
||||
; depends on fresh GIMP state
|
||||
; !!!! tests hardcode image ID 5
|
||||
|
||||
; !!! Note inconsistent use in GIMP of GRAY versus GRAYSCALE
|
||||
|
||||
|
||||
|
||||
; Basic grayscale tests
|
||||
|
||||
|
||||
; method new from fresh GIMP state returns ID 5
|
||||
(assert '(=
|
||||
(car (gimp-image-new 21 22 RGB))
|
||||
5))
|
||||
|
||||
; method gimp-image-convert-grayscale does not error
|
||||
(assert '(gimp-image-convert-grayscale 5))
|
||||
|
||||
; conversion was effective:
|
||||
; basetype of grayscale is GRAY
|
||||
(assert '(=
|
||||
(car (gimp-image-get-base-type 5))
|
||||
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 (gimp-image-get-colormap 5)))
|
||||
0))
|
||||
|
||||
; grayscale images have precision PRECISION-U8-NON-LINEAR
|
||||
; FIXME annotation of PDB procedure says GIMP_PRECISION_U8
|
||||
(assert '(=
|
||||
(car (gimp-image-get-precision 5))
|
||||
PRECISION-U8-NON-LINEAR ))
|
||||
|
||||
; TODO
|
||||
; drawable of grayscale image is also grayscale
|
||||
;(assert '(car (gimp-drawable-is-grayscale
|
||||
; ()
|
||||
; 5)
|
||||
|
||||
; convert precision of grayscale image succeeds
|
||||
(assert '(gimp-image-convert-precision
|
||||
5
|
||||
PRECISION-DOUBLE-GAMMA))
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,63 @@
|
|||
; test Image of mode indexed methods of PDB
|
||||
|
||||
|
||||
; depends on fresh GIMP state
|
||||
; !!!! tests hardcode image ID 4
|
||||
|
||||
; Using numeric equality operator '=' on numeric ID's
|
||||
|
||||
|
||||
; Basic indexed tests
|
||||
|
||||
|
||||
; method new from fresh GIMP state returns ID 4
|
||||
(assert '(=
|
||||
(car (gimp-image-new 21 22 RGB))
|
||||
4))
|
||||
|
||||
; method gimp-image-convert-indexed yields truthy (now yields (#t) )
|
||||
(assert '(gimp-image-convert-indexed
|
||||
4
|
||||
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 is INDEXED
|
||||
(assert '(=
|
||||
(car (gimp-image-get-base-type 4))
|
||||
INDEXED))
|
||||
|
||||
; conversion was effective:
|
||||
; indexed 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 (gimp-image-get-colormap 4)))
|
||||
0))
|
||||
|
||||
; indexed images have precision PRECISION-U8-NON-LINEAR
|
||||
; FIXME annotation of PDB procedure says GIMP_PRECISION_U8
|
||||
(assert '(=
|
||||
(car (gimp-image-get-precision 4))
|
||||
PRECISION-U8-NON-LINEAR ))
|
||||
|
||||
; TODO
|
||||
; drawable of indexed image is also indexed
|
||||
;(assert '(car (gimp-drawable-is-indexed
|
||||
; ()
|
||||
; 4)
|
||||
|
||||
; convert precision of indexed images yields error
|
||||
(assert-error '(car (gimp-image-convert-precision
|
||||
4
|
||||
PRECISION-DOUBLE-GAMMA))
|
||||
"Procedure execution of gimp-image-convert-precision failed on invalid input arguments: Image '[Untitled]' (4) must not be of type 'indexed'")
|
||||
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,145 @@
|
|||
; test Image methods of PDB
|
||||
|
||||
; loading this file changes testing state
|
||||
|
||||
; depends on fresh GIMP state
|
||||
; !!!! tests hardcode image ID 1
|
||||
|
||||
; Using numeric equality operator '=' on numeric ID's
|
||||
|
||||
|
||||
; method new from fresh GIMP state returns ID 1
|
||||
(assert '(=
|
||||
(car (gimp-image-new 21 22 RGB))
|
||||
1 ))
|
||||
|
||||
; FUTURE method is_valid on new image yields #t
|
||||
; method is_valid on new image yields 1 i.e. true
|
||||
(assert '(=
|
||||
(car (gimp-image-id-is-valid 1))
|
||||
1))
|
||||
|
||||
; Ensure attributes of new image are correct
|
||||
|
||||
; method is_dirty on new image is true
|
||||
(assert '(=
|
||||
(car (gimp-image-is-dirty 1))
|
||||
1))
|
||||
|
||||
; method get_width on new image yields same width given when created
|
||||
(assert '(=
|
||||
(car (gimp-image-get-width 1))
|
||||
21))
|
||||
|
||||
; method get_height on new image yields same height given when created
|
||||
(assert '(=
|
||||
(car (gimp-image-get-height 1))
|
||||
22))
|
||||
|
||||
; method get-base-type yields same image type given when created
|
||||
(assert '(=
|
||||
(car (gimp-image-get-base-type 1))
|
||||
RGB))
|
||||
|
||||
; new image is known to gimp
|
||||
; Returns (<length> #(1))
|
||||
(assert '(= (car (gimp-get-images))
|
||||
1))
|
||||
|
||||
|
||||
; new image has no components
|
||||
|
||||
; new image has zero layers
|
||||
(assert '(= (car (gimp-image-get-layers 1))
|
||||
0))
|
||||
|
||||
; new image has zero vectors
|
||||
(assert '(= (car (gimp-image-get-vectors 1))
|
||||
0))
|
||||
|
||||
; new image has no parasites
|
||||
(assert '(= (length
|
||||
(car (gimp-image-get-parasite-list 1)))
|
||||
0))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
; new image has-a selection
|
||||
(assert '(gimp-image-get-selection 1))
|
||||
|
||||
; new image has no floating selection
|
||||
(assert '(=
|
||||
(car (gimp-image-get-floating-sel 1))
|
||||
-1))
|
||||
|
||||
; TODO floating-sel-attached-to
|
||||
|
||||
|
||||
|
||||
; new image has unit having ID 1
|
||||
(assert '(=
|
||||
(car (gimp-image-get-unit 1))
|
||||
1))
|
||||
|
||||
; new image has name
|
||||
(assert '(string=?
|
||||
(car (gimp-image-get-name 1))
|
||||
"[Untitled]"))
|
||||
|
||||
; new image has empty metadata string
|
||||
(assert '(string=?
|
||||
(car (gimp-image-get-metadata 1))
|
||||
""))
|
||||
|
||||
; has an effective color profile
|
||||
(assert '(gimp-image-get-effective-color-profile 1))
|
||||
|
||||
|
||||
|
||||
; new image has no associated files
|
||||
|
||||
; GFile is string in ScriptFu
|
||||
|
||||
; no file, xcf file, imported file, or exported file
|
||||
(assert '(string=? (car (gimp-image-get-file 1)) ""))
|
||||
(assert '(string=? (car (gimp-image-get-xcf-file 1)) ""))
|
||||
(assert '(string=? (car (gimp-image-get-imported-file 1)) ""))
|
||||
(assert '(string=? (car (gimp-image-get-exported-file 1)) ""))
|
||||
|
||||
|
||||
|
||||
; Test delete method.
|
||||
; !!! ID 1 is no longer valid
|
||||
|
||||
; method delete succeeds on new image
|
||||
; returns 1 for true. FUTURE returns #t
|
||||
(assert `(car (gimp-image-delete 1)))
|
||||
|
||||
; ensure id invalid for deleted image
|
||||
; returns 0 for false. FUTURE returns #f
|
||||
(assert `(=
|
||||
(car (gimp-image-id-is-valid 1))
|
||||
0))
|
||||
|
||||
; deleted image is not in gimp
|
||||
; Returns (<length> #())
|
||||
; FUTURE Returns empty list '()
|
||||
(assert '(=
|
||||
(car (gimp-get-images))
|
||||
0))
|
||||
|
||||
|
||||
|
||||
; Test abnormal args to image-new
|
||||
|
||||
|
||||
; Dimension zero yields error
|
||||
; It does NOT yield invalid ID -1
|
||||
(assert-error '(gimp-image-new 0 0 RGB)
|
||||
"Procedure execution of gimp-image-new failed on invalid input arguments: Procedure 'gimp-image-new' has been called with value '0' for argument 'width' (#1, type gint). This value is out of range." )
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,85 @@
|
|||
; Test various operations on image
|
||||
|
||||
|
||||
; method new from fresh GIMP state returns ID 2
|
||||
(assert '(=
|
||||
(car (gimp-image-new 21 22 RGB))
|
||||
6))
|
||||
|
||||
|
||||
; transformations
|
||||
|
||||
; flip
|
||||
(assert '(gimp-image-flip 6 ORIENTATION-HORIZONTAL))
|
||||
(assert '(gimp-image-flip 6 ORIENTATION-VERTICAL))
|
||||
; TODO rotate scale resize policy
|
||||
|
||||
(assert-error '(gimp-image-flip 6 ORIENTATION-UNKNOWN)
|
||||
(string-append
|
||||
"Procedure execution of gimp-image-flip failed on invalid input arguments: "
|
||||
"Procedure 'gimp-image-flip' has been called with value 'GIMP_ORIENTATION_UNKNOWN'"
|
||||
" for argument 'flip-type' (#2, type GimpOrientationType). This value is out of range."))
|
||||
|
||||
; rotate
|
||||
(assert '(gimp-image-rotate 6 ROTATE-90))
|
||||
(assert '(gimp-image-rotate 6 ROTATE-180))
|
||||
(assert '(gimp-image-rotate 6 ROTATE-270))
|
||||
|
||||
; scale
|
||||
; up
|
||||
(assert '(gimp-image-scale 6 100 100))
|
||||
|
||||
; down to min
|
||||
(assert '(gimp-image-scale 6 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 '(gimp-image-scale 6 524288 524288))
|
||||
|
||||
; down to min
|
||||
(assert '(gimp-image-scale 6 1 1))
|
||||
|
||||
|
||||
; policy ops
|
||||
|
||||
; 0 means non-interactive
|
||||
(assert '(gimp-image-policy-color-profile 6 0))
|
||||
(assert '(gimp-image-policy-rotate 6 0))
|
||||
|
||||
|
||||
|
||||
; freezing and unfreezing (avoid updates to dialogs)
|
||||
; Used for performance.
|
||||
(assert '(gimp-image-freeze-channels 6))
|
||||
(assert '(gimp-image-freeze-layers 6))
|
||||
(assert '(gimp-image-freeze-vectors 6))
|
||||
(assert '(gimp-image-thaw-channels 6))
|
||||
(assert '(gimp-image-thaw-layers 6))
|
||||
(assert '(gimp-image-thaw-vectors 6))
|
||||
|
||||
; clean-all makes image not dirty
|
||||
(assert '(gimp-image-clean-all 6))
|
||||
(assert '(=
|
||||
(car (gimp-image-is-dirty 6))
|
||||
0))
|
||||
|
||||
; TODO test flatten is effective
|
||||
; crop
|
||||
|
||||
|
||||
; painting ops
|
||||
; TODO
|
||||
; heal
|
||||
; erase
|
||||
; smudge
|
||||
; pencil
|
||||
; clone
|
||||
; airbrush
|
||||
|
||||
; cannot flatten empty image
|
||||
(assert-error '(gimp-image-flatten 6)
|
||||
"Procedure execution of gimp-image-flatten failed: Cannot flatten an image without any visible layer.")
|
||||
|
|
@ -0,0 +1,60 @@
|
|||
; test Image precision methods of PDB
|
||||
|
||||
|
||||
; depends on fresh GIMP state
|
||||
; !!!! tests hardcode image ID 2
|
||||
|
||||
; Using numeric equality operator '=' on numeric ID's
|
||||
|
||||
|
||||
; Basic precision tests
|
||||
|
||||
|
||||
; method new from fresh GIMP state returns ID 2
|
||||
(assert '(=
|
||||
(car (gimp-image-new 21 22 RGB))
|
||||
2 ))
|
||||
|
||||
; method get_precision on new image yields PRECISION-U8-NON-LINEAR 150
|
||||
(assert '(=
|
||||
(car (gimp-image-get-precision 2))
|
||||
PRECISION-U8-NON-LINEAR ))
|
||||
|
||||
|
||||
|
||||
; Convert precision
|
||||
|
||||
; method convert-precision yields true, with side effect on image
|
||||
(assert '(car (gimp-image-convert-precision
|
||||
2
|
||||
PRECISION-U8-LINEAR)))
|
||||
|
||||
|
||||
; converted image is the precision
|
||||
(assert '(=
|
||||
(car (gimp-image-get-precision 2))
|
||||
PRECISION-U8-LINEAR ))
|
||||
|
||||
; converting to the same precision yields error message
|
||||
(assert-error '(gimp-image-convert-precision
|
||||
2
|
||||
PRECISION-U8-LINEAR)
|
||||
"Procedure execution of gimp-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
|
||||
|
||||
; method new-with-precision from fresh GIMP state returns ID 3
|
||||
(assert '(=
|
||||
(car (gimp-image-new-with-precision 21 22 RGB PRECISION-DOUBLE-GAMMA))
|
||||
3 ))
|
||||
|
||||
; image has given precision
|
||||
(assert '(=
|
||||
(car (gimp-image-get-precision 3))
|
||||
PRECISION-DOUBLE-GAMMA ))
|
||||
|
|
@ -0,0 +1,166 @@
|
|||
; 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 gimp-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 `(gimp-item-id-is-valid ,item))
|
||||
|
||||
; item is not a group (can have no children)
|
||||
(assert `(= (car (gimp-item-is-group ,item))
|
||||
0))
|
||||
|
||||
; item has no color tag
|
||||
(assert `(= (car (gimp-item-get-color-tag ,item))
|
||||
COLOR-TAG-NONE))
|
||||
|
||||
; item is not expanded
|
||||
(assert `(= (car (gimp-item-get-expanded ,item))
|
||||
0))
|
||||
|
||||
; item has name, tattoo
|
||||
; Test does not check returned value
|
||||
(assert `(gimp-item-get-name ,item))
|
||||
(assert `(gimp-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 (gimp-item-get-parasite-list ,item))))
|
||||
|
||||
; item has no parent
|
||||
; yields -1 for NULL ID
|
||||
(assert `(= (car (gimp-item-get-parent ,item))
|
||||
-1))
|
||||
|
||||
; item has-a image
|
||||
; Test does not compare item ID
|
||||
(assert `(gimp-item-get-image ,item))
|
||||
|
||||
; item's content, position, visibility is not locked
|
||||
(assert `(= (car (gimp-item-get-lock-content ,item))
|
||||
0))
|
||||
(assert `(= (car (gimp-item-get-lock-position ,item))
|
||||
0))
|
||||
(assert `(= (car (gimp-item-get-lock-visibility ,item))
|
||||
0))
|
||||
)
|
||||
|
||||
|
||||
; Test methods of image,item
|
||||
(define (test-item-in-image image item)
|
||||
; item can produce a selection
|
||||
(assert `(gimp-image-select-item
|
||||
,image
|
||||
CHANNEL-OP-ADD
|
||||
,item))
|
||||
)
|
||||
|
||||
|
||||
|
||||
; !!! GimpParasite 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.gimpusers.com/forums/gimp-user/12970-how-are-parasites-represented-in-script-fu
|
||||
; https://www.mail-archive.com/gimp-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 `(gimp-item-get-parasite
|
||||
,item
|
||||
"Test Parasite") ; name
|
||||
"Procedure execution of gimp-item-get-parasite failed")
|
||||
|
||||
; can attach parasite
|
||||
(assert `(gimp-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 (gimp-item-get-parasite
|
||||
,item
|
||||
"Parasite New")) ; name
|
||||
"Parasite New"))
|
||||
|
||||
; can detach parasite
|
||||
(assert `(gimp-item-detach-parasite
|
||||
,item
|
||||
"Parasite New"))
|
||||
; detach was effective
|
||||
(assert-error `(gimp-item-get-parasite
|
||||
,item
|
||||
"Test Parasite") ; name
|
||||
"Procedure execution of gimp-item-get-parasite failed")
|
||||
)
|
||||
|
||||
|
||||
; use image,item instance extant from previous tests.
|
||||
|
||||
; text layer
|
||||
(test-bare-item 15)
|
||||
(test-item-in-image 8 15)
|
||||
(test-item-parasite 15)
|
||||
|
||||
; layer
|
||||
(test-bare-item 12)
|
||||
(test-item-in-image 9 12)
|
||||
(test-item-parasite 12)
|
||||
|
||||
; layerMask
|
||||
(test-bare-item 14)
|
||||
(test-item-in-image 9 14)
|
||||
(test-item-parasite 14)
|
||||
|
||||
; vectors
|
||||
; ID 16 is also a vectors named "foo"
|
||||
(test-bare-item 19)
|
||||
(test-item-in-image 10 19)
|
||||
(test-item-parasite 19)
|
||||
|
||||
; channel
|
||||
(test-bare-item 20)
|
||||
(test-item-in-image 10 20)
|
||||
(test-item-parasite 20)
|
||||
|
||||
; selection
|
||||
(test-bare-item 18)
|
||||
(test-item-in-image 10 18)
|
||||
(test-item-parasite 18)
|
||||
|
||||
; TODO other item types e.g. ?
|
||||
|
||||
; gimp-image-get-item-position
|
||||
; gimp-image-raise-item
|
||||
; gimp-image-raise-item-to-top
|
||||
; lower
|
||||
; reorder
|
||||
|
|
@ -0,0 +1,114 @@
|
|||
; tests of methods re masks on layers
|
||||
|
||||
; masks are a separate class in Gimp GimpLayerMask
|
||||
; but the methods are named strangely,
|
||||
; e.g. there is no gimp-layer-mask-get-layer
|
||||
|
||||
|
||||
; setup
|
||||
; Image owns Layers
|
||||
|
||||
; method new from fresh GIMP state returns ID
|
||||
(assert '(= (car (gimp-image-new 21 22 RGB))
|
||||
9 ))
|
||||
|
||||
; new method yields layer ID 12
|
||||
(assert '(= (car (gimp-layer-new
|
||||
9
|
||||
21
|
||||
22
|
||||
RGB-IMAGE
|
||||
"LayerNew"
|
||||
50.0
|
||||
LAYER-MODE-NORMAL))
|
||||
12))
|
||||
; assert layer is not inserted in image
|
||||
|
||||
|
||||
; gimp-layer-create-mask yields ID 13
|
||||
; Creating for the layer, but not on the layer yet!!!
|
||||
(assert '(= (car (gimp-layer-create-mask
|
||||
12
|
||||
ADD-MASK-WHITE))
|
||||
13))
|
||||
|
||||
; mask is not on layer until added.
|
||||
; Getting the mask for the layer yields -1.
|
||||
(assert '(= (car (gimp-layer-mask 12))
|
||||
-1))
|
||||
|
||||
; add layerMask created on a layer to that layer succeeds
|
||||
(assert '(gimp-layer-add-mask
|
||||
12 ; layer
|
||||
13)) ; layer mask
|
||||
|
||||
; add layerMask to layer was effective:
|
||||
; Getting the mask for the layer yields layerMask ID
|
||||
(assert '(= (car (gimp-layer-mask 12))
|
||||
13))
|
||||
|
||||
; and vice versa
|
||||
(assert '(= (car (gimp-layer-from-mask 13))
|
||||
12))
|
||||
|
||||
|
||||
|
||||
; creating and adding second mask
|
||||
|
||||
; creating a second mask from layer succeeds
|
||||
(assert '(= (car (gimp-layer-create-mask
|
||||
12
|
||||
ADD-MASK-WHITE))
|
||||
14))
|
||||
|
||||
; adding a second layerMask fails
|
||||
(assert-error '(gimp-layer-add-mask
|
||||
12 ; layer
|
||||
14) ; layer mask
|
||||
(string-append
|
||||
"Procedure execution of gimp-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 '(gimp-layer-remove-mask
|
||||
12 ; layer
|
||||
MASK-APPLY) ; removal mode
|
||||
(string-append
|
||||
"Procedure execution of gimp-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 '(gimp-image-insert-layer
|
||||
9 ; image
|
||||
12 ; layer
|
||||
0 ; parent
|
||||
0 )) ; position within parent
|
||||
|
||||
; remove-mask succeeds
|
||||
; when layer is in image
|
||||
(assert '(gimp-layer-remove-mask
|
||||
12 ; layer
|
||||
MASK-APPLY)) ; removal mode
|
||||
|
||||
; and is effective
|
||||
; layer no longer has a mask
|
||||
(assert '(= (car (gimp-layer-mask 12))
|
||||
-1))
|
||||
|
||||
; and now we can add the second mask
|
||||
(assert '(gimp-layer-add-mask
|
||||
12 ; layer
|
||||
14)) ; second layer mask
|
||||
|
||||
|
||||
; 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
|
||||
|
|
@ -0,0 +1,127 @@
|
|||
; test Layer methods of PDB
|
||||
|
||||
|
||||
; setup
|
||||
; Image owns Layers
|
||||
|
||||
; method new from fresh GIMP state returns ID
|
||||
(assert '(=
|
||||
(car (gimp-image-new 21 22 RGB))
|
||||
7 ))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
; new method yields layer ID 8
|
||||
(assert '(= (car (gimp-layer-new
|
||||
7
|
||||
21
|
||||
22
|
||||
RGB-IMAGE
|
||||
"LayerNew"
|
||||
50.0
|
||||
LAYER-MODE-NORMAL))
|
||||
8))
|
||||
|
||||
|
||||
; new layer is not in the image until inserted
|
||||
(assert '(= (car (gimp-image-get-layers 7))
|
||||
0))
|
||||
|
||||
|
||||
|
||||
; attributes of new layer
|
||||
|
||||
; defaulted attributes
|
||||
|
||||
; apply-mask default false
|
||||
(assert '(=
|
||||
(car (gimp-layer-get-apply-mask 8))
|
||||
0))
|
||||
|
||||
; blend-space default LAYER-COLOR-SPACE-AUTO
|
||||
(assert '(=
|
||||
(car (gimp-layer-get-blend-space 8))
|
||||
LAYER-COLOR-SPACE-AUTO))
|
||||
|
||||
; composite-mode default LAYER-COMPOSITE-AUTO
|
||||
(assert '(=
|
||||
(car (gimp-layer-get-composite-mode 8))
|
||||
LAYER-COMPOSITE-AUTO))
|
||||
|
||||
; composite-space default LAYER-COLOR-SPACE-AUTO
|
||||
(assert '(=
|
||||
(car (gimp-layer-get-composite-space 8))
|
||||
LAYER-COLOR-SPACE-AUTO))
|
||||
|
||||
; edit-mask default false
|
||||
(assert '(=
|
||||
(car (gimp-layer-get-edit-mask 8))
|
||||
0))
|
||||
|
||||
; lock-alpha default false
|
||||
; deprecated? gimp-layer-get-preserve-trans
|
||||
(assert '(=
|
||||
(car (gimp-layer-get-lock-alpha 8))
|
||||
0))
|
||||
|
||||
; mask not exist, ID -1
|
||||
; deprecated? gimp-layer-mask
|
||||
(assert '(=
|
||||
(car (gimp-layer-get-mask 8))
|
||||
-1))
|
||||
|
||||
; mode default LAYER-MODE-NORMAL
|
||||
(assert '(=
|
||||
(car (gimp-layer-get-mode 8))
|
||||
LAYER-MODE-NORMAL))
|
||||
|
||||
; show-mask default false
|
||||
(assert '(=
|
||||
(car (gimp-layer-get-show-mask 8))
|
||||
0))
|
||||
|
||||
; visible default true
|
||||
; FIXME doc says default false
|
||||
(assert '(=
|
||||
(car (gimp-layer-get-visible 8))
|
||||
1))
|
||||
|
||||
; is-floating-sel default false
|
||||
(assert '(=
|
||||
(car (gimp-layer-is-floating-sel 8))
|
||||
0))
|
||||
|
||||
; !!! No get-offsets
|
||||
|
||||
|
||||
|
||||
|
||||
; attributes are as given when created
|
||||
|
||||
; name is as given
|
||||
assert '(string=? (car (gimp-layer-get-name 8))
|
||||
"LayerNew")
|
||||
|
||||
; opacity is as given
|
||||
(assert '(=
|
||||
(car (gimp-layer-get-opacity 8))
|
||||
50.0))
|
||||
|
||||
|
||||
; generated attributes
|
||||
|
||||
; tattoo
|
||||
; tattoo is generated unique within image?
|
||||
(assert '(=
|
||||
(car (gimp-layer-get-tattoo 8))
|
||||
2))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,98 @@
|
|||
; test Layer methods of PDB
|
||||
; where methods are operations
|
||||
|
||||
|
||||
; setup
|
||||
; Image owns Layers
|
||||
|
||||
; method new from fresh GIMP state returns ID
|
||||
;(define testImage 1)
|
||||
;(set! testImage (car (gimp-image-new 21 22 RGB)))
|
||||
;(displayln testImage)
|
||||
|
||||
(assert '(= (car (gimp-image-new 21 22 RGB))
|
||||
8 ))
|
||||
|
||||
|
||||
|
||||
; new method yields layer ID 10
|
||||
(assert '(= (car (gimp-layer-new
|
||||
8
|
||||
21
|
||||
22
|
||||
RGB-IMAGE
|
||||
"LayerNew#2"
|
||||
50.0
|
||||
LAYER-MODE-NORMAL))
|
||||
10))
|
||||
; assert layer is not inserted in image
|
||||
|
||||
|
||||
; errors when layer not in image
|
||||
|
||||
; resize fails
|
||||
(assert-error '(gimp-layer-resize 10 23 24 0 0)
|
||||
(string-append
|
||||
"Procedure execution of gimp-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 '(gimp-layer-scale 10
|
||||
23 24 ; width height
|
||||
0) ; is local origin?
|
||||
(string-append
|
||||
"Procedure execution of gimp-layer-scale failed on invalid input arguments: "
|
||||
"Item 'LayerNew#2' (10) cannot be used because it has not been added to an image"))
|
||||
|
||||
; gimp-layer-resize-to-image-size fails
|
||||
; TODO
|
||||
|
||||
; gimp-layer-remove-mask fails when layer has no mask
|
||||
(assert-error '(gimp-layer-remove-mask
|
||||
10
|
||||
MASK-APPLY)
|
||||
(string-append
|
||||
"Procedure execution of gimp-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 '(gimp-layer-add-alpha 10))
|
||||
|
||||
; and is effective
|
||||
; Note method on superclass Drawable
|
||||
(assert '(= (car (gimp-drawable-has-alpha 10))
|
||||
1))
|
||||
|
||||
; flatten succeeds
|
||||
(assert '(gimp-layer-flatten 10))
|
||||
|
||||
; flatten was effective: no longer has alpha
|
||||
; flatten a layer means "remove alpha"
|
||||
(assert '(= (car (gimp-drawable-has-alpha 10))
|
||||
0))
|
||||
|
||||
|
||||
|
||||
|
||||
; delete
|
||||
|
||||
; delete succeeds
|
||||
(assert '(gimp-layer-delete 10))
|
||||
|
||||
; delete second time fails
|
||||
(assert-error '(gimp-layer-delete 10)
|
||||
"runtime: invalid item ID")
|
||||
|
||||
; Error for flatten:
|
||||
; "Procedure execution of gimp-layer-delete failed on invalid input arguments: "
|
||||
; "Procedure 'gimp-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
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,13 @@
|
|||
|
||||
; Miscellaneous tests of the PDB
|
||||
; These are not associated with an object class
|
||||
|
||||
|
||||
; 0 is an invalid item id
|
||||
; FUTURE gimp returns #f instead of 0
|
||||
; FUTURE gimp doesn't wrap in extra list
|
||||
(assert '(= (car (gimp-item-id-is-vectors 0)) 0))
|
||||
|
||||
; -1 is an invalid item id
|
||||
; FUTURE: '(not (gimp-item-id-is-valid -1))
|
||||
(assert '(= (car (gimp-item-id-is-valid -1)) 0))
|
||||
|
|
@ -0,0 +1,64 @@
|
|||
; 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.
|
||||
|
||||
; creates images 1-6
|
||||
(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 "layer-new.scm") ; image 7 and layer 8
|
||||
(testing:load-test "layer-ops.scm") ; image 8 and layer 10
|
||||
(testing:load-test "layer-mask.scm") ; image 9 and layer 12 and layerMask 13, 14
|
||||
; TODO layer stack ops
|
||||
|
||||
(testing:load-test "text-layer-new.scm") ; image 8, layer 15, vectors 16
|
||||
|
||||
(testing:load-test "vectors-new.scm") ; image 10 and vectors 19
|
||||
|
||||
(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.
|
||||
(testing:load-test "item.scm")
|
||||
; todo item order
|
||||
|
||||
; TODO drawable
|
||||
|
||||
(testing:load-test "resource.scm")
|
||||
(testing:load-test "brush.scm")
|
||||
; TODO other resources gradient, etc
|
||||
|
||||
; TODO edit ops
|
||||
; TODO undo
|
||||
; TODO unit
|
||||
; TODO progress
|
||||
; pdb
|
||||
; context
|
||||
; gimp the class, gimp-get, gimp-parasite
|
||||
|
||||
; parasite is not a class, only methods of other classes
|
||||
|
||||
(testing:load-test "misc.scm")
|
||||
(testing:load-test "enums.scm")
|
||||
|
||||
; report the result
|
||||
(testing:report)
|
||||
|
||||
; yield the session result
|
||||
(testing:all-passed?)
|
||||
|
||||
|
|
@ -0,0 +1,43 @@
|
|||
; Test methods of Resource class
|
||||
|
||||
; Testing may depend on fresh install.
|
||||
; Depends on the default context.
|
||||
|
||||
; !!! ScriptFu currently traffics in string names of resources
|
||||
; FUTURE traffic in numeric ID
|
||||
; FIXME numerous script-fu/scripts that deal with brush using name strings
|
||||
|
||||
; a brush from context is a string
|
||||
(assert '(string=?
|
||||
(car (gimp-context-get-brush))
|
||||
"2. Hardness 050"))
|
||||
|
||||
; gimp-brush-get-by-name returns same string, when brush of that name exists
|
||||
(assert '(string=?
|
||||
(car (gimp-brush-get-by-name "2. Hardness 050"))
|
||||
"2. Hardness 050"))
|
||||
|
||||
; gimp-brush-get-by-name returns error, when brush of that name not exists
|
||||
(assert-error '(gimp-brush-get-by-name "foo")
|
||||
"Procedure execution of gimp-brush-get-by-name failed on invalid input arguments: Brush 'foo' not found")
|
||||
|
||||
|
||||
|
||||
; TODO the rest of these require ScriptFu to traffic in numeric ID
|
||||
|
||||
;(assert '(= (gimp-resource-id-is-valid
|
||||
; (car (gimp-context-get-brush))
|
||||
; 1))
|
||||
|
||||
;gimp-resource-
|
||||
;delete
|
||||
;duplicate
|
||||
;get-name
|
||||
;id-is-brush
|
||||
;id-is-font
|
||||
;id-is_gradient
|
||||
;id-is-palette
|
||||
;id-is-pattern
|
||||
;id-is-valid
|
||||
;is-editable
|
||||
;rename
|
||||
|
|
@ -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 `(gimp-selection-none ,testImage))
|
||||
; test the testFunction
|
||||
(assert `(,testFunction
|
||||
,testImage
|
||||
4 )) ; radius or step
|
||||
; expect selection is still empty
|
||||
(assert `(= (car (gimp-selection-is-empty ,testImage))
|
||||
1))
|
||||
; expect since there is no selection, the bounds are the entire image
|
||||
(assert `(equal? (cdr (gimp-selection-bounds ,testImage))
|
||||
'(0 0 21 22)))
|
||||
)
|
||||
|
||||
(define (test-selection-change-from-all testFunction testImage isIdempotent)
|
||||
; Starting state: selection all
|
||||
(assert `(gimp-selection-all ,testImage))
|
||||
; test the testFunction
|
||||
(assert `(,testFunction
|
||||
,testImage
|
||||
4 )) ; radius or step
|
||||
|
||||
(if isIdempotent
|
||||
(begin
|
||||
; expect selection is still not empty
|
||||
(assert `(= (car (gimp-selection-is-empty ,testImage))
|
||||
0))
|
||||
; expect selection bounds are still entire image
|
||||
(assert `(equal? (cdr (gimp-selection-bounds ,testImage))
|
||||
'(0 0 21 22)))))
|
||||
)
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
; test selection methods that change by a pixel amount
|
||||
(test-selection-change-from-none gimp-selection-feather testImage)
|
||||
(test-selection-change-from-none gimp-selection-grow testImage)
|
||||
(test-selection-change-from-none gimp-selection-shrink testImage)
|
||||
(test-selection-change-from-none gimp-selection-border testImage)
|
||||
|
||||
; feather and grow from all are idempotent
|
||||
(test-selection-change-from-all gimp-selection-feather testImage #t)
|
||||
(test-selection-change-from-all gimp-selection-grow testImage #t)
|
||||
|
||||
(test-selection-change-from-all gimp-selection-shrink testImage #f)
|
||||
; shrink from all changes bounds
|
||||
(assert `(equal? (cdr (gimp-selection-bounds ,testImage))
|
||||
'(4 4 17 18)))
|
||||
(test-selection-change-from-all gimp-selection-border testImage #f)
|
||||
; border from all empties the selection
|
||||
(assert `(= (car (gimp-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 (gimp-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 `(gimp-selection-flood ,testImage))
|
||||
(assert `(gimp-selection-invert ,testImage))
|
||||
(assert `(gimp-selection-sharpen ,testImage))
|
||||
(assert `(gimp-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
|
||||
|
|
@ -0,0 +1,111 @@
|
|||
; Test methods of selection class of the PDB
|
||||
|
||||
|
||||
|
||||
; setup
|
||||
; Reusing image 10
|
||||
(define testImage 10)
|
||||
|
||||
|
||||
; get-selection yields an ID.
|
||||
; Image always yields a selection object.
|
||||
; It is a singleton.
|
||||
(assert `(= (car (gimp-image-get-selection ,testImage))
|
||||
18))
|
||||
|
||||
(define testSelection 18)
|
||||
|
||||
; The returned ID is-a Selection
|
||||
(assert `(= (car (gimp-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 (gimp-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 (gimp-selection-bounds ,testImage))
|
||||
0))
|
||||
; selection bounds equal bounds of image
|
||||
(assert `(equal? (cdr (gimp-selection-bounds ,testImage))
|
||||
'(0 0 21 22)))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
; select all and none
|
||||
|
||||
; select all succeeds
|
||||
(assert `(gimp-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 (gimp-image-get-selection ,testImage))
|
||||
,testSelection))
|
||||
; after select all, selection bound indicates selection created
|
||||
(assert `(= (car (gimp-selection-bounds ,testImage))
|
||||
1))
|
||||
; and now is-empty is false
|
||||
(assert `(= (car (gimp-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 `(gimp-selection-none ,testImage))
|
||||
; effective: is-empty is true
|
||||
(assert `(= (car (gimp-selection-is-empty ,testImage))
|
||||
1))
|
||||
; same singleton on image exists
|
||||
(assert `(= (car (gimp-image-get-selection ,testImage))
|
||||
,testSelection))
|
||||
|
||||
|
||||
; misc selection operations
|
||||
|
||||
; gimp-selection-value
|
||||
|
||||
|
||||
; change selection to totally new selection
|
||||
; Not a function of existing selection, by color or shape.
|
||||
|
||||
;gimp-image-select-color
|
||||
; ,testImage
|
||||
; CHANNEL-OP-ADD
|
||||
; drawable
|
||||
; "red")
|
||||
|
||||
; gimp-image-select-contiguous-color
|
||||
; ellipse
|
||||
; polygon
|
||||
; rectangle
|
||||
; round-rectangle
|
||||
|
||||
|
||||
|
||||
|
||||
; gimp-selection-float is tested elsewhere
|
||||
; It is not an op on the selection, but an op on the image that uses the selection.
|
||||
; See gimp-image-floating-selection
|
||||
|
|
@ -0,0 +1,148 @@
|
|||
; tests of TextLayer class
|
||||
|
||||
; !!! Some methods tested here are named strangely:
|
||||
; text-fontname returns a new TextLayer
|
||||
|
||||
|
||||
|
||||
|
||||
; No setup
|
||||
; Reuses image 8 from prior testing
|
||||
; Require it has no layer
|
||||
|
||||
|
||||
|
||||
; new
|
||||
|
||||
; new yields ID 15
|
||||
(assert '(= (car (gimp-text-layer-new
|
||||
8 ; image
|
||||
"textOfTestTextLayer" ; text
|
||||
"fontName" ; fontname
|
||||
30 ; fontsize
|
||||
UNIT-PIXEL))
|
||||
15))
|
||||
|
||||
; !!!! 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 GimpUnitsType is distinct from PIXELS GimpSizeType
|
||||
|
||||
|
||||
; TODO test UNIT-POINT
|
||||
|
||||
|
||||
; is-a TextLayer
|
||||
(assert '(= (car (gimp-item-id-is-text-layer 15))
|
||||
1))
|
||||
|
||||
; text layer is not in image yet
|
||||
(assert '(= (car (gimp-image-get-layers 8))
|
||||
0))
|
||||
|
||||
; adding layer to image succeeds
|
||||
(assert '(gimp-image-insert-layer
|
||||
8 ; image
|
||||
15 ; layer
|
||||
0 ; parent
|
||||
0 )) ; position within parent
|
||||
|
||||
|
||||
|
||||
|
||||
; attributes
|
||||
|
||||
; antialias default true
|
||||
; FIXME doc says false
|
||||
(assert '(= (car (gimp-text-layer-get-antialias 15))
|
||||
1))
|
||||
|
||||
; base-direction default TEXT-DIRECTION-LTR
|
||||
(assert '(= (car (gimp-text-layer-get-base-direction 15))
|
||||
TEXT-DIRECTION-LTR))
|
||||
|
||||
; language default "C"
|
||||
(assert '(string=? (car (gimp-text-layer-get-language 15))
|
||||
"C"))
|
||||
|
||||
; TODO other attributes
|
||||
|
||||
; TODO setters effective
|
||||
|
||||
; attributes as given
|
||||
|
||||
; text
|
||||
(assert '(string=? (car (gimp-text-layer-get-text 15))
|
||||
"textOfTestTextLayer"))
|
||||
; font
|
||||
(assert '(string=? (car (gimp-text-layer-get-font 15))
|
||||
"fontName"))
|
||||
; font-size
|
||||
(assert '(= (car (gimp-text-layer-get-font-size 15))
|
||||
30))
|
||||
|
||||
; is no method to get fontSize unit
|
||||
|
||||
|
||||
; misc ops
|
||||
|
||||
; vectors from text yields ID 16
|
||||
(assert '(= (car (gimp-vectors-new-from-text-layer
|
||||
8 ; image
|
||||
15)) ; text layer
|
||||
16))
|
||||
|
||||
|
||||
|
||||
; misc method
|
||||
|
||||
; gimp-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 (gimp-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
|
||||
|
||||
|
||||
; gimp-text-fontname creates text layer and inserts it into image
|
||||
(assert '(= (car (gimp-text-fontname
|
||||
8 ; image
|
||||
-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" )) ; fontname
|
||||
17))
|
||||
;
|
||||
|
||||
; error to insert layer created by gimp-text-fontname
|
||||
(assert-error '(gimp-image-insert-layer
|
||||
8 ; image
|
||||
17 ; layer
|
||||
0 ; parent
|
||||
0 ) ; position within parent
|
||||
(string-append
|
||||
"Procedure execution of gimp-image-insert-layer failed on invalid input arguments: "
|
||||
"Item 'bar' (17) has already been added to an image"))
|
||||
|
||||
|
||||
|
||||
; for debugging: display
|
||||
(assert '(= (car (gimp-display-new 8))
|
||||
1))
|
||||
|
|
@ -0,0 +1,89 @@
|
|||
|
||||
; Test methods of vector class of the PDB
|
||||
|
||||
; aka Path. Image has set of Paths. Path has strokes.
|
||||
|
||||
|
||||
; setup
|
||||
; Not all tests here use this image
|
||||
; test-image is no immutable and can be redefined?
|
||||
|
||||
; from fresh GIMP state returns ID 10
|
||||
(define test-image (car (gimp-image-new 21 22 RGB)))
|
||||
(assert `(= ,test-image 10))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
; ID methods
|
||||
|
||||
; ensure ID 0 and negative are not vectors
|
||||
; FIXME #f/#t
|
||||
(assert '(= (car (gimp-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 (gimp-image-get-vectors ,test-image))
|
||||
0))
|
||||
|
||||
|
||||
; vectors-new succeeds
|
||||
(assert `(car (gimp-vectors-new
|
||||
,test-image
|
||||
"Test Path")))
|
||||
|
||||
; from fresh GIMP state, path ID is 19
|
||||
(define test-path 19)
|
||||
|
||||
|
||||
; !!! id is valid even though vectors is not inserted in image
|
||||
(assert `(= (car (gimp-item-id-is-vectors ,test-path))
|
||||
1)) ; #t
|
||||
|
||||
; new path name is as given
|
||||
(assert `(string=?
|
||||
(car (gimp-item-get-name ,test-path))
|
||||
"Test Path"))
|
||||
|
||||
; new vectors is not in image yet
|
||||
; image still has count of vectors == 0
|
||||
(assert `(= (car (gimp-image-get-vectors ,test-image))
|
||||
0))
|
||||
|
||||
; new path has no strokes
|
||||
; path has stroke count == 0
|
||||
(assert `(= (car (gimp-vectors-get-strokes ,test-path))
|
||||
0))
|
||||
|
||||
|
||||
; insert vector in image yields (#t)
|
||||
(assert `(car (gimp-image-insert-vectors
|
||||
,test-image
|
||||
,test-path
|
||||
0 0))) ; parent=0 position=0
|
||||
|
||||
; image with inserted vectors now has count of vectors == 1
|
||||
(assert `(= (car (gimp-image-get-vectors ,test-image))
|
||||
1))
|
||||
|
||||
; export to string succeeds
|
||||
(assert `(gimp-vectors-export-to-string
|
||||
,test-image
|
||||
,test-path))
|
||||
|
||||
; export-to-string all
|
||||
; FAIL: crashes
|
||||
; PDB doc says 0 should work, and ScriptFu is marshalling to a null GimpVectors*
|
||||
; so the PDB function in C is at fault?
|
||||
;(assert `(gimp-vectors-export-to-string
|
||||
; ,test-image
|
||||
; 0))
|
||||
|
|
@ -0,0 +1,173 @@
|
|||
|
||||
; 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
|
||||
; FIXME need a test with other locale?
|
||||
|
||||
; 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)
|
||||
"
|
||||
"))
|
||||
; TODO #\return
|
||||
|
||||
; char, ASCII, non-printing control
|
||||
; FIXME, should yield a single glyph.
|
||||
; !!! It should not yield a sharp constant "#\x7"
|
||||
(assert `(string=? (atom->string #\x7)
|
||||
""))
|
||||
; !!! This also passes, because readstring interprets
|
||||
; the \x.. escape sequence.
|
||||
(assert `(string=? (atom->string #\x7)
|
||||
"\x07"))
|
||||
|
||||
|
||||
; multi-byte UTF-8 encode chars
|
||||
|
||||
; char, unichar outside the ASCII range
|
||||
; FIXME: needs unichar fixes
|
||||
; (assert `(string=? (atom->string 'a)
|
||||
; "a"))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
; symbol
|
||||
(assert `(string=? (atom->string 'gimp-message)
|
||||
"gimp-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 gimp-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.
|
||||
|
|
@ -0,0 +1,78 @@
|
|||
|
||||
; Test cases for cond-expand in ScriptFu interpreter of GIMP 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.
|
||||
; GIMP 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"))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,80 @@
|
|||
; test integer->char function
|
||||
|
||||
; Is R5RS, but with unicode
|
||||
|
||||
|
||||
; 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
|
||||
; whose repr in the REPL is #\x0
|
||||
; > (integer->char 0)
|
||||
; "#\x0"
|
||||
|
||||
; Converting the atom to string yields an empty string
|
||||
(assert `(string=? (atom->string (integer->char 0))
|
||||
""))
|
||||
|
||||
; ASCII null terminates the string early, so to speak.
|
||||
|
||||
; You can also represent as escaped hex "x\00"
|
||||
(assert `(string=? "\x00"
|
||||
""))
|
||||
; Escaped hex must have more than one hex digit.
|
||||
; Can't be tested: (assert-error `(string? "\x0") "Error reading string ")
|
||||
; In REPL:
|
||||
; > "\x0"
|
||||
; Error: Error reading string
|
||||
|
||||
|
||||
; the first non-ASCII character;
|
||||
|
||||
; TODO (integer->char 128),
|
||||
|
||||
|
||||
; first Unicode character outside the 8-bit range;
|
||||
|
||||
; evaluates without complaint
|
||||
(assert (integer->char 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 `(= (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))
|
||||
"𐀀"))
|
||||
|
||||
; !!! Note the SF Console REPL yields #\
|
||||
; which is not the correct representation.
|
||||
; FIXME
|
||||
|
|
@ -0,0 +1,52 @@
|
|||
; 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.
|
||||
|
||||
|
||||
; 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))
|
||||
|
||||
; 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))
|
||||
|
||||
|
|
@ -0,0 +1,236 @@
|
|||
; 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.
|
||||
|
||||
; FIXME: sharp followed by space parses as a token,
|
||||
; but I don't know that it is legal syntax
|
||||
; See the code, there is a space here: " tfodxb\\"
|
||||
|
||||
; #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
|
||||
; FIXME currently is syntax error, untestable.
|
||||
; It should not be a syntax error.
|
||||
; (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
|
||||
; FIXME (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 "undefined sharp expression" in REPL
|
||||
; FIXME: the error message should be more specific, should say "syntax"
|
||||
|
||||
; sharp constant hex having non-hex digit is an error
|
||||
; z is not in [a-f0-9]
|
||||
; Only testable in REPL
|
||||
; > #\xz
|
||||
; Error: undefined sharp expression
|
||||
; Not testable here since it is syntax
|
||||
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,105 @@
|
|||
; 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 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) #\λ))
|
||||
|
||||
; hex sharp char is same as sharp char
|
||||
(assert (equal? #\x3bb #\λ))
|
||||
(assert '(char? #\x3bb))
|
||||
|
||||
; Unichar extracted from string equals sharp char expr unicode
|
||||
(assert (equal? (string-ref "λ" 0) #\λ))
|
||||
|
||||
|
||||
; Omitted, a test of the REPL
|
||||
; quoted Unichar is equal to its usual representation
|
||||
(assert `(equal? ,λ #\λ))
|
||||
|
||||
; a sharp char expr unicode is-a char
|
||||
(assert (char? #\λ))
|
||||
|
||||
|
||||
; sharp char expr unicode passed to string function
|
||||
(assert (equal? (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)) '#(#\λ))
|
||||
|
||||
|
||||
; Omitted: a test of REPL
|
||||
; display unichar
|
||||
; > (display (string-ref "λ" 0))
|
||||
; λ#t
|
||||
|
||||
|
||||
; This is 0x7 BEL
|
||||
; TODO for greek lambda unicode char
|
||||
; string function takes sequence of chars
|
||||
(assert (equal? (string #\) ""))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
; unichar in context of other expressions
|
||||
|
||||
; unichar evaluated after evaluating display.
|
||||
; Prints side effect of display
|
||||
; followed by value of the last expression, a unichar
|
||||
;> (begin (display "Unicode lambda char: ") (string-ref "λ" 0))
|
||||
;Unicode lambda char: #\λ
|
||||
|
||||
; Single Unicode character outside of string can be displayed in error
|
||||
;>(display "Unicode lambda char: ")(error "testUnicodeKo1: " (string-ref "λ" 0))
|
||||
;Unicode lambda char: #tError: testUnicodeKo1: #\λ
|
||||
; TODO this test seems to infinite loop
|
||||
; Maybe the problems is catting string to char
|
||||
;(assert-error `(error "Error: " (string-ref "λ" 0))
|
||||
; "Error: λ")
|
||||
;(assert-error `(error "Error: " "λ")
|
||||
; "Error: λ")
|
||||
;(assert-error `(error "Error λ")
|
||||
; "Error: λ")
|
||||
; Seems to be flaw in testing framework
|
||||
|
||||
|
||||
|
||||
; Edge case: first invalid codepoint greater than max valid
|
||||
; '#\x110000
|
||||
; TODO
|
||||
|
||||
; A codepoint that fits in 32 bits but invalid UTF-8 encoding
|
||||
; '#\xd800
|
||||
; TODO
|
||||
|
||||
; sharp constant hex exceeding max range of int 32 codepoint
|
||||
; longer than 8 hex digits \xf87654321
|
||||
|
||||
; FIXME currently this fails to pass or fail
|
||||
; Yields #\! in the REPL ????
|
||||
; (assert '#\xf87654321 )
|
||||
|
||||
; FIXME This passes but it should not.
|
||||
; It should be a syntax or other error
|
||||
; If syntax, not testable here.
|
||||
(assert `(not (null? #\xf87654321 )))
|
||||
|
|
@ -0,0 +1,86 @@
|
|||
; 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.
|
||||
|
||||
; FIXME: sharp followed by space parses as a token,
|
||||
; but I don't know that it is legal syntax
|
||||
; See the code, there is a space here: " tfodxb\\"
|
||||
|
||||
; #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
|
||||
; TODO only testable in REPL?
|
||||
; Note there is a newline after foo
|
||||
;(assert '#! foo
|
||||
; )
|
||||
|
||||
; #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?
|
||||
|
||||
|
|
@ -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))))
|
||||
|
||||
|
||||
|
||||
|
|
@ -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")
|
||||
|
||||
|
||||
|
|
@ -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")
|
||||
; Currently failing badly (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?)
|
||||
|
||||
|
|
@ -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? 'λ))
|
||||
|
|
@ -0,0 +1,84 @@
|
|||
; test vector methods of TS
|
||||
|
||||
|
||||
|
||||
; make-vector
|
||||
|
||||
; make-vector succeeds
|
||||
(assert '(make-vector 25))
|
||||
|
||||
; 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:")
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,271 @@
|
|||
# Testing ScriptFu using the testing framework
|
||||
|
||||
## Quick start
|
||||
|
||||
0. Rebuild GIMP with the ScriptFu compile option 'no line numbers in error messages' (see below.)
|
||||
The build must be a non-stable build (nightly/development version.)
|
||||
1. View the Gimp 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 Gimp 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 "Gimp 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 GIMP 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 GIMP 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 GIMP 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 GIMP 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 Gimp.
|
||||
|
||||
### 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?) .
|
||||
|
||||
### Gimp State
|
||||
|
||||
Gimp state includes open images, installed resources, the selection, etc.
|
||||
Testing has side effects on Gimp state.
|
||||
|
||||
To ensure tests succeed, you should test a new install of Gimp.
|
||||
If you don't mind a few failed tests,
|
||||
you can test later than a new install.
|
||||
|
||||
Tests may require that GIMP be newly started:
|
||||
|
||||
1. PDB tests may hardcode certain constant ID's and rely on GIMP
|
||||
to consistently number ID's.
|
||||
|
||||
Tests may require that GIMP be newly installed:
|
||||
|
||||
1. PDB tests may depend on the initial set of Gimp resources in ~/.config/GIMP
|
||||
|
||||
## 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.
|
||||
To do that requires that TinyScheme be built without the compile option
|
||||
to display file and line number in error messages.
|
||||
Since file paths change across platforms,
|
||||
and since the test scripts should not reference line numbers.
|
||||
|
||||
|
||||
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 Gimp state.
|
||||
|
||||
### Tests are order dependent
|
||||
|
||||
Generally, you cannot run the tests in any order.
|
||||
The tests may hardcode GIMP ID's that GIMP assigns,
|
||||
thus the test order is also fixed.
|
||||
|
||||
In general, run a large test, such as pdb.scm or tinyscheme.scm.
|
||||
|
||||
### 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 GIMP Error Console
|
||||
using gimp-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 Gimp 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 gimp-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.
|
||||
|
||||
|
||||
|
||||
Loading…
Reference in New Issue