;; 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 <http://www.gnu.org/licenses/>.
;;
(module whodunit
*
(import scheme chicken data-structures extras)
(use posix srfi-69)
(define *numsamples* (or (and (> (length (argv)) 1)
(string->number (cadr (argv))))
3))
(define (topdata)
(with-input-from-pipe
(conc "top -b -n " *numsamples* " -d 0.1")
read-lines))
(define (cleanup-data topdat)
(let loop ((hed (car topdat))
(tal (cdr topdat))
(res '()))
(let* ((line-list (string-split hed))
(nums (map (lambda (indat)(or (string->number indat) indat)) line-list))
(not-data (or (null? nums)
(not (number? (car nums)))))
(new-res (if not-data res (cons nums res))))
(if (null? tal)
new-res
(loop (car tal)(cdr tal) new-res)))))
;; sum up
(define (sum-up data ht)
(for-each
(lambda (indat)
(let ((pid (car indat))
(usr (cadr indat))
(cpu (list-ref indat 8)))
(hash-table-set! ht usr (+ cpu (hash-table-ref/default ht usr 0)))))
data))
)
(import whodunit)
(print "Getting " *numsamples* " samples of cpu usage data.")
(define data (cleanup-data (topdata)))
(define pidhash (make-hash-table))
(define userhash (make-hash-table))
(sum-up data userhash)
(for-each
(lambda (usr)
(let* ((usage (inexact->exact (round (/ (hash-table-ref userhash usr) *numsamples*)))))
(if (> usage 0)
(print usr (if (< (string-length usr) 8) "\t\t" "\t") usage))))
(sort (hash-table-keys userhash)
(lambda (a b)
(> (hash-table-ref userhash a)
(hash-table-ref userhash b)))))