Function: proced-format

proced-format is a byte-compiled function defined in proced.el.gz.

Signature

(proced-format PROCESS-ALIST FORMAT)

Documentation

Display PROCESS-ALIST using FORMAT.

Source Code

;; Defined in /usr/src/emacs/lisp/proced.el.gz
(defun proced-format (process-alist format)
  "Display PROCESS-ALIST using FORMAT."
  (if (symbolp format)
      (setq format (cdr (assq format proced-format-alist))))

  ;; Not all systems give us all attributes.  We take `emacs-pid' as a
  ;; representative process PID.  If FORMAT contains a list of alternative
  ;; attributes, we take the first attribute that is non-nil for `emacs-pid'.
  ;; If none of the alternatives is non-nil, the attribute is ignored
  ;; in the listing.
  (let ((standard-attributes
         (car (proced-process-attributes (list (emacs-pid)))))
        new-format fmi)
    (if (and proced-tree-flag
             (assq 'ppid standard-attributes))
        (push (cons 'tree 0) standard-attributes))
    (dolist (fmt format)
      (if (symbolp fmt)
          (if (assq fmt standard-attributes)
              (push fmt new-format))
        (while (setq fmi (pop fmt))
          (when (assq fmi standard-attributes)
            (push fmi new-format)
            (setq fmt nil)))))
    (setq format (nreverse new-format)))

  (insert (make-string (length process-alist) ?\n))
  (let ((whitespace " ") (unknown "?")
        (sort-key (if (consp proced-sort) (car proced-sort) proced-sort))
        header-list grammar)
    ;; Loop over all attributes
    (while (setq grammar (assq (pop format) proced-grammar-alist))
      (let* ((key (car grammar))
             (nth2grm (nth 2 grammar))
             (fun (cond ((stringp nth2grm)
                         (lambda (arg) (format nth2grm arg)))
                        ((not nth2grm) #'identity)
                        (t nth2grm)))
             (whitespace (if format whitespace ""))
             ;; Text properties:
             ;; We use the text property `proced-key' to store in each
             ;; field the corresponding key.
             ;; Of course, the sort predicate appearing in help-echo
             ;; is only part of the story.  But it gives the main idea.
             (hprops
              (if (nth 4 grammar)
                  (let ((descend (if (eq key sort-key) proced-descend (nth 5 grammar))))
                    `(proced-key ,key mouse-face header-line-highlight
                                 help-echo ,(format proced-header-help-echo
                                                    (if descend "-" "+")
                                                    (nth 1 grammar)
                                                    (if descend "descending" "ascending"))))))
             (refiner (nth 7 grammar))
             (fprops
              (cond ((functionp (car refiner))
                     `(proced-key ,key mouse-face highlight
                                  help-echo ,(format "mouse-2, RET: %s"
                                                     (nth 1 refiner))))
                    ((consp refiner)
                     `(proced-key ,key mouse-face highlight
                                  help-echo ,(format "mouse-2, RET: refine by attribute %s %s"
                                                     (nth 1 grammar)
                                                     (mapconcat (lambda (s)
                                                                  (if s "+" "-"))
                                                                refiner ""))))))
             value)

        ;; highlight the header of the sort column
        (if (eq key sort-key)
            (setq hprops (append '(face proced-sort-header) hprops)))
        (goto-char (point-min))
        (cond ( ;; fixed width of output field
               (numberp (nth 3 grammar))
               (dolist (process process-alist)
                 (end-of-line)
                 (setq value (cdr (assq key (cdr process))))
                 (insert (if value
                             (apply #'propertize (funcall fun value) fprops)
                           (format (concat "%" (number-to-string (nth 3 grammar)) "s")
                                   unknown))
                         whitespace)
                 (forward-line))
               (push (format (concat "%" (number-to-string (nth 3 grammar)) "s")
                             (apply #'propertize (nth 1 grammar) hprops))
                     header-list))

              ( ;; last field left-justified
               (and (not format) (eq 'left (nth 3 grammar)))
               (dolist (process process-alist)
                 (end-of-line)
                 (setq value (cdr (assq key (cdr process))))
                 (insert (if value (apply #'propertize (funcall fun value) fprops)
                           unknown))
                 (forward-line))
               (push (apply #'propertize (nth 1 grammar) hprops) header-list))

              (t ;; calculated field width
               (let ((width (length (nth 1 grammar)))
                     field-list value)
                 (dolist (process process-alist)
                   (setq value (cdr (assq key (cdr process))))
                   (if value
                       (setq value (apply #'propertize (funcall fun value) fprops)
                             width (max width (length value))
                             field-list (cons value field-list))
                     (push unknown field-list)
                     (setq width (max width (length unknown)))))
                 (let ((afmt (concat "%" (if (eq 'left (nth 3 grammar)) "-" "")
                                     (number-to-string width) "s")))
                   (push (format afmt (apply #'propertize (nth 1 grammar) hprops))
                         header-list)
                   (dolist (value (nreverse field-list))
                     (end-of-line)
                     (insert (format afmt value) whitespace)
                     (forward-line))))))))

    ;; final cleanup
    (goto-char (point-min))
    (dolist (process process-alist)
      ;; We use the text property `proced-pid' to store in each line
      ;; the corresponding pid
      (put-text-property (point) (line-end-position) 'proced-pid (car process))
      (forward-line))
    ;; Set header line
    (setq proced-header-line
          (mapconcat #'identity (nreverse header-list) whitespace))
    (if (string-match "[ \t]+$" proced-header-line)
        (setq proced-header-line (substring proced-header-line 0
                                            (match-beginning 0))))
    ;; (delete-trailing-whitespace)
    (goto-char (point-min))
    (while (re-search-forward "[ \t\r]+$" nil t)
      (delete-region (match-beginning 0) (match-end 0)))))