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
|
;
; module providing gwave commands and dialogs for exporting data
;
(define-module (app gwave export)
:use-module (gtk gtk)
:use-module (ice-9 optargs)
:use-module (app gwave cmds)
:use-module (app gwave gtk-helpers)
)
(read-set! keywords 'prefix)
(debug-enable 'backtrace)
(debug-enable 'debug)
; list of registered plot filters. each entry is a 3-element list:
; (name dialog-builder-procedure do-plot-procedure)
(define plot-list '())
;; Register a new plot-filter module to appear in the plot dialog box.
;; plot filter modules will call this to register themselves.
(define-public (register-plotfilter name dproc eproc)
(set! plot-list (cons
(list name dproc eproc #f)
plot-list)))
; debug: dump export filter list
(define (dump-plotf-list)
(format #t "plot-list:\n")
(for-each (lambda (exptype)
(format #t " name=~s " (car exptype))
(format #t "dproc=~s\n" (cadr exptype))
(format #t " eproc=~s\n" (caddr exptype)))
plot-list))
;; Export the data from a list of visiblewaves to a named file.
(define (export-variables-to-file f vwlist . ext)
(let ((p (open f (logior O_WRONLY O_CREAT O_TRUNC) #o0777)))
; (print "ext is " ext "\n");
(if (null? ext)
(export-variables vwlist p)
(export-variables vwlist p (car ext) (cadr ext)))
(close-port p)
))
;; Pop up the plotting dialog box
(define-public (popup-export-dialog wvlist)
(let* ((window (gtk-window-new 'toplevel))
(vbox (gtk-vbox-new #f 0))
(hbox1 (gtk-hbox-new #f 10))
(outf-label (gtk-label-new "Output File:"))
(filename-entry (gtk-entry-new))
(browse-btn (gtk-button-new-with-label "Browse"))
(hbox2 (gtk-hbox-new #f 10))
(use-extents #f)
(minx 0.0)
(maxx 1.0)
(extents-group #f)
(action-hbox (gtk-hbox-new #f 10))
(separator (gtk-hseparator-new))
(cancel-btn (gtk-button-new-with-label "Cancel"))
(export-btn (gtk-button-new-with-label "Export"))
)
(gtk-window-set-title window "Export Data")
(gtk-container-border-width window 0)
(gtk-container-add window vbox)
(gtk-widget-show vbox)
(gtk-container-border-width hbox1 10)
(gtk-box-pack-start vbox hbox1 #f #t 0)
(gtk-widget-show hbox1)
(gtk-box-pack-start hbox1 outf-label #f #t 0)
(gtk-widget-show outf-label)
(gtk-box-pack-start hbox1 filename-entry #f #t 0)
(gtk-widget-show filename-entry)
(gtk-entry-set-text filename-entry "gwexport.dat")
(gtk-box-pack-start hbox1 browse-btn #f #t 0)
(gtk-signal-connect browse-btn "clicked"
(lambda ()
(with-selected-filename
"Export to file"
(lambda (f)
(gtk-entry-set-text filename-entry f))
#:default (gtk-entry-get-text filename-entry))))
(gtk-widget-show browse-btn)
; row of buttons for x-extents to export
(gtk-container-border-width hbox2 10)
(gtk-box-pack-start vbox hbox2 #f #t 0)
(gtk-widget-show hbox2)
(set! extents-group (add-radio-button
hbox2 extents-group "All" #t
(lambda ()
(display "setting all\n")
(set! use-extents #f))))
(set! extents-group (add-radio-button
hbox2 extents-group "Visible" #f
(lambda ()
(display "setting visible\n")
(set! use-extents #t)
(set! minx (wtable-start-xval))
(set! maxx (wtable-end-xval)))))
(set! extents-group (add-radio-button
hbox2 extents-group "Between Cursors" #f
(lambda ()
(display "setting tween-cursor\n")
(set! use-extents #t)
(set! minx (wtable-vcursor 0))
(set! maxx (wtable-vcursor 1)))))
; row of action buttons
(gtk-container-border-width action-hbox 10)
(gtk-box-pack-start vbox action-hbox #f #t 0)
(gtk-widget-show action-hbox)
(gtk-signal-connect cancel-btn "clicked"
(lambda ()
(gtk-widget-destroy window)))
(gtk-box-pack-start action-hbox cancel-btn #t #t 0)
(gtk-widget-show cancel-btn)
(gtk-tooltips-set-tip gwave-tooltips cancel-btn
"Cancel export and close window" "")
(gtk-box-pack-start action-hbox export-btn #t #t 0)
(gtk-signal-connect export-btn "clicked"
(lambda ()
(if (and use-extents (number? minx) (number? maxx))
(export-variables-to-file
(gtk-entry-get-text filename-entry)
wvlist minx maxx)
(export-variables-to-file
(gtk-entry-get-text filename-entry) wvlist))
(gtk-widget-destroy window)))
(gtk-widget-show export-btn)
(gtk-tooltips-set-tip gwave-tooltips export-btn
"Export data" "")
(gtk-widget-set-flags export-btn '(can-default))
(gtk-widget-grab-default export-btn)
(gtk-widget-show window)
))
(define-public (popup-plot-dialog plist)
(let* ((window (gtk-window-new 'toplevel))
(vbox (gtk-vbox-new #f 0))
(hbox1 (gtk-hbox-new #f 10))
(outf-label (gtk-label-new "Output File:"))
(filename-entry (gtk-entry-new))
(browse-btn (gtk-button-new-with-label "Browse"))
(hbox2 (gtk-hbox-new #f 10))
(tmpfcheck (gtk-check-button-new-with-label "Keep Tempfiles"))
(notebook (gtk-notebook-new))
(plot-options '())
(action-hbox (gtk-hbox-new #f 10))
(separator (gtk-hseparator-new))
(cancel-btn (gtk-button-new-with-label "Cancel"))
(export-btn (gtk-button-new-with-label "Plot"))
(oproc-assoc '())
)
(gtk-window-set-title window "Plot Data")
(gtk-container-border-width window 0)
(gtk-container-add window vbox)
(gtk-widget-show vbox)
(gtk-container-border-width hbox1 10)
(gtk-box-pack-start vbox hbox1 #f #t 0)
(gtk-widget-show hbox1)
(gtk-box-pack-start hbox1 outf-label #f #t 0)
(gtk-widget-show outf-label)
(gtk-box-pack-start hbox1 filename-entry #f #t 0)
(gtk-widget-show filename-entry)
(gtk-entry-set-text filename-entry "gwplot.dat")
(gtk-box-pack-start hbox1 browse-btn #f #t 0)
(gtk-signal-connect browse-btn "clicked"
(lambda ()
(with-selected-filename
"Plot to file"
(lambda (f)
(gtk-entry-set-text filename-entry f))
#:default (gtk-entry-get-text filename-entry))))
(gtk-widget-show browse-btn)
; notebook with entry for each supported plot filter
; containing that filter's various options
(gtk-notebook-set-tab-pos notebook 'top)
(gtk-box-pack-start vbox notebook #t #t 0)
; (dump-plotf-list)
(for-each (lambda (exptype)
(let* ((panelproc ( (cadr exptype) ))
(panel (car panelproc))
(optproc (cadr panelproc))
(plotproc (caddr exptype))
(label (gtk-label-new (car exptype))))
(gtk-notebook-append-page notebook panel label)
; associate options-procedure with plot-procedure so we can
; look up the right one based on the active
; notebook tab when the go button is clicked
(set! oproc-assoc (assoc-set! oproc-assoc plotproc optproc))
))
plot-list)
; (format #t "oproc-assoc:~s\n" oproc-assoc)
; put up somthing helpful if there are no plot modules registered
(if (= 0 (length plot-list))
(let ((vbox (gtk-vbox-new #f 0))
(label1 (gtk-label-new "No plot backend"))
(label2 (gtk-label-new "No plot filter modules have been loaded")) (label3 (gtk-label-new "by .gwaverc or system.gwaverc"))
)
(gtk-widget-show vbox)
(gtk-widget-show label1)
(gtk-widget-show label2)
(gtk-widget-show label3)
(gtk-box-pack-start vbox label2 #t #t 0)
(gtk-box-pack-start vbox label3 #t #t 0)
(gtk-notebook-append-page notebook vbox label1)))
(gtk-widget-show notebook)
; general options
(gtk-box-pack-start hbox2 tmpfcheck #f #t 0)
(gtk-widget-show tmpfcheck)
(gtk-widget-show hbox2)
(gtk-box-pack-start vbox hbox2 #t #t 0)
; row of action buttons
(gtk-container-border-width action-hbox 10)
(gtk-box-pack-start vbox action-hbox #f #t 0)
(gtk-widget-show action-hbox)
(gtk-signal-connect cancel-btn "clicked"
(lambda ()
(gtk-widget-destroy window)))
(gtk-box-pack-start action-hbox cancel-btn #t #t 0)
(gtk-tooltips-set-tip gwave-tooltips cancel-btn
"Cancel export and close window" "")
(gtk-widget-show cancel-btn)
(gtk-box-pack-start action-hbox export-btn #t #t 0)
(gtk-tooltips-set-tip gwave-tooltips export-btn "Plot data" "")
(gtk-signal-connect export-btn "clicked"
(lambda ()
(let* ((n (gtk-notebook-get-current-page notebook))
(pp (if (>= n 0)
(caddr (list-ref plot-list n))
#f))
(op (assoc-ref oproc-assoc pp))
(optlist (if (procedure? op) (op) (list))))
; (format #t "plot filter ~d ~s ~s\n" n op pp)
; (format #t "opts: ~s\n" optlist)
(if (procedure? pp)
(pp
(gtk-entry-get-text filename-entry)
plist optlist
(gtk-toggle-button-active tmpfcheck))))
(gtk-widget-destroy window)))
(if (= 0 (length plot-list))
(gtk-widget-set-sensitive export-btn #f))
(gtk-widget-show export-btn)
(gtk-widget-set-flags export-btn '(can-default))
(gtk-widget-grab-default export-btn)
(gtk-widget-show window)
))
;; run a command in a subprocess, redirecting its output to a named file.
(define-public (subprocess-to-file f cmd arglist)
(let ((port (if f
(open f (logior O_WRONLY O_CREAT O_TRUNC) #o0777)
#f))
(null (open "/dev/null" O_RDONLY 0)))
(if gwave-debug
(format #t "subprocess-to-file ~a ~s\n" cmd arglist))
(flush-all-ports)
; TODO: search for and stat cmd to make sure it exists and is executable.
(let ((p (primitive-fork)))
(cond ((< p 0)
; error
(error "fork"))
((eq? 0 p)
; child
(if port
(redirect-port port (current-output-port)))
(redirect-port null (current-input-port))
(close-all-ports-except (current-input-port)
(current-output-port)
(current-error-port))
(false-if-exception
(begin
(apply execlp cmd arglist)
(primitive-exit 127)))
)
(else
; parent
(if port
(close port))
(if gwave-debug
(format #t "child process ~d started for ~a ~s\n" p cmd arglist))
(reap-child)
)))))
(define (reap-child)
(let* ((w (catch 'system-error
(lambda () (waitpid 0 WNOHANG))
(lambda (func . stuff) (cons 0 #f))))
(pid (car w))
(st (cdr w)))
(if (not (eq? 0 pid))
(begin
(format #t "process ~d" pid)
(if (status:exit-val st)
(format #t " exited (~d)" (status:exit-val st)))
(if (status:term-sig st)
(format #t " terminated on signal ~d" (status:term-sig st)))
(if (status:stop-sig st)
(format #t " stopped on signal~d" (status:exit-sig st)))
(display "\n"))
;(display "no child\n")
)))
(dbprint "setting SIGCHLD handler\n")
;(display (sigaction SIGCHLD (lambda (s) (reap-child)))) (newline)
;(display (sigaction SIGCHLD)) (newline)
(dbprint "export.scm done")
|
