vms-pstree.el

vms-pstree.el

Post by Thien-Thi Nguye » Wed, 02 Jul 2003 04:34:39



if you use emacs under vms, you might find vms-pstree.el useful.

thi

__________________________________________________________
;;; vms-pstree.el --- Display VMS processes as a tree

;;; Copyright (C) 2003 Thien-Thi Nguyen <t...@gnu.org>

;; This file is released under the same license as GNU Emacs.

;; GNU Emacs 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 2, or (at your option)
;; any later version.

;; GNU Emacs 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 GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Commentary:

;; VMS processes can be listed w/ the "SHOW USER/FULL" command, and now
;; visualized in a tree form to show relationships between a process and
;; its parent (if any), with vms-pstree.el.  This was written to help me
;; decide whether or not the Emacs 21.x port to OpenVMS 7.3-1 should be
;; changed to actually implement "proper" subprocesses.  OK, I confess:
;; it is merely a display hack that actually has no bearing on whether
;; or not subprocess support will change.  Actually^2, it does help to
;; lightly test the work-in-progress port so there is some merit besides
;; (actually^3) being another creative act of procrastination...
;;
;; In any case, the usage is relatively simple:
;;
;;      M-x vms-pstree
;;
;; Emacs asks for a user name to scan; leave empty to scan all users.
;; The output shows up in a buffer named "*vms-pstree USER*".
;;
;; There are two variables to modify the behavior of `vms-pstree':
;; `vms-pstree-show-pid' and `vms-pstree-suppress-unix-init-envy'.
;; See their respective docstrings for more info.
;;
;; Feedback welcome.

;;; Code:

(require 'cl)                           ; use the source luke!

(defvar vms-pstree-show-pid nil
  "If non-nil, `vms-pstree' also displays the PID of each process.")

(defvar vms-pstree-suppress-unix-init-envy nil
  "If non-nil, `vms-pstree' does not fake an \"init\" parent process.")

(defun vms-pstree-hash ()
  (let ((ht (make-hash-table :test 'equal))
        ;; hash data: children parent tty name
        (empty (list nil nil nil nil))
        case-fold-search)
    ;; unix envy rears its ugly head
    (unless vms-pstree-suppress-unix-init-envy
      (puthash "1" (list nil nil nil "init") ht))
    (goto-char (point-min))
    (while (re-search-forward "^ [A-Z][A-Z]+ " (point-max) t)
      (move-to-column 18)
      (let ((p (point)) name pid tty parent)
        (setq name (progn (move-to-column 32)
                          (buffer-substring p (setq p (point))))
              pid (buffer-substring p (+ 8 p)))
        (let ((snip (string-match " +$" name)))
          (when snip (setq name (substring name 0 snip))))
        (forward-char 10)
        (cond ((looking-at "[A-Z0-9]+:")
               (setq tty (buffer-substring (point) (match-end 0)))
               (unless vms-pstree-suppress-unix-init-envy
                 (setq parent "1")))
              ((looking-at ".subprocess of \\([0-9A-F]+\\)")
               (setq parent (buffer-substring (match-beginning 1)
                                              (match-end 1))))
              (t (unless vms-pstree-suppress-unix-init-envy
                   (setq parent "1"))))
        (when parent
          (puthash parent (let ((cur (gethash parent ht empty)))
                            (cons (cons pid (car cur)) (cdr cur)))
                   ht))
        (puthash pid (let ((cur (gethash pid ht empty)))
                       (list (car cur) parent tty name))
                 ht)))
    ht))

(defun vms-pstree-spew (ht pid &optional prefix cols uncp)
  ;; PREFIX is calculated by the parent when recursing.  For the first child,
  ;; it is a short connector, for subsequent children, it may contain uncle-
  ;; continuation marks (vertical bars) if UNCP is non-nil, at the columns
  ;; specified by COLS.  A number in COLS less than zero is used in offset
  ;; calculations (that is, its absolute value is used) but does not render
  ;; an uncle-continuation mark.
  (unless prefix (setq prefix ""))
  (unless cols (setq cols (list 0)))
  (let* ((data (gethash pid ht))
         (name (cadddr data))
         (kids (car data))
         (ofs (+ (abs (car cols)) (length name) 2
                 (if vms-pstree-show-pid
                     (+ 2 (length pid))
                   0))))
    (insert (format "%s%S" prefix name))
    (when vms-pstree-show-pid
      (insert (format "(%s)" pid)))
    (if (not kids)
        (insert "\n")
      (let ((last-kid (car (reverse (cdr kids))))
            (nkids (length kids)))
        (vms-pstree-spew ht
                         (car kids)
                         (if (= 1 nkids) "-----" "--+--")
                         (cons (+ 5 ofs) cols)
                         (< 1 nkids))
        (mapcar '(lambda (kid)
                   (vms-pstree-spew
                    ht kid
                    (concat (if uncp
                                (mapconcat
                                 '(lambda (f)
                                    (make-string (- f 5) 32))
                                 (let ((ls (remove-if '(lambda (x) (> 0 x))
                                                      (cons (+ 5 ofs) cols)))
                                       fill)
                                   (while (cdr ls)
                                     (setq fill (cons (- (car ls)
                                                         (cadr ls))
                                                      fill)
                                           ls (cdr ls)))
                                   fill)
                                 "  |  ")
                              (make-string ofs 32))
                            (if (equal kid last-kid)
                                "  `--"
                              "  |--"))
                    (cons (* (if (equal kid last-kid)
                                 ;; A negative column counts for offset
                                 ;; calculations but disables display of
                                 ;; uncle continuation marks there.
                                 -1
                               1)
                             (+ 5 ofs))
                          cols)
                    (not (equal kid last-kid))))
                (cdr kids))))))

(defun vms-pstree (user)
  (interactive "sUser (empty for all): ")
  (let* ((SPC-user (if (string= "" user)
                       user
                     (concat " " user)))
         (buf (get-buffer-create (concat "*vms-pstree" SPC-user "*"))))
    (switch-to-buffer buf)
    (erase-buffer)
    (subprocess-command-to-buffer (concat "SHOW USER/FULL" SPC-user) buf)
    (let ((ht (vms-pstree-hash)))
      (erase-buffer)
      (let (top)
        (maphash '(lambda (key value)
                    (unless (cadr value)
                      (setq top (cons key top))))
                 ht)
        (goto-char (point-min))
        (mapcar '(lambda (tree)
                   (vms-pstree-spew ht tree)
                   (insert "\n"))
                top)))))

(provide 'vms-pstree)

;;; vms-pstree.el ends here