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$ 10 11package require tcltest 2.1 12eval tcltest::configure $argv 13tcltest::loadTestedCommands 14 15catch {destroy .b} 16toplevel .b 17wm geom .b +0+0 18update idletasks 19 20proc setup {} { 21 catch {destroy .b.f} 22 catch {eval font delete [font names]} 23 label .b.f 24 pack .b.f 25 update 26} 27 28label .b.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left -text "0" -font "Courier -12" 29pack .b.l 30canvas .b.c -closeenough 0 31.b.c create text 0 0 -tags text -anchor nw -just left -font "Courier -12" 32pack .b.c 33update 34 35set ax [winfo reqwidth .b.l] 36set ay [winfo reqheight .b.l] 37proc getsize {} { 38 update 39 return "[winfo reqwidth .b.l] [winfo reqheight .b.l]" 40} 41 42proc csetup {{str ""}} { 43 focus -force .b.c 44 .b.c dchars text 0 end 45 .b.c insert text 0 $str 46 .b.c focus text 47} 48 49setup 50 51case [tk windowingsystem] { 52 x11 {set fixed "fixed"} 53 win32 {set fixed "courier 12"} 54 classic - 55 aqua {set fixed "monaco 9"} 56} 57 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? ?--? ?char?"}} 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? ?--? ?char?"}} 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? ?--? ?char?"}} 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} {unix 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} win { 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 {expr {[font measure xyz -displayof]>0}} msg] $msg 313} {0 1} 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} 330test font-9.6 {font command: measure -d} { 331 list [catch {expr {[font measure $fixed -d] > 0}} msg] $msg 332} {0 1} 333test font-9.7 {font command: measure -d with -displayof} { 334 list [catch {expr {[font measure $fixed -displayof . -d] > 0}} msg] $msg 335} {0 1} 336test font-9.8 {font command: measure: arguments} { 337 list [catch {font measure $fixed -displayof .} msg] $msg 338} {1 {wrong # args: should be "font measure font ?-displayof window? text"}} 339 340test font-10.1 {font command: metrics: arguments} { 341 list [catch {font metrics xyz -displayof} msg] $msg 342} {1 {value for "-displayof" missing}} 343test font-10.2 {font command: metrics: arguments} { 344 # (skip < 0) 345 list [catch {font metrics xyz -displayof} msg] $msg 346} {1 {value for "-displayof" missing}} 347test font-10.3 {font command: metrics: arguments} { 348 # (objc < 3) 349 list [catch {font metrics} msg] $msg 350} {1 {wrong # args: should be "font metrics font ?-displayof window? ?option?"}} 351test font-10.4 {font command: metrics: arguments} { 352 # (objc - skip) > 4) when skip == 0 353 list [catch {font metrics xyz abc def} msg] $msg 354} {1 {wrong # args: should be "font metrics font ?-displayof window? ?option?"}} 355test font-10.5 {font command: metrics: arguments} { 356 # (objc - skip) > 4) when skip == 2 357 list [catch {font metrics xyz -displayof . abc} msg] $msg 358} {1 {bad metric "abc": must be -ascent, -descent, -linespace, or -fixed}} 359test font-10.6 {font command: metrics: bad font} {noExceed} { 360 # (tkfont == NULL) 361 list [catch {font metrics "\{xyz"} msg] $msg 362} [list 1 "font \"{xyz\" doesn't exist"] 363test font-10.7 {font command: metrics: get all metrics} { 364 # (objc == 3) 365 catch {unset a} 366 array set a [font metrics {-family xyz}] 367 set x [lsort [array names a]] 368 unset a 369 set x 370} {-ascent -descent -fixed -linespace} 371test font-10.8 {font command: metrics: bad metric} { 372 # (Tcl_GetIndexFromObj() != TCL_OK) 373 list [catch {font metrics $fixed -xyz} msg] $msg 374} {1 {bad metric "-xyz": must be -ascent, -descent, -linespace, or -fixed}} 375test font-10.9 {font command: metrics: get individual metrics} { 376 font metrics $fixed -ascent 377 font metrics $fixed -descent 378 font metrics $fixed -linespace 379 font metrics $fixed -fixed 380} {1} 381 382test font-11.1 {font command: names: arguments} { 383 # (objc != 2) 384 list [catch {font names xyz} msg] $msg 385} {1 {wrong # args: should be "font names"}} 386test font-11.2 {font command: names: loop test: no passes} { 387 setup 388 font names 389} {} 390test font-11.3 {font command: names: loop test: one pass} { 391 setup 392 font create 393 font names 394} {font1} 395test font-11.4 {font command: names: loop test: multiple passes} { 396 setup 397 font create xyz 398 font create abc 399 font create def 400 lsort [font names] 401} {abc def xyz} 402test font-11.5 {font command: names: skip deletePending fonts} { 403 # (nfPtr->deletePending == 0) 404 setup 405 set x {} 406 font create xyz 407 font create abc 408 lappend x [lsort [font names]] 409 .b.f config -font xyz 410 font delete xyz 411 lappend x [font names] 412} {{abc xyz} abc} 413 414test font-12.1 {UpdateDependantFonts procedure: no users} { 415 # (nfPtr->refCount == 0) 416 setup 417 font create xyz 418 font configure xyz -family times 419} {} 420test font-12.2 {UpdateDependantFonts procedure: pings the widgets} { 421 setup 422 font create xyz -family times -size 20 423 .b.f config -font xyz -text "abcd" -padx 0 -bd 0 -highlightthickness 0 424 set a1 [font measure xyz "abcd"] 425 update 426 set b1 [winfo reqwidth .b.f] 427 font configure xyz -family helvetica -size 20 428 set a2 [font measure xyz "abcd"] 429 update 430 set b2 [winfo reqwidth .b.f] 431 expr {$a1==$b1 && $a2==$b2} 432} {1} 433 434test font-13.1 {CreateNamedFont: new named font} { 435 # not (new == 0) 436 setup 437 set x {} 438 lappend x [font names] 439 font create xyz 440 lappend x [font names] 441} {{} xyz} 442test font-13.2 {CreateNamedFont: named font already exists} { 443 # (new == 0) 444 setup 445 font create xyz 446 list [catch {font create xyz} msg] $msg 447} {1 {named font "xyz" already exists}} 448test font-13.3 {CreateNamedFont: named font already exists} { 449 # (nfPtr->deletePending == 0) 450 setup 451 font create xyz 452 list [catch {font create xyz} msg] $msg 453} {1 {named font "xyz" already exists}} 454test font-13.4 {CreateNamedFont: recreate "deleted" font} { 455 # not (nfPtr->deletePending == 0) 456 setup 457 font create xyz -family times 458 .b.f configure -font xyz 459 font delete xyz 460 font create xyz -family courier 461 font configure xyz -family 462} {courier} 463 464test font-14.1 {Tk_GetFont procedure} { 465} {} 466 467test font-15.1 {Tk_AllocFontFromObj - converting internal reps} testfont { 468 set x {Times 16} 469 lindex $x 0 470 destroy .b1 .b2 471 button .b1 -font $x 472 lindex $x 0 473 testfont counts {Times 16} 474} {{1 0}} 475test font-15.2 {Tk_AllocFontFromObj - discard stale font} testfont { 476 set x {Times 16} 477 destroy .b1 .b2 478 button .b1 -font $x 479 destroy .b1 480 set result {} 481 lappend result [testfont counts {Times 16}] 482 button .b2 -font $x 483 lappend result [testfont counts {Times 16}] 484} {{} {{1 1}}} 485test font-15.3 {Tk_AllocFontFromObj - reuse existing font} testfont { 486 set x {Times 16} 487 destroy .b1 .b2 488 button .b1 -font $x 489 set result {} 490 lappend result [testfont counts {Times 16}] 491 button .b2 -font $x 492 pack .b1 .b2 -side top 493 lappend result [testfont counts {Times 16}] 494} {{{1 1}} {{2 1}}} 495test font-15.4 {Tk_AllocFontFromObj procedure: bump ref count} { 496 # (new == 0) 497 setup 498 .b.f config -font {-family fixed} 499 lindex [font actual {-family fixed}] 0 500} {-family} 501test font-15.5 {Tk_AllocFontFromObj procedure: get named font} { 502 # (namedHashPtr != NULL) 503 setup 504 font create xyz 505 .b.f config -font xyz 506} {} 507test font-15.6 {Tk_AllocFontFromObj procedure: not a named font} { 508 # not (namedHashPtr != NULL) 509 setup 510 .b.f config -font {times 20} 511} {} 512test font-15.7 {Tk_AllocFontFromObj procedure: get native font} unix { 513 # not (fontPtr == NULL) 514 setup 515 .b.f config -font fixed 516} {} 517test font-15.8 {Tk_AllocFontFromObj procedure: get native font} win { 518 # not (fontPtr == NULL) 519 setup 520 .b.f config -font oemfixed 521} {} 522test font-15.10 {Tk_AllocFontFromObj procedure: get attribute font} { 523 # (fontPtr == NULL) 524 list [catch {.b.f config -font {xxx yyy zzz}} msg] $msg 525} {1 {expected integer but got "yyy"}} 526test font-15.11 {Tk_AllocFontFromObj procedure: no match} {noExceed} { 527 # (ParseFontNameObj() != TCL_OK) 528 list [catch {font actual "\{xyz"} msg] $msg 529} [list 1 "font \"{xyz\" doesn't exist"] 530test font-15.12 {Tk_AllocFontFromObj procedure: get attribute font} { 531 # not (ParseFontNameObj() != TCL_OK) 532 lindex [font actual {plan 9}] 0 533} {-family} 534test font-15.13 {Tk_AllocFontFromObj procedure: setup tab width} { 535 # Tk_MeasureChars(fontPtr, "0", ...) 536 label .l -bd 0 -padx 0 -highlightthickness 0 -font $fixed -text "a\tb" 537 update 538 set x [winfo reqwidth .l] 539 destroy .l 540 set x 541} [expr [font measure $fixed "0"]*9] 542test font-15.14 {Tk_AllocFontFromObj procedure: underline position} { 543 # (fontPtr->underlineHeight == 0) because size was < 10 544 setup 545 .b.f config -text "underline" -font "times -8 underline" 546 update 547} {} 548 549test font-16.1 {Tk_NameOfFont procedure} { 550 setup 551 .b.f config -font -family\ fixed 552 .b.f cget -font 553} {-family fixed} 554 555test font-17.1 {Tk_FreeFontFromObj - reference counts} testfont { 556 set x {Courier 12} 557 destroy .b1 .b2 .b3 558 button .b1 -font $x 559 button .b3 -font $x 560 button .b2 -font $x 561 set result {} 562 lappend result [testfont counts {Courier 12}] 563 destroy .b1 564 lappend result [testfont counts {Courier 12}] 565 destroy .b2 566 lappend result [testfont counts {Courier 12}] 567 destroy .b3 568 lappend result [testfont counts {Courier 12}] 569} {{{3 1}} {{2 1}} {{1 1}} {}} 570test font-17.2 {Tk_FreeFont procedure: one ref} { 571 # (fontPtr->refCount == 0) 572 setup 573 .b.f config -font {-family fixed} 574 destroy .b.f 575} {} 576test font-17.3 {Tk_FreeFont procedure: multiple ref} { 577 # not (fontPtr->refCount == 0) 578 setup 579 .b.f config -font {-family fixed} 580 button .b.b -font {-family fixed} 581 destroy .b.f 582 set x [.b.b cget -font] 583 destroy .b.b 584 set x 585} {-family fixed} 586test font-17.4 {Tk_FreeFont procedure: named font} { 587 # (fontPtr->namedHashPtr != NULL) 588 setup 589 font create xyz 590 .b.f config -font xyz 591 destroy .b.f 592 font names 593} {xyz} 594test font-17.5 {Tk_FreeFont procedure: named font} { 595 # not (fontPtr->refCount == 0) 596 setup 597 font create xyz -underline 1 598 .b.f config -font xyz 599 font delete xyz 600 set x [font actual xyz -underline] 601 destroy .b.f 602 list [font actual xyz -underline] $x 603} {0 1} 604test font-17.6 {Tk_FreeFont procedure: named font not deleted yet} { 605 setup 606 font create xyz 607 .b.f config -font xyz 608 button .b.b -font xyz 609 font delete xyz 610 set x [font actual xyz] 611 destroy .b.b 612 list [lindex [font actual xyz] 0] [lindex $x 0] 613} {-family -family} 614 615test font-18.1 {FreeFontObjProc} testfont { 616 destroy .b1 617 set x [format {Courier 12}] 618 button .b1 -font $x 619 set y [format {Courier 12}] 620 .b1 configure -font $y 621 set z [format {Courier 12}] 622 .b1 configure -font $z 623 set result {} 624 lappend result [testfont counts {Courier 12}] 625 set x red 626 lappend result [testfont counts {Courier 12}] 627 set z 32 628 lappend result [testfont counts {Courier 12}] 629 destroy .b1 630 lappend result [testfont counts {Courier 12}] 631 set y bogus 632 set result 633} {{{1 3}} {{1 2}} {{1 1}} {}} 634 635test font-19.1 {Tk_FontId} { 636 .b.f config -font "times 20" 637 update 638} {} 639 640test font-20.1 {Tk_GetFontMetrics procedure} { 641 button .b.w1 -text abc 642 entry .b.w2 -text abcd 643 update 644 destroy .b.w1 .b.w2 645} {} 646 647proc psfontname {name} { 648 set a [.b.c itemcget text -font] 649 .b.c itemconfig text -text "We need text" -font $name 650 set post [.b.c postscript] 651 .b.c itemconfig text -font $a 652 set end [string first "findfont" $post] 653 incr end -2 654 set post [string range $post [expr $end-70] $end] 655 set start [string first "gsave" $post] 656 return [string range $post [expr $start+7] end] 657} 658test font-21.1 {Tk_PostscriptFontName procedure: native} unix { 659 set x [font actual {{itc avant garde} 10} -family] 660 if {[string match *avant*garde $x]} { 661 psfontname "{itc avant garde} 10" 662 } else { 663 set x {AvantGarde-Book} 664 } 665} {AvantGarde-Book} 666test font-21.2 {Tk_PostscriptFontName procedure: native} win { 667 psfontname "arial 10" 668} {Helvetica} 669test font-21.3 {Tk_PostscriptFontName procedure: native} win { 670 psfontname "{times new roman} 10" 671} {Times-Roman} 672test font-21.4 {Tk_PostscriptFontName procedure: native} win { 673 psfontname "{courier new} 10" 674} {Courier} 675test font-21.8 {Tk_PostscriptFontName procedure: spaces} unix { 676 set x [font actual {{lucida bright} 10} -family] 677 if {[string match lucida*bright $x]} { 678 psfontname "{lucida bright} 10" 679 } else { 680 set x {LucidaBright} 681 } 682} {LucidaBright} 683test font-21.9 {Tk_PostscriptFontName procedure: spaces} unix { 684 psfontname "{new century schoolbook} 10" 685} {NewCenturySchlbk-Roman} 686set i 10 687foreach p { 688 {font-21.10 "avantgarde" 689 AvantGarde-Book AvantGarde-Demi 690 AvantGarde-BookOblique AvantGarde-DemiOblique} 691 {font-21.11 "bookman" 692 Bookman-Light Bookman-Demi Bookman-LightItalic Bookman-DemiItalic} 693 {font-21.12 "courier" 694 Courier Courier-Bold Courier-Oblique Courier-BoldOblique} 695 {font-21.13 "helvetica" 696 Helvetica Helvetica-Bold Helvetica-Oblique Helvetica-BoldOblique} 697 {font-21.14 "new century schoolbook" 698 NewCenturySchlbk-Roman NewCenturySchlbk-Bold 699 NewCenturySchlbk-Italic NewCenturySchlbk-BoldItalic} 700 {font-21.15 "palatino" 701 Palatino-Roman Palatino-Bold Palatino-Italic Palatino-BoldItalic} 702 {font-21.16 "symbol" 703 Symbol Symbol Symbol Symbol} 704 {font-21.17 "times" 705 Times-Roman Times-Bold Times-Italic Times-BoldItalic} 706 {font-21.18 "zapfchancery" 707 ZapfChancery-MediumItalic ZapfChancery-MediumItalic 708 ZapfChancery-MediumItalic ZapfChancery-MediumItalic} 709 {font-21.19 "zapfdingbats" 710 ZapfDingbats ZapfDingbats ZapfDingbats ZapfDingbats} 711} { 712 set values [lassign $p testName family] 713 test $testName {Tk_PostscriptFontName procedure: exhaustive} unix { 714 set x {} 715 set j 0 716 foreach slant {roman italic} { 717 foreach weight {normal bold} { 718 set name [list $family 12 $slant $weight] 719 if {[font actual $name -family] == $family} { 720 lappend x [psfontname $name] 721 } else { 722 lappend x [lindex $values $j] 723 } 724 incr j 725 } 726 } 727 set x 728 } $values 729} 730foreach p { 731 {font-21.20 "arial" 732 Helvetica Helvetica-Bold Helvetica-Oblique Helvetica-BoldOblique} 733 {font-21.21 "courier new" 734 Courier Courier-Bold Courier-Oblique Courier-BoldOblique} 735 {font-21.22 "helvetica" 736 Helvetica Helvetica-Bold Helvetica-Oblique Helvetica-BoldOblique} 737 {font-21.23 "symbol" 738 Symbol Symbol-Bold Symbol-Italic Symbol-BoldItalic} 739 {font-21.24 "times new roman" 740 Times-Roman Times-Bold Times-Italic Times-BoldItalic} 741} { 742 set values [lassign $p testName family] 743 test $testName {Tk_PostscriptFontName procedure: exhaustive} win { 744 set x {} 745 foreach slant {roman italic} { 746 foreach weight {normal bold} { 747 lappend x [psfontname [list $family 12 "$slant $weight"]] 748 } 749 } 750 set x 751 } $values 752} 753 754test font-22.1 {Tk_TextWidth procedure} { 755 font measure [.b.l cget -font] "000" 756} [expr $ax*3] 757 758test font-23.1 {Tk_UnderlineChars procedure} { 759 text .b.t 760 .b.t insert 1.0 abc\tdefg 761 .b.t tag config sel -underline 1 762 .b.t tag add sel 1.0 end 763 update 764} {} 765 766setup 767test font-24.1 {Tk_ComputeTextLayout: empty string} { 768 .b.l config -text "" 769} {} 770test font-24.2 {Tk_ComputeTextLayout: simple string} { 771 .b.l config -text "000" 772 getsize 773} "[expr $ax*3] $ay" 774test font-24.3 {Tk_ComputeTextLayout: find special chars} { 775 .b.l config -text "000\n000" 776 getsize 777} "[expr $ax*3] [expr $ay*2]" 778test font-24.4 {Tk_ComputeTextLayout: calls Tk_MeasureChars} { 779 .b.l config -text "000\n000" 780 getsize 781} "[expr $ax*3] [expr $ay*2]" 782test font-24.5 {Tk_ComputeTextLayout: break line} { 783 .b.l config -text "000\t00000" -wrap [expr 9*$ax] 784 set x [getsize] 785 .b.l config -wrap 0 786 set x 787} "[expr 8*$ax] [expr 2*$ay]" 788test font-24.6 {Tk_ComputeTextLayout: normal ended on special char} { 789 .b.l config -text "000\n000" 790} {} 791test font-24.7 {Tk_ComputeTextLayout: special char was \n} { 792 .b.l config -text "000\n0000" 793 getsize 794} "[expr $ax*4] [expr $ay*2]" 795test font-24.8 {Tk_ComputeTextLayout: special char was \t} { 796 .b.l config -text "000\t00" 797 getsize 798} "[expr $ax*10] $ay" 799test font-24.9 {Tk_ComputeTextLayout: tab didn't cause break} { 800 set x {} 801 .b.l config -text "000\t000" 802 lappend x [getsize] 803 .b.l config -text "000\t000" -wrap [expr 100*$ax] 804 lappend x [getsize] 805 .b.l config -wrap 0 806 set x 807} "{[expr $ax*11] $ay} {[expr $ax*11] $ay}" 808test font-24.10 {Tk_ComputeTextLayout: tab caused break} { 809 set x {} 810 .b.l config -text "000\t" 811 lappend x [getsize] 812 .b.l config -text "000\t00" -wrap [expr $ax*6] 813 lappend x [getsize] 814 .b.l config -wrap 0 815 set x 816} "{[expr $ax*3] $ay} {[expr $ax*3] [expr $ay*2]}" 817test font-24.11 {Tk_ComputeTextLayout: absorb spaces at eol} { 818 set x {} 819 .b.l config -text "000 000" -wrap [expr $ax*5] 820 lappend x [getsize] 821 .b.l config -text "000 " 822 lappend x [getsize] 823 .b.l config -wrap 0 824 set x 825} "{[expr $ax*3] [expr $ay*2]} {[expr $ax*3] $ay}" 826test font-24.12 {Tk_ComputeTextLayout: append non-printing spaces to chunk} { 827 set x {} 828 .b.l config -text "000 0000" -wrap [expr $ax*5] 829 lappend x [getsize] 830 .b.l config -text "000\t00 0000" -wrap [expr $ax*12] 831 lappend x [getsize] 832 .b.l config -wrap 0 833 set x 834} "{[expr $ax*4] [expr $ay*2]} {[expr $ax*10] [expr $ay*2]}" 835test font-24.13 {Tk_ComputeTextLayout: many lines -> realloc line array} { 836 .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" 837 getsize 838} "1 [expr $ay*129]" 839test font-24.14 {Tk_ComputeTextLayout: text ended with \n} { 840 list [.b.l config -text "0000"; getsize] [.b.l config -text "0000\n"; getsize] 841} "{[expr $ax*4] $ay} {[expr $ax*4] [expr $ay*2]}" 842test font-24.15 {Tk_ComputeTextLayout: justification} { 843 csetup "000\n00000" 844 set x {} 845 .b.c itemconfig text -just left 846 lappend x [.b.c index text @[expr $ax*2],0] 847 .b.c itemconfig text -just center 848 lappend x [.b.c index text @[expr $ax*2],0] 849 .b.c itemconfig text -just right 850 lappend x [.b.c index text @[expr $ax*2],0] 851 .b.c itemconfig text -just left 852 set x 853} {2 1 0} 854 855test font-25.1 {Tk_FreeTextLayout procedure} { 856 setup 857 .b.f config -text foo 858 .b.f config -text boo 859} {} 860 861test font-26.1 {Tk_DrawTextLayout procedure: auto-detect last char} { 862 .b.f config -text foo 863} {} 864test font-26.2 {Tk_DrawTextLayout procedure: multiple chunks} { 865 csetup "000\t00\n000" 866} {} 867test font-26.3 {Tk_DrawTextLayout: draw subset of chunk: numDisplay <= 0} { 868 csetup "000\t00" 869 .b.c select from text 3 870 .b.c select to text 5 871} {} 872test font-26.4 {Tk_DrawTextLayout: draw subset of chunk: firstChar <= 0} { 873 .b.c select from text 3 874 .b.c select to text 5 875} {} 876test font-26.5 {Tk_DrawTextLayout: draw subset of chunk: firstChar > 0} { 877 .b.c select from text 2 878 .b.c select to text 2 879} {} 880test font-26.6 {Tk_DrawTextLayout: draw subset of chunk: lastChar < numChars} { 881 .b.c select from text 4 882 .b.c select to text 4 883} {} 884 885test font-27.1 {Tk_UnderlineTextLayout procedure: no underline chosen} { 886 .b.f config -text "foo" -under -1 887} {} 888test font-27.2 {Tk_UnderlineTextLayout procedure: underline not visible} { 889 .b.f config -text "000 00000" -wrap [expr $ax*7] -under 10 890} {} 891test font-27.3 {Tk_UnderlineTextLayout procedure: underline is visible} { 892 .b.f config -text "000 00000" -wrap [expr $ax*7] -under 5 893 .b.f config -wrap -1 -under -1 894} {} 895 896test font-28.1 {Tk_PointToChar procedure: above all lines} { 897 csetup "000" 898 .b.c index text @-1,0 899} {0} 900test font-28.2 {Tk_PointToChar procedure: no chars} { 901 # After fixing the following bug: 902 # 903 # In canvas text item, it was impossible to click to position the 904 # insertion point just after the last character. 905 # 906 # introduced another bug that Tk_PointToChar() would return a character 907 # index of 1 if TextLayout contained 0 characters. 908 909 csetup "" 910 .b.c index text @100,100 911} {0} 912test font-28.3 {Tk_PointToChar procedure: loop test} { 913 csetup "000\n000\n000\n000" 914 .b.c index text @10000,0 915} {3} 916test font-28.4 {Tk_PointToChar procedure: intersect line} { 917 csetup "000\n000\n000" 918 .b.c index text @0,$ay 919} {4} 920test font-28.5 {Tk_PointToChar procedure: to the left of all chunks} { 921 .b.c index text @-100,$ay 922} {4} 923test font-28.6 {Tk_PointToChar procedure: past any possible chunk} { 924 .b.c index text @100000,$ay 925} {7} 926test font-28.7 {Tk_PointToChar procedure: which chunk on this line} { 927 csetup "000\n000\t000\t000\n000" 928 .b.c index text @[expr $ax*2],$ay 929} {6} 930test font-28.8 {Tk_PointToChar procedure: which chunk on this line} { 931 csetup "000\n000\t000\t000\n000" 932 .b.c index text @[expr $ax*10],$ay 933} {10} 934test font-28.9 {Tk_PointToChar procedure: in special chunk} { 935 csetup "000\n000\t000\t000\n000" 936 .b.c index text @[expr $ax*6],$ay 937} {7} 938test font-28.10 {Tk_PointToChar procedure: past all chars in chunk} { 939 csetup "000 0000000" 940 .b.c itemconfig text -width [expr $ax*5] 941 set x [.b.c index text @[expr $ax*5],0] 942 .b.c itemconfig text -width 0 943 set x 944} {3} 945test font-28.11 {Tk_PointToChar procedure: below all chunks} { 946 csetup "000 0000000" 947 .b.c index text @0,1000000 948} {11} 949 950test font-29.1 {Tk_CharBBox procedure: index < 0} { 951 .b.f config -text "000" -underline -1 952} {} 953test font-29.2 {Tk_CharBBox procedure: loop} { 954 .b.f config -text "000\t000\t000\t000" -underline 9 955} {} 956test font-29.3 {Tk_CharBBox procedure: special char} { 957 .b.f config -text "000\t000\t000" -underline 7 958} {} 959test font-29.4 {Tk_CharBBox procedure: normal char} { 960 .b.f config -text "000" -underline 1 961} {} 962test font-29.5 {Tk_CharBBox procedure: right edge of bbox truncated} { 963 .b.f config -text "0 0000" -wrap [expr $ax*4] -under 2 964 .b.f config -wrap 0 965} {} 966test font-29.6 {Tk_CharBBox procedure: bbox pegged to right edge} { 967 .b.f config -text "0 0000" -wrap [expr $ax*4] -under 3 968 .b.f config -wrap 0 969} {} 970 971.b.c bind all <Enter> {lappend x [.b.c index current @%x,%y]} 972 973test font-30.1 {Tk_DistanceToTextLayout procedure: loop once} { 974 csetup "000\n000\n000" 975 set x {} 976 event generate .b.c <Leave> 977 event generate .b.c <Enter> -x 0 -y 0 978 set x 979} {0} 980test font-30.2 {Tk_DistanceToTextLayout procedure: loop multiple} { 981 csetup "000\n000\n000" 982 set x {} 983 event generate .b.c <Leave> 984 event generate .b.c <Enter> -x $ax -y $ay 985 set x 986} {5} 987test font-30.3 {Tk_DistanceToTextLayout procedure: loop to end} { 988 csetup "000\n0\n000" 989 set x {} 990 event generate .b.c <Leave> 991 event generate .b.c <Enter> -x [expr $ax*2] -y $ay 992 set x 993} {} 994test font-30.4 {Tk_DistanceToTextLayout procedure: hit a special char (tab)} { 995 csetup "000\t000\n000" 996 set x {} 997 event generate .b.c <Leave> 998 event generate .b.c <Enter> -x [expr $ax*6] -y 0 999 set x 1000} {3} 1001test font-30.5 {Tk_DistanceToTextLayout procedure: ignore newline} { 1002 csetup "000\n0\n000" 1003 set x {} 1004 event generate .b.c <Leave> 1005 event generate .b.c <Enter> -x [expr $ax*2] -y $ay 1006 set x 1007} {} 1008test font-30.6 {Tk_DistanceToTextLayout procedure: ignore spaces at eol} { 1009 csetup "000\n000 000000000" 1010 .b.c itemconfig text -width [expr $ax*10] 1011 set x {} 1012 event generate .b.c <Leave> 1013 event generate .b.c <Enter> -x [expr $ax*5] -y $ay 1014 .b.c itemconfig text -width 0 1015 set x 1016} {} 1017.b.c itemconfig text -justify center 1018test font-30.7 {Tk_DistanceToTextLayout procedure: on left side} { 1019 csetup "0\n000" 1020 set x {} 1021 event generate .b.c <Leave> 1022 event generate .b.c <Enter> -x 0 -y 0 1023 set x 1024} {} 1025test font-30.8 {Tk_DistanceToTextLayout procedure: on right side} { 1026 csetup "0\n000" 1027 set x {} 1028 event generate .b.c <Leave> 1029 event generate .b.c <Enter> -x [expr $ax*2] -y 0 1030 set x 1031} {} 1032test font-30.9 {Tk_DistanceToTextLayout procedure: inside line} { 1033 csetup "0\n000" 1034 set x {} 1035 event generate .b.c <Leave> 1036 event generate .b.c <Enter> -x $ax -y 0 1037 set x 1038} {0} 1039test font-30.10 {Tk_DistanceToTextLayout procedure: above line} { 1040 csetup "0\n000" 1041 set x {} 1042 event generate .b.c <Leave> 1043 event generate .b.c <Enter> -x 0 -y 0 1044 set x 1045} {} 1046test font-30.11 {Tk_DistanceToTextLayout procedure: below line} { 1047 csetup "000\n0" 1048 set x {} 1049 event generate .b.c <Leave> 1050 event generate .b.c <Enter> -x 0 -y $ay 1051 set x 1052} {} 1053test font-30.12 {Tk_DistanceToTextLayout procedure: in line} { 1054 csetup "0\n000" 1055 set x {} 1056 event generate .b.c <Leave> 1057 event generate .b.c <Enter> -x $ax -y $ay 1058 set x 1059} {3} 1060.b.c itemconfig text -justify left 1061test font-30.13 {Tk_DistanceToTextLayout procedure: exact hit} { 1062 csetup "000" 1063 set x {} 1064 event generate .b.c <Leave> 1065 event generate .b.c <Enter> -x $ax -y 0 1066 set x 1067} {1} 1068 1069test font-31.1 {Tk_IntersectTextLayout procedure: loop once} { 1070 csetup "000\n000\n000" 1071 .b.c find overlapping 0 0 0 0 1072} [.b.c find withtag text] 1073test font-31.2 {Tk_IntersectTextLayout procedure: loop multiple} { 1074 csetup "000\t000\t000" 1075 .b.c find overlapping [expr $ax*10] 0 [expr $ax*10] 0 1076} [.b.c find withtag text] 1077test font-31.3 {Tk_IntersectTextLayout procedure: loop to end} { 1078 csetup "0\n000" 1079 .b.c find overlapping [expr $ax*2] 0 [expr $ax*2] 0 1080} {} 1081test font-31.4 {Tk_IntersectTextLayout procedure: hit a special char (tab)} { 1082 csetup "000\t000" 1083 .b.c find overlapping [expr $ax*6] 0 [expr $ax*6] 0 1084} [.b.c find withtag text] 1085test font-31.5 {Tk_IntersectTextLayout procedure: ignore newlines} { 1086 csetup "000\n0\n000" 1087 .b.c find overlapping $ax $ay $ax $ay 1088} {} 1089test font-31.6 {Tk_IntersectTextLayout procedure: ignore spaces at eol} { 1090 csetup "000\n000 000000000" 1091 .b.c itemconfig text -width [expr $ax*10] 1092 set x [.b.c find overlapping [expr $ax*5] $ay [expr $ax*5] $ay] 1093 .b.c itemconfig text -width 0 1094 set x 1095} {} 1096 1097test font-32.1 {Tk_TextLayoutToPostscript: ensure buffer doesn't overflow} { 1098 # If there were a whole bunch of returns or tabs in a row, then the 1099 # temporary buffer could overflow and write on the stack. 1100 1101 csetup "qwertyuiopasdfghjklzxcvbnm1234qwertyuiopasdfghjklzxcvbnm\n" 1102 .b.c itemconfig text -width 800 1103 .b.c insert text end "qwertyuiopasdfghjklzxcvbnm1234qwertyuiopasdfghjklzxcvbnm\n" 1104 .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" 1105 .b.c insert text end "end" 1106 set x [.b.c postscript] 1107 set i [string first "(qwerty" $x] 1108 string range $x $i [expr {$i + 278}] 1109} {(qwertyuiopasdfghjklzxcvbnm1234qwertyuiopasdfghjklzxcvbnm)] 1110[(qwertyuiopasdfghjklzxcvbnm1234qwertyuiopasdfghjklzxcvbnm)] 1111[()] 1112[()] 1113[()] 1114[()] 1115[()] 1116[()] 1117[()] 1118[()] 1119[()] 1120[()] 1121[()] 1122[()] 1123[()] 1124[()] 1125[()] 1126[()] 1127[()] 1128[()] 1129[()] 1130[()] 1131[()] 1132[()] 1133[()] 1134[()] 1135[()] 1136[()] 1137[()] 1138[()] 1139[()] 1140[()] 1141[(end)] 1142} 1143 1144test font-33.1 {Tk_TextWidth procedure} { 1145} {} 1146 1147test font-34.1 {ConfigAttributesObj procedure: arguments} { 1148 # (Tcl_GetIndexFromObj() != TCL_OK) 1149 setup 1150 list [catch {font create xyz -xyz} msg] $msg 1151} {1 {bad option "-xyz": must be -family, -size, -weight, -slant, -underline, or -overstrike}} 1152test font-34.2 {ConfigAttributesObj procedure: arguments} { 1153 # (objc & 1) 1154 setup 1155 list [catch {font create xyz -family} msg] $msg 1156} {1 {value for "-family" option missing}} 1157foreach p { 1158 {font-34.3 family xyz times} 1159 {font-34.4 size 20 40} 1160 {font-34.5 weight normal bold} 1161 {font-34.6 slant roman italic} 1162 {font-34.7 underline 0 1} 1163 {font-34.8 overstrike 0 1} 1164} { 1165 lassign $p testName opt val1 val2 1166 test $testName "ConfigAttributesObj procedure: $opt" { 1167 setup 1168 set x {} 1169 font create xyz -$opt $val1 1170 lappend x [font config xyz -$opt] 1171 font config xyz -$opt $val2 1172 lappend x [font config xyz -$opt] 1173 } [list $val1 $val2] 1174} 1175foreach p { 1176 {font-34.9 size xyz {expected integer but got "xyz"}} 1177 {font-34.10 weight xyz {bad -weight value "xyz": must be normal, or bold}} 1178 {font-34.11 slant xyz {bad -slant value "xyz": must be roman, or italic}} 1179 {font-34.12 underline xyz {expected boolean value but got "xyz"}} 1180 {font-34.13 overstrike xyz {expected boolean value but got "xyz"}} 1181} { 1182 lassign $p testName opt val result 1183 test $testName "ConfigAttributesObj procedure: $opt" -setup { 1184 setup 1185 } -body { 1186 font create xyz -$opt $val 1187 } -returnCodes error -result $result 1188} 1189 1190test font-35.1 {GetAttributeInfoObj procedure: one attribute} { 1191 # (objPtr != NULL) 1192 setup 1193 font create xyz -family xyz 1194 font config xyz -family 1195} {xyz} 1196 1197test font-36.1 {GetAttributeInfoObj procedure: unknown attribute} { 1198 # (Tcl_GetIndexFromObj() != TCL_OK) 1199 setup 1200 font create xyz 1201 list [catch {font config xyz -xyz} msg] $msg 1202} {1 {bad option "-xyz": must be -family, -size, -weight, -slant, -underline, or -overstrike}} 1203 1204test font-37.1 {GetAttributeInfoObj procedure: all attributes} { 1205 # not (objPtr != NULL) 1206 setup 1207 font create xyz -family xyz 1208 font config xyz 1209} {-family xyz -size 0 -weight normal -slant roman -underline 0 -overstrike 0} 1210set i 4 1211foreach p { 1212 {font-37.2 family xyz xyz} 1213 {font-37.3 size 20 20} 1214 {font-37.4 weight normal normal} 1215 {font-37.5 slant italic italic} 1216 {font-37.6 underline yes 1} 1217 {font-37.7 overstrike false 0} 1218} { 1219 lassign $p testName opt val expected 1220 test $testName "GetAttributeInfo procedure: $opt" -setup { 1221 setup 1222 } -body { 1223 font create xyz -$opt $val 1224 font config xyz -$opt 1225 } -result $expected 1226} 1227 1228# In tests below, one field is set to "xyz" so that font name doesn't 1229# look like a native X font, so that ParseFontNameObj or TkParseXLFD will 1230# be called. 1231 1232setup 1233 1234test font-38.1 {ParseFontNameObj procedure: begins with -} { 1235 lindex [font actual -xyz-times-*-*-*-*-*-*-*-*-*-*-*-*] 1 1236} $times 1237test font-38.2 {ParseFontNameObj procedure: begins with -*} { 1238 lindex [font actual -*-times-xyz-*-*-*-*-*-*-*-*-*-*-*] 1 1239} $times 1240test font-38.3 {ParseFontNameObj procedure: begins with -, doesn't look like list} { 1241 lindex [font actual -xyz-times-*-*-*-*-*-*-*-*-*-*-*-*] 1 1242} $times 1243test font-38.4 {ParseFontNameObj procedure: begins with -, looks like list} { 1244 lindex [font actual {-family times}] 1 1245} $times 1246test font-38.5 {ParseFontNameObj procedure: begins with *} { 1247 lindex [font actual *-times-xyz-*-*-*-*-*-*-*-*-*-*-*] 1 1248} $times 1249test font-38.6 {ParseFontNameObj procedure: begins with *} { 1250 font actual *-times-xyz -family 1251} $times 1252test font-38.7 {ParseFontNameObj procedure: arguments} {noExceed} { 1253 list [catch {font actual "\{xyz"} msg] $msg 1254} [list 1 "font \"{xyz\" doesn't exist"] 1255test font-38.8 {ParseFontNameObj procedure: arguments} {noExceed} { 1256 list [catch {font actual ""} msg] $msg 1257} {1 {font "" doesn't exist}} 1258test font-38.9 {ParseFontNameObj procedure: arguments} { 1259 list [catch {font actual {times 20 xyz xyz}} msg] $msg 1260} {1 {unknown font style "xyz"}} 1261test font-38.10 {ParseFontNameObj procedure: arguments} { 1262 list [catch {font actual {times xyz xyz}} msg] $msg 1263} {1 {expected integer but got "xyz"}} 1264test font-38.12 {ParseFontNameObj procedure: stylelist loop} {unixOrPc} { 1265 lrange [font actual {times 12 bold italic overstrike underline}] 4 end 1266} {-weight bold -slant italic -underline 1 -overstrike 1} 1267test font-38.13 {ParseFontNameObj procedure: stylelist error} { 1268 list [catch {font actual {times 12 bold xyz}} msg] $msg 1269} {1 {unknown font style "xyz"}} 1270test font-38.14 "ParseFontNameObj: options with hyphenated family: bug #2791352" -body { 1271 font actual {-family sans-serif -size 12 -weight bold -slant roman -underline 0 -overstrike 0} 1272} -returnCodes ok -result [font actual {sans-serif 12 bold}] 1273test font-38.15 "ParseFontNameObj: bug #2791352" -body { 1274 font actual {-invalidfont 8 bold} 1275} -returnCodes error -match glob -result {bad option "-invalidfont": *} 1276 1277test font-39.1 {NewChunk procedure: test realloc} { 1278 .b.f config -text "xxx\nxxx\txxx\nxxx\t\t\t" 1279} {} 1280 1281test font-40.1 {TkFontParseXLFD procedure: initial dash} { 1282 font actual -xyz-times-*-*-*-*-*-*-*-*-*-*-*-* -family 1283} $times 1284test font-40.2 {TkFontParseXLFD procedure: no initial dash} { 1285 font actual *-times-*-*-*-*-*-*-*-*-*-*-*-xyz -family 1286} $times 1287test font-40.3 {TkFontParseXLFD procedure: not enough fields} { 1288 font actual -xyz-times-*-*-* -family 1289} $times 1290test font-40.4 {TkFontParseXLFD procedure: all fields unspecified} { 1291 lindex [font actual -xyz-*-*-*-*-*-*-*-*-*-*-*-*-*] 0 1292} {-family} 1293test font-40.5 {TkFontParseXLFD procedure: all fields specified} { 1294 lindex [font actual -foundry-times-weight-slant-setwidth-addstyle-10-10-10-10-spacing-avgwidth-registry-encoding] 1 1295} $times 1296test font-41.1 {TkParseXLFD procedure: arguments} { 1297 # XLFD with bad pointsize: fallback to some system font. 1298 font actual -*-*-*-*-*-*-xyz-*-*-*-*-*-*-* 1299 set x {} 1300} {} 1301test font-42.1 {TkFontParseXLFD procedure: arguments} { 1302 # XLFD with bad pixelsize: fallback to some system font. 1303 font actual -*-*-*-*-*-*-*-xyz-*-*-*-*-*-* 1304 set x {} 1305} {} 1306test font-42.2 {TkFontParseXLFD procedure: pixelsize specified} { 1307 font metrics -xyz-times-*-*-*-*-12-*-*-*-*-*-*-* -linespace 1308 set x {} 1309} {} 1310test font-42.3 {TkFontParseXLFD procedure: weird pixelsize specified} { 1311 font metrics {-xyz-times-*-*-*-*-[ 12.0 0 12.0 0]-*-*-*-*-*-*-*} -linespace 1312 set x {} 1313} {} 1314test font-42.4 {TkFontParseXLFD procedure: pointsize specified} { 1315 font metrics -xyz-times-*-*-*-*-*-120-*-*-*-*-*-* -linespace 1316 set x {} 1317} {} 1318test font-42.5 {TkFontParseXLFD procedure: weird pointsize specified} { 1319 font metrics {-xyz-times-*-*-*-*-*-[ 12.0 0 12.0 0]-*-*-*-*-*-*} -linespace 1320 set x {} 1321} {} 1322 1323test font-43.1 {FieldSpecified procedure: specified vs. non-specified} { 1324 font actual -xyz--*-*-*-*-*-*-*-*-*-*-*-* 1325 font actual -xyz-*-*-*-*-*-*-*-*-*-*-*-*-* 1326 font actual -xyz-?-*-*-*-*-*-*-*-*-*-*-*-* 1327 lindex [font actual -xyz-times-*-*-*-*-*-*-*-*-*-*-*-*] 1 1328} $times 1329 1330set oldscale [tk scaling] 1331tk scaling 0.5 1332test font-44.1 {TkFontGetPixels: size < 0} { 1333 font actual {times -12} -size 1334} {24} 1335test font-44.2 {TkFontGetPoints: size >= 0} {noExceed} { 1336 font actual {times 12} -size 1337} {12} 1338 1339tk scaling $oldscale 1340 1341test font-45.1 {TkFontGetAliasList: no match} { 1342 font actual {snarky 10} -family 1343} [font actual {-size 10} -family] 1344test font-45.3 {TkFontGetAliasList: match} win { 1345 font actual {times 10} -family 1346} {Times New Roman} 1347test font-45.4 {TkFontGetAliasList: match} {unix noExceed} { 1348 # can fail on Unix systems that have a real "times new roman" font 1349 font actual {{times new roman} 10} -family 1350} [font actual {times 10} -family] 1351 1352test font-46.1 {font actual, with character, no option, no --} \ 1353 -body { 1354 font actual {times 10} a 1355 } \ 1356 -match glob \ 1357 -result [list -family [font actual {times 10} -family] -size *\ 1358 -slant roman -underline 0 -overstrike 0] 1359 1360test font-46.2 {font actual, with character introduced by --} \ 1361 -body { 1362 font actual {times 10} -- - 1363 } \ 1364 -match glob \ 1365 -result [list -family [font actual {times 10} -family] -size *\ 1366 -slant roman -underline 0 -overstrike 0] 1367 1368test font-46.3 {font actual, with character and option} { 1369 font actual {times 10} -family a 1370} [font actual {times 10} -family] 1371 1372test font-46.4 {font actual, with character, option and --} { 1373 font actual {times 10} -family -- - 1374} [font actual {times 10} -family] 1375 1376test font-46.5 {font actual, too many chars} { 1377 list [catch { 1378 font actual {times 10} 123456789012345678901234567890123456789012345678901 1379 } result] $result 1380} {1 {expected a single character but got "1234567890123456789012345678901234567..."}} 1381 1382setup 1383 1384destroy .b 1385 1386# cleanup 1387cleanupTests 1388return 1389