summaryrefslogtreecommitdiffstats
path: root/library/xmfbox.tcl
blob: 0cbf2513f02e44eadcf4a292816e64e624f32bd8 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
# xmfbox.tcl --
#
#	Implements the "Motif" style file selection dialog for the
#	Unix platform. This implementation is used only if the
#	"::tk_strictMotif" flag is set.
#
# Copyright (c) 1996 Sun Microsystems, Inc.
# Copyright (c) 1998-2000 Scriptics Corporation
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

namespace eval ::tk::dialog {}
namespace eval ::tk::dialog::file {}


# ::tk::MotifFDialog --
#
#	Implements a file dialog similar to the standard Motif file
#	selection box.
#
# Arguments:
#	type		"open" or "save"
#	args		Options parsed by the procedure.
#
# Results:
#	When -multiple is set to 0, this returns the absolute pathname
#	of the selected file. (NOTE: This is not the same as a single
#	element list.)
# 
#	When -multiple is set to > 0, this returns a Tcl list of absolute
#       pathnames. The argument for -multiple is ignored, but for consistency
#       with Windows it defines the maximum amount of memory to allocate for
#       the returned filenames.

proc ::tk::MotifFDialog {type args} {
    variable ::tk::Priv
    set dataName __tk_filedialog
    upvar ::tk::dialog::file::$dataName data

    set w [MotifFDialog_Create $dataName $type $args]

    # Set a grab and claim the focus too.

    ::tk::SetFocusGrab $w $data(sEnt)
    $data(sEnt) selection range 0 end

    # Wait for the user to respond, then restore the focus and
    # return the index of the selected button.  Restore the focus
    # before deleting the window, since otherwise the window manager
    # may take the focus away so we can't redirect it.  Finally,
    # restore any grab that was in effect.

    vwait ::tk::Priv(selectFilePath)
    set result $Priv(selectFilePath)
    ::tk::RestoreFocusGrab $w $data(sEnt) withdraw

    return $result
}

# ::tk::MotifFDialog_Create --
#
#	Creates the Motif file dialog (if it doesn't exist yet) and
#	initialize the internal data structure associated with the
#	dialog.
#
#	This procedure is used by ::tk::MotifFDialog to create the
#	dialog. It's also used by the test suite to test the Motif
#	file dialog implementation. User code shouldn't call this
#	procedure directly.
#
# Arguments:
#	dataName	Name of the global "data" array for the file dialog.
#	type		"Save" or "Open"
#	argList		Options parsed by the procedure.
#
# Results:
#	Pathname of the file dialog.

proc ::tk::MotifFDialog_Create {dataName type argList} {
    upvar ::tk::dialog::file::$dataName data

    MotifFDialog_Config $dataName $type $argList

    if {$data(-parent) eq "."} {
        set w .$dataName
    } else {
        set w $data(-parent).$dataName
    }

    # (re)create the dialog box if necessary
    #
    if {![winfo exists $w]} {
	MotifFDialog_BuildUI $w
    } elseif {[winfo class $w] ne "TkMotifFDialog"} {
	destroy $w
	MotifFDialog_BuildUI $w
    } else {
	set data(fEnt) $w.top.f1.ent
	set data(dList) $w.top.f2.a.l
	set data(fList) $w.top.f2.b.l
	set data(sEnt) $w.top.f3.ent
	set data(okBtn) $w.bot.ok
	set data(filterBtn) $w.bot.filter
	set data(cancelBtn) $w.bot.cancel
    }
    MotifFDialog_SetListMode $w

    # Dialog boxes should be transient with respect to their parent,
    # so that they will always stay on top of their parent window.  However,
    # some window managers will create the window as withdrawn if the parent
    # window is withdrawn or iconified.  Combined with the grab we put on the
    # window, this can hang the entire application.  Therefore we only make
    # the dialog transient if the parent is viewable.

    if {[winfo viewable [winfo toplevel $data(-parent)]] } {
	wm transient $w $data(-parent)
    }

    MotifFDialog_FileTypes $w
    MotifFDialog_Update $w

    # Withdraw the window, then update all the geometry information
    # so we know how big it wants to be, then center the window in the
    # display (Motif style) and de-iconify it.

    ::tk::PlaceWindow $w
    wm title $w $data(-title)

    return $w
}

# ::tk::MotifFDialog_FileTypes --
#
#	Checks the -filetypes option. If present this adds a list of radio-
#	buttons to pick the file types from.
#
# Arguments:
#	w		Pathname of the tk_get*File dialogue.
#
# Results:
#	none

proc ::tk::MotifFDialog_FileTypes {w} {
    upvar ::tk::dialog::file::[winfo name $w] data

    set f $w.top.f3.types
    destroy $f

    # No file types: use "*" as the filter and display no radio-buttons
    if {$data(-filetypes) eq ""} {
	set data(filter) *
	return
    }

    # The filetypes radiobuttons
    # set data(fileType) $data(-defaulttype)
    # Default type to first entry
    set initialTypeName [lindex $data(-filetypes) 0 0]
    if {$data(-typevariable) ne ""} {
	upvar #0 $data(-typevariable) typeVariable
	if {[info exist typeVariable]} {
	    set initialTypeName $typeVariable
	}
    }
    set ix 0
    set data(fileType) 0
    foreach fltr $data(-filetypes) {
	set fname [lindex $fltr 0]
	if {[string first $initialTypeName $fname] == 0} {
	    set data(fileType) $ix
	    break
	}
	incr ix
    }

    MotifFDialog_SetFilter $w [lindex $data(-filetypes) $data(fileType)]

    #don't produce radiobuttons for only one filetype
    if {[llength $data(-filetypes)] == 1} {
	return
    }

    frame $f
    set cnt 0
    if {$data(-filetypes) ne {}} {
	foreach type $data(-filetypes) {
	    set title  [lindex [lindex $type 0] 0]
	    set filter [lindex $type 1]
	    radiobutton $f.b$cnt \
		-text $title \
		-variable ::tk::dialog::file::[winfo name $w](fileType) \
		-value $cnt \
		-command [list tk::MotifFDialog_SetFilter $w $type]
	    pack $f.b$cnt -side left
	    incr cnt
	}
    }
    $f.b$data(fileType) invoke

    pack $f -side bottom -fill both

    return
}

# This proc gets called whenever data(filter) is set
#
proc ::tk::MotifFDialog_SetFilter {w type} {
    upvar ::tk::dialog::file::[winfo name $w] data
    variable ::tk::Priv

    set data(filter) [lindex $type 1]
    set Priv(selectFileType) [lindex [lindex $type 0] 0]

    MotifFDialog_Update $w
}

# ::tk::MotifFDialog_Config --
#
#	Iterates over the optional arguments to determine the option
#	values for the Motif file dialog; gives default values to
#	unspecified options.
#
# Arguments:
#	dataName	The name of the global variable in which
#			data for the file dialog is stored.
#	type		"Save" or "Open"
#	argList		Options parsed by the procedure.

proc ::tk::MotifFDialog_Config {dataName type argList} {
    upvar ::tk::dialog::file::$dataName data

    set data(type) $type

    # 1: the configuration specs
    #
    set specs {
	{-defaultextension "" "" ""}
	{-filetypes "" "" ""}
	{-initialdir "" "" ""}
	{-initialfile "" "" ""}
	{-parent "" "" "."}
	{-title "" "" ""}
	{-typevariable "" "" ""}
    }
    if {$type eq "open"} {
	lappend specs {-multiple "" "" "0"}
    }
    if {$type eq "save"} {
	lappend specs {-confirmoverwrite "" "" "1"}
    }

    set data(-multiple) 0
    set data(-confirmoverwrite) 1
    # 2: default values depending on the type of the dialog
    #
    if {![info exists data(selectPath)]} {
	# first time the dialog has been popped up
	set data(selectPath) [pwd]
	set data(selectFile) ""
    }

    # 3: parse the arguments
    #
    tclParseConfigSpec ::tk::dialog::file::$dataName $specs "" $argList

    if {$data(-title) eq ""} {
	if {$type eq "open"} {
	    if {$data(-multiple) != 0} {
		set data(-title) "[mc {Open Multiple Files}]"
	    } else {
		set data(-title) [mc "Open"]
	    }
	} else {
	    set data(-title) [mc "Save As"]
	}
    }

    # 4: set the default directory and selection according to the -initial
    #    settings
    #
    if {$data(-initialdir) ne ""} {
	if {[file isdirectory $data(-initialdir)]} {
	    set data(selectPath) [lindex [glob $data(-initialdir)] 0]
	} else {
	    set data(selectPath) [pwd]
	}

	# Convert the initialdir to an absolute path name.

	set old [pwd]
	cd $data(selectPath)
	set data(selectPath) [pwd]
	cd $old
    }
    set data(selectFile) $data(-initialfile)

    # 5. Parse the -filetypes option. It is not used by the motif
    #    file dialog, but we check for validity of the value to make sure
    #    the application code also runs fine with the TK file dialog.
    #
    set data(-filetypes) [::tk::FDGetFileTypes $data(-filetypes)]

    if {![info exists data(filter)]} {
	set data(filter) *
    }
    if {![winfo exists $data(-parent)]} {
	error "bad window path name \"$data(-parent)\""
    }
}

# ::tk::MotifFDialog_BuildUI --
#
#	Builds the UI components of the Motif file dialog.
#
# Arguments:
# 	w		Pathname of the dialog to build.
#
# Results:
# 	None.

proc ::tk::MotifFDialog_BuildUI {w} {
    set dataName [lindex [split $w .] end]
    upvar ::tk::dialog::file::$dataName data

    # Create the dialog toplevel and internal frames.
    #
    toplevel $w -class TkMotifFDialog
    set top [frame $w.top -relief raised -bd 1]
    set bot [frame $w.bot -relief raised -bd 1]

    pack $w.bot -side bottom -fill x
    pack $w.top -side top -expand yes -fill both

    set f1 [frame $top.f1]
    set f2 [frame $top.f2]
    set f3 [frame $top.f3]

    pack $f1 -side top    -fill x
    pack $f3 -side bottom -fill x
    pack $f2 -expand yes -fill both

    set f2a [frame $f2.a]
    set f2b [frame $f2.b]

    grid $f2a -row 0 -column 0 -rowspan 1 -columnspan 1 -padx 4 -pady 4 \
	-sticky news
    grid $f2b -row 0 -column 1 -rowspan 1 -columnspan 1 -padx 4 -pady 4 \
	-sticky news
    grid rowconfigure $f2 0    -minsize 0   -weight 1
    grid columnconfigure $f2 0 -minsize 0   -weight 1
    grid columnconfigure $f2 1 -minsize 150 -weight 2

    # The Filter box
    #
    bind [::tk::AmpWidget label $f1.lab -text [mc "Fil&ter:"] -anchor w] \
	<<AltUnderlined>> [list focus $f1.ent]
    entry $f1.ent
    pack $f1.lab -side top -fill x -padx 6 -pady 4
    pack $f1.ent -side top -fill x -padx 4 -pady 0
    set data(fEnt) $f1.ent

    # The file and directory lists
    #
    set data(dList) [MotifFDialog_MakeSList $w $f2a \
	    [mc "&Directory:"] DList]
    set data(fList) [MotifFDialog_MakeSList $w $f2b \
	    [mc "Fi&les:"]     FList]

    # The Selection box
    #
    bind [::tk::AmpWidget label $f3.lab -text [mc "&Selection:"] -anchor w] \
	<<AltUnderlined>> [list focus $f3.ent]
    entry $f3.ent
    pack $f3.lab -side top -fill x -padx 6 -pady 0
    pack $f3.ent -side top -fill x -padx 4 -pady 4
    set data(sEnt) $f3.ent

    # The buttons
    #
    set maxWidth [::tk::mcmaxamp &OK &Filter &Cancel]
    set maxWidth [expr {$maxWidth<6?6:$maxWidth}]
    set data(okBtn) [::tk::AmpWidget button $bot.ok -text [mc "&OK"] \
	    -width $maxWidth \
	    -command [list tk::MotifFDialog_OkCmd $w]]
    set data(filterBtn) [::tk::AmpWidget button $bot.filter -text [mc "&Filter"] \
	    -width $maxWidth \
	    -command [list tk::MotifFDialog_FilterCmd $w]]
    set data(cancelBtn) [::tk::AmpWidget button $bot.cancel -text [mc "&Cancel"] \
	    -width $maxWidth \
	    -command [list tk::MotifFDialog_CancelCmd $w]]

    pack $bot.ok $bot.filter $bot.cancel -padx 10 -pady 10 -expand yes \
	-side left

    # Create the bindings:
    #
    bind $w <Alt-Key> [list ::tk::AltKeyInDialog $w %A]

    bind $data(fEnt) <Return> [list tk::MotifFDialog_ActivateFEnt $w]
    bind $data(sEnt) <Return> [list tk::MotifFDialog_ActivateSEnt $w]
    bind $w <Escape> [list tk::MotifFDialog_CancelCmd $w]
    bind $w.bot <Destroy> {set ::tk::Priv(selectFilePath) {}}

    wm protocol $w WM_DELETE_WINDOW [list tk::MotifFDialog_CancelCmd $w]
}

proc ::tk::MotifFDialog_SetListMode {w} {
    upvar ::tk::dialog::file::[winfo name $w] data

    if {$data(-multiple) != 0} {
	set selectmode extended
    } else {
	set selectmode browse
    }
    set f $w.top.f2.b
    $f.l configure -selectmode $selectmode
}

# ::tk::MotifFDialog_MakeSList --
#
#	Create a scrolled-listbox and set the keyboard accelerator
#	bindings so that the list selection follows what the user
#	types.
#
# Arguments:
#	w		Pathname of the dialog box.
#	f		Frame widget inside which to create the scrolled
#			listbox. This frame widget already exists.
#	label		The string to display on top of the listbox.
#	under		Sets the -under option of the label.
#	cmdPrefix	Specifies procedures to call when the listbox is
#			browsed or activated.

proc ::tk::MotifFDialog_MakeSList {w f label cmdPrefix} {
    bind [::tk::AmpWidget label $f.lab -text $label -anchor w] \
	<<AltUnderlined>> [list focus $f.l]
    listbox $f.l -width 12 -height 5 -exportselection 0\
	-xscrollcommand [list $f.h set]	-yscrollcommand [list $f.v set]
    scrollbar $f.v -orient vertical   -takefocus 0 -command [list $f.l yview]
    scrollbar $f.h -orient horizontal -takefocus 0 -command [list $f.l xview]
    grid $f.lab -row 0 -column 0 -sticky news -rowspan 1 -columnspan 2 \
	-padx 2 -pady 2
    grid $f.l -row 1 -column 0 -rowspan 1 -columnspan 1 -sticky news
    grid $f.v -row 1 -column 1 -rowspan 1 -columnspan 1 -sticky news
    grid $f.h -row 2 -column 0 -rowspan 1 -columnspan 1 -sticky news

    grid rowconfigure    $f 0 -weight 0 -minsize 0
    grid rowconfigure    $f 1 -weight 1 -minsize 0
    grid columnconfigure $f 0 -weight 1 -minsize 0

    # bindings for the listboxes
    #
    set list $f.l
    bind $list <<ListboxSelect>> [list tk::MotifFDialog_Browse$cmdPrefix $w]
    bind $list <Double-ButtonRelease-1> \
	    [list tk::MotifFDialog_Activate$cmdPrefix $w]
    bind $list <Return>	"tk::MotifFDialog_Browse$cmdPrefix [list $w]; \
	    tk::MotifFDialog_Activate$cmdPrefix [list $w]"

    bindtags $list [list Listbox $list [winfo toplevel $list] all]
    ListBoxKeyAccel_Set $list

    return $f.l
}

# ::tk::MotifFDialog_InterpFilter --
#
#	Interpret the string in the filter entry into two components:
#	the directory and the pattern. If the string is a relative
#	pathname, give a warning to the user and restore the pattern
#	to original.
#
# Arguments:
#	w		pathname of the dialog box.
#
# Results:
# 	A list of two elements. The first element is the directory
# 	specified # by the filter. The second element is the filter
# 	pattern itself.

proc ::tk::MotifFDialog_InterpFilter {w} {
    upvar ::tk::dialog::file::[winfo name $w] data

    set text [string trim [$data(fEnt) get]]

    # Perform tilde substitution
    #
    set badTilde 0
    if {[string index $text 0] eq "~"} {
	set list [file split $text]
	set tilde [lindex $list 0]
	if {[catch {set tilde [glob $tilde]}]} {
	    set badTilde 1
	} else {
	    set text [eval file join [concat $tilde [lrange $list 1 end]]]
	}
    }

    # If the string is a relative pathname, combine it
    # with the current selectPath.

    set relative 0
    if {[file pathtype $text] eq "relative"} {
	set relative 1
    } elseif {$badTilde} {
	set relative 1	
    }

    if {$relative} {
	tk_messageBox -icon warning -type ok \
		-message "\"$text\" must be an absolute pathname"

	$data(fEnt) delete 0 end
	$data(fEnt) insert 0 [::tk::dialog::file::JoinFile $data(selectPath) \
		$data(filter)]

	return [list $data(selectPath) $data(filter)]
    }

    set resolved [::tk::dialog::file::JoinFile [file dirname $text] [file tail $text]]

    if {[file isdirectory $resolved]} {
	set dir $resolved
	set fil $data(filter)
    } else {
	set dir [file dirname $resolved]
	set fil [file tail    $resolved]
    }

    return [list $dir $fil]
}

# ::tk::MotifFDialog_Update
#
#	Load the files and synchronize the "filter" and "selection" fields
#	boxes.
#
# Arguments:
# 	w 		pathname of the dialog box.
#
# Results:
#	None.

proc ::tk::MotifFDialog_Update {w} {
    upvar ::tk::dialog::file::[winfo name $w] data

    $data(fEnt) delete 0 end
    $data(fEnt) insert 0 \
            [::tk::dialog::file::JoinFile $data(selectPath) $data(filter)]
    $data(sEnt) delete 0 end
    $data(sEnt) insert 0 [::tk::dialog::file::JoinFile $data(selectPath) \
	    $data(selectFile)]
 
    MotifFDialog_LoadFiles $w
}

# ::tk::MotifFDialog_LoadFiles --
#
#	Loads the files and directories into the two listboxes according
#	to the filter setting.
#
# Arguments:
# 	w 		pathname of the dialog box.
#
# Results:
#	None.

proc ::tk::MotifFDialog_LoadFiles {w} {
    upvar ::tk::dialog::file::[winfo name $w] data

    $data(dList) delete 0 end
    $data(fList) delete 0 end

    set appPWD [pwd]
    if {[catch {cd $data(selectPath)}]} {
	cd $appPWD

	$data(dList) insert end ".."
	return
    }

    # Make the dir and file lists
    #
    # For speed we only have one glob, which reduces the file system
    # calls (good for slow NFS networks).
    #
    # We also do two smaller sorts (files + dirs) instead of one large sort,
    # which gives a small speed increase.
    #
    set top 0
    set dlist ""
    set flist ""
    foreach f [glob -nocomplain .* *] {
	if {[file isdir ./$f]} {
	    lappend dlist $f
	} else {
            foreach pat $data(filter) {
                if {[string match $pat $f]} {
		    if {[string match .* $f]} {
			incr top
		    }
		    lappend flist $f
                    break
		}
            }
	}
    }
    eval [list $data(dList) insert end] [lsort -dictionary $dlist]
    eval [list $data(fList) insert end] [lsort -dictionary $flist]

    # The user probably doesn't want to see the . files. We adjust the view
    # so that the listbox displays all the non-dot files
    $data(fList) yview $top

    cd $appPWD
}

# ::tk::MotifFDialog_BrowseDList --
#
#	This procedure is called when the directory list is browsed
#	(clicked-over) by the user.
#
# Arguments:
# 	w		The pathname of the dialog box.
#
# Results:
#	None.	

proc ::tk::MotifFDialog_BrowseDList {w} {
    upvar ::tk::dialog::file::[winfo name $w] data

    focus $data(dList)
    if {[$data(dList) curselection] eq ""} {
	return
    }
    set subdir [$data(dList) get [$data(dList) curselection]]
    if {$subdir eq ""} {
	return
    }

    $data(fList) selection clear 0 end

    set list [MotifFDialog_InterpFilter $w]
    set data(filter) [lindex $list 1]

    switch -- $subdir {
	. {
	    set newSpec [::tk::dialog::file::JoinFile $data(selectPath) $data(filter)]
	}
	.. {
	    set newSpec [::tk::dialog::file::JoinFile [file dirname $data(selectPath)] \
		$data(filter)]
	}
	default {
	    set newSpec [::tk::dialog::file::JoinFile [::tk::dialog::file::JoinFile \
		    $data(selectPath) $subdir] $data(filter)]
	}
    }

    $data(fEnt) delete 0 end
    $data(fEnt) insert 0 $newSpec
}

# ::tk::MotifFDialog_ActivateDList --
#
#	This procedure is called when the directory list is activated
#	(double-clicked) by the user.
#
# Arguments:
# 	w		The pathname of the dialog box.
#
# Results:
#	None.	

proc ::tk::MotifFDialog_ActivateDList {w} {
    upvar ::tk::dialog::file::[winfo name $w] data

    if {[$data(dList) curselection] eq ""} {
	return
    }
    set subdir [$data(dList) get [$data(dList) curselection]]
    if {$subdir eq ""} {
	return
    }

    $data(fList) selection clear 0 end

    switch -- $subdir {
	. {
	    set newDir $data(selectPath)
	}
	.. {
	    set newDir [file dirname $data(selectPath)]
	}
	default {
	    set newDir [::tk::dialog::file::JoinFile $data(selectPath) $subdir]
	}
    }

    set data(selectPath) $newDir
    MotifFDialog_Update $w

    if {$subdir ne ".."} {
	$data(dList) selection set 0
	$data(dList) activate 0
    } else {
	$data(dList) selection set 1
	$data(dList) activate 1
    }
}

# ::tk::MotifFDialog_BrowseFList --
#
#	This procedure is called when the file list is browsed
#	(clicked-over) by the user.
#
# Arguments:
# 	w		The pathname of the dialog box.
#
# Results:
#	None.	

proc ::tk::MotifFDialog_BrowseFList {w} {
    upvar ::tk::dialog::file::[winfo name $w] data

    focus $data(fList)
    set data(selectFile) ""
    foreach item [$data(fList) curselection] {
	lappend data(selectFile) [$data(fList) get $item]
    }
    if {[llength $data(selectFile)] == 0} {
	return
    }

    $data(dList) selection clear 0 end

    $data(fEnt) delete 0 end
    $data(fEnt) insert 0 [::tk::dialog::file::JoinFile $data(selectPath) \
	    $data(filter)]
    $data(fEnt) xview end
 
    # if it's a multiple selection box, just put in the filenames 
    # otherwise put in the full path as usual 
    $data(sEnt) delete 0 end
    if {$data(-multiple) != 0} {
	$data(sEnt) insert 0 $data(selectFile)
    } else {
	$data(sEnt) insert 0 [::tk::dialog::file::JoinFile $data(selectPath) \
		[lindex $data(selectFile) 0]]
    }
    $data(sEnt) xview end
}

# ::tk::MotifFDialog_ActivateFList --
#
#	This procedure is called when the file list is activated
#	(double-clicked) by the user.
#
# Arguments:
# 	w		The pathname of the dialog box.
#
# Results:
#	None.	

proc ::tk::MotifFDialog_ActivateFList {w} {
    upvar ::tk::dialog::file::[winfo name $w] data

    if {[$data(fList) curselection] eq ""} {
	return
    }
    set data(selectFile) [$data(fList) get [$data(fList) curselection]]
    if {$data(selectFile) eq ""} {
	return
    } else {
	MotifFDialog_ActivateSEnt $w
    }
}

# ::tk::MotifFDialog_ActivateFEnt --
#
#	This procedure is called when the user presses Return inside
#	the "filter" entry. It updates the dialog according to the
#	text inside the filter entry.
#
# Arguments:
# 	w		The pathname of the dialog box.
#
# Results:
#	None.	

proc ::tk::MotifFDialog_ActivateFEnt {w} {
    upvar ::tk::dialog::file::[winfo name $w] data

    set list [MotifFDialog_InterpFilter $w]
    set data(selectPath) [lindex $list 0]
    set data(filter)    [lindex $list 1]

    MotifFDialog_Update $w
}

# ::tk::MotifFDialog_ActivateSEnt --
#
#	This procedure is called when the user presses Return inside
#	the "selection" entry. It sets the ::tk::Priv(selectFilePath) 
#	variable so that the vwait loop in tk::MotifFDialog will be
#	terminated.
#
# Arguments:
# 	w		The pathname of the dialog box.
#
# Results:
#	None.	

proc ::tk::MotifFDialog_ActivateSEnt {w} {
    variable ::tk::Priv
    upvar ::tk::dialog::file::[winfo name $w] data

    set selectFilePath [string trim [$data(sEnt) get]]

    if {$selectFilePath eq ""} {
	MotifFDialog_FilterCmd $w
	return
    }

    if {$data(-multiple) == 0} {
	set selectFilePath [list $selectFilePath]
    }

    if {[file isdirectory [lindex $selectFilePath 0]]} {
	set data(selectPath) [lindex [glob $selectFilePath] 0]
	set data(selectFile) ""
	MotifFDialog_Update $w
	return
    }

    set newFileList ""
    foreach item $selectFilePath {
	if {[file pathtype $item] ne "absolute"} {
	    set item [file join $data(selectPath) $item]
	} elseif {![file exists [file dirname $item]]} {
	    tk_messageBox -icon warning -type ok \
		    -message [mc {Directory "%1$s" does not exist.} \
		    [file dirname $item]]
	    return
	}

	if {![file exists $item]} {
	    if {$data(type) eq "open"} {
		tk_messageBox -icon warning -type ok \
			-message [mc {File "%1$s" does not exist.} $item]
		return
	    }
	} elseif {$data(type) eq "save" && $data(-confirmoverwrite)} {
	    set message [format %s%s \
		    [mc "File \"%1\$s\" already exists.\n\n" $selectFilePath] \
		    [mc {Replace existing file?}]]
	    set answer [tk_messageBox -icon warning -type yesno \
		    -message $message]
	    if {$answer eq "no"} {
		return
	    }
	}

	lappend newFileList $item
    }

    # Return selected filter
    if {[info exists data(-typevariable)] && $data(-typevariable) ne ""
	    && [info exists data(-filetypes)] && $data(-filetypes) ne ""} {
	upvar #0 $data(-typevariable) typeVariable
	set typeVariable [lindex $data(-filetypes) $data(fileType) 0]
    }

    if {$data(-multiple) != 0} {
	set Priv(selectFilePath) $newFileList
    } else {
	set Priv(selectFilePath) [lindex $newFileList 0]
    }

    # Set selectFile and selectPath to first item in list
    set Priv(selectFile)     [file tail    [lindex $newFileList 0]]
    set Priv(selectPath)     [file dirname [lindex $newFileList 0]]
}


proc ::tk::MotifFDialog_OkCmd {w} {
    upvar ::tk::dialog::file::[winfo name $w] data

    MotifFDialog_ActivateSEnt $w
}

proc ::tk::MotifFDialog_FilterCmd {w} {
    upvar ::tk::dialog::file::[winfo name $w] data

    MotifFDialog_ActivateFEnt $w
}

proc ::tk::MotifFDialog_CancelCmd {w} {
    variable ::tk::Priv

    set Priv(selectFilePath) ""
    set Priv(selectFile)     ""
    set Priv(selectPath)     ""
}

proc ::tk::ListBoxKeyAccel_Set {w} {
    bind Listbox <Any-KeyPress> ""
    bind $w <Destroy> [list tk::ListBoxKeyAccel_Unset $w]
    bind $w <Any-KeyPress> [list tk::ListBoxKeyAccel_Key $w %A]
}

proc ::tk::ListBoxKeyAccel_Unset {w} {
    variable ::tk::Priv

    catch {after cancel $Priv(lbAccel,$w,afterId)}
    unset -nocomplain Priv(lbAccel,$w) Priv(lbAccel,$w,afterId)
}

# ::tk::ListBoxKeyAccel_Key--
#
#	This procedure maintains a list of recently entered keystrokes
#	over a listbox widget. It arranges an idle event to move the
#	selection of the listbox to the entry that begins with the
#	keystrokes.
#
# Arguments:
# 	w		The pathname of the listbox.
#	key		The key which the user just pressed.
#
# Results:
#	None.	

proc ::tk::ListBoxKeyAccel_Key {w key} {
    variable ::tk::Priv

    if { $key eq "" } {
	return
    }
    append Priv(lbAccel,$w) $key
    ListBoxKeyAccel_Goto $w $Priv(lbAccel,$w)
    catch {
	after cancel $Priv(lbAccel,$w,afterId)
    }
    set Priv(lbAccel,$w,afterId) [after 500 \
	    [list tk::ListBoxKeyAccel_Reset $w]]
}

proc ::tk::ListBoxKeyAccel_Goto {w string} {
    variable ::tk::Priv

    set string [string tolower $string]
    set end [$w index end]
    set theIndex -1

    for {set i 0} {$i < $end} {incr i} {
	set item [string tolower [$w get $i]]
	if {[string compare $string $item] >= 0} {
	    set theIndex $i
	}
	if {[string compare $string $item] <= 0} {
	    set theIndex $i
	    break
	}
    }

    if {$theIndex >= 0} {
	$w selection clear 0 end
	$w selection set $theIndex $theIndex
	$w activate $theIndex
	$w see $theIndex
	event generate $w <<ListboxSelect>>
    }
}

proc ::tk::ListBoxKeyAccel_Reset {w} {
    variable ::tk::Priv

    unset -nocomplain Priv(lbAccel,$w)
}

proc ::tk_getFileType {} {
    variable ::tk::Priv

    return $Priv(selectFileType)
}

/span> int flags, Tcl_EncodingState*statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); static int UtfToUcs2beProc(ClientData clientData, const char*src, int srcLen, int flags, Tcl_EncodingState*statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); #endif /* *------------------------------------------------------------------------- * * FontPkgCleanup -- * * This function is called when an application is created. It initializes * all the structures that are used by the platform-dependent code on a * per application basis. * * Results: * None. * * Side effects: * Releases thread-specific resources used by font pkg. * *------------------------------------------------------------------------- */ static void FontPkgCleanup( ClientData clientData) { ThreadSpecificData *tsdPtr = Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData)); if (tsdPtr->controlFamily.encoding != NULL) { FontFamily *familyPtr = &tsdPtr->controlFamily; int i; Tcl_FreeEncoding(familyPtr->encoding); for (i = 0; i < FONTMAP_PAGES; i++) { if (familyPtr->fontMap[i] != NULL) { ckfree(familyPtr->fontMap[i]); } } tsdPtr->controlFamily.encoding = NULL; } } /* *------------------------------------------------------------------------- * * TkpFontPkgInit -- * * This function is called when an application is created. It initializes * all the structures that are used by the platform-dependent code on a * per application basis. * * Results: * None. * * Side effects: * None. * *------------------------------------------------------------------------- */ void TkpFontPkgInit( TkMainInfo *mainPtr) /* The application being created. */ { ThreadSpecificData *tsdPtr = Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData)); Tcl_EncodingType type; SubFont dummy; int i; if (tsdPtr->controlFamily.encoding == NULL) { type.encodingName = "X11ControlChars"; type.toUtfProc = ControlUtfProc; type.fromUtfProc = ControlUtfProc; type.freeProc = NULL; type.clientData = NULL; type.nullSize = 0; tsdPtr->controlFamily.refCount = 2; tsdPtr->controlFamily.encoding = Tcl_CreateEncoding(&type); tsdPtr->controlFamily.isTwoByteFont = 0; dummy.familyPtr = &tsdPtr->controlFamily; dummy.fontMap = tsdPtr->controlFamily.fontMap; for (i = 0x00; i < 0x20; i++) { FontMapInsert(&dummy, i); FontMapInsert(&dummy, i + 0x80); } #ifndef WORDS_BIGENDIAN /* * UCS-2BE is unicode (UCS-2) in big-endian format. Define this if * native order isn't BE. It is used in iso10646 fonts. */ type.encodingName = "ucs-2be"; type.toUtfProc = Ucs2beToUtfProc; type.fromUtfProc = UtfToUcs2beProc; type.freeProc = NULL; type.clientData = NULL; type.nullSize = 2; Tcl_CreateEncoding(&type); #endif Tcl_CreateThreadExitHandler(FontPkgCleanup, NULL); } } /* *------------------------------------------------------------------------- * * ControlUtfProc -- * * Convert from UTF-8 into the ASCII expansion of a control character. * * Results: * Returns TCL_OK if conversion was successful. * * Side effects: * None. * *------------------------------------------------------------------------- */ static int ControlUtfProc( ClientData clientData, /* Not used. */ const char *src, /* Source string in UTF-8. */ int srcLen, /* Source string length in bytes. */ int flags, /* Conversion control flags. */ Tcl_EncodingState *statePtr,/* Place for conversion routine to store state * information used during a piecewise * conversion. Contents of statePtr are * initialized and/or reset by conversion * routine under control of flags argument. */ char *dst, /* Output buffer in which converted string is * stored. */ int dstLen, /* The maximum length of output buffer in * bytes. */ int *srcReadPtr, /* Filled with the number of bytes from the * source string that were converted. This may * be less than the original source length if * there was a problem converting some source * characters. */ int *dstWrotePtr, /* Filled with the number of bytes that were * stored in the output buffer as a result of * the conversion. */ int *dstCharsPtr) /* Filled with the number of characters that * correspond to the bytes stored in the * output buffer. */ { const char *srcStart, *srcEnd; char *dstStart, *dstEnd; Tcl_UniChar ch; int result; static char hexChars[] = "0123456789abcdef"; static char mapChars[] = { 0, 0, 0, 0, 0, 0, 0, 'a', 'b', 't', 'n', 'v', 'f', 'r' }; result = TCL_OK; srcStart = src; srcEnd = src + srcLen; dstStart = dst; dstEnd = dst + dstLen - 6; for ( ; src < srcEnd; ) { if (dst > dstEnd) { result = TCL_CONVERT_NOSPACE; break; } src += Tcl_UtfToUniChar(src, &ch); dst[0] = '\\'; if ((ch < sizeof(mapChars)) && (mapChars[ch] != 0)) { dst[1] = mapChars[ch]; dst += 2; } else if (ch < 256) { dst[1] = 'x'; dst[2] = hexChars[(ch >> 4) & 0xf]; dst[3] = hexChars[ch & 0xf]; dst += 4; } else { dst[1] = 'u'; dst[2] = hexChars[(ch >> 12) & 0xf]; dst[3] = hexChars[(ch >> 8) & 0xf]; dst[4] = hexChars[(ch >> 4) & 0xf]; dst[5] = hexChars[ch & 0xf]; dst += 6; } } *srcReadPtr = src - srcStart; *dstWrotePtr = dst - dstStart; *dstCharsPtr = dst - dstStart; return result; } #ifndef WORDS_BIGENDIAN /* *------------------------------------------------------------------------- * * Ucs2beToUtfProc -- * * Convert from UCS-2BE (big-endian 16-bit Unicode) to UTF-8. * This is only defined on LE machines. * * Results: * Returns TCL_OK if conversion was successful. * * Side effects: * None. * *------------------------------------------------------------------------- */ static int Ucs2beToUtfProc( ClientData clientData, /* Not used. */ const char *src, /* Source string in Unicode. */ int srcLen, /* Source string length in bytes. */ int flags, /* Conversion control flags. */ Tcl_EncodingState *statePtr,/* Place for conversion routine to store state * information used during a piecewise * conversion. Contents of statePtr are * initialized and/or reset by conversion * routine under control of flags argument. */ char *dst, /* Output buffer in which converted string is * stored. */ int dstLen, /* The maximum length of output buffer in * bytes. */ int *srcReadPtr, /* Filled with the number of bytes from the * source string that were converted. This may * be less than the original source length if * there was a problem converting some source * characters. */ int *dstWrotePtr, /* Filled with the number of bytes that were * stored in the output buffer as a result of * the conversion. */ int *dstCharsPtr) /* Filled with the number of characters that * correspond to the bytes stored in the * output buffer. */ { const char *srcStart, *srcEnd; char *dstEnd, *dstStart; int result, numChars; result = TCL_OK; /* check alignment with ucs-2 (2 == sizeof(UCS-2)) */ if ((srcLen % 2) != 0) { result = TCL_CONVERT_MULTIBYTE; srcLen--; } srcStart = src; srcEnd = src + srcLen; dstStart = dst; dstEnd = dst + dstLen - TCL_UTF_MAX; for (numChars = 0; src < srcEnd; numChars++) { if (dst > dstEnd) { result = TCL_CONVERT_NOSPACE; break; } /* * Need to swap byte-order on little-endian machines (x86) for * UCS-2BE. We know this is an LE->BE swap. */ dst += Tcl_UniCharToUtf(htons(*((short *)src)), dst); src += 2 /* sizeof(UCS-2) */; } *srcReadPtr = src - srcStart; *dstWrotePtr = dst - dstStart; *dstCharsPtr = numChars; return result; } /* *------------------------------------------------------------------------- * * UtfToUcs2beProc -- * * Convert from UTF-8 to UCS-2BE (fixed 2-byte encoding). * * Results: * Returns TCL_OK if conversion was successful. * * Side effects: * None. * *------------------------------------------------------------------------- */ static int UtfToUcs2beProc( ClientData clientData, /* TableEncodingData that specifies * encoding. */ const char *src, /* Source string in UTF-8. */ int srcLen, /* Source string length in bytes. */ int flags, /* Conversion control flags. */ Tcl_EncodingState *statePtr,/* Place for conversion routine to store state * information used during a piecewise * conversion. Contents of statePtr are * initialized and/or reset by conversion * routine under control of flags argument. */ char *dst, /* Output buffer in which converted string is * stored. */ int dstLen, /* The maximum length of output buffer in * bytes. */ int *srcReadPtr, /* Filled with the number of bytes from the * source string that were converted. This may * be less than the original source length if * there was a problem converting some source * characters. */ int *dstWrotePtr, /* Filled with the number of bytes that were * stored in the output buffer as a result of * the conversion. */ int *dstCharsPtr) /* Filled with the number of characters that * correspond to the bytes stored in the * output buffer. */ { const char *srcStart, *srcEnd, *srcClose, *dstStart, *dstEnd; int result, numChars; Tcl_UniChar ch; srcStart = src; srcEnd = src + srcLen; srcClose = srcEnd; if ((flags & TCL_ENCODING_END) == 0) { srcClose -= TCL_UTF_MAX; } dstStart = dst; dstEnd = dst + dstLen - 2 /* sizeof(UCS-2) */; result = TCL_OK; for (numChars = 0; src < srcEnd; numChars++) { if ((src > srcClose) && (!Tcl_UtfCharComplete(src, srcEnd - src))) { /* * If there is more string to follow, this will ensure that the * last UTF-8 character in the source buffer hasn't been cut off. */ result = TCL_CONVERT_MULTIBYTE; break; } if (dst > dstEnd) { result = TCL_CONVERT_NOSPACE; break; } src += Tcl_UtfToUniChar(src, &ch); /* * Ensure big-endianness (store big bits first). * XXX: This hard-codes the assumed size of Tcl_UniChar as 2. Make * sure to work in char* for Tcl_UtfToUniChar alignment. [Bug 1122671] */ *dst++ = (ch >> 8); *dst++ = (ch & 0xFF); } *srcReadPtr = src - srcStart; *dstWrotePtr = dst - dstStart; *dstCharsPtr = numChars; return result; } #endif /* WORDS_BIGENDIAN */ /* *--------------------------------------------------------------------------- * * TkpGetNativeFont -- * * Map a platform-specific native font name to a TkFont. * * Results: * The return value is a pointer to a TkFont that represents the native * font. If a native font by the given name could not be found, the * return value is NULL. * * Every call to this function returns a new TkFont structure, even if * the name has already been seen before. The caller should call * TkpDeleteFont() when the font is no longer needed. * * The caller is responsible for initializing the memory associated with * the generic TkFont when this function returns and releasing the * contents of the generic TkFont before calling TkpDeleteFont(). * * Side effects: * Memory allocated. * *--------------------------------------------------------------------------- */ TkFont * TkpGetNativeFont( Tk_Window tkwin, /* For display where font will be used. */ const char *name) /* Platform-specific font name. */ { UnixFont *fontPtr; XFontStruct *fontStructPtr; FontAttributes fa; const char *p; int hasSpace, dashes, hasWild; /* * The behavior of X when given a name that isn't an XLFD is unspecified. * For example, Exceed 6 returns a valid font for any random string. This * is awkward since system names have higher priority than the other Tk * font syntaxes. So, we need to perform a quick sanity check on the name * and fail if it looks suspicious. We fail if the name: * - contains a space immediately before a dash * - contains a space, but no '*' characters and fewer than 14 dashes */ hasSpace = dashes = hasWild = 0; for (p = name; *p != '\0'; p++) { if (*p == ' ') { if (p[1] == '-') { return NULL; } hasSpace = 1; } else if (*p == '-') { dashes++; } else if (*p == '*') { hasWild = 1; } } if ((dashes < 14) && !hasWild && hasSpace) { return NULL; } fontStructPtr = XLoadQueryFont(Tk_Display(tkwin), name); if (fontStructPtr == NULL) { /* * Handle all names that look like XLFDs here. Otherwise, when * TkpGetFontFromAttributes is called from generic code, any foundry * or encoding information specified in the XLFD will have been parsed * out and lost. But make sure we don't have an "-option value" string * since TkFontParseXLFD would return a false success when attempting * to parse it. */ if (name[0] == '-') { if (name[1] != '*') { char *dash; dash = strchr(name + 1, '-'); if ((dash == NULL) || (isspace(UCHAR(dash[-1])))) { return NULL; } } } else if (name[0] != '*') { return NULL; } if (TkFontParseXLFD(name, &fa.fa, &fa.xa) != TCL_OK) { return NULL; } fontStructPtr = CreateClosestFont(tkwin, &fa.fa, &fa.xa); } fontPtr = ckalloc(sizeof(UnixFont)); InitFont(tkwin, fontStructPtr, fontPtr); return (TkFont *) fontPtr; } /* *--------------------------------------------------------------------------- * * TkpGetFontFromAttributes -- * * Given a desired set of attributes for a font, find a font with the * closest matching attributes. * * Results: * The return value is a pointer to a TkFont that represents the font * with the desired attributes. If a font with the desired attributes * could not be constructed, some other font will be substituted * automatically. * * Every call to this function returns a new TkFont structure, even if * the specified attributes have already been seen before. The caller * should call TkpDeleteFont() to free the platform- specific data when * the font is no longer needed. * * The caller is responsible for initializing the memory associated with * the generic TkFont when this function returns and releasing the * contents of the generic TkFont before calling TkpDeleteFont(). * * Side effects: * Memory allocated. * *--------------------------------------------------------------------------- */ TkFont * TkpGetFontFromAttributes( TkFont *tkFontPtr, /* If non-NULL, store the information in this * existing TkFont structure, rather than * allocating a new structure to hold the * font; the existing contents of the font * will be released. If NULL, a new TkFont * structure is allocated. */ Tk_Window tkwin, /* For display where font will be used. */ const TkFontAttributes *faPtr) /* Set of attributes to match. */ { UnixFont *fontPtr; TkXLFDAttributes xa; XFontStruct *fontStructPtr; TkInitXLFDAttributes(&xa); fontStructPtr = CreateClosestFont(tkwin, faPtr, &xa); fontPtr = (UnixFont *) tkFontPtr; if (fontPtr == NULL) { fontPtr = ckalloc(sizeof(UnixFont)); } else { ReleaseFont(fontPtr); } InitFont(tkwin, fontStructPtr, fontPtr); fontPtr->font.fa.underline = faPtr->underline; fontPtr->font.fa.overstrike = faPtr->overstrike; return (TkFont *) fontPtr; } /* *--------------------------------------------------------------------------- * * TkpDeleteFont -- * * Called to release a font allocated by TkpGetNativeFont() or * TkpGetFontFromAttributes(). The caller should have already released * the fields of the TkFont that are used exclusively by the generic * TkFont code. * * Results: * None. * * Side effects: * TkFont is deallocated. * *--------------------------------------------------------------------------- */ void TkpDeleteFont( TkFont *tkFontPtr) /* Token of font to be deleted. */ { UnixFont *fontPtr = (UnixFont *) tkFontPtr; ReleaseFont(fontPtr); } /* *--------------------------------------------------------------------------- * * TkpGetFontFamilies -- * * Return information about the font families that are available on the * display of the given window. * * Results: * Modifies interp's result object to hold a list of all the available * font families. * * Side effects: * None. * *--------------------------------------------------------------------------- */ void TkpGetFontFamilies( Tcl_Interp *interp, /* Interp to hold result. */ Tk_Window tkwin) /* For display to query. */ { int i, new, numNames; char *family, **nameList; Tcl_HashTable familyTable; Tcl_HashEntry *hPtr; Tcl_HashSearch search; Tcl_Obj *resultPtr, *strPtr; Tcl_InitHashTable(&familyTable, TCL_STRING_KEYS); nameList = ListFonts(Tk_Display(tkwin), "*", &numNames); for (i = 0; i < numNames; i++) { char *familyEnd; family = strchr(nameList[i] + 1, '-'); if (family == NULL) { /* * Apparently, sometimes ListFonts() can return a font name with * zero or one '-' character in it. This is probably indicative of * a server misconfiguration, but crashing because of it is a very * bad idea anyway. [Bug 1475865] */ continue; } family++; /* Advance to char after '-'. */ familyEnd = strchr(family, '-'); if (familyEnd == NULL) { continue; /* See comment above. */ } *familyEnd = '\0'; Tcl_CreateHashEntry(&familyTable, family, &new); } XFreeFontNames(nameList); hPtr = Tcl_FirstHashEntry(&familyTable, &search); resultPtr = Tcl_NewObj(); while (hPtr != NULL) { strPtr = Tcl_NewStringObj(Tcl_GetHashKey(&familyTable, hPtr), -1); Tcl_ListObjAppendElement(NULL, resultPtr, strPtr); hPtr = Tcl_NextHashEntry(&search); } Tcl_SetObjResult(interp, resultPtr); Tcl_DeleteHashTable(&familyTable); } /* *------------------------------------------------------------------------- * * TkpGetSubFonts -- * * A function used by the testing package for querying the actual screen * fonts that make up a font object. * * Results: * Modifies interp's result object to hold a list containing the names of * the screen fonts that make up the given font object. * * Side effects: * None. * *------------------------------------------------------------------------- */ void TkpGetSubFonts( Tcl_Interp *interp, Tk_Font tkfont) { int i; Tcl_Obj *objv[3], *resultPtr, *listPtr; UnixFont *fontPtr; FontFamily *familyPtr; resultPtr = Tcl_NewObj(); fontPtr = (UnixFont *) tkfont; for (i = 0; i < fontPtr->numSubFonts; i++) { familyPtr = fontPtr->subFontArray[i].familyPtr; objv[0] = Tcl_NewStringObj(familyPtr->faceName, -1); objv[1] = Tcl_NewStringObj(familyPtr->foundry, -1); objv[2] = Tcl_NewStringObj( Tcl_GetEncodingName(familyPtr->encoding), -1); listPtr = Tcl_NewListObj(3, objv); Tcl_ListObjAppendElement(NULL, resultPtr, listPtr); } Tcl_SetObjResult(interp, resultPtr); } /* *---------------------------------------------------------------------- * * TkpGetFontAttrsForChar -- * * Retrieve the font attributes of the actual font used to render a given * character. * * Results: * None. * * Side effects: * The font attributes are stored in *faPtr. * *---------------------------------------------------------------------- */ void TkpGetFontAttrsForChar( Tk_Window tkwin, /* Window on the font's display */ Tk_Font tkfont, /* Font to query */ Tcl_UniChar c, /* Character of interest */ TkFontAttributes *faPtr) /* Output: Font attributes */ { FontAttributes atts; UnixFont *fontPtr = (UnixFont *) tkfont; /* Structure describing the logical font */ SubFont *lastSubFontPtr = &fontPtr->subFontArray[0]; /* Pointer to subfont array in case * FindSubFontForChar needs to fix up the * memory allocation */ SubFont *thisSubFontPtr = FindSubFontForChar(fontPtr, c, &lastSubFontPtr); /* Pointer to the subfont to use for the given * character */ GetFontAttributes(Tk_Display(tkwin), thisSubFontPtr->fontStructPtr, &atts); *faPtr = atts.fa; } /* *--------------------------------------------------------------------------- * * Tk_MeasureChars -- * * Determine the number of characters from the string that will fit in * the given horizontal span. The measurement is done under the * assumption that Tk_DrawChars() will be used to actually display the * characters. * * Results: * The return value is the number of bytes from source that fit into the * span that extends from 0 to maxLength. *lengthPtr is filled with the * x-coordinate of the right edge of the last character that did fit. * * Side effects: * None. * *--------------------------------------------------------------------------- */ int Tk_MeasureChars( Tk_Font tkfont, /* Font in which characters will be drawn. */ const char *source, /* UTF-8 string to be displayed. Need not be * '\0' terminated. */ int numBytes, /* Maximum number of bytes to consider from * source string. */ int maxLength, /* If >= 0, maxLength specifies the longest * permissible line length in pixels; don't * consider any character that would cross * this x-position. If < 0, then line length * is unbounded and the flags argument is * ignored. */ int flags, /* Various flag bits OR-ed together: * TK_PARTIAL_OK means include the last char * which only partially fit on this line. * TK_WHOLE_WORDS means stop on a word * boundary, if possible. TK_AT_LEAST_ONE * means return at least one character even if * no characters fit. */ int *lengthPtr) /* Filled with x-location just after the * terminating character. */ { UnixFont *fontPtr; SubFont *lastSubFontPtr; int curX, curByte; /* * Unix does not use kerning or fractional character widths when * displaying text on the screen. So that means we can safely measure * individual characters or spans of characters and add up the widths w/o * any "off-by-one-pixel" errors. */ fontPtr = (UnixFont *) tkfont; lastSubFontPtr = &fontPtr->subFontArray[0]; if (numBytes == 0) { curX = 0; curByte = 0; } else if (maxLength < 0) { const char *p, *end, *next; Tcl_UniChar ch; SubFont *thisSubFontPtr; FontFamily *familyPtr; Tcl_DString runString; /* * A three step process: * 1. Find a contiguous range of characters that can all be * represented by a single screen font. * 2. Convert those chars to the encoding of that font. * 3. Measure converted chars. */ curX = 0; end = source + numBytes; for (p = source; p < end; ) { next = p + Tcl_UtfToUniChar(p, &ch); thisSubFontPtr = FindSubFontForChar(fontPtr, ch, &lastSubFontPtr); if (thisSubFontPtr != lastSubFontPtr) { familyPtr = lastSubFontPtr->familyPtr; Tcl_UtfToExternalDString(familyPtr->encoding, source, p - source, &runString); if (familyPtr->isTwoByteFont) { curX += XTextWidth16(lastSubFontPtr->fontStructPtr, (XChar2b *) Tcl_DStringValue(&runString), Tcl_DStringLength(&runString) / 2); } else { curX += XTextWidth(lastSubFontPtr->fontStructPtr, Tcl_DStringValue(&runString), Tcl_DStringLength(&runString)); } Tcl_DStringFree(&runString); lastSubFontPtr = thisSubFontPtr; source = p; } p = next; } familyPtr = lastSubFontPtr->familyPtr; Tcl_UtfToExternalDString(familyPtr->encoding, source, p - source, &runString); if (familyPtr->isTwoByteFont) { curX += XTextWidth16(lastSubFontPtr->fontStructPtr, (XChar2b *) Tcl_DStringValue(&runString), Tcl_DStringLength(&runString) >> 1); } else { curX += XTextWidth(lastSubFontPtr->fontStructPtr, Tcl_DStringValue(&runString), Tcl_DStringLength(&runString)); } Tcl_DStringFree(&runString); curByte = numBytes; } else { const char *p, *end, *next, *term; int newX, termX, sawNonSpace, dstWrote; Tcl_UniChar ch; FontFamily *familyPtr; XChar2b buf[8]; /* * How many chars will fit in the space allotted? This first version * may be inefficient because it measures every character * individually. */ next = source + Tcl_UtfToUniChar(source, &ch); newX = curX = termX = 0; term = source; end = source + numBytes; sawNonSpace = (ch > 255) || !isspace(ch); familyPtr = lastSubFontPtr->familyPtr; for (p = source; ; ) { if ((ch < BASE_CHARS) && (fontPtr->widths[ch] != 0)) { newX += fontPtr->widths[ch]; } else { lastSubFontPtr = FindSubFontForChar(fontPtr, ch, NULL); familyPtr = lastSubFontPtr->familyPtr; Tcl_UtfToExternal(NULL, familyPtr->encoding, p, next - p, 0, NULL, (char *)&buf[0].byte1, sizeof(buf), NULL, &dstWrote, NULL); if (familyPtr->isTwoByteFont) { newX += XTextWidth16(lastSubFontPtr->fontStructPtr, buf, dstWrote >> 1); } else { newX += XTextWidth(lastSubFontPtr->fontStructPtr, (char *)&buf[0].byte1, dstWrote); } } if (newX > maxLength) { break; } curX = newX; p = next; if (p >= end) { term = end; termX = curX; break; } next += Tcl_UtfToUniChar(next, &ch); if ((ch < 256) && isspace(ch)) { if (sawNonSpace) { term = p; termX = curX; sawNonSpace = 0; } } else { sawNonSpace = 1; } } /* * P points to the first character that doesn't fit in the desired * span. Use the flags to figure out what to return. */ if ((flags & TK_PARTIAL_OK) && (p < end) && (curX < maxLength)) { /* * Include the first character that didn't quite fit in the * desired span. The width returned will include the width of that * extra character. */ curX = newX; p += Tcl_UtfToUniChar(p, &ch); } if ((flags & TK_AT_LEAST_ONE) && (term == source) && (p < end)) { term = p; termX = curX; if (term == source) { term += Tcl_UtfToUniChar(term, &ch); termX = newX; } } else if ((p >= end) || !(flags & TK_WHOLE_WORDS)) { term = p; termX = curX; } curX = termX; curByte = term - source; } *lengthPtr = curX; return curByte; } /* *--------------------------------------------------------------------------- * * TkpMeasureCharsInContext -- * * Determine the number of bytes from the string that will fit in the * given horizontal span. The measurement is done under the assumption * that TkpDrawCharsInContext() will be used to actually display the * characters. * * This one is almost the same as Tk_MeasureChars(), but with access to * all the characters on the line for context. On X11 this context isn't * consulted, so we just call Tk_MeasureChars(). * * Results: * The return value is the number of bytes from source that fit into the * span that extends from 0 to maxLength. *lengthPtr is filled with the * x-coordinate of the right edge of the last character that did fit. * * Side effects: * None. * *--------------------------------------------------------------------------- */ int TkpMeasureCharsInContext( Tk_Font tkfont, /* Font in which characters will be drawn. */ const char *source, /* UTF-8 string to be displayed. Need not be * '\0' terminated. */ int numBytes, /* Maximum number of bytes to consider from * source string in all. */ int rangeStart, /* Index of first byte to measure. */ int rangeLength, /* Length of range to measure in bytes. */ int maxLength, /* If >= 0, maxLength specifies the longest * permissible line length; don't consider any * character that would cross this x-position. * If < 0, then line length is unbounded and * the flags argument is ignored. */ int flags, /* Various flag bits OR-ed together: * TK_PARTIAL_OK means include the last char * which only partially fit on this line. * TK_WHOLE_WORDS means stop on a word * boundary, if possible. TK_AT_LEAST_ONE * means return at least one character even if * no characters fit. TK_ISOLATE_END means * that the last character should not be * considered in context with the rest of the * string (used for breaking lines). */ int *lengthPtr) /* Filled with x-location just after the * terminating character. */ { (void) numBytes; /*unused*/ return Tk_MeasureChars(tkfont, source + rangeStart, rangeLength, maxLength, flags, lengthPtr); } /* *--------------------------------------------------------------------------- * * Tk_DrawChars -- * * Draw a string of characters on the screen. Tk_DrawChars() expands * control characters that occur in the string to \xNN sequences. * * Results: * None. * * Side effects: * Information gets drawn on the screen. * *--------------------------------------------------------------------------- */ void Tk_DrawChars( Display *display, /* Display on which to draw. */ Drawable drawable, /* Window or pixmap in which to draw. */ GC gc, /* Graphics context for drawing characters. */ Tk_Font tkfont, /* Font in which characters will be drawn; * must be the same as font used in GC. */ const char *source, /* UTF-8 string to be displayed. Need not be * '\0' terminated. All Tk meta-characters * (tabs, control characters, and newlines) * should be stripped out of the string that * is passed to this function. If they are not * stripped out, they will be displayed as * regular printing characters. */ int numBytes, /* Number of bytes in string. */ int x, int y) /* Coordinates at which to place origin of * string when drawing. */ { UnixFont *fontPtr = (UnixFont *) tkfont; SubFont *thisSubFontPtr, *lastSubFontPtr; Tcl_DString runString; const char *p, *end, *next; int xStart, needWidth, window_width, do_width; Tcl_UniChar ch; FontFamily *familyPtr; #ifdef TK_DRAW_CHAR_XWINDOW_CHECK int rx, ry; unsigned width, height, border_width, depth; Drawable root; #endif lastSubFontPtr = &fontPtr->subFontArray[0]; xStart = x; #ifdef TK_DRAW_CHAR_XWINDOW_CHECK /* * Get the window width so we can abort drawing outside of the window */ if (XGetGeometry(display, drawable, &root, &rx, &ry, &width, &height, &border_width, &depth) == False) { window_width = INT_MAX; } else { window_width = width; } #else /* * This is used by default until we find a solution that doesn't do a * round-trip to the X server (needed to get Tk cached window width). */ window_width = 32768; #endif end = source + numBytes; needWidth = fontPtr->font.fa.underline + fontPtr->font.fa.overstrike; for (p = source; p <= end; ) { if (p < end) { next = p + Tcl_UtfToUniChar(p, &ch); thisSubFontPtr = FindSubFontForChar(fontPtr, ch, &lastSubFontPtr); } else { next = p + 1; thisSubFontPtr = lastSubFontPtr; } if ((thisSubFontPtr != lastSubFontPtr) || (p == end) || (p-source > 200)) { if (p > source) { do_width = (needWidth || (p != end)) ? 1 : 0; familyPtr = lastSubFontPtr->familyPtr; Tcl_UtfToExternalDString(familyPtr->encoding, source, p - source, &runString); if (familyPtr->isTwoByteFont) { XDrawString16(display, drawable, gc, x, y, (XChar2b *) Tcl_DStringValue(&runString), Tcl_DStringLength(&runString) / 2); if (do_width) { x += XTextWidth16(lastSubFontPtr->fontStructPtr, (XChar2b *) Tcl_DStringValue(&runString), Tcl_DStringLength(&runString) / 2); } } else { XDrawString(display, drawable, gc, x, y, Tcl_DStringValue(&runString), Tcl_DStringLength(&runString)); if (do_width) { x += XTextWidth(lastSubFontPtr->fontStructPtr, Tcl_DStringValue(&runString), Tcl_DStringLength(&runString)); } } Tcl_DStringFree(&runString); } lastSubFontPtr = thisSubFontPtr; source = p; XSetFont(display, gc, lastSubFontPtr->fontStructPtr->fid); if (x > window_width) { break; } } p = next; } if (lastSubFontPtr != &fontPtr->subFontArray[0]) { XSetFont(display, gc, fontPtr->subFontArray[0].fontStructPtr->fid); } if (fontPtr->font.fa.underline != 0) { XFillRectangle(display, drawable, gc, xStart, y + fontPtr->underlinePos, (unsigned) (x - xStart), (unsigned) fontPtr->barHeight); } if (fontPtr->font.fa.overstrike != 0) { y -= fontPtr->font.fm.descent + (fontPtr->font.fm.ascent) / 10; XFillRectangle(display, drawable, gc, xStart, y, (unsigned) (x - xStart), (unsigned) fontPtr->barHeight); } } /* *--------------------------------------------------------------------------- * * TkpDrawCharsInContext -- * * Draw a string of characters on the screen like Tk_DrawChars(), but * with access to all the characters on the line for context. On X11 this * context isn't consulted, so we just call Tk_DrawChars(). * * Results: * None. * * Side effects: * Information gets drawn on the screen. * *--------------------------------------------------------------------------- */ void TkpDrawCharsInContext( Display *display, /* Display on which to draw. */ Drawable drawable, /* Window or pixmap in which to draw. */ GC gc, /* Graphics context for drawing characters. */ Tk_Font tkfont, /* Font in which characters will be drawn; * must be the same as font used in GC. */ const char *source, /* UTF-8 string to be displayed. Need not be * '\0' terminated. All Tk meta-characters * (tabs, control characters, and newlines) * should be stripped out of the string that * is passed to this function. If they are not * stripped out, they will be displayed as * regular printing characters. */ int numBytes, /* Number of bytes in string. */ int rangeStart, /* Index of first byte to draw. */ int rangeLength, /* Length of range to draw in bytes. */ int x, int y) /* Coordinates at which to place origin of the * whole (not just the range) string when * drawing. */ { (void) numBytes; /*unused*/ Tk_DrawChars(display, drawable, gc, tkfont, source + rangeStart, rangeLength, x, y); } /* *------------------------------------------------------------------------- * * CreateClosestFont -- * * Helper for TkpGetNativeFont() and TkpGetFontFromAttributes(). Given a * set of font attributes, construct a close XFontStruct. If requested * face name is not available, automatically substitutes an alias for * requested face name. If encoding is not specified (or the requested * one is not available), automatically chooses another encoding from the * list of preferred encodings. If the foundry is not specified (or is * not available) automatically prefers "adobe" foundry. For all other * attributes, if the requested value was not available, the appropriate * "close" value will be used. * * Results: * Return value is the XFontStruct that best matched the requested * attributes. The return value is never NULL; some font will always be * returned. * * Side effects: * None. * *------------------------------------------------------------------------- */ static XFontStruct * CreateClosestFont( Tk_Window tkwin, /* For display where font will be used. */ const TkFontAttributes *faPtr, /* Set of generic attributes to match. */ const TkXLFDAttributes *xaPtr) /* Set of X-specific attributes to match. */ { FontAttributes want; char **nameList; int numNames, nameIdx, bestIdx[2]; Display *display; XFontStruct *fontStructPtr; unsigned bestScore[2]; want.fa = *faPtr; want.xa = *xaPtr; if (want.xa.foundry == NULL) { want.xa.foundry = Tk_GetUid("adobe"); } if (want.fa.family == NULL) { want.fa.family = Tk_GetUid("fixed"); } want.fa.size = -TkFontGetPixels(tkwin, faPtr->size); if (want.xa.charset == NULL || *want.xa.charset == '\0') { want.xa.charset = Tk_GetUid("iso8859-1"); /* locale. */ } display = Tk_Display(tkwin); /* * Algorithm to get the closest font to the name requested. * * try fontname * try all aliases for fontname * foreach fallback for fontname * try the fallback * try all aliases for the fallback */ nameList = ListFontOrAlias(display, want.fa.family, &numNames); if (numNames == 0) { const char *const *const *fontFallbacks; int i, j; const char *fallback; fontFallbacks = TkFontGetFallbacks(); for (i = 0; fontFallbacks[i] != NULL; i++) { for (j = 0; (fallback = fontFallbacks[i][j]) != NULL; j++) { if (strcasecmp(want.fa.family, fallback) == 0) { break; } } if (fallback != NULL) { for (j = 0; (fallback = fontFallbacks[i][j]) != NULL; j++) { nameList = ListFontOrAlias(display, fallback, &numNames); if (numNames != 0) { goto found; } } } } nameList = ListFonts(display, "fixed", &numNames); if (numNames == 0) { nameList = ListFonts(display, "*", &numNames); } if (numNames == 0) { return GetSystemFont(display); } } found: bestIdx[0] = -1; bestIdx[1] = -1; bestScore[0] = (unsigned) -1; bestScore[1] = (unsigned) -1; for (nameIdx = 0; nameIdx < numNames; nameIdx++) { FontAttributes got; int scalable; unsigned score; if (TkFontParseXLFD(nameList[nameIdx], &got.fa, &got.xa) != TCL_OK) { continue; } IdentifySymbolEncodings(&got); scalable = (got.fa.size == 0); score = RankAttributes(&want, &got); if (score < bestScore[scalable]) { bestIdx[scalable] = nameIdx; bestScore[scalable] = score; } if (score == 0) { break; } } fontStructPtr = GetScreenFont(display, &want, nameList, bestIdx, bestScore); XFreeFontNames(nameList); if (fontStructPtr == NULL) { return GetSystemFont(display); } return fontStructPtr; } /* *--------------------------------------------------------------------------- * * InitFont -- * * Helper for TkpGetNativeFont() and TkpGetFontFromAttributes(). * Initializes the memory for a new UnixFont that wraps the * platform-specific data. * * The caller is responsible for initializing the fields of the TkFont * that are used exclusively by the generic TkFont code, and for * releasing those fields before calling TkpDeleteFont(). * * Results: * Fills the WinFont structure. * * Side effects: * Memory allocated. * *--------------------------------------------------------------------------- */ static void InitFont( Tk_Window tkwin, /* For screen where font will be used. */ XFontStruct *fontStructPtr, /* X information about font. */ UnixFont *fontPtr) /* Filled with information constructed from * the above arguments. */ { ThreadSpecificData *tsdPtr = Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData)); unsigned long value; int minHi, maxHi, minLo, maxLo, fixed, width, limit, i, n; FontAttributes fa; TkFontAttributes *faPtr; TkFontMetrics *fmPtr; SubFont *controlPtr, *subFontPtr; char *pageMap; Display *display; /* * Get all font attributes and metrics. */ display = Tk_Display(tkwin); GetFontAttributes(display, fontStructPtr, &fa); minHi = fontStructPtr->min_byte1; maxHi = fontStructPtr->max_byte1; minLo = fontStructPtr->min_char_or_byte2; maxLo = fontStructPtr->max_char_or_byte2; fixed = 1; if (fontStructPtr->per_char != NULL) { width = 0; limit = (maxHi - minHi + 1) * (maxLo - minLo + 1); for (i = 0; i < limit; i++) { n = fontStructPtr->per_char[i].width; if (n != 0) { if (width == 0) { width = n; } else if (width != n) { fixed = 0; break; } } } } fontPtr->font.fid = fontStructPtr->fid; faPtr = &fontPtr->font.fa; faPtr->family = fa.fa.family; faPtr->size = TkFontGetPoints(tkwin, fa.fa.size); faPtr->weight = fa.fa.weight; faPtr->slant = fa.fa.slant; faPtr->underline = 0; faPtr->overstrike = 0; fmPtr = &fontPtr->font.fm; fmPtr->ascent = fontStructPtr->ascent; fmPtr->descent = fontStructPtr->descent; fmPtr->maxWidth = fontStructPtr->max_bounds.width; fmPtr->fixed = fixed; fontPtr->display = display; fontPtr->pixelSize = TkFontGetPixels(tkwin, fa.fa.size); fontPtr->xa = fa.xa; fontPtr->numSubFonts = 1; fontPtr->subFontArray = fontPtr->staticSubFonts; InitSubFont(display, fontStructPtr, 1, &fontPtr->subFontArray[0]); fontPtr->controlSubFont = fontPtr->subFontArray[0]; subFontPtr = FindSubFontForChar(fontPtr, '0', NULL); controlPtr = &fontPtr->controlSubFont; controlPtr->fontStructPtr = subFontPtr->fontStructPtr; controlPtr->familyPtr = &tsdPtr->controlFamily; controlPtr->fontMap = tsdPtr->controlFamily.fontMap; pageMap = fontPtr->subFontArray[0].fontMap[0]; for (i = 0; i < 256; i++) { if ((minHi > 0) || (i < minLo) || (i > maxLo) || (((pageMap[i>>3] >> (i&7)) & 1) == 0)) { n = 0; } else if (fontStructPtr->per_char == NULL) { n = fontStructPtr->max_bounds.width; } else { n = fontStructPtr->per_char[i - minLo].width; } fontPtr->widths[i] = n; } if (XGetFontProperty(fontStructPtr, XA_UNDERLINE_POSITION, &value)) { fontPtr->underlinePos = value; } else { /* * If the XA_UNDERLINE_POSITION property does not exist, the X manual * recommends using the following value: */ fontPtr->underlinePos = fontStructPtr->descent / 2; } fontPtr->barHeight = 0; if (XGetFontProperty(fontStructPtr, XA_UNDERLINE_THICKNESS, &value)) { fontPtr->barHeight = value; } if (fontPtr->barHeight == 0) { /* * If the XA_UNDERLINE_THICKNESS property does not exist, the X manual * recommends using the width of the stem on a capital letter. I don't * know of a way to get the stem width of a letter, so guess and use * 1/3 the width of a capital I. */ fontPtr->barHeight = fontPtr->widths['I'] / 3; if (fontPtr->barHeight == 0) { fontPtr->barHeight = 1; } } if (fontPtr->underlinePos + fontPtr->barHeight > fontStructPtr->descent) { /* * If this set of cobbled together values would cause the bottom of * the underline bar to stick below the descent of the font, jack the * underline up a bit higher. */ fontPtr->barHeight = fontStructPtr->descent - fontPtr->underlinePos; if (fontPtr->barHeight == 0) { fontPtr->underlinePos--; fontPtr->barHeight = 1; } } } /* *------------------------------------------------------------------------- * * ReleaseFont -- * * Called to release the unix-specific contents of a TkFont. The caller * is responsible for freeing the memory used by the font itself. * * Results: * None. * * Side effects: * Memory is freed. * *--------------------------------------------------------------------------- */ static void ReleaseFont( UnixFont *fontPtr) /* The font to delete. */ { int i; for (i = 0; i < fontPtr->numSubFonts; i++) { ReleaseSubFont(fontPtr->display, &fontPtr->subFontArray[i]); } if (fontPtr->subFontArray != fontPtr->staticSubFonts) { ckfree(fontPtr->subFontArray); } } /* *------------------------------------------------------------------------- * * InitSubFont -- * * Wrap a screen font and load the FontFamily that represents it. Used to * prepare a SubFont so that characters can be mapped from UTF-8 to the * charset of the font. * * Results: * The subFontPtr is filled with information about the font. * * Side effects: * None. * *------------------------------------------------------------------------- */ static void InitSubFont( Display *display, /* Display in which font will be used. */ XFontStruct *fontStructPtr, /* The screen font. */ int base, /* Non-zero if this SubFont is being used as * the base font for a font object. */ SubFont *subFontPtr) /* Filled with SubFont constructed from above * attributes. */ { subFontPtr->fontStructPtr = fontStructPtr; subFontPtr->familyPtr = AllocFontFamily(display, fontStructPtr, base); subFontPtr->fontMap = subFontPtr->familyPtr->fontMap; } /* *------------------------------------------------------------------------- * * ReleaseSubFont -- * * Called to release the contents of a SubFont. The caller is responsible * for freeing the memory used by the SubFont itself. * * Results: * None. * * Side effects: * Memory and resources are freed. * *--------------------------------------------------------------------------- */ static void ReleaseSubFont( Display *display, /* Display which owns screen font. */ SubFont *subFontPtr) /* The SubFont to delete. */ { XFreeFont(display, subFontPtr->fontStructPtr); FreeFontFamily(subFontPtr->familyPtr); } /* *------------------------------------------------------------------------- * * AllocFontFamily -- * * Find the FontFamily structure associated with the given font name. * The information should be stored by the caller in a SubFont and used * when determining if that SubFont supports a character. * * Cannot use the string name used to construct the font as the key, * because the capitalization may not be canonical. Therefore use the * face name actually retrieved from the font metrics as the key. * * Results: * A pointer to a FontFamily. The reference count in the FontFamily is * automatically incremented. When the SubFont is released, the reference * count is decremented. When no SubFont is using this FontFamily, it may * be deleted. * * Side effects: * A new FontFamily structure will be allocated if this font family has * not been seen. TrueType character existence metrics are loaded into * the FontFamily structure. * *------------------------------------------------------------------------- */ static FontFamily * AllocFontFamily( Display *display, /* Display in which font will be used. */ XFontStruct *fontStructPtr, /* Screen font whose FontFamily is to be * returned. */ int base) /* Non-zero if this font family is to be used * in the base font of a font object. */ { FontFamily *familyPtr; FontAttributes fa; Tcl_Encoding encoding; ThreadSpecificData *tsdPtr = Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData)); GetFontAttributes(display, fontStructPtr, &fa); encoding = Tcl_GetEncoding(NULL, GetEncodingAlias(fa.xa.charset)); familyPtr = tsdPtr->fontFamilyList; for (; familyPtr != NULL; familyPtr = familyPtr->nextPtr) { if ((familyPtr->faceName == fa.fa.family) && (familyPtr->foundry == fa.xa.foundry) && (familyPtr->encoding == encoding)) { Tcl_FreeEncoding(encoding); familyPtr->refCount++; return familyPtr; } } familyPtr = ckalloc(sizeof(FontFamily)); memset(familyPtr, 0, sizeof(FontFamily)); familyPtr->nextPtr = tsdPtr->fontFamilyList; tsdPtr->fontFamilyList = familyPtr; /* * Set key for this FontFamily. */ familyPtr->foundry = fa.xa.foundry; familyPtr->faceName = fa.fa.family; familyPtr->encoding = encoding; /* * An initial refCount of 2 means that FontFamily information will persist * even when the SubFont that loaded the FontFamily is released. Change it * to 1 to cause FontFamilies to be unloaded when not in use. */ familyPtr->refCount = 2; /* * One byte/character fonts have both min_byte1 and max_byte1 0, and * max_char_or_byte2 <= 255. Anything else specifies a two byte/character * font. */ familyPtr->isTwoByteFont = !( (fontStructPtr->min_byte1 == 0) && (fontStructPtr->max_byte1 == 0) && (fontStructPtr->max_char_or_byte2 < 256)); return familyPtr; } /* *------------------------------------------------------------------------- * * FreeFontFamily -- * * Called to free an FontFamily when the SubFont is finished using it. * Frees the contents of the FontFamily and the memory used by the * FontFamily itself. * * Results: * None. * * Side effects: * None. * *------------------------------------------------------------------------- */ static void FreeFontFamily( FontFamily *familyPtr) /* The FontFamily to delete. */ { FontFamily **familyPtrPtr; ThreadSpecificData *tsdPtr = Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData)); int i; if (familyPtr == NULL) { return; } familyPtr->refCount--; if (familyPtr->refCount > 0) { return; } Tcl_FreeEncoding(familyPtr->encoding); for (i = 0; i < FONTMAP_PAGES; i++) { if (familyPtr->fontMap[i] != NULL) { ckfree(familyPtr->fontMap[i]); } } /* * Delete from list. */ for (familyPtrPtr = &tsdPtr->fontFamilyList; ; ) { if (*familyPtrPtr == familyPtr) { *familyPtrPtr = familyPtr->nextPtr; break; } familyPtrPtr = &(*familyPtrPtr)->nextPtr; } ckfree(familyPtr); } /* *------------------------------------------------------------------------- * * FindSubFontForChar -- * * Determine which screen font is necessary to use to display the given * character. If the font object does not have a screen font that can * display the character, another screen font may be loaded into the font * object, following a set of preferred fallback rules. * * Results: * The return value is the SubFont to use to display the given character. * * Side effects: * The contents of fontPtr are modified to cache the results of the * lookup and remember any SubFonts that were dynamically loaded. The * table of SubFonts might be extended, and if a non-NULL reference to a * subfont pointer is available, it is updated if it previously pointed * into the old subfont table. * *------------------------------------------------------------------------- */ static SubFont * FindSubFontForChar( UnixFont *fontPtr, /* The font object with which the character * will be displayed. */ int ch, /* The Unicode character to be displayed. */ SubFont **fixSubFontPtrPtr) /* Subfont reference to fix up if we * reallocate our subfont table. */ { int i, j, k, numNames; Tk_Uid faceName; const char *fallback; const char *const *aliases; char **nameList; const char *const *anyFallbacks; const char *const *const *fontFallbacks; SubFont *subFontPtr; Tcl_DString ds; if (FontMapLookup(&fontPtr->subFontArray[0], ch)) { return &fontPtr->subFontArray[0]; } for (i = 1; i < fontPtr->numSubFonts; i++) { if (FontMapLookup(&fontPtr->subFontArray[i], ch)) { return &fontPtr->subFontArray[i]; } } if (FontMapLookup(&fontPtr->controlSubFont, ch)) { return &fontPtr->controlSubFont; } /* * Keep track of all face names that we check, so we don't check some name * multiple times if it can be reached by multiple paths. */ Tcl_DStringInit(&ds); /* * Are there any other fonts with the same face name as the base font that * could display this character, e.g., if the base font is * adobe:fixed:iso8859-1, we could might be able to use * misc:fixed:iso8859-8 or sony:fixed:jisx0208.1983-0 */ faceName = fontPtr->font.fa.family; if (SeenName(faceName, &ds) == 0) { subFontPtr = CanUseFallback(fontPtr, faceName, ch, fixSubFontPtrPtr); if (subFontPtr != NULL) { goto end; } } aliases = TkFontGetAliasList(faceName); subFontPtr = NULL; fontFallbacks = TkFontGetFallbacks(); for (i = 0; fontFallbacks[i] != NULL; i++) { for (j = 0; (fallback = fontFallbacks[i][j]) != NULL; j++) { if (strcasecmp(fallback, faceName) == 0) { /* * If the base font has a fallback... */ goto tryfallbacks; } else if (aliases != NULL) { /* * Or if an alias for the base font has a fallback... */ for (k = 0; aliases[k] != NULL; k++) { if (strcasecmp(fallback, aliases[k]) == 0) { goto tryfallbacks; } } } } continue; tryfallbacks: /* * ...then see if we can use one of the fallbacks, or an alias for one * of the fallbacks. */ for (j = 0; (fallback = fontFallbacks[i][j]) != NULL; j++) { subFontPtr = CanUseFallbackWithAliases(fontPtr, fallback, ch, &ds, fixSubFontPtrPtr); if (subFontPtr != NULL) { goto end; } } } /* * See if we can use something from the global fallback list. */ anyFallbacks = TkFontGetGlobalClass(); for (i = 0; (fallback = anyFallbacks[i]) != NULL; i++) { subFontPtr = CanUseFallbackWithAliases(fontPtr, fallback, ch, &ds, fixSubFontPtrPtr); if (subFontPtr != NULL) { goto end; } } /* * Try all face names available in the whole system until we find one that * can be used. */ nameList = ListFonts(fontPtr->display, "*", &numNames); for (i = 0; i < numNames; i++) { fallback = strchr(nameList[i] + 1, '-') + 1; strchr(fallback, '-')[0] = '\0'; if (SeenName(fallback, &ds) == 0) { subFontPtr = CanUseFallback(fontPtr, fallback, ch, fixSubFontPtrPtr); if (subFontPtr != NULL) { XFreeFontNames(nameList); goto end; } } } XFreeFontNames(nameList); end: Tcl_DStringFree(&ds); if (subFontPtr == NULL) { /* * No font can display this character, so it will be displayed as a * control character expansion. */ subFontPtr = &fontPtr->controlSubFont; FontMapInsert(subFontPtr, ch); } return subFontPtr; } /* *------------------------------------------------------------------------- * * FontMapLookup -- * * See if the screen font can display the given character. * * Results: * The return value is 0 if the screen font cannot display the character, * non-zero otherwise. * * Side effects: * New pages are added to the font mapping cache whenever the character * belongs to a page that hasn't been seen before. When a page is loaded, * information about all the characters on that page is stored, not just * for the single character in question. * *------------------------------------------------------------------------- */ static int FontMapLookup( SubFont *subFontPtr, /* Contains font mapping cache to be queried * and possibly updated. */ int ch) /* Character to be tested. */ { int row, bitOffset; row = ch >> FONTMAP_SHIFT; if (subFontPtr->fontMap[row] == NULL) { FontMapLoadPage(subFontPtr, row); } bitOffset = ch & (FONTMAP_BITSPERPAGE - 1); return (subFontPtr->fontMap[row][bitOffset >> 3] >> (bitOffset & 7)) & 1; } /* *------------------------------------------------------------------------- * * FontMapInsert -- * * Tell the font mapping cache that the given screen font should be used * to display the specified character. This is called when no font on the * system can be be found that can display that character; we lie to the * font and tell it that it can display the character, otherwise we would * end up re-searching the entire fallback hierarchy every time that * character was seen. * * Results: * None. * * Side effects: * New pages are added to the font mapping cache whenever the character * belongs to a page that hasn't been seen before. When a page is loaded, * information about all the characters on that page is stored, not just * for the single character in question. * *------------------------------------------------------------------------- */ static void FontMapInsert( SubFont *subFontPtr, /* Contains font mapping cache to be * updated. */ int ch) /* Character to be added to cache. */ { int row, bitOffset; row = ch >> FONTMAP_SHIFT; if (subFontPtr->fontMap[row] == NULL) { FontMapLoadPage(subFontPtr, row); } bitOffset = ch & (FONTMAP_BITSPERPAGE - 1); subFontPtr->fontMap[row][bitOffset >> 3] |= 1 << (bitOffset & 7); } /* *------------------------------------------------------------------------- * * FontMapLoadPage -- * * Load information about all the characters on a given page. This * information consists of one bit per character that indicates whether * the associated screen font can (1) or cannot (0) display the * characters on the page. * * Results: * None. * * Side effects: * Memory allocated. * *------------------------------------------------------------------------- */ static void FontMapLoadPage( SubFont *subFontPtr, /* Contains font mapping cache to be * updated. */ int row) /* Index of the page to be loaded into the * cache. */ { char buf[16], src[TCL_UTF_MAX]; int minHi, maxHi, minLo, maxLo, scale, checkLo; int i, end, bitOffset, isTwoByteFont, n; Tcl_Encoding encoding; XFontStruct *fontStructPtr; XCharStruct *widths; ThreadSpecificData *tsdPtr = Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData)); subFontPtr->fontMap[row] = ckalloc(FONTMAP_BITSPERPAGE / 8); memset(subFontPtr->fontMap[row], 0, FONTMAP_BITSPERPAGE / 8); if (subFontPtr->familyPtr == &tsdPtr->controlFamily) { return; } fontStructPtr = subFontPtr->fontStructPtr; encoding = subFontPtr->familyPtr->encoding; isTwoByteFont = subFontPtr->familyPtr->isTwoByteFont; widths = fontStructPtr->per_char; minHi = fontStructPtr->min_byte1; maxHi = fontStructPtr->max_byte1; minLo = fontStructPtr->min_char_or_byte2; maxLo = fontStructPtr->max_char_or_byte2; scale = maxLo - minLo + 1; checkLo = minLo; if (! isTwoByteFont) { if (minLo < 32) { checkLo = 32; } } end = (row + 1) << FONTMAP_SHIFT; for (i = row << FONTMAP_SHIFT; i < end; i++) { int hi, lo; if (Tcl_UtfToExternal(NULL, encoding, src, Tcl_UniCharToUtf(i, src), TCL_ENCODING_STOPONERROR, NULL, buf, sizeof(buf), NULL, NULL, NULL) != TCL_OK) { continue; } if (isTwoByteFont) { hi = ((unsigned char *) buf)[0]; lo = ((unsigned char *) buf)[1]; } else { hi = 0; lo = ((unsigned char *) buf)[0]; } if ((hi < minHi) || (hi > maxHi) || (lo < checkLo) || (lo > maxLo)) { continue; } n = (hi - minHi) * scale + lo - minLo; if ((widths == NULL) || (widths[n].width + widths[n].rbearing != 0)) { bitOffset = i & (FONTMAP_BITSPERPAGE - 1); subFontPtr->fontMap[row][bitOffset >> 3] |= 1 << (bitOffset & 7); } } } /* *--------------------------------------------------------------------------- * * CanUseFallbackWithAliases -- * * Helper function for FindSubFontForChar. Determine if the specified * face name (or an alias of the specified face name) can be used to * construct a screen font that can display the given character. * * Results: * See CanUseFallback(). * * Side effects: * If the name and/or one of its aliases was rejected, the rejected * string is recorded in nameTriedPtr so that it won't be tried again. * The table of SubFonts might be extended, and if a non-NULL reference * to a subfont pointer is available, it is updated if it previously * pointed into the old subfont table. * *--------------------------------------------------------------------------- */ static SubFont * CanUseFallbackWithAliases( UnixFont *fontPtr, /* The font object that will own the new * screen font. */ const char *faceName, /* Desired face name for new screen font. */ int ch, /* The Unicode character that the new screen * font must be able to display. */ Tcl_DString *nameTriedPtr, /* Records face names that have already been * tried. It is possible for the same face * name to be queried multiple times when * trying to find a suitable screen font. */ SubFont **fixSubFontPtrPtr) /* Subfont reference to fix up if we * reallocate our subfont table. */ { SubFont *subFontPtr; const char *const *aliases; int i; if (SeenName(faceName, nameTriedPtr) == 0) { subFontPtr = CanUseFallback(fontPtr, faceName, ch, fixSubFontPtrPtr); if (subFontPtr != NULL) { return subFontPtr; } } aliases = TkFontGetAliasList(faceName); if (aliases != NULL) { for (i = 0; aliases[i] != NULL; i++) { if (SeenName(aliases[i], nameTriedPtr) == 0) { subFontPtr = CanUseFallback(fontPtr, aliases[i], ch, fixSubFontPtrPtr); if (subFontPtr != NULL) { return subFontPtr; } } } } return NULL; } /* *--------------------------------------------------------------------------- * * SeenName -- * * Used to determine we have already tried and rejected the given face * name when looking for a screen font that can support some Unicode * character. * * Results: * The return value is 0 if this face name has not already been seen, * non-zero otherwise. * * Side effects: * None. * *--------------------------------------------------------------------------- */ static int SeenName( const char *name, /* The name to check. */ Tcl_DString *dsPtr) /* Contains names that have already been * seen. */ { const char *seen, *end; seen = Tcl_DStringValue(dsPtr); end = seen + Tcl_DStringLength(dsPtr); while (seen < end) { if (strcasecmp(seen, name) == 0) { return 1; } seen += strlen(seen) + 1; } Tcl_DStringAppend(dsPtr, name, (int) (strlen(name) + 1)); return 0; } /* *------------------------------------------------------------------------- * * CanUseFallback -- * * If the specified screen font has not already been loaded into the font * object, determine if the specified screen font can display the given * character. * * Results: * The return value is a pointer to a newly allocated SubFont, owned by * the font object. This SubFont can be used to display the given * character. The SubFont represents the screen font with the base set of * font attributes from the font object, but using the specified face * name. NULL is returned if the font object already holds a reference to * the specified font or if the specified font doesn't exist or cannot * display the given character. * * Side effects: * The font object's subFontArray is updated to contain a reference to * the newly allocated SubFont. The table of SubFonts might be extended, * and if a non-NULL reference to a subfont pointer is available, it is * updated if it previously pointed into the old subfont table. * *------------------------------------------------------------------------- */ static SubFont * CanUseFallback( UnixFont *fontPtr, /* The font object that will own the new * screen font. */ const char *faceName, /* Desired face name for new screen font. */ int ch, /* The Unicode character that the new screen * font must be able to display. */ SubFont **fixSubFontPtrPtr) /* Subfont reference to fix up if we * reallocate our subfont table. */ { int i, nameIdx, numNames, srcLen, numEncodings, bestIdx[2]; Tk_Uid hateFoundry; const char *charset, *hateCharset; unsigned bestScore[2]; char **nameList; char **nameListOrig; char src[TCL_UTF_MAX]; FontAttributes want, got; Display *display; SubFont subFont; XFontStruct *fontStructPtr; Tcl_DString dsEncodings; Tcl_Encoding *encodingCachePtr; /* * Assume: the face name is times. * Assume: adobe:times:iso8859-1 has already been used. * * Are there any versions of times that can display this character (e.g., * perhaps linotype:times:iso8859-2)? * a. Get list of all times fonts. * b1. Cross out all names whose encodings we've already used. * b2. Cross out all names whose foundry & encoding we've already seen. * c. Cross out all names whose encoding cannot handle the character. * d. Rank each name and pick the best match. * e. If that font cannot actually display the character, cross out all * names with the same foundry and encoding and go back to (c). */ display = fontPtr->display; nameList = ListFonts(display, faceName, &numNames); if (numNames == 0) { return NULL; } nameListOrig = nameList; srcLen = Tcl_UniCharToUtf(ch, src); want.fa = fontPtr->font.fa; want.xa = fontPtr->xa; want.fa.family = Tk_GetUid(faceName); want.fa.size = -fontPtr->pixelSize; hateFoundry = NULL; hateCharset = NULL; numEncodings = 0; Tcl_DStringInit(&dsEncodings); charset = NULL; /* lint, since numNames must be > 0 to get here. */ retry: bestIdx[0] = -1; bestIdx[1] = -1; bestScore[0] = (unsigned) -1; bestScore[1] = (unsigned) -1; for (nameIdx = 0; nameIdx < numNames; nameIdx++) { Tcl_Encoding encoding; char dst[16]; int scalable, srcRead, dstWrote; unsigned score; if (nameList[nameIdx] == NULL) { continue; } if (TkFontParseXLFD(nameList[nameIdx], &got.fa, &got.xa) != TCL_OK) { goto crossout; } IdentifySymbolEncodings(&got); charset = GetEncodingAlias(got.xa.charset); if (hateFoundry != NULL) { /* * E. If the font we picked cannot actually display the character, * cross out all names with the same foundry and encoding. */ if ((hateFoundry == got.xa.foundry) && (strcmp(hateCharset, charset) == 0)) { goto crossout; } } else { /* * B. Cross out all names whose encodings we've already used. */ for (i = 0; i < fontPtr->numSubFonts; i++) { encoding = fontPtr->subFontArray[i].familyPtr->encoding; if (strcmp(charset, Tcl_GetEncodingName(encoding)) == 0) { goto crossout; } } } /* * C. Cross out all names whose encoding cannot handle the character. */ encodingCachePtr = (Tcl_Encoding *) Tcl_DStringValue(&dsEncodings); for (i = numEncodings; --i >= 0; encodingCachePtr++) { encoding = *encodingCachePtr; if (strcmp(Tcl_GetEncodingName(encoding), charset) == 0) { break; } } if (i < 0) { encoding = Tcl_GetEncoding(NULL, charset); if (encoding == NULL) { goto crossout; } Tcl_DStringAppend(&dsEncodings, (char *) &encoding, sizeof(encoding)); numEncodings++; } Tcl_UtfToExternal(NULL, encoding, src, srcLen, TCL_ENCODING_STOPONERROR, NULL, dst, sizeof(dst), &srcRead, &dstWrote, NULL); if (dstWrote == 0) { goto crossout; } /* * D. Rank each name and pick the best match. */ scalable = (got.fa.size == 0); score = RankAttributes(&want, &got); if (score < bestScore[scalable]) { bestIdx[scalable] = nameIdx; bestScore[scalable] = score; } if (score == 0) { break; } continue; crossout: if (nameList == nameListOrig) { /* * Not allowed to change pointers to memory that X gives you, so * make a copy. */ nameList = ckalloc(numNames * sizeof(char *)); memcpy(nameList, nameListOrig, numNames * sizeof(char *)); } nameList[nameIdx] = NULL; } fontStructPtr = GetScreenFont(display, &want, nameList, bestIdx, bestScore); encodingCachePtr = (Tcl_Encoding *) Tcl_DStringValue(&dsEncodings); for (i = numEncodings; --i >= 0; encodingCachePtr++) { Tcl_FreeEncoding(*encodingCachePtr); } Tcl_DStringFree(&dsEncodings); numEncodings = 0; if (fontStructPtr == NULL) { if (nameList != nameListOrig) { ckfree(nameList); } XFreeFontNames(nameListOrig); return NULL; } InitSubFont(display, fontStructPtr, 0, &subFont); if (FontMapLookup(&subFont, ch) == 0) { /* * E. If the font we picked cannot actually display the character, * cross out all names with the same foundry and encoding and pick * another font. */ hateFoundry = got.xa.foundry; hateCharset = charset; ReleaseSubFont(display, &subFont); goto retry; } if (nameList != nameListOrig) { ckfree(nameList); } XFreeFontNames(nameListOrig); if (fontPtr->numSubFonts >= SUBFONT_SPACE) { SubFont *newPtr; newPtr = ckalloc(sizeof(SubFont) * (fontPtr->numSubFonts + 1)); memcpy(newPtr, fontPtr->subFontArray, fontPtr->numSubFonts * sizeof(SubFont)); if (fixSubFontPtrPtr != NULL) { register SubFont *fixSubFontPtr = *fixSubFontPtrPtr; if (fixSubFontPtr != &fontPtr->controlSubFont) { *fixSubFontPtrPtr = newPtr + (fixSubFontPtr - fontPtr->subFontArray); } } if (fontPtr->subFontArray != fontPtr->staticSubFonts) { ckfree(fontPtr->subFontArray); } fontPtr->subFontArray = newPtr; } fontPtr->subFontArray[fontPtr->numSubFonts] = subFont; fontPtr->numSubFonts++; return &fontPtr->subFontArray[fontPtr->numSubFonts - 1]; } /* *--------------------------------------------------------------------------- * * RankAttributes -- * * Determine how close the attributes of the font in question match the * attributes that we want. * * Results: * The return value is the score; lower numbers are better. *scalablePtr * is set to 0 if the font was not scalable, 1 otherwise. * * Side effects: * None. * *--------------------------------------------------------------------------- */ static unsigned RankAttributes( FontAttributes *wantPtr, /* The desired attributes. */ FontAttributes *gotPtr) /* The attributes we have to live with. */ { unsigned penalty; penalty = 0; if (gotPtr->xa.foundry != wantPtr->xa.foundry) { penalty += 4500; } if (gotPtr->fa.family != wantPtr->fa.family) { penalty += 9000; } if (gotPtr->fa.weight != wantPtr->fa.weight) { penalty += 90; } if (gotPtr->fa.slant != wantPtr->fa.slant) { penalty += 60; } if (gotPtr->xa.slant != wantPtr->xa.slant) { penalty += 10; } if (gotPtr->xa.setwidth != wantPtr->xa.setwidth) { penalty += 1000; } if (gotPtr->fa.size == 0) { /* * A scalable font is almost always acceptable, but the corresponding * bitmapped font would be better. */ penalty += 10; } else { int diff; /* * It's worse to be too large than to be too small. */ diff = (-gotPtr->fa.size - -wantPtr->fa.size); if (diff > 0) { penalty += 600; } else if (diff < 0) { penalty += 150; diff = -diff; } penalty += 150 * diff; } if (gotPtr->xa.charset != wantPtr->xa.charset) { int i; const char *gotAlias, *wantAlias; penalty += 65000; gotAlias = GetEncodingAlias(gotPtr->xa.charset); wantAlias = GetEncodingAlias(wantPtr->xa.charset); if (strcmp(gotAlias, wantAlias) != 0) { penalty += 30000; for (i = 0; encodingList[i] != NULL; i++) { if (strcmp(gotAlias, encodingList[i]) == 0) { penalty -= 30000; break; } penalty += 20000; } } } return penalty; } /* *--------------------------------------------------------------------------- * * GetScreenFont -- * * Given the names for the best scalable and best bitmapped font, * actually construct an XFontStruct based on the best XLFD. This is * where all the alias and fallback substitution bottoms out. * * Results: * The screen font that best corresponds to the set of attributes. * * Side effects: * None. * *--------------------------------------------------------------------------- */ static XFontStruct * GetScreenFont( Display *display, /* Display for new XFontStruct. */ FontAttributes *wantPtr, /* Contains desired actual pixel-size if the * best font was scalable. */ char **nameList, /* Array of XLFDs. */ int bestIdx[2], /* Indices into above array for XLFD of best * bitmapped and best scalable font. */ unsigned bestScore[2]) /* Scores of best bitmapped and best scalable * font. XLFD corresponding to lowest score * will be constructed. */ { XFontStruct *fontStructPtr; if ((bestIdx[0] < 0) && (bestIdx[1] < 0)) { return NULL; } /* * Now we know which is the closest matching scalable font and the closest * matching bitmapped font. If the scalable font was a better match, try * getting the scalable font; however, if the scalable font was not * actually available in the desired pointsize, fall back to the closest * bitmapped font. */ fontStructPtr = NULL; if (bestScore[1] < bestScore[0]) { char *str, *rest, buf[256]; int i; /* * Fill in the desired pixel size for this font. */ tryscale: str = nameList[bestIdx[1]]; for (i = 0; i < XLFD_PIXEL_SIZE; i++) { str = strchr(str + 1, '-'); } rest = str; for (i = XLFD_PIXEL_SIZE; i < XLFD_CHARSET; i++) { rest = strchr(rest + 1, '-'); } *str = '\0'; sprintf(buf, "%.200s-%d-*-*-*-*-*%s", nameList[bestIdx[1]], -wantPtr->fa.size, rest); *str = '-'; fontStructPtr = XLoadQueryFont(display, buf); bestScore[1] = INT_MAX; } if (fontStructPtr == NULL) { fontStructPtr = XLoadQueryFont(display, nameList[bestIdx[0]]); if (fontStructPtr == NULL) { /* * This shouldn't happen because the font name is one of the names * that X gave us to use, but it does anyhow. */ if (bestScore[1] < INT_MAX) { goto tryscale; } return GetSystemFont(display); } } return fontStructPtr; } /* *--------------------------------------------------------------------------- * * GetSystemFont -- * * Absolute fallback mechanism, called when we need a font and no other * font can be found and/or instantiated. * * Results: * A pointer to a font. Never NULL. * * Side effects: * If there are NO fonts installed on the system, this call will panic, * but how did you get X running in that case? * *--------------------------------------------------------------------------- */ static XFontStruct * GetSystemFont( Display *display) /* Display for new XFontStruct. */ { XFontStruct *fontStructPtr; fontStructPtr = XLoadQueryFont(display, "fixed"); if (fontStructPtr == NULL) { fontStructPtr = XLoadQueryFont(display, "*"); if (fontStructPtr == NULL) { Tcl_Panic("TkpGetFontFromAttributes: cannot get any font"); } } return fontStructPtr; } /* *--------------------------------------------------------------------------- * * GetFontAttributes -- * * Given a screen font, determine its actual attributes, which are not * necessarily the attributes that were used to construct it. * * Results: * *faPtr is filled with the screen font's attributes. * * Side effects: * None. * *--------------------------------------------------------------------------- */ static int GetFontAttributes( Display *display, /* Display that owns the screen font. */ XFontStruct *fontStructPtr, /* Screen font to query. */ FontAttributes *faPtr) /* For storing attributes of screen font. */ { unsigned long value; char *name; if ((XGetFontProperty(fontStructPtr, XA_FONT, &value) != False) && (value != 0)) { name = XGetAtomName(display, (Atom) value); if (TkFontParseXLFD(name, &faPtr->fa, &faPtr->xa) != TCL_OK) { faPtr->fa.family = Tk_GetUid(name); faPtr->xa.foundry = Tk_GetUid(""); faPtr->xa.charset = Tk_GetUid(""); } XFree(name); } else { TkInitFontAttributes(&faPtr->fa); TkInitXLFDAttributes(&faPtr->xa); } /* * Do last ditch check for family. It seems that some X servers can fail * on the X font calls above, slipping through earlier checks. X-Win32 5.4 * is one of these. */ if (faPtr->fa.family == NULL) { faPtr->fa.family = Tk_GetUid(""); faPtr->xa.foundry = Tk_GetUid(""); faPtr->xa.charset = Tk_GetUid(""); } return IdentifySymbolEncodings(faPtr); } /* *--------------------------------------------------------------------------- * * ListFonts -- * * Utility function to return the array of all XLFDs on the system with * the specified face name. * * Results: * The return value is an array of XLFDs, which should be freed with * XFreeFontNames(), or NULL if no XLFDs matched the requested name. * * Side effects: * None. * *--------------------------------------------------------------------------- */ static char ** ListFonts( Display *display, /* Display to query. */ const char *faceName, /* Desired face name, or "*" for all. */ int *numNamesPtr) /* Filled with length of returned array, or 0 * if no names were found. */ { char buf[256]; sprintf(buf, "-*-%.80s-*-*-*-*-*-*-*-*-*-*-*-*", faceName); return XListFonts(display, buf, 10000, numNamesPtr); } static char ** ListFontOrAlias( Display *display, /* Display to query. */ const char *faceName, /* Desired face name, or "*" for all. */ int *numNamesPtr) /* Filled with length of returned array, or 0 * if no names were found. */ { char **nameList; const char *const *aliases; int i; nameList = ListFonts(display, faceName, numNamesPtr); if (nameList != NULL) { return nameList; } aliases = TkFontGetAliasList(faceName); if (aliases != NULL) { for (i = 0; aliases[i] != NULL; i++) { nameList = ListFonts(display, aliases[i], numNamesPtr); if (nameList != NULL) { return nameList; } } } *numNamesPtr = 0; return NULL; } /* *--------------------------------------------------------------------------- * * IdentifySymbolEncodings -- * * If the font attributes refer to a symbol font, update the charset * field of the font attributes so that it reflects the encoding of that * symbol font. In general, the raw value for the charset field parsed * from an XLFD is meaningless for symbol fonts. * * Symbol fonts are all fonts whose name appears in the symbolClass. * * Results: * The return value is non-zero if the font attributes specify a symbol * font, or 0 otherwise. If a non-zero value is returned the charset * field of the font attributes will be changed to the string that * represents the actual encoding for the symbol font. * * Side effects: * None. * *--------------------------------------------------------------------------- */ static int IdentifySymbolEncodings( FontAttributes *faPtr) { int i, j; const char *const *aliases; const char *const *symbolClass; symbolClass = TkFontGetSymbolClass(); for (i = 0; symbolClass[i] != NULL; i++) { if (strcasecmp(faPtr->fa.family, symbolClass[i]) == 0) { faPtr->xa.charset = Tk_GetUid(GetEncodingAlias(symbolClass[i])); return 1; } aliases = TkFontGetAliasList(symbolClass[i]); for (j = 0; (aliases != NULL) && (aliases[j] != NULL); j++) { if (strcasecmp(faPtr->fa.family, aliases[j]) == 0) { faPtr->xa.charset = Tk_GetUid(GetEncodingAlias(aliases[j])); return 1; } } } return 0; } /* *--------------------------------------------------------------------------- * * GetEncodingAlias -- * * Map the name of an encoding to another name that should be used when * actually loading the encoding. For instance, the encodings * "jisc6226.1978", "jisx0208.1983", "jisx0208.1990", and "jisx0208.1996" * are well-known names for the same encoding and are represented by one * encoding table: "jis0208". * * Results: * As above. If the name has no alias, the original name is returned. * * Side effects: * None. * *--------------------------------------------------------------------------- */ static const char * GetEncodingAlias( const char *name) /* The name to look up. */ { EncodingAlias *aliasPtr; for (aliasPtr = encodingAliases; aliasPtr->aliasPattern != NULL; ) { if (Tcl_StringMatch(name, aliasPtr->aliasPattern)) { return aliasPtr->realName; } aliasPtr++; } return name; } /* *--------------------------------------------------------------------------- * * TkDrawAngledChars -- * * Draw some characters at an angle. This is awkward here because we have * no reliable way of drawing any characters at an angle in classic X11; * we have to draw on a Pixmap which is converted to an XImage (from * helper function GetImageOfText), rotate the image (hokey code!) onto * another XImage (from helper function InitDestImage), and then use the * rotated image as a mask when drawing. This is pretty awful; improved * versions are welcomed! * * Results: * None. * * Side effects: * Target drawable is updated. * *--------------------------------------------------------------------------- */ static inline XImage * GetImageOfText( Display *display, /* Display on which to draw. */ Drawable drawable, /* Window or pixmap in which to draw. */ Tk_Font tkfont, /* Font in which characters will be drawn. */ const char *source, /* UTF-8 string to be displayed. Need not be * '\0' terminated. All Tk meta-characters * (tabs, control characters, and newlines) * should be stripped out of the string that * is passed to this function. If they are not * stripped out, they will be displayed as * regular printing characters. */ int numBytes, /* Number of bytes in string. */ int *realWidthPtr, int *realHeightPtr) { int width, height; TkFont *fontPtr = (TkFont *) tkfont; Pixmap bitmap; GC bitmapGC; XGCValues values; XImage *image; (void) Tk_MeasureChars(tkfont, source, numBytes, -1, 0, &width); height = fontPtr->fm.ascent + fontPtr->fm.descent; bitmap = Tk_GetPixmap(display, drawable, width, height, 1); values.graphics_exposures = False; values.foreground = BlackPixel(display, DefaultScreen(display)); bitmapGC = XCreateGC(display, bitmap, GCGraphicsExposures|GCForeground, &values); XFillRectangle(display, bitmap, bitmapGC, 0, 0, width, height); values.font = Tk_FontId(tkfont); values.foreground = WhitePixel(display, DefaultScreen(display)); values.background = BlackPixel(display, DefaultScreen(display)); XChangeGC(display, bitmapGC, GCFont|GCForeground|GCBackground, &values); Tk_DrawChars(display, bitmap, bitmapGC, tkfont, source, numBytes, 0, fontPtr->fm.ascent); XFreeGC(display, bitmapGC); image = XGetImage(display, bitmap, 0, 0, width, height, AllPlanes, ZPixmap); Tk_FreePixmap(display, bitmap); *realWidthPtr = width; *realHeightPtr = height; return image; } static inline XImage * InitDestImage( Display *display, Drawable drawable, int width, int height, Pixmap *bitmapPtr) { Pixmap bitmap; XImage *image; GC bitmapGC; XGCValues values; bitmap = Tk_GetPixmap(display, drawable, width, height, 1); values.graphics_exposures = False; values.foreground = BlackPixel(display, DefaultScreen(display)); bitmapGC = XCreateGC(display, bitmap, GCGraphicsExposures|GCForeground, &values); XFillRectangle(display, bitmap, bitmapGC, 0, 0, width, height); XFreeGC(display, bitmapGC); image = XGetImage(display, bitmap, 0, 0, width, height, AllPlanes, ZPixmap); *bitmapPtr = bitmap; return image; } void TkDrawAngledChars( Display *display, /* Display on which to draw. */ Drawable drawable, /* Window or pixmap in which to draw. */ GC gc, /* Graphics context for drawing characters. */ Tk_Font tkfont, /* Font in which characters will be drawn; * must be the same as font used in GC. */ const char *source, /* UTF-8 string to be displayed. Need not be * '\0' terminated. All Tk meta-characters * (tabs, control characters, and newlines) * should be stripped out of the string that * is passed to this function. If they are not * stripped out, they will be displayed as * regular printing characters. */ int numBytes, /* Number of bytes in string. */ double x, double y, double angle) { if (angle == 0.0) { Tk_DrawChars(display, drawable, gc, tkfont, source, numBytes, x, y); } else { double sinA = sin(angle * PI/180.0), cosA = cos(angle * PI/180.0); int bufHeight, bufWidth, srcWidth, srcHeight, i, j, dx, dy; Pixmap buf; XImage *srcImage = GetImageOfText(display, drawable, tkfont, source, numBytes, &srcWidth, &srcHeight); XImage *dstImage; enum {Q0=1,R1,Q1,R2,Q2,R3,Q3} quadrant; GC bwgc, cpgc; XGCValues values; int ascent = ((TkFont *) tkfont)->fm.ascent; /* * First, work out what quadrant we are operating in. We also handle * the rectilinear rotations as special cases. Conceptually, there's * also R0 (angle == 0.0) but that has been already handled as a * special case above. * * R1 * Q1 | Q0 * | * R2 ----+---- R0 * | * Q2 | Q3 * R3 */ if (angle < 90.0) { quadrant = Q0; } else if (angle == 90.0) { quadrant = R1; } else if (angle < 180.0) { quadrant = Q1; } else if (angle == 180.0) { quadrant = R2; } else if (angle < 270.0) { quadrant = Q2; } else if (angle == 270.0) { quadrant = R3; } else { quadrant = Q3; } if (srcImage == NULL) { return; } bufWidth = srcWidth*fabs(cosA) + srcHeight*fabs(sinA); bufHeight = srcHeight*fabs(cosA) + srcWidth*fabs(sinA); dstImage = InitDestImage(display, drawable, bufWidth,bufHeight, &buf); if (dstImage == NULL) { Tk_FreePixmap(display, buf); XDestroyImage(srcImage); return; } /* * Do the rotation, setting or resetting pixels in the destination * image dependent on whether the corresponding pixel (after rotation * to source image space) is set. */ for (i=0 ; i<srcWidth ; i++) { for (j=0 ; j<srcHeight ; j++) { switch (quadrant) { case Q0: dx = ROUND16(i*cosA + j*sinA); dy = ROUND16(j*cosA + (srcWidth - i)*sinA); break; case R1: dx = j; dy = srcWidth - i; break; case Q1: dx = ROUND16((i - srcWidth)*cosA + j*sinA); dy = ROUND16((srcWidth-i)*sinA + (j-srcHeight)*cosA); break; case R2: dx = srcWidth - i; dy = srcHeight - j; break; case Q2: dx = ROUND16((i-srcWidth)*cosA + (j-srcHeight)*sinA); dy = ROUND16((j - srcHeight)*cosA - i*sinA); break; case R3: dx = srcHeight - j; dy = i; break; default: dx = ROUND16(i*cosA + (j - srcHeight)*sinA); dy = ROUND16(j*cosA - i*sinA); } if (dx < 0 || dy < 0 || dx >= bufWidth || dy >= bufHeight) { continue; } XPutPixel(dstImage, dx, dy, XGetPixel(dstImage,dx,dy) | XGetPixel(srcImage,i,j)); } } XDestroyImage(srcImage); /* * Schlep the data back to the Xserver. */ values.function = GXcopy; values.foreground = WhitePixel(display, DefaultScreen(display)); values.background = BlackPixel(display, DefaultScreen(display)); bwgc = XCreateGC(display, buf, GCFunction|GCForeground|GCBackground, &values); XPutImage(display, buf, bwgc, dstImage, 0,0, 0,0, bufWidth,bufHeight); XFreeGC(display, bwgc); XDestroyImage(dstImage); /* * Calculate where we want to draw the text. */ switch (quadrant) { case Q0: dx = x; dy = y - srcWidth*sinA; break; case R1: dx = x; dy = y - srcWidth; break; case Q1: dx = x + srcWidth*cosA; dy = y + srcHeight*cosA - srcWidth*sinA; break; case R2: dx = x - srcWidth; dy = y - srcHeight; break; case Q2: dx = x + srcWidth*cosA + srcHeight*sinA; dy = y + srcHeight*cosA; break; case R3: dx = x - srcHeight; dy = y; break; default: dx = x + srcHeight*sinA; dy = y; } /* * Apply a correction to deal with the fact that we aren't told to * draw from our top-left corner but rather from the left-end of our * baseline. */ dx -= ascent*sinA; dy -= ascent*cosA; /* * Transfer the text to the screen. This is done by using it as a mask * and then drawing through that mask with the original drawing color. */ values.function = GXcopy; values.fill_style = FillSolid; values.clip_mask = buf; values.clip_x_origin = dx; values.clip_y_origin = dy; cpgc = XCreateGC(display, drawable, GCFunction|GCFillStyle|GCClipMask|GCClipXOrigin|GCClipYOrigin, &values); XCopyGC(display, gc, GCForeground, cpgc); XFillRectangle(display, drawable, cpgc, dx, dy, bufWidth, bufHeight); XFreeGC(display, cpgc); Tk_FreePixmap(display, buf); return; } } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */