blob: 9eda8d1753f20e96e053c110f7643885bdd13f2b (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
|
(use-modules (ice-9 ftw)
(srfi srfi-1)
((graphviz) :prefix gv.))
(define g (gv.graph "test-graph"))
(define (show g)
(gv.layout g "dot")
(let* ((filename (tmpnam)))
(gv.render g "png" filename)
(display (format #f "#<Image: ~a>~%" filename))))
(define (numeric-string< a b)
(< (string->number a) (string->number b)))
(use-modules (ice-9 pretty-print))
(define pp pretty-print)
(define processes (scandir "/proc" string->number numeric-string<))
(define (fds pid) (scandir (format #f "/proc/~a/fd" pid) string->number numeric-string<))
(define (fd-link pid fd) (catch 'system-error (lambda () (readlink (format #f "/proc/~a/fd/~a" pid fd)))
(lambda args "#f")))
(define (process-attribute pid field)
(call-with-input-file (format #f "/proc/~a/~a" pid field)
(@ (ice-9 rdelim) read-line)))
(define (process-cmd pid)
(cond ((process-attribute pid "cmdline")
(negate eof-object?) => identity)
(else (process-attribute pid "comm"))))
(use-modules (ice-9 hash-table))
(define freqs (make-hash-table))
;; (gv.setv g "nodesep" "1")
(gv.setv g "overlap" "false")
;; (gv.setv g "splines" "line")
(gv.setv g "K" "10.0")
;; (gv.setv g "sep" "+1")
;; (gv.setv g "pack" "true")
(use-modules (rnrs records syntactic))
(define-record-type proc-node
(fields (immutable name)
(mutable files)))
(define-record-type file-node
(fields (immutable name)
(mutable procs)))
(define file-nodes (make-hash-table))
(define (get-file-node proc name)
(define fn (hash-ref file-nodes name (make-file-node name '())))
(file-node-procs-set! fn (cons proc (file-node-procs fn)))
(hash-set! file-nodes name fn)
fn)
(define next-color
(let ((lst (circular-list "cyan" "red" "green" "blue" "orange" "purple" "pink" "yellow")))
(lambda () (set! lst (cdr lst)) (car lst))))
(define proc-nodes
(map (lambda (pid)
(define pn (make-proc-node (format #f "~a: ~a" pid (process-cmd pid)) '()))
(proc-node-files-set!
pn
(cond ((fds pid)
=> (lambda (lst)
(map (lambda (fd)
(define target (fd-link pid fd))
(hash-set! freqs target (1+ (hash-ref freqs target 0)))
(get-file-node pn target))
lst)))
(else '()))))
processes))
(define colored (make-hash-table))
;;; Split file nodes into those that many have open, and those that only a few have open
(define-values (popular-files loser-files)
(span (lambda (fn) (< 30 (length (file-node-procs fn))))
(map (lambda (name) (hash-ref file-nodes name))
(map car
(sort (hash-map->list cons freqs)
(lambda (a b) (> (cdr a) (cdr b))))))))
;;; This allows us to focus on the "popular" nodes, and given them a subpgrah and color each
(for-each (lambda (fn)
(define c (next-color))
(let ((sg (gv.graph g (symbol->string (gensym "graph")))))
;; (gv.setv sg "layout" "circo")
(gv.setv sg "style" "dotted")
(let ((fn-node (gv.node sg (file-node-name fn))))
(gv.setv fn-node "fillcolor" c)
(gv.setv fn-node "style" "filled")
(for-each (lambda (proc)
(define gn-node (gv.node sg (proc-node-name proc)))
(define edge (gv.edge fn-node gn-node))
(gv.setv edge "color" c)
(gv.setv gn-node "shape" "box")
)
(file-node-procs fn)))))
popular-files)
;;; Then just place the impopular nodes anywhere.
;;; Note that this fails to account for busy programs, opening ALL THE FILES!
(for-each (lambda (fn)
(let ((fn-node (gv.node g (file-node-name fn))))
(for-each (lambda (proc)
(define gn-node (gv.node g (proc-node-name proc)))
(define edge (gv.edge fn-node gn-node))
(gv.setv gn-node "shape" "box")
)
(file-node-procs fn)))
)
loser-files)
(gv.layout g "neato")
(gv.render g "dot" "out.dot")
;; (gv.render g "png" "out.png")
|
