Portable ps
This commit is contained in:
Martin Gasbichler
parent
d805699156
commit
4f88768976
|
|
@ -0,0 +1,223 @@
|
|||
;;; 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)
|
||||
Loading…
Reference in New Issue