1# This file is a Tcl script to test out Tk's "font" command 2# plus the procedures in tkFont.c. It is organized in the 3# standard white-box fashion for Tcl tests. 4# 5# Copyright (c) 1996-1998 Sun Microsystems, Inc. 6# Copyright (c) 1998-1999 by Scriptics Corporation. 7# All rights reserved. 8# 9# RCS: @(#) $Id: font.test,v 1.8 2002/07/14 05:48:46 dgp Exp $ 10 11package require tcltest 2.1 12namespace import -force tcltest::configure 13namespace import -force tcltest::testsDirectory 14configure -testdir [file join [pwd] [file dirname [info script]]] 15configure -loadfile [file join [testsDirectory] constraints.tcl] 16tcltest::loadTestedCommands 17 18catch {destroy .b} 19toplevel .b 20wm geom .b +0+0 21update idletasks 22 23proc setup {} { 24 catch {destroy .b.f} 25 catch {eval font delete [font names]} 26 label .b.f 27 pack .b.f 28 update 29} 30 31label .b.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left -text "0" -font "Courier -12" 32pack .b.l 33canvas .b.c -closeenough 0 34.b.c create text 0 0 -tags text -anchor nw -just left -font "Courier -12" 35pack .b.c 36update 37 38set ax [winfo reqwidth .b.l] 39set ay [winfo reqheight .b.l] 40proc getsize {} { 41 update 42 return "[winfo reqwidth .b.l] [winfo reqheight .b.l]" 43} 44 45proc csetup {{str ""}} { 46 focus -force .b.c 47 .b.c dchars text 0 end 48 .b.c insert text 0 $str 49 .b.c focus text 50} 51 52setup 53 54case $tcl_platform(platform) { 55 unix {set fixed "fixed"} 56 windows {set fixed "courier 12"} 57 macintosh {set fixed "monaco 9"} 58} 59set times [font actual {times 0} -family] 60 61test font-1.1 {TkFontPkgInit} { 62 catch {interp delete foo} 63 interp create foo 64 foo eval { 65 load {} Tk 66 wm geometry . +0+0 67 update 68 } 69 interp delete foo 70} {} 71 72test font-2.1 {TkFontPkgFree} { 73 catch {interp delete foo} 74 interp create foo 75 set x {} 76 77 # Makes sure that named font was visible only to child interp. 78 79 foo eval { 80 load {} Tk 81 wm geometry . +0+0 82 button .b -font {times 16} -text "hi" 83 pack .b 84 font create wiggles -family courier -underline 1 85 update 86 } 87 lappend x [catch {font configure wiggles} msg; set msg] 88 89 # Tests cancelling the idle handler for TheWorldHasChanged, 90 # because app goes away before idle serviced. 91 92 foo eval { 93 .b config -font wiggles 94 font config wiggles -size 24 95 destroy . 96 } 97 lappend x [foo eval {catch {font families} msg; set msg}] 98 99 interp delete foo 100 set x 101} {{named font "wiggles" doesn't exist} {can't invoke "font" command: application has been destroyed}} 102 103 104test font-3.1 {font command: general} { 105 list [catch {font} msg] $msg 106} {1 {wrong # args: should be "font option ?arg?"}} 107test font-3.2 {font command: general} { 108 list [catch {font xyz} msg] $msg 109} {1 {bad option "xyz": must be actual, configure, create, delete, families, measure, metrics, or names}} 110 111test font-4.1 {font command: actual: arguments} { 112 # (skip < 0) 113 list [catch {font actual xyz -displayof} msg] $msg 114} {1 {value for "-displayof" missing}} 115test font-4.2 {font command: actual: arguments} { 116 # (objc < 3) 117 list [catch {font actual} msg] $msg 118} {1 {wrong # args: should be "font actual font ?-displayof window? ?option?"}} 119test font-4.3 {font command: actual: arguments} { 120 # (objc - skip > 4) when skip == 0 121 list [catch {font actual xyz abc def} msg] $msg 122} {1 {wrong # args: should be "font actual font ?-displayof window? ?option?"}} 123test font-4.4 {font command: actual: displayof specified, so skip to next} { 124 catch {font actual xyz -displayof . -size} 125} {0} 126test font-4.5 {font command: actual: displayof specified, so skip to next} { 127 lindex [font actual xyz -displayof .] 0 128} {-family} 129test font-4.6 {font command: actual: arguments} { 130 # (objc - skip > 4) when skip == 2 131 list [catch {font actual xyz -displayof . abc def} msg] $msg 132} {1 {wrong # args: should be "font actual font ?-displayof window? ?option?"}} 133test font-4.7 {font command: actual: arguments} {noExceed} { 134 # (tkfont == NULL) 135 list [catch {font actual "\{xyz"} msg] $msg 136} [list 1 "font \"{xyz\" doesn't exist"] 137test font-4.8 {font command: actual: all attributes} { 138 # not (objc > 3) so objPtr = NULL 139 lindex [font actual {-family times}] 0 140} {-family} 141test font-4.9 {font command: actual} {macOrUnix noExceed} { 142 # (objc > 3) so objPtr = objv[3 + skip] 143 string tolower [font actual {-family times} -family] 144} {times} 145test font-4.10 {font command: actual} {pcOnly} { 146 # (objc > 3) so objPtr = objv[3 + skip] 147 font actual {-family times} -family 148} {Times New Roman} 149test font-4.11 {font command: bad option} { 150 list [catch {font actual xyz -style} msg] $msg 151} {1 {bad option "-style": must be -family, -size, -weight, -slant, -underline, or -overstrike}} 152 153test font-5.1 {font command: configure} { 154 # (objc < 3) 155 list [catch {font configure} msg] $msg 156} {1 {wrong # args: should be "font configure fontname ?options?"}} 157test font-5.2 {font command: configure: non-existent font} { 158 # (namedHashPtr == NULL) 159 list [catch {font configure xyz} msg] $msg 160} {1 {named font "xyz" doesn't exist}} 161test font-5.3 {font command: configure: "deleted" font} { 162 # (nfPtr->deletePending != 0) 163 setup 164 font create xyz 165 .b.f configure -font xyz 166 font delete xyz 167 list [catch {font configure xyz} msg] $msg 168} {1 {named font "xyz" doesn't exist}} 169test font-5.4 {font command: configure: get all options} { 170 # (objc == 3) so objPtr = NULL 171 setup 172 font create xyz -family xyz 173 lindex [font configure xyz] 1 174} xyz 175test font-5.5 {font command: configure: get one option} { 176 # (objc == 4) so objPtr = objv[3] 177 setup 178 font create xyz -family xyz 179 font configure xyz -family 180} xyz 181test font-5.6 {font command: configure: update existing font} { 182 # else result = ConfigAttributesObj() 183 setup 184 font create xyz 185 font configure xyz -family xyz 186 update 187 font configure xyz -family 188} xyz 189test font-5.7 {font command: configure: bad option} { 190 setup 191 font create xyz 192 list [catch {font configure xyz -style} msg] $msg 193} {1 {bad option "-style": must be -family, -size, -weight, -slant, -underline, or -overstrike}} 194 195test font-6.1 {font command: create: make up name} { 196 # (objc < 3) so name = NULL 197 setup 198 font create 199 font names 200} {font1} 201test font-6.2 {font command: create: name specified} { 202 # not (objc < 3) 203 setup 204 font create xyz 205 font names 206} {xyz} 207test font-6.3 {font command: create: name not really specified} { 208 # (name[0] == '-') so name = NULL 209 setup 210 font create -family xyz 211 font names 212} {font1} 213test font-6.4 {font command: create: generate name} { 214 # (name == NULL) 215 setup 216 font create -family one 217 font create -family two 218 font create -family three 219 font delete font2 220 font create -family four 221 font configure font2 -family 222} {four} 223test font-6.5 {font command: create: bad option creating new font} { 224 # name was specified so skip = 3 225 setup 226 list [catch {font create xyz -xyz times} msg] $msg 227} {1 {bad option "-xyz": must be -family, -size, -weight, -slant, -underline, or -overstrike}} 228test font-6.6 {font command: create: bad option creating new font} { 229 # name was not specified so skip = 2 230 setup 231 list [catch {font create -xyz times} msg] $msg 232} {1 {bad option "-xyz": must be -family, -size, -weight, -slant, -underline, or -overstrike}} 233test font-6.7 {font command: create: already exists} { 234 # (CreateNamedFont() != TCL_OK) 235 setup 236 font create xyz 237 list [catch {font create xyz} msg] $msg 238} {1 {named font "xyz" already exists}} 239 240test font-7.1 {font command: delete: arguments} { 241 # (objc < 3) 242 list [catch {font delete} msg] $msg 243} {1 {wrong # args: should be "font delete fontname ?fontname ...?"}} 244test font-7.2 {font command: delete: loop test} { 245 # for (i = 2; i < objc; i++) 246 setup 247 set x {} 248 font create a -underline 1 249 font create b -underline 1 250 font create c -underline 1 251 font create d -underline 1 252 font create e -underline 1 253 lappend x [lsort [font names]] 254 font delete a e c b 255 lappend x [lsort [font names]] 256} {{a b c d e} d} 257test font-7.3 {font command: delete: loop test} { 258 # (namedHashPtr == NULL) in middle of loop 259 setup 260 set x {} 261 font create a -underline 1 262 font create b -underline 1 263 font create c -underline 1 264 font create d -underline 1 265 font create e -underline 1 266 lappend x [lsort [font names]] 267 catch {font delete a d q c e b} 268 lappend x [lsort [font names]] 269} {{a b c d e} {b c e}} 270test font-7.4 {font command: delete: non-existent} { 271 # (namedHashPtr == NULL) 272 setup 273 list [catch {font delete xyz} msg] $msg 274} {1 {named font "xyz" doesn't exist}} 275test font-7.5 {font command: delete: mark for later deletion} { 276 # (nfPtr->refCount != 0) 277 setup 278 font create xyz 279 .b.f configure -font xyz 280 font delete xyz 281 font actual xyz 282 list [catch {font configure xyz} msg] $msg [.b.f cget -font] 283} {1 {named font "xyz" doesn't exist} xyz} 284test font-7.6 {font command: delete: actually delete} { 285 # not (nfPtr->refCount != 0) 286 setup 287 font create xyz -underline 1 288 font delete xyz 289 catch {font config xyz} 290} {1} 291setup 292 293test font-8.1 {font command: families: arguments} { 294 # (skip < 0) 295 list [catch {font families -displayof} msg] $msg 296} {1 {value for "-displayof" missing}} 297test font-8.2 {font command: families: arguments} { 298 # (objc - skip != 2) when skip == 0 299 list [catch {font families xyz} msg] $msg 300} {1 {wrong # args: should be "font families ?-displayof window?"}} 301test font-8.3 {font command: families: arguments} { 302 # (objc - skip != 2) when skip == 2 303 list [catch {font families -displayof . xyz} msg] $msg 304} {1 {wrong # args: should be "font families ?-displayof window?"}} 305test font-8.4 {font command: families} { 306 # TkpGetFontFamilies() 307 regexp -nocase times [font families] 308} {1} 309 310test font-9.1 {font command: measure: arguments} { 311 # (skip < 0) 312 list [catch {font measure xyz -displayof} msg] $msg 313} {1 {value for "-displayof" missing}} 314test font-9.2 {font command: measure: arguments} { 315 # (objc - skip != 4) 316 list [catch {font measure} msg] $msg 317} {1 {wrong # args: should be "font measure font ?-displayof window? text"}} 318test font-9.3 {font command: measure: arguments} { 319 # (objc - skip != 4) 320 list [catch {font measure xyz abc def} msg] $msg 321} {1 {wrong # args: should be "font measure font ?-displayof window? text"}} 322test font-9.4 {font command: measure: arguments} {noExceed} { 323 # (tkfont == NULL) 324 list [catch {font measure "\{xyz" abc} msg] $msg 325} [list 1 "font \"{xyz\" doesn't exist"] 326test font-9.5 {font command: measure} { 327 # Tk_TextWidth() 328 expr [font measure $fixed "abcdefg"]==[font measure $fixed "a"]*7 329} {1} 330 331test font-10.1 {font command: metrics: arguments} { 332 list [catch {font metrics xyz -displayof} msg] $msg 333} {1 {value for "-displayof" missing}} 334test font-10.2 {font command: metrics: arguments} { 335 # (skip < 0) 336 list [catch {font metrics xyz -displayof} msg] $msg 337} {1 {value for "-displayof" missing}} 338test font-10.3 {font command: metrics: arguments} { 339 # (objc < 3) 340 list [catch {font metrics} msg] $msg 341} {1 {wrong # args: should be "font metrics font ?-displayof window? ?option?"}} 342test font-10.4 {font command: metrics: arguments} { 343 # (objc - skip) > 4) when skip == 0 344 list [catch {font metrics xyz abc def} msg] $msg 345} {1 {wrong # args: should be "font metrics font ?-displayof window? ?option?"}} 346test font-10.5 {font command: metrics: arguments} { 347 # (objc - skip) > 4) when skip == 2 348 list [catch {font metrics xyz -displayof . abc} msg] $msg 349} {1 {bad metric "abc": must be -ascent, -descent, -linespace, or -fixed}} 350test font-10.6 {font command: metrics: bad font} {noExceed} { 351 # (tkfont == NULL) 352 list [catch {font metrics "\{xyz"} msg] $msg 353} [list 1 "font \"{xyz\" doesn't exist"] 354test font-10.7 {font command: metrics: get all metrics} { 355 # (objc == 3) 356 catch {unset a} 357 array set a [font metrics {-family xyz}] 358 set x [lsort [array names a]] 359 unset a 360 set x 361} {-ascent -descent -fixed -linespace} 362test font-10.8 {font command: metrics: bad metric} { 363 # (Tcl_GetIndexFromObj() != TCL_OK) 364 list [catch {font metrics $fixed -xyz} msg] $msg 365} {1 {bad metric "-xyz": must be -ascent, -descent, -linespace, or -fixed}} 366test font-10.9 {font command: metrics: get individual metrics} { 367 font metrics $fixed -ascent 368 font metrics $fixed -descent 369 font metrics $fixed -linespace 370 font metrics $fixed -fixed 371} {1} 372 373test font-11.1 {font command: names: arguments} { 374 # (objc != 2) 375 list [catch {font names xyz} msg] $msg 376} {1 {wrong # args: should be "font names"}} 377test font-11.2 {font command: names: loop test: no passes} { 378 setup 379 font names 380} {} 381test font-11.3 {font command: names: loop test: one pass} { 382 setup 383 font create 384 font names 385} {font1} 386test font-11.4 {font command: names: loop test: multiple passes} { 387 setup 388 font create xyz 389 font create abc 390 font create def 391 lsort [font names] 392} {abc def xyz} 393test font-11.5 {font command: names: skip deletePending fonts} { 394 # (nfPtr->deletePending == 0) 395 setup 396 set x {} 397 font create xyz 398 font create abc 399 lappend x [lsort [font names]] 400 .b.f config -font xyz 401 font delete xyz 402 lappend x [font names] 403} {{abc xyz} abc} 404 405test font-12.1 {UpdateDependantFonts procedure: no users} { 406 # (nfPtr->refCount == 0) 407 setup 408 font create xyz 409 font configure xyz -family times 410} {} 411test font-12.2 {UpdateDependantFonts procedure: pings the widgets} { 412 setup 413 font create xyz -family times -size 20 414 .b.f config -font xyz -text "abcd" -padx 0 -bd 0 -highlightthickness 0 415 set a1 [font measure xyz "abcd"] 416 update 417 set b1 [winfo reqwidth .b.f] 418 font configure xyz -family helvetica -size 20 419 set a2 [font measure xyz "abcd"] 420 update 421 set b2 [winfo reqwidth .b.f] 422 expr {$a1==$b1 && $a2==$b2} 423} {1} 424 425test font-13.1 {CreateNamedFont: new named font} { 426 # not (new == 0) 427 setup 428 set x {} 429 lappend x [font names] 430 font create xyz 431 lappend x [font names] 432} {{} xyz} 433test font-13.2 {CreateNamedFont: named font already exists} { 434 # (new == 0) 435 setup 436 font create xyz 437 list [catch {font create xyz} msg] $msg 438} {1 {named font "xyz" already exists}} 439test font-13.3 {CreateNamedFont: named font already exists} { 440 # (nfPtr->deletePending == 0) 441 setup 442 font create xyz 443 list [catch {font create xyz} msg] $msg 444} {1 {named font "xyz" already exists}} 445test font-13.4 {CreateNamedFont: recreate "deleted" font} { 446 # not (nfPtr->deletePending == 0) 447 setup 448 font create xyz -family times 449 .b.f configure -font xyz 450 font delete xyz 451 font create xyz -family courier 452 font configure xyz -family 453} {courier} 454 455test font-14.1 {Tk_GetFont procedure} { 456} {} 457 458test font-15.1 {Tk_AllocFontFromObj - converting internal reps} testfont { 459 set x {Times 16} 460 lindex $x 0 461 destroy .b1 .b2 462 button .b1 -font $x 463 lindex $x 0 464 testfont counts {Times 16} 465} {{1 0}} 466test font-15.2 {Tk_AllocFontFromObj - discard stale font} testfont { 467 set x {Times 16} 468 destroy .b1 .b2 469 button .b1 -font $x 470 destroy .b1 471 set result {} 472 lappend result [testfont counts {Times 16}] 473 button .b2 -font $x 474 lappend result [testfont counts {Times 16}] 475} {{} {{1 1}}} 476test font-15.3 {Tk_AllocFontFromObj - reuse existing font} testfont { 477 set x {Times 16} 478 destroy .b1 .b2 479 button .b1 -font $x 480 set result {} 481 lappend result [testfont counts {Times 16}] 482 button .b2 -font $x 483 pack .b1 .b2 -side top 484 lappend result [testfont counts {Times 16}] 485} {{{1 1}} {{2 1}}} 486test font-15.4 {Tk_AllocFontFromObj procedure: bump ref count} { 487 # (new == 0) 488 setup 489 .b.f config -font {-family fixed} 490 lindex [font actual {-family fixed}] 0 491} {-family} 492test font-15.5 {Tk_AllocFontFromObj procedure: get named font} { 493 # (namedHashPtr != NULL) 494 setup 495 font create xyz 496 .b.f config -font xyz 497} {} 498test font-15.6 {Tk_AllocFontFromObj procedure: not a named font} { 499 # not (namedHashPtr != NULL) 500 setup 501 .b.f config -font {times 20} 502} {} 503test font-15.7 {Tk_AllocFontFromObj procedure: get native font} {unixOnly} { 504 # not (fontPtr == NULL) 505 setup 506 .b.f config -font fixed 507} {} 508test font-15.8 {Tk_AllocFontFromObj procedure: get native font} {pcOnly} { 509 # not (fontPtr == NULL) 510 setup 511 .b.f config -font oemfixed 512} {} 513test font-15.9 {Tk_AllocFontFromObj procedure: get native font} {macOnly} { 514 # not (fontPtr == NULL) 515 setup 516 .b.f config -font application 517} {} 518test font-15.10 {Tk_AllocFontFromObj procedure: get attribute font} { 519 # (fontPtr == NULL) 520 list [catch {.b.f config -font {xxx yyy zzz}} msg] $msg 521} {1 {expected integer but got "yyy"}} 522test font-15.11 {Tk_AllocFontFromObj procedure: no match} {noExceed} { 523 # (ParseFontNameObj() != TCL_OK) 524 list [catch {font actual "\{xyz"} msg] $msg 525} [list 1 "font \"{xyz\" doesn't exist"] 526test font-15.12 {Tk_AllocFontFromObj procedure: get attribute font} { 527 # not (ParseFontNameObj() != TCL_OK) 528 lindex [font actual {plan 9}] 0 529} {-family} 530test font-15.13 {Tk_AllocFontFromObj procedure: setup tab width} { 531 # Tk_MeasureChars(fontPtr, "0", ...) 532 label .l -bd 0 -padx 0 -highlightthickness 0 -font $fixed -text "a\tb" 533 update 534 set x [winfo reqwidth .l] 535 destroy .l 536 set x 537} [expr [font measure $fixed "0"]*9] 538test font-15.14 {Tk_AllocFontFromObj procedure: underline position} { 539 # (fontPtr->underlineHeight == 0) because size was < 10 540 setup 541 .b.f config -text "underline" -font "times -8 underline" 542 update 543} {} 544 545test font-16.1 {Tk_NameOfFont procedure} { 546 setup 547 .b.f config -font -family\ fixed 548 .b.f cget -font 549} {-family fixed} 550 551test font-17.1 {Tk_FreeFontFromObj - reference counts} testfont { 552 set x {Courier 12} 553 destroy .b1 .b2 .b3 554 button .b1 -font $x 555 button .b3 -font $x 556 button .b2 -font $x 557 set result {} 558 lappend result [testfont counts {Courier 12}] 559 destroy .b1 560 lappend result [testfont counts {Courier 12}] 561 destroy .b2 562 lappend result [testfont counts {Courier 12}] 563 destroy .b3 564 lappend result [testfont counts {Courier 12}] 565} {{{3 1}} {{2 1}} {{1 1}} {}} 566test font-17.2 {Tk_FreeFont procedure: one ref} { 567 # (fontPtr->refCount == 0) 568 setup 569 .b.f config -font {-family fixed} 570 destroy .b.f 571} {} 572test font-17.3 {Tk_FreeFont procedure: multiple ref} { 573 # not (fontPtr->refCount == 0) 574 setup 575 .b.f config -font {-family fixed} 576 button .b.b -font {-family fixed} 577 destroy .b.f 578 set x [.b.b cget -font] 579 destroy .b.b 580 set x 581} {-family fixed} 582test font-17.4 {Tk_FreeFont procedure: named font} { 583 # (fontPtr->namedHashPtr != NULL) 584 setup 585 font create xyz 586 .b.f config -font xyz 587 destroy .b.f 588 font names 589} {xyz} 590test font-17.5 {Tk_FreeFont procedure: named font} { 591 # not (fontPtr->refCount == 0) 592 setup 593 font create xyz -underline 1 594 .b.f config -font xyz 595 font delete xyz 596 set x [font actual xyz -underline] 597 destroy .b.f 598 list [font actual xyz -underline] $x 599} {0 1} 600test font-17.6 {Tk_FreeFont procedure: named font not deleted yet} { 601 setup 602 font create xyz 603 .b.f config -font xyz 604 button .b.b -font xyz 605 font delete xyz 606 set x [font actual xyz] 607 destroy .b.b 608 list [lindex [font actual xyz] 0] [lindex $x 0] 609} {-family -family} 610 611test font-18.1 {FreeFontObjProc} testfont { 612 destroy .b1 613 set x [format {Courier 12}] 614 button .b1 -font $x 615 set y [format {Courier 12}] 616 .b1 configure -font $y 617 set z [format {Courier 12}] 618 .b1 configure -font $z 619 set result {} 620 lappend result [testfont counts {Courier 12}] 621 set x red 622 lappend result [testfont counts {Courier 12}] 623 set z 32 624 lappend result [testfont counts {Courier 12}] 625 destroy .b1 626 lappend result [testfont counts {Courier 12}] 627 set y bogus 628 set result 629} {{{1 3}} {{1 2}} {{1 1}} {}} 630 631test font-19.1 {Tk_FontId} { 632 .b.f config -font "times 20" 633 update 634} {} 635 636test font-20.1 {Tk_GetFontMetrics procedure} { 637 button .b.w1 -text abc 638 entry .b.w2 -text abcd 639 update 640 destroy .b.w1 .b.w2 641} {} 642 643proc psfontname {name} { 644 set a [.b.c itemcget text -font] 645 .b.c itemconfig text -text "We need text" -font $name 646 set post [.b.c postscript] 647 .b.c itemconfig text -font $a 648 set end [string first "findfont" $post] 649 incr end -2 650 set post [string range $post [expr $end-70] $end] 651 set start [string first "gsave" $post] 652 return [string range $post [expr $start+7] end] 653} 654test font-21.1 {Tk_PostscriptFontName procedure: native} {unixOnly} { 655 set x [font actual {{itc avant garde} 10} -family] 656 if {[string match *avant*garde $x]} { 657 psfontname "{itc avant garde} 10" 658 } else { 659 set x {AvantGarde-Book} 660 } 661} {AvantGarde-Book} 662test font-21.2 {Tk_PostscriptFontName procedure: native} {pcOnly} { 663 psfontname "arial 10" 664} {Helvetica} 665test font-21.3 {Tk_PostscriptFontName procedure: native} {pcOnly} { 666 psfontname "{times new roman} 10" 667} {Times-Roman} 668test font-21.4 {Tk_PostscriptFontName procedure: native} {pcOnly} { 669 psfontname "{courier new} 10" 670} {Courier} 671test font-21.5 {Tk_PostscriptFontName procedure: native} {macOnly} { 672 psfontname "geneva 10" 673} {Helvetica} 674test font-21.6 {Tk_PostscriptFontName procedure: native} {macOnly} { 675 psfontname "{new york} 10" 676} {Times-Roman} 677test font-21.7 {Tk_PostscriptFontName procedure: native} {macOnly} { 678 psfontname "monaco 10" 679} {Courier} 680test font-21.8 {Tk_PostscriptFontName procedure: spaces} {unixOnly} { 681 set x [font actual {{lucida bright} 10} -family] 682 if {[string match lucida*bright $x]} { 683 psfontname "{lucida bright} 10" 684 } else { 685 set x {LucidaBright} 686 } 687} {LucidaBright} 688test font-21.9 {Tk_PostscriptFontName procedure: spaces} {unixOnly} { 689 psfontname "{new century schoolbook} 10" 690} {NewCenturySchlbk-Roman} 691set i 10 692foreach p { 693 {"avantgarde" AvantGarde-Book AvantGarde-Demi AvantGarde-BookOblique AvantGarde-DemiOblique} 694 {"bookman" Bookman-Light Bookman-Demi Bookman-LightItalic Bookman-DemiItalic} 695 {"courier" Courier Courier-Bold Courier-Oblique Courier-BoldOblique} 696 {"helvetica" Helvetica Helvetica-Bold Helvetica-Oblique Helvetica-BoldOblique} 697 {"new century schoolbook" NewCenturySchlbk-Roman NewCenturySchlbk-Bold NewCenturySchlbk-Italic NewCenturySchlbk-BoldItalic} 698 {"palatino" Palatino-Roman Palatino-Bold Palatino-Italic Palatino-BoldItalic} 699 {"symbol" Symbol Symbol Symbol Symbol} 700 {"times" Times-Roman Times-Bold Times-Italic Times-BoldItalic} 701 {"zapfchancery" ZapfChancery-MediumItalic ZapfChancery-MediumItalic ZapfChancery-MediumItalic ZapfChancery-MediumItalic} 702 {"zapfdingbats" ZapfDingbats ZapfDingbats ZapfDingbats ZapfDingbats} 703} { 704 test font-21.$i {Tk_PostscriptFontName procedure: exhaustive} {unixOnly} { 705 set family [lindex $p 0] 706 set x {} 707 set i 1 708 foreach slant {roman italic} { 709 foreach weight {normal bold} { 710 set name [list $family 12 $slant $weight] 711 if {[font actual $name -family] == $family} { 712 lappend x [psfontname $name] 713 } else { 714 lappend x [lindex $p $i] 715 } 716 incr i 717 } 718 } 719 incr i 720 set x 721 } [lrange $p 1 end] 722} 723foreach p { 724 {"arial" Helvetica Helvetica-Bold Helvetica-Oblique Helvetica-BoldOblique} 725 {"courier new" Courier Courier-Bold Courier-Oblique Courier-BoldOblique} 726 {"helvetica" Helvetica Helvetica-Bold Helvetica-Oblique Helvetica-BoldOblique} 727 {"symbol" Symbol Symbol-Bold Symbol-Italic Symbol-BoldItalic} 728 {"times new roman" Times-Roman Times-Bold Times-Italic Times-BoldItalic} 729} { 730 test font-21.$i {Tk_PostscriptFontName procedure: exhaustive} {pcOnly} { 731 set family [lindex $p 0] 732 set x {} 733 foreach slant {roman italic} { 734 foreach weight {normal bold} { 735 lappend x [psfontname [list $family 12 "$slant $weight"]] 736 } 737 } 738 incr i 739 set x 740 } [lrange $p 1 end] 741} 742foreach p { 743 {"courier" Courier Courier-Bold Courier-Oblique Courier-BoldOblique} 744 {"geneva" Helvetica Helvetica-Bold Helvetica-Oblique Helvetica-BoldOblique} 745 {"helvetica" Helvetica Helvetica-Bold Helvetica-Oblique Helvetica-BoldOblique} 746 {"monaco" Courier Courier-Bold Courier-Oblique Courier-BoldOblique} 747 {"new york" Times-Roman Times-Bold Times-Italic Times-BoldItalic} 748 {"symbol" Symbol Symbol-Bold Symbol-Italic Symbol-BoldItalic} 749 {"times" Times-Roman Times-Bold Times-Italic Times-BoldItalic} 750} { 751 test font-21.$i {Tk_PostscriptFontName procedure: exhaustive} {macOnly} { 752 set family [lindex $p 0] 753 set x {} 754 foreach slant {roman italic} { 755 foreach weight {normal bold} { 756 lappend x [psfontname [list $family 12 $slant $weight]] 757 } 758 } 759 incr i 760 set x 761 } [lrange $p 1 end] 762} 763 764test font-22.1 {Tk_TextWidth procedure} { 765 font measure [.b.l cget -font] "000" 766} [expr $ax*3] 767 768test font-23.1 {Tk_UnderlineChars procedure} { 769 text .b.t 770 .b.t insert 1.0 abc\tdefg 771 .b.t tag config sel -underline 1 772 .b.t tag add sel 1.0 end 773 update 774} {} 775 776setup 777test font-24.1 {Tk_ComputeTextLayout: empty string} { 778 .b.l config -text "" 779} {} 780test font-24.2 {Tk_ComputeTextLayout: simple string} { 781 .b.l config -text "000" 782 getsize 783} "[expr $ax*3] $ay" 784test font-24.3 {Tk_ComputeTextLayout: find special chars} { 785 .b.l config -text "000\n000" 786 getsize 787} "[expr $ax*3] [expr $ay*2]" 788test font-24.4 {Tk_ComputeTextLayout: calls Tk_MeasureChars} { 789 .b.l config -text "000\n000" 790 getsize 791} "[expr $ax*3] [expr $ay*2]" 792test font-24.5 {Tk_ComputeTextLayout: break line} { 793 .b.l config -text "000\t00000" -wrap [expr 9*$ax] 794 set x [getsize] 795 .b.l config -wrap 0 796 set x 797} "[expr 8*$ax] [expr 2*$ay]" 798test font-24.6 {Tk_ComputeTextLayout: normal ended on special char} { 799 .b.l config -text "000\n000" 800} {} 801test font-24.7 {Tk_ComputeTextLayout: special char was \n} { 802 .b.l config -text "000\n0000" 803 getsize 804} "[expr $ax*4] [expr $ay*2]" 805test font-24.8 {Tk_ComputeTextLayout: special char was \t} { 806 .b.l config -text "000\t00" 807 getsize 808} "[expr $ax*10] $ay" 809test font-24.9 {Tk_ComputeTextLayout: tab didn't cause break} { 810 set x {} 811 .b.l config -text "000\t000" 812 lappend x [getsize] 813 .b.l config -text "000\t000" -wrap [expr 100*$ax] 814 lappend x [getsize] 815 .b.l config -wrap 0 816 set x 817} "{[expr $ax*11] $ay} {[expr $ax*11] $ay}" 818test font-24.10 {Tk_ComputeTextLayout: tab caused break} { 819 set x {} 820 .b.l config -text "000\t" 821 lappend x [getsize] 822 .b.l config -text "000\t00" -wrap [expr $ax*6] 823 lappend x [getsize] 824 .b.l config -wrap 0 825 set x 826} "{[expr $ax*3] $ay} {[expr $ax*3] [expr $ay*2]}" 827test font-24.11 {Tk_ComputeTextLayout: absorb spaces at eol} { 828 set x {} 829 .b.l config -text "000 000" -wrap [expr $ax*5] 830 lappend x [getsize] 831 .b.l config -text "000 " 832 lappend x [getsize] 833 .b.l config -wrap 0 834 set x 835} "{[expr $ax*3] [expr $ay*2]} {[expr $ax*3] $ay}" 836test font-24.12 {Tk_ComputeTextLayout: append non-printing spaces to chunk} { 837 set x {} 838 .b.l config -text "000 0000" -wrap [expr $ax*5] 839 lappend x [getsize] 840 .b.l config -text "000\t00 0000" -wrap [expr $ax*12] 841 lappend x [getsize] 842 .b.l config -wrap 0 843 set x 844} "{[expr $ax*4] [expr $ay*2]} {[expr $ax*10] [expr $ay*2]}" 845test font-24.13 {Tk_ComputeTextLayout: many lines -> realloc line array} { 846 .b.l config -text "\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n" 847 getsize 848} "1 [expr $ay*129]" 849test font-24.14 {Tk_ComputeTextLayout: text ended with \n} { 850 list [.b.l config -text "0000"; getsize] [.b.l config -text "0000\n"; getsize] 851} "{[expr $ax*4] $ay} {[expr $ax*4] [expr $ay*2]}" 852test font-24.15 {Tk_ComputeTextLayout: justification} { 853 csetup "000\n00000" 854 set x {} 855 .b.c itemconfig text -just left 856 lappend x [.b.c index text @[expr $ax*2],0] 857 .b.c itemconfig text -just center 858 lappend x [.b.c index text @[expr $ax*2],0] 859 .b.c itemconfig text -just right 860 lappend x [.b.c index text @[expr $ax*2],0] 861 .b.c itemconfig text -just left 862 set x 863} {2 1 0} 864 865test font-25.1 {Tk_FreeTextLayout procedure} { 866 setup 867 .b.f config -text foo 868 .b.f config -text boo 869} {} 870 871test font-26.1 {Tk_DrawTextLayout procedure: auto-detect last char} { 872 .b.f config -text foo 873} {} 874test font-26.2 {Tk_DrawTextLayout procedure: multiple chunks} { 875 csetup "000\t00\n000" 876} {} 877test font-26.3 {Tk_DrawTextLayout: draw subset of chunk: numDisplay <= 0} { 878 csetup "000\t00" 879 .b.c select from text 3 880 .b.c select to text 5 881} {} 882test font-26.4 {Tk_DrawTextLayout: draw subset of chunk: firstChar <= 0} { 883 .b.c select from text 3 884 .b.c select to text 5 885} {} 886test font-26.5 {Tk_DrawTextLayout: draw subset of chunk: firstChar > 0} { 887 .b.c select from text 2 888 .b.c select to text 2 889} {} 890test font-26.6 {Tk_DrawTextLayout: draw subset of chunk: lastChar < numChars} { 891 .b.c select from text 4 892 .b.c select to text 4 893} {} 894 895test font-27.1 {Tk_UnderlineTextLayout procedure: no underline chosen} { 896 .b.f config -text "foo" -under -1 897} {} 898test font-27.2 {Tk_UnderlineTextLayout procedure: underline not visible} { 899 .b.f config -text "000 00000" -wrap [expr $ax*7] -under 10 900} {} 901test font-27.3 {Tk_UnderlineTextLayout procedure: underline is visible} { 902 .b.f config -text "000 00000" -wrap [expr $ax*7] -under 5 903 .b.f config -wrap -1 -under -1 904} {} 905 906test font-28.1 {Tk_PointToChar procedure: above all lines} { 907 csetup "000" 908 .b.c index text @-1,0 909} {0} 910test font-28.2 {Tk_PointToChar procedure: no chars} { 911 # After fixing the following bug: 912 # 913 # In canvas text item, it was impossible to click to position the 914 # insertion point just after the last character. 915 # 916 # introduced another bug that Tk_PointToChar() would return a character 917 # index of 1 if TextLayout contained 0 characters. 918 919 csetup "" 920 .b.c index text @100,100 921} {0} 922test font-28.3 {Tk_PointToChar procedure: loop test} { 923 csetup "000\n000\n000\n000" 924 .b.c index text @10000,0 925} {3} 926test font-28.4 {Tk_PointToChar procedure: intersect line} { 927 csetup "000\n000\n000" 928 .b.c index text @0,$ay 929} {4} 930test font-28.5 {Tk_PointToChar procedure: to the left of all chunks} { 931 .b.c index text @-100,$ay 932} {4} 933test font-28.6 {Tk_PointToChar procedure: past any possible chunk} { 934 .b.c index text @100000,$ay 935} {7} 936test font-28.7 {Tk_PointToChar procedure: which chunk on this line} { 937 csetup "000\n000\t000\t000\n000" 938 .b.c index text @[expr $ax*2],$ay 939} {6} 940test font-28.8 {Tk_PointToChar procedure: which chunk on this line} { 941 csetup "000\n000\t000\t000\n000" 942 .b.c index text @[expr $ax*10],$ay 943} {10} 944test font-28.9 {Tk_PointToChar procedure: in special chunk} { 945 csetup "000\n000\t000\t000\n000" 946 .b.c index text @[expr $ax*6],$ay 947} {7} 948test font-28.10 {Tk_PointToChar procedure: past all chars in chunk} { 949 csetup "000 0000000" 950 .b.c itemconfig text -width [expr $ax*5] 951 set x [.b.c index text @[expr $ax*5],0] 952 .b.c itemconfig text -width 0 953 set x 954} {3} 955test font-28.11 {Tk_PointToChar procedure: below all chunks} { 956 csetup "000 0000000" 957 .b.c index text @0,1000000 958} {11} 959 960test font-29.1 {Tk_CharBBox procedure: index < 0} { 961 .b.f config -text "000" -underline -1 962} {} 963test font-29.2 {Tk_CharBBox procedure: loop} { 964 .b.f config -text "000\t000\t000\t000" -underline 9 965} {} 966test font-29.3 {Tk_CharBBox procedure: special char} { 967 .b.f config -text "000\t000\t000" -underline 7 968} {} 969test font-29.4 {Tk_CharBBox procedure: normal char} { 970 .b.f config -text "000" -underline 1 971} {} 972test font-29.5 {Tk_CharBBox procedure: right edge of bbox truncated} { 973 .b.f config -text "0 0000" -wrap [expr $ax*4] -under 2 974 .b.f config -wrap 0 975} {} 976test font-29.6 {Tk_CharBBox procedure: bbox pegged to right edge} { 977 .b.f config -text "0 0000" -wrap [expr $ax*4] -under 3 978 .b.f config -wrap 0 979} {} 980 981.b.c bind all <Enter> {lappend x [.b.c index current @%x,%y]} 982 983test font-30.1 {Tk_DistanceToTextLayout procedure: loop once} { 984 csetup "000\n000\n000" 985 set x {} 986 event generate .b.c <Leave> 987 event generate .b.c <Enter> -x 0 -y 0 988 set x 989} {0} 990test font-30.2 {Tk_DistanceToTextLayout procedure: loop multiple} { 991 csetup "000\n000\n000" 992 set x {} 993 event generate .b.c <Leave> 994 event generate .b.c <Enter> -x $ax -y $ay 995 set x 996} {5} 997test font-30.3 {Tk_DistanceToTextLayout procedure: loop to end} { 998 csetup "000\n0\n000" 999 set x {} 1000 event generate .b.c <Leave> 1001 event generate .b.c <Enter> -x [expr $ax*2] -y $ay 1002 set x 1003} {} 1004test font-30.4 {Tk_DistanceToTextLayout procedure: hit a special char (tab)} { 1005 csetup "000\t000\n000" 1006 set x {} 1007 event generate .b.c <Leave> 1008 event generate .b.c <Enter> -x [expr $ax*6] -y 0 1009 set x 1010} {3} 1011test font-30.5 {Tk_DistanceToTextLayout procedure: ignore newline} { 1012 csetup "000\n0\n000" 1013 set x {} 1014 event generate .b.c <Leave> 1015 event generate .b.c <Enter> -x [expr $ax*2] -y $ay 1016 set x 1017} {} 1018test font-30.6 {Tk_DistanceToTextLayout procedure: ignore spaces at eol} { 1019 csetup "000\n000 000000000" 1020 .b.c itemconfig text -width [expr $ax*10] 1021 set x {} 1022 event generate .b.c <Leave> 1023 event generate .b.c <Enter> -x [expr $ax*5] -y $ay 1024 .b.c itemconfig text -width 0 1025 set x 1026} {} 1027.b.c itemconfig text -justify center 1028test font-30.7 {Tk_DistanceToTextLayout procedure: on left side} { 1029 csetup "0\n000" 1030 set x {} 1031 event generate .b.c <Leave> 1032 event generate .b.c <Enter> -x 0 -y 0 1033 set x 1034} {} 1035test font-30.8 {Tk_DistanceToTextLayout procedure: on right side} { 1036 csetup "0\n000" 1037 set x {} 1038 event generate .b.c <Leave> 1039 event generate .b.c <Enter> -x [expr $ax*2] -y 0 1040 set x 1041} {} 1042test font-30.9 {Tk_DistanceToTextLayout procedure: inside line} { 1043 csetup "0\n000" 1044 set x {} 1045 event generate .b.c <Leave> 1046 event generate .b.c <Enter> -x $ax -y 0 1047 set x 1048} {0} 1049test font-30.10 {Tk_DistanceToTextLayout procedure: above line} { 1050 csetup "0\n000" 1051 set x {} 1052 event generate .b.c <Leave> 1053 event generate .b.c <Enter> -x 0 -y 0 1054 set x 1055} {} 1056test font-30.11 {Tk_DistanceToTextLayout procedure: below line} { 1057 csetup "000\n0" 1058 set x {} 1059 event generate .b.c <Leave> 1060 event generate .b.c <Enter> -x 0 -y $ay 1061 set x 1062} {} 1063test font-30.12 {Tk_DistanceToTextLayout procedure: in line} { 1064 csetup "0\n000" 1065 set x {} 1066 event generate .b.c <Leave> 1067 event generate .b.c <Enter> -x $ax -y $ay 1068 set x 1069} {3} 1070.b.c itemconfig text -justify left 1071test font-30.13 {Tk_DistanceToTextLayout procedure: exact hit} { 1072 csetup "000" 1073 set x {} 1074 event generate .b.c <Leave> 1075 event generate .b.c <Enter> -x $ax -y 0 1076 set x 1077} {1} 1078 1079test font-31.1 {Tk_IntersectTextLayout procedure: loop once} { 1080 csetup "000\n000\n000" 1081 .b.c find overlapping 0 0 0 0 1082} [.b.c find withtag text] 1083test font-31.2 {Tk_IntersectTextLayout procedure: loop multiple} { 1084 csetup "000\t000\t000" 1085 .b.c find overlapping [expr $ax*10] 0 [expr $ax*10] 0 1086} [.b.c find withtag text] 1087test font-31.3 {Tk_IntersectTextLayout procedure: loop to end} { 1088 csetup "0\n000" 1089 .b.c find overlapping [expr $ax*2] 0 [expr $ax*2] 0 1090} {} 1091test font-31.4 {Tk_IntersectTextLayout procedure: hit a special char (tab)} { 1092 csetup "000\t000" 1093 .b.c find overlapping [expr $ax*6] 0 [expr $ax*6] 0 1094} [.b.c find withtag text] 1095test font-31.5 {Tk_IntersectTextLayout procedure: ignore newlines} { 1096 csetup "000\n0\n000" 1097 .b.c find overlapping $ax $ay $ax $ay 1098} {} 1099test font-31.6 {Tk_IntersectTextLayout procedure: ignore spaces at eol} { 1100 csetup "000\n000 000000000" 1101 .b.c itemconfig text -width [expr $ax*10] 1102 set x [.b.c find overlapping [expr $ax*5] $ay [expr $ax*5] $ay] 1103 .b.c itemconfig text -width 0 1104 set x 1105} {} 1106 1107test font-32.1 {Tk_TextLayoutToPostscript: ensure buffer doesn't overflow} { 1108 # If there were a whole bunch of returns or tabs in a row, then the 1109 # temporary buffer could overflow and write on the stack. 1110 1111 csetup "qwertyuiopasdfghjklzxcvbnm1234qwertyuiopasdfghjklzxcvbnm\n" 1112 .b.c itemconfig text -width 800 1113 .b.c insert text end "qwertyuiopasdfghjklzxcvbnm1234qwertyuiopasdfghjklzxcvbnm\n" 1114 .b.c insert text end "\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n" 1115 .b.c insert text end "end" 1116 set x [.b.c postscript] 1117 set i [string first "(qwerty" $x] 1118 string range $x $i [expr {$i + 278}] 1119} {(qwertyuiopasdfghjklzxcvbnm1234qwertyuiopasdfghjklzxcvbnm)] 1120[(qwertyuiopasdfghjklzxcvbnm1234qwertyuiopasdfghjklzxcvbnm)] 1121[()] 1122[()] 1123[()] 1124[()] 1125[()] 1126[()] 1127[()] 1128[()] 1129[()] 1130[()] 1131[()] 1132[()] 1133[()] 1134[()] 1135[()] 1136[()] 1137[()] 1138[()] 1139[()] 1140[()] 1141[()] 1142[()] 1143[()] 1144[()] 1145[()] 1146[()] 1147[()] 1148[()] 1149[()] 1150[()] 1151[(end)] 1152} 1153 1154test font-33.1 {Tk_TextWidth procedure} { 1155} {} 1156 1157test font-33.2 {ConfigAttributesObj procedure: arguments} { 1158 # (Tcl_GetIndexFromObj() != TCL_OK) 1159 setup 1160 list [catch {font create xyz -xyz} msg] $msg 1161} {1 {bad option "-xyz": must be -family, -size, -weight, -slant, -underline, or -overstrike}} 1162test font-34.1 {ConfigAttributesObj procedure: arguments} { 1163 # (objc & 1) 1164 setup 1165 list [catch {font create xyz -family} msg] $msg 1166} {1 {value for "-family" option missing}} 1167set i 3 1168foreach p { 1169 {family xyz times} 1170 {size 20 40} 1171 {weight normal bold} 1172 {slant roman italic} 1173 {underline 0 1} 1174 {overstrike 0 1} 1175} { 1176 set opt [lindex $p 0] 1177 test font-34.$i "ConfigAttributesObj procedure: $opt" { 1178 setup 1179 set x {} 1180 font create xyz -$opt [lindex $p 1] 1181 lappend x [font config xyz -$opt] 1182 font config xyz -$opt [lindex $p 2] 1183 lappend x [font config xyz -$opt] 1184 } [lrange $p 1 2] 1185 incr i 1186} 1187foreach p { 1188 {size xyz {1 {expected integer but got "xyz"}}} 1189 {weight xyz {1 {bad -weight value "xyz": must be normal, or bold}}} 1190 {slant xyz {1 {bad -slant value "xyz": must be roman, or italic}}} 1191 {underline xyz {1 {expected boolean value but got "xyz"}}} 1192 {overstrike xyz {1 {expected boolean value but got "xyz"}}} 1193} { 1194 test font-34.$i "ConfigAttributesObj procedure: [lindex $p 0]" { 1195 setup 1196 list [catch {font create xyz -[lindex $p 0] [lindex $p 1]} msg] $msg 1197 } [lindex $p 2] 1198 incr i 1199} 1200 1201test font-35.1 {GetAttributeInfoObj procedure: one attribute} { 1202 # (objPtr != NULL) 1203 setup 1204 font create xyz -family xyz 1205 font config xyz -family 1206} {xyz} 1207test font-36.1 {GetAttributeInfoObj procedure: unknown attribute} { 1208 # (Tcl_GetIndexFromObj() != TCL_OK) 1209 setup 1210 font create xyz 1211 list [catch {font config xyz -xyz} msg] $msg 1212} {1 {bad option "-xyz": must be -family, -size, -weight, -slant, -underline, or -overstrike}} 1213test font-37.1 {GetAttributeInfoObj procedure: all attributes} { 1214 # not (objPtr != NULL) 1215 setup 1216 font create xyz -family xyz 1217 font config xyz 1218} {-family xyz -size 0 -weight normal -slant roman -underline 0 -overstrike 0} 1219set i 4 1220foreach p { 1221 {family xyz xyz} 1222 {size 20 20} 1223 {weight normal normal} 1224 {slant italic italic} 1225 {underline yes 1} 1226 {overstrike false 0} 1227} { 1228 test font-31.$i "GetAttributeInfo procedure: [lindex $p 0]" { 1229 setup 1230 font create xyz -[lindex $p 0] [lindex $p 1] 1231 font config xyz -[lindex $p 0] 1232 } [lindex $p 2] 1233 incr i 1234} 1235 1236# In tests below, one field is set to "xyz" so that font name doesn't 1237# look like a native X font, so that ParseFontNameObj or TkParseXLFD will 1238# be called. 1239 1240setup 1241 1242test font-38.1 {ParseFontNameObj procedure: begins with -} { 1243 lindex [font actual -xyz-times-*-*-*-*-*-*-*-*-*-*-*-*] 1 1244} $times 1245test font-38.2 {ParseFontNameObj procedure: begins with -*} { 1246 lindex [font actual -*-times-xyz-*-*-*-*-*-*-*-*-*-*-*] 1 1247} $times 1248test font-38.3 {ParseFontNameObj procedure: begins with -, doesn't look like list} { 1249 lindex [font actual -xyz-times-*-*-*-*-*-*-*-*-*-*-*-*] 1 1250} $times 1251test font-38.4 {ParseFontNameObj procedure: begins with -, looks like list} { 1252 lindex [font actual {-family times}] 1 1253} $times 1254test font-38.5 {ParseFontNameObj procedure: begins with *} { 1255 lindex [font actual *-times-xyz-*-*-*-*-*-*-*-*-*-*-*] 1 1256} $times 1257test font-38.6 {ParseFontNameObj procedure: begins with *} { 1258 font actual *-times-xyz -family 1259} $times 1260test font-38.7 {ParseFontNameObj procedure: arguments} {noExceed} { 1261 list [catch {font actual "\{xyz"} msg] $msg 1262} [list 1 "font \"{xyz\" doesn't exist"] 1263test font-38.8 {ParseFontNameObj procedure: arguments} {noExceed} { 1264 list [catch {font actual ""} msg] $msg 1265} {1 {font "" doesn't exist}} 1266test font-38.9 {ParseFontNameObj procedure: arguments} { 1267 list [catch {font actual {times 20 xyz xyz}} msg] $msg 1268} {1 {unknown font style "xyz"}} 1269test font-38.10 {ParseFontNameObj procedure: arguments} { 1270 list [catch {font actual {times xyz xyz}} msg] $msg 1271} {1 {expected integer but got "xyz"}} 1272test font-38.11 {ParseFontNameObj procedure: stylelist loop} {macOnly} { 1273 lrange [font actual {times 12 bold italic overstrike underline}] 4 end 1274} {-weight bold -slant italic -underline 1 -overstrike 0} 1275test font-38.12 {ParseFontNameObj procedure: stylelist loop} {unixOrPc} { 1276 lrange [font actual {times 12 bold italic overstrike underline}] 4 end 1277} {-weight bold -slant italic -underline 1 -overstrike 1} 1278test font-38.13 {ParseFontNameObj procedure: stylelist error} { 1279 list [catch {font actual {times 12 bold xyz}} msg] $msg 1280} {1 {unknown font style "xyz"}} 1281 1282test font-39.1 {NewChunk procedure: test realloc} { 1283 .b.f config -text "xxx\nxxx\txxx\nxxx\t\t\t" 1284} {} 1285 1286test font-40.1 {TkFontParseXLFD procedure: initial dash} { 1287 font actual -xyz-times-*-*-*-*-*-*-*-*-*-*-*-* -family 1288} $times 1289test font-40.2 {TkFontParseXLFD procedure: no initial dash} { 1290 font actual *-times-*-*-*-*-*-*-*-*-*-*-*-xyz -family 1291} $times 1292test font-40.3 {TkFontParseXLFD procedure: not enough fields} { 1293 font actual -xyz-times-*-*-* -family 1294} $times 1295test font-40.4 {TkFontParseXLFD procedure: all fields unspecified} { 1296 lindex [font actual -xyz-*-*-*-*-*-*-*-*-*-*-*-*-*] 0 1297} {-family} 1298test font-40.5 {TkFontParseXLFD procedure: all fields specified} { 1299 lindex [font actual -foundry-times-weight-slant-setwidth-addstyle-10-10-10-10-spacing-avgwidth-registry-encoding] 1 1300} $times 1301test font-41.1 {TkParseXLFD procedure: arguments} { 1302 # XLFD with bad pointsize: fallback to some system font. 1303 font actual -*-*-*-*-*-*-xyz-*-*-*-*-*-*-* 1304 set x {} 1305} {} 1306test font-42.1 {TkFontParseXLFD procedure: arguments} { 1307 # XLFD with bad pixelsize: fallback to some system font. 1308 font actual -*-*-*-*-*-*-*-xyz-*-*-*-*-*-* 1309 set x {} 1310} {} 1311test font-42.2 {TkFontParseXLFD procedure: pixelsize specified} { 1312 font metrics -xyz-times-*-*-*-*-12-*-*-*-*-*-*-* -linespace 1313 set x {} 1314} {} 1315test font-42.3 {TkFontParseXLFD procedure: weird pixelsize specified} { 1316 font metrics {-xyz-times-*-*-*-*-[ 12.0 0 12.0 0]-*-*-*-*-*-*-*} -linespace 1317 set x {} 1318} {} 1319test font-42.4 {TkFontParseXLFD procedure: pointsize specified} { 1320 font metrics -xyz-times-*-*-*-*-*-120-*-*-*-*-*-* -linespace 1321 set x {} 1322} {} 1323test font-42.5 {TkFontParseXLFD procedure: weird pointsize specified} { 1324 font metrics {-xyz-times-*-*-*-*-*-[ 12.0 0 12.0 0]-*-*-*-*-*-*} -linespace 1325 set x {} 1326} {} 1327 1328test font-43.1 {FieldSpecified procedure: specified vs. non-specified} { 1329 font actual -xyz--*-*-*-*-*-*-*-*-*-*-*-* 1330 font actual -xyz-*-*-*-*-*-*-*-*-*-*-*-*-* 1331 font actual -xyz-?-*-*-*-*-*-*-*-*-*-*-*-* 1332 lindex [font actual -xyz-times-*-*-*-*-*-*-*-*-*-*-*-*] 1 1333} $times 1334 1335set oldscale [tk scaling] 1336tk scaling 0.5 1337test font-44.1 {TkFontGetPixels: size < 0} { 1338 font actual {times -12} -size 1339} {24} 1340test font-44.2 {TkFontGetPoints: size >= 0} {noExceed} { 1341 font actual {times 12} -size 1342} {12} 1343 1344tk scaling $oldscale 1345 1346test font-45.1 {TkFontGetAliasList: no match} { 1347 font actual {snarky 10} -family 1348} [font actual {-size 10} -family] 1349test font-45.2 {TkFontGetAliasList: match} {macOnly} { 1350 # Result could be either "Times" or "New York" 1351 font actual {{times new roman} 10} -family 1352} [font actual {times 10} -family] 1353test font-45.3 {TkFontGetAliasList: match} {pcOnly} { 1354 font actual {times 10} -family 1355} {Times New Roman} 1356test font-45.4 {TkFontGetAliasList: match} {unixOnly noExceed} { 1357 # can fail on Unix systems that have a real "times new roman" font 1358 font actual {{times new roman} 10} -family 1359} [font actual {times 10} -family] 1360 1361setup 1362 1363destroy .b 1364 1365# cleanup 1366::tcltest::cleanupTests 1367return 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381