1 # main.tcl --
2 #
3 # This is the main entry point for the mps tool.
4 # Tcl source code expansion with tcl-expand.tcl starts here.
5 # Tcl execution also starts here.
6 #
7 # Copyright (c) 1997-2002 The Regents of the University of California.
8 # All rights reserved.
9 #
10 # Redistribution and use in source and binary forms, with or without
11 # modification, are permitted provided that the following conditions are met:
12 #
13 # A. Redistributions of source code must retain the above copyright notice,
14 # this list of conditions and the following disclaimer.
15 # B. Redistributions in binary form must reproduce the above copyright notice,
16 # this list of conditions and the following disclaimer in the documentation
17 # and/or other materials provided with the distribution.
18 # C. Neither the names of the copyright holders nor the names of its
19 # contributors may be used to endorse or promote products derived from this
20 # software without specific prior written permission.
21 #
22 # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS IS''
23 # AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
24 # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
25 # ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR
26 # ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
27 # DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
28 # SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
29 # CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
30 # OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
31 # OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
32
33 source tcl/mps/gs.tcl
34
35 #FIXME
36 proc havefont args { return 1 }
37
38 #
39 # We want these resources to override user defaults
40 # (the option command's "userDefault" priority is 60)
41 # We do this for a consistent user inteface "look".
42 # Too often, people define *background and *foreground
43 # in their X resources, which gives bad results with tk.
44 #
45 option add *background gray80 61
46 option add *foreground black 61
47 option add *activeBackground gray95 61
48 option add *selectBackground gray95 61
49 option add *Scale.sliderForeground gray66 61
50 option add *Scale.activeForeground gray80 61
51 #option add *Scale.background gray70 61
52 option add *Scrollbar.foreground gray80 61
53 option add *Scrollbar.activeForeground gray70 61
54 option add *disabledForeground gray40
55
56 option add *Radiobutton.relief flat startupFile
57
58 #
59 # These can be overridden.
60 #
61 option add Tkgs.iconPrefix tkgs: startupFile
62 option add Tkgs.foundry adobe startupFile
63
64 #FIXME not fully tested
65 proc mapf f {
66 if { ! [havefont $f] } {
67 set i [string first 75 $f]
68 set f [string range $f 0 [expr $i - 1]]*-*-*-*-*-*
69 }
70 return $f
71 }
72 set ff [option get . foundry Tkgs]
73 set helv10 [mapf "-$ff-helvetica-medium-r-normal--*-100-75-75-*-*-*-*"]
74 set helv10b [mapf "-$ff-helvetica-bold-r-normal--*-100-75-75-*-*-*-*"]
75 set helv10o [mapf "-$ff-helvetica-bold-o-normal--*-100-75-75-*-*-*-*"]
76 set helv12 [mapf "-$ff-helvetica-medium-r-normal--*-120-75-75-*-*-*-*"]
77 set helv12b [mapf "-$ff-helvetica-bold-r-normal--*-120-75-75-*-*-*-*"]
78 set helv14 [mapf "-$ff-helvetica-medium-r-normal--*-140-75-75-*-*-*-*"]
79 set helv14b [mapf "-$ff-helvetica-bold-r-normal--*-140-75-75-*-*-*-*"]
80 set times14 [mapf "-$ff-times-medium-r-normal--*-140-75-75-*-*-*-*"]
81
82 option add *Font $helv12b startupFile
83 option add Tkgs.disablefont $helv10o
84 option add Tkgs.smallfont $helv10b
85 option add Tkgs.medfont $helv12b startupFile
86 option add Tkgs.helpFont $times14 startupFile
87 option add Tkgs.entryFont $helv10 startupFile
88
89 proc smallfont {} {
90 #FIXME
91 return fixed
92 }
93
94 proc build.bar w {
95 global title
96 frame $w.bar
97 label $w.bar.title -text "mps v[version]" -font [smallfont]\
98 -background gray -borderwidth 2 -relief raised
99 button $w.bar.quit -text Quit -borderwidth 2 -relief raised \
100 -background gray -font [smallfont] -command "quit"
101 button $w.bar.menu -text Menu -borderwidth 2 -relief raised \
102 -background gray -font [smallfont] \
103 -command "toggle_window .menu"
104 button $w.bar.help -text Help -borderwidth 2 -relief raised \
105 -background gray -font [smallfont] \
106 -command "toggle_window .help"
107
108 pack $w.bar.title -side left -fill x -expand 1
109 pack $w.bar.menu $w.bar.help $w.bar.quit -side left
110 }
111
112 #
113 # Build the user-interface.
114 #
115 proc build.tk { } {
116 # global prefix
117 # set prefix [option get . iconPrefix Tkgs]
118 #wm iconname . $prefix$conf
119 #wm title . $conf
120
121 . configure -background [option get . background Tkgs]
122 #
123 # emulate implicit keyboard focus
124 #
125 bind . <Enter> { focus %W }
126 #wm focusmodel . active
127 bind . <q> { quit }
128 bind . <Control-c> { quit }
129 bind . <Control-d> { quit }
130
131 frame .top
132 set pswin [new PostscriptWindow .top.wb]
133 set gs [new GPSinterp $pswin]
134 pack .top.wb -fill both -side bottom -expand 1
135 pack .top -expand 1 -fill both
136
137 #
138 # Withdraw window so that user-placement is deferred
139 # until after initial geometry is computed
140 #
141 wm withdraw .
142 wm geometry . 612x792
143
144 update idletasks
145 set minwidth [winfo reqwidth .]
146 set minheight [winfo reqheight .]
147 #FIXME
148 if { $minwidth < 200 || $minheight < 100 } {
149 set minwidth 200
150 set minheight 100
151 }
152 wm minsize . $minwidth $minheight
153 wm deiconify .
154
155 return $gs
156 }
157 if { $argc != 1 } {
158 puts stderr "usage: mps file"
159 exit 1
160 }
161 set psFile [open $argv r]
162 set psp [new DSC_Parser]
163 $psp set-file $psFile
164 set npage [$psp set npage_]
165 set pageNo 1
166 set tmpFile /tmp/mps.[pid].ps
167 proc nextPage {} {
168 global pageNo npage tmpFile psp gs
169 if { $pageNo > $npage } {
170 quit
171 }
172 set f [open $tmpFile w]
173 puts "Page $pageNo"
174 # dump preamble then current page.
175 # (but not for page 1, which includes preamble!)
176 #FIXME need to fix this API
177 if { $pageNo > 1 } {
178 $psp dump 0 $f
179 }
180 $psp dump $pageNo $f
181 close $f
182 $gs render-file $tmpFile
183 incr pageNo
184 }
185 proc quit {} {
186 global gs
187 delete $gs
188 exit 0
189 }
190
191 set gs [build.tk]
192 update
193 $gs fork
194 #quit
195 bind all <Return> nextPage
196
This page was automatically generated by the
LXR engine.
Visit the LXR main site for more
information.