Random Bits of Open Code

Check-in [d63085db62]
Login

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Merged changes for mtdb to trunk
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1:d63085db623480af0334580a4315dd58cb297e12
User & Date: mrwellan 2019-05-06 18:09:47
Context
2019-05-07
04:43
Resurected textcalc check-in: 9c9044594c user: matt tags: trunk
2019-05-06
18:09
Merged changes for mtdb to trunk check-in: d63085db62 user: mrwellan tags: trunk
2019-05-01
17:20
Added detailed manager level graphs with sub-users, still missing sub-manager summaries check-in: e89d9090b5 user: jmoon18 tags: trunk
2018-11-21
22:10
added new metod to get runs fom multiple areas check-in: 1d95ba842d user: pjhatwal tags: pjhatwal
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to mtutils/mtdb/mtdb.scm.

67
68
69
70
71
72
73

74
75
76
77
78
79
80
...
623
624
625
626
627
628
629













630
631
632
633
634
635
636
....
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
     sync-test-steps
     sync-test-gen-data
     init-cached-info
     
     ;; runs
     get-run-info
     get-runs-info

     insert-run
     get-run-name-from-id

     ;; tests
     get-test-info-by-id
     get-test-id
     full-name
................................................................................
   cons
   '()
   dbh   ;; 0    1       2       3      4     5      6       7        8         9         10          11         12
   "SELECT id,target,ttype_id,run_name,state,status,owner,event_time,comment,fail_count,pass_count,last_update,area_id
       FROM runs WHERE state != 'deleted' AND target LIKE ? AND run_name LIKE ? AND area_id IN (SELECT id FROM areas WHERE area_name LIKE ?)
       ORDER BY event_time DESC, id DESC LIMIT ?  OFFSET ? ;"
   target-patt run-name-patt area-patt limit offset))) ;;Note: reverse the list because we are cons'ing the data














;;======================================================================
;;  T E S T - S T E P S
;;======================================================================

(define (get-test-step-id dbh test-id stepname state)
  (dbi:get-one
................................................................................
(define (get-target-1.X adat run-id)
  (let* ((keyvals (get-key-vals-1.X adat run-id))
	 (thekey  (string-intersperse (map (lambda (x)(if (string? x) x "-na-"))
					   (vector->list keyvals))
				      "/")))
    thekey))

#;(use trace)
#;(trace with-run-db update-test get-runs-info get-test-id run-id->mtpg-run-id)
#;(trace-call-sites #t)

;;======================================================================
;; The attic
;;======================================================================


)







>







 







>
>
>
>
>
>
>
>
>
>
>
>
>







 







|
|
|







67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
...
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
....
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
     sync-test-steps
     sync-test-gen-data
     init-cached-info
     
     ;; runs
     get-run-info
     get-runs-info
     get-runs-info-multi-areas
     insert-run
     get-run-name-from-id

     ;; tests
     get-test-info-by-id
     get-test-id
     full-name
................................................................................
   cons
   '()
   dbh   ;; 0    1       2       3      4     5      6       7        8         9         10          11         12
   "SELECT id,target,ttype_id,run_name,state,status,owner,event_time,comment,fail_count,pass_count,last_update,area_id
       FROM runs WHERE state != 'deleted' AND target LIKE ? AND run_name LIKE ? AND area_id IN (SELECT id FROM areas WHERE area_name LIKE ?)
       ORDER BY event_time DESC, id DESC LIMIT ?  OFFSET ? ;"
   target-patt run-name-patt area-patt limit offset))) ;;Note: reverse the list because we are cons'ing the data

(define (get-runs-info-multi-areas dbh target-patt run-name-patt area-patt offset limit) ;; to join ttype or not?
    (let* ((areas (conc "'" (string-join area-patt "','" )"'")))
   
  (reverse (dbi:fold-row
   cons
   '()
   dbh   ;; 0    1       2       3      4     5      6       7        8         9         10          11         12
   (conc "SELECT id,target,ttype_id,run_name,state,status,owner,event_time,comment,fail_count,pass_count,last_update,area_id
       FROM runs WHERE state != 'deleted' AND target LIKE ? AND run_name LIKE ? AND area_id IN (SELECT id FROM areas WHERE area_name in (" areas "))
       ORDER BY event_time DESC, id DESC LIMIT ?  OFFSET ? ;")
   target-patt run-name-patt  limit offset)))) ;;Note: reverse the list because we are cons'ing the data


;;======================================================================
;;  T E S T - S T E P S
;;======================================================================

(define (get-test-step-id dbh test-id stepname state)
  (dbi:get-one
................................................................................
(define (get-target-1.X adat run-id)
  (let* ((keyvals (get-key-vals-1.X adat run-id))
	 (thekey  (string-intersperse (map (lambda (x)(if (string? x) x "-na-"))
					   (vector->list keyvals))
				      "/")))
    thekey))

;(use trace)
;(trace get-runs-info-multi-areas)
;(trace-call-sites #t)

;;======================================================================
;; The attic
;;======================================================================


)

Changes to utils/wiki-to-dot.scm.

1


























2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
..
34
35
36
37
38
39
40
41
42





43
44
45
46
47
48
49
50
51
52
53
54
55

56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73



74

75
76


77


78
79
80
81






82














83










84








85
86

87

















88
89
90





91
92
93
94
95
96
97
98










99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115





















(use regex srfi-13 srfi-1 posix)



























(define (fsl . params)
  (with-input-from-pipe
   (conc "fossil " (string-intersperse params " "))
   read-lines))

(define show-pages (cdr (argv)))

(define pages (let ((all (fsl "wiki list")))
		(if (null? show-pages)
		    all
		    (filter (lambda (x)
			      (member x show-pages))
			    all))))

(define max-links-per-page 10)

(print "// pages \"" (string-intersperse pages "\", \"") "\"")

(print "digraph G {")
(print "  rankdir=LR;")
(define cnum 0)
;;(define seprx "\\][^\\[]" )
(define notsqr "[^\\]\\[]")
(define seprx (regexp (conc "("
			    "\\]" notsqr "+\\[|"
			    "^" notsqr "*\\[|"
			    "\\]" notsqr "*$"
................................................................................
(define (escape-quotes inl)
  (string-substitute
   "\\]" "\\]"
   (string-substitute
    "\\[" "\\["
    (string-substitute "\"" "\\\"" inl #t))))

(for-each
 (lambda (page)





   (print " subgraph cluster_" cnum " {")
   (print "  style=filled;
  color=white;
  node [style=filled,color=lightgrey];
  label = \"" page "\";")
   (set! cnum (+ cnum 1))
   (with-input-from-pipe
    (conc "fossil wiki export " "\"" page "\"")
    (lambda ()
      (let loop ((inl (read-line))
		 (ver #f)) ;; verbatim mode?
	(if (not (eof-object? inl))
	    (let* ((ldat (string-split-fields seprx inl #:infix)))

	      (cond
	       ((and (or (string-search "<verbatim>" inl)
			 (string-search "<div " inl))         ;; force verbatim mode if we see a div - can't easily parse this page
		     (not (string-search "</verbatim>" inl))) ;; have <verbatim> without </verbatim> on same line
		(loop (read-line) #t))
	       ((string-search "</verbatim>" inl)
		(loop (read-line) #f))
	       (ver (loop (read-line) ver))
	       (else
		(if (and (string-search "\\[" inl)
			 (> (length ldat) 0))
		    (let ((link-count 0))
		      (for-each
		       (lambda (seg)
			 (if (not (string-null? seg))
			     (if (< link-count max-links-per-page)
				 (let* ((parts (string-split seg "|")))
				   (set! link-count (+ link-count 1))



				   (if (> (length parts) 1)

				       (print "   \"" page "\" -> \"" (escape-quotes (car parts))
					      "\" [label=\"" (escape-quotes (cadr parts)) "\"];")


				       (print "   \"" page "\" -> \"" (escape-quotes seg) "\";"))))))


			 ldat)))
		;; (print "ldat: \"" (string-intersperse ldat "\",\"") "\"")
		(loop (read-line) ver))))))))
   (print " }\n")






   )














 pages)



















(print "}")
	    

      

















   
;; digraph G {
;; 





;; 	subgraph cluster_0 {
;; 		style=filled;
;; 		color=lightgrey;
;; 		node [style=filled,color=white];
;; 		a0 -> a1 -> a2 -> a3;
;; 		label = "process #1";
;; 	}
;; 










;; 	subgraph cluster_1 {
;; 		node [style=filled];
;; 		b0 -> b1 -> b2 -> b3;
;; 		label = "process #2";
;; 		color=blue
;; 	}
;; 	start -> a0;
;; 	start -> b0;
;; 	a1 -> b3;
;; 	b2 -> a3;
;; 	a3 -> a0;
;; 	a3 -> end;
;; 	b3 -> end;
;; 
;; 	start [shape=Mdiamond];
;; 	end [shape=Msquare];
;; }






















>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>






|








|

<
<
<
<







 







|
|
>
>
>
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
|
|
>
>
>
|
>
|
|
>
>
|
>
>
|
<
|
|
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
|
|
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
<
<
>
>
>
>
>
|
<
<
<
<
<
<
<
>
>
>
>
>
>
>
>
>
>
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44




45
46
47
48
49
50
51
..
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98

99
100
101
102
103
104
105
106
107
108
109
110
111
112
113

114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178


179
180
181
182
183
184







185
186
187
188
189
190
191
192
193
194
195
















196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
(use regex srfi-13 srfi-1 posix)
(use (prefix margs args:))

(define help (conc
	      "
Usage: wiki-to-dot <options>
  Options:
     -ignore patt1,patt2...    : skip pages with names matching regex patterns patt1, patt2 etc.
     -only patt1,patt2...      : only show pages matchine patt1, patt2 etc.
     -o fname                  : send output to files fname.dot fname.orphans fname.bad
     -links/page N             : flag or suppress links above N
     -suppress                 : suppress links over the links/page number
     -h                        : print this help
"))
  
(define remargs (args:get-args 
                 (argv)
		 '("-ignore" ;; comma delimited list of pages to ignore
		   "-only"   ;; only show pages matching
		   "-o"      ;; set output file
		   "-links/page" ;; number of links allowed per page
		   )
		 '("-h"
		   "-suppress"   ;; suppress links over allowed amount
		   )
		 args:arg-hash
		 0))

(define (fsl . params)
  (with-input-from-pipe
   (conc "fossil " (string-intersperse params " "))
   read-lines))

(define show-pages remargs) ;; (cdr (argv)))

(define pages (let ((all (fsl "wiki list")))
		(if (null? show-pages)
		    all
		    (filter (lambda (x)
			      (member x show-pages))
			    all))))

(define max-links-per-page (string->number (or (args:get-arg "-links/page") "15")))





(define cnum 0)
;;(define seprx "\\][^\\[]" )
(define notsqr "[^\\]\\[]")
(define seprx (regexp (conc "("
			    "\\]" notsqr "+\\[|"
			    "^" notsqr "*\\[|"
			    "\\]" notsqr "*$"
................................................................................
(define (escape-quotes inl)
  (string-substitute
   "\\]" "\\]"
   (string-substitute
    "\\[" "\\["
    (string-substitute "\"" "\\\"" inl #t))))

(define bad-pages      (make-hash-table))
(define pages-no-links (make-hash-table))
(define no-links-to    (make-hash-table))

(define (make-page page)
  (let ((link-count 0)
	(lines      0))
    (print "  subgraph cluster_" cnum " {")
    (print "    style=filled;
    color=white;
    node [style=filled,color=lightgrey];
    label = \"" page "\";")
    (set! cnum (+ cnum 1))
    (with-input-from-pipe
     (conc "fossil wiki export " "\"" page "\"")
     (lambda ()
       (let loop ((inl (read-line))
		  (ver #f)) ;; verbatim mode?
	 (if (not (eof-object? inl))
	     (let* ((ldat (string-split-fields seprx inl #:infix)))
	       (set! lines (+ lines 1))
	       (cond
		((and (or (string-search "<verbatim>" inl)
			  (string-search "<div " inl))         ;; force verbatim mode if we see a div - can't easily parse this page
		      (not (string-search "</verbatim>" inl))) ;; have <verbatim> without </verbatim> on same line
		 (loop (read-line) #t))
		((string-search "</verbatim>" inl)
		 (loop (read-line) #f))
		(ver (loop (read-line) ver))
		(else
		 (if (and (string-search "\\[" inl)
			  (> (length ldat) 0))
		     (begin ;; (let ((link-count 0))
		       (for-each
			(lambda (seg)
			  (if (not (string-null? seg))

			      (let* ((parts (string-split seg "|")))
				(set! link-count (+ link-count 1))
				(if (> link-count max-links-per-page)(hash-table-set! bad-pages page link-count))
				(if (or (< link-count max-links-per-page)
					(not (args:get-arg "-suppress")))
				    (if (> (length parts) 1)
					(let ((targ (car parts)))
					  (print "    \"" page "\" -> \"" (escape-quotes targ)
						 "\" [label=\"" (escape-quotes (cadr parts)) "\"];")
					  (if (hash-table-exists? no-links-to targ)(hash-table-delete! no-links-to targ)))
					(begin
					  (print "    \"" page "\" -> \"" (escape-quotes seg) "\";")
					  (if (hash-table-exists? no-links-to seg)(hash-table-delete! no-links-to seg))))
				    )))) ;; (+ (hash-table-ref/default bad-pages page 0) 1))))))
			ldat)))))

	       (loop (read-line) ver))))))
    (print " }\n")
    (if (> lines 1)
	link-count
	(begin
	  (if (hash-table-exists? no-links-to page) ;; empty pages are deleted, don't expect to have links to them
	      (hash-table-delete! no-links-to page))
	  #f))))

(define (match-any instr patts)
  (let ((fn (lambda (patt)
	      (string-match patt instr))))
    (filter list? (map fn patts))))

(define (port-or-stdout fname ext)
  (if fname
      (open-output-file (conc fname "." ext))
      (current-output-port)))

(define (close-port-if-file port fname)
  (if fname
      (close-output-port port)))

(define (process-pages)
  (let* ((ignore-patts (map regexp (if (args:get-arg "-ignore")
				       (string-split (args:get-arg "-ignore") ",")
				       '())))
	 (only-patts   (map regexp (if (args:get-arg "-only")
				       (string-split (args:get-arg "-only") ",")
				       `(,(regexp ".*")))))
	 (fnamestem    (args:get-arg "-o"))
	 (outp         (port-or-stdout fnamestem "dot"))
	 (badp         (port-or-stdout fnamestem "bad"))
	 (orphanp      (port-or-stdout fnamestem "orphans")))
    
    ;; the page header / opening stanza
    
    (with-output-to-port outp
      (lambda ()
	(print "// pages \"" (string-intersperse pages "\", \"") "\"")
	
	(print "digraph G {")
	(print "  rankdir=LR;")
	(print "")))

    ;; the page nodes 
    
    (for-each
     (lambda (page)
       (hash-table-set! no-links-to page #t)
       (if (and (null? (match-any page ignore-patts))
		(not (null? (match-any page only-patts))))
	   (let* ((num-links 0)
		  (res       (with-output-to-string
			       (lambda ()
				 (set! num-links (make-page page))))))
	     (if num-links
		 (if (> num-links 0)
		     (with-output-to-port outp
		       (lambda ()(print res)))
		     (hash-table-set! pages-no-links page #t))
		 (print "// removed page " page)))
	   (print "// ignoring page " page)))
     pages)



    ;; print the bad pages

    (with-output-to-port badp
      (lambda ()
	(set! cnum (+ cnum))
	(print "  subgraph cluster_" cnum " { ")







	(print "     label=\"Too many links\";")
	(for-each
	 (lambda (page)
	   (print "  \"" page "=" (hash-table-ref bad-pages page) "\""))
	 (sort (hash-table-keys bad-pages) string>=?))
	(print "  }")))

    (with-output-to-port orphanp
      (lambda ()
	(set! cnum (+ cnum))
	(print " subgraph cluster_" cnum " { ")
















	(print "     label=\"No links\";")
	(for-each
	 (lambda (page)
	   (print "  \"" page " \""))
	 (sort (hash-table-keys no-links-to) string>=?))
	(print "  }")))

    (with-output-to-port outp
      (lambda ()
	(print "}")))
    
    (close-port-if-file outp fnamestem)
    (close-port-if-file badp fnamestem)
    (close-port-if-file orphanp fnamestem)
    ))

;; Limiations/to be fixed:
;;  <a href="wiki?name=pig_isoenv_core">f
;;  more than one link on a line

(process-pages)