mirror of https://github.com/GNOME/gimp.git
ScriptFu: change binding of resource from string to int
Fix #9991 And change test cases And fix string-prefix? function in testing framework
This commit is contained in:
bootchk
Lloyd Konneker
parent
623becd72d
commit
bfaebccf4e
|
|
@ -360,7 +360,7 @@ marshal_returned_PDB_value (scheme *sc,
|
|||
|
||||
/* Order is important.
|
||||
* GFile before other objects.
|
||||
* GIMP resource objects before GIMP Image, Drawable, etc. objects.
|
||||
* GIMP Image, Drawable, etc. objects.
|
||||
* Alternatively, more specific tests.
|
||||
*/
|
||||
if (G_VALUE_TYPE (value) == G_TYPE_FILE)
|
||||
|
|
@ -381,28 +381,12 @@ marshal_returned_PDB_value (scheme *sc,
|
|||
}
|
||||
/* Ensure result holds a string, possibly empty. */
|
||||
}
|
||||
else if (GIMP_VALUE_HOLDS_RESOURCE (value))
|
||||
{
|
||||
/* ScriptFu represents resource objects by ther unique string ID's. */
|
||||
GObject *object = g_value_get_object (value);
|
||||
gchar *name = NULL;
|
||||
|
||||
if (object)
|
||||
name = gimp_resource_get_name (GIMP_RESOURCE (object));
|
||||
|
||||
if (! name)
|
||||
g_warning ("PDB procedure returned NULL object.");
|
||||
|
||||
result = sc->vptr->mk_string (sc, name);
|
||||
|
||||
g_free (name);
|
||||
}
|
||||
else if (G_VALUE_HOLDS_OBJECT (value))
|
||||
{
|
||||
/* G_VALUE_HOLDS_OBJECT only ensures value derives from GObject.
|
||||
* Could be a GIMP or a GLib type.
|
||||
* Here we handle GIMP types, which all have an id property.
|
||||
* Resources have a string ID and Images and Drawables etc. have an int ID.
|
||||
* Resources, Images, Drawables etc. have an int ID.
|
||||
*/
|
||||
GObject *object = g_value_get_object (value);
|
||||
gint id = -1;
|
||||
|
|
|
|||
|
|
@ -1257,15 +1257,20 @@ script_fu_marshal_procedure_call (scheme *sc,
|
|||
}
|
||||
else if (GIMP_VALUE_HOLDS_RESOURCE (&value))
|
||||
{
|
||||
if (! sc->vptr->is_string (sc->vptr->pair_car (a)))
|
||||
return script_type_error (sc, "string", i, proc_name);
|
||||
if (! sc->vptr->is_integer (sc->vptr->pair_car (a)))
|
||||
return script_type_error (sc, "integer", i, proc_name);
|
||||
else
|
||||
{
|
||||
/* Create new instance of a resource object. */
|
||||
GimpResource *resource;
|
||||
GType type = G_VALUE_TYPE (&value);
|
||||
const gchar *name = sc->vptr->string_value (sc->vptr->pair_car (a));
|
||||
resource = gimp_resource_get_by_name (type, name);
|
||||
|
||||
gint resource_id = sc->vptr->ivalue (sc->vptr->pair_car (a));
|
||||
/* Superclass is Resource, subclass is e.g. Brush.
|
||||
* Superclass is abstract, can't instantiate it.
|
||||
* This returns an instance of the appropriate subclass for the ID.
|
||||
* ID's are unique across all instances of Resource.
|
||||
*/
|
||||
resource = gimp_resource_get_by_id (resource_id);
|
||||
|
||||
g_value_set_object (&value, resource);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -346,12 +346,20 @@
|
|||
str))))
|
||||
(rtrim (to-string any))))
|
||||
|
||||
; FIXME this is not robust to str2 shorter than str1
|
||||
|
||||
; string-prefix? is in R5RS but not tinyscheme.
|
||||
; string-prefix? is in various SRFI's but we don't have them here
|
||||
; So yet again, we need to implement it de novo
|
||||
(define (string-prefix? str1 str2)
|
||||
(string=?
|
||||
str1
|
||||
(substring str2 0 (string-length str1))))
|
||||
; if str1 is longer than str2, it is not a prefix
|
||||
(if (> (string-length str1) (string-length str2))
|
||||
#f
|
||||
; else str2 is longer str2 than str1.
|
||||
; str1 is a prefix if the leading substring of str2,
|
||||
; that is the length of str1, equals str1.
|
||||
(string=?
|
||||
str1
|
||||
(substring str2 0 (string-length str1)))))
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -24,9 +24,11 @@ if not stable
|
|||
'tests' / 'PDB' / 'selection' / 'selection.scm',
|
||||
'tests' / 'PDB' / 'selection' / 'selection-from.scm',
|
||||
'tests' / 'PDB' / 'resource' / 'resource.scm',
|
||||
'tests' / 'PDB' / 'resource' / 'resource-ops.scm',
|
||||
'tests' / 'PDB' / 'resource' / 'brush.scm',
|
||||
'tests' / 'PDB' / 'resource' / 'palette.scm',
|
||||
'tests' / 'PDB' / 'context' / 'context-get-set.scm',
|
||||
'tests' / 'PDB' / 'context' / 'context-resource.scm',
|
||||
# TODO context push pop list-paint-methods
|
||||
'tests' / 'PDB' / 'buffer.scm',
|
||||
'tests' / 'PDB' / 'misc.scm',
|
||||
|
|
|
|||
|
|
@ -0,0 +1,113 @@
|
|||
; test resource methods of Context
|
||||
|
||||
|
||||
|
||||
; function to test methods on Resource
|
||||
; for a valid Resource ID
|
||||
(define (test-resource-methods resource)
|
||||
|
||||
; a resource is an int ID in ScriptFu
|
||||
(assert `(integer? ,resource))
|
||||
|
||||
; get-name returns a string
|
||||
(assert `(string? (car (gimp-resource-get-name ,resource))))
|
||||
|
||||
; id-is-valid returns truth
|
||||
; (1) FUTURE #t
|
||||
(assert `(car (gimp-resource-id-is-valid ,resource)))
|
||||
|
||||
; gimp-resource-get-identifiers succeeds
|
||||
; it returns a triplet
|
||||
(assert `(gimp-resource-get-identifiers ,resource))
|
||||
|
||||
; gimp-resource-get-identifiers returns numeric for is-internal
|
||||
; Some of the fresh gimp active resource are internal, some not !!!
|
||||
(assert `(number? (car (gimp-resource-get-identifiers ,resource))))
|
||||
|
||||
; name from get-identifiers is same as from gimp-resource-get-name
|
||||
; name is second field of triplet i.e. cadr
|
||||
(assert `(string=? (cadr (gimp-resource-get-identifiers ,resource))
|
||||
(car (gimp-resource-get-name ,resource))))
|
||||
|
||||
; gimp-resource-is-editable succeeds
|
||||
; Returns a wrapped boolean
|
||||
(assert `(gimp-resource-is-editable ,resource))
|
||||
|
||||
; The fresh gimp active resources are all system resources i.e. not editable
|
||||
; returns 0 for #f
|
||||
(assert `(= (car(gimp-resource-is-editable ,resource))
|
||||
0))
|
||||
)
|
||||
|
||||
; "Test Parasite") ; name
|
||||
; "Procedure execution of gimp-resource-get-parasite failed")
|
||||
|
||||
|
||||
|
||||
; test context-get-resource returns active resource of given className
|
||||
; Setup. Not assert.
|
||||
|
||||
(define testBrush (car (gimp-context-get-resource "GimpBrush")))
|
||||
(define testFont (car (gimp-context-get-resource "GimpFont")))
|
||||
(define testGradient (car (gimp-context-get-resource "GimpGradient")))
|
||||
(define testPalette (car (gimp-context-get-resource "GimpPalette")))
|
||||
(define testPattern (car (gimp-context-get-resource "GimpPattern")))
|
||||
; FUTURE Dynamics and other Resource subclasses
|
||||
|
||||
|
||||
; test methods on active resource ID's
|
||||
|
||||
(test-resource-methods testBrush)
|
||||
(test-resource-methods testFont)
|
||||
(test-resource-methods testGradient)
|
||||
(test-resource-methods testPalette)
|
||||
(test-resource-methods testPattern)
|
||||
|
||||
|
||||
; test more specific context methods return same result
|
||||
; as the general context-get-resource
|
||||
|
||||
; test equality of numeric IDs
|
||||
(assert `(= (car(gimp-context-get-brush))
|
||||
,testBrush))
|
||||
(assert `(= (car(gimp-context-get-font))
|
||||
,testFont))
|
||||
(assert `(= (car(gimp-context-get-gradient))
|
||||
,testGradient))
|
||||
(assert `(= (car(gimp-context-get-palette))
|
||||
,testPalette))
|
||||
(assert `(= (car(gimp-context-get-pattern))
|
||||
,testPattern))
|
||||
|
||||
|
||||
; test resource-id-is-foo methods
|
||||
|
||||
; the resource IDs from setup work with the specific id-is-foo methods
|
||||
|
||||
(assert `(= (car(gimp-resource-id-is-brush ,testBrush))
|
||||
1))
|
||||
(assert `(= (car(gimp-resource-id-is-font ,testFont))
|
||||
1))
|
||||
(assert `(= (car(gimp-resource-id-is-gradient ,testGradient))
|
||||
1))
|
||||
(assert `(= (car(gimp-resource-id-is-palette ,testPalette))
|
||||
1))
|
||||
(assert `(= (car(gimp-resource-id-is-pattern ,testPattern))
|
||||
1))
|
||||
|
||||
|
||||
; test errors
|
||||
|
||||
|
||||
; invalid type name
|
||||
(assert-error `(gimp-context-get-resource "InvalidTypeName")
|
||||
"Procedure execution of gimp-context-get-resource failed")
|
||||
|
||||
; invalid numeric ID
|
||||
; -1 is out of range
|
||||
(assert-error `(gimp-resource-get-name -1)
|
||||
"Procedure execution of gimp-resource-get-name failed on invalid input arguments:")
|
||||
; 12345678 is in range but invalid
|
||||
(assert-error `(gimp-resource-get-name 12345678)
|
||||
"Procedure execution of gimp-resource-get-name failed on invalid input arguments:")
|
||||
|
||||
|
|
@ -21,7 +21,9 @@
|
|||
(testing:load-test "layer-mask.scm")
|
||||
; TODO layer stack ops
|
||||
|
||||
(testing:load-test "text-layer-new.scm")
|
||||
; Commented out until PDB is fixed
|
||||
; Known to crash GIMP
|
||||
;(testing:load-test "text-layer-new.scm")
|
||||
|
||||
(testing:load-test "vectors-new.scm")
|
||||
(testing:load-test "channel-new.scm")
|
||||
|
|
@ -34,15 +36,25 @@
|
|||
; 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
|
||||
; commented out until text-get-fontname is fixed
|
||||
; Known to crash GIMP
|
||||
;(testing:load-test "item.scm")
|
||||
; todo item ordering operations
|
||||
|
||||
; TODO drawable
|
||||
|
||||
; context
|
||||
(testing:load-test "context-get-set.scm")
|
||||
|
||||
; Temporarily commented out until gimpgpparam-body.c is fixed for GimpParamResource
|
||||
; If you uncomment it, see warnings in stderr
|
||||
;(testing:load-test "context-resource.scm")
|
||||
|
||||
(testing:load-test "resource.scm")
|
||||
(testing:load-test "brush.scm")
|
||||
(testing:load-test "palette.scm")
|
||||
; TODO other resources gradient, etc
|
||||
(testing:load-test "resource-ops.scm")
|
||||
|
||||
(testing:load-test "buffer.scm")
|
||||
|
||||
|
|
@ -61,7 +73,6 @@
|
|||
(testing:load-test "misc.scm")
|
||||
(testing:load-test "enums.scm")
|
||||
(testing:load-test "refresh.scm")
|
||||
(testing:load-test "context-get-set.scm")
|
||||
(testing:load-test "bind-args.scm")
|
||||
|
||||
; report the result
|
||||
|
|
|
|||
|
|
@ -1,101 +1,121 @@
|
|||
; 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.
|
||||
; In future, will be possible to create new brush with same name as existing?
|
||||
|
||||
|
||||
; new and delete
|
||||
; new
|
||||
|
||||
|
||||
; new succeeds
|
||||
; setup, not an assert
|
||||
(define testNewBrush (car (gimp-brush-new "TestBrushNew")))
|
||||
|
||||
; a resource is an int ID in ScriptFu
|
||||
(assert `(number? ,testNewBrush))
|
||||
|
||||
; new returns brush of given name
|
||||
(assert '(string=?
|
||||
(car (gimp-brush-new "TestBrushNew"))
|
||||
; note call superclass method
|
||||
(assert `(string=?
|
||||
(car (gimp-resource-get-name ,testNewBrush))
|
||||
"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
|
||||
; attributes of new brush
|
||||
|
||||
; new brush is kind generated
|
||||
(assert '(equal?
|
||||
(car (gimp-brush-is-generated "TestBrushNew"))
|
||||
; new brush is kind generated versus raster
|
||||
(assert `(= (car (gimp-brush-is-generated ,testNewBrush))
|
||||
1))
|
||||
|
||||
; angle default is 0
|
||||
(assert '(=
|
||||
(car (gimp-brush-get-angle "TestBrushNew"))
|
||||
(assert `(=
|
||||
(car (gimp-brush-get-angle ,testNewBrush))
|
||||
0))
|
||||
|
||||
; aspect-ratio default is 1.0
|
||||
; FIXME: the doc says 0.0
|
||||
(assert '(=
|
||||
(car (gimp-brush-get-aspect-ratio "TestBrushNew"))
|
||||
(assert `(=
|
||||
(car (gimp-brush-get-aspect-ratio ,testNewBrush))
|
||||
1.0))
|
||||
|
||||
; hardness default is 0.5
|
||||
; FIXME: the doc says 0
|
||||
(assert '(=
|
||||
(car (gimp-brush-get-hardness "TestBrushNew"))
|
||||
(assert `(=
|
||||
(car (gimp-brush-get-hardness ,testNewBrush))
|
||||
0.5))
|
||||
|
||||
; shape default is GENERATED-CIRCLE
|
||||
(assert '(=
|
||||
(car (gimp-brush-get-shape "TestBrushNew"))
|
||||
(assert `(=
|
||||
(car (gimp-brush-get-shape ,testNewBrush))
|
||||
BRUSH-GENERATED-CIRCLE))
|
||||
|
||||
; spikes default is 2
|
||||
; FIXME: docs says 0
|
||||
(assert '(=
|
||||
(car (gimp-brush-get-spikes "TestBrushNew"))
|
||||
(assert `(=
|
||||
(car (gimp-brush-get-spikes ,testNewBrush))
|
||||
2))
|
||||
|
||||
; get-radius default 5.0
|
||||
; FIXME: docs says 0
|
||||
(assert '(=
|
||||
(car (gimp-brush-get-radius "TestBrushNew"))
|
||||
(assert `(=
|
||||
(car (gimp-brush-get-radius ,testNewBrush))
|
||||
5.0))
|
||||
|
||||
|
||||
; spacing default 20
|
||||
; FIXME: docs says 0
|
||||
(assert '(=
|
||||
(car (gimp-brush-get-spacing "TestBrushNew"))
|
||||
(assert `(=
|
||||
(car (gimp-brush-get-spacing ,testNewBrush))
|
||||
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)))
|
||||
(assert `(equal? (gimp-brush-get-info ,testNewBrush)
|
||||
`(11 11 1 0)))
|
||||
|
||||
; get-pixels returns a list of attributes
|
||||
; It is is long so we don't compare.
|
||||
; This test is just that it doesn't crash or return #f.
|
||||
(assert '(gimp-brush-get-pixels "TestBrushNew"))
|
||||
(assert `(gimp-brush-get-pixels ,testNewBrush))
|
||||
|
||||
|
||||
|
||||
; delete
|
||||
|
||||
; can delete a new brush
|
||||
; PDB returns void, ScriptFu returns wrapped truth i.e. (#t)
|
||||
(assert `(car (gimp-resource-delete ,testNewBrush)))
|
||||
|
||||
; delete was effective
|
||||
; ID is now invalid
|
||||
(assert `(= (car (gimp-resource-id-is-valid ,testNewBrush))
|
||||
0))
|
||||
|
||||
|
||||
|
||||
; Kind non-generated brush
|
||||
|
||||
; "z Pepper" is non-generated and is a system brush always installed
|
||||
; Brush named "z Pepper" is non-generated and is a system brush always installed
|
||||
|
||||
; setup, not an assert
|
||||
(define testNongenBrush (car (gimp-resource-get-by-name "GimpBrush" "z Pepper")))
|
||||
|
||||
; brush says itself is not generated
|
||||
|
||||
|
||||
|
||||
; Certain attributes of non-generated brush yield errors
|
||||
; angle, aspect-ratio, hardness, shape, spikes, radius
|
||||
|
||||
; angle
|
||||
|
||||
; angle is not an attribute of non-generated brush
|
||||
(assert-error
|
||||
'(gimp-brush-get-angle "z Pepper")
|
||||
`(gimp-brush-get-angle ,testNongenBrush)
|
||||
"Procedure execution of gimp-brush-get-angle failed")
|
||||
|
||||
; TODO all the other attributes
|
||||
|
|
@ -104,27 +124,28 @@
|
|||
; Non-generated brush attributes
|
||||
|
||||
; is not generated
|
||||
(assert '(=
|
||||
(car (gimp-brush-is-generated "z Pepper"))
|
||||
(assert `(=
|
||||
(car (gimp-brush-is-generated ,testNongenBrush))
|
||||
0))
|
||||
|
||||
; spacing
|
||||
(assert '(=
|
||||
(car (gimp-brush-get-spacing "z Pepper"))
|
||||
(assert `(=
|
||||
(car (gimp-brush-get-spacing ,testNongenBrush))
|
||||
100))
|
||||
|
||||
; pixels returns a list of attributes
|
||||
; FAIL: CRASH Inconsistency detected by ld.so: dl-runtime.c: 63: _dl_fixup: Assertion `ELFW(R_TYPE)(reloc->r_info) == ELF_MACHINE_JMP_SLOT' failed!
|
||||
; (assert '(gimp-brush-get-pixels "z Pepper"))
|
||||
; Known to fail because TS allocation of 120k byte contiguous cells for vector fails.
|
||||
; (assert `(gimp-brush-get-pixels ,testNongenBrush))
|
||||
|
||||
; get-info returns a list of attributes
|
||||
(assert '(equal? (gimp-brush-get-info "z Pepper")
|
||||
'(180 220 1 3)))
|
||||
|
||||
|
||||
|
||||
|
||||
(assert `(equal? (gimp-brush-get-info ,testNongenBrush)
|
||||
`(180 220 1 3)))
|
||||
|
||||
|
||||
|
||||
; miscellaneous
|
||||
|
||||
; 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")
|
||||
|
|
|
|||
|
|
@ -1,7 +1,6 @@
|
|||
; Test methods of palette 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 palettees in GIMP.
|
||||
|
|
@ -9,19 +8,16 @@
|
|||
; In future, will be possible to create new palette with same name as existing.
|
||||
|
||||
|
||||
; new and delete
|
||||
|
||||
; new returns palette of given name
|
||||
(assert '(string=?
|
||||
(car (gimp-palette-new "testPaletteNew"))
|
||||
"testPaletteNew"))
|
||||
|
||||
; TODO delete
|
||||
; can delete a new palette
|
||||
; FAIL _gimp_gp_param_def_to_param_spec: GParamSpec type unsupported 'GimpParamResource'
|
||||
;(assert '(string=?
|
||||
; (car (gimp-resource-delete "testPaletteNew"))
|
||||
; "testPaletteNew"))
|
||||
; setup, not assert
|
||||
; but tests the -new method
|
||||
(define testNewPalette (car (gimp-palette-new "testNewPalette")))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -31,65 +27,92 @@
|
|||
; gimp-palette-get-background deprecated => gimp-context-get-background
|
||||
; ditto foreground
|
||||
|
||||
; new palette has given name
|
||||
; !!! Fails if not a fresh install, then name is like "testNewPalette #2"
|
||||
(assert `(string=?
|
||||
(car (gimp-resource-get-name ,testNewPalette))
|
||||
"testNewPalette"))
|
||||
|
||||
; new palette has zero colors
|
||||
(assert '(= (car (gimp-palette-get-color-count "testPaletteNew"))
|
||||
(assert `(= (car (gimp-palette-get-color-count ,testNewPalette))
|
||||
0))
|
||||
|
||||
; new palette has empty colormap
|
||||
; (0 #())
|
||||
(assert '(= (car (gimp-palette-get-colors "testPaletteNew"))
|
||||
(assert `(= (car (gimp-palette-get-colors ,testNewPalette))
|
||||
0))
|
||||
|
||||
; new palette has zero columns
|
||||
; (0 #())
|
||||
(assert '(= (car (gimp-palette-get-columns "testPaletteNew"))
|
||||
(assert `(= (car (gimp-palette-get-columns ,testNewPalette))
|
||||
0))
|
||||
|
||||
; TODO is editable resource-is-editable
|
||||
; new palette is-editable
|
||||
; method on Resource class
|
||||
(assert `(= (car (gimp-resource-is-editable ,testNewPalette))
|
||||
1))
|
||||
|
||||
; can set new palette in context
|
||||
; Despite having empty colormap
|
||||
(assert `(gimp-context-set-palette ,testNewPalette))
|
||||
|
||||
|
||||
|
||||
; attributes of existing palette
|
||||
|
||||
; Max size palette 256
|
||||
; setup
|
||||
(define testBearsPalette (car (gimp-palette-get-by-name "Bears")))
|
||||
|
||||
|
||||
; Max size palette is 256
|
||||
|
||||
; Bears palette has 256 colors
|
||||
(assert '(= (car (gimp-palette-get-color-count "Bears"))
|
||||
(assert `(= (car (gimp-palette-get-color-count ,testBearsPalette))
|
||||
256))
|
||||
|
||||
; Bears palette colormap is size 256
|
||||
; (256)
|
||||
(assert '(= (car (gimp-palette-get-color-count "Bears"))
|
||||
(assert `(= (car (gimp-palette-get-color-count ,testBearsPalette))
|
||||
256))
|
||||
|
||||
; Bears palette colormap array is size 256 vector of 3-tuple lists
|
||||
; (256 #((8 8 8) ... ))
|
||||
(assert '(= (vector-length (cadr (gimp-palette-get-colors "Bears")))
|
||||
(assert `(= (vector-length (cadr (gimp-palette-get-colors ,testBearsPalette)))
|
||||
256))
|
||||
|
||||
; Bears palette has zero columns
|
||||
; (0 #())
|
||||
(assert (= (car (gimp-palette-get-columns "Bears"))
|
||||
(assert `(= (car (gimp-palette-get-columns ,testBearsPalette))
|
||||
0))
|
||||
|
||||
; TODO is not editable resource-is-editable
|
||||
; system palette is not editable
|
||||
(assert `(= (car (gimp-resource-is-editable ,testBearsPalette))
|
||||
0))
|
||||
|
||||
|
||||
|
||||
; setting attributes of existing palette
|
||||
|
||||
; Can not change column count on system palette
|
||||
(assert-error `(gimp-palette-set-columns "Bears" 1)
|
||||
(assert-error `(gimp-palette-set-columns ,testBearsPalette 1)
|
||||
"Procedure execution of gimp-palette-set-columns failed")
|
||||
|
||||
|
||||
; add entry to full system palette
|
||||
|
||||
; error to add entry to palette which is non-editable and has full colormap
|
||||
(assert-error `(gimp-palette-add-entry ,testBearsPalette "fooEntryName" "red")
|
||||
"Procedure execution of gimp-palette-add-entry failed ")
|
||||
|
||||
|
||||
|
||||
; setting attributes of new palette
|
||||
|
||||
; succeeds
|
||||
(assert `(gimp-palette-set-columns "testPaletteNew" 1))
|
||||
(assert `(gimp-palette-set-columns ,testNewPalette 1))
|
||||
|
||||
; effective
|
||||
(assert `(= (car (gimp-palette-get-columns "testPaletteNew"))
|
||||
(assert `(= (car (gimp-palette-get-columns ,testNewPalette))
|
||||
1))
|
||||
|
||||
|
||||
|
|
@ -97,43 +120,74 @@
|
|||
|
||||
; add first entry returns index 0
|
||||
; result is wrapped (0)
|
||||
(assert `(= (car (gimp-palette-add-entry "testPaletteNew" "fooEntryName" "red"))
|
||||
(assert `(= (car (gimp-palette-add-entry ,testNewPalette "fooEntryName" "red"))
|
||||
0))
|
||||
|
||||
; was effective on color
|
||||
; FIXME returns ((0 0 0)) which is not "red"
|
||||
(assert `(equal? (car (gimp-palette-entry-get-color "testPaletteNew" 0))
|
||||
(assert `(equal? (car (gimp-palette-entry-get-color ,testNewPalette 0))
|
||||
(list 0 0 0)))
|
||||
|
||||
; was effective on name
|
||||
(assert `(equal? (car (gimp-palette-entry-get-name "testPaletteNew" 0))
|
||||
(assert `(equal? (car (gimp-palette-entry-get-name ,testNewPalette 0))
|
||||
"fooEntryName"))
|
||||
|
||||
|
||||
|
||||
; delete entry
|
||||
; delete colormap entry
|
||||
|
||||
; succeeds
|
||||
; FIXME: the name seems backward, could be entry-delete
|
||||
(assert `(gimp-palette-delete-entry "testPaletteNew" 0))
|
||||
(assert `(gimp-palette-delete-entry ,testNewPalette 0))
|
||||
; effective, color count is back to 0
|
||||
(assert '(= (car (gimp-palette-get-color-count "testPaletteNew"))
|
||||
(assert `(= (car (gimp-palette-get-color-count ,testNewPalette))
|
||||
0))
|
||||
|
||||
|
||||
; adding color "entry" to new palette which is full
|
||||
; adding color "entry" to system palette
|
||||
; TODO
|
||||
|
||||
|
||||
; TODO locked palette? See issue about locking palette?
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
; delete palette
|
||||
|
||||
; can delete a new palette
|
||||
(assert `(gimp-resource-delete ,testNewPalette))
|
||||
|
||||
; delete was effective
|
||||
; ID is now invalid
|
||||
(assert `(= (car(gimp-resource-id-is-palette ,testNewPalette))
|
||||
0))
|
||||
|
||||
; delete was effective
|
||||
; not findable by name anymore
|
||||
; If the name DOES exist (because not started fresh) yields "substring out of bounds"
|
||||
(assert-error `(gimp-palette-get-by-name "testNewPalette")
|
||||
"Procedure execution of gimp-palette-get-by-name failed on invalid input arguments: Palette 'testNewPalette' not found")
|
||||
|
||||
|
||||
|
||||
|
||||
; see context.scm
|
||||
|
||||
; same as context-set-palette ?
|
||||
;gimp-palettes-set-palette deprecated
|
||||
|
||||
|
||||
|
||||
; test deprecated methods
|
||||
|
||||
; These should give warnings in Gimp Error Console.
|
||||
; Now they are methods on Context, not Palette.
|
||||
|
||||
(gimp-palettes-set-palette testBearsPalette)
|
||||
|
||||
(gimp-palette-swap-colors)
|
||||
(gimp-palette-set-foreground "pink")
|
||||
(gimp-palette-set-background "purple")
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,8 @@
|
|||
; test operations on resource pool
|
||||
|
||||
; TODO
|
||||
|
||||
; gimp-resource-rename
|
||||
; gimp-resource-duplicate
|
||||
; gimp-resource-delete
|
||||
; gimp-resource-rename
|
||||
|
|
@ -1,43 +1,12 @@
|
|||
; Test methods of Resource class
|
||||
|
||||
; Testing may depend on fresh install.
|
||||
; Depends on the default context.
|
||||
; This is currently empty of tests
|
||||
|
||||
; !!! 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
|
||||
; See brush.scm, palette.scm etc. for test of subclasses of Resource
|
||||
|
||||
; a brush from context is a string
|
||||
(assert '(string=?
|
||||
(car (gimp-context-get-brush))
|
||||
"2. Hardness 050"))
|
||||
; See resource-ops.scm for tests of:
|
||||
;gimp-resource-delete -duplicate -rename
|
||||
|
||||
; 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
|
||||
; See context/context-resource.scm
|
||||
; for tests of generic methods
|
||||
; e.g. gimp-resource-get-name -id-is-valid -is-editable
|
||||
Loading…
Reference in New Issue