1 # gs.tcl --
2 #
3 # FIXME: This file needs a description here.
4 #
5 # Copyright (c) 1997-2002 The Regents of the University of California.
6 # All rights reserved.
7 #
8 # Redistribution and use in source and binary forms, with or without
9 # modification, are permitted provided that the following conditions are met:
10 #
11 # A. Redistributions of source code must retain the above copyright notice,
12 # this list of conditions and the following disclaimer.
13 # B. Redistributions in binary form must reproduce the above copyright notice,
14 # this list of conditions and the following disclaimer in the documentation
15 # and/or other materials provided with the distribution.
16 # C. Neither the names of the copyright holders nor the names of its
17 # contributors may be used to endorse or promote products derived from this
18 # software without specific prior written permission.
19 #
20 # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS IS''
21 # AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
22 # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
23 # ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR
24 # ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
25 # DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
26 # SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
27 # CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
28 # OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
29 # OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
30 #
31 # @(#) $Header: /usr/mash/src/repository/mash/mash-1/tcl/mps/gs.tcl,v 1.11 2002/02/03 04:27:59 lim Exp $
32
33
34 Class GPSinterp
35
36 GPSinterp instproc fork {} {
37 #
38 # Here's where we hook into the ghostview protocol
39 # to pass an X window to ghostscript.
40 # We bind the window ID to the environment
41 # variable GHOSTVIEW. We then pass a bunch of
42 # information to ghostscript via the "GHOSTVIEW"
43 # property on the window indicated here. One of
44 # these attributes is the Drawable, in our case a
45 # pixmap ID. This is handled in setup-property().
46 # This API is fragile to say the least.
47 #
48 $self instvar path_ pswin_ pipe_
49 set windowID [winfo id $path_]
50 set pixmapID [$pswin_ pixmap-id]
51 #
52 # setting the Tcl "env" var sets the appropricate value in C,
53 # so this value gets correctly transferred into the forked
54 # process' environment. The expr's convert 0x hex form to
55 # unsigned decimal.
56 #
57 global env
58 set env(GHOSTVIEW) "[expr $windowID] [expr $pixmapID]"
59 puts stderr "\$GHOSTVIEW = $env(GHOSTVIEW)"
60 # set env(DISPLAY) :0.0
61 $self setup-property
62 set failed [catch {
63 set pipe_ [open "|gs -dQUIET -dNOPAUSE -dSAFER -dNOPLATFONTS -" w]
64 }]
65
66 # set pipe_ [open "|gs -dNOPAUSE -dSAFER -dNOPLATFONTS -" w]
67 #
68 # Set non-blocking mode on the pipe so we don't hang if gs
69 # has a problem. We only ever write small snippets of
70 # ps to the pipe so writes should never block anyway.
71 # (The snippets of ps code load the target code from a file.)
72 #
73 if !{$failed} { fconfigure $pipe_ -blocking false }
74 }
75
76 GPSinterp instproc init pswin {
77 $self instvar orient_ pswin_ path_
78 set orient_ 0
79
80 #FIXME for now create only a single ps-window
81
82 set pswin_ $pswin
83 set path_ [$pswin_ path]
84 }
85
86 GPSinterp instproc kill {} {
87 $self instvar pipe_
88 if [info exists pipe_] {
89 set pid [pid $pipe_]
90 $self dump "quit\n"
91 catch {flush $pipe_}
92
93 foreach p $pid {
94 # REVIEW:
95 # for now do this, have to take into account portability
96 # later
97 exec kill $p
98 }
99 catch "close $pipe_"
100 unset pipe_
101 }
102 }
103
104 GPSinterp instproc destroy {} {
105 $self instvar pswin_ pipe_
106 $pswin_ release
107 delete $pswin_
108 $self kill
109
110 #NOTE: need to comment out $self next here, otherwise Tcl will crash
111 #$self next
112 }
113
114 GPSinterp instproc dump msg {
115 $self instvar pipe_
116 puts $pipe_ $msg
117 }
118
119 GPSinterp instproc render-file f {
120 $self instvar pipe_ first_ pswin_ mwin_
121 if ![info exists pipe_] {
122 return
123 }
124 #FIXME FIX THIS
125 $pswin_ start
126 #
127 # Dump a chunk of postscript code to gs:
128 # - nullify $brkpage to avoid problematic "error recovery" code
129 # in framemaker-generated ps
130 # - save a snapshot of the VM in userdict
131 # - map "showpage" to "stop" so we halt the interpreter on the
132 # page boundary
133 # - interpret the file and catch the showpage/stop with
134 # the proc "stopped"
135 # - restore the interpreter state
136 #
137 $self dump [concat \
138 {userdict /$brkpage {} put
139 userdict /_$mash$save save put
140 userdict /_$realshowpage /showpage load put
141 userdict /showpage { stop } bind put } \
142 ($f) (r) file cvx stopped pop \
143 {_$realshowpage grestoreall clear cleardictstack _$mash$save restore}]
144 flush $pipe_
145 puts stderr "executing render-file $f"
146 }
147
148 #FIXME
149 GPSinterp instproc width {} {
150 $self instvar path_
151 return [winfo width $path_]
152 }
153
154 #FIXME
155 GPSinterp instproc height {} {
156 $self instvar path_
157 return [winfo height $path_]
158 }
159
160 GPSinterp instproc set-orientation o {
161 #FIXME
162 }
163
164 GPSinterp instproc setup-property {} {
165 $self instvar orient_ pswin_
166 $self instvar bbox_
167
168 if { [info exists bbox_] && "$bbox_"!="" } {
169 set w [expr [lindex $bbox_ 2] - [lindex $bbox_ 0]]
170 set h [expr [lindex $bbox_ 3] - [lindex $bbox_ 1]]
171 set xdpi [expr int(72*[$self width]/$w)]
172 set ydpi [expr int(72*[$self height]/$h)]
173 } else {
174 if $orient_ {
175 set w [$self height]
176 set h [$self width]
177 } else {
178 set w [$self width]
179 set h [$self height]
180 }
181 set scaledWidth [expr int(8.5 * 72 + 0.5)]
182 set scaledHeight [expr int(11 * 72 + 0.5)]
183 # FIXME assume 8.5in width
184
185 set xdpi [expr int($w / 8.5 - 0.5)]
186 set ydpi [expr int($h / 11 - 0.5 )]
187 }
188
189
190 #
191 # <BackingStoreFlag, Orientation, llx, lly, urx, ury, dpi, dpi>
192 # The bounding box coordinates are Postscript style (i.e.,
193 # in points, not pixels).
194 #
195 # use the bounding box if it is there, otherwise use width and height
196 if { [info exists bbox_] && "$bbox_"!="" } {
197 set s "0 $orient_ $bbox_ $xdpi $ydpi"
198 } else {
199 set s "0 $orient_ 0 0 $scaledWidth $scaledHeight $xdpi $ydpi"
200 }
201 puts $s
202 #set s "0 $orient_ 0 0 612 792 72 72"
203 $pswin_ set-atom GHOSTVIEW $s
204 }
205
206 #FIXME bad name - called when gs finishes rendering page
207 PostscriptWindow instproc recv-page w {
208 # force a redraw
209 $self damage
210 $self instvar mwin_ path_
211 set mwin_ $w
212 #FIXME our widget doesn't support tk configuration
213 [winfo parent $path_] configure -cursor ""
214 }
215
216 PostscriptWindow instproc init path {
217 $self next $path
218 $self instvar path_
219 set path_ $path
220 }
221
222 PostscriptWindow instproc path {} {
223 $self instvar path_
224 return $path_
225 }
226
227 PostscriptWindow instproc resize {} {
228 $self instvar path_
229 puts stderr "resize [winfo width $path_] [winfo height $path_]"
230 }
231
232 #
233 # Called to prime gs for the next page.
234 #
235 PostscriptWindow instproc start {} {
236 $self instvar path_
237 $self release
238 #FIXME our widget doesn't support tk configuration
239 puts [[winfo parent $path_] cget -cursor]
240 [winfo parent $path_] configure -cursor watch
241 }
242
243 PostscriptWindow instproc release {} {
244 $self instvar mwin_
245 if [info exists mwin_] {
246 #
247 # gs is wedged waiting for a NEXT event
248 # kick it loose!
249 #
250 puts stderr "calling next-page"
251 $self next-page $mwin_
252 unset mwin_
253 }
254 }
255
This page was automatically generated by the
LXR engine.
Visit the LXR main site for more
information.