Tk Source Code

#ifdef _WIN32
#include "tkWinInt.h"
#endif

#if defined(MAC_OSX_TK)
#include "tkMacOSXInt.h"
#include "tkScrollbar.h"
#define LOG_DISPLAY TkTestLogDisplay()
#else
#define LOG_DISPLAY 1
#endif

#ifdef __UNIX__
#include "tkUnixInt.h"
#endif

/*

{
    TImageInstance *instPtr = (TImageInstance *) clientData;
    char buffer[200 + TCL_INTEGER_SPACE * 6];
    
    /*
     * The purpose of the test image type is to track the calls to an image
     * display proc and record the parameters passed in each call.  On macOS



     * a display proc must be run inside of the drawRect method of an NSView
     * in order for the graphics operations to have any effect.  To deal with
     * this, whenever a display proc is called outside of any drawRect method
     * it schedules a redraw of the NSView by calling [view setNeedsDisplay:YES].
     * This will trigger a later call to the view's drawRect method which will
     * run the display proc a second time.
     *
     * This complicates testing, since it can result in more calls to the display
     * proc than are expected by the test.  It can also result in an inconsistent
     * number of calls unless the test waits until the call to drawRect actually
     * occurs before validating its results.
     *
     * In an attempt to work around this, this display proc only logs those
     * calls which occur within a drawRect method.  This means that tests must
     * be written so as to ensure that the drawRect method is run before
     * results are validated.  In practice it usually suffices to run update
     * idletasks (to run the display proc the first time) followed by update
     * (to run the display proc in drawRect).
     *
     * This also has the consequence that the image changed command will log
     * different results on Aqua than on other systems, because when the image


     * is redisplayed in the drawRect method the entire image will be drawn,
     * not just the changed portion.  Tests must account for this.
     */

    if (LOG_DISPLAY) {
	sprintf(buffer, "%s display %d %d %d %d",
		instPtr->masterPtr->imageName, imageX, imageY, width, height);

	Tcl_SetVar2(instPtr->masterPtr->interp, instPtr->masterPtr->varName,
		    NULL, buffer, TCL_GLOBAL_ONLY|TCL_APPEND_VALUE|TCL_LIST_ELEMENT);
    }
    if (width > (instPtr->masterPtr->width - imageX)) {
	width = instPtr->masterPtr->width - imageX;
    }
    if (height > (instPtr->masterPtr->height - imageY)) {
	height = instPtr->masterPtr->height - imageY;
    }

MODULE_SCOPE void TkpClipDrawableToRect(Display *display, Drawable d, int x,
	int y, int width, int height);
MODULE_SCOPE void TkpRetainRegion(TkRegion r);
MODULE_SCOPE void TkpReleaseRegion(TkRegion r);
MODULE_SCOPE void TkpShiftButton(NSButton *button, NSPoint delta);
MODULE_SCOPE Bool TkpAppIsDrawing(void);
MODULE_SCOPE void TkpDisplayWindow(Tk_Window tkwin);
MODULE_SCOPE Bool TkTestLogDisplay(void);
MODULE_SCOPE Bool TkMacOSXInDarkMode(Tk_Window tkwin);

/*
 * Include the stubbed internal platform-specific API.
 */

#include "tkIntPlatDecls.h"

    return TCL_OK;
}
#endif

/*
 *----------------------------------------------------------------------
 *
 * TkTestLogDisplay --
 *
 *      The test image display procedure calls this to determine whether it
 *      should write a log message recording that it has being run.  On OSX
 *      10.14 and later, only calls to the display procedure which occur inside
 *      of the drawRect method should be logged, since those are the only ones
 *      which actually draw anything.  On earlier systems the opposite is true.
 *      The calls from within the drawRect method are redundant, since the
 *      first time the display procedure is run it will do the drawing and that
 *      first call will usually not occur inside of drawRect.
 *

 * Results:
 *      On OSX 10.14 and later, returns true if and only if called from
 *      within [NSView drawRect].  On earlier systems returns false if
 *      and only if called from with [NSView drawRect].
 *
 * Side effects:
 *	None
 *
 *----------------------------------------------------------------------
 */
MODULE_SCOPE Bool
TkTestLogDisplay(void) {
    if ([NSApp macMinorVersion] >= 14) {
	return [NSApp isDrawing];
    } else {
	return ![NSApp isDrawing];
    }
}


/*
 * Local Variables:
 * mode: objc
 * c-basic-offset: 4

    .c itemconfigure i1 -image {}
    update
    list $x [.c bbox i1]
} -cleanup {
	.c delete all
	image delete foo
} -result {{{foo free}} {}}
test canvImg-4.2 {ConfigureImage procedure} -constraints testImageType -setup {
    .c delete all
} -body {
    image create test foo -variable x
    image create test foo2 -variable y
    foo2 changed 0 0 0 0 80 60
    .c create image 50 100 -image foo -tags i1 -anchor nw
    update
    set x {}
    set y {}
    set timer [after 300 {lappend y "timeout"}]
    .c itemconfigure i1 -image foo2
    update idletasks
    update
    # On MacOS we need to wait for the test image display procedure to run.
    while {"timeout" ni $y && [lindex $y end 1] ne "display"} {
        vwait y
    }
    after cancel timer
    list $x $y [.c bbox i1]
} -cleanup {
	.c delete all
	image delete foo
	image delete foo2
} -result {{{foo free}} {{foo2 get} {foo2 display 0 0 80 60}} {50 100 130 160}}
test canvImg-4.3 {ConfiugreImage procedure} -constraints testImageType -setup {

    .c scale image 25 0 2.0 1.5
    .c bbox image
} -cleanup {
	.c delete all
	image delete foo
} -result {75 150 105 165}

if {[tk windowingsystem] == "aqua" && $tcl_platform(osVersion) > 18} {
    # Aqua >= 10.14 will redraw the entire image.
    set result_10_1 {{foo display 0 0 30 15}}
} else {
    set result_10_1 {{foo display 2 4 6 8}} 
}
test canvImg-10.1 {TranslateImage procedure} -constraints testImageType -setup {
    .c delete all
    update
} -body {
	image create test foo -variable x
    .c create image 50 100 -image foo -tags image -anchor nw
    update
    set x {}
    foo changed 2 4 6 8 30 15
    update
    return $x
} -cleanup {
	.c delete all
	image delete foo
} -result $result_10_1

test canvImg-11.1 {TranslateImage procedure} -constraints testImageType -setup {
    .c delete all
    update
} -body {
	image create test foo -variable x
    .c create image 50 100 -image foo -tags image -anchor nw

    set x {}
    foo changed 0 0 0 0 40 50
    .c bbox image
} -cleanup {
	.c delete all
	image delete foo
} -result {30 75 70 125}
if {[tk windowingsystem] == "aqua" && $tcl_platform(osVersion) > 18} {
    # Aqua >= 10.14 will redraw the entire image.
    set result_11_3 {{foo2 display 0 0 80 60}}
} else {
    set result_11_3 {{foo2 display 0 0 20 40}} 
}
test canvImg-11.3 {ImageChangedProc procedure} -constraints {
	testImageType 
} -setup {
    .c delete all
    update
} -body {
    image create test foo -variable x
    image create test foo2 -variable y
    foo changed 0 0 0 0 40 50
    foo2 changed 0 0 0 0 80 60

    .c create image 50 100 -image foo -tags image -anchor nw
    .c create image 70 110 -image foo2 -anchor nw
    update
    set y {}
    image create test foo -variable x
    update
    return $y
} -cleanup {
	.c delete all
	image delete foo foo2
} -result $result_11_3

# cleanup
imageFinish
cleanupTests
return

# Local variables:
# mode: tcl
# End:

test image-1.3 {Tk_ImageCmd procedure, "create" option} -body {
    image create
} -returnCodes error -result {wrong # args: should be "image create type ?name? ?-option value ...?"}
test image-1.4 {Tk_ImageCmd procedure, "create" option} -body {
    image c bad_type
} -returnCodes error -result {image type "bad_type" doesn't exist}
test image-1.5 {Tk_ImageCmd procedure, "create" option} -constraints {
    testImageType
} -body {
    list [image create test myimage] [imageNames]
} -cleanup {
    imageCleanup
} -result {myimage myimage}
test image-1.6 {Tk_ImageCmd procedure, "create" option} -constraints {
    testImageType
} -setup {
    imageCleanup
} -body {
    scan [image create test] image%d first
    image create test myimage
    scan [image create test -variable x] image%d second
    expr $second-$first
} -cleanup {
    imageCleanup
} -result {1}

test image-1.7 {Tk_ImageCmd procedure, "create" option} -constraints {
    testImageType
} -setup {
    imageCleanup
} -body {
    image create test myimage -variable x
    .c create image 100 50 -image myimage
    .c create image 100 150 -image myimage
    update
    set x {}
    set timer [after 500 {lappend x "timeout"}]
    image create test myimage -variable x
    update idletasks
    update
    # On MacOS we need to wait for the test image display procedure to run.
    while {"timeout" ni $x && [lindex $x end 1] ne "display"} {
        vwait x
    }
    after cancel timer
    return $x
} -cleanup {
    imageCleanup
} -result {{myimage free} {myimage free} {myimage delete} {myimage get} {myimage get} {myimage display 0 0 30 15} {myimage display 0 0 30 15}}
test image-1.8 {Tk_ImageCmd procedure, "create" option} -constraints {
	testImageType
} -setup {
    .c delete all
    imageCleanup
} -body {
    image create test myimage -variable x
    .c create image 100 50 -image myimage
    .c create image 100 150 -image myimage
    image delete myimage
    update
    set x {}
    image create test myimage -variable x
    update
    return $x
} -cleanup {
    .c delete all
    imageCleanup
} -result {{myimage get} {myimage get} {myimage display 0 0 30 15} {myimage display 0 0 30 15}}
test image-1.9 {Tk_ImageCmd procedure, "create" option} -constraints {
	testImageType
} -body {
    image create test -badName foo
} -returnCodes error -result {bad option name "-badName"}
test image-1.10 {Tk_ImageCmd procedure, "create" option} -constraints {
    testImageType
} -body {
    catch {image create test -badName foo}
    imageNames
} -result {}
test image-1.11 {Tk_ImageCmd procedure, "create" option with same name as main window} -body {
    set code [loadTkCommand]
    append code {

    image delete $i $j
} -result works

test image-2.1 {Tk_ImageCmd procedure, "delete" option} -body {
    image delete
} -result {}
test image-2.2 {Tk_ImageCmd procedure, "delete" option} -constraints {
    testImageType
} -setup {
    imageCleanup
    set result {}
} -body {
    image create test myimage
    image create test img2
    lappend result [lsort [imageNames]]
    image d myimage img2
    lappend result [imageNames]
} -cleanup {
    imageCleanup
} -result {{img2 myimage} {}}
test image-2.3 {Tk_ImageCmd procedure, "delete" option} -constraints {
    testImageType
} -setup {
    imageCleanup
} -body {
    image create test myimage
    image create test img2
    image delete myimage gorp img2
} -cleanup {
    imageCleanup
} -returnCodes error -result {image "gorp" doesn't exist}
test image-2.4 {Tk_ImageCmd procedure, "delete" option} -constraints {
    testImageType
} -setup {
    imageCleanup
} -body {
    image create test myimage
    image create test img2
    catch {image delete myimage gorp img2}
    imageNames

test image-3.2 {Tk_ImageCmd procedure, "height" option} -body {
    image height a b
} -returnCodes error -result {wrong # args: should be "image height name"}
test image-3.3 {Tk_ImageCmd procedure, "height" option} -body {
    image height foo
} -returnCodes error -result {image "foo" doesn't exist}
test image-3.4 {Tk_ImageCmd procedure, "height" option} -constraints {
    testImageType
} -setup {
    imageCleanup
} -body {
    image create test myimage
    set x [image h myimage]
    myimage changed 0 0 0 0 60 50
    list $x [image height myimage]
} -cleanup {
    imageCleanup
} -result {15 50}


test image-4.1 {Tk_ImageCmd procedure, "names" option} -body {
    image names x
} -returnCodes error -result {wrong # args: should be "image names"}
test image-4.2 {Tk_ImageCmd procedure, "names" option} -constraints {
    testImageType
} -setup {
    catch {interp delete testinterp}
} -body {
    interp create testinterp
    load {} Tk testinterp
    interp eval testinterp {
        image delete {*}[image names]

    image type a b
} -returnCodes error -result {wrong # args: should be "image type name"}
test image-5.3 {Tk_ImageCmd procedure, "type" option} -body {
    image type foo
} -returnCodes error -result {image "foo" doesn't exist}

test image-5.4 {Tk_ImageCmd procedure, "type" option} -constraints {
    testImageType
} -setup {
    imageCleanup
} -body {
    image create test myimage
    image type myimage
} -cleanup {
    imageCleanup
} -result {test}
test image-5.5 {Tk_ImageCmd procedure, "type" option} -constraints {
    testImageType
} -setup {
    imageCleanup
} -body {
    image create test myimage
    .c create image 50 50 -image myimage
    image delete myimage
    image type myimage
} -cleanup {
    imageCleanup
} -returnCodes error -result {image "myimage" doesn't exist}
test image-5.6 {Tk_ImageCmd procedure, "type" option} -constraints {
    testOldImageType
} -setup {
    imageCleanup
} -body {
    image create oldtest myimage
    image type myimage
} -cleanup {
    imageCleanup
} -result {oldtest}
test image-5.7 {Tk_ImageCmd procedure, "type" option} -constraints {
    testOldImageType
} -setup {
    .c delete all
    imageCleanup
} -body {
    image create oldtest myimage
    .c create image 50 50 -image myimage
    image delete myimage
    image type myimage
} -cleanup {
    .c delete all
    imageCleanup
} -returnCodes error -result {image "myimage" doesn't exist}


test image-6.1 {Tk_ImageCmd procedure, "types" option} -body {
    image types x
} -returnCodes error -result {wrong # args: should be "image types"}
test image-6.2 {Tk_ImageCmd procedure, "types" option} -constraints {
    testImageType
} -body {
    lsort [image types]
} -result {bitmap oldtest photo test}


test image-7.1 {Tk_ImageCmd procedure, "width" option} -body {
    image width
} -returnCodes error -result {wrong # args: should be "image width name"}
test image-7.2 {Tk_ImageCmd procedure, "width" option} -body {
    image width a b
} -returnCodes error -result {wrong # args: should be "image width name"}
test image-7.3 {Tk_ImageCmd procedure, "width" option} -body {
    image width foo
} -returnCodes error -result {image "foo" doesn't exist}
test image-7.4 {Tk_ImageCmd procedure, "width" option} -constraints {
    testImageType
} -setup {
    imageCleanup
} -body {
    image create test myimage
    set x [image w myimage]
    myimage changed 0 0 0 0 60 50
    list $x [image width myimage]
} -cleanup {
    imageCleanup
} -result {30 60}


test image-8.1 {Tk_ImageCmd procedure, "inuse" option} -constraints {
    testImageType
} -setup {
    imageCleanup
    set res {}
    destroy .b
} -body {
    image create test myimage2
    lappend res [image inuse myimage2]
    button .b -image myimage2
    lappend res [image inuse myimage2]
} -cleanup {
    imageCleanup
    catch {destroy .b}
} -result [list 0 1]

if {[tk windowingsystem] == "aqua" && $tcl_platform(osVersion) > 18} {
    # Aqua >= 10.14 will redraw the entire image in drawRect.
    set result_9_1 {{foo display 0 0 30 15}}
} else {
    set result_9_1 {{foo display 5 6 7 8}}
}
test image-9.1 {Tk_ImageChanged procedure} -constraints testImageType -setup {
    .c delete all
    imageCleanup
    update
} -body {
    image create test foo -variable x
    .c create image 50 50 -image foo
    update
    set x {}
    set timer [after 500 {lappend x "timeout"}]
    foo changed 5 6 7 8 30 15
    update idletasks
    update
    # On MacOS we need to wait for the test image display procedure to run.
    while {"timeout" ni $x && [lindex $x end 1] ne "display"} {
        vwait x
    }
    after cancel timer
    return $x
} -cleanup {
    .c delete all
    imageCleanup
} -result $result_9_1
if {[tk windowingsystem] == "aqua" && $tcl_platform(osVersion) > 18} {
    # Aqua >= 10.14 will redraw the entire image.
    set result_9_2 {{foo display 0 0 30 15} {foo display 0 0 30 15}}
} else {
    set result_9_2 {{foo display 5 6 25 9} {foo display 0 0 12 14}}
}
test image-9.2 {Tk_ImageChanged procedure} -constraints testImageType -setup {
    .c delete all
    imageCleanup
    update
} -body {
    image create test foo -variable x
    .c create image 50 50 -image foo
    .c create image 90 100 -image foo
    update
    set x {}
    foo changed 5 6 7 8 30 15
    update
    return $x
} -cleanup {
    .c delete all
    imageCleanup

} -result $result_9_2

test image-10.1 {Tk_GetImage procedure} -setup {
    imageCleanup
} -body {
    .c create image 100 10 -image bad_name
} -cleanup {
    imageCleanup

    lappend x [imageNames]
    image create photo foo -width 20 -height 20
    lappend x [.c bbox i1] [imageNames]
} -cleanup {
    .c delete all
    imageCleanup
} -result {10 10 20 20 foo {} {10 10 30 30} foo}

destroy .c
imageFinish

# cleanup
cleanupTests
return

# Local variables:
# mode: tcl
# End: