scheme/export.scm

   1 ;
   2 ; module providing gwave commands and dialogs for exporting data
   3 ;
   4
   5 (define-module (app gwave export)
   6   :use-module (oop goops)
   7   :use-module (gnome-2)
   8   :use-module (gnome gtk)
   9   :use-module (ice-9 optargs)
  10   :use-module (app gwave cmds)
  11   :use-module (app gwave gtk-helpers)
  12 )
  13 (read-set! keywords 'prefix)
  14 (debug-enable 'backtrace)
  15 (debug-enable 'debug)
  16
  17 ; list of registered plot filters.  each entry is a 3-element list:
  18 ; (name dialog-builder-procedure do-plot-procedure)
  19 (define plot-list '())
  20
  21 ;; Register a new plot-filter module to appear in the plot dialog box.
  22 ;; plot filter modules will call this to register themselves.
  23 (define-public (register-plotfilter name dproc eproc)
  24   (set! plot-list (cons
  25                   (list name dproc eproc #f)
  26                   plot-list)))
  27
  28  ; debug: dump export filter list
  29 (define (dump-plotf-list)
  30     (format #t "plot-list:\n")
  31     (for-each (lambda (exptype)
  32                 (format #t " name=~s " (car exptype))
  33                 (format #t "dproc=~s\n" (cadr exptype))
  34                 (format #t " eproc=~s\n" (caddr exptype)))
  35               plot-list))
  36
  37 ;; Export the data from a list of visiblewaves to a named file.
  38 (define (export-variables-to-file f vwlist . ext)
  39  (let ((p (open f (logior O_WRONLY O_CREAT O_TRUNC) #o0777)))
  40 ;  (print "ext is " ext "\n");
  41    (if (null? ext)
  42           (export-variables vwlist p)
  43           (export-variables vwlist p (car ext) (cadr ext)))
  44    (close-port p)
  45    ))
  46
  47 ;; Pop up the plotting dialog box
  48 (define-public (popup-export-dialog wvlist)
  49   (let* ((window (gtk-window-new 'toplevel))
  50          (vbox (gtk-vbox-new #f 0))
  51          (hbox1 (gtk-hbox-new #f 10))
  52          (outf-label (gtk-label-new "Output File:"))
  53          (filename-entry (make <gtk-entry>))
  54          (browse-btn (gtk-button-new-with-label "Browse"))
  55
  56          (hbox2 (gtk-hbox-new #f 10))
  57          (use-extents #f)
  58          (minx 0.0)
  59          (maxx 1.0)
  60          (extents-group #f)
  61
  62          (action-hbox (gtk-hbox-new #f 10))
  63          (separator (gtk-hseparator-new))
  64          (cancel-btn (gtk-button-new-with-label "Cancel"))
  65          (export-btn (gtk-button-new-with-label "Export"))
  66          )
  67
  68     (gtk-window-set-title window "Export Data")
  69     (gtk-container-set-border-width window 0)
  70     (gtk-container-add window vbox)
  71     (gtk-widget-show vbox)
  72
  73     (gtk-container-set-border-width hbox1 10)
  74     (gtk-box-pack-start vbox hbox1 #f #t 0)
  75     (gtk-widget-show hbox1)
  76
  77     (gtk-box-pack-start hbox1 outf-label #f #t 0)
  78     (gtk-widget-show outf-label)
  79
  80     (gtk-box-pack-start hbox1 filename-entry #f #t 0)
  81     (gtk-widget-show filename-entry)
  82     (gtk-entry-set-text filename-entry "gwexport.dat")
  83
  84     (gtk-box-pack-start hbox1 browse-btn #f #t 0)
  85     (gtk-signal-connect browse-btn "clicked"
  86                         (lambda (b) ; TODO: use filechooserbutton
  87                           (with-selected-filename
  88                            "Export to file"
  89                            (lambda (f)
  90                              (gtk-entry-set-text filename-entry f))
  91                            #:default (gtk-entry-get-text filename-entry))))
  92     (gtk-widget-show browse-btn)
  93
  94     ; row of buttons for x-extents to export
  95     (gtk-container-set-border-width hbox2 10)
  96     (gtk-box-pack-start vbox hbox2 #f #t 0)
  97     (gtk-widget-show hbox2)
  98
  99     (set! extents-group (add-radio-button
 100                       hbox2 extents-group "All" #t
 101                       (lambda ()
 102                         (display "setting all\n")
 103                         (set! use-extents #f))))
 104     (set! extents-group (add-radio-button
 105                       hbox2 extents-group "Visible" #f
 106                       (lambda ()
 107                         (display "setting visible\n")
 108                         (set! use-extents #t)
 109                         (set! minx (wtable-start-xval))
 110                         (set! maxx (wtable-end-xval)))))
 111     (set! extents-group (add-radio-button
 112                       hbox2 extents-group "Between Cursors" #f
 113                       (lambda ()
 114                         (display "setting tween-cursor\n")
 115                         (set! use-extents #t)
 116                         (set! minx (wtable-vcursor 0))
 117                         (set! maxx (wtable-vcursor 1)))))
 118
 119     ; row of action buttons
 120     (gtk-container-set-border-width action-hbox 10)
 121     (gtk-box-pack-start vbox action-hbox #f #t 0)
 122     (gtk-widget-show action-hbox)
 123
 124     (gtk-signal-connect cancel-btn "clicked"
 125                         (lambda (b)
 126                           (gtk-widget-destroy window)))
 127     (gtk-box-pack-start action-hbox cancel-btn #t #t 0)
 128     (gtk-widget-show cancel-btn)
 129     (gtk-tooltips-set-tip gwave-tooltips cancel-btn
 130                           "Cancel export and close window" "")
 131
 132     (gtk-box-pack-start action-hbox export-btn #t #t 0)
 133     (gtk-signal-connect export-btn "clicked"
 134                         (lambda (b)
 135                           (if (and use-extents (number? minx) (number? maxx))
 136                               (export-variables-to-file
 137                                (gtk-entry-get-text filename-entry)
 138                                wvlist minx maxx)
 139                               (export-variables-to-file
 140                                (gtk-entry-get-text filename-entry) wvlist))
 141                           (gtk-widget-destroy window)))
 142     (gtk-widget-show export-btn)
 143     (gtk-tooltips-set-tip gwave-tooltips export-btn
 144                           "Export data" "")
 145
 146 ;    (gtk-widget-set-flags export-btn '(can-default))
 147     (gtk-widget-grab-default export-btn)
 148     (gtk-widget-show window)
 149 ))
 150
 151
 152 (define-public (popup-plot-dialog plist)
 153   (let* ((window (gtk-window-new 'toplevel))
 154          (vbox (gtk-vbox-new #f 0))
 155          (hbox1 (gtk-hbox-new #f 10))
 156          (outf-label (gtk-label-new "Output File:"))
 157          (filename-entry (make <gtk-entry>))
 158          (browse-btn (gtk-button-new-with-label "Browse"))
 159
 160          (hbox2 (gtk-hbox-new #f 10))
 161          (tmpfcheck (gtk-check-button-new-with-label "Keep Tempfiles"))
 162
 163          (notebook (gtk-notebook-new))
 164          (plot-options '())
 165
 166          (action-hbox (gtk-hbox-new #f 10))
 167          (separator (gtk-hseparator-new))
 168          (cancel-btn (gtk-button-new-with-label "Cancel"))
 169          (export-btn (gtk-button-new-with-label "Plot"
 170                                                 :flags 'can-default ))
 171          (oproc-assoc '())
 172          )
 173
 174     (gtk-window-set-title window "Plot Data")
 175     (gtk-container-set-border-width window 0)
 176     (gtk-container-add window vbox)
 177     (gtk-widget-show vbox)
 178
 179     (gtk-container-set-border-width hbox1 10)
 180     (gtk-box-pack-start vbox hbox1 #f #t 0)
 181     (gtk-widget-show hbox1)
 182
 183     (gtk-box-pack-start hbox1 outf-label #f #t 0)
 184     (gtk-widget-show outf-label)
 185
 186     (gtk-box-pack-start hbox1 filename-entry #f #t 0)
 187     (gtk-widget-show filename-entry)
 188     (gtk-entry-set-text filename-entry "gwplot.dat")
 189
 190     (gtk-box-pack-start hbox1 browse-btn #f #t 0)
 191     (gtk-signal-connect browse-btn "clicked"
 192                         (lambda (x)
 193                           (with-selected-filename
 194                            "Plot to file"
 195                            (lambda (f)
 196                              (gtk-entry-set-text filename-entry f))
 197                            #:default (gtk-entry-get-text filename-entry))))
 198     (gtk-widget-show browse-btn)
 199
 200     ; notebook with entry for each supported plot filter
 201     ; containing that filter's various options
 202     (gtk-notebook-set-tab-pos notebook 'top)
 203     (gtk-box-pack-start vbox notebook #t #t 0)
 204
 205 ;    (dump-plotf-list)
 206     (for-each (lambda (exptype)
 207                 (let* ((panelproc ( (cadr exptype) ))
 208                        (panel (car panelproc))
 209                        (optproc (cadr panelproc))
 210                        (plotproc (caddr exptype))
 211                        (label (gtk-label-new (car exptype))))
 212                   (gtk-notebook-append-page notebook panel label)
 213
 214                   ; associate options-procedure with plot-procedure so we can
 215                   ; look up the right one based on the active
 216                   ; notebook tab when the go button is clicked
 217                   (set! oproc-assoc (assoc-set! oproc-assoc plotproc optproc))
 218                   ))
 219               plot-list)
 220 ;    (format #t "oproc-assoc:~s\n" oproc-assoc)
 221
 222     ; put up somthing helpful if there are no plot modules registered
 223     (if (= 0 (length plot-list))
 224         (let ((vbox (gtk-vbox-new #f 0))
 225               (label1 (gtk-label-new "No plot backend"))
 226               (label2 (gtk-label-new "No plot filter modules have been loaded"))              (label3 (gtk-label-new "by .gwaverc or system.gwaverc"))
 227 )
 228           (gtk-widget-show vbox)
 229           (gtk-widget-show label1)
 230           (gtk-widget-show label2)
 231           (gtk-widget-show label3)
 232           (gtk-box-pack-start vbox label2 #t #t 0)
 233           (gtk-box-pack-start vbox label3 #t #t 0)
 234           (gtk-notebook-append-page notebook vbox label1)))
 235
 236     (gtk-widget-show notebook)
 237
 238     ; general options
 239     (gtk-box-pack-start hbox2 tmpfcheck #f #t 0)
 240     (gtk-widget-show tmpfcheck)
 241     (gtk-widget-show hbox2)
 242     (gtk-box-pack-start vbox hbox2 #t #t 0)
 243
 244     ; row of action buttons
 245     (gtk-container-set-border-width action-hbox 10)
 246     (gtk-box-pack-start vbox action-hbox #f #t 0)
 247     (gtk-widget-show action-hbox)
 248
 249     (gtk-signal-connect cancel-btn "clicked"
 250                         (lambda (x)
 251                           (gtk-widget-destroy window)))
 252     (gtk-box-pack-start action-hbox cancel-btn #t #t 0)
 253     (gtk-tooltips-set-tip gwave-tooltips cancel-btn
 254                           "Cancel export and close window" "")
 255     (gtk-widget-show cancel-btn)
 256
 257     (gtk-box-pack-start action-hbox export-btn #t #t 0)
 258     (gtk-tooltips-set-tip gwave-tooltips export-btn "Plot data" "")
 259     (gtk-signal-connect export-btn "clicked"
 260                         (lambda (x)
 261                           (let* ((n (gtk-notebook-get-current-page notebook))
 262                                  (pp (if (>= n 0)
 263                                          (caddr (list-ref plot-list n))
 264                                          #f))
 265                                  (op (assoc-ref oproc-assoc pp))
 266                                  (optlist (if (procedure?  op) (op) (list))))
 267 ;                           (format #t "plot filter ~d ~s ~s\n" n op pp)
 268 ;                           (format #t "opts: ~s\n" optlist)
 269                             (if (procedure? pp)
 270                                 (pp
 271                                  (gtk-entry-get-text filename-entry)
 272                                  plist optlist
 273                                 (gtk-toggle-button-get-active tmpfcheck))))
 274                           (gtk-widget-destroy window)))
 275     (if (= 0 (length plot-list))
 276         (gtk-widget-set-sensitive export-btn #f))
 277     (gtk-widget-show export-btn)
 278
 279 ;    (gtk-widget-set-flags export-btn '(can-default))
 280 ;    (set-flags export-btn '(can-default))
 281     (gtk-widget-grab-default export-btn)
 282     (gtk-widget-show window)
 283 ))
 284
 285 ;; run a command in a subprocess, redirecting its output to a named file.
 286 (define-public (subprocess-to-file f cmd arglist)
 287   (let ((port (if f
 288                   (open f (logior O_WRONLY O_CREAT O_TRUNC) #o0777)
 289                   #f))
 290         (null (open "/dev/null" O_RDONLY 0)))
 291     (if gwave-debug
 292         (format #t "subprocess-to-file ~a ~s\n" cmd arglist))
 293     (flush-all-ports)
 294     ; TODO: search for and stat cmd to make sure it exists and is executable.
 295     (let ((p (primitive-fork)))
 296       (cond ((< p 0)
 297              ; error
 298              (error "fork"))
 299             ((eq? 0 p)
 300              ; child
 301              (if port
 302                  (redirect-port port (current-output-port)))
 303              (redirect-port null (current-input-port))
 304              (close-all-ports-except (current-input-port)
 305                                      (current-output-port)
 306                                      (current-error-port))
 307              (false-if-exception
 308               (begin
 309                 (apply execlp cmd arglist)
 310                 (primitive-exit 127)))
 311              )
 312             (else
 313              ; parent
 314              (if port
 315                  (close port))
 316
 317              (if gwave-debug
 318                  (format #t "child process ~d started for ~a ~s\n" p cmd arglist))
 319              (reap-child)
 320              )))))
 321
 322 (define (reap-child)
 323   (let* ((w (catch 'system-error
 324             (lambda () (waitpid 0 WNOHANG))
 325             (lambda (func . stuff) (cons 0 #f))))
 326          (pid (car w))
 327          (st (cdr w)))
 328     (if (not (eq? 0 pid))
 329         (begin
 330           (format #t "process ~d" pid)
 331           (if (status:exit-val st)
 332               (format #t " exited (~d)" (status:exit-val st)))
 333           (if (status:term-sig st)
 334               (format #t " terminated on signal ~d" (status:term-sig st)))
 335           (if (status:stop-sig st)
 336               (format #t " stopped on signal~d" (status:exit-sig st)))
 337           (display "\n"))
 338          ;(display "no child\n")
 339         )))
 340
 341 (dbprint "setting SIGCHLD handler\n")
 342 ;(display (sigaction SIGCHLD (lambda (s) (reap-child)))) (newline)
 343 ;(display (sigaction SIGCHLD)) (newline)
 344 (dbprint "export.scm done")
 345