Index: Makefile
==================================================================
--- Makefile
+++ Makefile
@@ -28,13 +28,13 @@
PREFIX=$(PWD)
CSCOPTS=
INSTALL=install
SRCFILES = common.scm items.scm launch.scm ods.scm runconfig.scm \
server.scm configf.scm db.scm keys.scm \
- process.scm runs.scm tasks.scm tests.scm genexample.scm \
+ process.scm runs.scm tests.scm genexample.scm \
tdb.scm mt.scm \
- ezsteps.scm rmt.scm api.scm \
+ ezsteps.scm api.scm \
subrun.scm archive.scm env.scm \
diff-report.scm
# cgisetup/models/pgdb.scm
Index: api.scm
==================================================================
--- api.scm
+++ api.scm
@@ -24,11 +24,10 @@
(declare (uses debugprint))
(declare (uses commonmod))
(declare (uses dbmod))
(declare (uses dbfile))
-(declare (uses tasks))
(declare (uses tcp-transportmod))
(import commonmod)
(import apimod)
(import dbmod)
ADDED attic/fdb_records.scm
Index: attic/fdb_records.scm
==================================================================
--- /dev/null
+++ attic/fdb_records.scm
@@ -0,0 +1,36 @@
+;; Copyright 2006-2017, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see .
+
+;; Single record for managing a filedb
+;; make-vector-record "Filedb record" filedb fdb db dbpath pathcache idcache partcache
+;; Filedb record
+(define (make-filedb:fdb)(make-vector 5))
+(define-inline (filedb:fdb-get-db vec) (vector-ref vec 0))
+(define-inline (filedb:fdb-get-dbpath vec) (vector-ref vec 1))
+(define-inline (filedb:fdb-get-pathcache vec) (vector-ref vec 2))
+(define-inline (filedb:fdb-get-idcache vec) (vector-ref vec 3))
+(define-inline (filedb:fdb-get-partcache vec) (vector-ref vec 4))
+(define-inline (filedb:fdb-set-db! vec val)(vector-set! vec 0 val))
+(define-inline (filedb:fdb-set-dbpath! vec val)(vector-set! vec 1 val))
+(define-inline (filedb:fdb-set-pathcache! vec val)(vector-set! vec 2 val))
+(define-inline (filedb:fdb-set-idcache! vec val)(vector-set! vec 3 val))
+(define-inline (filedb:fdb-set-partcache! vec val)(vector-set! vec 4 val))
+
+;; children records, should have use something other than "child"
+(define-inline (filedb:child-get-id vec) (vector-ref vec 0))
+(define-inline (filedb:child-get-path vec) (vector-ref vec 1))
+(define-inline (filedb:child-get-parent_id vec)(vector-ref vec 2))
ADDED attic/newdashboard.scm
Index: attic/newdashboard.scm
==================================================================
--- /dev/null
+++ attic/newdashboard.scm
@@ -0,0 +1,752 @@
+;;======================================================================
+;; Copyright 2006-2016, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see .
+
+;;======================================================================
+
+(declare (uses common))
+(declare (uses debugprint))
+(declare (uses megatest-version))
+(declare (uses mtargs))
+(declare (uses commonmod))
+
+(use format)
+
+(use (prefix iup iup:))
+
+(use canvas-draw)
+(import canvas-draw-iup)
+
+(use sql-de-lite srfi-1 posix regex regex-case srfi-69 typed-records sparse-vectors ;; defstruct
+ (prefix dbi dbi:))
+
+(import commonmod
+ debugprint
+ (prefix mtargs args:))
+
+;; (declare (uses launch))
+;; (declare (uses gutils))
+;; (declare (uses db))
+;; (declare (uses server))
+(declare (uses dcommon))
+;; (declare (uses tree))
+;;
+;; (include "common_records.scm")
+;; (include "db_records.scm")
+;; (include "key_records.scm")
+
+(define help (conc
+"Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest
+ version " megatest-version "
+ license GPL, Copyright (C) Matt Welland 2011
+
+Usage: dashboard [options]
+ -h : this help
+ -server host:port : connect to host:port instead of db access
+ -test testid : control test identified by testid
+ -guimonitor : control panel for runs
+
+Misc
+ -rows N : set number of rows
+"))
+
+;; process args
+(define remargs (args:get-args
+ (argv)
+ (list "-rows"
+ "-run"
+ "-test"
+ "-debug"
+ "-host"
+ )
+ (list "-h"
+ "-guimonitor"
+ "-main"
+ "-v"
+ "-q"
+ )
+ args:arg-hash
+ 0))
+
+(if (args:get-arg "-h")
+ (begin
+ (print help)
+ (exit)))
+
+;; ease debugging by loading ~/.dashboardrc
+(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc")))
+ (if (common:file-exists? debugcontrolf)
+ (load debugcontrolf)))
+
+(debug:setup)
+
+(define *tim* (iup:timer))
+(define *ord* #f)
+
+(iup:attribute-set! *tim* "TIME" 300)
+(iup:attribute-set! *tim* "RUN" "YES")
+
+(define (message-window msg)
+ (iup:show
+ (iup:dialog
+ (iup:vbox
+ (iup:label msg #:margin "40x40")))))
+
+(define (iuplistbox-fill-list lb items . default)
+ (let ((i 1)
+ (selected-item (if (null? default) #f (car default))))
+ (iup:attribute-set! lb "VALUE" (if selected-item selected-item ""))
+ (for-each (lambda (item)
+ (iup:attribute-set! lb (number->string i) item)
+ (if selected-item
+ (if (equal? selected-item item)
+ (iup:attribute-set! lb "VALUE" item))) ;; (number->string i))))
+ (set! i (+ i 1)))
+ items)
+ i))
+
+(define (pad-list l n)(append l (make-list (- n (length l)))))
+
+
+(define (mkstr . x)
+ (string-intersperse (map conc x) ","))
+
+(define (update-search x val)
+ (hash-table-set! *searchpatts* x val))
+
+
+;; data for each specific tab goes here
+;;
+(defstruct dboard:tabdat
+ ;; runs
+ ((allruns '()) : list) ;; list of dboard:rundat records
+ ((allruns-by-id (make-hash-table)) : hash-table) ;; hash of run-id -> dboard:rundat records
+ ((done-runs '()) : list) ;; list of runs already drawn
+ ((not-done-runs '()) : list) ;; list of runs not yet drawn
+ (header #f) ;; header for decoding the run records
+ (keys #f) ;; keys for this run (i.e. target components)
+ ((numruns (string->number (or (args:get-arg "-cols") "10"))) : number) ;;
+ ((tot-runs 0) : number)
+ ((last-data-update 0) : number) ;; last time the data in allruns was updated
+ ((last-runs-update 0) : number) ;; last time we pulled the runs info to update the tree
+ (runs-mutex (make-mutex)) ;; use to prevent parallel access to draw objects
+ ((run-update-times (make-hash-table)) : hash-table) ;; update times indexed by run-id
+ ((last-test-dat (make-hash-table)) : hash-table) ;; cache last tests dat by run-id
+ ((run-db-paths (make-hash-table)) : hash-table) ;; cache the paths to the run db files
+
+ ;; Runs view
+ ((buttondat (make-hash-table)) : hash-table) ;;
+ ((item-test-names '()) : list) ;; list of itemized tests
+ ((run-keys (make-hash-table)) : hash-table)
+ (runs-matrix #f) ;; used in newdashboard
+ ((start-run-offset 0) : number) ;; left-right slider value
+ ((start-test-offset 0) : number) ;; up-down slider value
+ ((runs-btn-height (or (configf:lookup *configdat* "dashboard" "btn-height") "x16")) : string) ;; was 12
+ ((runs-btn-fontsz (or (configf:lookup *configdat* "dashboard" "btn-fontsz") "10")) : string) ;; was 8
+ ((runs-cell-width (or (configf:lookup *configdat* "dashboard" "cell-width") "60")) : string) ;; was 50
+ ((all-test-names '()) : list)
+
+ ;; Canvas and drawing data
+ (cnv #f)
+ (cnv-obj #f)
+ (drawing #f)
+ ((run-start-row 0) : number)
+ ((max-row 0) : number)
+ ((running-layout #f) : boolean)
+ (originx #f)
+ (originy #f)
+ ((layout-update-ok #t) : boolean)
+ ((compact-layout #t) : boolean)
+
+ ;; Run times layout
+ ;; (graph-button-box #f) ;; RA => Think it is not referenced anywhere
+ (graph-matrix #f)
+ ((graph-matrix-table (make-hash-table)) : hash-table) ;; graph-dats referenced thru graph name info
+ ((graph-cell-table (make-hash-table)) : hash-table) ;; graph-dats referenced thru matrix cell info
+ ((graph-matrix-row 1) : number)
+ ((graph-matrix-col 1) : number)
+
+ ;; Controls used to launch runs etc.
+ ((command "") : string) ;; for run control this is the command being built up
+ (command-tb #f) ;; widget for the type of command; run, remove-runs etc.
+ (test-patterns-textbox #f) ;; text box widget for editing a list of test patterns
+ (key-listboxes #f)
+ (key-lbs #f)
+ run-name ;; from run name setting widget
+ states ;; states for -state s1,s2 ...
+ statuses ;; statuses for -status s1,s2 ...
+
+ ;; Selector variables
+ curr-run-id ;; current row to display in Run summary view
+ prev-run-id ;; previous runid selected before current runid was selected (used in xor-two-runs runs summary mode
+ curr-test-ids ;; used only in dcommon:run-update which is used in newdashboard
+ ((filters-changed #t) : boolean) ;; to indicate that the user changed filters for this tab
+ ((last-filter-str "") : string) ;; conc the target runname and testpatt for a signature of changed filters
+ ((hide-empty-runs #f) : boolean)
+ ((hide-not-hide #t) : boolean) ;; toggle for hide/not hide empty runs
+ (hide-not-hide-button #f)
+ ((searchpatts (make-hash-table)) : hash-table) ;;
+ ((state-ignore-hash (make-hash-table)) : hash-table) ;; hash of STATE => #t/#f for display control
+ ((status-ignore-hash (make-hash-table)) : hash-table) ;; hash of STATUS => #t/#f
+ (target #f)
+ (test-patts #f)
+
+ ;; db info to file the .db files for the area
+ (access-mode (db:get-access-mode)) ;; use cached db or not
+ (dbdir #f)
+ (dbfpath #f)
+ (dbkeys #f)
+ ((last-db-update (make-hash-table)) : hash-table) ;; last db file timestamp
+ (monitor-db-path #f) ;; where to find monitor.db
+ ro ;; is the database read-only?
+
+ ;; tests data
+ ((num-tests 10) : number) ;; total number of tests to show (used in the old runs display)
+
+ ;; runs tree
+ ((path-run-ids (make-hash-table)) : hash-table) ;; path (target / runname) => id
+ (runs-tree #f)
+ ((runs-tree-ht (make-hash-table)) : hash-table) ;; track which targets added to tree (merge functionality with path-run-ids?)
+
+ ;; tab data
+ ((view-changed #t) : boolean)
+ ((xadj 0) : number) ;; x slider number (if using canvas)
+ ((yadj 0) : number) ;; y slider number (if using canvas)
+ ;; runs-summary tab state
+ ((runs-summary-modes '((one-run . "Show One Run") (xor-two-runs . "XOR Two Runs") (xor-two-runs-hide-clean . "XOR; Hide Clean")) ) : list)
+ ((runs-summary-mode-buttons '()) : list)
+ ((runs-summary-mode 'one-run) : symbol)
+ ((runs-summary-mode-change-callbacks '()) : list)
+ (runs-summary-source-runname-label #f)
+ (runs-summary-dest-runname-label #f)
+ ;; runs summary view
+
+ tests-tree ;; used in newdashboard
+ )
+
+
+
+;; mtest is actually the megatest.config file
+;;
+(define (mtest toppath window-id)
+ (let* ((curr-row-num 0)
+ ;; (rawconfig (read-config (conc toppath "/megatest.config") #f 'return-string))
+ (keys-matrix (iup:matrix)) ;; (dcommon:keys-matrix rawconfig))
+ (setup-matrix (iup:matrix)) ;; (dcommon:section-matrix rawconfig "setup" "Varname" "Value"))
+ (jobtools-matrix (iup:matrix
+ #:expand "YES"
+ #:numcol 1
+ #:numlin 5
+ #:numcol-visible 1
+ #:numlin-visible 3))
+ (validvals-matrix (iup:matrix
+ #:expand "YES"
+ #:numcol 1
+ #:numlin 2
+ #:numcol-visible 1
+ #:numlin-visible 2))
+ (envovrd-matrix (iup:matrix
+ #:expand "YES"
+ #:numcol 1
+ #:numlin 20
+ #:numcol-visible 1
+ #:numlin-visible 8))
+ (disks-matrix (iup:matrix
+ #:expand "YES"
+ #:numcol 1
+ #:numlin 20
+ #:numcol-visible 1
+ #:numlin-visible 8))
+ )
+ (iup:attribute-set! disks-matrix "0:0" "Disk Name")
+ (iup:attribute-set! disks-matrix "0:1" "Disk Path")
+ (iup:attribute-set! disks-matrix "WIDTH1" "120")
+ (iup:attribute-set! disks-matrix "WIDTH0" "100")
+ (iup:attribute-set! disks-matrix "ALIGNMENT1" "ALEFT")
+ (iup:attribute-set! disks-matrix "FIXTOTEXT" "C1")
+ (iup:attribute-set! disks-matrix "RESIZEMATRIX" "YES")
+
+ ;; fill in existing info
+ (for-each
+ (lambda (mat fname)
+ (set! curr-row-num 1)
+ (for-each
+ (lambda (var)
+ (iup:attribute-set! mat (conc curr-row-num ":0") var)
+ ;; (iup:attribute-set! mat (conc curr-row-num ":1") (config-lookup rawconfig fname var))
+ (set! curr-row-num (+ curr-row-num 1)))
+ '()));; (configf:section-vars rawconfig fname)))
+ (list setup-matrix jobtools-matrix validvals-matrix envovrd-matrix disks-matrix)
+ (list "setup" "jobtools" "validvalues" "env-override" "disks"))
+
+ (for-each
+ (lambda (mat)
+ (iup:attribute-set! mat "0:1" "Value")
+ (iup:attribute-set! mat "0:0" "Var")
+ (iup:attribute-set! mat "ALIGNMENT1" "ALEFT")
+ (iup:attribute-set! mat "FIXTOTEXT" "C1")
+ (iup:attribute-set! mat "RESIZEMATRIX" "YES")
+ (iup:attribute-set! mat "WIDTH1" "120")
+ (iup:attribute-set! mat "WIDTH0" "100")
+ )
+ (list setup-matrix jobtools-matrix validvals-matrix envovrd-matrix))
+
+ (iup:attribute-set! validvals-matrix "WIDTH1" "290")
+ (iup:attribute-set! envovrd-matrix "WIDTH1" "290")
+
+ (iup:vbox
+ (iup:hbox
+
+ (iup:vbox
+ (let ((tabs (iup:tabs
+ ;; The required tab
+ (iup:hbox
+ ;; The keys
+ (iup:frame
+ #:title "Keys (required)"
+ (iup:vbox
+ (iup:label (conc "Set the fields for organising your runs\n"
+ "here. Note: can only be changed before\n"
+ "running the first run when megatest.db\n"
+ "is created."))
+ keys-matrix))
+ (iup:vbox
+ ;; The setup section
+ (iup:frame
+ #:title "Setup"
+ (iup:vbox
+ (iup:label (conc "max_concurrent_jobs : limits total concurrent jobs (optional)\n"
+ "linktree : directory where linktree will be created."))
+ setup-matrix))
+ ;; The jobtools
+ (iup:frame
+ #:title "Jobtools"
+ (iup:vbox
+ (iup:label (conc "launcher : tool or script to run jobs (try nbfake)\n"
+ "useshell : use system to run your launcher\n"
+ "workhosts : spread jobs out on these hosts"))
+ jobtools-matrix))
+ ;; The disks
+ (iup:frame
+ #:title "Disks"
+ (iup:vbox
+ (iup:label (conc "Enter names and existing paths of locations to run tests"))
+ disks-matrix))))
+ ;; The optional tab
+ (iup:vbox
+ ;; The Environment Overrides
+ (iup:frame
+ #:title "Env override"
+ envovrd-matrix)
+ ;; The valid values
+ (iup:frame
+ #:title "Validvalues"
+ validvals-matrix)
+ ))))
+ (iup:attribute-set! tabs "TABTITLE0" "Required settings")
+ (iup:attribute-set! tabs "TABTITLE1" "Optional settings")
+ tabs))
+ ))))
+
+;; The runconfigs.config file
+;;
+(define (rconfig window-id)
+ (iup:vbox
+ (iup:frame #:title "Default")))
+
+;;======================================================================
+;; T E S T S
+;;======================================================================
+
+(define (tree-path->test-id path)
+ (if (not (null? path))
+ (hash-table-ref/default (dboard:data-path-test-ids *data*) path #f)
+ #f))
+
+(define (test-panel window-id)
+ (let* ((curr-row-num 0)
+ (viewlog (lambda (x)
+ (if (common:file-exists? logfile)
+ ;(system (conc "firefox " logfile "&"))
+ (iup:send-url logfile)
+ (message-window (conc "File " logfile " not found")))))
+ (xterm (lambda (x)
+ (if (directory-exists? rundir)
+ (let ((shell (if (get-environment-variable "SHELL")
+ (conc "-e " (get-environment-variable "SHELL"))
+ "")))
+ (system (conc "cd " rundir
+ ";xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&")))
+ (message-window (conc "Directory " rundir " not found")))))
+ (command-text-box (iup:textbox #:expand "HORIZONTAL" #:font "Courier New, -12"))
+ (command-launch-button (iup:button "Execute!"
+ ;; #:expand "HORIZONTAL"
+ #:size "50x"
+ #:action (lambda (x)
+ (let ((cmd (iup:attribute command-text-box "VALUE")))
+ (system (conc cmd " &"))))))
+ (run-test (lambda (x)
+ (iup:attribute-set!
+ command-text-box "VALUE"
+ (conc "xterm -geometry 180x20 -e \"megatest -target " keystring " :runname " runname
+ " -runtests " (conc testname "/" (if (equal? item-path "")
+ "%"
+ item-path))
+ ";echo Press any key to continue;bash -c 'read -n 1 -s'\""))))
+ (remove-test (lambda (x)
+ (iup:attribute-set!
+ command-text-box "VALUE"
+ (conc "xterm -geometry 180x20 -e \"megatest -remove-runs -target " keystring " :runname " runname
+ " -testpatt " (conc testname "/" (if (equal? item-path "")
+ "%"
+ item-path))
+ " -v;echo Press any key to continue;bash -c 'read -n 1 -s'\""))))
+ (run-info-matrix (iup:matrix
+ #:expand "YES"
+ ;; #:scrollbar "YES"
+ #:numcol 1
+ #:numlin 4
+ #:numcol-visible 1
+ #:numlin-visible 4
+ #:click-cb (lambda (obj lin col status)
+ #f
+ ;;(print "obj: " obj " lin: " lin " col: " col " status: " status)
+ )))
+ (test-info-matrix (iup:matrix
+ #:expand "YES"
+ #:numcol 1
+ #:numlin 7
+ #:numcol-visible 1
+ #:numlin-visible 7))
+ (test-run-matrix (iup:matrix
+ #:expand "YES"
+ #:numcol 1
+ #:numlin 5
+ #:numcol-visible 1
+ #:numlin-visible 5))
+ (meta-dat-matrix (iup:matrix
+ #:expand "YES"
+ #:numcol 1
+ #:numlin 5
+ #:numcol-visible 1
+ #:numlin-visible 5))
+ (steps-matrix (iup:matrix
+ #:expand "YES"
+ #:numcol 6
+ #:numlin 50
+ #:numcol-visible 6
+ #:numlin-visible 8))
+ (data-matrix (iup:matrix
+ #:expand "YES"
+ #:numcol 8
+ #:numlin 50
+ #:numcol-visible 8
+ #:numlin-visible 8))
+ (updater (lambda (testdat)
+ (test-update window-id testdat run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix steps-matrix data-matrix))))
+
+ ;; Set the updater in updaters
+ ;; (hash-table-set! (dboard:data-updaters *data*) window-id updater)
+ ;;
+ (for-each
+ (lambda (mat)
+ ;; (iup:attribute-set! mat "0:1" "Value")
+ ;; (iup:attribute-set! mat "0:0" "Var")
+ (iup:attribute-set! mat "HEIGHT0" 0)
+ (iup:attribute-set! mat "ALIGNMENT1" "ALEFT")
+ ;; (iup:attribute-set! mat "FIXTOTEXT" "C1")
+ (iup:attribute-set! mat "RESIZEMATRIX" "YES"))
+ ;; (iup:attribute-set! mat "WIDTH1" "120")
+ ;; (iup:attribute-set! mat "WIDTH0" "100"))
+ (list run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix))
+
+ ;; Steps matrix
+ (iup:attribute-set! steps-matrix "0:1" "Step Name")
+ (iup:attribute-set! steps-matrix "0:2" "Start")
+ (iup:attribute-set! steps-matrix "WIDTH2" "40")
+ (iup:attribute-set! steps-matrix "0:3" "End")
+ (iup:attribute-set! steps-matrix "WIDTH3" "40")
+ (iup:attribute-set! steps-matrix "0:4" "Status")
+ (iup:attribute-set! steps-matrix "WIDTH4" "40")
+ (iup:attribute-set! steps-matrix "0:5" "Duration")
+ (iup:attribute-set! steps-matrix "WIDTH5" "40")
+ (iup:attribute-set! steps-matrix "0:6" "Log File")
+ (iup:attribute-set! steps-matrix "ALIGNMENT1" "ALEFT")
+ ;; (iup:attribute-set! steps-matrix "FIXTOTEXT" "C1")
+ (iup:attribute-set! steps-matrix "RESIZEMATRIX" "YES")
+ ;; (iup:attribute-set! steps-matrix "WIDTH1" "120")
+ ;; (iup:attribute-set! steps-matrix "WIDTH0" "100")
+
+ ;; Data matrix
+ ;;
+ (let ((rownum 1))
+ (for-each
+ (lambda (x)
+ (iup:attribute-set! data-matrix (conc "0:" rownum) x)
+ (iup:attribute-set! data-matrix (conc "WIDTH" rownum) "50")
+ (set! rownum (+ rownum 1)))
+ (list "Category" "Variable" "Value" "Expected" "Tolerance" "Status" "Units" "Type" "Comment")))
+ (iup:attribute-set! data-matrix "REDRAW" "ALL")
+
+ (for-each
+ (lambda (data)
+ (let ((mat (car data))
+ (keys (cadr data))
+ (rownum 1))
+ (for-each
+ (lambda (key)
+ (iup:attribute-set! mat (conc rownum ":0") key)
+ (set! rownum (+ rownum 1)))
+ keys)
+ (iup:attribute-set! mat "REDRAW" "ALL")))
+ (list
+ (list run-info-matrix '("Run Id" "Target" "Runname" "Run Start Time" ))
+ (list test-info-matrix '("Test Id" "Testname" "Itempath" "State" "Status" "Test Start Time" "Comment"))
+ (list test-run-matrix '("Hostname" "Host info" "Disk Free" "CPU Load" "Run Duration"))
+ (list meta-dat-matrix '("Author" "Owner" "Last Reviewed" "Tags" "Description"))))
+
+ (iup:split
+ #:orientation "HORIZONTAL"
+ (iup:vbox
+ (iup:hbox
+ (iup:vbox
+ run-info-matrix
+ test-info-matrix)
+ ;; test-info-matrix)
+ (iup:vbox
+ test-run-matrix
+ meta-dat-matrix))
+ (iup:vbox
+ (iup:vbox
+ (iup:hbox
+ (iup:button "View Log" #:action viewlog #:size "60x" ) ;; #:size "30x"
+ (iup:button "Start Xterm" #:action xterm #:size "60x" )) ;; #:size "30x"
+ (iup:hbox
+ (iup:button "Run Test" #:action run-test #:size "60x" ) ;; #:size "30x"
+ (iup:button "Clean Test" #:action remove-test #:size "60x" ))) ;; #:size "30x"
+ (iup:hbox
+ ;; hiup:split ;; hbox
+ ;; #:orientation "HORIZONTAL"
+ ;; #:value 300
+ command-text-box
+ command-launch-button)))
+ (iup:vbox
+ (let ((tabs (iup:tabs
+ steps-matrix
+ data-matrix)))
+ (iup:attribute-set! tabs "TABTITLE0" "Test Steps")
+ (iup:attribute-set! tabs "TABTITLE1" "Test Data")
+ tabs)))))
+
+;; Test browser
+(define (tests window-id)
+ (iup:split
+ (let* ((tb (iup:treebox
+ #:selection-cb
+ (lambda (obj id state)
+ ;; (print "obj: " obj ", id: " id ", state: " state)
+ (let* ((run-path (tree:node->path obj id))
+ (test-id (tree-path->test-id (cdr run-path))))
+ ;; (if test-id
+ ;; (hash-table-set! (dboard:data-curr-test-ids *data*)
+ ;; window-id test-id))
+ ;; (print "path: " (tree:node->path obj id) " test-id: " test-id)
+ )))))
+ (iup:attribute-set! tb "VALUE" "0")
+ (iup:attribute-set! tb "NAME" "Runs")
+ ;;(iup:attribute-set! tb "ADDEXPANDED" "NO")
+ ;; (dboard:data-tests-tree-set! *data* tb)
+ tb)
+ (test-panel window-id)))
+
+;; The function to update the fields in the test view panel
+(define (test-update window-id testdat run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix steps-matrix data-matrix)
+ ;; get test-id
+ ;; then get test record
+ (if testdat
+ (let* ((test-id 0) ;; (hash-table-ref/default (dboard:data-curr-test-ids *data*) window-id #f))
+ (test-data (hash-table-ref/default testdat test-id #f))
+ (run-id (db:test-get-run_id test-data))
+ (targ/runname (hash-table-ref/default (dboard:data-run-keys *data*)
+ run-id
+ '()))
+ (target (if (null? targ/runname) "" (string-intersperse (reverse (cdr (reverse targ/runname))) "/")))
+ (runname (if (null? targ/runname) "" (car (cdr targ/runname))))
+ (steps-dat (tests:get-compressed-steps *dbstruct-local* run-id test-id)))
+
+ (if test-data
+ (begin
+ ;;
+ (for-each
+ (lambda (data)
+ (let ((mat (car data))
+ (vals (cadr data))
+ (rownum 1))
+ (for-each
+ (lambda (key)
+ (let ((cell (conc rownum ":1")))
+ (if (not (equal? (iup:attribute mat cell)(conc key)))
+ (begin
+ ;; (print "setting cell " cell " in matrix " mat " to value " key)
+ (iup:attribute-set! mat cell (conc key))
+ (iup:attribute-set! mat "REDRAW" cell)))
+ (set! rownum (+ rownum 1))))
+ vals)))
+ (list
+ (list run-info-matrix
+ (if test-id
+ (list (db:test-get-run_id test-data)
+ target
+ runname
+ "n/a")
+ (make-list 4 "")))
+ (list test-info-matrix
+ (if test-id
+ (list test-id
+ (db:test-get-testname test-data)
+ (db:test-get-item-path test-data)
+ (db:test-get-state test-data)
+ (db:test-get-status test-data)
+ (seconds->string (db:test-get-event_time test-data))
+ (db:test-get-comment test-data))
+ (make-list 7 "")))
+ (list test-run-matrix
+ (if test-id
+ (list (db:test-get-host test-data)
+ (db:test-get-uname test-data)
+ (db:test-get-diskfree test-data)
+ (db:test-get-cpuload test-data)
+ (seconds->hr-min-sec (db:test-get-run_duration test-data)))
+ (make-list 5 "")))
+ ))
+ (dcommon:populate-steps steps-dat steps-matrix))))))
+ ;;(list meta-dat-matrix
+ ;; (if test-id
+ ;; (list (
+
+
+;; db:test-get-id
+;; db:test-get-run_id
+;; db:test-get-testname
+;; db:test-get-state
+;; db:test-get-status
+;; db:test-get-event_time
+;; db:test-get-host
+;; db:test-get-cpuload
+;; db:test-get-diskfree
+;; db:test-get-uname
+;; db:test-get-rundir
+;; db:test-get-item-path
+;; db:test-get-run_duration
+;; db:test-get-final_logf
+;; db:test-get-comment
+;; db:test-get-fullname
+
+
+;;======================================================================
+;; R U N C O N T R O L
+;;======================================================================
+
+;; Overall runs browser
+;;
+(define (runs window-id)
+ (let* ((runs-matrix (iup:matrix
+ #:expand "YES"
+ ;; #:fittosize "YES"
+ #:scrollbar "YES"
+ #:numcol 100
+ #:numlin 100
+ #:numcol-visible 7
+ #:numlin-visible 7
+ #:click-cb (lambda (obj lin col status)
+ #f
+ ;; (print "obj: " obj " lin: " lin " col: " col " status: " status)
+ ))))
+
+ (iup:attribute-set! runs-matrix "RESIZEMATRIX" "YES")
+ (iup:attribute-set! runs-matrix "WIDTH0" "100")
+
+ ;; (dboard:data-runs-matrix-set! *data* runs-matrix)
+ (iup:hbox
+ (iup:frame
+ #:title "Runs browser"
+ (iup:vbox
+ runs-matrix)))))
+
+;; Browse and control a single run
+;;
+(define (runcontrol window-id)
+ (iup:hbox))
+
+;;======================================================================
+;; D A S H B O A R D
+;;======================================================================
+
+;; Main Panel
+(define (main-panel window-id)
+ (iup:dialog
+ #:title "Megatest Control Panel"
+ #:menu (dcommon:main-menu)
+ #:shrink "YES"
+ (let ((tabtop (iup:tabs
+ (runs window-id)
+ (tests window-id)
+ (runcontrol window-id)
+ (mtest *toppath* window-id)
+ (rconfig window-id)
+ )))
+ (iup:attribute-set! tabtop "TABTITLE0" "Runs")
+ (iup:attribute-set! tabtop "TABTITLE1" "Tests")
+ (iup:attribute-set! tabtop "TABTITLE2" "Run Control")
+ (iup:attribute-set! tabtop "TABTITLE3" "megatest.config")
+ (iup:attribute-set! tabtop "TABTITLE4" "runconfigs.config")
+ tabtop)))
+
+(define *current-window-id* 0)
+
+(define (newdashboard dbstruct)
+ (let* ((data (make-hash-table))
+ (keys '()) ;; (db:get-keys dbstruct))
+ (runname "%")
+ (testpatt "%")
+ (keypatts '()) ;; (map (lambda (k)(list k "%")) keys))
+ (states '())
+ (statuses '())
+ (nextmintime (current-milliseconds))
+ (my-window-id *current-window-id*))
+ (set! *current-window-id* (+ 1 *current-window-id*))
+ ;; (dboard:data-runs-set! *data* data) ;; make this data available to the rest of the application
+ (iup:show (main-panel my-window-id))
+ ;; Yes, running iup:show will pop up a new panel
+ ;; (iup:show (main-panel my-window-id))
+ (iup:callback-set! *tim*
+ "ACTION_CB"
+ (lambda (x)
+ ;; Want to dedicate no more than 50% of the time to this so skip if
+ ;; 2x delta time has not passed since last query
+ (if (< nextmintime (current-milliseconds))
+ (let* ((starttime (current-milliseconds))
+ ;; (changes (dcommon:run-update keys data runname keypatts testpatt states statuses 'full my-window-id))
+ (endtime (current-milliseconds)))
+ (set! nextmintime (+ endtime (* 2 (- endtime starttime))))
+ ;; (debug:print 11 *default-log-port* "CHANGE(S): " (car changes) "..."))
+ )
+ (debug:print-info 11 *default-log-port* "Server overloaded"))))))
+
+;; (dboard:data-updaters-set! *data* (make-hash-table))
+(newdashboard #f) ;; *dbstruct-local*)
+(iup:main-loop)
ADDED attic/rmt.scm
Index: attic/rmt.scm
==================================================================
--- /dev/null
+++ attic/rmt.scm
@@ -0,0 +1,52 @@
+;;======================================================================
+;; Copyright 2006-2017, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see .
+;;
+;;======================================================================
+
+(use format typed-records) ;; RADT => purpose of json format??
+
+(declare (unit rmt))
+(declare (uses debugprint))
+(declare (uses api))
+(declare (uses common))
+(declare (uses commonmod))
+(declare (uses configfmod))
+(declare (uses dbfile))
+(declare (uses dbmod))
+(declare (uses tcp-transportmod))
+(include "common_records.scm")
+(declare (uses rmtmod))
+
+;; used by http-transport
+(import dbfile
+ rmtmod
+ commonmod
+ configfmod
+ debugprint
+;; dbmemmod
+ dbfile
+ dbmod
+ tcp-transportmod)
+
+;;
+;; THESE ARE ALL CALLED ON THE CLIENT SIDE!!!
+;;
+
+;; generate entries for ~/.megatestrc with the following
+;;
+;; grep define ../rmt.scm | grep rmt: |perl -pi -e 's/\(define\s+\((\S+)\W.*$/\1/'|sort -u
ADDED attic/tasks.scm
Index: attic/tasks.scm
==================================================================
--- /dev/null
+++ attic/tasks.scm
@@ -0,0 +1,48 @@
+;; Copyright 2006-2012, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see .
+;;
+
+;; strftime('%m/%d/%Y %H:%M:%S','now','localtime')
+
+(declare (unit tasks))
+(declare (uses debugprint))
+(declare (uses dbfile))
+(declare (uses db))
+(declare (uses dbmod))
+(declare (uses rmt))
+(declare (uses rmtmod))
+(declare (uses common))
+(declare (uses pgdb))
+(declare (uses commonmod))
+(declare (uses configfmod))
+(declare (uses processmod))
+(declare (uses mtargs))
+
+(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking format)
+(import (prefix sqlite3 sqlite3:))
+
+(import commonmod
+ configfmod
+ processmod
+ debugprint
+ dbmod
+ rmtmod
+ (prefix mtargs args:))
+
+(import dbfile)
+;; (import pgdb) ;; pgdb is a module
+
ADDED attic/widgets.scm
Index: attic/widgets.scm
==================================================================
--- /dev/null
+++ attic/widgets.scm
@@ -0,0 +1,208 @@
+;; Copyright 2006-2017, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see .
+
+(require-library srfi-4 iup)
+(import srfi-4 iup
+ ;; iup-pplot
+ iup-glcanvas) ;; iup-web
+
+(define (popup dlg . args)
+ (apply show dlg #:modal? 'yes args)
+ (destroy! dlg))
+
+(define (properties ih)
+ (popup (element-properties-dialog ih))
+ 'default)
+
+(define dlg
+ (dialog
+ (vbox
+ (hbox ; headline
+ (fill)
+ (frame (label " Inspect control and dialog classes "
+ fontsize: 15))
+ (fill)
+ margin: '0x0)
+
+ (label "")
+ (label "Dialogs" fontsize: 12)
+ (hbox
+ (button "dialog"
+ action: (lambda (self) (properties (dialog (vbox)))))
+ (button "color-dialog"
+ action: (lambda (self) (properties (color-dialog))))
+ (button "file-dialog"
+ action: (lambda (self) (properties (file-dialog))))
+ (button "font-dialog"
+ action: (lambda (self) (properties (font-dialog))))
+ (button "message-dialog"
+ action: (lambda (self) (properties (message-dialog))))
+ (fill)
+ margin: '0x0)
+ (hbox
+ (button "layout-dialog"
+ action: (lambda (self) (properties (layout-dialog))))
+ (button "element-properties-dialog"
+ action: (lambda (self)
+ (properties
+ (element-properties-dialog (create 'user)))))
+ (fill)
+ margin: '0x0)
+
+ (label "")
+ (label "Composition widgets" fontsize: 12)
+ (hbox
+ (button "fill"
+ action: (lambda (self) (properties (fill))))
+ (button "hbox"
+ action: (lambda (self) (properties (hbox))))
+ (button "vbox"
+ action: (lambda (self) (properties (vbox))))
+ (button "zbox"
+ action: (lambda (self) (properties (zbox))))
+ (button "radio"
+ action: (lambda (self) (properties (radio (vbox)))))
+ (button "normalizer"
+ action: (lambda (self) (properties (normalizer))))
+ (button "cbox"
+ action: (lambda (self) (properties (cbox))))
+ (button "sbox"
+ action: (lambda (self) (properties (sbox (vbox)))))
+ (button "split"
+ action: (lambda (self) (properties (split (vbox) (vbox)))))
+ (fill)
+ margin: '0x0)
+
+ (label "")
+ (label "Standard widgets" fontsize: 12)
+ (hbox
+ (button "button"
+ action: (lambda (self) (properties (button))))
+ (button "canvas"
+ action: (lambda (self) (properties (canvas))))
+ (button "frame"
+ action: (lambda (self) (properties (frame))))
+ (button "label"
+ action: (lambda (self) (properties (label))))
+ (button "listbox"
+ action: (lambda (self) (properties (listbox))))
+ (button "progress-bar"
+ action: (lambda (self) (properties (progress-bar))))
+ (button "spin"
+ action: (lambda (self) (properties (spin))))
+ (fill)
+ margin: '0x0)
+ (hbox
+ (button "tabs"
+ action: (lambda (self) (properties (tabs))))
+ (button "textbox"
+ action: (lambda (self) (properties (textbox))))
+ (button "toggle"
+ action: (lambda (self) (properties (toggle))))
+ (button "treebox"
+ action: (lambda (self) (properties (treebox))))
+ (button "valuator"
+ action: (lambda (self) (properties (valuator ""))))
+ (fill)
+ margin: '0x0)
+
+ (label "")
+ (label "Additional widgets" fontsize: 12)
+ (hbox
+ (button "cells"
+ action: (lambda (self) (properties (cells))))
+ (button "color-bar"
+ action: (lambda (self) (properties (color-bar))))
+ (button "color-browser"
+ action: (lambda (self) (properties (color-browser))))
+ (button "dial"
+ action: (lambda (self) (properties (dial ""))))
+ (button "matrix"
+ action: (lambda (self) (properties (matrix))))
+ (fill)
+ margin: '0x0)
+ (hbox
+ #;(button "pplot"
+ action: (lambda (self) (properties (pplot))))
+ (button "glcanvas"
+ action: (lambda (self) (properties (glcanvas))))
+ ;; (button "web-browser"
+ ;; action: (lambda (self) (properties (web-browser))))
+ (fill)
+ margin: '0x0)
+
+ (label "")
+ (label "Menu widgets" fontsize: 12)
+ (hbox
+ (button "menu"
+ action: (lambda (self) (properties (menu))))
+ (button "menu-item"
+ action: (lambda (self) (properties (menu-item))))
+ (button "menu-separator"
+ action: (lambda (self) (properties (menu-separator))))
+ (fill)
+ margin: '0x0)
+
+ (label "")
+ (label "Images" fontsize: 12)
+ (hbox
+ (button "image/palette"
+ action: (lambda (self)
+ (properties
+ (image/palette 1 1 (u8vector->blob (u8vector 0))))))
+ (button "image/rgb"
+ action: (lambda (self)
+ (properties
+ (image/rgb 1 1 (u8vector->blob (u8vector 0))))))
+ (button "image/rgba"
+ action: (lambda (self)
+ (properties
+ (image/rgba 1 1 (u8vector->blob (u8vector 0))))))
+ (button "image/file"
+ action: (lambda (self)
+ (properties
+ ;; same attributes as image/palette
+ (image/palette 1 1 (u8vector->blob (u8vector 0))))))
+ ;; needs a file in current directory
+ ;(image/file "chicken.ico")))) ; ok
+ ;(image/file "chicken.png")))) ; doesn't work
+ (fill)
+ margin: '0x0)
+
+ (label "")
+ (label "Other widgets" fontsize: 12)
+ (hbox
+ (button "clipboard"
+ action: (lambda (self) (properties (clipboard))))
+ (button "timer"
+ action: (lambda (self) (properties (timer))))
+ (button "spinbox"
+ action: (lambda (self) (properties (spinbox (vbox)))))
+ (fill)
+ margin: '0x0)
+
+ (fill)
+ (button "E&xit"
+ expand: 'horizontal
+ action: (lambda (self) 'close))
+ )
+ margin: '15x15
+ title: "Iup inspector"))
+
+(show dlg)
+(main-loop)
+(exit 0)
ADDED codescan/show-uncalled-procedures.scm
Index: codescan/show-uncalled-procedures.scm
==================================================================
--- /dev/null
+++ codescan/show-uncalled-procedures.scm
@@ -0,0 +1,30 @@
+;; Copyright 2006-2017, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see .
+;;
+(include "codescanlib.scm")
+
+(define (show-danglers)
+ (let* ((all-scm-files (glob "*.scm"))
+ (xref (get-xref all-scm-files))
+ (dangling-procs
+ (map car (filter (lambda (x) (equal? 1 (length x))) xref))))
+ (for-each print dangling-procs) ;; our product.
+ ))
+
+(show-danglers)
+
+
ADDED codescan/trackback.scm
Index: codescan/trackback.scm
==================================================================
--- /dev/null
+++ codescan/trackback.scm
@@ -0,0 +1,53 @@
+;; Copyright 2006-2017, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see .
+
+(include "codescanlib.scm")
+
+;; show call paths for named procedure
+(define (traceback-proc in-procname)
+ (letrec* ((all-scm-files (glob "*.scm"))
+ (xref (get-xref all-scm-files))
+ (have (alist-ref (string->symbol in-procname) xref eq? #f))
+ (lookup (lambda (path procname depth)
+ (let* ((upcone-temp (filter (lambda (x)
+ (eq? procname (car x)))
+ xref))
+ (upcone-temp2 (cond
+ ((null? upcone-temp) '())
+ (else (cdar upcone-temp))))
+ (upcone (filter
+ (lambda (x) (not (eq? x procname)))
+ upcone-temp2))
+ (uppath (cons procname path))
+ (updepth (add1 depth)))
+ (if (null? upcone)
+ (print uppath)
+ (for-each (lambda (x)
+ (if (not (member procname path))
+ (lookup uppath x updepth) ))
+ upcone))))))
+ (if have
+ (lookup '() (string->symbol in-procname) 0)
+ (print "no such func - "in-procname))))
+
+
+(if (eq? 1 (length (command-line-arguments)))
+ (traceback-proc (car (command-line-arguments)))
+ (print "Usage: trackback "))
+
+(exit 0)
+
Index: dashboard-context-menu.scm
==================================================================
--- dashboard-context-menu.scm
+++ dashboard-context-menu.scm
@@ -27,11 +27,10 @@
(declare (uses common))
(declare (uses commonmod))
(declare (uses configfmod))
(declare (uses db))
(declare (uses gutils))
-(declare (uses rmt))
(declare (uses rmtmod))
(declare (uses ezsteps))
;; (declare (uses sdb))
;; (declare (uses filedb))
(declare (uses subrun))
Index: dashboard-guimonitor.scm
==================================================================
--- dashboard-guimonitor.scm
+++ dashboard-guimonitor.scm
@@ -33,11 +33,10 @@
(declare (unit dashboard-guimonitor))
(declare (uses common))
(declare (uses keys))
(declare (uses db))
-(declare (uses tasks))
(declare (uses commonmod))
(import commonmod)
(include "common_records.scm")
(include "db_records.scm")
Index: dashboard-tests.scm
==================================================================
--- dashboard-tests.scm
+++ dashboard-tests.scm
@@ -35,11 +35,10 @@
(declare (uses testsmod))
(declare (uses dcommon))
(declare (uses gutils))
(declare (uses db))
-(declare (uses rmt))
(declare (uses ezsteps))
(declare (uses subrun))
(declare (uses runsmod))
(declare (uses subrunmod))
DELETED datashare.scm
Index: datashare.scm
==================================================================
--- datashare.scm
+++ /dev/null
@@ -1,824 +0,0 @@
-
-;; Copyright 2006-2013, Matthew Welland.
-;;
-;; This file is part of Megatest.
-;;
-;; Megatest is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-;;
-;; Megatest is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with Megatest. If not, see .
-
-;; ==> (module datashare
-;; ==> (use ssax)
-;; ==> (use sxml-serializer)
-;; ==> (use sxml-modifications)
-;; ==> (use regex)
-;; ==> (use srfi-69)
-;; ==> (use regex-case)
-;; ==> (use posix)
-;; ==> (use json)
-;; ==> (use csv)
-;; ==> (use srfi-18)
-;; ==> (use format)
-;; ==>
-;; ==> (use (prefix iup iup:))
-;; ==> (import (prefix ini-file ini:))
-;; ==>
-;; ==> (use canvas-draw)
-;; ==> (import canvas-draw-iup)
-;; ==>
-;; ==> (use sqlite3 srfi-1 posix regex regex-case srfi-69)
-;; ==> (import (prefix sqlite3 sqlite3:))
-;; ==>
-;; ==> (declare (uses configf))
-;; ==> (declare (uses tree))
-;; ==> (declare (uses margs))
-;; ==> ;; (declare (uses dcommon))
-;; ==> ;; (declare (uses launch))
-;; ==> ;; (declare (uses gutils))
-;; ==> ;; (declare (uses db))
-;; ==> ;; (declare (uses synchash))
-;; ==> ;; (declare (uses server))
-;; ==> ;; (declare (uses megatest-version))
-;; ==> ;; (declare (uses tbd))
-;; ==>
-;; ==> (include "megatest-fossil-hash.scm")
-;; ==>
-;; ==> ;;
-;; ==> ;; GLOBALS
-;; ==> ;;
-;; ==> (define *datashare:current-tab-number* 0)
-;; ==> (define *args-hash* (make-hash-table))
-;; ==> (define datashare:help (conc "Usage: datashare [action [params ...]]
-;; ==>
-;; ==> Note: run datashare without parameters to start the gui.
-;; ==>
-;; ==> list-areas : List the allowed areas
-;; ==>
-;; ==> list-versions : List versions available in
-;; ==> options : -full, -vpatt patt
-;; ==>
-;; ==> publish : Publish data for area and with version
-;; ==>
-;; ==> get : Get a link to data, put the link in destpath
-;; ==> options : -i iteration
-;; ==>
-;; ==> update : Update the link to data to the latest iteration.
-;; ==>
-;; ==> Part of the Megatest tool suite.
-;; ==> Learn more at http://www.kiatoa.com/fossils/megatest
-;; ==>
-;; ==> Version: " megatest-fossil-hash)) ;; "
-;; ==>
-;; ==> ;;======================================================================
-;; ==> ;; RECORDS
-;; ==> ;;======================================================================
-;; ==>
-;; ==> ;; make-vector-record "testing" datastore pkg id area version_name store_type copied source_path iteration submitter datetime storegrp datavol quality disk_id comment
-;; ==> ;; testing
-;; ==> (define (make-datashare:pkg)(make-vector 15))
-;; ==> (define-inline (datashare:pkg-get-id vec) (vector-ref vec 0))
-;; ==> (define-inline (datashare:pkg-get-area vec) (vector-ref vec 1))
-;; ==> (define-inline (datashare:pkg-get-version_name vec) (vector-ref vec 2))
-;; ==> (define-inline (datashare:pkg-get-store_type vec) (vector-ref vec 3))
-;; ==> (define-inline (datashare:pkg-get-copied vec) (vector-ref vec 4))
-;; ==> (define-inline (datashare:pkg-get-source_path vec) (vector-ref vec 5))
-;; ==> (define-inline (datashare:pkg-get-iteration vec) (vector-ref vec 6))
-;; ==> (define-inline (datashare:pkg-get-submitter vec) (vector-ref vec 7))
-;; ==> (define-inline (datashare:pkg-get-datetime vec) (vector-ref vec 8))
-;; ==> (define-inline (datashare:pkg-get-storegrp vec) (vector-ref vec 9))
-;; ==> (define-inline (datashare:pkg-get-datavol vec) (vector-ref vec 10))
-;; ==> (define-inline (datashare:pkg-get-quality vec) (vector-ref vec 11))
-;; ==> (define-inline (datashare:pkg-get-disk_id vec) (vector-ref vec 12))
-;; ==> (define-inline (datashare:pkg-get-comment vec) (vector-ref vec 13))
-;; ==> (define-inline (datashare:pkg-get-stored_path vec) (vector-ref vec 14))
-;; ==> (define-inline (datashare:pkg-set-id! vec val)(vector-set! vec 0 val))
-;; ==> (define-inline (datashare:pkg-set-area! vec val)(vector-set! vec 1 val))
-;; ==> (define-inline (datashare:pkg-set-version_name! vec val)(vector-set! vec 2 val))
-;; ==> (define-inline (datashare:pkg-set-store_type! vec val)(vector-set! vec 3 val))
-;; ==> (define-inline (datashare:pkg-set-copied! vec val)(vector-set! vec 4 val))
-;; ==> (define-inline (datashare:pkg-set-source_path! vec val)(vector-set! vec 5 val))
-;; ==> (define-inline (datashare:pkg-set-iteration! vec val)(vector-set! vec 6 val))
-;; ==> (define-inline (datashare:pkg-set-submitter! vec val)(vector-set! vec 7 val))
-;; ==> (define-inline (datashare:pkg-set-datetime! vec val)(vector-set! vec 8 val))
-;; ==> (define-inline (datashare:pkg-set-storegrp! vec val)(vector-set! vec 9 val))
-;; ==> (define-inline (datashare:pkg-set-datavol! vec val)(vector-set! vec 10 val))
-;; ==> (define-inline (datashare:pkg-set-quality! vec val)(vector-set! vec 11 val))
-;; ==> (define-inline (datashare:pkg-set-disk_id! vec val)(vector-set! vec 12 val))
-;; ==> (define-inline (datashare:pkg-set-comment! vec val)(vector-set! vec 13 val))
-;; ==> (define-inline (datashare:pkg-set-stored_path! vec val)(vector-set! vec 14 val))
-;; ==>
-;; ==> ;;======================================================================
-;; ==> ;; DB
-;; ==> ;;======================================================================
-;; ==>
-;; ==> (define (datashare:initialize-db db)
-;; ==> (for-each
-;; ==> (lambda (qry)
-;; ==> (sqlite3:execute db qry))
-;; ==> (list
-;; ==> "CREATE TABLE pkgs
-;; ==> (id INTEGER PRIMARY KEY,
-;; ==> area TEXT,
-;; ==> version_name TEXT,
-;; ==> store_type TEXT DEFAULT 'copy',
-;; ==> copied INTEGER DEFAULT 0,
-;; ==> source_path TEXT,
-;; ==> stored_path TEXT,
-;; ==> iteration INTEGER DEFAULT 0,
-;; ==> submitter TEXT,
-;; ==> datetime TIMESTAMP DEFAULT (strftime('%s','now')),
-;; ==> storegrp TEXT,
-;; ==> datavol INTEGER,
-;; ==> quality TEXT,
-;; ==> disk_id INTEGER,
-;; ==> comment TEXT);"
-;; ==> "CREATE TABLE refs
-;; ==> (id INTEGER PRIMARY KEY,
-;; ==> pkg_id INTEGER,
-;; ==> destlink TEXT);"
-;; ==> "CREATE TABLE disks
-;; ==> (id INTEGER PRIMARY KEY,
-;; ==> storegrp TEXT,
-;; ==> path TEXT);")))
-;; ==>
-;; ==> (define (datashare:register-data db area version-name store-type submitter quality source-path comment)
-;; ==> (let ((iter-qry (sqlite3:prepare db "SELECT max(iteration) FROM pkgs WHERE area=? AND version_name=?;"))
-;; ==> (next-iteration 0))
-;; ==> (sqlite3:with-transaction
-;; ==> db
-;; ==> (lambda ()
-;; ==> (sqlite3:for-each-row
-;; ==> (lambda (iteration)
-;; ==> (if (and (number? iteration)
-;; ==> (>= iteration next-iteration))
-;; ==> (set! next-iteration (+ iteration 1))))
-;; ==> iter-qry area version-name)
-;; ==> ;; now store the data
-;; ==> (sqlite3:execute db "INSERT INTO pkgs (area,version_name,iteration,store_type,submitter,source_path,quality,comment)
-;; ==> VALUES (?,?,?,?,?,?,?,?);"
-;; ==> area version-name next-iteration (conc store-type) submitter source-path quality comment)))
-;; ==> (sqlite3:finalize! iter-qry)
-;; ==> next-iteration))
-;; ==>
-;; ==> (define (datashare:get-id db area version-name iteration)
-;; ==> (let ((res #f))
-;; ==> (sqlite3:for-each-row
-;; ==> (lambda (id)
-;; ==> (set! res id))
-;; ==> db
-;; ==> "SELECT id FROM pkgs WHERE area=? AND version_name=? AND iteration=?;"
-;; ==> area version-name iteration)
-;; ==> res))
-;; ==>
-;; ==> (define (datashare:set-stored-path db id path)
-;; ==> (sqlite3:execute db "UPDATE pkgs SET stored_path=? WHERE id=?;" path id))
-;; ==>
-;; ==> (define (datashare:set-copied db id value)
-;; ==> (sqlite3:execute db "UPDATE pkgs SET copied=? WHERE id=?;" value id))
-;; ==>
-;; ==> (define (datashare:get-pkg-record db area version-name iteration)
-;; ==> (let ((res #f))
-;; ==> (sqlite3:for-each-row
-;; ==> (lambda (a . b)
-;; ==> (set! res (apply vector a b)))
-;; ==> db
-;; ==> "SELECT * FROM pkgs WHERE area=? AND version_name=? AND iteration=?;"
-;; ==> area
-;; ==> version-name
-;; ==> iteration)
-;; ==> res))
-;; ==>
-;; ==> ;; take version-name iteration and register or update "lastest/0"
-;; ==> ;;
-;; ==> (define (datashare:set-latest db id area version-name iteration)
-;; ==> (let* ((rec (datashare:get-pkg-record db area version-name iteration))
-;; ==> (latest-id (datashare:get-id db area "latest" 0))
-;; ==> (stored-path (datashare:pkg-get-stored_path rec)))
-;; ==> (if latest-id ;; have a record - bump the link pointer
-;; ==> (datashare:set-stored-path db latest-id stored-path)
-;; ==> (datashare:register-data db area "latest" 'link "auto" "na" stored-path "latest data"))))
-;; ==>
-;; ==> ;; set a package ref, this is the location where the link back to the stored data
-;; ==> ;; is put.
-;; ==> ;;
-;; ==> ;; if there is nothing at that location then the record can be removed
-;; ==> ;; if there are no refs for a particular pkg-id then that pkg-id is a
-;; ==> ;; candidate for removal
-;; ==> ;;
-;; ==> (define (datashare:record-pkg-ref db pkg-id dest-link)
-;; ==> (sqlite3:execute db "INSERT INTO refs (pkg_id,destlink) VALUES (?,?);" pkg-id dest-link))
-;; ==>
-;; ==> (define (datashare:count-refs db pkg-id)
-;; ==> (let ((res 0))
-;; ==> (sqlite3:for-each-row
-;; ==> (lambda (count)
-;; ==> (set! res count))
-;; ==> db
-;; ==> "SELECT count(id) FROM refs WHERE pkg_id=?;"
-;; ==> pkg-id)
-;; ==> res))
-;; ==>
-;; ==> ;; Create the sqlite db
-;; ==> (define (datashare:open-db configdat)
-;; ==> (let ((path (configf:lookup configdat "database" "location")))
-;; ==> (if (and path
-;; ==> (directory? path)
-;; ==> (file-read-access? path))
-;; ==> (let* ((dbpath (conc path "/datashare.db"))
-;; ==> (writeable (file-write-access? dbpath))
-;; ==> (dbexists (common:file-exists? dbpath))
-;; ==> (handler (make-busy-timeout 136000)))
-;; ==> (handle-exceptions
-;; ==> exn
-;; ==> (begin
-;; ==> (debug:print 2 *default-log-port* "ERROR: problem accessing db " dbpath
-;; ==> ((condition-property-accessor 'exn 'message) exn))
-;; ==> (exit))
-;; ==> (set! db (sqlite3:open-database dbpath)))
-;; ==> (if *db-write-access* (sqlite3:set-busy-handler! db handler))
-;; ==> (if (not dbexists)
-;; ==> (begin
-;; ==> (datashare:initialize-db db)))
-;; ==> db)
-;; ==> (print "ERROR: invalid path for storing database: " path))))
-;; ==>
-;; ==> (define (open-run-close-exception-handling proc idb . params)
-;; ==> (handle-exceptions
-;; ==> exn
-;; ==> (let ((sleep-time (random 30))
-;; ==> (err-status ((condition-property-accessor 'sqlite3 'status #f) exn)))
-;; ==> (case err-status
-;; ==> ((busy)
-;; ==> (thread-sleep! sleep-time))
-;; ==> (else
-;; ==> (print "EXCEPTION: database overloaded or unreadable.")
-;; ==> (print " message: " ((condition-property-accessor 'exn 'message) exn))
-;; ==> (print "exn=" (condition->list exn))
-;; ==> (print " status: " ((condition-property-accessor 'sqlite3 'status) exn))
-;; ==> (print-call-chain (current-error-port))
-;; ==> (thread-sleep! sleep-time)
-;; ==> (print "trying db call one more time....this may never recover, if necessary kill process " (current-process-id) " on host " (get-host-name) " to clean up")))
-;; ==> (apply open-run-close-exception-handling proc idb params))
-;; ==> (apply open-run-close-no-exception-handling proc idb params)))
-;; ==>
-;; ==> (define (open-run-close-no-exception-handling proc idb . params)
-;; ==> ;; (print "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params)
-;; ==> (let* ((db (cond
-;; ==> ((sqlite3:database? idb) idb)
-;; ==> ((not idb) (print "ERROR: cannot open-run-close with #f anymore"))
-;; ==> ((procedure? idb) (idb))
-;; ==> (else (print "ERROR: cannot open-run-close with #f anymore"))))
-;; ==> (res #f))
-;; ==> (set! res (apply proc db params))
-;; ==> (if (not idb)(sqlite3:finalize! dbstruct))
-;; ==> ;; (print "open-run-close-no-exception-handling END" )
-;; ==> res))
-;; ==>
-;; ==> (define open-run-close open-run-close-no-exception-handling)
-;; ==>
-;; ==> (define (datashare:get-pkgs db area-filter version-filter iter-filter)
-;; ==> (let ((res '()))
-;; ==> (sqlite3:for-each-row ;; replace with fold ...
-;; ==> (lambda (a . b)
-;; ==> (set! res (cons (list->vector (cons a b)) res)))
-;; ==> db
-;; ==> (conc "SELECT id,area,version_name,store_type,copied,source_path,iteration,submitter,datetime,storegrp,datavol,quality,disk_id,comment,stored_path "
-;; ==> " FROM pkgs WHERE area like ? AND version_name LIKE ? AND iteration " iter-filter ";")
-;; ==> area-filter version-filter)
-;; ==> (reverse res)))
-;; ==>
-;; ==> (define (datashare:get-pkg db area-name version-name #!key (iteration #f))
-;; ==> (let ((dat '())
-;; ==> (res #f))
-;; ==> (sqlite3:for-each-row ;; replace with fold ...
-;; ==> (lambda (a . b)
-;; ==> (set! dat (cons (list->vector (cons a b)) dat)))
-;; ==> db
-;; ==> (conc "SELECT id,area,version_name,store_type,copied,source_path,iteration,submitter,datetime,storegrp,datavol,quality,disk_id,comment,stored_path "
-;; ==> " FROM pkgs WHERE area=? AND version_name=? ORDER BY iteration ASC;")
-;; ==> area-name version-name)
-;; ==> ;; now filter for iteration, either max if #f or specific one
-;; ==> (if (null? dat)
-;; ==> #f
-;; ==> (let loop ((hed (car dat))
-;; ==> (tal (cdr dat))
-;; ==> (cur 0))
-;; ==> (let ((itr (datashare:pkg-get-iteration hed)))
-;; ==> (if (equal? itr iteration) ;; this is the one if iteration is specified
-;; ==> hed
-;; ==> (if (null? tal)
-;; ==> hed
-;; ==> (loop (car tal)(cdr tal)))))))))
-;; ==>
-;; ==> (define (datashare:get-versions-for-area db area-name #!key (version-patt #f))
-;; ==> (let ((res '())
-;; ==> (data (make-hash-table)))
-;; ==> (sqlite3:for-each-row
-;; ==> (lambda (version-name submitter iteration submitted-time comment)
-;; ==> ;; 0 1 2 3 4
-;; ==> (hash-table-set! data version-name (vector version-name submitter iteration submitted-time comment)))
-;; ==> db
-;; ==> "SELECT version_name,submitter,iteration,datetime,comment FROM pkgs WHERE area='megatest' AND version_name != 'latest' AND version_name LIKE ? ORDER BY datetime asc;"
-;; ==> (or version-patt "%"))
-;; ==> (map (lambda (x)(hash-table-ref data x))(sort (hash-table-keys data) string-ci>=))))
-;; ==>
-;; ==> ;;======================================================================
-;; ==> ;; DATA IMPORT/EXPORT
-;; ==> ;;======================================================================
-;; ==>
-;; ==> (define (datashare:import-data configdat source-path dest-path area version iteration)
-;; ==> (let* ((space-avail (car dest-path))
-;; ==> (disk-path (cdr dest-path))
-;; ==> (targ-path (conc disk-path "/" area "/" version "/" iteration))
-;; ==> (id (datashare:get-id db area version iteration))
-;; ==> (db (datashare:open-db configdat)))
-;; ==> (if (> space-avail 10000) ;; dumb heuristic
-;; ==> (begin
-;; ==> (create-directory targ-path #t)
-;; ==> (datashare:set-stored-path db id targ-path)
-;; ==> (print "Running command: rsync -av " source-path "/ " targ-path "/")
-;; ==> (let ((th1 (make-thread (lambda ()
-;; ==> (let ((pid (process-run "rsync" (list "-av" (conc source-path "/") (conc targ-path "/")))))
-;; ==> (process-wait pid)
-;; ==> (datashare:set-copied db id "yes")
-;; ==> (sqlite3:finalize! db)))
-;; ==> "Data copy")))
-;; ==> (thread-start! th1))
-;; ==> #t)
-;; ==> (begin
-;; ==> (print "ERROR: Not enough space in storage area " dest-path)
-;; ==> (datashare:set-copied db id "no")
-;; ==> (sqlite3:finalize! db)
-;; ==> #f))))
-;; ==>
-;; ==> (define (datashare:get-areas configdat)
-;; ==> (let* ((areadat (configf:get-section configdat "areas"))
-;; ==> (areas (if areadat (map car areadat) '())))
-;; ==> areas))
-;; ==>
-;; ==> (define (datashare:publish configdat publish-type area-name version comment spath submitter quality)
-;; ==> ;; input checks
-;; ==> (cond
-;; ==> ((not (member area-name (datashare:get-areas configdat)))
-;; ==> (cons #f (conc "Illegal area name \"" area-name "\"")))
-;; ==> (else
-;; ==> (let ((db (datashare:open-db configdat))
-;; ==> (iteration (datashare:register-data db area-name version publish-type submitter quality spath comment))
-;; ==> (dest-store (datashare:get-best-storage configdat)))
-;; ==> (if iteration
-;; ==> (if (eq? 'copy publish-type)
-;; ==> (begin
-;; ==> (datashare:import-data configdat spath dest-store area-name version iteration)
-;; ==> (let ((id (datashare:get-id db area-name version iteration)))
-;; ==> (datashare:set-latest db id area-name version iteration)))
-;; ==> (let ((id (datashare:get-id db area-name version iteration)))
-;; ==> (datashare:set-stored-path db id spath)
-;; ==> (datashare:set-copied db id "yes")
-;; ==> (datashare:set-copied db id "n/a")
-;; ==> (datashare:set-latest db id area-name version iteration)))
-;; ==> (print "ERROR: Failed to get an iteration number"))
-;; ==> (sqlite3:finalize! db)
-;; ==> (cons #t "Successfully saved data")))))
-;; ==>
-;; ==> (define (datashare:get-best-storage configdat)
-;; ==> (let* ((storage (configf:lookup configdat "settings" "storage"))
-;; ==> (store-areas (if storage (string-split storage) '())))
-;; ==> (print "Looking for available space in " store-areas)
-;; ==> (datashare:find-most-space store-areas)))
-;; ==>
-;; ==> ;; (string->number (list-ref (with-input-from-pipe "df -B1000000 /tmp" (lambda ()(read-line)(string-split (read-line)))) 3))
-;; ==>
-;; ==> (define (datashare:find-most-space paths)
-;; ==> (fold (lambda (area res)
-;; ==> ;; (print "area=" area " res=" res)
-;; ==> (let ((maxspace (car res))
-;; ==> (currpath (cdr res)))
-;; ==> ;; (print currpath " " maxspace)
-;; ==> (if (file-write-access? area)
-;; ==> (let ((currspace (string->number
-;; ==> (list-ref
-;; ==> (with-input-from-pipe
-;; ==> ;; (conc "df --output=avail " area)
-;; ==> (conc "df -B1000000 " area)
-;; ==> ;; (lambda ()(read)(read))
-;; ==> (lambda ()(read-line)(string-split (read-line))))
-;; ==> 3))))
-;; ==> (if (> currspace maxspace)
-;; ==> (cons currspace area)
-;; ==> res))
-;; ==> res)))
-;; ==> (cons 0 #f)
-;; ==> paths))
-;; ==>
-;; ==> ;; remove existing link and if possible ...
-;; ==> ;; create path to next of tip of target, create link back to source
-;; ==> (define (datashare:build-dir-make-link source target)
-;; ==> (if (common:file-exists? target)(datashare:backup-move target))
-;; ==> (create-directory (pathname-directory target) #t)
-;; ==> (create-symbolic-link source target))
-;; ==>
-;; ==> (define (datashare:backup-move path)
-;; ==> (let* ((trashdir (conc (pathname-directory path) "/.trash"))
-;; ==> (trashfile (conc trashdir "/" (current-seconds) "-" (pathname-file path))))
-;; ==> (create-directory trashdir #t)
-;; ==> (if (directory? path)
-;; ==> (system (conc "mv " path " " trashfile))
-;; ==> (file-move path trash-file))))
-;; ==>
-;; ==> ;;======================================================================
-;; ==> ;; GUI
-;; ==> ;;======================================================================
-;; ==>
-;; ==> ;; The main menu
-;; ==> (define (datashare:main-menu)
-;; ==> (iup:menu ;; a menu is a special attribute to a dialog (think Gnome putting the menu at screen top)
-;; ==> (iup:menu-item "Files" (iup:menu ;; Note that you can use either #:action or action: for options
-;; ==> (iup:menu-item "Open" action: (lambda (obj)
-;; ==> (iup:show (iup:file-dialog))
-;; ==> (print "File->open " obj)))
-;; ==> (iup:menu-item "Save" #:action (lambda (obj)(print "File->save " obj)))
-;; ==> (iup:menu-item "Exit" #:action (lambda (obj)(exit)))))
-;; ==> (iup:menu-item "Tools" (iup:menu
-;; ==> (iup:menu-item "Create new blah" #:action (lambda (obj)(print "Tools->new blah")))
-;; ==> ;; (iup:menu-item "Show dialog" #:action (lambda (obj)
-;; ==> ;; (show message-window
-;; ==> ;; #:modal? #t
-;; ==> ;; ;; set positon using coordinates or center, start, top, left, end, bottom, right, parent-center, current
-;; ==> ;; ;; #:x 'mouse
-;; ==> ;; ;; #:y 'mouse
-;; ==> ;; )
-;; ==> ))))
-;; ==>
-;; ==> (define (datashare:publish-view configdat)
-;; ==> ;; (pp (hash-table->alist configdat))
-;; ==> (let* ((areas (configf:get-section configdat "areas"))
-;; ==> (label-size "70x")
-;; ==> (areas-sel (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES"))
-;; ==> (version-tb (iup:textbox #:expand "HORIZONTAL")) ;; #:size "50x"))
-;; ==> (areas-sel (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES"))
-;; ==> (component (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES" ))
-;; ==> (version-val (iup:textbox #:expand "HORIZONTAL" #:size "50x"))
-;; ==> ;; (copy-link (iup:toggle #:expand "HORIZONTAL"))
-;; ==> ;; (iteration (iup:textbox #:expand "YES" #:size "20x"))
-;; ==> ;; (iteration (iup:textbox #:expand "HORIZONTAL" #:size "20x"))
-;; ==> (area-filter (iup:textbox #:expand "HORIZONTAL" #:value "%"))
-;; ==> (comment-tb (iup:textbox #:expand "YES" #:multiline "YES"))
-;; ==> (source-tb (iup:textbox #:expand "HORIZONTAL"
-;; ==> #:value (or (configf:lookup configdat "settings" "basepath")
-;; ==> "")))
-;; ==> (publish (lambda (publish-type)
-;; ==> (let* ((area-num (or (string->number (iup:attribute areas-sel "VALUE")) 0))
-;; ==> (area-dat (if (> area-num 0)(list-ref areas (- area-num 1))'("NOT SELECTED" "NOT SELECTED")))
-;; ==> (area-path (cadr area-dat))
-;; ==> (area-name (car area-dat))
-;; ==> (version (iup:attribute version-tb "VALUE"))
-;; ==> (comment (iup:attribute comment-tb "VALUE"))
-;; ==> (spath (iup:attribute source-tb "VALUE"))
-;; ==> (submitter (current-user-name))
-;; ==> (quality 2))
-;; ==> (datashare:publish configdat publish-type area-name version comment spath submitter quality))))
-;; ==> (copy (iup:button "Copy and Publish"
-;; ==> #:expand "HORIZONTAL"
-;; ==> #:action (lambda (obj)
-;; ==> (publish 'copy))))
-;; ==> (link (iup:button "Link and Publish"
-;; ==> #:expand "HORIZONTAL"
-;; ==> #:action (lambda (obj)
-;; ==> (publish 'link))))
-;; ==> (browse-btn (iup:button "Browse"
-;; ==> #:size "40x"
-;; ==> #:action (lambda (obj)
-;; ==> (let* ((fd (iup:file-dialog #:dialogtype "DIR"))
-;; ==> (top (iup:show fd #:modal? "YES")))
-;; ==> (iup:attribute-set! source-tb "VALUE"
-;; ==> (iup:attribute fd "VALUE"))
-;; ==> (iup:destroy! fd))))))
-;; ==> (print "areas")
-;; ==> ;; (pp areas)
-;; ==> (fold (lambda (areadat num)
-;; ==> ;; (print "Adding num=" num ", areadat=" areadat)
-;; ==> (iup:attribute-set! areas-sel (conc num) (car areadat))
-;; ==> (+ 1 num))
-;; ==> 1 areas)
-;; ==> (iup:vbox
-;; ==> (iup:hbox (iup:label "Area:" #:size label-size) ;; area-filter
-;; ==> areas-sel)
-;; ==> (iup:hbox (iup:label "Version:" #:size label-size) version-tb)
-;; ==> ;; (iup:hbox (iup:label "Link only" #:size label-size) copy-link)
-;; ==> ;; (iup:label "Iteration:") iteration)
-;; ==> (iup:hbox (iup:label "Comment:" #:size label-size) comment-tb)
-;; ==> (iup:hbox (iup:label "Source base path:" #:size label-size) source-tb browse-btn)
-;; ==> (iup:hbox copy link))))
-;; ==>
-;; ==> (define (datashare:lst->path pathlst)
-;; ==> (conc "/" (string-intersperse (map conc pathlst) "/")))
-;; ==>
-;; ==> (define (datashare:path->lst path)
-;; ==> (string-split path "/"))
-;; ==>
-;; ==> (define (datashare:pathdat-apply-heuristics configdat path)
-;; ==> (cond
-;; ==> ((common:file-exists? path) "found")
-;; ==> (else (conc path " not installed"))))
-;; ==>
-;; ==> (define (datashare:get-view configdat)
-;; ==> (iup:vbox
-;; ==> (iup:hbox
-;; ==> (let* ((label-size "60x")
-;; ==> ;; filter elements
-;; ==> (area-filter "%")
-;; ==> (version-filter "%")
-;; ==> (iter-filter ">= 0")
-;; ==> ;; reverse lookup from path to data for src and installed
-;; ==> (srcdat (make-hash-table)) ;; reverse lookup
-;; ==> (installed-dat (make-hash-table))
-;; ==> ;; config values
-;; ==> (basepath (configf:lookup configdat "settings" "basepath"))
-;; ==> ;; gui elements
-;; ==> (submitter (iup:label "" #:expand "HORIZONTAL"))
-;; ==> (date-submitted (iup:label "" #:expand "HORIZONTAL"))
-;; ==> (comment (iup:label "" #:expand "HORIZONTAL"))
-;; ==> (copy-link (iup:label "" #:expand "HORIZONTAL"))
-;; ==> (quality (iup:label "" #:expand "HORIZONTAL"))
-;; ==> (installed-status (iup:label "" #:expand "HORIZONTAL"))
-;; ==> ;; misc
-;; ==> (curr-record #f)
-;; ==> ;; (source-data (iup:label "" #:expand "HORIZONTAL"))
-;; ==> (tb (iup:treebox
-;; ==> #:value 0
-;; ==> #:name "Packages"
-;; ==> #:expand "YES"
-;; ==> #:addexpanded "NO"
-;; ==> #:selection-cb
-;; ==> (lambda (obj id state)
-;; ==> ;; (print "obj: " obj ", id: " id ", state: " state)
-;; ==> (let* ((path (datashare:lst->path (cdr (tree:node->path obj id))))
-;; ==> (record (hash-table-ref/default srcdat path #f)))
-;; ==> (if record
-;; ==> (begin
-;; ==> (set! curr-record record)
-;; ==> (iup:attribute-set! submitter "TITLE" (datashare:pkg-get-submitter record))
-;; ==> (iup:attribute-set! date-submitted "TITLE" (time->string (seconds->local-time (datashare:pkg-get-datetime record))))
-;; ==> (iup:attribute-set! comment "TITLE" (datashare:pkg-get-comment record))
-;; ==> (iup:attribute-set! quality "TITLE" (datashare:pkg-get-quality record))
-;; ==> (iup:attribute-set! copy-link "TITLE" (datashare:pkg-get-store_type record))
-;; ==> ))
-;; ==> ;; (print "id=" id " path=" path " record=" record);; (tree:node->path obj id) " run-id: " run-id)
-;; ==> ))))
-;; ==> (tb2 (iup:treebox
-;; ==> #:value 0
-;; ==> #:name "Installed"
-;; ==> #:expand "YES"
-;; ==> #:addexpanded "NO"
-;; ==> #:selection-cb
-;; ==> (lambda (obj id state)
-;; ==> ;; (print "obj: " obj ", id: " id ", state: " state)
-;; ==> (let* ((path (datashare:lst->path (cdr (tree:node->path obj id))))
-;; ==> (status (hash-table-ref/default installed-dat path #f)))
-;; ==> (iup:attribute-set! installed-status "TITLE" (if status status ""))
-;; ==> ))))
-;; ==> (refresh (lambda (obj)
-;; ==> (let* ((db (datashare:open-db configdat))
-;; ==> (areas (or (configf:get-section configdat "areas") '())))
-;; ==> ;;
-;; ==> ;; first update the Sources
-;; ==> ;;
-;; ==> (for-each
-;; ==> (lambda (pkgitem)
-;; ==> (let* ((pkg-path (list (datashare:pkg-get-area pkgitem)
-;; ==> (datashare:pkg-get-version_name pkgitem)
-;; ==> (datashare:pkg-get-iteration pkgitem)))
-;; ==> (pkg-id (datashare:pkg-get-id pkgitem))
-;; ==> (path (datashare:lst->path pkg-path)))
-;; ==> ;; (print "tree:add-node tb=" tb ", pkg-path=" pkg-path ", pkg-id=" pkg-id)
-;; ==> (if (not (hash-table-ref/default srcdat path #f))
-;; ==> (tree:add-node tb "Packages" pkg-path userdata: (conc "pkg-id: " pkg-id)))
-;; ==> ;; (print "path=" path " pkgitem=" pkgitem)
-;; ==> (hash-table-set! srcdat path pkgitem)))
-;; ==> (datashare:get-pkgs db area-filter version-filter iter-filter))
-;; ==> ;;
-;; ==> ;; then update the installed
-;; ==> ;;
-;; ==> (for-each
-;; ==> (lambda (area)
-;; ==> (let* ((path (conc "/" (cadr area)))
-;; ==> (fullpath (conc basepath path)))
-;; ==> (if (not (hash-table-ref/default installed-dat path #f))
-;; ==> (tree:add-node tb2 "Installed" (datashare:path->lst path)))
-;; ==> (hash-table-set! installed-dat path (datashare:pathdat-apply-heuristics configdat fullpath))))
-;; ==> areas)
-;; ==> (sqlite3:finalize! db))))
-;; ==> (apply (iup:button "Apply"
-;; ==> #:action
-;; ==> (lambda (obj)
-;; ==> (if curr-record
-;; ==> (let* ((area (datashare:pkg-get-area curr-record))
-;; ==> (stored-path (datashare:pkg-get-stored_path curr-record))
-;; ==> (source-type (datashare:pkg-get-store_type curr-record))
-;; ==> (source-path (case source-type ;; (equal? source-type "link"))
-;; ==> ((link)(datashare:pkg-get-source-path curr-record))
-;; ==> ((copy)stored-path)
-;; ==> (else #f)))
-;; ==> (dest-stub (configf:lookup configdat "areas" area))
-;; ==> (target-path (conc basepath "/" dest-stub)))
-;; ==> (datashare:build-dir-make-link stored-path target-path)
-;; ==> (print "Creating link from " stored-path " to " target-path)))))))
-;; ==> (iup:vbox
-;; ==> (iup:hbox tb tb2)
-;; ==> (iup:frame
-;; ==> #:title "Source Info"
-;; ==> (iup:vbox
-;; ==> (iup:hbox (iup:button "Refresh" #:action refresh) apply)
-;; ==> (iup:hbox (iup:label "Submitter: ") ;; #:size label-size)
-;; ==> submitter
-;; ==> (iup:label "Submitted on: ") ;; #:size label-size)
-;; ==> date-submitted)
-;; ==> (iup:hbox (iup:label "Data stored: ")
-;; ==> copy-link
-;; ==> (iup:label "Quality: ")
-;; ==> quality)
-;; ==> (iup:hbox (iup:label "Comment: ")
-;; ==> comment)))
-;; ==> (iup:frame
-;; ==> #:title "Installed Info"
-;; ==> (iup:vbox
-;; ==> (iup:hbox (iup:label "Installed status/path: ") installed-status)))
-;; ==> )))))
-;; ==>
-;; ==> (define (datashare:manage-view configdat)
-;; ==> (iup:vbox
-;; ==> (iup:hbox
-;; ==> (iup:button "Pushme"
-;; ==> #:expand "YES"
-;; ==> ))))
-;; ==>
-;; ==> (define (datashare:gui configdat)
-;; ==> (iup:show
-;; ==> (iup:dialog
-;; ==> #:title (conc "DataShare dashboard " (current-user-name) ":" (current-directory))
-;; ==> #:menu (datashare:main-menu)
-;; ==> (let* ((tabs (iup:tabs
-;; ==> #:tabchangepos-cb (lambda (obj curr prev)
-;; ==> (set! *datashare:current-tab-number* curr))
-;; ==> (datashare:publish-view configdat)
-;; ==> (datashare:get-view configdat)
-;; ==> (datashare:manage-view configdat)
-;; ==> )))
-;; ==> ;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c)))
-;; ==> (iup:attribute-set! tabs "TABTITLE0" "Publish")
-;; ==> (iup:attribute-set! tabs "TABTITLE1" "Get")
-;; ==> (iup:attribute-set! tabs "TABTITLE2" "Manage")
-;; ==> ;; (iup:attribute-set! tabs "BGCOLOR" "190 190 190")
-;; ==> tabs)))
-;; ==> (iup:main-loop))
-;; ==>
-;; ==> ;;======================================================================
-;; ==> ;; MISC
-;; ==> ;;======================================================================
-;; ==>
-;; ==>
-;; ==> (define (datashare:do-as-calling-user proc)
-;; ==> (let ((eid (current-effective-user-id))
-;; ==> (cid (current-user-id)))
-;; ==> (if (not (eq? eid cid)) ;; running suid
-;; ==> (set! (current-effective-user-id) cid))
-;; ==> ;; (print "running as " (current-effective-user-id))
-;; ==> (proc)
-;; ==> (if (not (eq? eid cid))
-;; ==> (set! (current-effective-user-id) eid))))
-;; ==>
-;; ==> (define (datashare:find name paths)
-;; ==> (if (null? paths)
-;; ==> #f
-;; ==> (let loop ((hed (car paths))
-;; ==> (tal (cdr paths)))
-;; ==> (if (common:file-exists? (conc hed "/" name))
-;; ==> hed
-;; ==> (if (null? tal)
-;; ==> #f
-;; ==> (loop (car tal)(cdr tal)))))))
-;; ==>
-;; ==> ;;======================================================================
-;; ==> ;; MAIN
-;; ==> ;;======================================================================
-;; ==>
-;; ==> (define (datashare:load-config exe-dir exe-name)
-;; ==> (let* ((fname (conc exe-dir "/." exe-name ".config")))
-;; ==> (ini:property-separator-patt " * *")
-;; ==> (ini:property-separator #\space)
-;; ==> (if (common:file-exists? fname)
-;; ==> ;; (ini:read-ini fname)
-;; ==> (read-config fname #f #t)
-;; ==> (make-hash-table))))
-;; ==>
-;; ==> (define (datashare:process-action configdat action . args)
-;; ==> (case (string->symbol action)
-;; ==> ((get)
-;; ==> (if (< (length args) 2)
-;; ==> (begin
-;; ==> (print "ERROR: Missing arguments; " (string-intersperse args ", "))
-;; ==> (exit 1))
-;; ==> (let* ((basepath (configf:lookup configdat "settings" "basepath"))
-;; ==> (db (datashare:open-db configdat))
-;; ==> (area (car args))
-;; ==> (version (cadr args)) ;; iteration
-;; ==> (remargs (args:get-args args '("-i") '() args:arg-hash 0))
-;; ==> (iteration (if (args:get-arg "-i")(string->number (args:get-arg "-i")) #f))
-;; ==> (curr-record (datashare:get-pkg db area version iteration: iteration)))
-;; ==> (if (not curr-record)
-;; ==> (begin
-;; ==> (print "ERROR: No matching record found; area=" area ", version=" version ", iteration=" (if iteration iteration "(max)"))
-;; ==> (exit 1))
-;; ==> (let* ((stored-path (datashare:pkg-get-stored_path curr-record))
-;; ==> (source-type (datashare:pkg-get-store_type curr-record))
-;; ==> (source-path (case source-type ;; (equal? source-type "link"))
-;; ==> ((link) (datashare:pkg-get-source-path curr-record))
-;; ==> ((copy) stored-path)
-;; ==> (else #f)))
-;; ==> (dest-stub (configf:lookup configdat "areas" area))
-;; ==> (target-path (conc basepath "/" dest-stub)))
-;; ==> (datashare:build-dir-make-link stored-path target-path)
-;; ==> (datashare:record-pkg-ref db (datashare:pkg-get-id curr-record) target-path)
-;; ==> (sqlite3:finalize! db)
-;; ==> (print "Creating link from " stored-path " to " target-path))))))
-;; ==> ((publish)
-;; ==> (if (< (length args) 3)
-;; ==> (begin
-;; ==> (print "ERROR: Missing arguments; " (string-intersperse args ", "))
-;; ==> (exit 1))
-;; ==> (let* ((srcpath (list-ref args 0))
-;; ==> (areaname (list-ref args 1))
-;; ==> (version (list-ref args 2))
-;; ==> (remargs (args:get-args (drop args 2)
-;; ==> '("-type" ;; link or copy (default is copy)
-;; ==> "-m")
-;; ==> '()
-;; ==> args:arg-hash
-;; ==> 0))
-;; ==> (publish-type (if (equal? (args:get-arg "-type") "link") 'link 'copy))
-;; ==> (comment (or (args:get-arg "-m") ""))
-;; ==> (submitter (current-user-name))
-;; ==> (quality (args:get-arg "-quality"))
-;; ==> (publish-res (datashare:publish configdat publish-type areaname version comment srcpath submitter quality)))
-;; ==> (if (not (car publish-res))
-;; ==> (begin
-;; ==> (print "ERROR: " (cdr publish-res))
-;; ==> (exit 1))))))
-;; ==> ((list-versions)
-;; ==> (let ((area-name (car args)) ;; version patt full print
-;; ==> (remargs (args:get-args args '("-vpatt") '("-full") args:arg-hash 0))
-;; ==> (db (datashare:open-db configdat))
-;; ==> (versions (datashare:get-versions-for-area db (car args) version-patt: (args:get-arg "-vpatt"))))
-;; ==> ;; (print "area-name=" area-name " args=" args " *args-hash*=" (hash-table->alist *args-hash*))
-;; ==> (map (lambda (x)
-;; ==> (if (args:get-arg "-full")
-;; ==> (format #t
-;; ==> "~10a~10a~4a~27a~30a\n"
-;; ==> (vector-ref x 0)
-;; ==> (vector-ref x 1)
-;; ==> (vector-ref x 2)
-;; ==> (conc "\"" (time->string (seconds->local-time (vector-ref x 3))) "\"")
-;; ==> (conc "\"" (vector-ref x 4) "\""))
-;; ==> (print (vector-ref x 0))))
-;; ==> versions)
-;; ==> (sqlite3:finalize! db)))))
-;; ==>
-;; ==> ;; ease debugging by loading ~/.dashboardrc - REMOVE FROM PRODUCTION!
-;; ==> (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.datasharerc")))
-;; ==> (if (common:file-exists? debugcontrolf)
-;; ==> (load debugcontrolf)))
-;; ==>
-;; ==> (define (main)
-;; ==> (let* ((args (argv))
-;; ==> (prog (car args))
-;; ==> (rema (cdr args))
-;; ==> (exe-name (pathname-file (car (argv))))
-;; ==> (exe-dir (or (pathname-directory prog)
-;; ==> (datashare:find exe-name (string-split (get-environment-variable "PATH") ":"))))
-;; ==> (configdat (datashare:load-config exe-dir exe-name)))
-;; ==> (cond
-;; ==> ;; one-word commands
-;; ==> ((eq? (length rema) 1)
-;; ==> (case (string->symbol (car rema))
-;; ==> ((help -h -help --h --help)
-;; ==> (print datashare:help))
-;; ==> ((list-areas)
-;; ==> (map print (datashare:get-areas configdat)))
-;; ==> (else
-;; ==> (print "ERROR: Unrecognised command. Try \"datashare help\""))))
-;; ==> ;; multi-word commands
-;; ==> ((null? rema)(datashare:gui configdat))
-;; ==> ((>= (length rema) 2)
-;; ==> (apply datashare:process-action configdat (car rema)(cdr rema)))
-;; ==> (else (print "ERROR: Unrecognised command. Try \"datashare help\"")))))
-;; ==>
-;; ==> (main)
Index: diff-report.scm
==================================================================
--- diff-report.scm
+++ diff-report.scm
@@ -17,11 +17,10 @@
;;
(declare (unit diff-report))
(declare (uses common))
(declare (uses debugprint))
-(declare (uses rmt))
(declare (uses rmtmod))
(declare (uses commonmod))
(import commonmod
rmtmod
debugprint)
DELETED fdb_records.scm
Index: fdb_records.scm
==================================================================
--- fdb_records.scm
+++ /dev/null
@@ -1,36 +0,0 @@
-;; Copyright 2006-2017, Matthew Welland.
-;;
-;; This file is part of Megatest.
-;;
-;; Megatest is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-;;
-;; Megatest is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with Megatest. If not, see .
-
-;; Single record for managing a filedb
-;; make-vector-record "Filedb record" filedb fdb db dbpath pathcache idcache partcache
-;; Filedb record
-(define (make-filedb:fdb)(make-vector 5))
-(define-inline (filedb:fdb-get-db vec) (vector-ref vec 0))
-(define-inline (filedb:fdb-get-dbpath vec) (vector-ref vec 1))
-(define-inline (filedb:fdb-get-pathcache vec) (vector-ref vec 2))
-(define-inline (filedb:fdb-get-idcache vec) (vector-ref vec 3))
-(define-inline (filedb:fdb-get-partcache vec) (vector-ref vec 4))
-(define-inline (filedb:fdb-set-db! vec val)(vector-set! vec 0 val))
-(define-inline (filedb:fdb-set-dbpath! vec val)(vector-set! vec 1 val))
-(define-inline (filedb:fdb-set-pathcache! vec val)(vector-set! vec 2 val))
-(define-inline (filedb:fdb-set-idcache! vec val)(vector-set! vec 3 val))
-(define-inline (filedb:fdb-set-partcache! vec val)(vector-set! vec 4 val))
-
-;; children records, should have use something other than "child"
-(define-inline (filedb:child-get-id vec) (vector-ref vec 0))
-(define-inline (filedb:child-get-path vec) (vector-ref vec 1))
-(define-inline (filedb:child-get-parent_id vec)(vector-ref vec 2))
Index: megatest.scm
==================================================================
--- megatest.scm
+++ megatest.scm
@@ -79,11 +79,10 @@
(declare (uses tdb))
(declare (uses mt))
(declare (uses api))
-(declare (uses tasks)) ;; only used for debugging.
(declare (uses env))
(declare (uses diff-report))
(declare (uses db))
(declare (uses runs))
(declare (uses launch))
Index: mt.scm
==================================================================
--- mt.scm
+++ mt.scm
@@ -31,11 +31,10 @@
(declare (uses items))
(declare (uses runconfig))
(declare (uses tests))
(declare (uses server))
(declare (uses runs))
-(declare (uses rmt))
(declare (uses rmtmod))
(declare (uses megatestmod))
(import debugprint
commonmod
Index: mtexec.scm
==================================================================
--- mtexec.scm
+++ mtexec.scm
@@ -28,11 +28,10 @@
)
;; (declare (uses common))
(declare (uses mtargs))
(declare (uses configf))
-;; (declare (uses rmt))
(declare (uses commonmod))
(declare (uses configfmod))
(import commonmod
configfmod
DELETED newdashboard.scm
Index: newdashboard.scm
==================================================================
--- newdashboard.scm
+++ /dev/null
@@ -1,752 +0,0 @@
-;;======================================================================
-;; Copyright 2006-2016, Matthew Welland.
-;;
-;; This file is part of Megatest.
-;;
-;; Megatest is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-;;
-;; Megatest is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with Megatest. If not, see .
-
-;;======================================================================
-
-(declare (uses common))
-(declare (uses debugprint))
-(declare (uses megatest-version))
-(declare (uses mtargs))
-(declare (uses commonmod))
-
-(use format)
-
-(use (prefix iup iup:))
-
-(use canvas-draw)
-(import canvas-draw-iup)
-
-(use sql-de-lite srfi-1 posix regex regex-case srfi-69 typed-records sparse-vectors ;; defstruct
- (prefix dbi dbi:))
-
-(import commonmod
- debugprint
- (prefix mtargs args:))
-
-;; (declare (uses launch))
-;; (declare (uses gutils))
-;; (declare (uses db))
-;; (declare (uses server))
-(declare (uses dcommon))
-;; (declare (uses tree))
-;;
-;; (include "common_records.scm")
-;; (include "db_records.scm")
-;; (include "key_records.scm")
-
-(define help (conc
-"Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest
- version " megatest-version "
- license GPL, Copyright (C) Matt Welland 2011
-
-Usage: dashboard [options]
- -h : this help
- -server host:port : connect to host:port instead of db access
- -test testid : control test identified by testid
- -guimonitor : control panel for runs
-
-Misc
- -rows N : set number of rows
-"))
-
-;; process args
-(define remargs (args:get-args
- (argv)
- (list "-rows"
- "-run"
- "-test"
- "-debug"
- "-host"
- )
- (list "-h"
- "-guimonitor"
- "-main"
- "-v"
- "-q"
- )
- args:arg-hash
- 0))
-
-(if (args:get-arg "-h")
- (begin
- (print help)
- (exit)))
-
-;; ease debugging by loading ~/.dashboardrc
-(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc")))
- (if (common:file-exists? debugcontrolf)
- (load debugcontrolf)))
-
-(debug:setup)
-
-(define *tim* (iup:timer))
-(define *ord* #f)
-
-(iup:attribute-set! *tim* "TIME" 300)
-(iup:attribute-set! *tim* "RUN" "YES")
-
-(define (message-window msg)
- (iup:show
- (iup:dialog
- (iup:vbox
- (iup:label msg #:margin "40x40")))))
-
-(define (iuplistbox-fill-list lb items . default)
- (let ((i 1)
- (selected-item (if (null? default) #f (car default))))
- (iup:attribute-set! lb "VALUE" (if selected-item selected-item ""))
- (for-each (lambda (item)
- (iup:attribute-set! lb (number->string i) item)
- (if selected-item
- (if (equal? selected-item item)
- (iup:attribute-set! lb "VALUE" item))) ;; (number->string i))))
- (set! i (+ i 1)))
- items)
- i))
-
-(define (pad-list l n)(append l (make-list (- n (length l)))))
-
-
-(define (mkstr . x)
- (string-intersperse (map conc x) ","))
-
-(define (update-search x val)
- (hash-table-set! *searchpatts* x val))
-
-
-;; data for each specific tab goes here
-;;
-(defstruct dboard:tabdat
- ;; runs
- ((allruns '()) : list) ;; list of dboard:rundat records
- ((allruns-by-id (make-hash-table)) : hash-table) ;; hash of run-id -> dboard:rundat records
- ((done-runs '()) : list) ;; list of runs already drawn
- ((not-done-runs '()) : list) ;; list of runs not yet drawn
- (header #f) ;; header for decoding the run records
- (keys #f) ;; keys for this run (i.e. target components)
- ((numruns (string->number (or (args:get-arg "-cols") "10"))) : number) ;;
- ((tot-runs 0) : number)
- ((last-data-update 0) : number) ;; last time the data in allruns was updated
- ((last-runs-update 0) : number) ;; last time we pulled the runs info to update the tree
- (runs-mutex (make-mutex)) ;; use to prevent parallel access to draw objects
- ((run-update-times (make-hash-table)) : hash-table) ;; update times indexed by run-id
- ((last-test-dat (make-hash-table)) : hash-table) ;; cache last tests dat by run-id
- ((run-db-paths (make-hash-table)) : hash-table) ;; cache the paths to the run db files
-
- ;; Runs view
- ((buttondat (make-hash-table)) : hash-table) ;;
- ((item-test-names '()) : list) ;; list of itemized tests
- ((run-keys (make-hash-table)) : hash-table)
- (runs-matrix #f) ;; used in newdashboard
- ((start-run-offset 0) : number) ;; left-right slider value
- ((start-test-offset 0) : number) ;; up-down slider value
- ((runs-btn-height (or (configf:lookup *configdat* "dashboard" "btn-height") "x16")) : string) ;; was 12
- ((runs-btn-fontsz (or (configf:lookup *configdat* "dashboard" "btn-fontsz") "10")) : string) ;; was 8
- ((runs-cell-width (or (configf:lookup *configdat* "dashboard" "cell-width") "60")) : string) ;; was 50
- ((all-test-names '()) : list)
-
- ;; Canvas and drawing data
- (cnv #f)
- (cnv-obj #f)
- (drawing #f)
- ((run-start-row 0) : number)
- ((max-row 0) : number)
- ((running-layout #f) : boolean)
- (originx #f)
- (originy #f)
- ((layout-update-ok #t) : boolean)
- ((compact-layout #t) : boolean)
-
- ;; Run times layout
- ;; (graph-button-box #f) ;; RA => Think it is not referenced anywhere
- (graph-matrix #f)
- ((graph-matrix-table (make-hash-table)) : hash-table) ;; graph-dats referenced thru graph name info
- ((graph-cell-table (make-hash-table)) : hash-table) ;; graph-dats referenced thru matrix cell info
- ((graph-matrix-row 1) : number)
- ((graph-matrix-col 1) : number)
-
- ;; Controls used to launch runs etc.
- ((command "") : string) ;; for run control this is the command being built up
- (command-tb #f) ;; widget for the type of command; run, remove-runs etc.
- (test-patterns-textbox #f) ;; text box widget for editing a list of test patterns
- (key-listboxes #f)
- (key-lbs #f)
- run-name ;; from run name setting widget
- states ;; states for -state s1,s2 ...
- statuses ;; statuses for -status s1,s2 ...
-
- ;; Selector variables
- curr-run-id ;; current row to display in Run summary view
- prev-run-id ;; previous runid selected before current runid was selected (used in xor-two-runs runs summary mode
- curr-test-ids ;; used only in dcommon:run-update which is used in newdashboard
- ((filters-changed #t) : boolean) ;; to indicate that the user changed filters for this tab
- ((last-filter-str "") : string) ;; conc the target runname and testpatt for a signature of changed filters
- ((hide-empty-runs #f) : boolean)
- ((hide-not-hide #t) : boolean) ;; toggle for hide/not hide empty runs
- (hide-not-hide-button #f)
- ((searchpatts (make-hash-table)) : hash-table) ;;
- ((state-ignore-hash (make-hash-table)) : hash-table) ;; hash of STATE => #t/#f for display control
- ((status-ignore-hash (make-hash-table)) : hash-table) ;; hash of STATUS => #t/#f
- (target #f)
- (test-patts #f)
-
- ;; db info to file the .db files for the area
- (access-mode (db:get-access-mode)) ;; use cached db or not
- (dbdir #f)
- (dbfpath #f)
- (dbkeys #f)
- ((last-db-update (make-hash-table)) : hash-table) ;; last db file timestamp
- (monitor-db-path #f) ;; where to find monitor.db
- ro ;; is the database read-only?
-
- ;; tests data
- ((num-tests 10) : number) ;; total number of tests to show (used in the old runs display)
-
- ;; runs tree
- ((path-run-ids (make-hash-table)) : hash-table) ;; path (target / runname) => id
- (runs-tree #f)
- ((runs-tree-ht (make-hash-table)) : hash-table) ;; track which targets added to tree (merge functionality with path-run-ids?)
-
- ;; tab data
- ((view-changed #t) : boolean)
- ((xadj 0) : number) ;; x slider number (if using canvas)
- ((yadj 0) : number) ;; y slider number (if using canvas)
- ;; runs-summary tab state
- ((runs-summary-modes '((one-run . "Show One Run") (xor-two-runs . "XOR Two Runs") (xor-two-runs-hide-clean . "XOR; Hide Clean")) ) : list)
- ((runs-summary-mode-buttons '()) : list)
- ((runs-summary-mode 'one-run) : symbol)
- ((runs-summary-mode-change-callbacks '()) : list)
- (runs-summary-source-runname-label #f)
- (runs-summary-dest-runname-label #f)
- ;; runs summary view
-
- tests-tree ;; used in newdashboard
- )
-
-
-
-;; mtest is actually the megatest.config file
-;;
-(define (mtest toppath window-id)
- (let* ((curr-row-num 0)
- ;; (rawconfig (read-config (conc toppath "/megatest.config") #f 'return-string))
- (keys-matrix (iup:matrix)) ;; (dcommon:keys-matrix rawconfig))
- (setup-matrix (iup:matrix)) ;; (dcommon:section-matrix rawconfig "setup" "Varname" "Value"))
- (jobtools-matrix (iup:matrix
- #:expand "YES"
- #:numcol 1
- #:numlin 5
- #:numcol-visible 1
- #:numlin-visible 3))
- (validvals-matrix (iup:matrix
- #:expand "YES"
- #:numcol 1
- #:numlin 2
- #:numcol-visible 1
- #:numlin-visible 2))
- (envovrd-matrix (iup:matrix
- #:expand "YES"
- #:numcol 1
- #:numlin 20
- #:numcol-visible 1
- #:numlin-visible 8))
- (disks-matrix (iup:matrix
- #:expand "YES"
- #:numcol 1
- #:numlin 20
- #:numcol-visible 1
- #:numlin-visible 8))
- )
- (iup:attribute-set! disks-matrix "0:0" "Disk Name")
- (iup:attribute-set! disks-matrix "0:1" "Disk Path")
- (iup:attribute-set! disks-matrix "WIDTH1" "120")
- (iup:attribute-set! disks-matrix "WIDTH0" "100")
- (iup:attribute-set! disks-matrix "ALIGNMENT1" "ALEFT")
- (iup:attribute-set! disks-matrix "FIXTOTEXT" "C1")
- (iup:attribute-set! disks-matrix "RESIZEMATRIX" "YES")
-
- ;; fill in existing info
- (for-each
- (lambda (mat fname)
- (set! curr-row-num 1)
- (for-each
- (lambda (var)
- (iup:attribute-set! mat (conc curr-row-num ":0") var)
- ;; (iup:attribute-set! mat (conc curr-row-num ":1") (config-lookup rawconfig fname var))
- (set! curr-row-num (+ curr-row-num 1)))
- '()));; (configf:section-vars rawconfig fname)))
- (list setup-matrix jobtools-matrix validvals-matrix envovrd-matrix disks-matrix)
- (list "setup" "jobtools" "validvalues" "env-override" "disks"))
-
- (for-each
- (lambda (mat)
- (iup:attribute-set! mat "0:1" "Value")
- (iup:attribute-set! mat "0:0" "Var")
- (iup:attribute-set! mat "ALIGNMENT1" "ALEFT")
- (iup:attribute-set! mat "FIXTOTEXT" "C1")
- (iup:attribute-set! mat "RESIZEMATRIX" "YES")
- (iup:attribute-set! mat "WIDTH1" "120")
- (iup:attribute-set! mat "WIDTH0" "100")
- )
- (list setup-matrix jobtools-matrix validvals-matrix envovrd-matrix))
-
- (iup:attribute-set! validvals-matrix "WIDTH1" "290")
- (iup:attribute-set! envovrd-matrix "WIDTH1" "290")
-
- (iup:vbox
- (iup:hbox
-
- (iup:vbox
- (let ((tabs (iup:tabs
- ;; The required tab
- (iup:hbox
- ;; The keys
- (iup:frame
- #:title "Keys (required)"
- (iup:vbox
- (iup:label (conc "Set the fields for organising your runs\n"
- "here. Note: can only be changed before\n"
- "running the first run when megatest.db\n"
- "is created."))
- keys-matrix))
- (iup:vbox
- ;; The setup section
- (iup:frame
- #:title "Setup"
- (iup:vbox
- (iup:label (conc "max_concurrent_jobs : limits total concurrent jobs (optional)\n"
- "linktree : directory where linktree will be created."))
- setup-matrix))
- ;; The jobtools
- (iup:frame
- #:title "Jobtools"
- (iup:vbox
- (iup:label (conc "launcher : tool or script to run jobs (try nbfake)\n"
- "useshell : use system to run your launcher\n"
- "workhosts : spread jobs out on these hosts"))
- jobtools-matrix))
- ;; The disks
- (iup:frame
- #:title "Disks"
- (iup:vbox
- (iup:label (conc "Enter names and existing paths of locations to run tests"))
- disks-matrix))))
- ;; The optional tab
- (iup:vbox
- ;; The Environment Overrides
- (iup:frame
- #:title "Env override"
- envovrd-matrix)
- ;; The valid values
- (iup:frame
- #:title "Validvalues"
- validvals-matrix)
- ))))
- (iup:attribute-set! tabs "TABTITLE0" "Required settings")
- (iup:attribute-set! tabs "TABTITLE1" "Optional settings")
- tabs))
- ))))
-
-;; The runconfigs.config file
-;;
-(define (rconfig window-id)
- (iup:vbox
- (iup:frame #:title "Default")))
-
-;;======================================================================
-;; T E S T S
-;;======================================================================
-
-(define (tree-path->test-id path)
- (if (not (null? path))
- (hash-table-ref/default (dboard:data-path-test-ids *data*) path #f)
- #f))
-
-(define (test-panel window-id)
- (let* ((curr-row-num 0)
- (viewlog (lambda (x)
- (if (common:file-exists? logfile)
- ;(system (conc "firefox " logfile "&"))
- (iup:send-url logfile)
- (message-window (conc "File " logfile " not found")))))
- (xterm (lambda (x)
- (if (directory-exists? rundir)
- (let ((shell (if (get-environment-variable "SHELL")
- (conc "-e " (get-environment-variable "SHELL"))
- "")))
- (system (conc "cd " rundir
- ";xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&")))
- (message-window (conc "Directory " rundir " not found")))))
- (command-text-box (iup:textbox #:expand "HORIZONTAL" #:font "Courier New, -12"))
- (command-launch-button (iup:button "Execute!"
- ;; #:expand "HORIZONTAL"
- #:size "50x"
- #:action (lambda (x)
- (let ((cmd (iup:attribute command-text-box "VALUE")))
- (system (conc cmd " &"))))))
- (run-test (lambda (x)
- (iup:attribute-set!
- command-text-box "VALUE"
- (conc "xterm -geometry 180x20 -e \"megatest -target " keystring " :runname " runname
- " -runtests " (conc testname "/" (if (equal? item-path "")
- "%"
- item-path))
- ";echo Press any key to continue;bash -c 'read -n 1 -s'\""))))
- (remove-test (lambda (x)
- (iup:attribute-set!
- command-text-box "VALUE"
- (conc "xterm -geometry 180x20 -e \"megatest -remove-runs -target " keystring " :runname " runname
- " -testpatt " (conc testname "/" (if (equal? item-path "")
- "%"
- item-path))
- " -v;echo Press any key to continue;bash -c 'read -n 1 -s'\""))))
- (run-info-matrix (iup:matrix
- #:expand "YES"
- ;; #:scrollbar "YES"
- #:numcol 1
- #:numlin 4
- #:numcol-visible 1
- #:numlin-visible 4
- #:click-cb (lambda (obj lin col status)
- #f
- ;;(print "obj: " obj " lin: " lin " col: " col " status: " status)
- )))
- (test-info-matrix (iup:matrix
- #:expand "YES"
- #:numcol 1
- #:numlin 7
- #:numcol-visible 1
- #:numlin-visible 7))
- (test-run-matrix (iup:matrix
- #:expand "YES"
- #:numcol 1
- #:numlin 5
- #:numcol-visible 1
- #:numlin-visible 5))
- (meta-dat-matrix (iup:matrix
- #:expand "YES"
- #:numcol 1
- #:numlin 5
- #:numcol-visible 1
- #:numlin-visible 5))
- (steps-matrix (iup:matrix
- #:expand "YES"
- #:numcol 6
- #:numlin 50
- #:numcol-visible 6
- #:numlin-visible 8))
- (data-matrix (iup:matrix
- #:expand "YES"
- #:numcol 8
- #:numlin 50
- #:numcol-visible 8
- #:numlin-visible 8))
- (updater (lambda (testdat)
- (test-update window-id testdat run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix steps-matrix data-matrix))))
-
- ;; Set the updater in updaters
- ;; (hash-table-set! (dboard:data-updaters *data*) window-id updater)
- ;;
- (for-each
- (lambda (mat)
- ;; (iup:attribute-set! mat "0:1" "Value")
- ;; (iup:attribute-set! mat "0:0" "Var")
- (iup:attribute-set! mat "HEIGHT0" 0)
- (iup:attribute-set! mat "ALIGNMENT1" "ALEFT")
- ;; (iup:attribute-set! mat "FIXTOTEXT" "C1")
- (iup:attribute-set! mat "RESIZEMATRIX" "YES"))
- ;; (iup:attribute-set! mat "WIDTH1" "120")
- ;; (iup:attribute-set! mat "WIDTH0" "100"))
- (list run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix))
-
- ;; Steps matrix
- (iup:attribute-set! steps-matrix "0:1" "Step Name")
- (iup:attribute-set! steps-matrix "0:2" "Start")
- (iup:attribute-set! steps-matrix "WIDTH2" "40")
- (iup:attribute-set! steps-matrix "0:3" "End")
- (iup:attribute-set! steps-matrix "WIDTH3" "40")
- (iup:attribute-set! steps-matrix "0:4" "Status")
- (iup:attribute-set! steps-matrix "WIDTH4" "40")
- (iup:attribute-set! steps-matrix "0:5" "Duration")
- (iup:attribute-set! steps-matrix "WIDTH5" "40")
- (iup:attribute-set! steps-matrix "0:6" "Log File")
- (iup:attribute-set! steps-matrix "ALIGNMENT1" "ALEFT")
- ;; (iup:attribute-set! steps-matrix "FIXTOTEXT" "C1")
- (iup:attribute-set! steps-matrix "RESIZEMATRIX" "YES")
- ;; (iup:attribute-set! steps-matrix "WIDTH1" "120")
- ;; (iup:attribute-set! steps-matrix "WIDTH0" "100")
-
- ;; Data matrix
- ;;
- (let ((rownum 1))
- (for-each
- (lambda (x)
- (iup:attribute-set! data-matrix (conc "0:" rownum) x)
- (iup:attribute-set! data-matrix (conc "WIDTH" rownum) "50")
- (set! rownum (+ rownum 1)))
- (list "Category" "Variable" "Value" "Expected" "Tolerance" "Status" "Units" "Type" "Comment")))
- (iup:attribute-set! data-matrix "REDRAW" "ALL")
-
- (for-each
- (lambda (data)
- (let ((mat (car data))
- (keys (cadr data))
- (rownum 1))
- (for-each
- (lambda (key)
- (iup:attribute-set! mat (conc rownum ":0") key)
- (set! rownum (+ rownum 1)))
- keys)
- (iup:attribute-set! mat "REDRAW" "ALL")))
- (list
- (list run-info-matrix '("Run Id" "Target" "Runname" "Run Start Time" ))
- (list test-info-matrix '("Test Id" "Testname" "Itempath" "State" "Status" "Test Start Time" "Comment"))
- (list test-run-matrix '("Hostname" "Host info" "Disk Free" "CPU Load" "Run Duration"))
- (list meta-dat-matrix '("Author" "Owner" "Last Reviewed" "Tags" "Description"))))
-
- (iup:split
- #:orientation "HORIZONTAL"
- (iup:vbox
- (iup:hbox
- (iup:vbox
- run-info-matrix
- test-info-matrix)
- ;; test-info-matrix)
- (iup:vbox
- test-run-matrix
- meta-dat-matrix))
- (iup:vbox
- (iup:vbox
- (iup:hbox
- (iup:button "View Log" #:action viewlog #:size "60x" ) ;; #:size "30x"
- (iup:button "Start Xterm" #:action xterm #:size "60x" )) ;; #:size "30x"
- (iup:hbox
- (iup:button "Run Test" #:action run-test #:size "60x" ) ;; #:size "30x"
- (iup:button "Clean Test" #:action remove-test #:size "60x" ))) ;; #:size "30x"
- (iup:hbox
- ;; hiup:split ;; hbox
- ;; #:orientation "HORIZONTAL"
- ;; #:value 300
- command-text-box
- command-launch-button)))
- (iup:vbox
- (let ((tabs (iup:tabs
- steps-matrix
- data-matrix)))
- (iup:attribute-set! tabs "TABTITLE0" "Test Steps")
- (iup:attribute-set! tabs "TABTITLE1" "Test Data")
- tabs)))))
-
-;; Test browser
-(define (tests window-id)
- (iup:split
- (let* ((tb (iup:treebox
- #:selection-cb
- (lambda (obj id state)
- ;; (print "obj: " obj ", id: " id ", state: " state)
- (let* ((run-path (tree:node->path obj id))
- (test-id (tree-path->test-id (cdr run-path))))
- ;; (if test-id
- ;; (hash-table-set! (dboard:data-curr-test-ids *data*)
- ;; window-id test-id))
- ;; (print "path: " (tree:node->path obj id) " test-id: " test-id)
- )))))
- (iup:attribute-set! tb "VALUE" "0")
- (iup:attribute-set! tb "NAME" "Runs")
- ;;(iup:attribute-set! tb "ADDEXPANDED" "NO")
- ;; (dboard:data-tests-tree-set! *data* tb)
- tb)
- (test-panel window-id)))
-
-;; The function to update the fields in the test view panel
-(define (test-update window-id testdat run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix steps-matrix data-matrix)
- ;; get test-id
- ;; then get test record
- (if testdat
- (let* ((test-id 0) ;; (hash-table-ref/default (dboard:data-curr-test-ids *data*) window-id #f))
- (test-data (hash-table-ref/default testdat test-id #f))
- (run-id (db:test-get-run_id test-data))
- (targ/runname (hash-table-ref/default (dboard:data-run-keys *data*)
- run-id
- '()))
- (target (if (null? targ/runname) "" (string-intersperse (reverse (cdr (reverse targ/runname))) "/")))
- (runname (if (null? targ/runname) "" (car (cdr targ/runname))))
- (steps-dat (tests:get-compressed-steps *dbstruct-local* run-id test-id)))
-
- (if test-data
- (begin
- ;;
- (for-each
- (lambda (data)
- (let ((mat (car data))
- (vals (cadr data))
- (rownum 1))
- (for-each
- (lambda (key)
- (let ((cell (conc rownum ":1")))
- (if (not (equal? (iup:attribute mat cell)(conc key)))
- (begin
- ;; (print "setting cell " cell " in matrix " mat " to value " key)
- (iup:attribute-set! mat cell (conc key))
- (iup:attribute-set! mat "REDRAW" cell)))
- (set! rownum (+ rownum 1))))
- vals)))
- (list
- (list run-info-matrix
- (if test-id
- (list (db:test-get-run_id test-data)
- target
- runname
- "n/a")
- (make-list 4 "")))
- (list test-info-matrix
- (if test-id
- (list test-id
- (db:test-get-testname test-data)
- (db:test-get-item-path test-data)
- (db:test-get-state test-data)
- (db:test-get-status test-data)
- (seconds->string (db:test-get-event_time test-data))
- (db:test-get-comment test-data))
- (make-list 7 "")))
- (list test-run-matrix
- (if test-id
- (list (db:test-get-host test-data)
- (db:test-get-uname test-data)
- (db:test-get-diskfree test-data)
- (db:test-get-cpuload test-data)
- (seconds->hr-min-sec (db:test-get-run_duration test-data)))
- (make-list 5 "")))
- ))
- (dcommon:populate-steps steps-dat steps-matrix))))))
- ;;(list meta-dat-matrix
- ;; (if test-id
- ;; (list (
-
-
-;; db:test-get-id
-;; db:test-get-run_id
-;; db:test-get-testname
-;; db:test-get-state
-;; db:test-get-status
-;; db:test-get-event_time
-;; db:test-get-host
-;; db:test-get-cpuload
-;; db:test-get-diskfree
-;; db:test-get-uname
-;; db:test-get-rundir
-;; db:test-get-item-path
-;; db:test-get-run_duration
-;; db:test-get-final_logf
-;; db:test-get-comment
-;; db:test-get-fullname
-
-
-;;======================================================================
-;; R U N C O N T R O L
-;;======================================================================
-
-;; Overall runs browser
-;;
-(define (runs window-id)
- (let* ((runs-matrix (iup:matrix
- #:expand "YES"
- ;; #:fittosize "YES"
- #:scrollbar "YES"
- #:numcol 100
- #:numlin 100
- #:numcol-visible 7
- #:numlin-visible 7
- #:click-cb (lambda (obj lin col status)
- #f
- ;; (print "obj: " obj " lin: " lin " col: " col " status: " status)
- ))))
-
- (iup:attribute-set! runs-matrix "RESIZEMATRIX" "YES")
- (iup:attribute-set! runs-matrix "WIDTH0" "100")
-
- ;; (dboard:data-runs-matrix-set! *data* runs-matrix)
- (iup:hbox
- (iup:frame
- #:title "Runs browser"
- (iup:vbox
- runs-matrix)))))
-
-;; Browse and control a single run
-;;
-(define (runcontrol window-id)
- (iup:hbox))
-
-;;======================================================================
-;; D A S H B O A R D
-;;======================================================================
-
-;; Main Panel
-(define (main-panel window-id)
- (iup:dialog
- #:title "Megatest Control Panel"
- #:menu (dcommon:main-menu)
- #:shrink "YES"
- (let ((tabtop (iup:tabs
- (runs window-id)
- (tests window-id)
- (runcontrol window-id)
- (mtest *toppath* window-id)
- (rconfig window-id)
- )))
- (iup:attribute-set! tabtop "TABTITLE0" "Runs")
- (iup:attribute-set! tabtop "TABTITLE1" "Tests")
- (iup:attribute-set! tabtop "TABTITLE2" "Run Control")
- (iup:attribute-set! tabtop "TABTITLE3" "megatest.config")
- (iup:attribute-set! tabtop "TABTITLE4" "runconfigs.config")
- tabtop)))
-
-(define *current-window-id* 0)
-
-(define (newdashboard dbstruct)
- (let* ((data (make-hash-table))
- (keys '()) ;; (db:get-keys dbstruct))
- (runname "%")
- (testpatt "%")
- (keypatts '()) ;; (map (lambda (k)(list k "%")) keys))
- (states '())
- (statuses '())
- (nextmintime (current-milliseconds))
- (my-window-id *current-window-id*))
- (set! *current-window-id* (+ 1 *current-window-id*))
- ;; (dboard:data-runs-set! *data* data) ;; make this data available to the rest of the application
- (iup:show (main-panel my-window-id))
- ;; Yes, running iup:show will pop up a new panel
- ;; (iup:show (main-panel my-window-id))
- (iup:callback-set! *tim*
- "ACTION_CB"
- (lambda (x)
- ;; Want to dedicate no more than 50% of the time to this so skip if
- ;; 2x delta time has not passed since last query
- (if (< nextmintime (current-milliseconds))
- (let* ((starttime (current-milliseconds))
- ;; (changes (dcommon:run-update keys data runname keypatts testpatt states statuses 'full my-window-id))
- (endtime (current-milliseconds)))
- (set! nextmintime (+ endtime (* 2 (- endtime starttime))))
- ;; (debug:print 11 *default-log-port* "CHANGE(S): " (car changes) "..."))
- )
- (debug:print-info 11 *default-log-port* "Server overloaded"))))))
-
-;; (dboard:data-updaters-set! *data* (make-hash-table))
-(newdashboard #f) ;; *dbstruct-local*)
-(iup:main-loop)
DELETED rmt.scm
Index: rmt.scm
==================================================================
--- rmt.scm
+++ /dev/null
@@ -1,52 +0,0 @@
-;;======================================================================
-;; Copyright 2006-2017, Matthew Welland.
-;;
-;; This file is part of Megatest.
-;;
-;; Megatest is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-;;
-;; Megatest is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with Megatest. If not, see .
-;;
-;;======================================================================
-
-(use format typed-records) ;; RADT => purpose of json format??
-
-(declare (unit rmt))
-(declare (uses debugprint))
-(declare (uses api))
-(declare (uses common))
-(declare (uses commonmod))
-(declare (uses configfmod))
-(declare (uses dbfile))
-(declare (uses dbmod))
-(declare (uses tcp-transportmod))
-(include "common_records.scm")
-(declare (uses rmtmod))
-
-;; used by http-transport
-(import dbfile
- rmtmod
- commonmod
- configfmod
- debugprint
-;; dbmemmod
- dbfile
- dbmod
- tcp-transportmod)
-
-;;
-;; THESE ARE ALL CALLED ON THE CLIENT SIDE!!!
-;;
-
-;; generate entries for ~/.megatestrc with the following
-;;
-;; grep define ../rmt.scm | grep rmt: |perl -pi -e 's/\(define\s+\((\S+)\W.*$/\1/'|sort -u
ADDED sauth/datashare.scm
Index: sauth/datashare.scm
==================================================================
--- /dev/null
+++ sauth/datashare.scm
@@ -0,0 +1,824 @@
+
+;; Copyright 2006-2013, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see .
+
+;; ==> (module datashare
+;; ==> (use ssax)
+;; ==> (use sxml-serializer)
+;; ==> (use sxml-modifications)
+;; ==> (use regex)
+;; ==> (use srfi-69)
+;; ==> (use regex-case)
+;; ==> (use posix)
+;; ==> (use json)
+;; ==> (use csv)
+;; ==> (use srfi-18)
+;; ==> (use format)
+;; ==>
+;; ==> (use (prefix iup iup:))
+;; ==> (import (prefix ini-file ini:))
+;; ==>
+;; ==> (use canvas-draw)
+;; ==> (import canvas-draw-iup)
+;; ==>
+;; ==> (use sqlite3 srfi-1 posix regex regex-case srfi-69)
+;; ==> (import (prefix sqlite3 sqlite3:))
+;; ==>
+;; ==> (declare (uses configf))
+;; ==> (declare (uses tree))
+;; ==> (declare (uses margs))
+;; ==> ;; (declare (uses dcommon))
+;; ==> ;; (declare (uses launch))
+;; ==> ;; (declare (uses gutils))
+;; ==> ;; (declare (uses db))
+;; ==> ;; (declare (uses synchash))
+;; ==> ;; (declare (uses server))
+;; ==> ;; (declare (uses megatest-version))
+;; ==> ;; (declare (uses tbd))
+;; ==>
+;; ==> (include "megatest-fossil-hash.scm")
+;; ==>
+;; ==> ;;
+;; ==> ;; GLOBALS
+;; ==> ;;
+;; ==> (define *datashare:current-tab-number* 0)
+;; ==> (define *args-hash* (make-hash-table))
+;; ==> (define datashare:help (conc "Usage: datashare [action [params ...]]
+;; ==>
+;; ==> Note: run datashare without parameters to start the gui.
+;; ==>
+;; ==> list-areas : List the allowed areas
+;; ==>
+;; ==> list-versions : List versions available in
+;; ==> options : -full, -vpatt patt
+;; ==>
+;; ==> publish : Publish data for area and with version
+;; ==>
+;; ==> get : Get a link to data, put the link in destpath
+;; ==> options : -i iteration
+;; ==>
+;; ==> update : Update the link to data to the latest iteration.
+;; ==>
+;; ==> Part of the Megatest tool suite.
+;; ==> Learn more at http://www.kiatoa.com/fossils/megatest
+;; ==>
+;; ==> Version: " megatest-fossil-hash)) ;; "
+;; ==>
+;; ==> ;;======================================================================
+;; ==> ;; RECORDS
+;; ==> ;;======================================================================
+;; ==>
+;; ==> ;; make-vector-record "testing" datastore pkg id area version_name store_type copied source_path iteration submitter datetime storegrp datavol quality disk_id comment
+;; ==> ;; testing
+;; ==> (define (make-datashare:pkg)(make-vector 15))
+;; ==> (define-inline (datashare:pkg-get-id vec) (vector-ref vec 0))
+;; ==> (define-inline (datashare:pkg-get-area vec) (vector-ref vec 1))
+;; ==> (define-inline (datashare:pkg-get-version_name vec) (vector-ref vec 2))
+;; ==> (define-inline (datashare:pkg-get-store_type vec) (vector-ref vec 3))
+;; ==> (define-inline (datashare:pkg-get-copied vec) (vector-ref vec 4))
+;; ==> (define-inline (datashare:pkg-get-source_path vec) (vector-ref vec 5))
+;; ==> (define-inline (datashare:pkg-get-iteration vec) (vector-ref vec 6))
+;; ==> (define-inline (datashare:pkg-get-submitter vec) (vector-ref vec 7))
+;; ==> (define-inline (datashare:pkg-get-datetime vec) (vector-ref vec 8))
+;; ==> (define-inline (datashare:pkg-get-storegrp vec) (vector-ref vec 9))
+;; ==> (define-inline (datashare:pkg-get-datavol vec) (vector-ref vec 10))
+;; ==> (define-inline (datashare:pkg-get-quality vec) (vector-ref vec 11))
+;; ==> (define-inline (datashare:pkg-get-disk_id vec) (vector-ref vec 12))
+;; ==> (define-inline (datashare:pkg-get-comment vec) (vector-ref vec 13))
+;; ==> (define-inline (datashare:pkg-get-stored_path vec) (vector-ref vec 14))
+;; ==> (define-inline (datashare:pkg-set-id! vec val)(vector-set! vec 0 val))
+;; ==> (define-inline (datashare:pkg-set-area! vec val)(vector-set! vec 1 val))
+;; ==> (define-inline (datashare:pkg-set-version_name! vec val)(vector-set! vec 2 val))
+;; ==> (define-inline (datashare:pkg-set-store_type! vec val)(vector-set! vec 3 val))
+;; ==> (define-inline (datashare:pkg-set-copied! vec val)(vector-set! vec 4 val))
+;; ==> (define-inline (datashare:pkg-set-source_path! vec val)(vector-set! vec 5 val))
+;; ==> (define-inline (datashare:pkg-set-iteration! vec val)(vector-set! vec 6 val))
+;; ==> (define-inline (datashare:pkg-set-submitter! vec val)(vector-set! vec 7 val))
+;; ==> (define-inline (datashare:pkg-set-datetime! vec val)(vector-set! vec 8 val))
+;; ==> (define-inline (datashare:pkg-set-storegrp! vec val)(vector-set! vec 9 val))
+;; ==> (define-inline (datashare:pkg-set-datavol! vec val)(vector-set! vec 10 val))
+;; ==> (define-inline (datashare:pkg-set-quality! vec val)(vector-set! vec 11 val))
+;; ==> (define-inline (datashare:pkg-set-disk_id! vec val)(vector-set! vec 12 val))
+;; ==> (define-inline (datashare:pkg-set-comment! vec val)(vector-set! vec 13 val))
+;; ==> (define-inline (datashare:pkg-set-stored_path! vec val)(vector-set! vec 14 val))
+;; ==>
+;; ==> ;;======================================================================
+;; ==> ;; DB
+;; ==> ;;======================================================================
+;; ==>
+;; ==> (define (datashare:initialize-db db)
+;; ==> (for-each
+;; ==> (lambda (qry)
+;; ==> (sqlite3:execute db qry))
+;; ==> (list
+;; ==> "CREATE TABLE pkgs
+;; ==> (id INTEGER PRIMARY KEY,
+;; ==> area TEXT,
+;; ==> version_name TEXT,
+;; ==> store_type TEXT DEFAULT 'copy',
+;; ==> copied INTEGER DEFAULT 0,
+;; ==> source_path TEXT,
+;; ==> stored_path TEXT,
+;; ==> iteration INTEGER DEFAULT 0,
+;; ==> submitter TEXT,
+;; ==> datetime TIMESTAMP DEFAULT (strftime('%s','now')),
+;; ==> storegrp TEXT,
+;; ==> datavol INTEGER,
+;; ==> quality TEXT,
+;; ==> disk_id INTEGER,
+;; ==> comment TEXT);"
+;; ==> "CREATE TABLE refs
+;; ==> (id INTEGER PRIMARY KEY,
+;; ==> pkg_id INTEGER,
+;; ==> destlink TEXT);"
+;; ==> "CREATE TABLE disks
+;; ==> (id INTEGER PRIMARY KEY,
+;; ==> storegrp TEXT,
+;; ==> path TEXT);")))
+;; ==>
+;; ==> (define (datashare:register-data db area version-name store-type submitter quality source-path comment)
+;; ==> (let ((iter-qry (sqlite3:prepare db "SELECT max(iteration) FROM pkgs WHERE area=? AND version_name=?;"))
+;; ==> (next-iteration 0))
+;; ==> (sqlite3:with-transaction
+;; ==> db
+;; ==> (lambda ()
+;; ==> (sqlite3:for-each-row
+;; ==> (lambda (iteration)
+;; ==> (if (and (number? iteration)
+;; ==> (>= iteration next-iteration))
+;; ==> (set! next-iteration (+ iteration 1))))
+;; ==> iter-qry area version-name)
+;; ==> ;; now store the data
+;; ==> (sqlite3:execute db "INSERT INTO pkgs (area,version_name,iteration,store_type,submitter,source_path,quality,comment)
+;; ==> VALUES (?,?,?,?,?,?,?,?);"
+;; ==> area version-name next-iteration (conc store-type) submitter source-path quality comment)))
+;; ==> (sqlite3:finalize! iter-qry)
+;; ==> next-iteration))
+;; ==>
+;; ==> (define (datashare:get-id db area version-name iteration)
+;; ==> (let ((res #f))
+;; ==> (sqlite3:for-each-row
+;; ==> (lambda (id)
+;; ==> (set! res id))
+;; ==> db
+;; ==> "SELECT id FROM pkgs WHERE area=? AND version_name=? AND iteration=?;"
+;; ==> area version-name iteration)
+;; ==> res))
+;; ==>
+;; ==> (define (datashare:set-stored-path db id path)
+;; ==> (sqlite3:execute db "UPDATE pkgs SET stored_path=? WHERE id=?;" path id))
+;; ==>
+;; ==> (define (datashare:set-copied db id value)
+;; ==> (sqlite3:execute db "UPDATE pkgs SET copied=? WHERE id=?;" value id))
+;; ==>
+;; ==> (define (datashare:get-pkg-record db area version-name iteration)
+;; ==> (let ((res #f))
+;; ==> (sqlite3:for-each-row
+;; ==> (lambda (a . b)
+;; ==> (set! res (apply vector a b)))
+;; ==> db
+;; ==> "SELECT * FROM pkgs WHERE area=? AND version_name=? AND iteration=?;"
+;; ==> area
+;; ==> version-name
+;; ==> iteration)
+;; ==> res))
+;; ==>
+;; ==> ;; take version-name iteration and register or update "lastest/0"
+;; ==> ;;
+;; ==> (define (datashare:set-latest db id area version-name iteration)
+;; ==> (let* ((rec (datashare:get-pkg-record db area version-name iteration))
+;; ==> (latest-id (datashare:get-id db area "latest" 0))
+;; ==> (stored-path (datashare:pkg-get-stored_path rec)))
+;; ==> (if latest-id ;; have a record - bump the link pointer
+;; ==> (datashare:set-stored-path db latest-id stored-path)
+;; ==> (datashare:register-data db area "latest" 'link "auto" "na" stored-path "latest data"))))
+;; ==>
+;; ==> ;; set a package ref, this is the location where the link back to the stored data
+;; ==> ;; is put.
+;; ==> ;;
+;; ==> ;; if there is nothing at that location then the record can be removed
+;; ==> ;; if there are no refs for a particular pkg-id then that pkg-id is a
+;; ==> ;; candidate for removal
+;; ==> ;;
+;; ==> (define (datashare:record-pkg-ref db pkg-id dest-link)
+;; ==> (sqlite3:execute db "INSERT INTO refs (pkg_id,destlink) VALUES (?,?);" pkg-id dest-link))
+;; ==>
+;; ==> (define (datashare:count-refs db pkg-id)
+;; ==> (let ((res 0))
+;; ==> (sqlite3:for-each-row
+;; ==> (lambda (count)
+;; ==> (set! res count))
+;; ==> db
+;; ==> "SELECT count(id) FROM refs WHERE pkg_id=?;"
+;; ==> pkg-id)
+;; ==> res))
+;; ==>
+;; ==> ;; Create the sqlite db
+;; ==> (define (datashare:open-db configdat)
+;; ==> (let ((path (configf:lookup configdat "database" "location")))
+;; ==> (if (and path
+;; ==> (directory? path)
+;; ==> (file-read-access? path))
+;; ==> (let* ((dbpath (conc path "/datashare.db"))
+;; ==> (writeable (file-write-access? dbpath))
+;; ==> (dbexists (common:file-exists? dbpath))
+;; ==> (handler (make-busy-timeout 136000)))
+;; ==> (handle-exceptions
+;; ==> exn
+;; ==> (begin
+;; ==> (debug:print 2 *default-log-port* "ERROR: problem accessing db " dbpath
+;; ==> ((condition-property-accessor 'exn 'message) exn))
+;; ==> (exit))
+;; ==> (set! db (sqlite3:open-database dbpath)))
+;; ==> (if *db-write-access* (sqlite3:set-busy-handler! db handler))
+;; ==> (if (not dbexists)
+;; ==> (begin
+;; ==> (datashare:initialize-db db)))
+;; ==> db)
+;; ==> (print "ERROR: invalid path for storing database: " path))))
+;; ==>
+;; ==> (define (open-run-close-exception-handling proc idb . params)
+;; ==> (handle-exceptions
+;; ==> exn
+;; ==> (let ((sleep-time (random 30))
+;; ==> (err-status ((condition-property-accessor 'sqlite3 'status #f) exn)))
+;; ==> (case err-status
+;; ==> ((busy)
+;; ==> (thread-sleep! sleep-time))
+;; ==> (else
+;; ==> (print "EXCEPTION: database overloaded or unreadable.")
+;; ==> (print " message: " ((condition-property-accessor 'exn 'message) exn))
+;; ==> (print "exn=" (condition->list exn))
+;; ==> (print " status: " ((condition-property-accessor 'sqlite3 'status) exn))
+;; ==> (print-call-chain (current-error-port))
+;; ==> (thread-sleep! sleep-time)
+;; ==> (print "trying db call one more time....this may never recover, if necessary kill process " (current-process-id) " on host " (get-host-name) " to clean up")))
+;; ==> (apply open-run-close-exception-handling proc idb params))
+;; ==> (apply open-run-close-no-exception-handling proc idb params)))
+;; ==>
+;; ==> (define (open-run-close-no-exception-handling proc idb . params)
+;; ==> ;; (print "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params)
+;; ==> (let* ((db (cond
+;; ==> ((sqlite3:database? idb) idb)
+;; ==> ((not idb) (print "ERROR: cannot open-run-close with #f anymore"))
+;; ==> ((procedure? idb) (idb))
+;; ==> (else (print "ERROR: cannot open-run-close with #f anymore"))))
+;; ==> (res #f))
+;; ==> (set! res (apply proc db params))
+;; ==> (if (not idb)(sqlite3:finalize! dbstruct))
+;; ==> ;; (print "open-run-close-no-exception-handling END" )
+;; ==> res))
+;; ==>
+;; ==> (define open-run-close open-run-close-no-exception-handling)
+;; ==>
+;; ==> (define (datashare:get-pkgs db area-filter version-filter iter-filter)
+;; ==> (let ((res '()))
+;; ==> (sqlite3:for-each-row ;; replace with fold ...
+;; ==> (lambda (a . b)
+;; ==> (set! res (cons (list->vector (cons a b)) res)))
+;; ==> db
+;; ==> (conc "SELECT id,area,version_name,store_type,copied,source_path,iteration,submitter,datetime,storegrp,datavol,quality,disk_id,comment,stored_path "
+;; ==> " FROM pkgs WHERE area like ? AND version_name LIKE ? AND iteration " iter-filter ";")
+;; ==> area-filter version-filter)
+;; ==> (reverse res)))
+;; ==>
+;; ==> (define (datashare:get-pkg db area-name version-name #!key (iteration #f))
+;; ==> (let ((dat '())
+;; ==> (res #f))
+;; ==> (sqlite3:for-each-row ;; replace with fold ...
+;; ==> (lambda (a . b)
+;; ==> (set! dat (cons (list->vector (cons a b)) dat)))
+;; ==> db
+;; ==> (conc "SELECT id,area,version_name,store_type,copied,source_path,iteration,submitter,datetime,storegrp,datavol,quality,disk_id,comment,stored_path "
+;; ==> " FROM pkgs WHERE area=? AND version_name=? ORDER BY iteration ASC;")
+;; ==> area-name version-name)
+;; ==> ;; now filter for iteration, either max if #f or specific one
+;; ==> (if (null? dat)
+;; ==> #f
+;; ==> (let loop ((hed (car dat))
+;; ==> (tal (cdr dat))
+;; ==> (cur 0))
+;; ==> (let ((itr (datashare:pkg-get-iteration hed)))
+;; ==> (if (equal? itr iteration) ;; this is the one if iteration is specified
+;; ==> hed
+;; ==> (if (null? tal)
+;; ==> hed
+;; ==> (loop (car tal)(cdr tal)))))))))
+;; ==>
+;; ==> (define (datashare:get-versions-for-area db area-name #!key (version-patt #f))
+;; ==> (let ((res '())
+;; ==> (data (make-hash-table)))
+;; ==> (sqlite3:for-each-row
+;; ==> (lambda (version-name submitter iteration submitted-time comment)
+;; ==> ;; 0 1 2 3 4
+;; ==> (hash-table-set! data version-name (vector version-name submitter iteration submitted-time comment)))
+;; ==> db
+;; ==> "SELECT version_name,submitter,iteration,datetime,comment FROM pkgs WHERE area='megatest' AND version_name != 'latest' AND version_name LIKE ? ORDER BY datetime asc;"
+;; ==> (or version-patt "%"))
+;; ==> (map (lambda (x)(hash-table-ref data x))(sort (hash-table-keys data) string-ci>=))))
+;; ==>
+;; ==> ;;======================================================================
+;; ==> ;; DATA IMPORT/EXPORT
+;; ==> ;;======================================================================
+;; ==>
+;; ==> (define (datashare:import-data configdat source-path dest-path area version iteration)
+;; ==> (let* ((space-avail (car dest-path))
+;; ==> (disk-path (cdr dest-path))
+;; ==> (targ-path (conc disk-path "/" area "/" version "/" iteration))
+;; ==> (id (datashare:get-id db area version iteration))
+;; ==> (db (datashare:open-db configdat)))
+;; ==> (if (> space-avail 10000) ;; dumb heuristic
+;; ==> (begin
+;; ==> (create-directory targ-path #t)
+;; ==> (datashare:set-stored-path db id targ-path)
+;; ==> (print "Running command: rsync -av " source-path "/ " targ-path "/")
+;; ==> (let ((th1 (make-thread (lambda ()
+;; ==> (let ((pid (process-run "rsync" (list "-av" (conc source-path "/") (conc targ-path "/")))))
+;; ==> (process-wait pid)
+;; ==> (datashare:set-copied db id "yes")
+;; ==> (sqlite3:finalize! db)))
+;; ==> "Data copy")))
+;; ==> (thread-start! th1))
+;; ==> #t)
+;; ==> (begin
+;; ==> (print "ERROR: Not enough space in storage area " dest-path)
+;; ==> (datashare:set-copied db id "no")
+;; ==> (sqlite3:finalize! db)
+;; ==> #f))))
+;; ==>
+;; ==> (define (datashare:get-areas configdat)
+;; ==> (let* ((areadat (configf:get-section configdat "areas"))
+;; ==> (areas (if areadat (map car areadat) '())))
+;; ==> areas))
+;; ==>
+;; ==> (define (datashare:publish configdat publish-type area-name version comment spath submitter quality)
+;; ==> ;; input checks
+;; ==> (cond
+;; ==> ((not (member area-name (datashare:get-areas configdat)))
+;; ==> (cons #f (conc "Illegal area name \"" area-name "\"")))
+;; ==> (else
+;; ==> (let ((db (datashare:open-db configdat))
+;; ==> (iteration (datashare:register-data db area-name version publish-type submitter quality spath comment))
+;; ==> (dest-store (datashare:get-best-storage configdat)))
+;; ==> (if iteration
+;; ==> (if (eq? 'copy publish-type)
+;; ==> (begin
+;; ==> (datashare:import-data configdat spath dest-store area-name version iteration)
+;; ==> (let ((id (datashare:get-id db area-name version iteration)))
+;; ==> (datashare:set-latest db id area-name version iteration)))
+;; ==> (let ((id (datashare:get-id db area-name version iteration)))
+;; ==> (datashare:set-stored-path db id spath)
+;; ==> (datashare:set-copied db id "yes")
+;; ==> (datashare:set-copied db id "n/a")
+;; ==> (datashare:set-latest db id area-name version iteration)))
+;; ==> (print "ERROR: Failed to get an iteration number"))
+;; ==> (sqlite3:finalize! db)
+;; ==> (cons #t "Successfully saved data")))))
+;; ==>
+;; ==> (define (datashare:get-best-storage configdat)
+;; ==> (let* ((storage (configf:lookup configdat "settings" "storage"))
+;; ==> (store-areas (if storage (string-split storage) '())))
+;; ==> (print "Looking for available space in " store-areas)
+;; ==> (datashare:find-most-space store-areas)))
+;; ==>
+;; ==> ;; (string->number (list-ref (with-input-from-pipe "df -B1000000 /tmp" (lambda ()(read-line)(string-split (read-line)))) 3))
+;; ==>
+;; ==> (define (datashare:find-most-space paths)
+;; ==> (fold (lambda (area res)
+;; ==> ;; (print "area=" area " res=" res)
+;; ==> (let ((maxspace (car res))
+;; ==> (currpath (cdr res)))
+;; ==> ;; (print currpath " " maxspace)
+;; ==> (if (file-write-access? area)
+;; ==> (let ((currspace (string->number
+;; ==> (list-ref
+;; ==> (with-input-from-pipe
+;; ==> ;; (conc "df --output=avail " area)
+;; ==> (conc "df -B1000000 " area)
+;; ==> ;; (lambda ()(read)(read))
+;; ==> (lambda ()(read-line)(string-split (read-line))))
+;; ==> 3))))
+;; ==> (if (> currspace maxspace)
+;; ==> (cons currspace area)
+;; ==> res))
+;; ==> res)))
+;; ==> (cons 0 #f)
+;; ==> paths))
+;; ==>
+;; ==> ;; remove existing link and if possible ...
+;; ==> ;; create path to next of tip of target, create link back to source
+;; ==> (define (datashare:build-dir-make-link source target)
+;; ==> (if (common:file-exists? target)(datashare:backup-move target))
+;; ==> (create-directory (pathname-directory target) #t)
+;; ==> (create-symbolic-link source target))
+;; ==>
+;; ==> (define (datashare:backup-move path)
+;; ==> (let* ((trashdir (conc (pathname-directory path) "/.trash"))
+;; ==> (trashfile (conc trashdir "/" (current-seconds) "-" (pathname-file path))))
+;; ==> (create-directory trashdir #t)
+;; ==> (if (directory? path)
+;; ==> (system (conc "mv " path " " trashfile))
+;; ==> (file-move path trash-file))))
+;; ==>
+;; ==> ;;======================================================================
+;; ==> ;; GUI
+;; ==> ;;======================================================================
+;; ==>
+;; ==> ;; The main menu
+;; ==> (define (datashare:main-menu)
+;; ==> (iup:menu ;; a menu is a special attribute to a dialog (think Gnome putting the menu at screen top)
+;; ==> (iup:menu-item "Files" (iup:menu ;; Note that you can use either #:action or action: for options
+;; ==> (iup:menu-item "Open" action: (lambda (obj)
+;; ==> (iup:show (iup:file-dialog))
+;; ==> (print "File->open " obj)))
+;; ==> (iup:menu-item "Save" #:action (lambda (obj)(print "File->save " obj)))
+;; ==> (iup:menu-item "Exit" #:action (lambda (obj)(exit)))))
+;; ==> (iup:menu-item "Tools" (iup:menu
+;; ==> (iup:menu-item "Create new blah" #:action (lambda (obj)(print "Tools->new blah")))
+;; ==> ;; (iup:menu-item "Show dialog" #:action (lambda (obj)
+;; ==> ;; (show message-window
+;; ==> ;; #:modal? #t
+;; ==> ;; ;; set positon using coordinates or center, start, top, left, end, bottom, right, parent-center, current
+;; ==> ;; ;; #:x 'mouse
+;; ==> ;; ;; #:y 'mouse
+;; ==> ;; )
+;; ==> ))))
+;; ==>
+;; ==> (define (datashare:publish-view configdat)
+;; ==> ;; (pp (hash-table->alist configdat))
+;; ==> (let* ((areas (configf:get-section configdat "areas"))
+;; ==> (label-size "70x")
+;; ==> (areas-sel (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES"))
+;; ==> (version-tb (iup:textbox #:expand "HORIZONTAL")) ;; #:size "50x"))
+;; ==> (areas-sel (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES"))
+;; ==> (component (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES" ))
+;; ==> (version-val (iup:textbox #:expand "HORIZONTAL" #:size "50x"))
+;; ==> ;; (copy-link (iup:toggle #:expand "HORIZONTAL"))
+;; ==> ;; (iteration (iup:textbox #:expand "YES" #:size "20x"))
+;; ==> ;; (iteration (iup:textbox #:expand "HORIZONTAL" #:size "20x"))
+;; ==> (area-filter (iup:textbox #:expand "HORIZONTAL" #:value "%"))
+;; ==> (comment-tb (iup:textbox #:expand "YES" #:multiline "YES"))
+;; ==> (source-tb (iup:textbox #:expand "HORIZONTAL"
+;; ==> #:value (or (configf:lookup configdat "settings" "basepath")
+;; ==> "")))
+;; ==> (publish (lambda (publish-type)
+;; ==> (let* ((area-num (or (string->number (iup:attribute areas-sel "VALUE")) 0))
+;; ==> (area-dat (if (> area-num 0)(list-ref areas (- area-num 1))'("NOT SELECTED" "NOT SELECTED")))
+;; ==> (area-path (cadr area-dat))
+;; ==> (area-name (car area-dat))
+;; ==> (version (iup:attribute version-tb "VALUE"))
+;; ==> (comment (iup:attribute comment-tb "VALUE"))
+;; ==> (spath (iup:attribute source-tb "VALUE"))
+;; ==> (submitter (current-user-name))
+;; ==> (quality 2))
+;; ==> (datashare:publish configdat publish-type area-name version comment spath submitter quality))))
+;; ==> (copy (iup:button "Copy and Publish"
+;; ==> #:expand "HORIZONTAL"
+;; ==> #:action (lambda (obj)
+;; ==> (publish 'copy))))
+;; ==> (link (iup:button "Link and Publish"
+;; ==> #:expand "HORIZONTAL"
+;; ==> #:action (lambda (obj)
+;; ==> (publish 'link))))
+;; ==> (browse-btn (iup:button "Browse"
+;; ==> #:size "40x"
+;; ==> #:action (lambda (obj)
+;; ==> (let* ((fd (iup:file-dialog #:dialogtype "DIR"))
+;; ==> (top (iup:show fd #:modal? "YES")))
+;; ==> (iup:attribute-set! source-tb "VALUE"
+;; ==> (iup:attribute fd "VALUE"))
+;; ==> (iup:destroy! fd))))))
+;; ==> (print "areas")
+;; ==> ;; (pp areas)
+;; ==> (fold (lambda (areadat num)
+;; ==> ;; (print "Adding num=" num ", areadat=" areadat)
+;; ==> (iup:attribute-set! areas-sel (conc num) (car areadat))
+;; ==> (+ 1 num))
+;; ==> 1 areas)
+;; ==> (iup:vbox
+;; ==> (iup:hbox (iup:label "Area:" #:size label-size) ;; area-filter
+;; ==> areas-sel)
+;; ==> (iup:hbox (iup:label "Version:" #:size label-size) version-tb)
+;; ==> ;; (iup:hbox (iup:label "Link only" #:size label-size) copy-link)
+;; ==> ;; (iup:label "Iteration:") iteration)
+;; ==> (iup:hbox (iup:label "Comment:" #:size label-size) comment-tb)
+;; ==> (iup:hbox (iup:label "Source base path:" #:size label-size) source-tb browse-btn)
+;; ==> (iup:hbox copy link))))
+;; ==>
+;; ==> (define (datashare:lst->path pathlst)
+;; ==> (conc "/" (string-intersperse (map conc pathlst) "/")))
+;; ==>
+;; ==> (define (datashare:path->lst path)
+;; ==> (string-split path "/"))
+;; ==>
+;; ==> (define (datashare:pathdat-apply-heuristics configdat path)
+;; ==> (cond
+;; ==> ((common:file-exists? path) "found")
+;; ==> (else (conc path " not installed"))))
+;; ==>
+;; ==> (define (datashare:get-view configdat)
+;; ==> (iup:vbox
+;; ==> (iup:hbox
+;; ==> (let* ((label-size "60x")
+;; ==> ;; filter elements
+;; ==> (area-filter "%")
+;; ==> (version-filter "%")
+;; ==> (iter-filter ">= 0")
+;; ==> ;; reverse lookup from path to data for src and installed
+;; ==> (srcdat (make-hash-table)) ;; reverse lookup
+;; ==> (installed-dat (make-hash-table))
+;; ==> ;; config values
+;; ==> (basepath (configf:lookup configdat "settings" "basepath"))
+;; ==> ;; gui elements
+;; ==> (submitter (iup:label "" #:expand "HORIZONTAL"))
+;; ==> (date-submitted (iup:label "" #:expand "HORIZONTAL"))
+;; ==> (comment (iup:label "" #:expand "HORIZONTAL"))
+;; ==> (copy-link (iup:label "" #:expand "HORIZONTAL"))
+;; ==> (quality (iup:label "" #:expand "HORIZONTAL"))
+;; ==> (installed-status (iup:label "" #:expand "HORIZONTAL"))
+;; ==> ;; misc
+;; ==> (curr-record #f)
+;; ==> ;; (source-data (iup:label "" #:expand "HORIZONTAL"))
+;; ==> (tb (iup:treebox
+;; ==> #:value 0
+;; ==> #:name "Packages"
+;; ==> #:expand "YES"
+;; ==> #:addexpanded "NO"
+;; ==> #:selection-cb
+;; ==> (lambda (obj id state)
+;; ==> ;; (print "obj: " obj ", id: " id ", state: " state)
+;; ==> (let* ((path (datashare:lst->path (cdr (tree:node->path obj id))))
+;; ==> (record (hash-table-ref/default srcdat path #f)))
+;; ==> (if record
+;; ==> (begin
+;; ==> (set! curr-record record)
+;; ==> (iup:attribute-set! submitter "TITLE" (datashare:pkg-get-submitter record))
+;; ==> (iup:attribute-set! date-submitted "TITLE" (time->string (seconds->local-time (datashare:pkg-get-datetime record))))
+;; ==> (iup:attribute-set! comment "TITLE" (datashare:pkg-get-comment record))
+;; ==> (iup:attribute-set! quality "TITLE" (datashare:pkg-get-quality record))
+;; ==> (iup:attribute-set! copy-link "TITLE" (datashare:pkg-get-store_type record))
+;; ==> ))
+;; ==> ;; (print "id=" id " path=" path " record=" record);; (tree:node->path obj id) " run-id: " run-id)
+;; ==> ))))
+;; ==> (tb2 (iup:treebox
+;; ==> #:value 0
+;; ==> #:name "Installed"
+;; ==> #:expand "YES"
+;; ==> #:addexpanded "NO"
+;; ==> #:selection-cb
+;; ==> (lambda (obj id state)
+;; ==> ;; (print "obj: " obj ", id: " id ", state: " state)
+;; ==> (let* ((path (datashare:lst->path (cdr (tree:node->path obj id))))
+;; ==> (status (hash-table-ref/default installed-dat path #f)))
+;; ==> (iup:attribute-set! installed-status "TITLE" (if status status ""))
+;; ==> ))))
+;; ==> (refresh (lambda (obj)
+;; ==> (let* ((db (datashare:open-db configdat))
+;; ==> (areas (or (configf:get-section configdat "areas") '())))
+;; ==> ;;
+;; ==> ;; first update the Sources
+;; ==> ;;
+;; ==> (for-each
+;; ==> (lambda (pkgitem)
+;; ==> (let* ((pkg-path (list (datashare:pkg-get-area pkgitem)
+;; ==> (datashare:pkg-get-version_name pkgitem)
+;; ==> (datashare:pkg-get-iteration pkgitem)))
+;; ==> (pkg-id (datashare:pkg-get-id pkgitem))
+;; ==> (path (datashare:lst->path pkg-path)))
+;; ==> ;; (print "tree:add-node tb=" tb ", pkg-path=" pkg-path ", pkg-id=" pkg-id)
+;; ==> (if (not (hash-table-ref/default srcdat path #f))
+;; ==> (tree:add-node tb "Packages" pkg-path userdata: (conc "pkg-id: " pkg-id)))
+;; ==> ;; (print "path=" path " pkgitem=" pkgitem)
+;; ==> (hash-table-set! srcdat path pkgitem)))
+;; ==> (datashare:get-pkgs db area-filter version-filter iter-filter))
+;; ==> ;;
+;; ==> ;; then update the installed
+;; ==> ;;
+;; ==> (for-each
+;; ==> (lambda (area)
+;; ==> (let* ((path (conc "/" (cadr area)))
+;; ==> (fullpath (conc basepath path)))
+;; ==> (if (not (hash-table-ref/default installed-dat path #f))
+;; ==> (tree:add-node tb2 "Installed" (datashare:path->lst path)))
+;; ==> (hash-table-set! installed-dat path (datashare:pathdat-apply-heuristics configdat fullpath))))
+;; ==> areas)
+;; ==> (sqlite3:finalize! db))))
+;; ==> (apply (iup:button "Apply"
+;; ==> #:action
+;; ==> (lambda (obj)
+;; ==> (if curr-record
+;; ==> (let* ((area (datashare:pkg-get-area curr-record))
+;; ==> (stored-path (datashare:pkg-get-stored_path curr-record))
+;; ==> (source-type (datashare:pkg-get-store_type curr-record))
+;; ==> (source-path (case source-type ;; (equal? source-type "link"))
+;; ==> ((link)(datashare:pkg-get-source-path curr-record))
+;; ==> ((copy)stored-path)
+;; ==> (else #f)))
+;; ==> (dest-stub (configf:lookup configdat "areas" area))
+;; ==> (target-path (conc basepath "/" dest-stub)))
+;; ==> (datashare:build-dir-make-link stored-path target-path)
+;; ==> (print "Creating link from " stored-path " to " target-path)))))))
+;; ==> (iup:vbox
+;; ==> (iup:hbox tb tb2)
+;; ==> (iup:frame
+;; ==> #:title "Source Info"
+;; ==> (iup:vbox
+;; ==> (iup:hbox (iup:button "Refresh" #:action refresh) apply)
+;; ==> (iup:hbox (iup:label "Submitter: ") ;; #:size label-size)
+;; ==> submitter
+;; ==> (iup:label "Submitted on: ") ;; #:size label-size)
+;; ==> date-submitted)
+;; ==> (iup:hbox (iup:label "Data stored: ")
+;; ==> copy-link
+;; ==> (iup:label "Quality: ")
+;; ==> quality)
+;; ==> (iup:hbox (iup:label "Comment: ")
+;; ==> comment)))
+;; ==> (iup:frame
+;; ==> #:title "Installed Info"
+;; ==> (iup:vbox
+;; ==> (iup:hbox (iup:label "Installed status/path: ") installed-status)))
+;; ==> )))))
+;; ==>
+;; ==> (define (datashare:manage-view configdat)
+;; ==> (iup:vbox
+;; ==> (iup:hbox
+;; ==> (iup:button "Pushme"
+;; ==> #:expand "YES"
+;; ==> ))))
+;; ==>
+;; ==> (define (datashare:gui configdat)
+;; ==> (iup:show
+;; ==> (iup:dialog
+;; ==> #:title (conc "DataShare dashboard " (current-user-name) ":" (current-directory))
+;; ==> #:menu (datashare:main-menu)
+;; ==> (let* ((tabs (iup:tabs
+;; ==> #:tabchangepos-cb (lambda (obj curr prev)
+;; ==> (set! *datashare:current-tab-number* curr))
+;; ==> (datashare:publish-view configdat)
+;; ==> (datashare:get-view configdat)
+;; ==> (datashare:manage-view configdat)
+;; ==> )))
+;; ==> ;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c)))
+;; ==> (iup:attribute-set! tabs "TABTITLE0" "Publish")
+;; ==> (iup:attribute-set! tabs "TABTITLE1" "Get")
+;; ==> (iup:attribute-set! tabs "TABTITLE2" "Manage")
+;; ==> ;; (iup:attribute-set! tabs "BGCOLOR" "190 190 190")
+;; ==> tabs)))
+;; ==> (iup:main-loop))
+;; ==>
+;; ==> ;;======================================================================
+;; ==> ;; MISC
+;; ==> ;;======================================================================
+;; ==>
+;; ==>
+;; ==> (define (datashare:do-as-calling-user proc)
+;; ==> (let ((eid (current-effective-user-id))
+;; ==> (cid (current-user-id)))
+;; ==> (if (not (eq? eid cid)) ;; running suid
+;; ==> (set! (current-effective-user-id) cid))
+;; ==> ;; (print "running as " (current-effective-user-id))
+;; ==> (proc)
+;; ==> (if (not (eq? eid cid))
+;; ==> (set! (current-effective-user-id) eid))))
+;; ==>
+;; ==> (define (datashare:find name paths)
+;; ==> (if (null? paths)
+;; ==> #f
+;; ==> (let loop ((hed (car paths))
+;; ==> (tal (cdr paths)))
+;; ==> (if (common:file-exists? (conc hed "/" name))
+;; ==> hed
+;; ==> (if (null? tal)
+;; ==> #f
+;; ==> (loop (car tal)(cdr tal)))))))
+;; ==>
+;; ==> ;;======================================================================
+;; ==> ;; MAIN
+;; ==> ;;======================================================================
+;; ==>
+;; ==> (define (datashare:load-config exe-dir exe-name)
+;; ==> (let* ((fname (conc exe-dir "/." exe-name ".config")))
+;; ==> (ini:property-separator-patt " * *")
+;; ==> (ini:property-separator #\space)
+;; ==> (if (common:file-exists? fname)
+;; ==> ;; (ini:read-ini fname)
+;; ==> (read-config fname #f #t)
+;; ==> (make-hash-table))))
+;; ==>
+;; ==> (define (datashare:process-action configdat action . args)
+;; ==> (case (string->symbol action)
+;; ==> ((get)
+;; ==> (if (< (length args) 2)
+;; ==> (begin
+;; ==> (print "ERROR: Missing arguments; " (string-intersperse args ", "))
+;; ==> (exit 1))
+;; ==> (let* ((basepath (configf:lookup configdat "settings" "basepath"))
+;; ==> (db (datashare:open-db configdat))
+;; ==> (area (car args))
+;; ==> (version (cadr args)) ;; iteration
+;; ==> (remargs (args:get-args args '("-i") '() args:arg-hash 0))
+;; ==> (iteration (if (args:get-arg "-i")(string->number (args:get-arg "-i")) #f))
+;; ==> (curr-record (datashare:get-pkg db area version iteration: iteration)))
+;; ==> (if (not curr-record)
+;; ==> (begin
+;; ==> (print "ERROR: No matching record found; area=" area ", version=" version ", iteration=" (if iteration iteration "(max)"))
+;; ==> (exit 1))
+;; ==> (let* ((stored-path (datashare:pkg-get-stored_path curr-record))
+;; ==> (source-type (datashare:pkg-get-store_type curr-record))
+;; ==> (source-path (case source-type ;; (equal? source-type "link"))
+;; ==> ((link) (datashare:pkg-get-source-path curr-record))
+;; ==> ((copy) stored-path)
+;; ==> (else #f)))
+;; ==> (dest-stub (configf:lookup configdat "areas" area))
+;; ==> (target-path (conc basepath "/" dest-stub)))
+;; ==> (datashare:build-dir-make-link stored-path target-path)
+;; ==> (datashare:record-pkg-ref db (datashare:pkg-get-id curr-record) target-path)
+;; ==> (sqlite3:finalize! db)
+;; ==> (print "Creating link from " stored-path " to " target-path))))))
+;; ==> ((publish)
+;; ==> (if (< (length args) 3)
+;; ==> (begin
+;; ==> (print "ERROR: Missing arguments; " (string-intersperse args ", "))
+;; ==> (exit 1))
+;; ==> (let* ((srcpath (list-ref args 0))
+;; ==> (areaname (list-ref args 1))
+;; ==> (version (list-ref args 2))
+;; ==> (remargs (args:get-args (drop args 2)
+;; ==> '("-type" ;; link or copy (default is copy)
+;; ==> "-m")
+;; ==> '()
+;; ==> args:arg-hash
+;; ==> 0))
+;; ==> (publish-type (if (equal? (args:get-arg "-type") "link") 'link 'copy))
+;; ==> (comment (or (args:get-arg "-m") ""))
+;; ==> (submitter (current-user-name))
+;; ==> (quality (args:get-arg "-quality"))
+;; ==> (publish-res (datashare:publish configdat publish-type areaname version comment srcpath submitter quality)))
+;; ==> (if (not (car publish-res))
+;; ==> (begin
+;; ==> (print "ERROR: " (cdr publish-res))
+;; ==> (exit 1))))))
+;; ==> ((list-versions)
+;; ==> (let ((area-name (car args)) ;; version patt full print
+;; ==> (remargs (args:get-args args '("-vpatt") '("-full") args:arg-hash 0))
+;; ==> (db (datashare:open-db configdat))
+;; ==> (versions (datashare:get-versions-for-area db (car args) version-patt: (args:get-arg "-vpatt"))))
+;; ==> ;; (print "area-name=" area-name " args=" args " *args-hash*=" (hash-table->alist *args-hash*))
+;; ==> (map (lambda (x)
+;; ==> (if (args:get-arg "-full")
+;; ==> (format #t
+;; ==> "~10a~10a~4a~27a~30a\n"
+;; ==> (vector-ref x 0)
+;; ==> (vector-ref x 1)
+;; ==> (vector-ref x 2)
+;; ==> (conc "\"" (time->string (seconds->local-time (vector-ref x 3))) "\"")
+;; ==> (conc "\"" (vector-ref x 4) "\""))
+;; ==> (print (vector-ref x 0))))
+;; ==> versions)
+;; ==> (sqlite3:finalize! db)))))
+;; ==>
+;; ==> ;; ease debugging by loading ~/.dashboardrc - REMOVE FROM PRODUCTION!
+;; ==> (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.datasharerc")))
+;; ==> (if (common:file-exists? debugcontrolf)
+;; ==> (load debugcontrolf)))
+;; ==>
+;; ==> (define (main)
+;; ==> (let* ((args (argv))
+;; ==> (prog (car args))
+;; ==> (rema (cdr args))
+;; ==> (exe-name (pathname-file (car (argv))))
+;; ==> (exe-dir (or (pathname-directory prog)
+;; ==> (datashare:find exe-name (string-split (get-environment-variable "PATH") ":"))))
+;; ==> (configdat (datashare:load-config exe-dir exe-name)))
+;; ==> (cond
+;; ==> ;; one-word commands
+;; ==> ((eq? (length rema) 1)
+;; ==> (case (string->symbol (car rema))
+;; ==> ((help -h -help --h --help)
+;; ==> (print datashare:help))
+;; ==> ((list-areas)
+;; ==> (map print (datashare:get-areas configdat)))
+;; ==> (else
+;; ==> (print "ERROR: Unrecognised command. Try \"datashare help\""))))
+;; ==> ;; multi-word commands
+;; ==> ((null? rema)(datashare:gui configdat))
+;; ==> ((>= (length rema) 2)
+;; ==> (apply datashare:process-action configdat (car rema)(cdr rema)))
+;; ==> (else (print "ERROR: Unrecognised command. Try \"datashare help\"")))))
+;; ==>
+;; ==> (main)
ADDED sauth/sharedat.scm
Index: sauth/sharedat.scm
==================================================================
--- /dev/null
+++ sauth/sharedat.scm
@@ -0,0 +1,517 @@
+
+;; Copyright 2006-2013, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see .
+
+
+(use defstruct)
+
+;; (use ssax)
+;; (use sxml-serializer)
+;; (use sxml-modifications)
+;; (use regex)
+;; (use srfi-69)
+;; (use regex-case)
+;; (use posix)
+;; (use json)
+;; (use csv)
+(use srfi-18)
+(use format)
+
+(require-library ini-file)
+(import (prefix ini-file ini:))
+
+(use sql-de-lite srfi-1 posix regex regex-case srfi-69)
+;; (import (prefix sqlite3 sqlite3:))
+;;
+(declare (uses configf))
+;; (declare (uses tree))
+(declare (uses margs))
+;; (declare (uses dcommon))
+;; (declare (uses launch))
+;; (declare (uses gutils))
+;; (declare (uses db))
+;; (declare (uses synchash))
+;; (declare (uses server))
+(declare (uses megatest-version))
+;; (declare (uses tbd))
+
+(include "megatest-fossil-hash.scm")
+
+;;
+;; GLOBALS
+;;
+(define *spublish:current-tab-number* 0)
+(define *args-hash* (make-hash-table))
+(define spublish:help (conc "Usage: spublish [action [params ...]]
+
+ ls : list contents of target area
+ cp|publish : copy file to target area
+ mkdir : makes directory in target area
+ rm : remove file from target area
+ ln : creates a symlink
+ log :
+
+ options:
+
+ -m \"message\" : describe what was done
+
+Part of the Megatest tool suite.
+Learn more at http://www.kiatoa.com/fossils/megatest
+
+Version: " megatest-fossil-hash)) ;; "
+
+;;======================================================================
+;; RECORDS
+;;======================================================================
+
+;;======================================================================
+;; DB
+;;======================================================================
+
+(define (spublish:initialize-db db)
+ (for-each
+ (lambda (qry)
+ (exec (sql db qry)))
+ (list
+ "CREATE TABLE IF NOT EXISTS actions
+ (id INTEGER PRIMARY KEY,
+ action TEXT NOT NULL,
+ submitter TEXT NOT NULL,
+ datetime TIMESTAMP DEFAULT (strftime('%s','now')),
+ srcpath TEXT NOT NULL,
+ comment TEXT DEFAULT '' NOT NULL,
+ state TEXT DEFAULT 'new');"
+ )))
+
+(define (spublish:register-action db action submitter source-path comment)
+ (exec (sql db "INSERT INTO actions (action,submitter,srcpath,comment)
+ VALUES(?,?,?,?)")
+ action
+ submitter
+ source-path
+ comment))
+
+;; (call-with-database
+;; (lambda (db)
+;; (set-busy-handler! db (busy-timeout 10000)) ; 10 second timeout
+;; ...))
+
+;; Create the sqlite db
+(define (spublish:db-do configdat proc)
+ (let ((path (configf:lookup configdat "database" "location")))
+ (if (not path)
+ (begin
+ (print "[database]\nlocation /some/path\n\n Is missing from the config file!")
+ (exit 1)))
+ (if (and path
+ (directory? path)
+ (file-read-access? path))
+ (let* ((dbpath (conc path "/spublish.db"))
+ (writeable (file-write-access? dbpath))
+ (dbexists (file-exists? dbpath)))
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print 2 *default-log-port* "ERROR: problem accessing db " dbpath
+ ((condition-property-accessor 'exn 'message) exn))
+ (exit 1))
+ (call-with-database
+ dbpath
+ (lambda (db)
+ ;; (print "calling proc " proc " on db " db)
+ (set-busy-handler! db (busy-timeout 10000)) ;; 10 sec timeout
+ (if (not dbexists)(spublish:initialize-db db))
+ (proc db)))))
+ (print "ERROR: invalid path for storing database: " path))))
+
+;; copy in file to dest, validation is done BEFORE calling this
+;;
+(define (spublish:cp configdat submitter source-path target-dir targ-file dest-dir comment)
+ (let ((dest-dir-path (conc target-dir "/" dest-dir))
+ (targ-path (conc target-dir "/" dest-dir "/" targ-file)))
+ (if (file-exists? targ-path)
+ (begin
+ (print "ERROR: target file already exists, remove it before re-publishing")
+ (exit 1)))
+ (if (not(file-exists? dest-dir-path))
+ (begin
+ (print "ERROR: target directory " target-dir " does not exists." )
+ (exit 1)))
+
+ (spublish:db-do
+ configdat
+ (lambda (db)
+ (spublish:register-action db "cp" submitter source-path comment)))
+ (let* (;; (target-path (configf:lookup "settings" "target-path"))
+ (th1 (make-thread
+ (lambda ()
+ (file-copy source-path targ-path #t))
+ (print " ... file " targ-path " copied to" targ-path)
+ ;; (let ((pid (process-run "cp" (list source-path target-dir))))
+ ;; (process-wait pid)))
+ "copy thread"))
+ (th2 (make-thread
+ (lambda ()
+ (let loop ()
+ (thread-sleep! 15)
+ (display ".")
+ (flush-output)
+ (loop)))
+ "action is happening thread")))
+ (thread-start! th1)
+ (thread-start! th2)
+ (thread-join! th1))
+ (cons #t "Successfully saved data")))
+
+(define (spublish:validate target-dir targ-mk)
+ (let* ((normal-path (normalize-pathname targ-mk))
+ (targ-path (conc target-dir "/" normal-path)))
+ (if (string-contains normal-path "..")
+ (begin
+ (print "ERROR: Path " targ-mk " resolved outside target area " target-dir )
+ (exit 1)))
+
+ (if (not (string-contains targ-path target-dir))
+ (begin
+ (print "ERROR: You cannot update data outside " target-dir ".")
+ (exit 1)))
+ (print "Path " targ-mk " is valid.")
+ ))
+;; make directory in dest
+;;
+
+(define (spublish:mkdir configdat submitter target-dir targ-mk comment)
+ (let ((targ-path (conc target-dir "/" targ-mk)))
+
+ (if (file-exists? targ-path)
+ (begin
+ (print "ERROR: target Directory " targ-path " already exist!!")
+ (exit 1)))
+ (spublish:db-do
+ configdat
+ (lambda (db)
+ (spublish:register-action db "mkdir" submitter targ-mk comment)))
+ (let* ((th1 (make-thread
+ (lambda ()
+ (create-directory targ-path #t)
+ (print " ... dir " targ-path " created"))
+ "mkdir thread"))
+ (th2 (make-thread
+ (lambda ()
+ (let loop ()
+ (thread-sleep! 15)
+ (display ".")
+ (flush-output)
+ (loop)))
+ "action is happening thread")))
+ (thread-start! th1)
+ (thread-start! th2)
+ (thread-join! th1))
+ (cons #t "Successfully saved data")))
+
+;; create a symlink in dest
+;;
+(define (spublish:ln configdat submitter target-dir targ-link link-name comment)
+ (let ((targ-path (conc target-dir "/" link-name)))
+ (if (file-exists? targ-path)
+ (begin
+ (print "ERROR: target file " targ-path " already exist!!")
+ (exit 1)))
+ (if (not (file-exists? targ-link ))
+ (begin
+ (print "ERROR: target file " targ-link " does not exist!!")
+ (exit 1)))
+
+ (spublish:db-do
+ configdat
+ (lambda (db)
+ (spublish:register-action db "ln" submitter link-name comment)))
+ (let* ((th1 (make-thread
+ (lambda ()
+ (create-symbolic-link targ-link targ-path )
+ (print " ... link " targ-path " created"))
+ "symlink thread"))
+ (th2 (make-thread
+ (lambda ()
+ (let loop ()
+ (thread-sleep! 15)
+ (display ".")
+ (flush-output)
+ (loop)))
+ "action is happening thread")))
+ (thread-start! th1)
+ (thread-start! th2)
+ (thread-join! th1))
+ (cons #t "Successfully saved data")))
+
+
+;; remove copy of file in dest
+;;
+(define (spublish:rm configdat submitter target-dir targ-file comment)
+ (let ((targ-path (conc target-dir "/" targ-file)))
+ (if (not (file-exists? targ-path))
+ (begin
+ (print "ERROR: target file " targ-path " not found, nothing to remove.")
+ (exit 1)))
+ (spublish:db-do
+ configdat
+ (lambda (db)
+ (spublish:register-action db "rm" submitter targ-file comment)))
+ (let* ((th1 (make-thread
+ (lambda ()
+ (delete-file targ-path)
+ (print " ... file " targ-path " removed"))
+ "rm thread"))
+ (th2 (make-thread
+ (lambda ()
+ (let loop ()
+ (thread-sleep! 15)
+ (display ".")
+ (flush-output)
+ (loop)))
+ "action is happening thread")))
+ (thread-start! th1)
+ (thread-start! th2)
+ (thread-join! th1))
+ (cons #t "Successfully saved data")))
+
+(define (spublish:backup-move path)
+ (let* ((trashdir (conc (pathname-directory path) "/.trash"))
+ (trashfile (conc trashdir "/" (current-seconds) "-" (pathname-file path))))
+ (create-directory trashdir #t)
+ (if (directory? path)
+ (system (conc "mv " path " " trashfile))
+ (file-move path trash-file))))
+
+
+(define (spublish:lst->path pathlst)
+ (conc "/" (string-intersperse (map conc pathlst) "/")))
+
+(define (spublish:path->lst path)
+ (string-split path "/"))
+
+(define (spublish:pathdat-apply-heuristics configdat path)
+ (cond
+ ((file-exists? path) "found")
+ (else (conc path " not installed"))))
+
+;;======================================================================
+;; MISC
+;;======================================================================
+
+(define (spublish:do-as-calling-user proc)
+ (let ((eid (current-effective-user-id))
+ (cid (current-user-id)))
+ (if (not (eq? eid cid)) ;; running suid
+ (set! (current-effective-user-id) cid))
+ ;; (print "running as " (current-effective-user-id))
+ (proc)
+ (if (not (eq? eid cid))
+ (set! (current-effective-user-id) eid))))
+
+(define (spublish:find name paths)
+ (if (null? paths)
+ #f
+ (let loop ((hed (car paths))
+ (tal (cdr paths)))
+ (if (file-exists? (conc hed "/" name))
+ hed
+ (if (null? tal)
+ #f
+ (loop (car tal)(cdr tal)))))))
+
+;;======================================================================
+;; MAIN
+;;======================================================================
+
+(define (spublish:load-config exe-dir exe-name)
+ (let* ((fname (conc exe-dir "/." exe-name ".config")))
+ (ini:property-separator-patt " * *")
+ (ini:property-separator #\space)
+ (if (file-exists? fname)
+ ;; (ini:read-ini fname)
+ (read-config fname #f #t)
+ (make-hash-table))))
+
+(define (spublish:process-action configdat action . args)
+ (let* ((target-dir (configf:lookup configdat "settings" "target-dir"))
+ (user (current-user-name))
+ (allowed-users (string-split
+ (or (configf:lookup configdat "settings" "allowed-users")
+ ""))))
+ (if (not target-dir)
+ (begin
+ (print "[settings]\ntarget-dir /some/path\n\n Is MISSING from the config file!")
+ (exit)))
+ (if (null? allowed-users)
+ (begin
+ (print "[setings]\nallowed-users user1 user2 ...\n\n Is MISSING from the config file!")
+ (exit)))
+ (if (not (member user allowed-users))
+ (begin
+ (print "User \"" (current-user-name) "\" does not have access. Exiting")
+ (exit 1)))
+ (case (string->symbol action)
+ ((cp publish)
+ (if (< (length args) 2)
+ (begin
+ (print "ERROR: Missing arguments; " (string-intersperse args ", "))
+ (exit 1)))
+ (let* ((remargs (args:get-args args '("-m") '() args:arg-hash 0))
+ (dest-dir (cadr args))
+ (src-path-in (car args))
+ (src-path (with-input-from-pipe
+ (conc "readlink -f " src-path-in)
+ (lambda ()
+ (read-line))))
+ (msg (or (args:get-arg "-m") ""))
+ (targ-file (pathname-strip-directory src-path)))
+ (if (not (file-read-access? src-path))
+ (begin
+ (print "ERROR: source file not readable: " src-path)
+ (exit 1)))
+ (if (directory? src-path)
+ (begin
+ (print "ERROR: source file is a directory, this is not supported yet.")
+ (exit 1)))
+ (print "publishing " src-path-in " to " target-dir)
+ (spublish:validate target-dir dest-dir)
+ (spublish:cp configdat user src-path target-dir targ-file dest-dir msg)))
+ ((mkdir)
+ (if (< (length args) 1)
+ (begin
+ (print "ERROR: Missing arguments; " (string-intersperse args ", "))
+ (exit 1)))
+ (let* ((targ-mk (car args))
+ (msg (or (args:get-arg "-m") "")))
+ (print "attempting to create directory " targ-mk " in " target-dir)
+ (spublish:validate target-dir targ-mk)
+ (spublish:mkdir configdat user target-dir targ-mk msg)))
+
+ ((ln)
+ (if (< (length args) 2)
+ (begin
+ (print "ERROR: Missing arguments; " (string-intersperse args ", "))
+ (exit 1)))
+ (let* ((targ-link (car args))
+ (link-name (cadr args))
+ (sub-path (string-reverse (string-join (cdr (string-split (string-reverse link-name) "/")) "/")))
+ (msg (or (args:get-arg "-m") "")))
+ (if(not (equal? sub-path link-name))
+ (begin
+ (print "attempting to create directory " sub-path " in " target-dir)
+ (spublish:validate target-dir sub-path)
+
+ (spublish:mkdir configdat user target-dir sub-path msg)))
+
+ (print "attempting to create link " link-name " in " target-dir)
+ (spublish:ln configdat user target-dir targ-link link-name msg)))
+
+ ((rm)
+ (if (< (length args) 1)
+ (begin
+ (print "ERROR: Missing arguments; " (string-intersperse args ", "))
+ (exit 1)))
+ (let* ((targ-file (car args))
+ (msg (or (args:get-arg "-m") "")))
+ (print "attempting to remove " targ-file " from " target-dir)
+ (spublish:validate target-dir targ-file)
+
+ (spublish:rm configdat user target-dir targ-file msg)))
+ ((publish)
+ (if (< (length args) 3)
+ (begin
+ (print "ERROR: Missing arguments; " (string-intersperse args ", "))
+ (exit 1))
+ (let* ((srcpath (list-ref args 0))
+ (areaname (list-ref args 1))
+ (version (list-ref args 2))
+ (remargs (args:get-args (drop args 2)
+ '("-type" ;; link or copy (default is copy)
+ "-m")
+ '()
+ args:arg-hash
+ 0))
+ (publish-type (if (equal? (args:get-arg "-type") "link") 'link 'copy))
+ (comment (or (args:get-arg "-m") ""))
+ (submitter (current-user-name))
+ (quality (args:get-arg "-quality"))
+ (publish-res (spublish:publish configdat publish-type areaname version comment srcpath submitter quality)))
+ (if (not (car publish-res))
+ (begin
+ (print "ERROR: " (cdr publish-res))
+ (exit 1))))))
+ ((list-versions)
+ (let ((area-name (car args)) ;; version patt full print
+ (remargs (args:get-args args '("-vpatt") '("-full") args:arg-hash 0))
+ (db (spublish:open-db configdat))
+ (versions (spublish:get-versions-for-area db (car args) version-patt: (args:get-arg "-vpatt"))))
+ ;; (print "area-name=" area-name " args=" args " *args-hash*=" (hash-table->alist *args-hash*))
+ (map (lambda (x)
+ (if (args:get-arg "-full")
+ (format #t
+ "~10a~10a~4a~27a~30a\n"
+ (vector-ref x 0)
+ (vector-ref x 1)
+ (vector-ref x 2)
+ (conc "\"" (time->string (seconds->local-time (vector-ref x 3))) "\"")
+ (conc "\"" (vector-ref x 4) "\""))
+ (print (vector-ref x 0))))
+ versions)))
+ (else (print "Unrecognised command " action)))))
+
+;; ease debugging by loading ~/.dashboardrc - REMOVE FROM PRODUCTION!
+;; (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.spublishrc")))
+;; (if (file-exists? debugcontrolf)
+;; (load debugcontrolf)))
+
+(define (main)
+ (let* ((args (argv))
+ (prog (car args))
+ (rema (cdr args))
+ (exe-name (pathname-file (car (argv))))
+ (exe-dir (or (pathname-directory prog)
+ (spublish:find exe-name (string-split (get-environment-variable "PATH") ":"))))
+ (configdat (spublish:load-config exe-dir exe-name)))
+ (cond
+ ;; one-word commands
+ ((eq? (length rema) 1)
+ (case (string->symbol (car rema))
+ ((help -h -help --h --help)
+ (print spublish:help))
+ ((list-vars) ;; print out the ini file
+ (map print (spublish:get-areas configdat)))
+ ((ls)
+ (let ((target-dir (configf:lookup configdat "settings" "target-dir")))
+ (print "Files in " target-dir)
+ (system (conc "ls " target-dir))))
+ ((log)
+ (spublish:db-do configdat (lambda (db)
+ (print "Listing actions")
+ (query (for-each-row
+ (lambda (row)
+ (apply print (intersperse row " | "))))
+ (sql db "SELECT * FROM actions")))))
+ (else
+ (print "ERROR: Unrecognised command. Try \"spublish help\""))))
+ ;; multi-word commands
+ ((null? rema)(print spublish:help))
+ ((>= (length rema) 2)
+ (apply spublish:process-action configdat (car rema)(cdr rema)))
+ (else (print "ERROR: Unrecognised command. Try \"spublish help\"")))))
+
+(main)
Index: server.scm
==================================================================
--- server.scm
+++ server.scm
@@ -18,11 +18,10 @@
(declare (unit server))
(declare (uses common))
(declare (uses db))
-(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
(declare (uses debugprint))
(declare (uses commonmod))
(declare (uses configfmod))
(declare (uses rmtmod))
(declare (uses launch))
DELETED sharedat.scm
Index: sharedat.scm
==================================================================
--- sharedat.scm
+++ /dev/null
@@ -1,517 +0,0 @@
-
-;; Copyright 2006-2013, Matthew Welland.
-;;
-;; This file is part of Megatest.
-;;
-;; Megatest is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-;;
-;; Megatest is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with Megatest. If not, see .
-
-
-(use defstruct)
-
-;; (use ssax)
-;; (use sxml-serializer)
-;; (use sxml-modifications)
-;; (use regex)
-;; (use srfi-69)
-;; (use regex-case)
-;; (use posix)
-;; (use json)
-;; (use csv)
-(use srfi-18)
-(use format)
-
-(require-library ini-file)
-(import (prefix ini-file ini:))
-
-(use sql-de-lite srfi-1 posix regex regex-case srfi-69)
-;; (import (prefix sqlite3 sqlite3:))
-;;
-(declare (uses configf))
-;; (declare (uses tree))
-(declare (uses margs))
-;; (declare (uses dcommon))
-;; (declare (uses launch))
-;; (declare (uses gutils))
-;; (declare (uses db))
-;; (declare (uses synchash))
-;; (declare (uses server))
-(declare (uses megatest-version))
-;; (declare (uses tbd))
-
-(include "megatest-fossil-hash.scm")
-
-;;
-;; GLOBALS
-;;
-(define *spublish:current-tab-number* 0)
-(define *args-hash* (make-hash-table))
-(define spublish:help (conc "Usage: spublish [action [params ...]]
-
- ls : list contents of target area
- cp|publish : copy file to target area
- mkdir : makes directory in target area
- rm : remove file from target area
- ln : creates a symlink
- log :
-
- options:
-
- -m \"message\" : describe what was done
-
-Part of the Megatest tool suite.
-Learn more at http://www.kiatoa.com/fossils/megatest
-
-Version: " megatest-fossil-hash)) ;; "
-
-;;======================================================================
-;; RECORDS
-;;======================================================================
-
-;;======================================================================
-;; DB
-;;======================================================================
-
-(define (spublish:initialize-db db)
- (for-each
- (lambda (qry)
- (exec (sql db qry)))
- (list
- "CREATE TABLE IF NOT EXISTS actions
- (id INTEGER PRIMARY KEY,
- action TEXT NOT NULL,
- submitter TEXT NOT NULL,
- datetime TIMESTAMP DEFAULT (strftime('%s','now')),
- srcpath TEXT NOT NULL,
- comment TEXT DEFAULT '' NOT NULL,
- state TEXT DEFAULT 'new');"
- )))
-
-(define (spublish:register-action db action submitter source-path comment)
- (exec (sql db "INSERT INTO actions (action,submitter,srcpath,comment)
- VALUES(?,?,?,?)")
- action
- submitter
- source-path
- comment))
-
-;; (call-with-database
-;; (lambda (db)
-;; (set-busy-handler! db (busy-timeout 10000)) ; 10 second timeout
-;; ...))
-
-;; Create the sqlite db
-(define (spublish:db-do configdat proc)
- (let ((path (configf:lookup configdat "database" "location")))
- (if (not path)
- (begin
- (print "[database]\nlocation /some/path\n\n Is missing from the config file!")
- (exit 1)))
- (if (and path
- (directory? path)
- (file-read-access? path))
- (let* ((dbpath (conc path "/spublish.db"))
- (writeable (file-write-access? dbpath))
- (dbexists (file-exists? dbpath)))
- (handle-exceptions
- exn
- (begin
- (debug:print 2 *default-log-port* "ERROR: problem accessing db " dbpath
- ((condition-property-accessor 'exn 'message) exn))
- (exit 1))
- (call-with-database
- dbpath
- (lambda (db)
- ;; (print "calling proc " proc " on db " db)
- (set-busy-handler! db (busy-timeout 10000)) ;; 10 sec timeout
- (if (not dbexists)(spublish:initialize-db db))
- (proc db)))))
- (print "ERROR: invalid path for storing database: " path))))
-
-;; copy in file to dest, validation is done BEFORE calling this
-;;
-(define (spublish:cp configdat submitter source-path target-dir targ-file dest-dir comment)
- (let ((dest-dir-path (conc target-dir "/" dest-dir))
- (targ-path (conc target-dir "/" dest-dir "/" targ-file)))
- (if (file-exists? targ-path)
- (begin
- (print "ERROR: target file already exists, remove it before re-publishing")
- (exit 1)))
- (if (not(file-exists? dest-dir-path))
- (begin
- (print "ERROR: target directory " target-dir " does not exists." )
- (exit 1)))
-
- (spublish:db-do
- configdat
- (lambda (db)
- (spublish:register-action db "cp" submitter source-path comment)))
- (let* (;; (target-path (configf:lookup "settings" "target-path"))
- (th1 (make-thread
- (lambda ()
- (file-copy source-path targ-path #t))
- (print " ... file " targ-path " copied to" targ-path)
- ;; (let ((pid (process-run "cp" (list source-path target-dir))))
- ;; (process-wait pid)))
- "copy thread"))
- (th2 (make-thread
- (lambda ()
- (let loop ()
- (thread-sleep! 15)
- (display ".")
- (flush-output)
- (loop)))
- "action is happening thread")))
- (thread-start! th1)
- (thread-start! th2)
- (thread-join! th1))
- (cons #t "Successfully saved data")))
-
-(define (spublish:validate target-dir targ-mk)
- (let* ((normal-path (normalize-pathname targ-mk))
- (targ-path (conc target-dir "/" normal-path)))
- (if (string-contains normal-path "..")
- (begin
- (print "ERROR: Path " targ-mk " resolved outside target area " target-dir )
- (exit 1)))
-
- (if (not (string-contains targ-path target-dir))
- (begin
- (print "ERROR: You cannot update data outside " target-dir ".")
- (exit 1)))
- (print "Path " targ-mk " is valid.")
- ))
-;; make directory in dest
-;;
-
-(define (spublish:mkdir configdat submitter target-dir targ-mk comment)
- (let ((targ-path (conc target-dir "/" targ-mk)))
-
- (if (file-exists? targ-path)
- (begin
- (print "ERROR: target Directory " targ-path " already exist!!")
- (exit 1)))
- (spublish:db-do
- configdat
- (lambda (db)
- (spublish:register-action db "mkdir" submitter targ-mk comment)))
- (let* ((th1 (make-thread
- (lambda ()
- (create-directory targ-path #t)
- (print " ... dir " targ-path " created"))
- "mkdir thread"))
- (th2 (make-thread
- (lambda ()
- (let loop ()
- (thread-sleep! 15)
- (display ".")
- (flush-output)
- (loop)))
- "action is happening thread")))
- (thread-start! th1)
- (thread-start! th2)
- (thread-join! th1))
- (cons #t "Successfully saved data")))
-
-;; create a symlink in dest
-;;
-(define (spublish:ln configdat submitter target-dir targ-link link-name comment)
- (let ((targ-path (conc target-dir "/" link-name)))
- (if (file-exists? targ-path)
- (begin
- (print "ERROR: target file " targ-path " already exist!!")
- (exit 1)))
- (if (not (file-exists? targ-link ))
- (begin
- (print "ERROR: target file " targ-link " does not exist!!")
- (exit 1)))
-
- (spublish:db-do
- configdat
- (lambda (db)
- (spublish:register-action db "ln" submitter link-name comment)))
- (let* ((th1 (make-thread
- (lambda ()
- (create-symbolic-link targ-link targ-path )
- (print " ... link " targ-path " created"))
- "symlink thread"))
- (th2 (make-thread
- (lambda ()
- (let loop ()
- (thread-sleep! 15)
- (display ".")
- (flush-output)
- (loop)))
- "action is happening thread")))
- (thread-start! th1)
- (thread-start! th2)
- (thread-join! th1))
- (cons #t "Successfully saved data")))
-
-
-;; remove copy of file in dest
-;;
-(define (spublish:rm configdat submitter target-dir targ-file comment)
- (let ((targ-path (conc target-dir "/" targ-file)))
- (if (not (file-exists? targ-path))
- (begin
- (print "ERROR: target file " targ-path " not found, nothing to remove.")
- (exit 1)))
- (spublish:db-do
- configdat
- (lambda (db)
- (spublish:register-action db "rm" submitter targ-file comment)))
- (let* ((th1 (make-thread
- (lambda ()
- (delete-file targ-path)
- (print " ... file " targ-path " removed"))
- "rm thread"))
- (th2 (make-thread
- (lambda ()
- (let loop ()
- (thread-sleep! 15)
- (display ".")
- (flush-output)
- (loop)))
- "action is happening thread")))
- (thread-start! th1)
- (thread-start! th2)
- (thread-join! th1))
- (cons #t "Successfully saved data")))
-
-(define (spublish:backup-move path)
- (let* ((trashdir (conc (pathname-directory path) "/.trash"))
- (trashfile (conc trashdir "/" (current-seconds) "-" (pathname-file path))))
- (create-directory trashdir #t)
- (if (directory? path)
- (system (conc "mv " path " " trashfile))
- (file-move path trash-file))))
-
-
-(define (spublish:lst->path pathlst)
- (conc "/" (string-intersperse (map conc pathlst) "/")))
-
-(define (spublish:path->lst path)
- (string-split path "/"))
-
-(define (spublish:pathdat-apply-heuristics configdat path)
- (cond
- ((file-exists? path) "found")
- (else (conc path " not installed"))))
-
-;;======================================================================
-;; MISC
-;;======================================================================
-
-(define (spublish:do-as-calling-user proc)
- (let ((eid (current-effective-user-id))
- (cid (current-user-id)))
- (if (not (eq? eid cid)) ;; running suid
- (set! (current-effective-user-id) cid))
- ;; (print "running as " (current-effective-user-id))
- (proc)
- (if (not (eq? eid cid))
- (set! (current-effective-user-id) eid))))
-
-(define (spublish:find name paths)
- (if (null? paths)
- #f
- (let loop ((hed (car paths))
- (tal (cdr paths)))
- (if (file-exists? (conc hed "/" name))
- hed
- (if (null? tal)
- #f
- (loop (car tal)(cdr tal)))))))
-
-;;======================================================================
-;; MAIN
-;;======================================================================
-
-(define (spublish:load-config exe-dir exe-name)
- (let* ((fname (conc exe-dir "/." exe-name ".config")))
- (ini:property-separator-patt " * *")
- (ini:property-separator #\space)
- (if (file-exists? fname)
- ;; (ini:read-ini fname)
- (read-config fname #f #t)
- (make-hash-table))))
-
-(define (spublish:process-action configdat action . args)
- (let* ((target-dir (configf:lookup configdat "settings" "target-dir"))
- (user (current-user-name))
- (allowed-users (string-split
- (or (configf:lookup configdat "settings" "allowed-users")
- ""))))
- (if (not target-dir)
- (begin
- (print "[settings]\ntarget-dir /some/path\n\n Is MISSING from the config file!")
- (exit)))
- (if (null? allowed-users)
- (begin
- (print "[setings]\nallowed-users user1 user2 ...\n\n Is MISSING from the config file!")
- (exit)))
- (if (not (member user allowed-users))
- (begin
- (print "User \"" (current-user-name) "\" does not have access. Exiting")
- (exit 1)))
- (case (string->symbol action)
- ((cp publish)
- (if (< (length args) 2)
- (begin
- (print "ERROR: Missing arguments; " (string-intersperse args ", "))
- (exit 1)))
- (let* ((remargs (args:get-args args '("-m") '() args:arg-hash 0))
- (dest-dir (cadr args))
- (src-path-in (car args))
- (src-path (with-input-from-pipe
- (conc "readlink -f " src-path-in)
- (lambda ()
- (read-line))))
- (msg (or (args:get-arg "-m") ""))
- (targ-file (pathname-strip-directory src-path)))
- (if (not (file-read-access? src-path))
- (begin
- (print "ERROR: source file not readable: " src-path)
- (exit 1)))
- (if (directory? src-path)
- (begin
- (print "ERROR: source file is a directory, this is not supported yet.")
- (exit 1)))
- (print "publishing " src-path-in " to " target-dir)
- (spublish:validate target-dir dest-dir)
- (spublish:cp configdat user src-path target-dir targ-file dest-dir msg)))
- ((mkdir)
- (if (< (length args) 1)
- (begin
- (print "ERROR: Missing arguments; " (string-intersperse args ", "))
- (exit 1)))
- (let* ((targ-mk (car args))
- (msg (or (args:get-arg "-m") "")))
- (print "attempting to create directory " targ-mk " in " target-dir)
- (spublish:validate target-dir targ-mk)
- (spublish:mkdir configdat user target-dir targ-mk msg)))
-
- ((ln)
- (if (< (length args) 2)
- (begin
- (print "ERROR: Missing arguments; " (string-intersperse args ", "))
- (exit 1)))
- (let* ((targ-link (car args))
- (link-name (cadr args))
- (sub-path (string-reverse (string-join (cdr (string-split (string-reverse link-name) "/")) "/")))
- (msg (or (args:get-arg "-m") "")))
- (if(not (equal? sub-path link-name))
- (begin
- (print "attempting to create directory " sub-path " in " target-dir)
- (spublish:validate target-dir sub-path)
-
- (spublish:mkdir configdat user target-dir sub-path msg)))
-
- (print "attempting to create link " link-name " in " target-dir)
- (spublish:ln configdat user target-dir targ-link link-name msg)))
-
- ((rm)
- (if (< (length args) 1)
- (begin
- (print "ERROR: Missing arguments; " (string-intersperse args ", "))
- (exit 1)))
- (let* ((targ-file (car args))
- (msg (or (args:get-arg "-m") "")))
- (print "attempting to remove " targ-file " from " target-dir)
- (spublish:validate target-dir targ-file)
-
- (spublish:rm configdat user target-dir targ-file msg)))
- ((publish)
- (if (< (length args) 3)
- (begin
- (print "ERROR: Missing arguments; " (string-intersperse args ", "))
- (exit 1))
- (let* ((srcpath (list-ref args 0))
- (areaname (list-ref args 1))
- (version (list-ref args 2))
- (remargs (args:get-args (drop args 2)
- '("-type" ;; link or copy (default is copy)
- "-m")
- '()
- args:arg-hash
- 0))
- (publish-type (if (equal? (args:get-arg "-type") "link") 'link 'copy))
- (comment (or (args:get-arg "-m") ""))
- (submitter (current-user-name))
- (quality (args:get-arg "-quality"))
- (publish-res (spublish:publish configdat publish-type areaname version comment srcpath submitter quality)))
- (if (not (car publish-res))
- (begin
- (print "ERROR: " (cdr publish-res))
- (exit 1))))))
- ((list-versions)
- (let ((area-name (car args)) ;; version patt full print
- (remargs (args:get-args args '("-vpatt") '("-full") args:arg-hash 0))
- (db (spublish:open-db configdat))
- (versions (spublish:get-versions-for-area db (car args) version-patt: (args:get-arg "-vpatt"))))
- ;; (print "area-name=" area-name " args=" args " *args-hash*=" (hash-table->alist *args-hash*))
- (map (lambda (x)
- (if (args:get-arg "-full")
- (format #t
- "~10a~10a~4a~27a~30a\n"
- (vector-ref x 0)
- (vector-ref x 1)
- (vector-ref x 2)
- (conc "\"" (time->string (seconds->local-time (vector-ref x 3))) "\"")
- (conc "\"" (vector-ref x 4) "\""))
- (print (vector-ref x 0))))
- versions)))
- (else (print "Unrecognised command " action)))))
-
-;; ease debugging by loading ~/.dashboardrc - REMOVE FROM PRODUCTION!
-;; (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.spublishrc")))
-;; (if (file-exists? debugcontrolf)
-;; (load debugcontrolf)))
-
-(define (main)
- (let* ((args (argv))
- (prog (car args))
- (rema (cdr args))
- (exe-name (pathname-file (car (argv))))
- (exe-dir (or (pathname-directory prog)
- (spublish:find exe-name (string-split (get-environment-variable "PATH") ":"))))
- (configdat (spublish:load-config exe-dir exe-name)))
- (cond
- ;; one-word commands
- ((eq? (length rema) 1)
- (case (string->symbol (car rema))
- ((help -h -help --h --help)
- (print spublish:help))
- ((list-vars) ;; print out the ini file
- (map print (spublish:get-areas configdat)))
- ((ls)
- (let ((target-dir (configf:lookup configdat "settings" "target-dir")))
- (print "Files in " target-dir)
- (system (conc "ls " target-dir))))
- ((log)
- (spublish:db-do configdat (lambda (db)
- (print "Listing actions")
- (query (for-each-row
- (lambda (row)
- (apply print (intersperse row " | "))))
- (sql db "SELECT * FROM actions")))))
- (else
- (print "ERROR: Unrecognised command. Try \"spublish help\""))))
- ;; multi-word commands
- ((null? rema)(print spublish:help))
- ((>= (length rema) 2)
- (apply spublish:process-action configdat (car rema)(cdr rema)))
- (else (print "ERROR: Unrecognised command. Try \"spublish help\"")))))
-
-(main)
DELETED show-uncalled-procedures.scm
Index: show-uncalled-procedures.scm
==================================================================
--- show-uncalled-procedures.scm
+++ /dev/null
@@ -1,30 +0,0 @@
-;; Copyright 2006-2017, Matthew Welland.
-;;
-;; This file is part of Megatest.
-;;
-;; Megatest is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-;;
-;; Megatest is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with Megatest. If not, see .
-;;
-(include "codescanlib.scm")
-
-(define (show-danglers)
- (let* ((all-scm-files (glob "*.scm"))
- (xref (get-xref all-scm-files))
- (dangling-procs
- (map car (filter (lambda (x) (equal? 1 (length x))) xref))))
- (for-each print dangling-procs) ;; our product.
- ))
-
-(show-danglers)
-
-
DELETED tasks.scm
Index: tasks.scm
==================================================================
--- tasks.scm
+++ /dev/null
@@ -1,48 +0,0 @@
-;; Copyright 2006-2012, Matthew Welland.
-;;
-;; This file is part of Megatest.
-;;
-;; Megatest is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-;;
-;; Megatest is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with Megatest. If not, see .
-;;
-
-;; strftime('%m/%d/%Y %H:%M:%S','now','localtime')
-
-(declare (unit tasks))
-(declare (uses debugprint))
-(declare (uses dbfile))
-(declare (uses db))
-(declare (uses dbmod))
-(declare (uses rmt))
-(declare (uses rmtmod))
-(declare (uses common))
-(declare (uses pgdb))
-(declare (uses commonmod))
-(declare (uses configfmod))
-(declare (uses processmod))
-(declare (uses mtargs))
-
-(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking format)
-(import (prefix sqlite3 sqlite3:))
-
-(import commonmod
- configfmod
- processmod
- debugprint
- dbmod
- rmtmod
- (prefix mtargs args:))
-
-(import dbfile)
-;; (import pgdb) ;; pgdb is a module
-
DELETED trackback.scm
Index: trackback.scm
==================================================================
--- trackback.scm
+++ /dev/null
@@ -1,53 +0,0 @@
-;; Copyright 2006-2017, Matthew Welland.
-;;
-;; This file is part of Megatest.
-;;
-;; Megatest is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-;;
-;; Megatest is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with Megatest. If not, see .
-
-(include "codescanlib.scm")
-
-;; show call paths for named procedure
-(define (traceback-proc in-procname)
- (letrec* ((all-scm-files (glob "*.scm"))
- (xref (get-xref all-scm-files))
- (have (alist-ref (string->symbol in-procname) xref eq? #f))
- (lookup (lambda (path procname depth)
- (let* ((upcone-temp (filter (lambda (x)
- (eq? procname (car x)))
- xref))
- (upcone-temp2 (cond
- ((null? upcone-temp) '())
- (else (cdar upcone-temp))))
- (upcone (filter
- (lambda (x) (not (eq? x procname)))
- upcone-temp2))
- (uppath (cons procname path))
- (updepth (add1 depth)))
- (if (null? upcone)
- (print uppath)
- (for-each (lambda (x)
- (if (not (member procname path))
- (lookup uppath x updepth) ))
- upcone))))))
- (if have
- (lookup '() (string->symbol in-procname) 0)
- (print "no such func - "in-procname))))
-
-
-(if (eq? 1 (length (command-line-arguments)))
- (traceback-proc (car (command-line-arguments)))
- (print "Usage: trackback "))
-
-(exit 0)
-
DELETED widgets.scm
Index: widgets.scm
==================================================================
--- widgets.scm
+++ /dev/null
@@ -1,208 +0,0 @@
-;; Copyright 2006-2017, Matthew Welland.
-;;
-;; This file is part of Megatest.
-;;
-;; Megatest is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-;;
-;; Megatest is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with Megatest. If not, see .
-
-(require-library srfi-4 iup)
-(import srfi-4 iup
- ;; iup-pplot
- iup-glcanvas) ;; iup-web
-
-(define (popup dlg . args)
- (apply show dlg #:modal? 'yes args)
- (destroy! dlg))
-
-(define (properties ih)
- (popup (element-properties-dialog ih))
- 'default)
-
-(define dlg
- (dialog
- (vbox
- (hbox ; headline
- (fill)
- (frame (label " Inspect control and dialog classes "
- fontsize: 15))
- (fill)
- margin: '0x0)
-
- (label "")
- (label "Dialogs" fontsize: 12)
- (hbox
- (button "dialog"
- action: (lambda (self) (properties (dialog (vbox)))))
- (button "color-dialog"
- action: (lambda (self) (properties (color-dialog))))
- (button "file-dialog"
- action: (lambda (self) (properties (file-dialog))))
- (button "font-dialog"
- action: (lambda (self) (properties (font-dialog))))
- (button "message-dialog"
- action: (lambda (self) (properties (message-dialog))))
- (fill)
- margin: '0x0)
- (hbox
- (button "layout-dialog"
- action: (lambda (self) (properties (layout-dialog))))
- (button "element-properties-dialog"
- action: (lambda (self)
- (properties
- (element-properties-dialog (create 'user)))))
- (fill)
- margin: '0x0)
-
- (label "")
- (label "Composition widgets" fontsize: 12)
- (hbox
- (button "fill"
- action: (lambda (self) (properties (fill))))
- (button "hbox"
- action: (lambda (self) (properties (hbox))))
- (button "vbox"
- action: (lambda (self) (properties (vbox))))
- (button "zbox"
- action: (lambda (self) (properties (zbox))))
- (button "radio"
- action: (lambda (self) (properties (radio (vbox)))))
- (button "normalizer"
- action: (lambda (self) (properties (normalizer))))
- (button "cbox"
- action: (lambda (self) (properties (cbox))))
- (button "sbox"
- action: (lambda (self) (properties (sbox (vbox)))))
- (button "split"
- action: (lambda (self) (properties (split (vbox) (vbox)))))
- (fill)
- margin: '0x0)
-
- (label "")
- (label "Standard widgets" fontsize: 12)
- (hbox
- (button "button"
- action: (lambda (self) (properties (button))))
- (button "canvas"
- action: (lambda (self) (properties (canvas))))
- (button "frame"
- action: (lambda (self) (properties (frame))))
- (button "label"
- action: (lambda (self) (properties (label))))
- (button "listbox"
- action: (lambda (self) (properties (listbox))))
- (button "progress-bar"
- action: (lambda (self) (properties (progress-bar))))
- (button "spin"
- action: (lambda (self) (properties (spin))))
- (fill)
- margin: '0x0)
- (hbox
- (button "tabs"
- action: (lambda (self) (properties (tabs))))
- (button "textbox"
- action: (lambda (self) (properties (textbox))))
- (button "toggle"
- action: (lambda (self) (properties (toggle))))
- (button "treebox"
- action: (lambda (self) (properties (treebox))))
- (button "valuator"
- action: (lambda (self) (properties (valuator ""))))
- (fill)
- margin: '0x0)
-
- (label "")
- (label "Additional widgets" fontsize: 12)
- (hbox
- (button "cells"
- action: (lambda (self) (properties (cells))))
- (button "color-bar"
- action: (lambda (self) (properties (color-bar))))
- (button "color-browser"
- action: (lambda (self) (properties (color-browser))))
- (button "dial"
- action: (lambda (self) (properties (dial ""))))
- (button "matrix"
- action: (lambda (self) (properties (matrix))))
- (fill)
- margin: '0x0)
- (hbox
- #;(button "pplot"
- action: (lambda (self) (properties (pplot))))
- (button "glcanvas"
- action: (lambda (self) (properties (glcanvas))))
- ;; (button "web-browser"
- ;; action: (lambda (self) (properties (web-browser))))
- (fill)
- margin: '0x0)
-
- (label "")
- (label "Menu widgets" fontsize: 12)
- (hbox
- (button "menu"
- action: (lambda (self) (properties (menu))))
- (button "menu-item"
- action: (lambda (self) (properties (menu-item))))
- (button "menu-separator"
- action: (lambda (self) (properties (menu-separator))))
- (fill)
- margin: '0x0)
-
- (label "")
- (label "Images" fontsize: 12)
- (hbox
- (button "image/palette"
- action: (lambda (self)
- (properties
- (image/palette 1 1 (u8vector->blob (u8vector 0))))))
- (button "image/rgb"
- action: (lambda (self)
- (properties
- (image/rgb 1 1 (u8vector->blob (u8vector 0))))))
- (button "image/rgba"
- action: (lambda (self)
- (properties
- (image/rgba 1 1 (u8vector->blob (u8vector 0))))))
- (button "image/file"
- action: (lambda (self)
- (properties
- ;; same attributes as image/palette
- (image/palette 1 1 (u8vector->blob (u8vector 0))))))
- ;; needs a file in current directory
- ;(image/file "chicken.ico")))) ; ok
- ;(image/file "chicken.png")))) ; doesn't work
- (fill)
- margin: '0x0)
-
- (label "")
- (label "Other widgets" fontsize: 12)
- (hbox
- (button "clipboard"
- action: (lambda (self) (properties (clipboard))))
- (button "timer"
- action: (lambda (self) (properties (timer))))
- (button "spinbox"
- action: (lambda (self) (properties (spinbox (vbox)))))
- (fill)
- margin: '0x0)
-
- (fill)
- (button "E&xit"
- expand: 'horizontal
- action: (lambda (self) 'close))
- )
- margin: '15x15
- title: "Iup inspector"))
-
-(show dlg)
-(main-loop)
-(exit 0)