224 lines
7.3 KiB
Scheme
224 lines
7.3 KiB
Scheme
;;; This file is part of the Scheme Untergrund Library.
|
|
|
|
;;; Copyright (c) 2002-2003 by Martin Gasbichler.
|
|
;;; For copyright information, see the file COPYING which comes with
|
|
;;; the distribution.
|
|
|
|
(define-record-type process-info :process-info
|
|
(really-make-process-info pid ppid logname
|
|
real-uid effective-uid saved-set-uid
|
|
real-gid effective-gid saved-set-gid
|
|
time tty executable command-line)
|
|
process-recrod?
|
|
(pid process-info-pid)
|
|
(ppid process-info-ppid)
|
|
(logname process-info-logname)
|
|
(real-uid process-info-real-uid)
|
|
(effective-uid process-info-effective-uid)
|
|
(saved-set-uid process-info-saved-set-uid)
|
|
(real-gid process-info-real-gid)
|
|
(effective-gid process-info-effective-gid)
|
|
(saved-set-gid process-info-saved-set-gid)
|
|
(time process-info-time)
|
|
(tty process-info-tty)
|
|
(executable process-info-executable)
|
|
(command-line process-info-command-line))
|
|
|
|
(define-record-discloser :process-info
|
|
(lambda (pi)
|
|
(list 'pi (process-info-pid pi) (process-info-executable pi) (process-info-logname pi))))
|
|
|
|
(define (make-process-info-with-restlist
|
|
ps-functions
|
|
pid ppid logname
|
|
real-uid effective-uid saved-set-uid
|
|
real-gid effective-gid saved-set-gid
|
|
time tty executable . command-line)
|
|
(really-make-process-info
|
|
(string->number pid) (string->number ppid) logname
|
|
(string->number real-uid) (string->number effective-uid)
|
|
(string->number saved-set-uid)
|
|
(string->number real-gid) (string->number effective-gid)
|
|
(string->number saved-set-gid)
|
|
((ps-time->seconds ps-functions) time)
|
|
tty executable command-line))
|
|
|
|
(define *os-pss* '())
|
|
|
|
(define (add-ps! ps-functions)
|
|
(set! *os-pss* (cons ps-functions *os-pss*)))
|
|
|
|
(define (pps)
|
|
(let ((os (uname:os-name (uname))))
|
|
(let lp ((os-pss *os-pss*))
|
|
(if (null? *os-pss*)
|
|
(error "ps not defined for " os)
|
|
(let ((next (car os-pss)))
|
|
(if (string=? os (ps-uname-string next))
|
|
(call-ps next)
|
|
(lp (cdr os-pss))))))))
|
|
|
|
(define (call-ps ps-functions)
|
|
(map (lambda (line)
|
|
(apply make-process-info-with-restlist
|
|
ps-functions
|
|
((ps-line-splitter ps-functions) line)))
|
|
((ps-command ps-functions))))
|
|
|
|
(define-record-type ps-functions :ps-functions
|
|
(really-make-ps-functions uname-string command time->seconds line-splitter)
|
|
ps-functions?
|
|
(uname-string ps-uname-string)
|
|
(command ps-command)
|
|
(time->seconds ps-time->seconds)
|
|
(line-splitter ps-line-splitter))
|
|
|
|
(define (make-ps-functions uname-string command time->seconds . maybe-line-splitter)
|
|
(really-make-ps-functions uname-string
|
|
command time->seconds
|
|
(if (null? maybe-line-splitter)
|
|
(sloppy-suffix-splitter)
|
|
(car maybe-line-splitter))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; FreeBSD
|
|
|
|
(define (fbsd-ps-command)
|
|
(let ((res (run/strings
|
|
(ps -axww
|
|
;; uses rgid instead of gid
|
|
"-opid,ppid,user,ruid,uid,svuid,rgid,rgid,svgid,time,tty,ucomm,command"))))
|
|
(if (null? res)
|
|
(error "ps failed")
|
|
(cdr res))))
|
|
|
|
(define fbsd-time->seconds ; hmm, what does the output look like for older processes??
|
|
(let ((short-rx (rx (: (submatch (+ digit)) #\:
|
|
(submatch (: digit digit)) #\.
|
|
(submatch (: digit digit))))))
|
|
(lambda (time)
|
|
(let ((match-data (regexp-search short-rx time)))
|
|
(if match-data
|
|
(+ (* 60 (string->number (match:substring match-data 1)))
|
|
(string->number (match:substring match-data 2))
|
|
(quotient (string->number (match:substring match-data 3)) 50))
|
|
0)))))
|
|
|
|
(define fbsd-ps (make-ps-functions "FreeBSD" fbsd-ps-command fbsd-time->seconds))
|
|
(add-ps! fbsd-ps)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Darwin
|
|
|
|
(define (darwin-ps-command)
|
|
(let ((res (run/strings
|
|
(ps -axww
|
|
;; uses rgid instead of gid
|
|
"-opid,ppid,user,ruid,uid,svuid,rgid,svgid,time,tty,ucomm,command"))))
|
|
(if (null? res)
|
|
(error "ps failed")
|
|
(cdr res))))
|
|
|
|
(define (darwin-line-splitter line)
|
|
(let ((line-as-list ((sloppy-suffix-splitter) line)))
|
|
(append (take line-as-list 7)
|
|
(list (list-ref line-as-list 7))
|
|
(drop line-as-list 7))))
|
|
|
|
(define darwin-ps (make-ps-functions "Darwin"
|
|
darwin-ps-command
|
|
fbsd-time->seconds
|
|
darwin-line-splitter))
|
|
(add-ps! darwin-ps)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Linux
|
|
(define (linux-ps-command)
|
|
(let ((res (run/strings
|
|
(ps -A ;axww
|
|
"-opid,ppid,user,ruid,uid,svuid,rgid,gid,svgid,time,tty,ucomm,command"))))
|
|
(if (null? res)
|
|
(error "ps failed")
|
|
(cdr res))))
|
|
|
|
(define linux-time->seconds ; hmm, what does the output look like for older processes??
|
|
(let ((short-rx (rx (: (submatch (+ digit)) #\:
|
|
(submatch (: digit digit)) #\:
|
|
(submatch (: digit digit))))))
|
|
(lambda (time)
|
|
(let ((match-data (regexp-search short-rx time)))
|
|
(if match-data
|
|
(+ (* 60 60 (string->number (match:substring match-data 1)))
|
|
(* 60 (string->number (match:substring match-data 2)))
|
|
(string->number (match:substring match-data 3)))
|
|
0)))))
|
|
|
|
(define linux-ps (make-ps-functions "Linux" linux-ps-command linux-time->seconds))
|
|
(add-ps! linux-ps)
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; AIX
|
|
|
|
(define (aix-ps-command)
|
|
(let ((res (run/strings
|
|
(ps -A
|
|
;; uses ruid/rgid instead of svuid/svgid
|
|
-opid -oppid -ouser -oruid -ouid -oruid -orgid -ogid -orgid -otime -otty -oucomm -oargs))))
|
|
(if (null? res)
|
|
(error "ps failed")
|
|
(cdr res))))
|
|
|
|
(define aix-time->seconds
|
|
(let ((short-rx (rx (: (? (submatch (** 1 3 digit)) #\-)
|
|
(submatch (** 1 2 digit)) #\:
|
|
(submatch (: digit digit)) #\:
|
|
(submatch (: digit digit))))))
|
|
(lambda (time)
|
|
(let ((match-data (regexp-search short-rx time)))
|
|
(if match-data
|
|
(+
|
|
(if (match:substring match-data 1)
|
|
(* 24 60 60 (string->number (match:substring match-data 1)))
|
|
0)
|
|
(* 60 60 (string->number (match:substring match-data 2)))
|
|
(* 60 (string->number (match:substring match-data 3)))
|
|
(string->number (match:substring match-data 4)))
|
|
(error "cannot parse time" time))))))
|
|
|
|
(define aix-ps (make-ps-functions "AIX" aix-ps-command aix-time->seconds))
|
|
(add-ps! aix-ps)
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Solaris
|
|
|
|
(define (solaris-ps-command)
|
|
(let ((res (run/strings
|
|
(ps -A
|
|
;; uses ruid/rgid instead of svuid/svgid
|
|
-opid -oppid -ouser -oruid -ouid -oruid -orgid -ogid -orgid -otime -otty -ocomm -oargs))))
|
|
(if (null? res)
|
|
(error "ps failed")
|
|
(cdr res))))
|
|
|
|
(define solaris-time->seconds
|
|
(let ((short-rx (rx (: (? (submatch (** 1 3 digit)) #\-)
|
|
(? (submatch (** 1 2 digit)) #\:)
|
|
(submatch (** 1 2 digit)) #\:
|
|
(submatch (: digit digit))))))
|
|
(lambda (time)
|
|
(let ((match-data (regexp-search short-rx time)))
|
|
(if match-data
|
|
(+
|
|
(if (match:substring match-data 1)
|
|
(* 24 60 60 (string->number (match:substring match-data 1)))
|
|
0)
|
|
(if (match:substring match-data 2)
|
|
(* 60 60 (string->number (match:substring match-data 2)))
|
|
0)
|
|
(* 60 (string->number (match:substring match-data 3)))
|
|
(string->number (match:substring match-data 4)))
|
|
(error "cannot parse time" time))))))
|
|
|
|
(define solaris-ps (make-ps-functions "SunOS" solaris-ps-command solaris-time->seconds))
|
|
(add-ps! solaris-ps)
|