- # This file is a Tcl script to test out procedures to write postscript
- # for canvases to files and channels. It exercises the procedure
- # TkCanvPostscriptCmd in generic/tkCanvPs.c
- #
- # Copyright (c) 1995 Sun Microsystems, Inc.
- # Copyright (c) 1998-1999 by Scriptics Corporation.
- # All rights reserved.
- #
- # RCS: @(#) $Id: canvPs.test,v 1.5.2.2 2006/03/14 04:59:44 dgp Exp $
- package require tcltest 2.1
- namespace import -force tcltest::configure
- namespace import -force tcltest::testsDirectory
- configure -testdir [file join [pwd] [file dirname [info script]]]
- configure -loadfile [file join [testsDirectory] constraints.tcl]
- tcltest::loadTestedCommands
- namespace import -force tcltest::makeFile
- namespace import -force tcltest::removeFile
- canvas .c -width 400 -height 300 -bd 2 -relief sunken
- .c create rectangle 20 20 80 80 -fill red
- pack .c
- update
- test canvPs-1.1 {test writing to a file} {unixOrPc} {
- removeFile foo.ps
- .c postscript -file foo.ps
- file exists foo.ps
- } 1
- test canvPs-1.2 {test writing to a file, idempotency} {unixOrPc} {
- removeFile foo.ps
- removeFile bar.ps
- .c postscript -file foo.ps
- .c postscript -file bar.ps
- set status ok
- if {[file size bar.ps] != [file size foo.ps]} {
- set status broken
- }
- set status
- } ok
- test canvPs-2.1 {test writing to a channel} {unixOrPc} {
- removeFile foo.ps
- set chan [open foo.ps w]
- fconfigure $chan -translation lf
- .c postscript -channel $chan
- close $chan
- file exists foo.ps
- } 1
- test canvPs-2.2 {test writing to channel, idempotency} {unixOrPc} {
- removeFile foo.ps
- removeFile bar.ps
- set c1 [open foo.ps w]
- set c2 [open bar.ps w]
- fconfigure $c1 -translation lf
- fconfigure $c2 -translation lf
- .c postscript -channel $c1
- .c postscript -channel $c2
- close $c1
- close $c2
- set status ok
- if {[file size bar.ps] != [file size foo.ps]} {
- set status broken
- }
- set status
- } ok
- test canvPs-2.3 {test writing to channel and file, same output} {unixOnly} {
- removeFile foo.ps
- removeFile bar.ps
- set c1 [open foo.ps w]
- fconfigure $c1 -translation lf
- .c postscript -channel $c1
- close $c1
- .c postscript -file bar.ps
- set status ok
- if {[file size foo.ps] != [file size bar.ps]} {
- set status broken
- }
- set status
- } ok
- test canvPs-2.4 {test writing to channel and file, same output} {pcOnly} {
- removeFile foo.ps
- removeFile bar.ps
- set c1 [open foo.ps w]
- fconfigure $c1 -translation crlf
- .c postscript -channel $c1
- close $c1
- .c postscript -file bar.ps
- set status ok
- if {[file size foo.ps] != [file size bar.ps]} {
- set status broken
- }
- set status
- } ok
- test canvPs-3.1 {test ps generation with an embedded window} {notAqua} {
- removeFile bar.ps
- destroy .c
- pack [canvas .c -width 200 -height 200 -background white]
- .c create rect 20 20 150 150 -tags rect0 -dash . -width 2
- .c create arc 0 50 200 200 -tags arc0
- -dash {4 4} -stipple question -outline red -fill green
- image create photo logo
- -file [file join $tk_library images pwrdLogo150.gif]
- .c create image 200 50 -image logo -anchor nw
- entry .c.e -background pink -foreground blue -width 14
- .c.e insert 0 "we gonna be postscripted"
- .c create window 50 180 -anchor nw -window .c.e
- update
- .c postscript -file bar.ps
- file exists bar.ps
- } 1
- test canvPs-3.2 {test ps generation with an embedded window not mapped} {} {
- removeFile bar.ps
- destroy .c
- pack [canvas .c -width 200 -height 200 -background white]
- entry .c.e -background pink -foreground blue -width 14
- .c.e insert 0 "we gonna be postscripted"
- .c create window 50 180 -anchor nw -window .c.e
- .c postscript -file bar.ps
- file exists bar.ps
- } 1
- test canvPs-4.1 {test ps generation with single-point uncolored poly, bug 734498} {} {
- destroy .c
- pack [canvas .c]
- .c create poly 10 20 10 20
- catch {.c postscript}
- } 0
- # cleanup
- removeFile foo.ps
- removeFile bar.ps
- deleteWindows
- ::tcltest::cleanupTests
- return